![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tpl.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / lisplib|
Return to tpl.l CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / lisplib |
1.1 ! root 1: (setq rcs-tpl- ! 2: "$Header: tpl.l,v 1.4 83/09/04 10:20:03 jkf Exp $") ! 3: ! 4: ; -[Sun Sep 4 10:18:42 1983 by jkf]- ! 5: ; ! 6: ! 7: ; to do ! 8: ; ?state : display status translink, *rset, displace-macros. ! 9: ; current error, prinlevel and prinlength ! 10: ; add a way of modifying the values ! 11: ; ?bk [n] : do a baktrace (default 10 frames from bottom) ! 12: ; ?zo [n] : add an optional number of frames to zoom ! 13: ; ?retf : return value from 'current' frame ! 14: ; ?retry : retry expr in 'current' frame (required mod to lisp). ! 15: ; ! 16: ; the frame re-eval question is not asked when it should. ! 17: ; interact with tracebreaks correctly ! 18: ; ! 19: ; add stepper. ! 20: ; get 'debugging' to work ok. ! 21: ! 22: ;--- state ! 23: ; ! 24: (declare (special tpl-debug-on tpl-step-on ! 25: tpl-top-framelist tpl-bot-framelist ! 26: tpl-eval-flush tpl-trace-flush ! 27: tpl-prinlength tpl-prinlevel ! 28: prinlevel prinlength ! 29: tpl-commands tpl-break-level ! 30: tpl-spec-char ! 31: tpl-last-loaded ! 32: tpl-level ! 33: tpl-fcn-in-eval ! 34: tpl-contuab ! 35: ER%tpl ER%all given-history res-history ! 36: tpl-stack-bad tpl-stack-ok ! 37: tpl-history-count ! 38: tpl-history-show ! 39: tpl-dontshow-tpl ! 40: tpl-step-enable ;; if stepping is on ! 41: tpl-step-print ;; if should print step forms ! 42: tpl-step-triggers ;; list of fcns to enable step ! 43: tpl-step-countdown ;; if positive, then don't break ! 44: tpl-step-reclevel ;; recursion level ! 45: evalhook funcallhook ! 46: *rset % piport ! 47: debug-error-handler ! 48: )) ! 49: ! 50: (putd 'tpl-eval (getd 'eval)) ! 51: (putd 'tpl-funcall (getd 'funcall)) ! 52: (putd 'tpl-evalhook (getd 'evalhook)) ! 53: (putd 'tpl-funcallhook (getd 'funcallhook)) ! 54: ! 55: ! 56: ;--- macros which should be in the system ! 57: ; ! 58: (defmacro evalframe-type (evf) `(car ,evf)) ! 59: (defmacro evalframe-pdl (evf) `(cadr ,evf)) ! 60: (defmacro evalframe-expr (evf) `(caddr ,evf)) ! 61: (defmacro evalframe-bind (evf) `(cadddr ,evf)) ! 62: (defmacro evalframe-np (evf) `(caddddr ,evf)) ! 63: (defmacro evalframe-lbot (evf) `(cadddddr ,evf)) ! 64: ! 65: ! 66: ;; messages are passed between break levels by means of catch and ! 67: ;; throw: ! 68: (defmacro tpl-throw (value) `(*throw 'tpl-break-catch ,value)) ! 69: (defmacro tpl-catch (form) `(*catch 'tpl-break-catch ,form)) ! 70: ! 71: ; A tpl-catch is placed around the prompting and evaluation of forms. ! 72: ; if something abnormal happens in the evaluation, a tpl-throw is done ! 73: ; which then tells the break look that something special should be ! 74: ; done. ! 75: ; ! 76: ; messages: ! 77: ; contbreak - this tells the break level to print out the message ! 78: ; it prints when it is entered (such as the error message). ! 79: ; [see poplevel message]. ! 80: ; poplevel - tells the break level to jump up to the next higher ! 81: ; break level and continue there. It sends contbreak ! 82: ; message to that break level so that it will remind the ! 83: ; user what the state is. [see cmd: ?pop ] ! 84: ; reset - This tells the break level to send a reset to the next ! 85: ; higher break level. Thus a reset is done by successive ! 86: ; small pops. This isn't totally necessary, but it is ! 87: ; clean. ! 88: ; (retbreak v) - return from the break level, returning the value v. ! 89: ; If this an error break, then we return (list v) since ! 90: ; that is required to indicate that an error has been ! 91: ; handled. ! 92: ; (retry v) - instead of asking for a new value, retry the given one. ! 93: ; popretry - take the expression that caused the current break and ! 94: ; send a (retry expr) message to the break level above us ! 95: ; so that it can be tried again. ! 96: ! 97: (setq tpl-eval-flush nil tpl-trace-flush nil ! 98: tpl-prinlevel 3 tpl-prinlength 4 ! 99: tpl-spec-char #/?) ! 100: ! 101: (or (boundp 'tpl-last-loaded) (setq tpl-last-loaded nil)) ! 102: ! 103: (defun tpl nil ! 104: (let ((debug-error-handler 'tpl-err-all-fcn)) ! 105: (setq ER%tpl 'tpl-err-tpl-fcn) ! 106: (putd '*break (getd 'tpl-*break)) ! 107: (setq given-history nil ! 108: res-history nil ! 109: tpl-debug-on nil ! 110: tpl-step-on nil ! 111: tpl-top-framelist nil ! 112: tpl-bot-framelist nil ! 113: tpl-stack-bad t ! 114: tpl-stack-ok nil ! 115: tpl-fcn-in-eval nil ! 116: tpl-level nil ! 117: tpl-history-count 0 ! 118: tpl-break-level -1 ! 119: tpl-dontshow-tpl t ! 120: tpl-history-show 10 ! 121: tpl-step-enable nil ! 122: tpl-step-countdown 0 ! 123: tpl-step-reclevel 0) ! 124: (do ((retv)) ! 125: (nil) ! 126: (setq retv ! 127: (tpl-catch ! 128: (tpl-break-function nil)))))) ! 129: ! 130: ! 131: ;--- do-one-transaction ! 132: ; do a single read-eval-print transaction ! 133: ; If eof-form is given, then we provide a prompt and read the input, ! 134: ; otherwise given is what we use, but we print the prompt and the ! 135: ; given input before evaling it again. ! 136: ; (given must be in the form (sys|user ..) ! 137: ; ! 138: (defun do-one-transaction (given prompt eof-form) ! 139: (let (retv) ! 140: (patom prompt) ! 141: (If eof-form ! 142: then (setq given ! 143: (car (errset (ntpl-read nil eof-form)))) ! 144: (If (eq eof-form given) ! 145: then (If (status isatty) ! 146: then (msg "EOF" N) ! 147: (setq given '(sys <eof>)) ! 148: else (exit))) ! 149: else (tpl-history-form-print given) ! 150: (terpr)) ! 151: (add-to-given-history given) ! 152: (If (eq 'user (car given)) ! 153: then (setq tpl-stack-bad t) ! 154: (setq retv ! 155: (if tpl-step-enable ! 156: then (tpl-evalhook (cdr given) ! 157: 'tpl-do-evalhook ! 158: 'tpl-do-funcallhook) ! 159: else (tpl-eval (cdr given)))) ! 160: (setq tpl-stack-bad t) ! 161: else (setq retv (process-fcn (cdr given))) ! 162: (setq tpl-stack-bad (not tpl-stack-ok))) ! 163: (add-to-res-history retv) ! 164: (ntpl-print retv) ! 165: (terpr) ! 166: )) ! 167: ! 168: ! 169: ;; reader ! 170: ; if sees a rpar as the first non space char, it just reads all chars ! 171: ; return (sys . form) where form is a list, e.g ! 172: ; )foo bar baz rets (sys foo bar baz) ! 173: ; or ! 174: ; (user . form) ! 175: ; note: if nothing is typed, (sys) is returned ! 176: ; ! 177: (defun ntpl-read (port eof-form) ! 178: (let (ch) ! 179: ; skip all spaces ! 180: (do () ! 181: ((and (not (eq (setq ch (tyipeek port)) #\space)) ! 182: (not (eq ch #\newline)))) ! 183: (setq ch (tyi))) ! 184: (If (eq ch #\eof) ! 185: then eof-form ! 186: else (setq ch (tyi port)) ! 187: (If (eq ch tpl-spec-char) ! 188: then (do ((xx (list #\lpar) (cons (tyi) xx))) ! 189: ((or (eq #\eof (car xx)) ! 190: (eq #\newline (car xx))) ! 191: (cons 'sys ! 192: (car (errset ! 193: (readlist ! 194: (nreverse ! 195: (cons #\rpar (cdr xx))))))))) ! 196: else (untyi ch) ! 197: (cons 'user (read port eof-form)))))) ! 198: ! 199: ;--- tpl-history-form-print :: the inverse of tpl-read ! 200: ; this takes the history form of an expression and prints it out ! 201: ; just as the user would have typed it. ! 202: ; ! 203: (defun tpl-history-form-print (form) ! 204: (If (eq 'user (car form)) ! 205: then (print (cdr form)) ! 206: else (patom "?") ! 207: (mapc '(lambda (x) (print x) (patom " ")) (cdr form)))) ! 208: ! 209: (defun ntpl-print (form) ! 210: (print form)) ! 211: ! 212: (setq tpl-commands ! 213: '( ((help h) tpl-command-help ! 214: " [cmd] - print general or specific info " ! 215: " '?help' - print a short description of all commands " ! 216: " '?help cmd' - print extended information on the given command ") ! 217: ( ? tpl-command-redo ! 218: " [args] - redo last or previous command " ! 219: " '??' - redo last user command " ! 220: " '?? n' - (for n>0) redo command #n (as printed by ?history)" ! 221: " '?? -n' - (for n>0) redo n'th previous command (?? -1 == ??)" ! 222: " '?? symb' - redo last with car == symb" ! 223: " '?? symb *' - redo last with car == symb*") ! 224: ( (his history) tpl-command-history ! 225: " [r] - print history list " ! 226: " ?history, ?his - print list of commands previously executed" ! 227: " '?his r' - print results too") ! 228: ( (re reset) tpl-command-reset ! 229: " - pop up to the top level" ! 230: " '?re, ?reset', pop up to the top level ") ! 231: ( tr tpl-command-trace ! 232: " [fn ..] - trace" ! 233: " '?tr' - print list of traced functions" ! 234: " '?tr fn ...' - trace given functions, can be fn or (fn cmd ...)" ! 235: " where cmds are trace commands") ! 236: ( step tpl-command-step ! 237: " [t] [funa funb ...] step always or when specific function hit" ! 238: " '?step t' - step starting right away " ! 239: " '?step funa funb' - step when either funa or funb to be called ") ! 240: ( soff tpl-command-stepoff ! 241: " - turn off stepping " ! 242: " '?soff' - turn off stepping ") ! 243: ( sc tpl-command-sc ! 244: " [n] - continue stepping [don't break for n steps] " ! 245: " '?sc' - do one step then break " ! 246: " '?sc n' - step for n steps before breaking " ! 247: " if n is a non integer (e.g. inf) then " ! 248: " step forever without breaking ") ! 249: ( state tpl-command-state ! 250: " [vals] - print or change state " ! 251: " 'state' - print current state in short form " ! 252: " 'state l' - print state in long form" ! 253: " 'state sym val ... ...' - set values of state " ! 254: " symbols are those given in 'state l' list") ! 255: ( prt tpl-command-prt ! 256: " - pop up a level and retry the command which caused this break" ! 257: " ?prt - do a ?pop followed by a retry of the command which" ! 258: " caused this break to be entered") ! 259: ( ld tpl-command-load ! 260: " [file ...] - load given or last files" ! 261: " 'ld' - loads the last files loaded with ?ld" ! 262: " 'ld file ...' - loads the given files") ! 263: ( debug tpl-command-debug ! 264: " [off] - toggle debug state " ! 265: " 'debug' Turns on debugging. When debug is on then" ! 266: " enough information is kept around for viewing" ! 267: " and quering evaluation stack" ! 268: " 'debug off' - Turns off debuging" ) ! 269: ( pop tpl-command-pop ! 270: " - pop up to previous break level" ! 271: " 'pop' - if not at top level, pop up to the break level" ! 272: " above this one") ! 273: ( ret tpl-command-ret ! 274: " [val] - return value from this break loop " ! 275: " 'ret [val]' if this is a break look due to a break command " ! 276: " or a continuable error, evaluate val (default nil)" ! 277: " and return it to the function that found an error," ! 278: " allowing it to continue") ! 279: ! 280: ( zo tpl-command-zoom ! 281: " - view a portion of evaluation stack" ! 282: " 'zo' - show a portion above and below the 'current' stack" ! 283: " frame. Use )up and )dn or alter current stack frame") ! 284: ( dn tpl-command-down ! 285: " [n] - go down stack frames " ! 286: " 'dn' - move the current stack frame down one. Down refers to" ! 287: " older stack frames" ! 288: " 'dn n' - n is a fixnum telling how many stack frames to go down" ! 289: " 'dn n z' - after going down, do a zoom" ! 290: " After dn is done, a limited zoom will be done") ! 291: ( up tpl-command-up ! 292: " [n] - go up stack frames " ! 293: " 'up' - move the current stack frame up one. Up refers to" ! 294: " younger stack frames" ! 295: " 'up n' - n is a fixnum telling how many stack frames to go up") ! 296: ( ev tpl-command-ev ! 297: " symbol - eval the given symbol wrt the current frame " ! 298: " 'ev symbol' - determine the value of the given symbol" ! 299: " after restoring the bindings to the way they were" ! 300: " when the current frame was current. see ?zo,?up,?dn") ! 301: ( pp tpl-command-pp ! 302: " - pretty print the current frame " ! 303: " 'pp' - pretty print the current frame (see ?zo, ?up, ?dn)") ! 304: ( <eof> tpl-command-pop ! 305: " - pop one break level up " ! 306: " '^D' - if connect to tty, pops up one break level," ! 307: " otherwise, exits doesn't exit unless ")) ! 308: ) ! 309: ! 310: ;--- process-fcn :: do a user command ! 311: ; ! 312: (defun process-fcn (form) ! 313: (let ((sel (car form))) ! 314: (setq tpl-stack-ok nil) ! 315: (do ((xx tpl-commands (cdr xx)) ! 316: (this)) ! 317: ((null xx) ! 318: (msg "Illegal command, type ?help for list of commands" N)) ! 319: (If (or (and (symbolp (setq this (caar xx))) ! 320: (eq sel this)) ! 321: (and (dtpr this) ! 322: (memq sel this))) ! 323: then (return (tpl-funcall (cadar xx) form)))))) ! 324: ! 325: ! 326: ! 327: ;--- tpl commands ! 328: ; ! 329: ! 330: ;--- tpl-command-help ! 331: (defun tpl-command-help (x) ! 332: (setq tpl-stack-ok t) ! 333: (If (cdr x) ! 334: then (do ((xx tpl-commands (cdr xx)) ! 335: (sel (cadr x)) ! 336: (this)) ! 337: ((null xx) ! 338: (msg "I don't know that command" N)) ! 339: ; look for command in tpl-commands list ! 340: (If (or (and (symbolp (setq this (caar xx))) ! 341: (eq sel this)) ! 342: (and (dtpr this) ! 343: (memq sel this))) ! 344: then (return (do ((yy (cdddar xx) (cdr yy))) ! 345: ((null yy)) ! 346: ; print all extended documentation ! 347: (patom (car yy)) ! 348: (terpr))))) ! 349: else ; print short info on all commands ! 350: (mapc #'(lambda (x) ! 351: (let ((sel (car x))) ! 352: ; first print selector or selectors ! 353: (If (dtpr sel) ! 354: then (patom (car sel)) ! 355: (mapc #'(lambda (y) (patom ",") (patom y)) ! 356: (cdr sel)) ! 357: else (patom sel)) ! 358: ; next print documentation ! 359: (patom (caddr x)) ! 360: (terpr))) ! 361: tpl-commands)) ! 362: nil) ! 363: ! 364: (defun tpl-command-load (args) ! 365: (setq args (cdr args)) ! 366: (If args ! 367: then (setq tpl-last-loaded args) ! 368: (mapc 'load args) ! 369: elseif tpl-last-loaded ! 370: then (mapc 'load tpl-last-loaded) ! 371: else (msg "Nothing to load" N))) ! 372: ! 373: ! 374: (defun tpl-command-trace (args) ! 375: (setq args (cdr args)) ! 376: (apply 'trace args)) ! 377: ! 378: ! 379: ! 380: ;--- tpl-command-state ! 381: ; ! 382: (defun tpl-command-state (x) ! 383: (msg " State: debug " tpl-debug-on ", step " tpl-step-enable N)) ! 384: ! 385: ;--- tpl-command-debug ! 386: ; ! 387: (defun tpl-command-debug (x) ! 388: (If (memq 'off (cdr x)) ! 389: then (*rset nil) ! 390: (msg "Debug is off" N) ! 391: (setq tpl-debug-on nil) ! 392: else (*rset t) ! 393: (sstatus translink nil) ! 394: (msg "Debug is on" N) ! 395: (setq tpl-debug-on t))) ! 396: ! 397: ;--- tpl-command-zoom ! 398: ; ! 399: (defun tpl-command-zoom (x) ! 400: (tpl-update-stack) ! 401: (setq tpl-stack-ok t) ! 402: (tpl-zoom)) ! 403: ! 404: (defun tpl-command-down (args) ! 405: ;; go down the evaluation stack and zoom ! 406: ;; down means towards older frames ! 407: (setq tpl-stack-ok t) ! 408: (let ((count 1)) ! 409: (If (and (fixp (cadr args)) (> (cadr args) 0)) ! 410: then (setq count (cadr args))) ! 411: (do ((xx count (1- xx))) ! 412: ((= 0 xx)) ! 413: (If tpl-bot-framelist ! 414: then (setq tpl-top-framelist (cons (car tpl-bot-framelist) ! 415: tpl-top-framelist) ! 416: tpl-bot-framelist (cdr tpl-bot-framelist)))) ! 417: (tpl-command-zoom nil))) ! 418: ! 419: (defun tpl-command-up (args) ! 420: ;; go up the stack and zoom ! 421: ;; up is towards more recent stuff ! 422: ;; ! 423: (setq tpl-stack-ok t) ! 424: (let ((count 1)) ! 425: (If (and (fixp (cadr args)) (> (cadr args) 0)) ! 426: then (setq count (cadr args))) ! 427: (do ((xx count (1- xx))) ! 428: ((= 0 xx)) ! 429: (If tpl-top-framelist ! 430: then (setq tpl-bot-framelist (cons (car tpl-top-framelist) ! 431: tpl-bot-framelist) ! 432: tpl-top-framelist (cdr tpl-top-framelist)))) ! 433: (tpl-command-zoom nil))) ! 434: ! 435: (defun tpl-command-ev (args) ! 436: ;; ?ev foo ! 437: ;; determine the value of variable foo with respect to the current ! 438: ;; evaluation frame. ! 439: ;; ! 440: (let ((sym (cadr args))) ! 441: (If (not (symbolp sym)) ! 442: then (msg "ev must be given a symbol" N) ! 443: elseif (null tpl-bot-framelist) ! 444: then (msg "there is no evaluation stack, is debug on?") ! 445: else (prog1 (car ! 446: (errset ! 447: (eval sym ! 448: (evalframe-bind (car tpl-bot-framelist))))) ! 449: (setq tpl-stack-ok t))))) ! 450: ! 451: ! 452: (defun tpl-command-pp (args) ! 453: (pp-form (evalframe-expr (car tpl-bot-framelist))) ! 454: (terpr) ! 455: nil) ! 456: ! 457: ;;-- history list maintainers ! 458: ; ! 459: ; history lists are just lists of forms ! 460: ; one for the given, and one for the returned ! 461: ; ! 462: (defun most-recent-given () (car given-history)) ! 463: ! 464: (defun add-to-given-history (form) ! 465: (setq given-history (cons form given-history)) ! 466: (setq res-history (cons nil res-history)) ! 467: (If (not (eq (car form) 'history)) ! 468: then (setq tpl-history-count (1+ tpl-history-count)))) ! 469: ! 470: (defun add-to-res-history (form) ! 471: (setq res-history (cons form (cdr res-history))) ! 472: (setq % form)) ! 473: ! 474: ! 475: ;--- evalframe generation ! 476: ; ! 477: ! 478: (defun tpl-update-stack nil ! 479: (If tpl-stack-bad ! 480: then (If (tpl-yorn "Should I re-calc the stack(y/n):") ! 481: then (tpl-gentrace) ! 482: else (msg "[not re-calc'ed]" N) ! 483: (setq tpl-stack-bad nil)))) ! 484: ! 485: ;--- tpl-gentrace ! 486: ; this is called before an function which references the ! 487: ; frame list. it needn't be called unless one knows that ! 488: ; the frame status has changed ! 489: ; ! 490: (defun tpl-gentrace () ! 491: (let ((templist (tpl-getframelist))) ! 492: ; templist contains the frame from bottom (oldest) to top ! 493: ! 494: (setq templist (nreverse templist)) ; now youngest to oldest ! 495: ! 496: ! 497: ; determine a new framelist and put it on the bottom list ! 498: ; the top list is empty. the first thing in the ! 499: ; bottom framelist is the 'current' frame. ! 500: ! 501: ; go though frames, based on flags, flush trace calls ! 502: ; or eval calls ! 503: (do ((xx templist (cdr xx)) ! 504: (remember (If tpl-dontshow-tpl then nil else t)) ! 505: (forget-this nil nil) ! 506: (res) ! 507: (exp) ! 508: (flushpoint)) ! 509: ((null xx) (setq tpl-bot-framelist (nreverse res))) ! 510: (setq exp (evalframe-expr (car xx))) ! 511: (If (dtpr exp) ! 512: then (If (and tpl-dontshow-tpl ! 513: (memq (car exp) '(tpl-eval tpl-funcall ! 514: tpl-evalhook ! 515: tpl-funcallhook))) ! 516: then (setq remember nil))) ! 517: (If (dtpr exp) ! 518: then (If (and tpl-dontshow-tpl (memq (car exp) ! 519: '(tpl-err-tpl-fcn ! 520: tpl-funcall-evalhook ! 521: tpl-do-funcallhook))) ! 522: then (setq forget-this t))) ! 523: (If (and remember (not forget-this)) ! 524: then (setq res (cons (car xx) res))) ! 525: (If (dtpr exp) ! 526: then (If (and tpl-dontshow-tpl ! 527: (eq (car exp) 'tpl-break-function)) ! 528: then (setq remember t)))) ! 529: ! 530: (setq tpl-top-framelist nil))) ! 531: ! 532: (defun tpl-getframelist nil ! 533: (let ((frames) ! 534: temp) ! 535: (If *rset ! 536: then ; Getting the first few frames is tricky because ! 537: ; the frames disappear quickly. ! 538: (setq temp (evalframe nil)) ; call to setq ! 539: (setq temp (evalframe (evalframe-pdl temp))) ! 540: (do ((xx (list (evalframe (evalframe-pdl temp))) ! 541: (cons (evalframe (evalframe-pdl (car xx))) xx))) ! 542: ((null (car xx)) ! 543: (cdr xx)))))) ! 544: ! 545: ! 546: (defun tpl-printframelist (printdown vals count) ! 547: (If (null vals) ! 548: then (If printdown ! 549: then (msg "*** bottom ***" N) ! 550: else (msg "*** top ***" N)) ! 551: elseif (= 0 count) ! 552: then (msg "... " (length vals) " more ..." N) ! 553: else (If (not printdown) ! 554: then (tpl-printframelist printdown (cdr vals) (1- count))) ! 555: (let ((prinlevel tpl-prinlevel) ! 556: (prinlength tpl-prinlength)) ! 557: ; tag apply type forms with 'a:' ! 558: (if (eq 'apply (evalframe-type (car vals))) ! 559: then (msg "a:")) ! 560: (print (evalframe-expr (car vals))) ! 561: (terpr)) ! 562: (If printdown ! 563: then (tpl-printframelist printdown (cdr vals) (1- count))))) ! 564: ! 565: ! 566: (defun tpl-zoom nil ! 567: (tpl-printframelist nil tpl-top-framelist 4) ! 568: (msg "// current \\\\" N) ! 569: (tpl-printframelist t tpl-bot-framelist 4)) ! 570: ! 571: ! 572: ! 573: (defmacro errdesc-class (err) `(car ,err)) ! 574: (defmacro errdesc-id (err) `(cadr ,err)) ! 575: (defmacro errdesc-contp (err) `(caddr ,err)) ! 576: (defmacro errdesc-descr (err) `(cdddr ,err)) ! 577: ! 578: ;--- error handler ! 579: ; ! 580: ! 581: (defun tpl-break-function (reason) ! 582: (do ((tpl-fcn-in-eval (most-recent-given)) ! 583: (tpl-level reason) ! 584: (tpl-continuab) ! 585: (tpl-break-level (1+ tpl-break-level)) ! 586: ;(tpl-step-enable) ! 587: (prompt) ! 588: (do-retry nil nil) ! 589: (retry-value) ! 590: (retv 'contbreak) ! 591: (piport nil) ! 592: (eof-form (ncons nil))) ! 593: (nil) ! 594: (If (eq retv 'contbreak) ! 595: then ! 596: (If (memq (car reason) '(error derror)) ! 597: then (if (eq (car reason) 'error) ! 598: then (msg "Error: ") ! 599: else (msg "DError: ")) ! 600: (patom (car (errdesc-descr (cdr reason)))) ! 601: (mapc #'(lambda (x) (patom " ") (print x)) ! 602: (cdr (errdesc-descr (cdr reason)))) ! 603: (terpr) ! 604: (msg "Form: " (cdr tpl-fcn-in-eval)) ! 605: elseif (eq 'break (car reason)) ! 606: then (msg "Break: ") ! 607: (patom (cadr reason)) ! 608: (mapc #'(lambda (x) (patom " ") (print x)) ! 609: (cddr reason))) ! 610: (terpr) ! 611: (setq tpl-contuab (or (memq (car reason) '(break derror step)) ! 612: (errdesc-contp (cdr reason)))) ! 613: (setq prompt (If reason ! 614: then (concat (if (eq (car reason) 'derror) ! 615: then "d" ! 616: elseif (eq (car reason) 'step) ! 617: then "s" ! 618: else "") ! 619: (If tpl-contuab then "c" else "") ! 620: "{" ! 621: tpl-break-level ! 622: "} ") ! 623: else "=> ")) ! 624: elseif (eq retv 'reset) ! 625: then (tpl-throw 'reset) ! 626: elseif (eq retv 'poplevel) ! 627: then (tpl-throw 'contbreak) ! 628: elseif (eq retv 'popretry) ! 629: then (tpl-throw `(retry ,tpl-fcn-in-eval)) ! 630: elseif (dtpr retv) ! 631: then (If (eq 'retbreak (car retv)) ! 632: then (If (eq 'error (car reason)) ! 633: then (return (cdr retv)) ; return from error ! 634: else (return (cadr retv))) ! 635: else (If (eq 'retry (car retv)) ! 636: then (setq do-retry t ! 637: retry-value (cadr retv))))) ! 638: (setq retv ! 639: (tpl-catch ! 640: (do () ! 641: (nil) ! 642: (If (null do-retry) ! 643: then (do-one-transaction nil prompt eof-form) ! 644: else (do-one-transaction retry-value prompt nil)) ! 645: (setq do-retry nil) ! 646: nil))))) ! 647: ! 648: ;--- tpl-err-tpl-fcn ! 649: ; attached to ER%tpl, the error will return to top level ! 650: ; generic error handler ! 651: ; ! 652: (defun tpl-err-tpl-fcn (err) ! 653: (tpl-break-function (cons 'error err))) ! 654: ! 655: ;--- tpl-err-all-fcn ! 656: ; attached to ER%all if (debugging t) is done. ! 657: ; ! 658: (defun tpl-err-all-fcn (err) ! 659: (setq ER%all 'tpl-err-all-fcn) ! 660: (tpl-break-function (cons 'derror err))) ! 661: ! 662: ;-- tpl-command-pop ! 663: ; pop a break level ! 664: ; ! 665: (defun tpl-command-pop (x) ! 666: (If (= 0 tpl-break-level) ! 667: then (msg "Already at top level " N) ! 668: else (tpl-throw 'poplevel))) ! 669: ! 670: ! 671: ! 672: (defun tpl-command-ret (x) ! 673: (If tpl-contuab ! 674: then (tpl-throw (list 'retbreak (eval (cadr x)))) ! 675: else (msg "Can't return at this point" N))) ! 676: ! 677: ;--- tpl-command-redo ! 678: ; see documentatio above for a list of the various things this accepts ! 679: ; ! 680: (defun tpl-command-redo (x) ! 681: (setq x (cdr x)) ! 682: (If (null x) ! 683: then (tpl-redo-by-count 1) ! 684: elseif (fixp (car x)) ! 685: then (If (< (car x) 0) ! 686: then (tpl-redo-by-count (- (car x))) ! 687: else (If (not (< (car x) tpl-history-count)) ! 688: then (msg "There aren't that many commands " N) ! 689: else (tpl-redo-by-count (- tpl-history-count (car x))))) ! 690: else (tpl-redo-by-car x))) ! 691: ! 692: ! 693: ;--- tpl-redo-by-car :: locate command to do by the car of the command ! 694: ; ! 695: (defun tpl-redo-by-car (x) ! 696: (let ((command (car x)) ! 697: (substringp (If (eq (cadr x) '*) thenret))) ! 698: (If substringp ! 699: then (If (not (symbolp command)) ! 700: then (msg "must give a symbol before *" N) ! 701: else (let* ((string (get_pname command)) ! 702: (len (pntlen string))) ! 703: (do ((xx (tpl-next-user-in-history given-history) ! 704: (tpl-next-user-in-history (cdr xx))) ! 705: (pos)) ! 706: ((null xx) ! 707: (msg "Can't find a match" N)) ! 708: (If (and (dtpr (cdar xx)) ! 709: (symbolp (setq pos (cadar xx)))) ! 710: then (If (equal (substring pos 1 len) ! 711: string) ! 712: then (tpl-throw ! 713: `(retry ,(car xx)))))))) ! 714: else (do ((xx (tpl-next-user-in-history given-history) ! 715: (tpl-next-user-in-history (cdr xx))) ! 716: (pos)) ! 717: ((null xx) ! 718: (msg "Can't find a match" N)) ! 719: (If (and (dtpr (cdar xx)) ! 720: (symbolp (setq pos (cadar xx)))) ! 721: then (If (eq pos command) ! 722: then (tpl-throw ! 723: `(retry ,(car xx))))))))) ! 724: ! 725: ;--- tpl-redo-by-count :: redo n'th previous input ! 726: ; n>=0. if n=0, then redo last. ! 727: ; ! 728: (defun tpl-redo-by-count (n) ! 729: (do ((xx n (1- xx)) ! 730: (list (tpl-next-user-in-history given-history) ! 731: (tpl-next-user-in-history (cdr list)))) ! 732: ((or (not (> xx 0)) (null list)) ! 733: (If (null list) ! 734: then (msg "There aren't that many commands " N) ! 735: else (tpl-throw `(retry ,(car list))))))) ! 736: ! 737: ! 738: '(defun tpl-next-user-in-history (hlist) ! 739: (do ((histlist hlist (cdr histlist))) ! 740: ((or (null histlist) ! 741: (eq 'user (caar histlist))) ! 742: histlist))) ! 743: ! 744: (defun tpl-next-user-in-history (hlist) ! 745: hlist) ! 746: ! 747: ;--- tpl-command-prt ! 748: ; pop and retry command which failed this time ! 749: ; ! 750: (defun tpl-command-prt (x) ! 751: (tpl-throw 'popretry)) ! 752: ! 753: ! 754: ;--- tpl-command-history ! 755: ; ! 756: (defun tpl-command-history (x) ! 757: (let (show-res) ! 758: (If (memq 'r (cdr x)) ! 759: then (setq show-res t)) ! 760: (tpl-command-his-rec tpl-history-show tpl-history-count show-res ! 761: given-history res-history))) ! 762: ! 763: (defun tpl-command-his-rec (count current show-res hlist rhlist) ! 764: (If (and hlist (> count 0)) ! 765: then (tpl-command-his-rec (1- count) (1- current) show-res ! 766: (cdr hlist) (cdr rhlist))) ! 767: (If hlist ! 768: then ! 769: (let ((prinlevel tpl-prinlevel) ! 770: (prinlength tpl-prinlength)) ! 771: (msg current ": ") (tpl-history-form-print (car hlist)) ! 772: (terpr) ! 773: (If show-res ! 774: then (msg "% " current ": " (car rhlist) N))))) ! 775: ! 776: ! 777: (defun tpl-command-reset (x) ! 778: (tpl-throw 'reset)) ! 779: ! 780: (defun tpl-yorn (message) ! 781: (drain piport) ! 782: (msg message) ! 783: (let ((ch (tyi))) ! 784: (drain piport) ! 785: (eq #/y ch))) ! 786: ! 787: ! 788: ;--- tpl-*break :: handle breaks ! 789: ; when tpl starts, this is put on *break's function cell ! 790: ; ! 791: (defun tpl-*break (pred message) ! 792: (let ((^w nil)) ! 793: (cond (pred (tpl-break-function (list 'break message)))))) ! 794: ! 795: ! 796: ! 797: ;; stepping code ! 798: (defun tpl-command-step (args) ! 799: (setq tpl-step-enable t ! 800: tpl-step-print nil ! 801: tpl-step-triggers nil ! 802: tpl-step-countdown 0) ! 803: (if (memq t args) ! 804: then (setq tpl-step-print t) ! 805: else (setq tpl-step-triggers args)) ! 806: (*rset t) ! 807: (setq evalhook nil funcallhook nil) ! 808: (sstatus translink nil) ! 809: (sstatus evalhook t)) ! 810: ! 811: ! 812: (defun tpl-command-stepoff (args) ! 813: ;; we don't turn off status evalhook because then an ! 814: ;; evalhook would cause an error (this probably should be fixed) ! 815: (sstatus evalhook nil) ! 816: (setq tpl-step-enable nil ! 817: tpl-step-print nil)) ! 818: ! 819: (defun tpl-command-sc (args) ! 820: ;; continue after step ! 821: (if (cdr args) ! 822: then (if (fixp (cadr args)) ! 823: then (setq tpl-step-countdown (cadr args)) ! 824: else (setq tpl-step-countdown 100000))) ! 825: (tpl-throw `(retbreak ,tpl-step-enable))) ! 826: ! 827: (defun tpl-do-evalhook (arg) ! 828: ;; arg is the form to eval ! 829: (tpl-funcall-evalhook arg 'eval)) ! 830: ! 831: (defun tpl-do-funcallhook (&rest args) ! 832: ;; this is called with n args. ! 833: ;; args 0 to n-2 are the actual arguments. ! 834: ;; arg n-1 is the function to call (notice that it comes at the end) ! 835: ; the list in 'args' is a fresh list, we can clobber it ! 836: (let (name) ! 837: ; strip the last cons cells from the args list ! 838: ; there will be at least one element in the list, ! 839: ; namely the function being called ! 840: (if (cdr args) ! 841: then ; case of at least one argument ! 842: (do ((xx args (cdr xx))) ! 843: ((null (cddr xx)) ! 844: (setq name (cadr xx)) ! 845: (setf (cdr xx) nil))) ! 846: else ; case of zero arguments ! 847: (setq name (car args) args nil)) ! 848: ! 849: (tpl-funcall-evalhook (cons name args) 'funcall))) ! 850: ! 851: ! 852: (defun tpl-funcall-evalhook (fform type) ! 853: ;; function called after an evalhook or funclalhook is triggered ! 854: ;; The form is an s-expression to be evaluated ! 855: ;; The type is either 'eval' or 'funcall', ! 856: ;; eval meaning that the form is something to be eval'ed ! 857: ;; funcall meaning that the car of the form is the function to ! 858: ;; be applied to the list which is the cdr [actually the cdr ! 859: ;; is spread out on the stack and a 'funcall' is done, but this ! 860: ;; is what apply does anyway. ! 861: ;; Upon entry we optionally print, optionally break, optionally continue ! 862: ;; stepping, and then optionally print the value ! 863: ;; We print if tpl-step-print is t ! 864: ;; We break if tpl-step-print is t and tpl-step-countdown is <= 0 ! 865: ;; We continue stepping if tpl-step-enable is t ! 866: ;; We print the result if we continued stepping. ! 867: ;; ! 868: ;; note: if it were possible to call evalhook and funcallhook if ! 869: ;; (status evalhook) were nil, then we could make ?soff turn off ! 870: ;; (status evalhook), making things run faster [as it is now, stepping ! 871: ;; continues until we reach top-level again. We just don't print ! 872: ;; things out] ! 873: ;; ! 874: (let ((tpl-step-reclevel (1+ tpl-step-reclevel))) ! 875: (if (and (not tpl-step-print) ! 876: (dtpr fform) ! 877: (memq (car fform) tpl-step-triggers)) ! 878: then (setq tpl-step-print t)) ! 879: (if tpl-step-print ! 880: then (tpl-step-printform tpl-step-reclevel type fform) ! 881: (if (<& tpl-step-countdown 1) ! 882: then (setq tpl-step-enable (tpl-break-function '(step))) ! 883: else (setq tpl-step-countdown (1- tpl-step-countdown)))) ! 884: (if tpl-step-enable ! 885: then (let ((newval)) ! 886: (setq newval (if (eq type 'eval) ! 887: then (tpl-evalhook fform ! 888: 'tpl-do-evalhook ! 889: 'tpl-do-funcallhook) ! 890: else (tpl-funcallhook fform ! 891: 'tpl-do-funcallhook ! 892: 'tpl-do-evalhook))) ! 893: (if tpl-step-print ! 894: then (tpl-step-printform tpl-step-reclevel 'r newval)) ! 895: newval) ! 896: else (if (eq type 'eval) ! 897: then (tpl-evalhook fform nil nil) ! 898: else (tpl-funcallhook fform nil nil))))) ! 899: ! 900: ! 901: (defun tpl-step-printform (indent key form) ! 902: (printblanks indent nil) ! 903: (let ((prinlevel 4) (prinlength 4)) ! 904: (msg (if (eq key 'r) ! 905: then '"==" ! 906: elseif (eq key 'funcall) ! 907: then 'f: ! 908: elseif (eq key 'eval) ! 909: then 'e: ! 910: else key) ! 911: form N))) ! 912: ! 913: ; in order to use this: (setq user-top-level 'tpl) ! 914: ! 915: ! 916: (putprop 'tpl t 'version)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.