Artifact 712f92701c8b2e36423e7cb743288ac1dde0350b5ab756507f6c1a4a97a0dc49:

• File psl-1983/3-1/util/step.lsp — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 4854) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/util/step.lsp — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 4854) [annotate] [blame] [check-ins using]

;;;
;;; 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)))
)