![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to handlers.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 handlers.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-handlers.l "@(#)handlers.l 5.1 (Berkeley) 5/31/85")
10:
11: ;; Handlers snarfed from FRANZ
12:
13: ; special atoms:
14: (declare (special debug-level-count break-level-count
15: errlist tpl-errlist user-top-level
16: franz-not-virgin piport ER%tpl ER%all
17: $ldprint ptport infile
18: top-level-eof * ** *** + ++ +++ ^w)
19: (macros t))
20:
21: (eval-when (compile eval load)
22: (or (get 'fpMacs 'loaded) (load 'fpMacs)))
23:
24:
25: ; this is the break handler, it should be tied to
26: ; ER%tpl always.
27: ; it is entered if there is an error which no one wants to handle.
28: ; We loop forever, printing out our error level until someone
29: ; types a ^D which goes to the next break level above us (or the
30: ; top-level if there are no break levels above us.
31: ; a (return n) will return that value to the error message
32: ; which called us, if that is possible (that is if the error is
33: ; continuable)
34: ;
35: (def break-err-handler
36: (lexpr (n)
37: ((lambda (message break-level-count retval rettype ^w)
38: (setq piport nil)
39: (cond ((greaterp n 0)
40: (cond ((eq (cadddr (arg 1)) '|NAMESTACK OVERFLOW|)
41:
42: (msg N "non-terminating" (N 2) '? N)
43: (cond
44: (ptport
45: (let ((scriptName (truename ptport)))
46: (resetio)
47: (setq ptport (outfile scriptName 'append))
48: (cond ((null ptport)
49: (msg "can't reopen script-file "
50: scriptName
51: N))))))
52: (and (null ptport) (resetio))
53: (reset)))
54: (print 'Error:)
55: (mapc '(lambda (a) (patom " ") (patom a) )
56: (cdddr (arg 1)))
57: (terpr)
58: (cond ((caddr (arg 1)) (setq rettype 'contuab))
59: (t (setq rettype nil))))
60: (t (setq rettype 'localcall)))
61:
62: (do nil (nil)
63: (cond ((dtpr
64: (setq
65: retval
66: (*catch
67: 'break-catch
68: (do ((form)) (nil)
69: (patom "<")
70: (patom break-level-count)
71: (patom ">: ")
72: (cond ((eq top-level-eof
73: (setq form (read nil top-level-eof)))
74: (cond ((null (status isatty))
75: (exit)))
76: (eval 1) ; force interrupt check
77: (return (sub1 break-level-count)))
78: ((and (dtpr form) (eq 'return (car form)))
79: (cond ((or (eq rettype 'contuab)
80: (eq rettype 'localcall))
81: (return (ncons (eval (cadr form)))))
82: (t (patom "Can't continue from this error")
83: (terpr))))
84: ((and (dtpr form) (eq 'retbrk (car form)))
85: (cond ((numberp (setq form (eval (cadr form))))
86: (return form))
87: (t (return (sub1 break-level-count)))))
88: (t (print (eval form))
89: (terpr)))))))
90: (return (cond ((eq rettype 'localcall)
91: (car retval))
92: (t retval))))
93: ((lessp retval break-level-count)
94: (setq tpl-errlist errlist)
95: (*throw 'break-catch retval))
96: (t (terpr)))))
97: nil
98: (add1 break-level-count)
99: nil
100: nil
101: nil)))
102:
103:
104:
105: ; this reset function is designed to work with the franz-top-level.
106: ; When franz-top-level begins, it makes franz-reset be reset.
107: ; when a reset occurs now, we set the global variable tpl-errlist to
108: ; the current value of errlist and throw to top level. At top level,
109: ; then tpl-errlist will be evaluated.
110: ;
111: (def franz-reset
112: (lambda nil
113: (setq tpl-errlist errlist)
114: (errset (*throw 'top-level-catch '?)
115: nil)
116: (old-reset-function)))
117:
118:
119:
120: ;---- autoloader functions
121:
122:
123: (def undef-func-handler
124: (lambda (args)
125: (prog (funcnam file n)
126: (setq funcnam (caddddr args))
127: (setq n (nreverse (explode (setq funcnam (caddddr args)))))
128: (cond ((and (not (greaterp 4 (length n)))
129: (eq 'pf_ (implode `(,(car n) ,(cadr n) ,(caddr n)))))
130: (cond ((and ptport (null infile)) (terpri ptport)))
131: (msg N (implode (nreverse (cdddr n))) " not defined"
132: N)
133: (bottom))
134: (t
135: (cond ((symbolp funcnam)
136: (cond ((setq file (get funcnam 'autoload))
137: (cond ($ldprint
138: (patom "[autoload ") (patom file)
139: (patom "]")(terpr)))
140: (load file))
141: (t (return nil)))
142: (cond ((getd funcnam) (return (ncons funcnam)))
143: (t (patom "Autoload file does not contain func ")
144: (return nil))))))))))
145:
146:
147:
148: (defun break-resp (x) ; reset on a break (handled like inf recursion)
149: (msg (N 2) " [break]" (N 2) '? N)
150: (cond
151: (ptport
152: (let ((scriptName (truename ptport)))
153: (resetio)
154: (setq ptport (outfile scriptName 'append))
155: (cond ((null ptport)
156: (msg "can't reopen script-file " scriptName N))))))
157: (and (null ptport) (resetio))
158: (reset))
159:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.