"$Header: /usr/lib/lisp/RCS/tpl.l,v 1.3 83/04/09 12:58:51 jkf Exp $")
; -[Tue Apr 5 12:32:38 1983 by jkf]-
; ?state : display status translink, *rset, displace-macros.
; current error, prinlevel and prinlength
; add a way of modifying the values
; ?bk [n] : do a baktrace (default 10 frames from bottom)
; ?zo [n] : add an optional number of frames to zoom
; ?retf : return value from 'current' frame
; ?retry : retry expr in 'current' frame (required mod to lisp).
; the frame re-eval question is not asked when it should.
; interact with tracebreaks correctly
; get 'debugging' to work ok.
(declare (special tpl-debug-on tpl-step-on
tpl-top-framelist tpl-bot-framelist
tpl-eval-flush tpl-trace-flush
tpl-prinlength tpl-prinlevel
tpl-commands tpl-break-level
ER%tpl ER%all given-history res-history
tpl-stack-bad tpl-stack-ok
(putd 'tpl-eval (getd 'eval))
(putd 'tpl-funcall (getd 'funcall))
;--- macros which should be in the system
(defmacro evalframe-type (evf) `(car ,evf))
(defmacro evalframe-pdl (evf) `(cadr ,evf))
(defmacro evalframe-expr (evf) `(caddr ,evf))
(defmacro evalframe-bind (evf) `(cadddr ,evf))
(defmacro evalframe-np (evf) `(caddddr ,evf))
(defmacro evalframe-lbot (evf) `(cadddddr ,evf))
;; messages are passed between break levels by means of catch and
(defmacro tpl-throw (value) `(*throw 'tpl-break-catch ,value))
(defmacro tpl-catch (form) `(*catch 'tpl-break-catch ,form))
; A tpl-catch is placed around the prompting and evaluation of forms.
; if something abnormal happens in the evaluation, a tpl-throw is done
; which then tells the break look that something special should be
; contbreak - this tells the break level to print out the message
; it prints when it is entered (such as the error message).
; [see poplevel message].
; poplevel - tells the break level to jump up to the next higher
; break level and continue there. It sends contbreak
; message to that break level so that it will remind the
; user what the state is. [see cmd: ?pop ]
; reset - This tells the break level to send a reset to the next
; higher break level. Thus a reset is done by successive
; small pops. This isn't totally necessary, but it is
; (retbreak v) - return from the break level, returning the value v.
; If this an error break, then we return (list v) since
; that is required to indicate that an error has been
; (retry v) - instead of asking for a new value, retry the given one.
; popretry - take the expression that caused the current break and
; send a (retry expr) message to the break level above us
; so that it can be tried again.
(setq tpl-eval-flush nil tpl-trace-flush nil
tpl-prinlevel 3 tpl-prinlength 4
(or (boundp 'tpl-last-loaded) (setq tpl-last-loaded nil))
(let ((debug-error-handler 'tpl-err-all-fcn))
(setq ER%tpl 'tpl-err-tpl-fcn)
(putd '*break (getd 'tpl-*break))
(tpl-break-function nil))))))
; do a single read-eval-print transaction
; If eof-form is given, then we provide a prompt and read the input,
; otherwise given is what we use, but we print the prompt and the
; given input before evaling it again.
; (given must be in the form (sys|user ..)
(defun do-one-transaction (given prompt eof-form)
(car (errset (ntpl-read nil eof-form))))
(setq given '(sys <eof>))
else (tpl-history-form-print given)
(add-to-given-history given)
(If (eq 'user (car given))
then (setq tpl-stack-bad t)
(setq retv (tpl-eval (cdr given)))
else (setq retv (process-fcn (cdr given)))
(setq tpl-stack-bad (not tpl-stack-ok)))
(add-to-res-history retv)
; if sees a rpar as the first non space char, it just reads all chars
; return (sys . form) where form is a list, e.g
; )foo bar baz rets (sys foo bar baz)
; note: if nothing is typed, (sys) is returned
(defun ntpl-read (port eof-form)
((and (not (eq (setq ch (tyipeek port)) #\space))
(not (eq ch #\newline))))
else (setq ch (tyi port))
(If (eq ch tpl-spec-char)
then (do ((xx (list #\lpar) (cons (tyi) xx)))
(cons #\rpar (cdr xx)))))))))
(cons 'user (read port eof-form))))))
;--- tpl-history-form-print :: the inverse of tpl-read
; this takes the history form of an expression and prints it out
; just as the user would have typed it.
(defun tpl-history-form-print (form)
(If (eq 'user (car form))
(mapc '(lambda (x) (print x) (patom " ")) (cdr form))))
'( ((help h) tpl-command-help
" [cmd] - print general or specific info "
" '?help' - print a short description of all commands "
" '?help cmd' - print extended information on the given command ")
" [args] - redo last or previous command "
" '??' - redo last user command "
" '?? n' - (for n>0) redo command #n (as printed by ?history)"
" '?? -n' - (for n>0) redo n'th previous command (?? -1 == ??)"
" '?? symb' - redo last with car == symb"
" '?? symb *' - redo last with car == symb*")
( (his history) tpl-command-history
" [r] - print history list "
" ?history, ?his - print list of commands previously executed"
" '?his r' - print results too")
( (re reset) tpl-command-reset
" - pop up to the top level"
" '?re, ?reset', pop up to the top level ")
" '?tr' - print list of traced functions"
" '?tr fn ...' - trace given functions, can be fn or (fn cmd ...)"
" where cmds are trace commands")
( state tpl-command-state
" [vals] - print or change state "
" 'state' - print current state in short form "
" 'state l' - print state in long form"
" 'state sym val ... ...' - set values of state "
" symbols are those given in 'state l' list")
" - pop up a level and retry the command which caused this break"
" ?prt - do a ?pop followed by a retry of the command which"
" caused this break to be entered")
" [file ...] - load given or last files"
" 'ld' - loads the last files loaded with ?ld"
" 'ld file ...' - loads the given files")
( debug tpl-command-debug
" [off] - toggle debug state "
" 'debug' Turns on debugging. When debug is on then"
" enough information is kept around for viewing"
" and quering evaluation stack"
" 'debug off' - Turns off debuging" )
" - pop up to previous break level"
" 'pop' - if not at top level, pop up to the break level"
" [val] - return value from this break loop "
" 'ret [val]' if this is a break look due to a break command "
" or a continuable error, evaluate val (default nil)"
" and return it to the function that found an error,"
" allowing it to continue")
" - view a portion of evaluation stack"
" 'zo' - show a portion above and below the 'current' stack"
" frame. Use )up and )dn or alter current stack frame")
" [n] - go down stack frames "
" 'dn' - move the current stack frame down one. Down refers to"
" 'dn n' - n is a fixnum telling how many stack frames to go down"
" 'dn n z' - after going down, do a zoom"
" After dn is done, a limited zoom will be done")
" [n] - go up stack frames "
" 'up' - move the current stack frame up one. Up refers to"
" 'up n' - n is a fixnum telling how many stack frames to go up")
" symbol - eval the given symbol wrt the current frame "
" 'ev symbol' - determine the value of the given symbol"
" after restoring the bindings to the way they were"
" when the current frame was current. see ?zo,?up,?dn")
" - pretty print the current frame "
" 'pp' - pretty print the current frame (see ?zo, ?up, ?dn)")
" - pop one break level up "
" '^D' - if connect to tty, pops up one break level,"
" otherwise, exits doesn't exit unless "))
;--- process-fcn :: do a user command
(defun process-fcn (form)
(do ((xx tpl-commands (cdr xx))
(msg "Illegal command, type )help for list of commands" N))
(If (or (and (symbolp (setq this (caar xx)))
then (return (tpl-funcall (cadar xx) form))))))
(defun tpl-command-help (x)
then (do ((xx tpl-commands (cdr xx))
(msg "I don't know that command" N))
; look for command in tpl-commands list
(If (or (and (symbolp (setq this (caar xx)))
then (return (do ((yy (cdddar xx) (cdr yy)))
; print all extended documentation
else ; print short info on all commands
; first print selector or selectors
(mapc #'(lambda (y) (patom ",") (patom y))
; next print documentation
(defun tpl-command-load (args)
then (setq tpl-last-loaded args)
then (mapc 'load tpl-last-loaded)
else (msg "Nothing to load" N)))
(defun tpl-command-trace (args)
(defun tpl-command-state (x)
(msg " State: debug " tpl-debug-on ", step " tpl-step-on N))
(defun tpl-command-debug (x)
(defun tpl-command-zoom (x)
(defun tpl-command-down (args)
(If (and (fixp (cadr args)) (> (cadr args) 0))
then (setq count (cadr args)))
then (setq tpl-top-framelist (cons (car tpl-bot-framelist)
tpl-bot-framelist (cdr tpl-bot-framelist))))
then (tpl-command-zoom nil))))
;--- tpl-command-up :: move up in the current stack
; moves from top to bot stacks
(defun tpl-command-up (args)
(If (and (fixp (cadr args)) (> (cadr args) 0))
then (setq count (cadr args)))
then (setq tpl-bot-framelist (cons (car tpl-top-framelist)
tpl-top-framelist (cdr tpl-top-framelist))))))
(defun tpl-command-ev (args)
then (msg "ev must be given a symbol" N)
elseif (null tpl-bot-framelist)
then (msg "there is no evaluation stack, is debug on?")
else (prog1 (eval sym (evalframe-bind (car tpl-bot-framelist)))
(setq tpl-stack-ok t)))))
(defun tpl-command-pp (args)
(pp-form (evalframe-expr (car tpl-bot-framelist)))
;;-- history list maintainers
; history lists are just lists of forms
; one for the given, and one for the returned
(defun most-recent-given () (car given-history))
(defun add-to-given-history (form)
(setq given-history (cons form given-history))
(setq res-history (cons nil res-history))
(If (not (eq (car form) 'history))
then (setq tpl-history-count (1+ tpl-history-count))))
(defun add-to-res-history (form)
(setq res-history (cons form (cdr res-history)))
;--- evalframe generation
(defun tpl-update-stack nil
then (If (tpl-yorn "Should I re-calc the stack(y/n):")
else (msg "[not re-calc'ed]" N)
(setq tpl-stack-bad nil))))
; this is called before an function which references the
; frame list. it needn't be called unless one knows that
; the frame status has changed
(let ((templist (tpl-getframelist)))
; templist contains the frame from bottom (oldest) to top
(setq templist (nreverse templist)) ; now youngest to oldest
; determine a new framelist and put it on the bottom list
; the top list is empty. the first thing in the
; bottom framelist is the 'current' frame.
; go though frames, based on flags, flush trace calls
(do ((xx templist (cdr xx))
(remember (If tpl-dontshow-tpl then nil else t))
((null xx) (setq tpl-bot-framelist (nreverse res)))
(setq exp (evalframe-expr (car xx)))
then (If (and tpl-dontshow-tpl
(memq (car exp) '(tpl-eval tpl-funcall)))
then (setq remember nil)))
then (If (and tpl-dontshow-tpl (memq (car exp)
then (setq forget-this t)))
(If (and remember (not forget-this))
then (setq res (cons (car xx) res)))
then (If (and tpl-dontshow-tpl
(eq (car exp) 'tpl-break-function))
then (setq remember t))))
(setq tpl-top-framelist nil)))
(defun tpl-getframelist nil
then ; Getting the first few frames is tricky because
; the frames disappear quickly.
(setq temp (evalframe nil)) ; call to setq
(setq temp (evalframe (evalframe-pdl temp)))
(do ((xx (list (evalframe (evalframe-pdl temp)))
(cons (evalframe (evalframe-pdl (car xx))) xx)))
(defun tpl-printframelist (printdown vals count)
then (msg "*** bottom ***" N)
else (msg "*** top ***" N))
then (msg "... " (length vals) " more ..." N)
then (tpl-printframelist printdown (cdr vals) (1- count)))
(let ((prinlevel tpl-prinlevel)
(prinlength tpl-prinlength))
(print (evalframe-expr (car vals)))
then (tpl-printframelist printdown (cdr vals) (1- count)))))
(tpl-printframelist nil tpl-top-framelist 4)
(msg "// current \\\\" N)
(tpl-printframelist t tpl-bot-framelist 4))
(defmacro errdesc-class (err) `(car ,err))
(defmacro errdesc-id (err) `(cadr ,err))
(defmacro errdesc-contp (err) `(caddr ,err))
(defmacro errdesc-descr (err) `(cdddr ,err))
(defun tpl-break-function (reason)
(do ((tpl-fcn-in-eval (most-recent-given))
(tpl-break-level (1+ tpl-break-level))
(If (memq (car reason) '(error derror))
then (if (eq (car reason) 'error)
(patom (car (errdesc-descr (cdr reason))))
(mapc #'(lambda (x) (patom " ") (print x))
(cdr (errdesc-descr (cdr reason))))
(msg "Form: " (cdr tpl-fcn-in-eval))
elseif (eq 'break (car reason))
(mapc #'(lambda (x) (patom " ") (print x))
(setq tpl-contuab (or (memq (car reason) '(break derror))
(errdesc-contp (cdr reason))))
then (concat (if (eq (car reason) 'derror)
(If tpl-contuab then "c" else "")
elseif (eq retv 'poplevel)
then (tpl-throw 'contbreak)
elseif (eq retv 'popretry)
then (tpl-throw `(retry ,tpl-fcn-in-eval))
then (If (eq 'retbreak (car retv))
then (If (eq 'error (car reason))
then (return (cdr retv)) ; return from error
else (return (cadr retv)))
else (If (eq 'retry (car retv))
retry-value (cadr retv)))))
then (do-one-transaction nil prompt eof-form)
else (do-one-transaction retry-value prompt nil))
; attached to ER%tpl, the error will return to top level
(defun tpl-err-tpl-fcn (err)
(tpl-break-function (cons 'error err)))
; attached to ER%all if (debugging t) is done.
(defun tpl-err-all-fcn (err)
(setq ER%all 'tpl-err-all-fcn)
(tpl-break-function (cons 'derror err)))
(defun tpl-command-pop (x)
(If (= 0 tpl-break-level)
then (msg "Already at top level " N)
else (tpl-throw 'poplevel)))
(defun tpl-command-ret (x)
then (tpl-throw (list 'retbreak (eval (cadr x))))
else (msg "Can't return at this point" N)))
; see documentatio above for a list of the various things this accepts
(defun tpl-command-redo (x)
then (tpl-redo-by-count 1)
then (tpl-redo-by-count (- (car x)))
else (If (not (< (car x) tpl-history-count))
then (msg "There aren't that many commands " N)
else (tpl-redo-by-count (- tpl-history-count (car x)))))
else (tpl-redo-by-car x)))
;--- tpl-redo-by-car :: locate command to do by the car of the command
(defun tpl-redo-by-car (x)
(substringp (If (eq (cadr x) '*) thenret)))
then (If (not (symbolp command))
then (msg "must give a symbol before *" N)
else (let* ((string (get_pname command))
(do ((xx (tpl-next-user-in-history given-history)
(tpl-next-user-in-history (cdr xx)))
(msg "Can't find a match" N))
(If (and (dtpr (cdar xx))
(symbolp (setq pos (cadar xx))))
then (If (equal (substring pos 1 len)
else (do ((xx (tpl-next-user-in-history given-history)
(tpl-next-user-in-history (cdr xx)))
(msg "Can't find a match" N))
(If (and (dtpr (cdar xx))
(symbolp (setq pos (cadar xx))))
then (If (eq pos command)
`(retry ,(car xx)))))))))
;--- tpl-redo-by-count :: redo n'th previous input
; n>=0. if n=0, then redo last.
(defun tpl-redo-by-count (n)
(list (tpl-next-user-in-history given-history)
(tpl-next-user-in-history (cdr list))))
((or (not (> xx 0)) (null list))
then (msg "There aren't that many commands " N)
else (tpl-throw `(retry ,(car list)))))))
'(defun tpl-next-user-in-history (hlist)
(do ((histlist hlist (cdr histlist)))
(eq 'user (caar histlist)))
(defun tpl-next-user-in-history (hlist)
; pop and retry command which failed this time
(defun tpl-command-prt (x)
(defun tpl-command-history (x)
(tpl-command-his-rec tpl-history-show tpl-history-count show-res
given-history res-history)))
(defun tpl-command-his-rec (count current show-res hlist rhlist)
(If (and hlist (> count 0))
then (tpl-command-his-rec (1- count) (1- current) show-res
(cdr hlist) (cdr rhlist)))
(let ((prinlevel tpl-prinlevel)
(prinlength tpl-prinlength))
(msg current ": ") (tpl-history-form-print (car hlist))
then (msg "% " current ": " (car rhlist) N)))))
(defun tpl-command-reset (x)
(defun tpl-yorn (message)
;--- tpl-*break :: handle breaks
; when tpl starts, this is put on *break's function cell
(defun tpl-*break (pred message)
(cond (pred (tpl-break-function (list 'break message))))))
; in order to use this: (setq user-top-level 'tpl)
(putprop 'tpl t 'version)