Return to handlers.l CVS log

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

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

1.1     ! root        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) 5/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: 

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.