Commit | Line | Data |
---|---|---|
5ffa1c4c C |
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) |