`(progn (putprop ,atm ,arg ,prp) ,atm))
(cadr x) (caddr x) (cadddr x))))
; register allocation and important addresses for compiled code
(setq np-reg 'r6 ;points one beyond top stack value
lbot-reg 'r7 ;current value of lbot
ln-reg 'r8 ;address of linker
olbot-reg 'r10 ;base of args to this fcn
bnp-val '"*-32(r8)" ;value of global var bnp
i-mov 'movl ;stacking instruction for namestack
i-clr 'clrl ;clear namestack
qfuncl '"*-28(r8)" ;addr of qfuncl
; these are the short cut places to call when you want to call
; a non system function with 4 or less arguments
(setplist 'qfs '(0 "*-8(r8)" 1 "*-12(r8)" 2 "*-16(r8)"
3 "*-20(r8)" 4 "*-24(r8)"))
(declare (special w-vars w-labs w-ret w-name w-bv w-atmt cm-alv v-cnt))
(cond ((lessp (opval 'pagelimit) 2000) (opval 'pagelimit 2000)))
(setq e (gensym (cond (x) (t 'L))))
(setq twa-list (cons e twa-list))
(setq l (quotient a 2704))
(setq a (difference a (times l 2704)))
(setq l (list l (quotient a 52) (mod a 52)))
(return (mapcar '(lambda (x) (nthelem
'(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
a b c d e f g h i j k l m n o p q r s t u v w x y z))) l)))))
(setq m (difference 0 n))
lp (cond ((zerop m) (return lst)))
(setq lst (cons (car x) lst))
(t (nth (cdr x) (sub1 n))))))
(def mylogor (lambda (x y)
loop (cond ((zerop cnt) (return x))
(t (setq x (times x 2)) (setq cnt (sub1 cnt))))
(cond ((put atm flg t) atm))))
(cond ((and (and (atom atm) (not (numberp atm)))
; returns a if a has the form cxr where x is an elt of {a d}
(cond ((lessp (flatsize a) 3) (return nil)))
(cond ((not (eq (car expl) 'c)) (return nil)))
loop (setq expl (cdr expl))
(cond ((eq (car expl) 'a) (go loop))
((eq (car expl) 'd) (go loop))
((and (eq (car expl) 'r) (null (cdr expl))) (return a))
;--- ismacro - a : atom name found in the functional position
; returns the body of the macro if a is the name of a macro, else
(cond ((not (symbolp a)) (return nil))
((setq x (assoc a k-macros)) (return (cadr x))))
(cond ((and (bcdp x) (eq (getdisc x) 'macro)) (return x))
((and (dtpr x) (eq (car x) 'macro)) (return x))))))
;--- isnlam - a : atom found in the functional position
; return the body of the nlambda if a names an nlambda,
(cond ((not (symbolp a)) (return nil)))
(cond ((setq x (assoc a k-nlams)) (return (cadr x))))
(cond ((and (dtpr x) (eq (car x) 'nlambda)) (return x))
((and (bcdp x) (eq (getdisc x) 'nlambda)) (return x))))))
(cond ((dtpr arg) (car arg))
;--- defsysf - funname : lisp function name
; - inname : internal system name
; We declare that funname is a system type function with
; the address of the c-code for it at inname. Thus we
; can call this function directly without going through
; the oblist. This type of optimization can be turned off
; by disabling this routine (if debuggin is desired)
(putprop funname inname 'x-sysf))) ; indicate of prop list
(list 'patom (cadr x) 'vp-sfile)))
loop (cond ((null foo) (return))
((atom foo) ($pr$ foo) (return))
(def $terpri (lambda () (terpr vp-sfile)))