BSD 4_3_Reno release

[unix-history] / usr / src / pgrm / lisp / fp / fp.vax / fpMacs.l

;  FP interpreter/compiler
;  Copyright (c) 1982  Scott B. Baden
;  Berkeley, California
;
;  Copyright (c) 1982 Regents of the University of California.
;  All rights reserved.  The Berkeley software License Agreement
;  specifies the terms and conditions for redistribution.
;
(setq SCCS-fpMacs.l "@(#)fpMacs.l       5.1 (Berkeley) 5/31/85")

(declare
 (macros t)
 (special ptport infile))


(eval-when (compile eval load)

 (setq whiteSpace ''(9 10 32))
 (setq blankOrTab ''(9 32))
 (setq CR 10)
 (setq BLANK 32)
 (setq lAngle '|<|)
 (setq rAngle '|>|)
 
 (setq funcForms
       ''(alpha$fp
          insert$fp
          constant$fp
          condit$fp
          constr$fp
          compos$fp
          while$fp
          ti$fp))
 
 (setq multiAdicFns
       ''(select$fp
          tl$fp
          tlr$fp
          id$fp
          atom$fp
          null$fp
          reverse$fp
          distl$fp
          distr$fp
          length$fp
          apndl$fp
          apndr$fp
          rotl$fp
          rotr$fp
          trans$fp
          first$fp
          last$fp
          front$fp
          pick$fp
          concat$fp
          pair$fp
          split$fp))
 
 (setq dyadFns
       ''(plus$fp
          sub$fp
          times$fp
          div$fp
          and$fp
          or$fp
          xor$fp
          not$fp
          lt$fp
          le$fp
          eq$fp
          ge$fp
          gt$fp
          ne$fp))
 
 
 (setq libFns
       ''(sin$fp
          asin$fp
          cos$fp
          acos$fp
          log$fp
          exp$fp
          mod$fp))
 
 (setq miscFns
       ''(iota$fp))
 )


(defmacro Tyi nil
 `(let ((z (tyi)))
       (cond ((and (null infile) ptport) (tyo z ptport))
             (t z))))

(defmacro peekc nil
      `(tyipeek infile))

(defmacro Getc nil
 `(let ((piport infile))
       (prog (c)
             (cond ((eq 'eof$$ (setq c (readc piport 'eof$$)))
                    (*throw 'parse$err 'eof$$))
                   (t (setq c (car (exploden c)))
                      (cond
                       ((not (and (null in_buf) (memq c #.whiteSpace)))
                        (setq in_buf (cons c in_buf))))))
             (cond ((and (null infile) ptport)
                    (cond
                     ((not (and (null in_buf) (memq c #.whiteSpace)))
                      (tyo c ptport)))))
             (return c))))

(defmacro Read nil
 `(let ((z (read)))
       (prog nil
             (cond ((and (null infile) ptport (not (listp z))) (patom z ptport)))
             (cond ((and (null infile) ptport (not (listp z)))
                    (do
                     ((c (tyipeek) (tyipeek)))
                     ((or (and (eq c #.CR) (Tyi) t)
                          (null (memq c #.blankOrTab))))
                     (Tyi))))
             
             (return z))))

(defmacro find (flg lst)
 `(cond ((atom ,lst) (eq ,flg ,lst))
        ((not (listp ,lst)) nil)
        (t (memq ,flg ,lst))))


; we want top-level size, not total number of arguments

(defmacro size (x)
 `(cond ((atom ,x) 1)
        (t (length ,x))))

(defmacro twop (x)
 `(eq 2 ,x))


;; Special macros to help out tree insert

(defmacro treeIns (fn input Len)
 `(cond ((zerop ,Len) (unitTreeInsert ,fn))
        ((onep ,Len) (car ,input))
        ((twop ,Len) (funcall ,fn  ,input))
        (t (treeInsWithLen ,fn ,input ,Len))))


(defmacro unitTreeInsert (fn)
 `(let ((ufn (get 'u-fnc ,fn)))
       (cond (ufn  (funcall ufn))
             (t (bottom)))))


(putprop 'fpMacs t 'loaded)