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