| 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) |