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