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