![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to toplevel.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 40BSD / cmd / liszt|
Return to toplevel.l CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / liszt |
1.1 ! root 1: ! 2: ; special atoms: ! 3: (declare (special debug-level-count break-level-count ! 4: errlist tpl-errlist user-top-level ! 5: top-level-eof * - ^w) ! 6: (macros t)) ! 7: ! 8: (setq top-level-eof (gensym 'Q) ! 9: tpl-errlist nil ! 10: errlist nil ! 11: user-top-level nil ) ! 12: ! 13: ;------------------------------------------------------ ! 14: ; Top level function for franz jkf, march 1980 ! 15: ; ! 16: ; The following function contains the top-level read, eval, print ! 17: ; loop. With the help of the error handling functions, ! 18: ; break-err-handler and debug-err-handler, franz-top-level provides ! 19: ; a reasonable enviroment for working with franz lisp. ! 20: ; ! 21: ! 22: (def franz-top-level ! 23: (lambda nil ! 24: (cond ((or (not (boundp 'franz-not-virgin)) ! 25: (null franz-not-virgin)) ! 26: (patom (status version)) ! 27: (setq franz-not-virgin t) ! 28: (setq ER%tpl 'break-err-handler) ! 29: (putd 'reset (getd 'franz-reset)) ! 30: (terpr) ! 31: (read-in-lisprc-file))) ! 32: ! 33: ; loop forever ! 34: (do nil (nil) ! 35: (setq retval ! 36: (*catch ! 37: '(top-level-catch break-catch) ! 38: ; begin or return to top level ! 39: (progn ! 40: (setq debug-level-count 0 break-level-count 0) ! 41: (cond (tpl-errlist (mapc 'eval tpl-errlist))) ! 42: (do ((^w nil nil)) ! 43: (nil) ! 44: (cond (user-top-level (funcall user-top-level)) ! 45: (t (patom "-> ") ! 46: (cond ((eq top-level-eof ! 47: (setq - ! 48: (car (errset (read nil ! 49: top-level-eof))))) ! 50: (cond ((not (status isatty)) ! 51: (exit))) ! 52: (cond ((null (status ignoreeof)) ! 53: (terpr) ! 54: (print 'Goodbye) ! 55: (terpr) ! 56: (exit)) ! 57: (t (terpr) ! 58: (setq - ''EOF))))) ! 59: (setq * (eval -)) ! 60: (print *) ! 61: (terpr))))))) ! 62: (terpr) ! 63: (patom "[Return to top level]") ! 64: (terpr) ! 65: (cond ((eq 'reset retval) (old-reset-function)))))) ! 66: ! 67: ! 68: ; debug-err-handler is the clb of ER%all when we are doing debugging ! 69: ; and we want to catch all errors. ! 70: ; It is just a read eval print loop with errset. ! 71: ; the only way to leave is: ! 72: ; (reset) just back to top level ! 73: ; (return x) return the value, if possible ! 74: ; ^D continue as if this handler wasn't called. ! 75: ; the form of errmsgs is: ! 76: ; (error_type unique_id continuable message_string other_args ...) ! 77: ; ! 78: (def debug-err-handler ! 79: (lexpr (n) ! 80: ((lambda (message debug-level-count retval ^w) ! 81: (cond ((greaterp n 0) ! 82: (print 'Error:) ! 83: (mapc '(lambda (a) (patom " ") (patom a) ) ! 84: (cdddr (arg 1))) ! 85: (terpr))) ! 86: (setq ER%all 'debug-err-handler) ! 87: (do nil (nil) ! 88: (cond ((setq retval ! 89: (dtpr ! 90: (errset ! 91: (do ((form)) (nil) ! 92: (patom "D<") ! 93: (patom debug-level-count) ! 94: (patom ">: ") ! 95: (cond ((eq top-level-eof ! 96: (setq form (read nil top-level-eof))) ! 97: (cond ((null (status isatty)) ! 98: (exit))) ! 99: (return nil)) ! 100: ((and (dtpr form) ! 101: (eq 'return (car form))) ! 102: (cond ((caddr errmsgs) ! 103: (return (ncons (eval (cadr form))))) ! 104: (t (patom "Can't continue from this error")))) ! 105: (t (print (eval form)) ! 106: (terpr))))))) ! 107: (return (car retval)))))) ! 108: nil ! 109: (add1 debug-level-count) ! 110: nil ! 111: nil))) ! 112: ! 113: ; this is the break handler, it should be tied to ! 114: ; ER%tpl always. ! 115: ; it is entered if there is an error which no one wants to handle. ! 116: ; We loop forever, printing out our error level until someone ! 117: ; types a ^D which goes to the next break level above us (or the ! 118: ; top-level if there are no break levels above us. ! 119: ; a (return n) will return that value to the error message ! 120: ; which called us, if that is possible (that is if the error is ! 121: ; continuable) ! 122: ; ! 123: (def break-err-handler ! 124: (lexpr (n) ! 125: ((lambda (message break-level-count retval rettype ^w) ! 126: (setq piport nil) ! 127: (cond ((greaterp n 0) ! 128: (print 'Error:) ! 129: (mapc '(lambda (a) (patom " ") (patom a) ) ! 130: (cdddr (arg 1))) ! 131: (terpr) ! 132: (cond ((caddr (arg 1)) (setq rettyp 'contuab)) ! 133: (t (setq rettyp nil)))) ! 134: (t (setq rettyp 'localcall))) ! 135: ! 136: (do nil (nil) ! 137: (cond ((dtpr ! 138: (setq retval ! 139: (*catch 'break-catch ! 140: (do ((form)) (nil) ! 141: (patom "<") ! 142: (patom break-level-count) ! 143: (patom ">: ") ! 144: (cond ((eq top-level-eof ! 145: (setq form (read nil top-level-eof))) ! 146: (cond ((null (status isatty)) ! 147: (exit))) ! 148: (eval 1) ; force interrupt check ! 149: (return (sub1 break-level-count))) ! 150: ((and (dtpr form) (eq 'return (car form))) ! 151: (cond ((or (eq rettyp 'contuab) ! 152: (eq rettyp 'localcall)) ! 153: (return (ncons (eval (cadr form))))) ! 154: (t (patom "Can't continue from this error") ! 155: (terpr)))) ! 156: ((and (dtpr form) (eq 'retbrk (car form))) ! 157: (cond ((numberp (setq form (eval (cadr form)))) ! 158: (return form)) ! 159: (t (return (sub1 break-level-count))))) ! 160: (t (print (eval form)) ! 161: (terpr))))))) ! 162: (return (cond ((eq rettype 'localcall) ! 163: (car retval)) ! 164: (t retval)))) ! 165: ((lessp retval break-level-count) ! 166: (setq tpl-errlist errlist) ! 167: (*throw 'break-catch retval)) ! 168: (t (terpr))))) ! 169: nil ! 170: (add1 break-level-count) ! 171: nil ! 172: nil ! 173: nil))) ! 174: ! 175: (def debugging ! 176: (lambda (val) ! 177: (cond (val (setq ER%all 'debug-err-handler)) ! 178: (t (setq ER%all nil))))) ! 179: ! 180: ! 181: ; the problem with this definition for break is that we are ! 182: ; forced to put an errset around the break-err-handler. This means ! 183: ; that we will never get break errors, since all errors will be ! 184: ; caught by our errset (better ours than one higher up though). ! 185: ; perhaps the solution is to automatically turn debugmode on. ! 186: ; ! 187: (defmacro break (message &optional (pred t)) ! 188: `(*break ,pred ',message)) ! 189: ! 190: (def *break ! 191: (lambda (pred message) ! 192: (let ((^w nil)) ! 193: (cond ((not (boundp 'break-level-count)) (setq break-level-count 1))) ! 194: (cond (pred (terpr) ! 195: (patom "Break ") ! 196: (patom message) ! 197: (terpr) ! 198: (do ((form)) ! 199: (nil) ! 200: (cond ((dtpr (setq form (errset (break-err-handler)))) ! 201: (return (car form)))))))))) ! 202: ! 203: ! 204: ; this reset function is designed to work with the franz-top-level. ! 205: ; When franz-top-level begins, it makes franz-reset be reset. ! 206: ; when a reset occurs now, we set the global variable tpl-errlist to ! 207: ; the current value of errlist and throw to top level. At top level, ! 208: ; then tpl-errlist will be evaluated. ! 209: ; ! 210: (def franz-reset ! 211: (lambda nil ! 212: (setq tpl-errlist errlist) ! 213: (errset (*throw 'top-level-catch 'reset) ! 214: nil) ! 215: (old-reset-function))) ! 216: ! 217: ! 218: ; this definition will have to do until we have the ability to ! 219: ; cause and error on any channel in franz ! 220: (def error ! 221: (lexpr (n) ! 222: (cond ((greaterp n 0) ! 223: (patom (arg 1)) ! 224: ! 225: (cond ((greaterp n 1) ! 226: (patom " ") ! 227: (patom (arg 2)))) ! 228: (terpr))) ! 229: (err))) ! 230: ! 231: ! 232: ; this file is read in just before dumplisping if you want .lisprc ! 233: ; from your home directory read in before the lisp begins. ! 234: (def read-in-lisprc-file ! 235: (lambda nil ! 236: ((lambda (hom prt) ! 237: (setq break-level-count 0 ; do this in case break ! 238: debug-level-count 0) ; occurs during readin ! 239: (*catch '(break-catch top-level-catch) ! 240: (cond (hom ! 241: (cond ((and ! 242: (errset ! 243: (progn ! 244: (setq prt (infile (concat hom '"/.lisprc"))) ! 245: (close prt)) ! 246: nil) ! 247: (null (errset ! 248: (load (concat hom '"/.lisprc"))))) ! 249: (patom '"Error in .lisprc file detected") ! 250: (terpr))))))) ! 251: (getenv 'HOME) nil))) ! 252: ! 253: (putd 'top-level (getd 'franz-top-level)) ! 254: ! 255: ; if this is the first time this file has been read in, then ! 256: ; make franz-reset be the reset function, but remember the original ! 257: ; reset function as old-reset-function. We need the old reset function ! 258: ; if we are going to allow the user to change top-levels, for in ! 259: ; order to do that we really have to jump all the way up to the top. ! 260: (cond ((null (getd 'old-reset-function)) ! 261: (putd 'old-reset-function (getd 'reset))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.