![[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 / lisplib|
Return to toplevel.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib |
1.1 root 1: (setq rcs-toplevel-
2: "$Header: toplevel.l,v 1.6 83/11/18 08:47:24 jkf Exp $")
3:
4: ;;
5: ;; toplevel.l -[Sun Oct 30 08:14:49 1983 by jkf]-
6: ;;
7: ;; toplevel read eval print loop
8: ;;
9:
10:
11: ; special atoms:
12: (declare (special debug-level-count break-level-count
13: errlist tpl-errlist user-top-level
14: franz-not-virgin piport ER%tpl ER%all
15: $ldprint evalhook funcallhook
16: franz-minor-version-number
17: top-level-init
18: top-level-prompt top-level-read
19: top-level-eval top-level-print
20: top-level-eof * ** *** + ++ +++ ^w)
21: (localf autorunlisp cvtsearchpathtolist)
22: (macros t))
23:
24: (setq top-level-eof (gensym 'Q)
25: tpl-errlist nil
26: errlist nil
27: user-top-level nil
28: top-level-init nil
29: top-level-prompt nil
30: top-level-read nil
31: top-level-eval nil
32: top-level-print nil)
33:
34: ;--- initialization, prompt, read, eval, and print functions are
35: ; user-selectable by just assigning another value to top-level-init,
36: ; top-level-prompt, top-level-read, top-level-eval, and top-level-print.
37: ;
38: (defmacro top-init nil
39: '(cond ((and top-level-init
40: (getd top-level-init))
41: (funcall top-level-init))
42: (t (cond ((not (autorunlisp))
43: (patom (status version))
44: ; franz-minor-version-number defined in version.l
45: (cond ((boundp 'franz-minor-version-number)
46: (patom franz-minor-version-number)))
47: (terpr)
48: (read-in-lisprc-file))))))
49:
50: (defmacro top-prompt nil
51: `(cond ((and top-level-prompt
52: (getd top-level-prompt))
53: (funcall top-level-prompt))
54: (t (patom "-> "))))
55:
56: (defmacro top-read (&rest args)
57: `(cond ((and top-level-read
58: (getd top-level-read))
59: (funcall top-level-read ,@args))
60: (t (read ,@args))))
61:
62: (defmacro top-eval (&rest args)
63: `(cond ((and top-level-eval
64: (getd top-level-eval))
65: (funcall top-level-eval ,@args))
66: (t (eval ,@args))))
67:
68: (defmacro top-print (&rest args)
69: `(cond ((and top-level-print
70: (getd top-level-print))
71: (funcall top-level-print ,@args))
72: (t (print ,@args))))
73:
74: ;------------------------------------------------------
75: ; Top level function for franz jkf, march 1980
76: ;
77: ; The following function contains the top-level read, eval, print
78: ; loop. With the help of the error handling functions,
79: ; break-err-handler and debug-err-handler, franz-top-level provides
80: ; a reasonable enviroment for working with franz lisp.
81: ;
82:
83: (def franz-top-level
84: (lambda nil
85: (putd 'reset (getd 'franz-reset))
86: (username-to-dir-flush-cache) ; clear tilde expansion knowledge
87: (cond ((or (not (boundp 'franz-not-virgin))
88: (null franz-not-virgin))
89: (setq franz-not-virgin t
90: + nil ++ nil +++ nil
91: * nil ** nil *** nil)
92: (setq ER%tpl 'break-err-handler)
93: (top-init)))
94:
95: ; loop forever
96: (do ((+*) (-) (retval))
97: (nil)
98: (setq retval
99: (*catch
100: '(top-level-catch break-catch)
101: ; begin or return to top level
102: (progn
103: (setq debug-level-count 0 break-level-count 0
104: evalhook nil funcallhook nil)
105: (cond (tpl-errlist (mapc 'eval tpl-errlist)))
106: (do ((^w nil nil))
107: (nil)
108: (cond (user-top-level (funcall user-top-level))
109: (t (top-prompt)
110: (cond ((eq top-level-eof
111: (setq -
112: (car (errset (top-read nil
113: top-level-eof)))))
114: (cond ((not (status isatty))
115: (exit)))
116: (cond ((null (status ignoreeof))
117: (terpr)
118: (print 'Goodbye)
119: (terpr)
120: (exit))
121: (t (terpr)
122: (setq - ''EOF)))))
123: (setq +* (top-eval -))
124: ; update list of old forms
125: (let ((val -))
126: (let ((o+ +) (o++ ++))
127: (setq + val
128: ++ o+
129: +++ o++)))
130: ; update list of old values
131: (let ((val +*))
132: (let ((o* *) (o** **))
133: (setq * val
134: ** o*
135: *** o**)))
136: (top-print +*)
137: (terpr)))))))
138: (terpr)
139: (patom "[Return to top level]")
140: (terpr)
141: (cond ((eq 'reset retval) (old-reset-function))))))
142:
143:
144:
145:
146:
147: ; debug-err-handler is the clb of ER%all when we are doing debugging
148: ; and we want to catch all errors.
149: ; It is just a read eval print loop with errset.
150: ; the only way to leave is:
151: ; (reset) just back to top level
152: ; (return x) return the value to the error checker.
153: ; if nil is returned then we will continue as if the error
154: ; didn't occur. Otherwise if the returned value is a list,
155: ; then if the error is continuable, the car of that list
156: ; will be returned to recontinue computation.
157: ; ^D continue as if this handler wasn't called.
158: ; the form of errmsgs is:
159: ; (error_type unique_id continuable message_string other_args ...)
160: ;
161: (def debug-err-handler
162: (lexpr (n)
163: ((lambda (message debug-level-count retval ^w piport)
164: (cond ((greaterp n 0)
165: (print 'Error:)
166: (mapc '(lambda (a) (patom " ") (patom a) )
167: (cdddr (arg 1)))
168: (terpr)))
169: (setq ER%all 'debug-err-handler)
170: (do ((retval)) (nil)
171: (cond ((dtpr
172: (setq retval
173: (errset
174: (do ((form)) (nil)
175: (patom "D<")
176: (patom debug-level-count)
177: (patom ">: ")
178: (cond ((eq top-level-eof
179: (setq form
180: (top-read nil
181: top-level-eof)))
182: (cond ((null (status isatty))
183: (exit)))
184: (return nil))
185: ((and (dtpr form)
186: (eq 'return
187: (car form)))
188: (return (eval (cadr form))))
189: (t (setq form (top-eval form))
190: (top-print form)
191: (terpr)))))))
192: (return (car retval))))))
193: nil
194: (add1 debug-level-count)
195: nil
196: nil
197: nil)))
198:
199: ; this is the break handler, it should be tied to
200: ; ER%tpl always.
201: ; it is entered if there is an error which no one wants to handle.
202: ; We loop forever, printing out our error level until someone
203: ; types a ^D which goes to the next break level above us (or the
204: ; top-level if there are no break levels above us.
205: ; a (return n) will return that value to the error message
206: ; which called us, if that is possible (that is if the error is
207: ; continuable)
208: ;
209: (def break-err-handler
210: (lexpr (n)
211: ((lambda (message break-level-count retval rettype ^w piport)
212: (cond ((greaterp n 0)
213: (print 'Error:)
214: (mapc '(lambda (a) (patom " ") (patom a) )
215: (cdddr (arg 1)))
216: (terpr)
217: (cond ((caddr (arg 1)) (setq rettype 'contuab))
218: (t (setq rettype nil))))
219: (t (setq rettype 'localcall)))
220:
221: (do nil (nil)
222: (cond ((dtpr
223: (setq retval
224: (*catch 'break-catch
225: (do ((form)) (nil)
226: (patom "<")
227: (patom break-level-count)
228: (patom ">: ")
229: (cond ((eq top-level-eof
230: (setq form
231: (top-read
232: nil
233: top-level-eof)))
234: (cond ((null (status isatty))
235: (exit)))
236: (eval 1) ; force interrupt check
237: (return (sub1 break-level-count)))
238: ((and (dtpr form)
239: (eq 'return (car form)))
240: (cond ((or (eq rettype 'contuab)
241: (eq rettype 'localcall))
242: (return (ncons (top-eval (cadr form)))))
243: (t (patom "Can't continue from this error")
244: (terpr))))
245: ((and (dtpr form) (eq 'retbrk (car form)))
246: (cond ((numberp (setq form (top-eval (cadr form))))
247: (return form))
248: (t (return (sub1 break-level-count)))))
249: (t (setq form (top-eval form))
250: (top-print form)
251: (terpr)))))))
252: (return (cond ((eq rettype 'localcall)
253: (car retval))
254: (t retval))))
255: ((lessp retval break-level-count)
256: (setq tpl-errlist errlist)
257: (*throw 'break-catch retval))
258: (t (terpr)))))
259: nil
260: (add1 break-level-count)
261: nil
262: nil
263: nil
264: nil)))
265:
266: (defvar debug-error-handler 'debug-err-handler) ; name of function to get
267: ; control on ER%all error
268: (def debugging
269: (lambda (val)
270: (cond (val (setq ER%all debug-error-handler)
271: (sstatus translink nil)
272: (*rset t))
273: (t (setq ER%all nil)))))
274:
275:
276: ; the problem with this definition for break is that we are
277: ; forced to put an errset around the break-err-handler. This means
278: ; that we will never get break errors, since all errors will be
279: ; caught by our errset (better ours than one higher up though).
280: ; perhaps the solution is to automatically turn debugmode on.
281: ;
282: (defmacro break (message &optional (pred t))
283: `(*break ,pred ',message))
284:
285: (def *break
286: (lambda (pred message)
287: (let ((^w nil))
288: (cond ((not (boundp 'break-level-count)) (setq break-level-count 1)))
289: (cond (pred (terpr)
290: (patom "Break ")
291: (patom message)
292: (terpr)
293: (do ((form))
294: (nil)
295: (cond ((dtpr (setq form (errset (break-err-handler))))
296: (return (car form))))))))))
297:
298:
299: ; this reset function is designed to work with the franz-top-level.
300: ; When franz-top-level begins, it makes franz-reset be reset.
301: ; when a reset occurs now, we set the global variable tpl-errlist to
302: ; the current value of errlist and throw to top level. At top level,
303: ; then tpl-errlist will be evaluated.
304: ;
305: (def franz-reset
306: (lambda nil
307: (setq tpl-errlist errlist)
308: (errset (*throw 'top-level-catch 'reset)
309: nil)
310: (old-reset-function)))
311:
312:
313: (declare (special $ldprint))
314:
315: ;--- read-in-lisprc-file
316: ; search for a lisp init file. Look first in . then in $HOME
317: ; look first for .o , then .l and then "",
318: ; look for file bodies .lisprc and then lisprc
319: ;
320: (def read-in-lisprc-file
321: (lambda nil
322: (setq break-level-count 0 ; do this in case break
323: debug-level-count 0) ; occurs during readin
324: (*catch '(break-catch top-level-catch)
325: (do ((dirs `("." ,(getenv 'HOME)) (cdr dirs))
326: ($ldprint nil $ldprint)) ; prevent messages
327: ((null dirs))
328: (cond ((do ((name '(".lisprc" "lisprc") (cdr name)))
329: ((null name))
330: (cond ((do ((ext '(".o" ".l" "") (cdr ext))
331: (file))
332: ((null ext))
333: (cond ((probef
334: (setq file
335: (concat (car dirs)
336: "/"
337: (car name)
338: (car ext))))
339: (cond ((atom (errset (load file)))
340: (patom
341: "Error loading lisp init file ")
342: (print file)
343: (terpr)
344: (return 'error)))
345: (return t))))
346: (return t))))
347: (return t)))))))
348:
349: (putd 'top-level (getd 'franz-top-level))
350:
351: ; if this is the first time this file has been read in, then
352: ; make franz-reset be the reset function, but remember the original
353: ; reset function as old-reset-function. We need the old reset function
354: ; if we are going to allow the user to change top-levels, for in
355: ; order to do that we really have to jump all the way up to the top.
356: (cond ((null (getd 'old-reset-function))
357: (putd 'old-reset-function (getd 'reset))))
358:
359:
360: ;---- autoloader functions
361:
362: (def undef-func-handler
363: (lambda (args)
364: (prog (funcnam file)
365: (setq funcnam (caddddr args))
366: (cond ((symbolp funcnam)
367: (cond ((setq file (or (get funcnam 'autoload)
368: (get funcnam 'macro-autoload)))
369: (cond ($ldprint
370: (patom "[autoload ") (patom file)
371: (patom "]")(terpr)))
372: (load file))
373: (t (return nil)))
374: (cond ((getd funcnam) (return (ncons funcnam)))
375: (t (patom "Autoload file " ) (print file)
376: (patom " does not contain function ")
377: (print funcnam)
378: (terpr)
379: (return nil))))))))
380:
381: (setq ER%undef 'undef-func-handler)
382:
383: (declare (special $ldprint))
384: ;--- autorunlisp :: check if this lisp is supposed to run a program right
385: ; away.
386: ;
387: (defun autorunlisp nil
388: (cond ((and (> (argv -1) 2) (equal (argv 1) '-f))
389: (let ((progname (argv 2))
390: ($ldprint nil)
391: (searchlist nil)) ; don't give fasl messages
392: (setq searchlist (cvtsearchpathtolist (getenv 'PATH)))
393: ; give two args to load to insure that a fasl is done.
394: (cond ((null
395: (errset (load-autorunobject progname searchlist)))
396: (exit 0))
397: (t t))))))
398:
399:
400: (defun cvtsearchpathtolist (path)
401: (do ((x (explodec path) (cdr x))
402: (names nil)
403: (cur nil))
404: ((null x)
405: (nreverse names))
406: (cond ((or (eq ': (car x))
407: (and (null (cdr x)) (setq cur (cons (car x) cur))))
408: (cond (cur (setq names (cons (implode (nreverse cur))
409: names))
410: (setq cur nil))
411: (t (setq names (cons '|.| names)))))
412: (t (setq cur (cons (car x) cur))))))
413:
414: (defun load-autorunobject (name search)
415: (cond ((memq (getchar name 1) '(/ |.|))
416: (cond ((probef name) (fasl name))
417: (t (error "From lisp autorun: can't find file to load"))))
418: (t (do ((xx search (cdr xx))
419: (fullname))
420: ((null xx) (error "Can't find file to execute "))
421: (cond ((probef (setq fullname (concat (car xx) "/" name)))
422: (return (fasl-a-file fullname nil nil))))))))
423:
424: ;--- command-line-args :: return a list of the command line arguments
425: ; The list does not include the name of the program being executed (argv 0).
426: ; It also doesn't include the autorun flag and arg.
427: ;
428: (defun command-line-args ()
429: (do ((res nil (cons (argv i) res))
430: (i (1- (argv -1)) (1- i)))
431: ((<& i 1)
432: (if (and (eq '-f (car res))
433: (cdr res))
434: then (cddr res)
435: else res))))
436:
437: (defun debug fexpr (args)
438: (load 'fix) ; load in fix package
439: (eval (cons 'debug args))) ; enter debug through eval
440:
441: ;-- default autoloader properties
442:
443: (putprop 'trace (concat lisp-library-directory "/trace") 'autoload)
444: (putprop 'untrace (concat lisp-library-directory "/trace") 'autoload)
445:
446: (putprop 'step (concat lisp-library-directory "/step") 'autoload)
447: (putprop 'editf (concat lisp-library-directory "/cmuedit") 'autoload)
448: (putprop 'editv (concat lisp-library-directory "/cmuedit") 'autoload)
449: (putprop 'editp (concat lisp-library-directory "/cmuedit") 'autoload)
450: (putprop 'edite (concat lisp-library-directory "/cmuedit") 'autoload)
451:
452: (putprop 'defstruct (concat lisp-library-directory "/struct") 'macro-autoload)
453: (putprop 'defstruct-expand-ref-macro
454: (concat lisp-library-directory "/struct") 'autoload)
455: (putprop 'defstruct-expand-cons-macro
456: (concat lisp-library-directory "/struct") 'autoload)
457: (putprop 'defstruct-expand-alter-macro
458: (concat lisp-library-directory "/struct") 'autoload)
459:
460: (putprop 'loop (concat lisp-library-directory "/loop") 'macro-autoload)
461: (putprop 'defflavor
462: (concat lisp-library-directory "/flavors") 'macro-autoload)
463: (putprop 'defflavor1
464: (concat lisp-library-directory "/flavors") 'autoload)
465:
466: (putprop 'format (concat lisp-library-directory "/format") 'autoload)
467: (putprop 'ferror (concat lisp-library-directory "/format") 'autoload)
468:
469: (putprop 'make-hash-table
470: (concat lisp-library-directory "/hash") 'autoload)
471: (putprop 'make-equal-hash-table
472: (concat lisp-library-directory "/hash") 'autoload)
473:
474: (putprop 'describe (concat lisp-library-directory "/describe") 'autoload)
475:
476: (putprop 'cgol (concat lisp-library-directory "/cgol/cgoll") 'autoload)
477: (putprop 'cgolprint (concat lisp-library-directory "/cgol/cgp") 'autoload)
478:
479: ; probably should be in franz so we don't have to autoload
480: (putprop 'displace (concat lisp-library-directory "/machacks") 'autoload)
481:
482: (putprop 'defrecord (concat lisp-library-directory "/record") 'macro-autoload)
483: (putprop 'record-pkg-construct
484: (concat lisp-library-directory "/record") 'autoload)
485: (putprop 'record-pkg-access
486: (concat lisp-library-directory "/record") 'autoload)
487: (putprop 'record-pkg-illegal-access
488: (concat lisp-library-directory "/record") 'autoload)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.