;;;
;;; STEP.LSP - Single-step evaluator
;;;
;;; Author: Eric Benson
;;; Symbolic Computation Group
;;; Computer Science Dept.
;;; University of Utah
;;; Date: 30 March 1982
;;; Copyright (c) 1982 University of Utah
;;;
#+Tops20
(eval-when (compile eval) ; Needed for PBIN in STEP-GET-CHAR
(load monsym))
(imports '(evalhook)) ; Tell the loader that evalhook is needed
(defvar step-level 0 "Level of recursion while stepping")
(defvar step-form () "Current form being evaluated")
(defvar step-pending-forms () "Buffer of forms being evaluated")
(defvar abort-step () "Flag to indicate exiting step")
(defvar step-dispatch (make-vector 127 t ())
"Dispatch table for character commands")
(defvar step-channel () "I/O Channel used for printing truncated forms.")
(eval-when (compile eval)
;;;; DEF-STEP-COMMAND - define a character command routine
(defmacro def-step-command (char . form)
`(vset step-dispatch ,char (function (lambda () ,@form))))
)
;;;; STEP - user entry point
(defun step (form)
(let ((step-level 0)
(step-pending-forms ())
(abort-step ()))
(prog1 (step-eval form)
(terpri))))
;;;; STEP-EVAL - main routine
(defun step-eval (step-form)
(if abort-step
(eval step-form)
(let ((step-pending-forms (cons step-form step-pending-forms)))
(step-print-form step-form "-> ")
(let ((macro-call (macro-p (first step-form))))
(when macro-call
(setq step-form (funcall macro-call step-form))
(step-print-form step-form "<->")))
(let ((step-value (let ((step-level (add1 step-level)))
(step-command))))
(unless (and abort-step (not (eql abort-step step-level)))
(setq abort-step ())
;; Print the non macro-expanded form
(step-print-value (first step-pending-forms)
step-value))
step-value))))
;;;; Control-N - Continue stepping each time
(def-step-command #\
(evalhookfn step-form #'step-eval))
;;;; Space - do not step lower levels
(def-step-command #\blank
(eval step-form))
;;;; Control-U - go up to next higher evaluation level
(def-step-command #\
(setq abort-step (- step-level 2))
(eval step-form))
;;;; Control-X - abort stepping entirely
(def-step-command #\
(setq abort-step -1)
(eval step-form))
;;;; Control-G - grind the current form
(def-step-command #\bell
(terpri)
(prettyprint (first step-pending-forms))
(step-command))
;;;; Control-P is the same as Control-G
(vset step-dispatch #\ (vref step-dispatch #\bell))
;;;; Control-R grinds the form in Rlisp syntax
(def-step-command #\
(terpri)
(rprint (first step-pending-forms)) ; This will only
(step-command)) ; work in Rlisp
;;;; Control-E - edit the current form
(def-step-command #\
(setq step-form (edit step-form))
(step-command))
;;;; Control-B - go into a break loop
(def-step-command #\
(step-break)
(step-command))
;;;; Control-L redisplay the last 10 pending forms
(def-step-command #\ff
(display-last-10)
(step-command))
;;;; ? - help
(def-step-command #\?
(load help)
(displayhelpfile 'step)
(step-command))
(defun display-last-10 ()
(display-aux step-pending-forms 10))
(defun display-aux (b n)
(let ((step-level (sub1 step-level)))
(unless (or (null b) (eql n 0))
(display-aux (rest b) (sub1 n))
(step-print-form (first b) "-> "))))
;;;; STEP-COMMAND - read a character and dispatch on it
(defun step-command ()
(let ((c (vref step-dispatch (step-get-char))))
(if c (funcall c)
(ouch #\bell) (step-command))))
;;;; STEP-PRINT-FORM - print incoming form with indentation
(defun step-print-form (form herald)
(terpri)
(tab (min step-level 15))
(princ herald)
(channelprin1 step-channel form))
;;;; STEP-PRINT-VALUE - print form and result of evaluation
(defun step-print-value (form value)
(terpri)
(tab (min step-level 15))
(princ "<- ")
(channelprin1 step-channel form)
(terpri)
(tab (+ (min step-level 15) 3))
(prin1 value))
;;;; STEP-BREAK - errset-protected break loop
(defun step-break ()
(errset (break) ()))
;;;; STEP-GET-CHAR - read a single character
#+Tops20
(lap '((*entry step-get-char expr 0)
(*move #\? (reg 1))
(pbout)
(pbin)
(*exit 0)))
#-Tops20
(defun step-get-char ()
(let ((promptstring* "?"))
(do ((ch (channelreadchar stdin*) (channelreadchar stdin*)))
((not (eql ch #\eol)) ch))))
;;;; STEP-PUT-CHAR - prints on current channel, truncates to one line
(defun step-put-char (channel ch)
(if (not (eql ch #\eol))
(unless (> (posn) 75) (writechar ch))))
(eval-when (load eval) ; Open a special channel
(let ((specialwritefunction* #'step-put-char)
(specialreadfunction* #'writeonlychannel)
(specialclosefunction* #'illegalstandardchannelclose))
(setq step-channel (open "" 'special)))
)