12e7fcc67Sbaden ; FP interpreter/compiler 22e7fcc67Sbaden ; Copyright (c) 1982 Scott B. Baden 32e7fcc67Sbaden ; Berkeley, California 4*542bf222Sdist ; 5*542bf222Sdist ; Copyright (c) 1982 Regents of the University of California. 6*542bf222Sdist ; All rights reserved. The Berkeley software License Agreement 7*542bf222Sdist ; specifies the terms and conditions for redistribution. 8*542bf222Sdist ; 9*542bf222Sdist (setq SCCS-fpMacs.l "@(#)fpMacs.l 5.1 (Berkeley) 05/31/85") 102e7fcc67Sbaden 112e7fcc67Sbaden (declare 122e7fcc67Sbaden (macros t) 132e7fcc67Sbaden (special ptport infile)) 142e7fcc67Sbaden 152e7fcc67Sbaden 162e7fcc67Sbaden (eval-when (compile eval load) 172e7fcc67Sbaden 182e7fcc67Sbaden (setq whiteSpace ''(9 10 32)) 192e7fcc67Sbaden (setq blankOrTab ''(9 32)) 202e7fcc67Sbaden (setq CR 10) 212e7fcc67Sbaden (setq BLANK 32) 222e7fcc67Sbaden (setq lAngle '|<|) 232e7fcc67Sbaden (setq rAngle '|>|) 242e7fcc67Sbaden 252e7fcc67Sbaden (setq funcForms 262e7fcc67Sbaden ''(alpha$fp 272e7fcc67Sbaden insert$fp 282e7fcc67Sbaden constant$fp 292e7fcc67Sbaden condit$fp 302e7fcc67Sbaden constr$fp 312e7fcc67Sbaden compos$fp 322e7fcc67Sbaden while$fp 332e7fcc67Sbaden ti$fp)) 342e7fcc67Sbaden 352e7fcc67Sbaden (setq multiAdicFns 362e7fcc67Sbaden ''(select$fp 372e7fcc67Sbaden tl$fp 382e7fcc67Sbaden tlr$fp 392e7fcc67Sbaden id$fp 402e7fcc67Sbaden atom$fp 412e7fcc67Sbaden null$fp 422e7fcc67Sbaden reverse$fp 432e7fcc67Sbaden distl$fp 442e7fcc67Sbaden distr$fp 452e7fcc67Sbaden length$fp 462e7fcc67Sbaden apndl$fp 472e7fcc67Sbaden apndr$fp 482e7fcc67Sbaden rotl$fp 492e7fcc67Sbaden rotr$fp 502e7fcc67Sbaden trans$fp 512e7fcc67Sbaden first$fp 522e7fcc67Sbaden last$fp 532e7fcc67Sbaden front$fp 542e7fcc67Sbaden pick$fp 552e7fcc67Sbaden concat$fp 562e7fcc67Sbaden pair$fp 572e7fcc67Sbaden split$fp)) 582e7fcc67Sbaden 592e7fcc67Sbaden (setq dyadFns 602e7fcc67Sbaden ''(plus$fp 612e7fcc67Sbaden sub$fp 622e7fcc67Sbaden times$fp 632e7fcc67Sbaden div$fp 642e7fcc67Sbaden and$fp 652e7fcc67Sbaden or$fp 662e7fcc67Sbaden xor$fp 672e7fcc67Sbaden not$fp 682e7fcc67Sbaden lt$fp 692e7fcc67Sbaden le$fp 702e7fcc67Sbaden eq$fp 712e7fcc67Sbaden ge$fp 722e7fcc67Sbaden gt$fp 732e7fcc67Sbaden ne$fp)) 742e7fcc67Sbaden 752e7fcc67Sbaden 762e7fcc67Sbaden (setq libFns 772e7fcc67Sbaden ''(sin$fp 782e7fcc67Sbaden asin$fp 792e7fcc67Sbaden cos$fp 802e7fcc67Sbaden acos$fp 812e7fcc67Sbaden log$fp 822e7fcc67Sbaden exp$fp 832e7fcc67Sbaden mod$fp)) 842e7fcc67Sbaden 852e7fcc67Sbaden (setq miscFns 862e7fcc67Sbaden ''(iota$fp)) 872e7fcc67Sbaden ) 882e7fcc67Sbaden 892e7fcc67Sbaden 902e7fcc67Sbaden (defmacro Tyi nil 912e7fcc67Sbaden `(let ((z (tyi))) 922e7fcc67Sbaden (cond ((and (null infile) ptport) (tyo z ptport)) 932e7fcc67Sbaden (t z)))) 942e7fcc67Sbaden 952e7fcc67Sbaden (defmacro peekc nil 962e7fcc67Sbaden `(tyipeek infile)) 972e7fcc67Sbaden 982e7fcc67Sbaden (defmacro Getc nil 992e7fcc67Sbaden `(let ((piport infile)) 1002e7fcc67Sbaden (prog (c) 1012e7fcc67Sbaden (cond ((eq 'eof$$ (setq c (readc piport 'eof$$))) 1022e7fcc67Sbaden (*throw 'parse$err 'eof$$)) 1032e7fcc67Sbaden (t (setq c (car (exploden c))) 1042e7fcc67Sbaden (cond 1052e7fcc67Sbaden ((not (and (null in_buf) (memq c #.whiteSpace))) 1062e7fcc67Sbaden (setq in_buf (cons c in_buf)))))) 1072e7fcc67Sbaden (cond ((and (null infile) ptport) 1082e7fcc67Sbaden (cond 1092e7fcc67Sbaden ((not (and (null in_buf) (memq c #.whiteSpace))) 1102e7fcc67Sbaden (tyo c ptport))))) 1112e7fcc67Sbaden (return c)))) 1122e7fcc67Sbaden 1132e7fcc67Sbaden (defmacro Read nil 1142e7fcc67Sbaden `(let ((z (read))) 1152e7fcc67Sbaden (prog nil 1162e7fcc67Sbaden (cond ((and (null infile) ptport (not (listp z))) (patom z ptport))) 1172e7fcc67Sbaden (cond ((and (null infile) ptport (not (listp z))) 1182e7fcc67Sbaden (do 1192e7fcc67Sbaden ((c (tyipeek) (tyipeek))) 1202e7fcc67Sbaden ((or (and (eq c #.CR) (Tyi) t) 1212e7fcc67Sbaden (null (memq c #.blankOrTab)))) 1222e7fcc67Sbaden (Tyi)))) 1232e7fcc67Sbaden 1242e7fcc67Sbaden (return z)))) 1252e7fcc67Sbaden 1262e7fcc67Sbaden (defmacro find (flg lst) 1272e7fcc67Sbaden `(cond ((atom ,lst) (eq ,flg ,lst)) 1282e7fcc67Sbaden ((not (listp ,lst)) nil) 1292e7fcc67Sbaden (t (memq ,flg ,lst)))) 1302e7fcc67Sbaden 1312e7fcc67Sbaden 1322e7fcc67Sbaden ; we want top-level size, not total number of arguments 1332e7fcc67Sbaden 1342e7fcc67Sbaden (defmacro size (x) 1352e7fcc67Sbaden `(cond ((atom ,x) 1) 1362e7fcc67Sbaden (t (length ,x)))) 1372e7fcc67Sbaden 1382e7fcc67Sbaden (defmacro twop (x) 1392e7fcc67Sbaden `(eq 2 ,x)) 1402e7fcc67Sbaden 1412e7fcc67Sbaden 1422e7fcc67Sbaden ;; Special macros to help out tree insert 1432e7fcc67Sbaden 1442e7fcc67Sbaden (defmacro treeIns (fn input Len) 1452e7fcc67Sbaden `(cond ((zerop ,Len) (unitTreeInsert ,fn)) 1462e7fcc67Sbaden ((onep ,Len) (car ,input)) 1472e7fcc67Sbaden ((twop ,Len) (funcall ,fn ,input)) 1482e7fcc67Sbaden (t (treeInsWithLen ,fn ,input ,Len)))) 1492e7fcc67Sbaden 1502e7fcc67Sbaden 1512e7fcc67Sbaden (defmacro unitTreeInsert (fn) 1522e7fcc67Sbaden `(let ((ufn (get 'u-fnc ,fn))) 1532e7fcc67Sbaden (cond (ufn (funcall ufn)) 1542e7fcc67Sbaden (t (bottom))))) 1552e7fcc67Sbaden 1562e7fcc67Sbaden 1572e7fcc67Sbaden (putprop 'fpMacs t 'loaded) 1582e7fcc67Sbaden 159