![[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] / 43BSDTahoe / ucb / lisp / lisplib|
Return to tpl.l CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / 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.