![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fpMain.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 fpMain.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-fpMain.l "@(#)fpMain.l 5.1 (Berkeley) 5/31/85")
10:
11: ; Main routine to start up FP
12:
13: (include specials.l)
14: (declare (special arg parse_tree)
15: (localf syntaxErr synErrMsg last_cr p_indic display rtime doExit)
16: )
17:
18: ; may ask for debug output,
19: ; specifiy character set, only ASCII (asc) supported at this time.
20: ; exit to shell if invoked from it.
21:
22: (defun fpMain (debug from_shell)
23:
24: (do ((arg nil)
25: (parse_tree (*catch '(parse$err end_condit end_while) (parse 'top_lev))
26: (*catch '(parse$err end_condit end_while) (parse 'top_lev))))
27:
28: ; exit if an EOF has been entered from the terminal
29: ; (and it was the only character entered on the line)
30:
31: ((and (eq parse_tree 'eof$$) (null infile))
32: (terpri)
33: (doExit from_shell)) ; in any case exit
34:
35: ; if the EOF was from a file close it and then accept
36: ; input from terminal again
37:
38: (cond
39: ((not (eq parse_tree 'eof$$))
40: (cond (debug (print parse_tree)
41: (terpri)))
42: (cond
43: ((not (eq parse_tree 'cmd$$))
44: (cond
45: ((not (listp parse_tree))
46: (let
47: ((defn (put_fn fn_name parse_tree))) ; define the function
48: (cond (in_def
49: (patom "{")
50: (patom (setq usr_fn_name
51: (implode
52: (nreverse (cdddr (nreverse (explode fn_name)))))))
53: (patom "}") (terpri)
54: (putprop 'sources in_buf usr_fn_name)))
55: (cond ((and debug in_def) (pp fn_name))))
56:
57: ; read in an FP sequence once a colon (apply) has been detected
58:
59: (cond ((not in_def)
60: (cond ((and (null infile) ptport)
61: (do
62: ((c (tyipeek) (tyipeek)))
63: ((or (null (memq c #.whiteSpace))))
64: (Tyi))))
65: (setq arg (*catch 'parse$err (get_obj nil)))
66:
67: (cond ((find 'err$$ arg)
68: (syntaxErr))
69: ((undefp arg)
70: (terpri) (patom '?) (terpri))
71: (t
72: (let ((sPlist
73: (If DynTraceFlg then
74: (copy (plist 'Measures)) else nil))
75: (wcTime1 (sys:time))
76: (time1 (ptime))
77: (rslt (*catch 'bottom$up (funcall fn_name arg)))
78: (time2 (ptime))
79: (wcTime2 (sys:time)))
80:
81: (fpPP rslt)
82:
83: (If (and DynTraceFlg (undefp rslt)) then (setplist 'Measures sPlist))
84: (cond (timeIt
85: (let ((gcTime (diff (cadr time2) (cadr time1))))
86: (msg N "cpu + gc [wc] = ")
87: (rtime (diff (diff (car time2) (car time1)) gcTime) 60.0)
88: (patom " + ")
89: (rtime gcTime 60.0)
90: (patom " [")
91: (rtime (diff wcTime2 wcTime1) 1.0)
92: (msg "]"))
93: (msg (N 2))))))))))
94:
95: (t (syntaxErr) ))))))
96:
97:
98: (cond (in_def (setq fn_name 'tmp$$)))
99:
100: (cond ((and infile (eq parse_tree 'eof$$))
101: (patom " ") (close infile) (setq infile nil))
102:
103: (t (cond ((and (null infile) (not (eq parse_tree 'eof$$)))
104: (patom " ")))))
105:
106: (setq level 0)
107: (setq in_buf nil)
108: (setq in_def nil)))
109:
110:
111: ; Display a LISP list as an equivalent FP sequence
112:
113: (defun display (obj)
114: (cond ((null obj) (patom "<>"))
115: ((atom obj) (patom obj))
116: ((listp obj)
117: (patom "<")
118: (maplist
119: '(lambda (x)
120: (display (car x))
121: (cond ((not (onep (length x))) (patom " ")))) obj)
122: (patom ">"))))
123:
124: ; Form a character string of a LISP list as an equivalent FP sequence
125:
126: (defun put_obj (obj)
127: (cond ((null obj) "<>")
128: ((atom obj) obj)
129: ((listp obj)
130: (cond ((onep (length obj))
131: (concat "<" (put_obj (car obj)) ">"))
132: (t (do
133: ((xx obj (cdr xx))
134: (zz t nil)
135: (yy "<"))
136: ((zerop (length xx)) (concat yy ">"))
137: (cond ((not zz) (setq yy (concat yy " "))))
138: (setq yy (concat yy (put_obj (car xx))))))))))
139:
140:
141:
142: (defun rtime (time scale)
143: (patom (quotient (float (fix (product 100 (quotient time scale))))
144: 100.0)))
145:
146: (defun doExit (exitCond)
147: (cond (exitCond
148: (dontLoseStats)
149: (and (portp 'traceport) (close traceport)) ; if traceport is open
150: (and ptport (close ptport)) ; if script port is open
151: (exit))))
152:
153:
154: (defun syntaxErr nil
155: (let ((piport infile)
156: (tbuf (ncons nil)))
157: (cond ((and in_def (eq #/} (car in_buf)))
158: (do ((c (Tyi) (Tyi)))
159: ((memq c '(-1 #.CR))))
160: (synErrMsg)
161: (p_indic)
162: )
163:
164: (t (cond (in_def
165: (cond ((and
166: (eq #.CR
167: (do ((c (tyipeek) (tyipeek))
168: (e nil))
169: ((memq c '(-1 #/} #.CR))
170: (If (eq c #/}) then
171: (progn
172: (tconc tbuf c)
173: (setq e (Tyi)))
174:
175: else
176:
177: (If (eq c #.CR) then
178: (setq e (Tyi))))
179:
180: (synErrMsg)
181: (mapcar 'p_strng (car tbuf))
182: (p_indic)
183: e)
184: (tconc tbuf (Tyi))))
185: infile)
186:
187: (do ((c (tyipeek) (tyipeek))
188: (tbuf (ncons nil)))
189: ((memq c '(-1 #/}))
190: (If (eq c #/})
191: then (tconc tbuf (Tyi)))
192: (mapcar 'p_strng (car tbuf))
193: (terpri)
194: (If (eq c #/}) then
195: (do ((c (Tyi) (Tyi)))
196: ((memq c '(-1 #.CR)))))
197: )
198:
199: (tconc tbuf (Tyi))))))
200:
201: (t
202: (do ((c (tyipeek) (tyipeek)))
203: ((memq c '(-1 #.CR))
204: (Tyi)
205: (synErrMsg)
206: (mapcar 'p_strng (car tbuf))
207: (p_indic))
208: (tconc tbuf (Tyi)))))))
209: ))
210:
211: (defun synErrMsg nil
212: (msg N "Syntax Error:"
213: (N 2))
214: (mapcar 'p_strng (reverse in_buf)))
215:
216:
217: (defun p_indic nil
218: (msg N (B (length (cdr (last_cr (reverse in_buf))))) "^" N)
219: (If (null infile) then (terpr)))
220:
221: (defun last_cr (zy)
222: (cond ((null (memq #.CR zy)) zy) (t (last_cr (cdr (memq #.CR zy))))))
223:
224: ; throw bottom to the next level
225: ; This shortens the compiled code
226:
227: (defun bottom nil
228: (*throw 'bottom$up '?))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.