Return to fpMacs.l CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / fp

Annotation of 42BSD/ucb/fp/fpMacs.l, revision 1.1.1.1

1.1       root        1: (setq SCCS-fpMacs.l "@(#)fpMacs.l      1.1     4/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: 

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.