; FP interpreter/compiler
; Copyright (c) 1982 Scott B. Baden
; Copyright (c) 1982 Regents of the University of California.
; All rights reserved. The Berkeley software License Agreement
; specifies the terms and conditions for redistribution.
(setq SCCS-handlers.l "@(#)handlers.l 5.1 (Berkeley) 5/31/85")
;; Handlers snarfed from FRANZ
(declare (special debug-level-count break-level-count
errlist tpl-errlist user-top-level
franz-not-virgin piport ER%tpl ER%all
top-level-eof * ** *** + ++ +++ ^w)
(eval-when (compile eval load)
(or (get 'fpMacs 'loaded) (load 'fpMacs)))
; this is the break handler, it should be tied to
; it is entered if there is an error which no one wants to handle.
; We loop forever, printing out our error level until someone
; types a ^D which goes to the next break level above us (or the
; top-level if there are no break levels above us.
; a (return n) will return that value to the error message
; which called us, if that is possible (that is if the error is
((lambda (message break-level-count retval rettype ^w)
(cond ((eq (cadddr (arg 1)) '|NAMESTACK OVERFLOW|)
(msg N "non-terminating" (N 2) '? N)
(let ((scriptName (truename ptport)))
(setq ptport (outfile scriptName 'append))
(msg "can't reopen script-file "
(and (null ptport) (resetio))
(mapc '(lambda (a) (patom " ") (patom a) )
(cond ((caddr (arg 1)) (setq rettype 'contuab))
(t (setq rettype 'localcall)))
(patom break-level-count)
(setq form (read nil top-level-eof)))
(cond ((null (status isatty))
(eval 1) ; force interrupt check
(return (sub1 break-level-count)))
((and (dtpr form) (eq 'return (car form)))
(cond ((or (eq rettype 'contuab)
(return (ncons (eval (cadr form)))))
(t (patom "Can't continue from this error")
((and (dtpr form) (eq 'retbrk (car form)))
(cond ((numberp (setq form (eval (cadr form))))
(t (return (sub1 break-level-count)))))
(return (cond ((eq rettype 'localcall)
((lessp retval break-level-count)
(setq tpl-errlist errlist)
(*throw 'break-catch retval))
; this reset function is designed to work with the franz-top-level.
; When franz-top-level begins, it makes franz-reset be reset.
; when a reset occurs now, we set the global variable tpl-errlist to
; the current value of errlist and throw to top level. At top level,
; then tpl-errlist will be evaluated.
(setq tpl-errlist errlist)
(errset (*throw 'top-level-catch '?)
;---- autoloader functions
(setq funcnam (caddddr args))
(setq n (nreverse (explode (setq funcnam (caddddr args)))))
(cond ((and (not (greaterp 4 (length n)))
(eq 'pf_ (implode `(,(car n) ,(cadr n) ,(caddr n)))))
(cond ((and ptport (null infile)) (terpri ptport)))
(msg N (implode (nreverse (cdddr n))) " not defined"
(cond ((setq file (get funcnam 'autoload))
(patom "[autoload ") (patom file)
(cond ((getd funcnam) (return (ncons funcnam)))
(t (patom "Autoload file does not contain func ")
(defun break-resp (x) ; reset on a break (handled like inf recursion)
(msg (N 2) "
\a [break]" (N 2) '? N)
(let ((scriptName (truename ptport)))
(setq ptport (outfile scriptName 'append))
(msg "can't reopen script-file " scriptName N))))))
(and (null ptport) (resetio))