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