112065Sbaden ; FP interpreter/compiler 212065Sbaden ; Copyright (c) 1982 Scott B. Baden 312065Sbaden ; Berkeley, California 4*21725Sdist ; 5*21725Sdist ; Copyright (c) 1982 Regents of the University of California. 6*21725Sdist ; All rights reserved. The Berkeley software License Agreement 7*21725Sdist ; specifies the terms and conditions for redistribution. 8*21725Sdist ; 9*21725Sdist (setq SCCS-fpMacs.l "@(#)fpMacs.l 5.1 (Berkeley) 05/31/85") 1012065Sbaden 1112065Sbaden (declare 1212065Sbaden (macros t) 1312065Sbaden (special ptport infile)) 1412065Sbaden 1512065Sbaden 1612065Sbaden (eval-when (compile eval load) 1712065Sbaden 1812065Sbaden (setq whiteSpace ''(9 10 32)) 1912065Sbaden (setq blankOrTab ''(9 32)) 2012065Sbaden (setq CR 10) 2112065Sbaden (setq BLANK 32) 2212065Sbaden (setq lAngle '|<|) 2312065Sbaden (setq rAngle '|>|) 2412065Sbaden 2512065Sbaden (setq funcForms 2612065Sbaden ''(alpha$fp 2712065Sbaden insert$fp 2812065Sbaden constant$fp 2912065Sbaden condit$fp 3012065Sbaden constr$fp 3112065Sbaden compos$fp 3212065Sbaden while$fp 3312065Sbaden ti$fp)) 3412065Sbaden 3512065Sbaden (setq multiAdicFns 3612065Sbaden ''(select$fp 3712065Sbaden tl$fp 3812065Sbaden tlr$fp 3912065Sbaden id$fp 4012065Sbaden atom$fp 4112065Sbaden null$fp 4212065Sbaden reverse$fp 4312065Sbaden distl$fp 4412065Sbaden distr$fp 4512065Sbaden length$fp 4612065Sbaden apndl$fp 4712065Sbaden apndr$fp 4812065Sbaden rotl$fp 4912065Sbaden rotr$fp 5012065Sbaden trans$fp 5112065Sbaden first$fp 5212065Sbaden last$fp 5312065Sbaden front$fp 5412065Sbaden pick$fp 5512065Sbaden concat$fp 5612065Sbaden pair$fp 5712065Sbaden split$fp)) 5812065Sbaden 5912065Sbaden (setq dyadFns 6012065Sbaden ''(plus$fp 6112065Sbaden sub$fp 6212065Sbaden times$fp 6312065Sbaden div$fp 6412065Sbaden and$fp 6512065Sbaden or$fp 6612065Sbaden xor$fp 6712065Sbaden not$fp 6812065Sbaden lt$fp 6912065Sbaden le$fp 7012065Sbaden eq$fp 7112065Sbaden ge$fp 7212065Sbaden gt$fp 7312065Sbaden ne$fp)) 7412065Sbaden 7512065Sbaden 7612065Sbaden (setq libFns 7712065Sbaden ''(sin$fp 7812065Sbaden asin$fp 7912065Sbaden cos$fp 8012065Sbaden acos$fp 8112065Sbaden log$fp 8212065Sbaden exp$fp 8312065Sbaden mod$fp)) 8412065Sbaden 8512065Sbaden (setq miscFns 8612065Sbaden ''(iota$fp)) 8712065Sbaden ) 8812065Sbaden 8912065Sbaden 9012065Sbaden (defmacro Tyi nil 9112065Sbaden `(let ((z (tyi))) 9212065Sbaden (cond ((and (null infile) ptport) (tyo z ptport)) 9312065Sbaden (t z)))) 9412065Sbaden 9512065Sbaden (defmacro peekc nil 9612065Sbaden `(tyipeek infile)) 9712065Sbaden 9812065Sbaden (defmacro Getc nil 9912065Sbaden `(let ((piport infile)) 10012065Sbaden (prog (c) 10112065Sbaden (cond ((eq 'eof$$ (setq c (readc piport 'eof$$))) 10212065Sbaden (*throw 'parse$err 'eof$$)) 10312065Sbaden (t (setq c (car (exploden c))) 10412065Sbaden (cond 10512065Sbaden ((not (and (null in_buf) (memq c #.whiteSpace))) 10612065Sbaden (setq in_buf (cons c in_buf)))))) 10712065Sbaden (cond ((and (null infile) ptport) 10812065Sbaden (cond 10912065Sbaden ((not (and (null in_buf) (memq c #.whiteSpace))) 11012065Sbaden (tyo c ptport))))) 11112065Sbaden (return c)))) 11212065Sbaden 11312065Sbaden (defmacro Read nil 11412065Sbaden `(let ((z (read))) 11512065Sbaden (prog nil 11612065Sbaden (cond ((and (null infile) ptport (not (listp z))) (patom z ptport))) 11712065Sbaden (cond ((and (null infile) ptport (not (listp z))) 11812065Sbaden (do 11912065Sbaden ((c (tyipeek) (tyipeek))) 12012065Sbaden ((or (and (eq c #.CR) (Tyi) t) 12112065Sbaden (null (memq c #.blankOrTab)))) 12212065Sbaden (Tyi)))) 12312065Sbaden 12412065Sbaden (return z)))) 12512065Sbaden 12612065Sbaden (defmacro find (flg lst) 12712065Sbaden `(cond ((atom ,lst) (eq ,flg ,lst)) 12812065Sbaden ((not (listp ,lst)) nil) 12912065Sbaden (t (memq ,flg ,lst)))) 13012065Sbaden 13112065Sbaden 13212065Sbaden ; we want top-level size, not total number of arguments 13312065Sbaden 13412065Sbaden (defmacro size (x) 13512065Sbaden `(cond ((atom ,x) 1) 13612065Sbaden (t (length ,x)))) 13712065Sbaden 13812065Sbaden (defmacro twop (x) 13912065Sbaden `(eq 2 ,x)) 14012065Sbaden 14112065Sbaden 14212065Sbaden ;; Special macros to help out tree insert 14312065Sbaden 14412065Sbaden (defmacro treeIns (fn input Len) 14512065Sbaden `(cond ((zerop ,Len) (unitTreeInsert ,fn)) 14612065Sbaden ((onep ,Len) (car ,input)) 14712065Sbaden ((twop ,Len) (funcall ,fn ,input)) 14812065Sbaden (t (treeInsWithLen ,fn ,input ,Len)))) 14912065Sbaden 15012065Sbaden 15112065Sbaden (defmacro unitTreeInsert (fn) 15212065Sbaden `(let ((ufn (get 'u-fnc ,fn))) 15312065Sbaden (cond (ufn (funcall ufn)) 15412065Sbaden (t (bottom))))) 15512065Sbaden 15612065Sbaden 15712065Sbaden (putprop 'fpMacs t 'loaded) 15812065Sbaden 159