![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to toplevel.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / pearl|
Return to toplevel.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / pearl |
1.1 root 1: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; toplevel.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;
2: ; Franz and UCI Lisp top level functions
3: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4: ; Copyright (c) 1983 , The Regents of the University of California.
5: ; All rights reserved.
6: ; Authors: Joseph Faletti and Michael Deering and John Foderaro.
7:
8: ;-------------------------------------------------------------------------
9: ; Top level functions for PEARL Joe Faletti, December 1981
10: ; modified from
11: ; Top level function for franz jkf, march 1980
12: ;
13: ; The following function contains the top-level read, eval, print
14: ; loop. With the help of the usual error handling functions,
15: ; pearl-break-err-handler and debug-err-handler, pearl-top-level provides
16: ; a reasonable environment for working with PEARL.
17: ;
18:
19: (defvar \$ldprint)
20:
21: ; Handle ^C with fixit.
22: (de pearl:int-serv (x)
23: (fixit nil))
24:
25: ; Before Opus 38.31:
26: ; (setq pearl-title (concat " plus PEARL " (status ctime)))
27: ; Moved to franz.l:
28: ; (setq pearl-title (concat " plus PEARL " (time-string)))
29:
30: (de read-in-initprl-file ()
31: (setq break-level-count 0 ; do this in case break
32: debug-level-count 0) ; occurs during readin
33: (*catch '(break-catch top-level-catch)
34: (do ((dirs `("." ,(getenv 'HOME)) (cdr dirs))
35: ; prevent warnings (from setdbsize in particular).
36: (*warn* nil *warn*)
37: (\$ldprint nil \$ldprint)) ; prevent messages
38: ((null dirs))
39: (cond ((do ((name '(".init.prl" "init.prl") (cdr name)))
40: ((null name))
41: (cond ((do ((ext '(".o" ".l" "") (cdr ext))
42: (file))
43: ((null ext))
44: (cond ((probef
45: (setq file (concat (car dirs)
46: "/"
47: (car name)
48: (car ext))))
49: (cond ((atom (errset (load file)))
50: (patom
51: "Error loading init.prl file ")
52: (print file)
53: (terpr)
54: (return 'error)))
55: (return t))))
56: (return t))))
57: (return t))))))
58:
59: (de read-in-startprl-file ()
60: (setq break-level-count 0 ; do this in case break
61: debug-level-count 0) ; occurs during readin
62: (*catch '(break-catch top-level-catch)
63: (do ((dirs `("." ,(getenv 'HOME)) (cdr dirs))
64: (\$ldprint nil \$ldprint)) ; prevent messages
65: ((null dirs))
66: (cond ((do ((name '(".start.prl" "start.prl") (cdr name)))
67: ((null name))
68: (cond ((do ((ext '(".o" ".l" "") (cdr ext))
69: (file))
70: ((null ext))
71: (cond ((probef
72: (setq file (concat (car dirs)
73: "/"
74: (car name)
75: (car ext))))
76: (cond ((atom (errset (load file)))
77: (patom
78: "Error loading start.prl file ")
79: (print file)
80: (terpr)
81: (return 'error)))
82: (return t))))
83: (return t))))
84: (return t))))))
85:
86: ; For the implementor who wishes to dump a PEARL.
87: (df savepearl (name)
88: (sstatus ignoreeof nil) ; to undo ~/.lisprc
89: (setq franz-not-virgin nil)
90: (aliasdef 'top-level 'pearl-top-level-init)
91: (setq \$gcprint nil)
92: (gc) ; garbage collect before dumping lisp
93: (cond (name (eval (list 'dumplisp (car name))))
94: ( t (dumplisp pearl)))
95: t)
96:
97: ; For the user who wishes to dump a PEARL that starts with .init.prl.
98: (de savefresh n
99: (prog (name)
100: ; (INITFN 'STARTUPPEARL)
101: (setq franz-not-virgin nil)
102: (aliasdef 'top-level 'pearl-top-level-init)
103: (setq \$gcprint nil)
104: (gc) ; garbage collect before dumping lisp
105: (cond ((\=& n 1) (setq name (arg 1)))
106: ((\=& n 2) (setq name (concat (arg 1) '|/| (arg 2))))
107: ( t (setq name 'pearl)))
108: (eval (list 'dumplisp name))
109: (return t)))
110:
111: ; For the user who wishes to dump a PEARL that continues with the
112: ; read-eval-print loop.
113: (de savecontinue n
114: (prog (name)
115: ; (INITFN 'PEARL-REP-LOOP)
116: (aliasdef 'top-level 'pearl-top-level)
117: (setq \$gcprint nil)
118: (gc) ; garbage collect before dumping lisp
119: (cond ((\=& n 1) (setq name (arg 1)))
120: ((\=& n 2) (setq name (concat (arg 1) '|/| (arg 2))))
121: ( t (setq name 'pearl)))
122: (eval (list 'dumplisp name))
123: (return t)))
124:
125: (de pearlreploop ()
126: (prog (*pval*)
127: *pearlloop*
128: (terpri)
129: (and *printhistorynumber*
130: (patom (1+ *historynumber*)))
131: (patom *pearlprompt*)
132: (setq *readlinechanged* nil)
133: (cond ((eq (unbound)
134: (setq *pval*
135: (car (errset (eval (addhistory (read)))))))
136: (rplacx (\\ *historynumber* *historysize*)
137: *histval*
138: (unbound))
139: (prin 'unbound))
140: ( t (rplacx (\\ *historynumber* *historysize*)
141: *histval*
142: *pval*)
143: (pearlprintfn *pval*)))
144: (go *pearlloop*)))
145:
146: (de pearl ()
147: (read-in-initprl-file)
148: (cond ((not (boundp '*db1size*))
149: (setdbsize 7.)))
150: (cond ((not (boundp '*db*))
151: (builddb *maindb*)
152: (setq *db* *maindb*)))
153: (cond ((not (boundp '*pearlprompt*))
154: (setq *pearlprompt* '|pearl> |))
155: ((null *pearlprompt*)
156: (setq *pearlprompt* '|-> |)))
157: (cond ((not (boundp '*historysize*))
158: (setq *historysize* 64.)))
159: (setq *historynumber* -1.)
160: (setq *history* (makhunk *historysize*))
161: (setq *histval* (makhunk *historysize*))
162: (read-in-startprl-file)
163: (terpri)
164: (pearlreploop))
165:
166: (de initpearl ()
167: (cond ((not (boundp '*db1size*))
168: (setdbsize 7.)))
169: (cond ((not (boundp '*db*))
170: (builddb *maindb*)
171: (setq *db* *maindb*))))
172:
173: (de pearl-top-level-init ()
174: (aliasdef 'reset 'franz-reset)
175: (aliasdef 'top-level 'pearl-top-level)
176: (signal 2 'pearl:int-serv)
177: (*catch '(top-level-catch break-catch)
178: (cond ((or (not (boundp 'franz-not-virgin))
179: (null franz-not-virgin))
180: (setq franz-not-virgin t
181: + nil ++ nil +++ nil
182: * nil ** nil *** nil)
183: ; This is changed because fixit is included now.
184: ; (setq ER%tpl 'pearl-break-err-handler)
185: (setq ER%tpl 'fixit)
186: (setq ER%brk 'fixit)
187: (setq ER%err 'fixit)
188:
189: ; The rest of the code should be within this
190: ; cond if autorunlisp existed
191: ; (cond ((not (autorunlisp))))
192: ;
193: (patom (status version))
194: (cond ((boundp 'franz-minor-version-number)
195: (patom franz-minor-version-number)))
196: (patom pearl-title)
197: (terpr)
198: (cond (*firststartup* (setq *firststartup* nil)
199: (read-in-initprl-file)))
200: (or *pearlprompt*
201: (setq *pearlprompt* '|-> |))
202: (and (not (\=& 64 *historysize*))
203: (setq *history* (makhunk *historysize*))
204: (setq *histval* (makhunk *historysize*)))
205: (read-in-startprl-file))))
206: (reset))
207:
208: (de pearl-top-level ()
209: ; loop forever
210: (do ((+*) (-) (retval))
211: (nil)
212: (setq retval
213: (*catch
214: '(top-level-catch break-catch)
215: ; begin or return to top level
216: (progn
217: (setq debug-level-count 0 break-level-count 0
218: evalhook nil funcallhook nil)
219: (cond (tpl-errlist (mapc 'eval tpl-errlist)))
220: (do ((^w nil nil))
221: (nil)
222: (cond (user-top-level (funcall user-top-level))
223: ( t ; Print prompt.
224: (and *printhistorynumber*
225: (patom (1+ *historynumber*)))
226: (patom *pearlprompt*)
227: (setq *readlinechanged* nil)
228:
229: (cond ((eq top-level-eof
230: ; read and add to history.
231: (setq -
232: (car (errset
233: (addhistory
234: (read nil
235: top-level-eof))))))
236: (cond ((not (status isatty))
237: (exit)))
238: (cond ((null (status ignoreeof))
239: (terpr)
240: (print 'Goodbye)
241: (terpr)
242: (exit))
243: ( t (terpr)
244: (setq - ''EOF)))))
245: ; Eval and story result in history.
246: (setq +* (eval -))
247: (rplacx (\\ *historynumber* *historysize*)
248: *histval*
249: +*)
250: ; update list of old forms
251: (let ((val -))
252: (let ((o+ +) (o++ ++))
253: (setq + val
254: ++ o+
255: +++ o++)))
256: ; update list of old values
257: (let ((val +*))
258: (let ((o* *) (o** **))
259: (setq * val
260: ** o*
261: *** o**)))
262: ; Don't print *invisible*.
263: (and (neq '*invisible* +*)
264: (pearlprintfn +*))
265: (terpr))))
266: (terpr)
267: (patom "[Return to top level]")
268: (terpr)
269: (cond ((eq 'reset retval) (old-reset-function))))))))
270:
271: ; this is the break handler, it should be tied to
272: ; ER%tpl always.
273: ; it is entered if there is an error which no one wants to handle.
274: ; We loop forever, printing out our error level until someone
275: ; types a ^D which goes to the next break level above us (or the
276: ; top-level if there are no break levels above us.)
277: ; a (return n) will return that value to the error message
278: ; which called us, if that is possible (that is if the error is
279: ; continuable)
280: ;
281: (def pearl-break-err-handler
282: (lexpr
283: (n)
284: ((lambda
285: (message break-level-count retval rettype ^w piport)
286: (cond ((>& n 0)
287: (print 'error:)
288: (mapc '(lambda (a) (patom " ") (patom a) )
289: (cdddr (arg 1)))
290: (terpr)
291: (cond ((caddr (arg 1)) (setq rettype 'contuab))
292: ( t (setq rettype nil))))
293: ( t (setq rettype 'localcall)))
294:
295: (do nil (nil)
296: (cond ((dtpr
297: (setq retval
298: (*catch
299: 'break-catch
300: (do ((form)) (nil)
301: (patom "<")
302: (patom break-level-count)
303: (patom ">: ")
304: (cond ((eq top-level-eof
305: (setq form (read nil top-level-eof)))
306: (cond ((null (status isatty))
307: (exit)))
308: (eval 1) ; force interrupt check
309: (return (1- break-level-count)))
310: ((and (dtpr form)
311: (eq 'return (car form)))
312: (cond ((or (eq rettype 'contuab)
313: (eq rettype 'localcall))
314: (return (ncons (eval (cadr form)))))
315: ( t (patom
316: "Can't continue from this error")
317: (terpr))))
318: ((and (dtpr form) (eq 'retbrk (car form)))
319: (cond ((numberp (setq form
320: (eval (cadr form))))
321: (return form))
322: ( t (return (1- break-level-count)))))
323: ( t (pearlbreakprintfn (eval form))
324: (terpr)))))))
325: (return (cond ((eq rettype 'localcall)
326: (car retval))
327: ( t retval))))
328: ((<& retval break-level-count)
329: (setq tpl-errlist errlist)
330: (*throw 'break-catch retval))
331: ( t (terpr)))))
332: nil
333: (1+ break-level-count)
334: nil
335: nil
336: nil
337: nil)))
338:
339: (aliasdef 'break-err-handler 'pearl-break-err-handler)
340:
341: ; vi: set lisp:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.