1 (setq SCCS-fpMacs.l "@(#)fpMacs.l 1.1 04/27/83") 2 ; FP interpreter/compiler 3 ; Copyright (c) 1982 Scott B. Baden 4 ; Berkeley, California 5 6 (declare 7 (macros t) 8 (special ptport infile)) 9 10 11 (eval-when (compile eval load) 12 13 (setq whiteSpace ''(9 10 32)) 14 (setq blankOrTab ''(9 32)) 15 (setq CR 10) 16 (setq BLANK 32) 17 (setq lAngle '|<|) 18 (setq rAngle '|>|) 19 20 (setq funcForms 21 ''(alpha$fp 22 insert$fp 23 constant$fp 24 condit$fp 25 constr$fp 26 compos$fp 27 while$fp 28 ti$fp)) 29 30 (setq multiAdicFns 31 ''(select$fp 32 tl$fp 33 tlr$fp 34 id$fp 35 atom$fp 36 null$fp 37 reverse$fp 38 distl$fp 39 distr$fp 40 length$fp 41 apndl$fp 42 apndr$fp 43 rotl$fp 44 rotr$fp 45 trans$fp 46 first$fp 47 last$fp 48 front$fp 49 pick$fp 50 concat$fp 51 pair$fp 52 split$fp)) 53 54 (setq dyadFns 55 ''(plus$fp 56 sub$fp 57 times$fp 58 div$fp 59 and$fp 60 or$fp 61 xor$fp 62 not$fp 63 lt$fp 64 le$fp 65 eq$fp 66 ge$fp 67 gt$fp 68 ne$fp)) 69 70 71 (setq libFns 72 ''(sin$fp 73 asin$fp 74 cos$fp 75 acos$fp 76 log$fp 77 exp$fp 78 mod$fp)) 79 80 (setq miscFns 81 ''(iota$fp)) 82 ) 83 84 85 (defmacro Tyi nil 86 `(let ((z (tyi))) 87 (cond ((and (null infile) ptport) (tyo z ptport)) 88 (t z)))) 89 90 (defmacro peekc nil 91 `(tyipeek infile)) 92 93 (defmacro Getc nil 94 `(let ((piport infile)) 95 (prog (c) 96 (cond ((eq 'eof$$ (setq c (readc piport 'eof$$))) 97 (*throw 'parse$err 'eof$$)) 98 (t (setq c (car (exploden c))) 99 (cond 100 ((not (and (null in_buf) (memq c #.whiteSpace))) 101 (setq in_buf (cons c in_buf)))))) 102 (cond ((and (null infile) ptport) 103 (cond 104 ((not (and (null in_buf) (memq c #.whiteSpace))) 105 (tyo c ptport))))) 106 (return c)))) 107 108 (defmacro Read nil 109 `(let ((z (read))) 110 (prog nil 111 (cond ((and (null infile) ptport (not (listp z))) (patom z ptport))) 112 (cond ((and (null infile) ptport (not (listp z))) 113 (do 114 ((c (tyipeek) (tyipeek))) 115 ((or (and (eq c #.CR) (Tyi) t) 116 (null (memq c #.blankOrTab)))) 117 (Tyi)))) 118 119 (return z)))) 120 121 (defmacro find (flg lst) 122 `(cond ((atom ,lst) (eq ,flg ,lst)) 123 ((not (listp ,lst)) nil) 124 (t (memq ,flg ,lst)))) 125 126 127 ; we want top-level size, not total number of arguments 128 129 (defmacro size (x) 130 `(cond ((atom ,x) 1) 131 (t (length ,x)))) 132 133 (defmacro twop (x) 134 `(eq 2 ,x)) 135 136 137 ;; Special macros to help out tree insert 138 139 (defmacro treeIns (fn input Len) 140 `(cond ((zerop ,Len) (unitTreeInsert ,fn)) 141 ((onep ,Len) (car ,input)) 142 ((twop ,Len) (funcall ,fn ,input)) 143 (t (treeInsWithLen ,fn ,input ,Len)))) 144 145 146 (defmacro unitTreeInsert (fn) 147 `(let ((ufn (get 'u-fnc ,fn))) 148 (cond (ufn (funcall ufn)) 149 (t (bottom))))) 150 151 152 (putprop 'fpMacs t 'loaded) 153 154