| 1 | ;--- file: complra.l |
| 2 | (include "compmacs.l") |
| 3 | |
| 4 | (def put |
| 5 | (macro (x) |
| 6 | ((lambda (atm prp arg) |
| 7 | `(progn (putprop ,atm ,arg ,prp) ,atm)) |
| 8 | (cadr x) (caddr x) (cadddr x)))) |
| 9 | |
| 10 | |
| 11 | |
| 12 | ; register allocation and important addresses for compiled code |
| 13 | ; |
| 14 | (setq np-reg 'r6 ;points one beyond top stack value |
| 15 | lbot-reg 'r7 ;current value of lbot |
| 16 | ln-reg 'r8 ;address of linker |
| 17 | olbot-reg 'r10 ;base of args to this fcn |
| 18 | bnp-reg 'r11 ;bind np |
| 19 | bnp-val '"*-32(r8)" ;value of global var bnp |
| 20 | i-mov 'movl ;stacking instruction for namestack |
| 21 | i-clr 'clrl ;clear namestack |
| 22 | qfuncl '"*-28(r8)" ;addr of qfuncl |
| 23 | ) |
| 24 | |
| 25 | ; these are the short cut places to call when you want to call |
| 26 | ; a non system function with 4 or less arguments |
| 27 | |
| 28 | (setplist 'qfs '(0 "*-8(r8)" 1 "*-12(r8)" 2 "*-16(r8)" |
| 29 | 3 "*-20(r8)" 4 "*-24(r8)")) |
| 30 | |
| 31 | (setq faslflag nil) |
| 32 | |
| 33 | (declare (special w-vars w-labs w-ret w-name w-bv w-atmt cm-alv v-cnt)) |
| 34 | |
| 35 | |
| 36 | |
| 37 | |
| 38 | (cond ((lessp (opval 'pagelimit) 2000) (opval 'pagelimit 2000))) |
| 39 | |
| 40 | |
| 41 | |
| 42 | (def Gensym (lambda (x) |
| 43 | (prog (e) |
| 44 | (setq e (gensym (cond (x) (t 'L)))) |
| 45 | (setq twa-list (cons e twa-list)) |
| 46 | (return e)))) |
| 47 | |
| 48 | (def cvt (lambda (a) |
| 49 | (prog (l) |
| 50 | (setq l (quotient a 2704)) |
| 51 | (setq a (difference a (times l 2704))) |
| 52 | (setq l (list l (quotient a 52) (mod a 52))) |
| 53 | (return (mapcar '(lambda (x) (nthelem |
| 54 | (add1 x) |
| 55 | '(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 |
| 56 | 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))))) |
| 57 | |
| 58 | (def nth |
| 59 | (lambda (x n) |
| 60 | (cond ((equal n 0) x) |
| 61 | ((lessp n 0) |
| 62 | (prog (m lst) |
| 63 | (setq m (difference 0 n)) |
| 64 | (setq x (reverse x)) |
| 65 | lp (cond ((zerop m) (return lst))) |
| 66 | (setq lst (cons (car x) lst)) |
| 67 | (setq x (cdr x)) |
| 68 | (setq m (sub1 m)) |
| 69 | (go lp))) |
| 70 | (t (nth (cdr x) (sub1 n)))))) |
| 71 | |
| 72 | (def cleanup (lambda nil |
| 73 | (mapc 'rematom twa-list) |
| 74 | (setq twa-list nil))) |
| 75 | |
| 76 | (def mylogor (lambda (x y) |
| 77 | (boole 7 x y))) |
| 78 | |
| 79 | (def leftshift |
| 80 | (lambda (x cnt) |
| 81 | (prog () |
| 82 | loop (cond ((zerop cnt) (return x)) |
| 83 | ((lessp cnt 0) |
| 84 | (setq x (quotient x 2)) |
| 85 | (setq cnt (add1 cnt))) |
| 86 | (t (setq x (times x 2)) (setq cnt (sub1 cnt)))) |
| 87 | (go loop)))) |
| 88 | |
| 89 | (def flag |
| 90 | (lambda (atm flg) |
| 91 | (cond ((put atm flg t) atm)))) |
| 92 | |
| 93 | (def ifflag |
| 94 | (lambda (atm flg) |
| 95 | (cond ((and (and (atom atm) (not (numberp atm))) |
| 96 | (get atm flg)) |
| 97 | t)))) |
| 98 | |
| 99 | (def unflag |
| 100 | (lambda (atm flg) |
| 101 | (put atm flg nil))) |
| 102 | |
| 103 | |
| 104 | \f |
| 105 | ;--- chain - a : an atom |
| 106 | ; returns a if a has the form cxr where x is an elt of {a d} |
| 107 | ; else returns nil. |
| 108 | ; |
| 109 | (def chain |
| 110 | (lambda (a) |
| 111 | (prog (expl) |
| 112 | (cond ((lessp (flatsize a) 3) (return nil))) |
| 113 | (setq expl (explode a)) |
| 114 | (cond ((not (eq (car expl) 'c)) (return nil))) |
| 115 | loop (setq expl (cdr expl)) |
| 116 | (cond ((eq (car expl) 'a) (go loop)) |
| 117 | ((eq (car expl) 'd) (go loop)) |
| 118 | ((and (eq (car expl) 'r) (null (cdr expl))) (return a)) |
| 119 | (t (return nil)))))) |
| 120 | |
| 121 | ;--- ismacro - a : atom name found in the functional position |
| 122 | ; returns the body of the macro if a is the name of a macro, else |
| 123 | ; return nil. |
| 124 | ; |
| 125 | (def ismacro |
| 126 | (lambda (a) |
| 127 | (prog (x) |
| 128 | (cond ((not (symbolp a)) (return nil)) |
| 129 | ((setq x (assoc a k-macros)) (return (cadr x)))) |
| 130 | (setq x (getd a)) |
| 131 | (cond ((and (bcdp x) (eq (getdisc x) 'macro)) (return x)) |
| 132 | ((and (dtpr x) (eq (car x) 'macro)) (return x)))))) |
| 133 | |
| 134 | ;--- isnlam - a : atom found in the functional position |
| 135 | ; return the body of the nlambda if a names an nlambda, |
| 136 | ; else return nil |
| 137 | ; |
| 138 | (def isnlam |
| 139 | (lambda (a) |
| 140 | (prog (x) |
| 141 | (cond ((not (symbolp a)) (return nil))) |
| 142 | (cond ((setq x (assoc a k-nlams)) (return (cadr x)))) |
| 143 | (setq x (getd a)) |
| 144 | (cond ((and (dtpr x) (eq (car x) 'nlambda)) (return x)) |
| 145 | ((and (bcdp x) (eq (getdisc x) 'nlambda)) (return x)))))) |
| 146 | |
| 147 | (def ucar |
| 148 | (lambda (arg) |
| 149 | (cond ((dtpr arg) (car arg)) |
| 150 | ((numberp arg) arg) |
| 151 | ((getd arg) arg) |
| 152 | (t (get arg '*car))))) |
| 153 | |
| 154 | ;--- defsysf - funname : lisp function name |
| 155 | ; - inname : internal system name |
| 156 | ; We declare that funname is a system type function with |
| 157 | ; the address of the c-code for it at inname. Thus we |
| 158 | ; can call this function directly without going through |
| 159 | ; the oblist. This type of optimization can be turned off |
| 160 | ; by disabling this routine (if debuggin is desired) |
| 161 | ; |
| 162 | (def defsysf |
| 163 | (lambda (funname inname) |
| 164 | (putprop funname inname 'x-sysf))) ; indicate of prop list |
| 165 | |
| 166 | (def $pr$ |
| 167 | (macro (x) |
| 168 | (list 'patom (cadr x) 'vp-sfile))) |
| 169 | |
| 170 | (def emit1 |
| 171 | (lambda (a) |
| 172 | (aprint a) |
| 173 | ($terpri))) |
| 174 | |
| 175 | (def emit2 |
| 176 | (lambda (a b) |
| 177 | (aprint a) |
| 178 | ($pr$ '" ") |
| 179 | (aprint b) |
| 180 | ($terpri))) |
| 181 | |
| 182 | (def emit3 |
| 183 | (lambda (a b c) |
| 184 | (aprint a) |
| 185 | ($pr$ '" ") |
| 186 | (aprint b) |
| 187 | ($pr$ '\,) |
| 188 | (aprint c) |
| 189 | ($terpri))) |
| 190 | |
| 191 | (def emit4 |
| 192 | (lambda (a b c d) |
| 193 | (aprint a) |
| 194 | ($pr$ '" ") |
| 195 | (aprint b) |
| 196 | ($pr$ '\,) |
| 197 | (aprint c) |
| 198 | ($pr$ '\,) |
| 199 | (aprint d) |
| 200 | ($terpri))) |
| 201 | |
| 202 | (def aprint |
| 203 | (lambda (foo) |
| 204 | (prog nil |
| 205 | loop (cond ((null foo) (return)) |
| 206 | ((atom foo) ($pr$ foo) (return)) |
| 207 | (t ($pr$ (car foo)) |
| 208 | (setq foo (cdr foo)))) |
| 209 | (go loop)))) |
| 210 | |
| 211 | (def $terpri (lambda () (terpr vp-sfile))) |
| 212 | |