Return to handlers.l CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / fp

Annotation of 42BSD/ucb/fp/handlers.l, revision 1.1

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.