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