Trailing-Edge - PDP-10 Archives - clisp - clisp/upsala/step.clisp
There are no other files named step.clisp in the archive.
;;; -*- Lisp -*-
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;; Spice Lisp Function Stepper
;;;    these functions are part of the standard Spice Lisp environment.
;;; Written by Jim Large
;;; Maintained by Steven Handerson
;;; **********************************************************************

(in-package 'lisp)

(export '(step *step-print-level* *step-print-length* *terminal-line-mode*))

(proclaim '(special
	    *evalhook*			;function which subs for eval
	    Step-state		        ;On, off (aborted), or sleeping
	    step-indentation-level	;# of spaces to indent step output

(defvar *step-print-level* 4
  "*Print-level* is bound to this when stepper prints forms.")

(defvar *step-print-length* 5
  "*Print-length* is bound to this when stepper prints forms.")

(defvar *max-step-indentation* 40
  "The maximum number of spaces that step output may be indented.")

(defvar *terminal-line-mode* nil
  "When nil, step will not require a terminating end-of-line for commands.")

(defvar *old-tlm* nil
  "Used by Step-get-char to see if *terminal-line-mode* has been toggled.
   A kludge.")

(defvar step-state nil
  "Step's memory.  Nil means off, T means on. A list of functions is a
  search list.  A non-symbol means step is asleep.")

(defvar step-indentation-level 0
  "Makes the step facilities prinout nicer.")

(eval-when (compile eval)
  (defmacro step-off-p ()
    '(null step-state))

  (defmacro step-on-p ()
    '(eq step-state t))

  (defmacro awaken-stepper ()
    '(setq step-state t
	   *evalhook* #'step-command-loop
	   step-indentation-level 0))

  (defmacro abort-stepper ()
    '(setq step-state nil))

  (defmacro sleep-stepper (&optional (functions 0))
    `(setq step-state ,functions
	   *evalhook* #'step-command-loop
	   step-indentation-level 0))

  (defmacro step-search-list ()
    `(and (listp step-state) step-state))


(eval-when (compile load eval)
  (defmacro with-terminal-modes (stream modelist &rest body)
    (let ((tm (gensym)))
      `(let ((,tm (get-terminal-modes ,stream)))
	   (progn (set-terminal-modes ,stream ,@modelist)
	   (apply #'set-terminal-modes ,stream ,tm))))))
;;; Flushes whitespace.
(eval-when (compile load eval)
  (defmacro step-get-char-CR ()
    `(do ((char (read-char *terminal-io*) (read-char *terminal-io*)))
	 ((not (member char '(#\return #\linefeed)))

(defmacro step-get-char ()
  `(cond (*terminal-line-mode*
	  (unless *old-tlm* (setq *old-tlm* t)
	    (set-terminal-modes *terminal-io* :pass-all nil))
	  (when *old-tlm* (setq *old-tlm* nil)
	    (set-terminal-modes *terminal-io* :pass-all t))
	  (clear-input *terminal-io*)
	  (prog1 (read-char *terminal-io*)

(defmacro step-step-form (form environment)
  `(let* ((results (multiple-value-list
	   (apply #'evalhook ,form #'step-command-loop () ,environment))))
     (step-print-values results)
     (values-list results)))

(defmacro step-eval-form (form environment)
  `(let ((results
	   (apply #'*eval ,form ,environment))))
     (step-print-values results)
     (values-list results)))
;;; Step-Help

;;; Step help is called to print a help message on the console.
(defun step-help ()
  (princ "

Commands are single characters.  If you don't like (linmode nil), then
(setq *terminal-line-mode* t).

 N (next)    also space	    evaluate current expression in step mode.
 S (skip)    CR, tab           ''      ''        ''     without stepping.
 M (macro)		    steps a macroexpansion, signaled by a :: prompt.
 Q (quit)    linefeed       finish evaluation, but turn stepper off.
 p (print)   (lowercase-p)  print current exp.
			      (ignore *step-print-level* & *step-print-length*)
 P	     (uppercase-P)  pretty-print current exp.
 B (break)		    enter break loop.
 E (eval)		    evaluate an arbitrary expression,
			      in the current environment.
 ? (help)		    print this text.
 R (return)		    prompt for an arbitrary value to return
			      as result of current exp.
 G			    throw to top level.

" *standard-output*))
;;; Step-Print

;;; Step-print is called to print a form according to the current indentation
;;;  level, and according to *step-print-level* and *step-print-length*.

(defun step-print (form)
  (do ((*print-level* *step-print-level*)
       (*print-length* *step-print-length*)
       (i (min step-indentation-level *max-step-indentation*)
	  (1- i)))
      ((zerop i) (prin1 form *standard-output*))
    (princ " " *standard-output*)))

;;; Step-print-values is called to print a list of values which were returned
;;;  from an evaluation.

(defun step-print-values (value-list)
  (fresh-line *standard-output*)		;In case of prints.
  (if (not (null value-list)) (step-print (car value-list)))
  (do ((*print-level* *step-print-level*)
       (*print-length* *step-print-length*)
       (vlist (cdr value-list) (cdr vlist)))
      ((null vlist) (terpri *standard-output*))
    (princ "  " *standard-output*)
    (prin1 (car vlist) *standard-output*)))

;;; Step-Command-Loop
;;; Step-command-loop is a substitute for *eval.  It prints the form, and
;;;  then enters a command loop.  The commands are read as single characters
;;;  from the terminal.  If the stepper has subsequently been turned off,
;;;  do the equivalent of the s command without printing.

(defun step-command-loop (form &rest environment)
   ;; If aborted, just eval it.
    (apply #'*eval form environment))
   ((or (step-on-p)
	(and (listp form)
	     (member (car form) (step-search-list))))
    ;;Otherwise, bind indent level, print form, and enter command loop.
    (let ((step-indentation-level (1+ step-indentation-level)))
      (cond ((or (symbolp form)
		 (constantp form))	  ;Could be quoted.
	     (step-print form)
	     (princ " = " *standard-output*)
	      (prin1 (apply #'*eval form environment) *standard-output*)
	      (terpri *standard-output*)))
	    (t (prog ()
		 (step-print form)
		 (if (and (listp form) (atom (car form))
			  (macro-function (car form)))
		     (princ " :: " *standard-output*)	;Notify the user for
                                                        ; expansion.
		     (princ " : " *standard-output*))
		 (case (step-get-char)
		   ((#\m #\M)
		    (return (step-step-form form environment)))
		   ((#\n #\N #\space)
		    (cond ((and (listp form) (atom (car form))
				(macro-function (car form)))
			   (setq form
				 (macroexpand form environment))
			   (go TOP))
			  (t (return
			      (step-step-form form environment)))))
		   ((#\s #\S #\return #\tab)
		    (return (step-eval-form form environment)))
		   ((#\q #\Q #\linefeed)
		    (return (apply #'*eval form environment)))
		   ((#\p) (prin1 form *standard-output*) (go NO-PRINT))
		   ((#\P) (pprint form *standard-output*) (go NO-PRINT))
		   ((#\b #\B) (break "Step") (terpri *standard-output*))
		   ((#\e #\E)
		    (princ "eval: " *query-io*)
		      *terminal-io* (:pass-all nil)
		      (let ((*evalhook* ()))
			(prin1 (apply #'*eval (read *query-io*) environment)
			(terpri *standard-output*))))
		   ((#\?) (step-help))
		   ((#\r #\R)
		    (princ "return: " *standard-output*)
		      *terminal-io* (:pass-all nil)
		      (let* ((*evalhook* ())
			     (results (multiple-value-list
				       (apply #'*eval (read) environment))))
			(step-print-values results)
			(return (values-list results)))))
		   ((#\g #\G) (throw 'top-level-catcher ()))
		   (T (princ "Type ? for help. " *standard-output*)
		      (clear-input *standard-input*)
		      (go NO-PROMPT)))
		 (go TOP))))))
   ;; Haven't found one yet.
   (t (apply #'evalhook form #'step-command-loop () environment))))
;;; Step

;;; Nice to know, but not an error.
(defun step-parse-functions (list)
  "Picks out functions from the list, and tells the user about those that 
  (do* ((list list (Cdr list))
	(functions ())
	(non-functions ()))
       ((null list)
	(if non-functions
	    (format *error-output* "Non-functions ignored - ~S" non-functions))
    (if (and (symbolp (car list))
	     (fboundp (Car list)))
	(setq functions (cons (car list) functions))
	(setq non-functions (cons (car list) non-functions)))))

;;; (Step form) is a special form which  "invokes the stepper".
;;; If no form, set up the stepper for being turned on inside a break loop.
;;; If form is T, turn the stepper on,
;;;           (),  ''  ''     ''   off,
;;; (step &rest functions) looks for any of the functions and steps on them.

(macro step (form)
  "With arg T or (), turns stepper on or off.  (Step) at top-level
  lets a (step t) in a break loop turn on stepping globally.  With a
  list of functions, turns on stepping when any are called.
  Otherwise, the arg is evaled with stepper bound on.  If T,
  *terminal-line-mode* causes step to wait for a return after a
  `(internal-step ',(cdr form)))

(Defun internal-step (forms)
  "With arg T or (), turns stepper on or off.  (Step) at top-level lets
  a (step t) in a break loop turn on stepping globally.  With a list of 
  functions, turns on stepping when any are called.  Otherwise, the arg
  is evaled with stepper bound on."
  (condition-bind ((() #'(lambda (&rest ignore)
			    (unless *old-tlm* (setq *old-tlm* t)
				     *terminal-io* :pass-all nil))
    (with-terminal-modes *terminal-io* (:pass-all t)
      (cond ((null forms) (sleep-stepper) T)
	    ((equal forms '(nil)) (abort-stepper) nil)
	    ((equal forms '(t)) (awaken-stepper) T)
	    ((symbolp (car forms))			;Check if function
	     (let ((functions (step-parse-functions forms)))
	       (sleep-stepper functions)
	    (T (let ((*evalhook* #'step-command-loop)
		     (step-state t)
		     (step-indentation-level 0))
		 (eval (car forms))))))))