"$Header: tpl.l,v 1.6 84/02/29 19:31:09 jkf Exp $")
; -[Thu Feb 16 07:49:26 1984 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
prinlevel prinlength top-level-print
tpl-commands tpl-break-level
ER%tpl ER%all given-history res-history
tpl-stack-bad tpl-stack-ok
tpl-step-enable ;; if stepping is on
tpl-step-print ;; if should print step forms
tpl-step-triggers ;; list of fcns to enable step
tpl-step-countdown ;; if positive, then don't break
tpl-step-reclevel ;; recursion level
(putd 'tpl-eval (getd 'eval))
(putd 'tpl-funcall (getd 'funcall))
(putd 'tpl-evalhook (getd 'evalhook))
(putd 'tpl-funcallhook (getd 'funcallhook))
;--- 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)
then (tpl-evalhook (cdr given)
else (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))))
(cond ((and top-level-print
(funcall top-level-print 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")
" [t] [funa funb ...] step always or when specific function hit"
" '?step t' - step starting right away "
" '?step funa funb' - step when either funa or funb to be called ")
( soff tpl-command-stepoff
" '?soff' - turn off stepping ")
" [n] - continue stepping [don't break for n steps] "
" '?sc' - do one step then break "
" '?sc n' - step for n steps before breaking "
" if n is a non integer (e.g. inf) then "
" step forever without breaking ")
( 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" )
" - set switches for fastest execution "
" '?fast - turn off ?debug mode (i.e. (*rset nil)), set the "
" translink table to 'on', and set displace-macros to t."
" This will cause franz to run as fast as possible "
" (but will result in loss of debugging information ")
" - 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-enable N)
(msg " *rset " *rset ", (status translink) " (status translink) N)
(msg " variables: tpl-prinlength " tpl-prinlength N)
(msg " tpl-prinlevel " tpl-prinlevel N))
(defun tpl-command-debug (x)
(defun tpl-command-fast (x)
(setq displace-macros t))
(defun tpl-command-zoom (x)
(defun tpl-command-down (args)
;; go down the evaluation stack and zoom
;; down means towards older frames
(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))))
(defun tpl-command-up (args)
;; go up the stack and zoom
;; up is towards more recent stuff
(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)
;; determine the value of variable foo with respect to the current
then (msg "ev must be given a symbol" N)
elseif (null tpl-bot-framelist)
then (msg "there is no evaluation stack, is debug on?")
(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))
; tag apply type forms with 'a:'
(if (eq 'apply (evalframe-type (car vals)))
(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 step))
(errdesc-contp (cdr reason))))
then (concat (if (eq (car reason) 'derror)
elseif (eq (car reason) 'step)
(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))))))
(defun tpl-command-step (args)
then (setq tpl-step-print t)
else (setq tpl-step-triggers args))
(setq evalhook nil funcallhook nil)
(defun tpl-command-stepoff (args)
;; we don't turn off status evalhook because then an
;; evalhook would cause an error (this probably should be fixed)
(setq tpl-step-enable nil
(defun tpl-command-sc (args)
then (if (fixp (cadr args))
then (setq tpl-step-countdown (cadr args))
else (setq tpl-step-countdown 100000)))
(tpl-throw `(retbreak ,tpl-step-enable)))
(defun tpl-do-evalhook (arg)
;; arg is the form to eval
(tpl-funcall-evalhook arg 'eval))
(defun tpl-do-funcallhook (&rest args)
;; this is called with n args.
;; args 0 to n-2 are the actual arguments.
;; arg n-1 is the function to call (notice that it comes at the end)
; the list in 'args' is a fresh list, we can clobber it
; strip the last cons cells from the args list
; there will be at least one element in the list,
; namely the function being called
then ; case of at least one argument
else ; case of zero arguments
(setq name (car args) args nil))
(tpl-funcall-evalhook (cons name args) 'funcall)))
(defun tpl-funcall-evalhook (fform type)
;; function called after an evalhook or funclalhook is triggered
;; The form is an s-expression to be evaluated
;; The type is either 'eval' or 'funcall',
;; eval meaning that the form is something to be eval'ed
;; funcall meaning that the car of the form is the function to
;; be applied to the list which is the cdr [actually the cdr
;; is spread out on the stack and a 'funcall' is done, but this
;; is what apply does anyway.
;; Upon entry we optionally print, optionally break, optionally continue
;; stepping, and then optionally print the value
;; We print if tpl-step-print is t
;; We break if tpl-step-print is t and tpl-step-countdown is <= 0
;; We continue stepping if tpl-step-enable is t
;; We print the result if we continued stepping.
;; note: if it were possible to call evalhook and funcallhook if
;; (status evalhook) were nil, then we could make ?soff turn off
;; (status evalhook), making things run faster [as it is now, stepping
;; continues until we reach top-level again. We just don't print
(let ((tpl-step-reclevel (1+ tpl-step-reclevel)))
(if (and (not tpl-step-print)
(memq (car fform) tpl-step-triggers))
then (setq tpl-step-print t))
then (tpl-step-printform tpl-step-reclevel type fform)
(if (<& tpl-step-countdown 1)
then (setq tpl-step-enable (tpl-break-function '(step)))
else (setq tpl-step-countdown (1- tpl-step-countdown))))
(setq newval (if (eq type 'eval)
else (tpl-funcallhook fform
then (tpl-step-printform tpl-step-reclevel 'r newval))
then (tpl-evalhook fform nil nil)
else (tpl-funcallhook fform nil nil)))))
(defun tpl-step-printform (indent key form)
(let ((prinlevel 4) (prinlength 4))
; in order to use this: (setq user-top-level 'tpl)
(putprop 'tpl t 'version)