1 (setq SCCS-handlers.l "@(#)handlers.l 1.1 04/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 155