![[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] / 40BSD / cmd / liszt|
Return to toplevel.l CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / liszt |
1.1 root 1:
2: ; special atoms:
3: (declare (special debug-level-count break-level-count
4: errlist tpl-errlist user-top-level
5: top-level-eof * - ^w)
6: (macros t))
7:
8: (setq top-level-eof (gensym 'Q)
9: tpl-errlist nil
10: errlist nil
11: user-top-level nil )
12:
13: ;------------------------------------------------------
14: ; Top level function for franz jkf, march 1980
15: ;
16: ; The following function contains the top-level read, eval, print
17: ; loop. With the help of the error handling functions,
18: ; break-err-handler and debug-err-handler, franz-top-level provides
19: ; a reasonable enviroment for working with franz lisp.
20: ;
21:
22: (def franz-top-level
23: (lambda nil
24: (cond ((or (not (boundp 'franz-not-virgin))
25: (null franz-not-virgin))
26: (patom (status version))
27: (setq franz-not-virgin t)
28: (setq ER%tpl 'break-err-handler)
29: (putd 'reset (getd 'franz-reset))
30: (terpr)
31: (read-in-lisprc-file)))
32:
33: ; loop forever
34: (do nil (nil)
35: (setq retval
36: (*catch
37: '(top-level-catch break-catch)
38: ; begin or return to top level
39: (progn
40: (setq debug-level-count 0 break-level-count 0)
41: (cond (tpl-errlist (mapc 'eval tpl-errlist)))
42: (do ((^w nil nil))
43: (nil)
44: (cond (user-top-level (funcall user-top-level))
45: (t (patom "-> ")
46: (cond ((eq top-level-eof
47: (setq -
48: (car (errset (read nil
49: top-level-eof)))))
50: (cond ((not (status isatty))
51: (exit)))
52: (cond ((null (status ignoreeof))
53: (terpr)
54: (print 'Goodbye)
55: (terpr)
56: (exit))
57: (t (terpr)
58: (setq - ''EOF)))))
59: (setq * (eval -))
60: (print *)
61: (terpr)))))))
62: (terpr)
63: (patom "[Return to top level]")
64: (terpr)
65: (cond ((eq 'reset retval) (old-reset-function))))))
66:
67:
68: ; debug-err-handler is the clb of ER%all when we are doing debugging
69: ; and we want to catch all errors.
70: ; It is just a read eval print loop with errset.
71: ; the only way to leave is:
72: ; (reset) just back to top level
73: ; (return x) return the value, if possible
74: ; ^D continue as if this handler wasn't called.
75: ; the form of errmsgs is:
76: ; (error_type unique_id continuable message_string other_args ...)
77: ;
78: (def debug-err-handler
79: (lexpr (n)
80: ((lambda (message debug-level-count retval ^w)
81: (cond ((greaterp n 0)
82: (print 'Error:)
83: (mapc '(lambda (a) (patom " ") (patom a) )
84: (cdddr (arg 1)))
85: (terpr)))
86: (setq ER%all 'debug-err-handler)
87: (do nil (nil)
88: (cond ((setq retval
89: (dtpr
90: (errset
91: (do ((form)) (nil)
92: (patom "D<")
93: (patom debug-level-count)
94: (patom ">: ")
95: (cond ((eq top-level-eof
96: (setq form (read nil top-level-eof)))
97: (cond ((null (status isatty))
98: (exit)))
99: (return nil))
100: ((and (dtpr form)
101: (eq 'return (car form)))
102: (cond ((caddr errmsgs)
103: (return (ncons (eval (cadr form)))))
104: (t (patom "Can't continue from this error"))))
105: (t (print (eval form))
106: (terpr)))))))
107: (return (car retval))))))
108: nil
109: (add1 debug-level-count)
110: nil
111: nil)))
112:
113: ; this is the break handler, it should be tied to
114: ; ER%tpl always.
115: ; it is entered if there is an error which no one wants to handle.
116: ; We loop forever, printing out our error level until someone
117: ; types a ^D which goes to the next break level above us (or the
118: ; top-level if there are no break levels above us.
119: ; a (return n) will return that value to the error message
120: ; which called us, if that is possible (that is if the error is
121: ; continuable)
122: ;
123: (def break-err-handler
124: (lexpr (n)
125: ((lambda (message break-level-count retval rettype ^w)
126: (setq piport nil)
127: (cond ((greaterp n 0)
128: (print 'Error:)
129: (mapc '(lambda (a) (patom " ") (patom a) )
130: (cdddr (arg 1)))
131: (terpr)
132: (cond ((caddr (arg 1)) (setq rettyp 'contuab))
133: (t (setq rettyp nil))))
134: (t (setq rettyp 'localcall)))
135:
136: (do nil (nil)
137: (cond ((dtpr
138: (setq retval
139: (*catch 'break-catch
140: (do ((form)) (nil)
141: (patom "<")
142: (patom break-level-count)
143: (patom ">: ")
144: (cond ((eq top-level-eof
145: (setq form (read nil top-level-eof)))
146: (cond ((null (status isatty))
147: (exit)))
148: (eval 1) ; force interrupt check
149: (return (sub1 break-level-count)))
150: ((and (dtpr form) (eq 'return (car form)))
151: (cond ((or (eq rettyp 'contuab)
152: (eq rettyp 'localcall))
153: (return (ncons (eval (cadr form)))))
154: (t (patom "Can't continue from this error")
155: (terpr))))
156: ((and (dtpr form) (eq 'retbrk (car form)))
157: (cond ((numberp (setq form (eval (cadr form))))
158: (return form))
159: (t (return (sub1 break-level-count)))))
160: (t (print (eval form))
161: (terpr)))))))
162: (return (cond ((eq rettype 'localcall)
163: (car retval))
164: (t retval))))
165: ((lessp retval break-level-count)
166: (setq tpl-errlist errlist)
167: (*throw 'break-catch retval))
168: (t (terpr)))))
169: nil
170: (add1 break-level-count)
171: nil
172: nil
173: nil)))
174:
175: (def debugging
176: (lambda (val)
177: (cond (val (setq ER%all 'debug-err-handler))
178: (t (setq ER%all nil)))))
179:
180:
181: ; the problem with this definition for break is that we are
182: ; forced to put an errset around the break-err-handler. This means
183: ; that we will never get break errors, since all errors will be
184: ; caught by our errset (better ours than one higher up though).
185: ; perhaps the solution is to automatically turn debugmode on.
186: ;
187: (defmacro break (message &optional (pred t))
188: `(*break ,pred ',message))
189:
190: (def *break
191: (lambda (pred message)
192: (let ((^w nil))
193: (cond ((not (boundp 'break-level-count)) (setq break-level-count 1)))
194: (cond (pred (terpr)
195: (patom "Break ")
196: (patom message)
197: (terpr)
198: (do ((form))
199: (nil)
200: (cond ((dtpr (setq form (errset (break-err-handler))))
201: (return (car form))))))))))
202:
203:
204: ; this reset function is designed to work with the franz-top-level.
205: ; When franz-top-level begins, it makes franz-reset be reset.
206: ; when a reset occurs now, we set the global variable tpl-errlist to
207: ; the current value of errlist and throw to top level. At top level,
208: ; then tpl-errlist will be evaluated.
209: ;
210: (def franz-reset
211: (lambda nil
212: (setq tpl-errlist errlist)
213: (errset (*throw 'top-level-catch 'reset)
214: nil)
215: (old-reset-function)))
216:
217:
218: ; this definition will have to do until we have the ability to
219: ; cause and error on any channel in franz
220: (def error
221: (lexpr (n)
222: (cond ((greaterp n 0)
223: (patom (arg 1))
224:
225: (cond ((greaterp n 1)
226: (patom " ")
227: (patom (arg 2))))
228: (terpr)))
229: (err)))
230:
231:
232: ; this file is read in just before dumplisping if you want .lisprc
233: ; from your home directory read in before the lisp begins.
234: (def read-in-lisprc-file
235: (lambda nil
236: ((lambda (hom prt)
237: (setq break-level-count 0 ; do this in case break
238: debug-level-count 0) ; occurs during readin
239: (*catch '(break-catch top-level-catch)
240: (cond (hom
241: (cond ((and
242: (errset
243: (progn
244: (setq prt (infile (concat hom '"/.lisprc")))
245: (close prt))
246: nil)
247: (null (errset
248: (load (concat hom '"/.lisprc")))))
249: (patom '"Error in .lisprc file detected")
250: (terpr)))))))
251: (getenv 'HOME) nil)))
252:
253: (putd 'top-level (getd 'franz-top-level))
254:
255: ; if this is the first time this file has been read in, then
256: ; make franz-reset be the reset function, but remember the original
257: ; reset function as old-reset-function. We need the old reset function
258: ; if we are going to allow the user to change top-levels, for in
259: ; order to do that we really have to jump all the way up to the top.
260: (cond ((null (getd 'old-reset-function))
261: (putd 'old-reset-function (getd 'reset))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.