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) 05/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 160