![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fpMacs.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / fp|
Return to fpMacs.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / fp |
1.1 root 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) 5/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:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.