;;; -*- Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Base:8; Fonts:(CPTFONT HL10B HL12BI HL12B CPTFONTB)Ï1; Ï*Patch-File:T -*-

;Ï1;;                     RESTRICTED RIGHTS LEGEND          Ï*
;Ï1;; Use, duplication, or disclosure by the Government is subject toÏ*
;Ï1;; restrictions as set forth in subdivision (b)(3)(ii) of the Rights inÏ*
;Ï1;; Technical Data and Computer Software clause at 52.227-7013.Ï*
;Ï1;;                   TEXAS INSTRUMENTS INCORPORATED.Ï*
;Ï1;;                            P.O. BOX 149149Ï*
;Ï1;;                         AUSTIN, TEXAS 78714-9149Ï*
;Ï1;;                             MS 2151Ï*
;Ï1;; Copyright (C) 1986,1987 Texas Instruments Incorporated. All rights reserved.Ï*
;Ï1;; Copyright (C) 1984-1989 Texas Instruments Incorporated. All rights reserved.Ï*

;;; 04-24-89 DAB Added all function, variables, flavors and instances that are documented to export list.

;Ï1;; Ultra-simple stepper for lisp-machine.Ï*
;Ï1;; Wins with multiple valuesÏ*
;Ï1;; Does not attempt to win with editor top levelÏ*
;Ï1;; Compile with QC-FILE.Ï*

;Ï1 NOTES:Ï*
;Ï1 The way it decides whether it needs to reprint the form when showingÏ*
;Ï1 you the values is pretty kludgey right now.  Can it check the cursorposÏ*
;Ï1 or ask itself whether it typed anything or something?Ï*
;
;Ï1 Would like to be able to evaluate and/or substitute in atoms and formsÏ*
;Ï1 without having to break first.Ï*
;
;Ï1 Would like to be able to type ðA and have it stop after evaluating theÏ*
;Ï1 args, before calling the function.Ï*
;
;Ï1 Raid registersÏ*
;
;Ï1 Hook up to DDT?Ï*
;Ï1 Ï*
;Ï1 If an error happens, user should be able to throw back into the stepper.Ï*

(DEFVAR Ï4*step-level*Ï* nil "Ï2Depth within STEP-EVAL, minus one, within call to STEPÏ*")
(DEFVAR Ï4*step-array*Ï* nil "Ï2Holds forms to evaluate, indexed by *STEP-LEVEL* value.Ï*")
(DEFVAR Ï4*step-apply-p-array*Ï* nil "Ï2Holds the APPLY-P flag for each level, indexed by *STEP-LEVEL* value.Ï*")
(DEFVAR Ï4*step-max*Ï* nil "Ï2Do not tell user about evaluations with *STEP-LEVEL* deeper than this.Ï*")
(DEFVAR Ï4*step-form*Ï* nil "Ï2Form to be or just evaluated, in STEP command loopÏ*")
(DEFVAR Ï4*step-value*Ï* nil "Ï2First value just computed.  May be changed in a breakpoint.Ï*")
(DEFVAR Ï4*step-values*Ï* nil "Ï2List of values just computed.  May be changed in a breakpoint.Ï*")

(PROCLAIM '(SPECIAL step-form step-value step-values))
(FORWARD-VALUE-CELL 'step-form '*step-form*)
(FORWARD-VALUE-CELL 'step-value '*step-value*)
(FORWARD-VALUE-CELL 'step-values '*step-values*)

(defvar	 Ï4*step-auto*Ï* nil)     ;Ï1; If non NIL, simulate cntrl-n at step-cmdr.Ï*
			       ;Ï1; normal printout produced unless NO-PRINT.Ï*
			       ;Ï1; User's program can turn on auto mode byÏ*
			       ;Ï1; (si:step-auto-on &optional (mode 'no-print))Ï*
			       ;Ï1; and (si:step-auto-off) to reable stepping.Ï*

(DEFVAR Ï4*ucl-stepper*Ï* nil "Ï2Holds the currently executing instance of stepper.Ï*")

(DEFVAR Ï4*step-function-not-recursive*Ï* t)   ;Ï1; Is this the first level call to this function?Ï*

;Ï1;; NEW SUGGESTIONS!!!Ï*
(sys:declare-suggestions-for 'si::step-eval 
			     :around (sys::make-default-around-form
				       si::step-eval single-stepper-top-menu
				       single-stepper-bottom-menu
				       single-stepper-commands-menu))

(DEFFLAVOR Ï4ucl-stepÏ*
	   ((apply-p)
	    (*step-max*)
	    (*step-level*)
	    ;Ï1;;(*step-auto*)Ï*
	    (form)
	    (VALUES)
	    (*step-array*)
	    (*step-apply-p-array*)
	    (*step-form*)
	    (*step-value*)
	    (*step-values*)
            name                                   ;Ï1; NEWÏ*
	    value-to-return)
	   (ucl:basic-command-loop)
  :gettable-instance-variables                     ;Ï1; NEWÏ*
  :settable-instance-variables
  (:special-instance-variables
    apply-p *step-max* *step-level* form values *step-array* *step-apply-p-array* 
    *step-form* *step-value* *step-values*)
  (:default-init-plist
    :active-command-tables '(step-cmd-table)
    :all-command-tables '(step-cmd-table)
    :menu-panes  nil
    :typein-handler :handle-typein-input
    :name        "Ï3StepÏ*"                            ;Ï1; NEWÏ*
    :basic-help '(documentation-cmd)))

(DEFRESOURCE Ï4ucl-stepÏ* ()
  :constructor (MAKE-INSTANCE 'ucl-step)
  :initial-copies 0)

;Ï1; Redefine this function to call the ucl command loop.Ï*
;Ï1; print whatever is necessary, read a command, set special variablesÏ*
;Ï1; and return how to proceed:  *eval (just *eval), evalhook (recurse), more options later.Ï*
;Ï1; If calling for *eval, *step-values* is nil, otherwise calling for return.Ï*
(DEFUN Ï4step-cmdrÏ* (form values print-form-p &optional apply-p)
  (DECLARE (SPECIAL apply-p *step-max* *step-level*  form values))
  (BLOCK ()
    (IF *step-auto*
       (IF (EQUAL *step-auto* :no-print) ;Ï1; Change no-print to keyword to avoid package conflictÏ*
	  (PROGN
	    (SETQ *step-max* (1+ *step-level*))
	    (RETURN 'EVALHOOK)) ;Ï1; Add else clause to handle *step-auto* being non-nil but notÏ*
	  (SEND tv:selected-window :force-kbd-input #\c-n))) ;Ï1; eq to :no-printÏ*
    (AND print-form-p (step-print-form form *step-level* apply-p))
    (print-values)
    ;Ï1; The following code has been reworked to make the stepper run in its own temporary stack group, Ï*
    ;Ï1; so that its UCL instance variables are not bound when user evaluates a form.  This is particularlyÏ*
    ;Ï1; important if the user is stepping through a UCL application, where he expects to findÏ*
    ;Ï1; *his* instance vars bound.  The three tricks below are a mechanism of communication betweenÏ*
    ;Ï1; two stack groups--the current one in which this function is called, and the temporary stack groupÏ*
    ;Ï1; which is used (in UCL:IN-OWN-STACK-GROUP) to execute the stepper command loop.  In the currentÏ*
    ;Ï1; sg, we have bound a group of special vars.  Trick#1 gives the stepper sg access to these Ï*
    ;Ï1; variables' current values.  Trick#2 makes sure the current sg gets any modifications the stepper Ï*
    ;Ï1; sg (stepper commands) make to the vars.Ï*
    (USING-RESOURCE (*ucl-stepper* ucl-step)
		    ;Ï1; Trick #1Ï*
       (DOLIST (ivar
	 '(apply-p *step-max* *step-level*  form values *step-array* *step-apply-p-array*
	   *step-form* *step-value* *step-values*))
	 (SET-IN-INSTANCE *ucl-stepper* ivar (SYMBOL-VALUE ivar)))
       ;Ï1; Trick#3: UCL:IN-OWN-STACK-GROUP can not return any values, so weÏ*
       ;Ï1; return a value through an instance variable.Ï*
       (ucl::in-own-stack-group (*ucl-stepper*) ()
	  (SEND *ucl-stepper* :set-value-to-return (SEND *ucl-stepper* :command-loop)))
       ;Ï1; Trick#2: some of these vars may have been modified during the command loop.Ï*
       ;Ï1; set them to the values of the corresponding instance variables.Ï*
       (DOLIST (special-var
	 '(apply-p *step-max* *step-level* form values *step-array* *step-apply-p-array*
	   *step-form* *step-value* *step-values*))
	 (SET special-var (SYMEVAL-IN-INSTANCE *ucl-stepper* special-var)))
       (LET ((ret-val (SEND *ucl-stepper* :value-to-return))) ;Ï1; If return value is 'exiting due to quit-cmd, then throw toÏ*
	 (IF (EQ ret-val 'exiting)                            ;Ï1; top level of step, otherwise continueÏ*
              (THROW 'exit-stepper ())
	    (RETURN ret-val))))))       

(DEFMETHOD Ï4(ucl-step :around :fetch-and-executeÏ*) (cont mt ignore)
  "Ï2Intercept a ucl method to break out of the command loop for some of the commands.
   This is necessary due to the nature of the implementation of the stepper.
   It sets a var in eval as a hook to regain control of the evaluation.Ï*"
  (CATCH 'ucl::command-abort
    (LET ((tv:kbd-intercepted-characters ;Ï1; Let this code handle the break key.Ï*
	   (REMOVE (ASSOC #\Break tv:kbd-intercepted-characters :test #'EQ)
		   (THE list tv:kbd-intercepted-characters) :test #'EQUAL)))
      (FUNCALL-WITH-MAPPING-TABLE cont mt :fetch-and-execute)
      (WHEN (AND (NOT ucl::preempting?) ucl::command-entry (TYPEP ucl::command-entry 'ucl::command)
		 ;Ï1; Several stepper commands are given this property in their DEFCOMMANDs.Ï*
	  (SEND ucl::command-entry :get 'exit-loop?))
	(THROW 'ucl::exit-command-loop
	       (CAR
		/)))))) 

(DEFMETHOD Ï4(ucl-step :around :handle-typein-inputÏ*) (cont mt ignore &optional (untyi-first-char? t))
  "Ï2Do the lisp prompt and afterwards output the stepper forms for Lisp typein.Ï*"
  (DECLARE (SPECIAL *step-array* *step-level* *step-apply-p-array*))
  (FORMAT t "Ï3    Eval: Ï*")
  (UNWIND-PROTECT (FUNCALL-WITH-MAPPING-TABLE
		   cont
		   mt
		   :handle-typein-input
		   untyi-first-char?)
    (DO ((i (MAX 0 (- *step-level* 10)) (1+ i)))
	((> i *step-level*)
	 nil)
      (step-print-form (AREF *step-array* i) i (AREF *step-apply-p-array* i)))
    (print-values))) 

(DEFMETHOD Ï4(ucl-step :handle-promptÏ*) ()
  "Ï2Redefine UCL method to do nothing so that a prompt is not printed.Ï*" nil)

(DEFMETHOD Ï4(ucl-step :designate-io-streamsÏ*) ()
  "Ï2Redefine a ucl method to set up the correct bindings.Ï*"
  (SETQ *standard-input* *terminal-io*
        *standard-output* *terminal-io*))

(DEFCOMMAND Ï4next-thing-cmdÏ* ()
  '(:description "Ï3Proceed to next thing evaled.Ï*"
    :names ("Ï3Next thingÏ*")
    :keys (#\Control-n)
    :property-list (exit-loop? t))
  (DECLARE (SPECIAL *step-max* *step-level*))
  (SETQ *step-max* (1+ *step-level*))
  'EVALHOOK)

(DEFCOMMAND Ï4next-this-level-cmdÏ* () 
  '(:description "Ï3Proceed to next thing evaled at same level.Ï*"
    :names ("Ï3Next this levelÏ*") 
    :keys (#\Space)
    :property-list (exit-loop? t :cant-preempt t)) ;Ï1;Keep space from preempting type-in.Ï*
  (DECLARE (SPECIAL *step-max* *step-level*))
  (SETQ *step-max* *step-level*)
  '*eval)    ;Ï1eval1 in rel 2Ï*

(DEFCOMMAND Ï4eval-args-cmdÏ* ()
   '(:description "Ï3Eval the args without stepping; stop before applying the function.Ï*"
     :names ("Ï3Eval argsÏ*")
     :keys (#\c-a)
     :property-list (exit-loop? t))
   (DECLARE (SPECIAL apply-p *step-max* *step-level*))
   (IF (NOT apply-p)
       (PROGN (SETQ *step-max* (1+ *step-level*))
              'APPLYHOOK)
       (PROGN (BEEP)
              (THROW 'ucl::command-abort t)))) 

(DEFCOMMAND Ï4proceed-up-cmdÏ* ()
  '(:description "Ï3Proceed to first thing up one level.Ï*"
    :names ("Ï3Proceed upÏ*")
    :keys (#\Control-u)
    :property-list (exit-loop? t))
  (DECLARE (SPECIAL *step-max* *step-level*))
  (SETQ *step-max* (MAX 0 (1- *step-level*)))
  '*eval)   ;Ï1; eval1 in rel 2Ï*

(DEFCOMMAND Ï4execute-no-stepping-cmdÏ* ()
  '(:description "Ï3Continue executing without further stepping.Ï*"
    :names ("Ï3Exit StepperÏ*")
    :keys (#\End #\Control-x)
    :property-list (exit-loop? t))
  (DECLARE (SPECIAL *step-max*))
  (SETQ *step-max* -1)
  '*eval)   ;Ï1; eval1 in rel 2Ï*

(DEFCOMMAND Ï4quit-cmdÏ* ()
   '(:description "Ï3Throw out of Stepper without further execution of program.Ï*" :names
     ("Ï3Abort ProgramÏ*") :keys (#\s-end))
   (THROW  'ucl::exit-command-loop
	  'exiting))                           ;Ï1Throw 'exiting so we can check at next level upÏ*

(DEFCOMMAND Ï4escape-to-editor-cmdÏ* ()
   '(:description "Ï3Escape to editor.Ï*" :names ("Ï3Escape to editorÏ*") :keys (#\c-e))
   (DECLARE (SPECIAL *step-level* *step-apply-p-array* *step-array* *ucl-stepper*)) (ED)
   (SEND *standard-output* :clear-screen)
   (DO ((i (MAX 0 (- *step-level* 10)) (1+ i)))
       ((> i *step-level*)
	nil)
     (step-print-form (AREF *step-array* i) i (AREF *step-apply-p-array* i)))
   (print-values)) 

(DEFCOMMAND Ï4retype-cmdÏ* ()
  '(:description "Ï3Retype current form in full.Ï*"
    :names ("Ï3RetypeÏ*")
    :keys (#\C-t))
  (DECLARE (SPECIAL values form *ucl-stepper*))  
  (IF (NULL values) (PRINT form)
    (DOLIST (value values) (PRINT value))))

(DEFCOMMAND Ï4grind-cmdÏ* ()
  '(:description "Ï3Grind current form.Ï*"
    :names ("Ï3GrindÏ*")
    :keys (#\C-g))
  (DECLARE (SPECIAL values form *ucl-stepper*))
  (IF (NULL values) (GRIND-TOP-LEVEL form)
    (DOLIST (value values) (GRIND-TOP-LEVEL value))))

(DEFCOMMAND Ï4breakpoint-cmdÏ* ()
   '(:description "Ï3Enter breakpoint with STEP-FORM, STEP-VALUE and STEP-VALUES bound.Ï*"
     :names ("Ï3BreakpointÏ*")
     :keys (#\Break #\c-b))
   (DECLARE (SPECIAL *step-form* *step-array* *step-level* apply-p *step-apply-p-array* *ucl-stepper*))
   (UNWIND-PROTECT (PROGN
		    (BREAK "Ï3step - with *STEP-FORM*, *STEP-VALUE* and *STEP-VALUES* bound.Ï*" t)
		    (SETF (AREF *step-array* *step-level*) *step-form*)
		    (SETF (AREF *step-apply-p-array* *step-level*) apply-p))
     (DO ((i (MAX 0 (- *step-level* 10)) (1+ i)))
	 ((> i *step-level*)
	  nil)
       (step-print-form (AREF *step-array* i) i (AREF *step-apply-p-array* i)))
     (print-values))) 
  
(DEFCOMMAND Ï4clear-and-list-cmdÏ* ()
   '(:description "Ï3Clear screen then list last ten forms.Ï*" :names ("Ï3Clear and listÏ*") :keys
     (#\Page #\c-l))
   (DECLARE (SPECIAL *step-level* *step-apply-p-array* *step-array* *ucl-stepper*))
   (SEND *standard-output* :clear-screen)
   (DO ((i (MAX 0 (- *step-level* 10)) (1+ i)))
       ((> i *step-level*)
	nil)
     (step-print-form (AREF *step-array* i) i (AREF *step-apply-p-array* i)))
   (print-values)) 

(DEFCOMMAND Ï4list-ten-forms-cmdÏ* ()
   '(:description "Ï3List last ten forms.Ï*" :names ("Ï3List tenÏ*") :keys (#\m-l))
   (DECLARE (SPECIAL *step-level* *step-apply-p-array* *step-array* *ucl-stepper*))
   (DO ((i (MAX 0 (- *step-level* 10)) (1+ i)))
       ((> i *step-level*)
	nil)
     (step-print-form (AREF *step-array* i) i (AREF *step-apply-p-array* i)))
   (print-values)) 

(DEFCOMMAND Ï4clear-list-all-cmdÏ* ()
   '(:description "Ï3Clear and list all forms.Ï*" :names ("Ï3Clear list allÏ*") :keys (#\c-m-l))
   (DECLARE (SPECIAL *step-level* *step-apply-p-array* *step-array* *ucl-stepper*))
   (SEND *standard-output* :clear-screen)
   (DO ((i 0 (1+ i)))
       ((> i *step-level*)
	nil)
     (step-print-form (AREF *step-array* i) i (AREF *step-apply-p-array* i)))
   (print-values)) 

(DEFCOMMAND Ï4documentation-cmdÏ* ()
   '(:description "Ï3Describe what is about to be done next.Ï*" :names ("Ï3DocumentationÏ*") :keys
     (#\c-help #\m-help))
   (DECLARE (SPECIAL apply-p *step-values* *ucl-stepper*)) (TERPRI)
   (PRINC
    (COND
      ((NULL *step-values*)
       (IF apply-p "Ï3You are about to apply the above function to the above arguments.Ï*"
	  "Ï3You are about to evaluate the above form.Ï*"))
      (t
       (IF apply-p
	  "Ï3You have applied a function to arguments and are about to return the above values.Ï*"
	  "Ï3You have evaluated a form and are about to return the above values.Ï*"))))
   (TERPRI)
   (PRINC
    "Ï3Magic flags preceding output:

    Ü   Ordinary LISP form
    Ä   About to apply a function
    Ñ   Macro
    Ý   Values
    ö   Separates multiple values

    For the UCL command display press HYPER-CONTROL-HELP.Ï*")
   (TERPRI)
   (DO ((i (MAX 0 (- *step-level* 10)) (1+ i)))
       ((> i *step-level*)
	nil)
     (step-print-form (AREF *step-array* i) i (AREF *step-apply-p-array* i)))
   (print-values)) 

(DEFUN Ï4print-valuesÏ* ()
  (DECLARE (SPECIAL values))
  (DO ((l values (CDR l))
       (ch #\Ý #\ö))
      ((NULL l))
    (terpri-if-insufficient-space 120)
    (WRITE-CHAR #\Space)
    (WRITE-CHAR (INT-CHAR ch))
    (WRITE-CHAR #\Space)
    (print-truncated (CAR l) 142))) 	   ;Ï1; Several windows lose if this is 100.Ï*


;Ï1Make the UCL command table.Ï*

(BUILD-COMMAND-TABLE 'step-cmd-table 'ucl-step
  '(next-thing-cmd
    next-this-level-cmd
    eval-args-cmd
    proceed-up-cmd
    execute-no-stepping-cmd
    quit-cmd
    escape-to-editor-cmd
    retype-cmd
    grind-cmd
    breakpoint-cmd
    clear-and-list-cmd
    list-ten-forms-cmd
    clear-list-all-cmd
    documentation-cmd)
  :init-options
  '(:name "Ï3Step Command TableÏ*"
    :documentation "Ï3The Step commands.Ï*"))


(COMPILE-FLAVOR-METHODS ucl-step)


;Ï1; Do these step-* vars need to be declared special?     ;!Ï*
;Ï1; 9/13/88 clm - fixed two misspellings in doc string and added compiler-letÏ*
;Ï1; form to prevent redefinition warnings.Ï*
(COMPILER-LET ((local-declarations '((:expr-sxhash 6217301.))))	
(DEFMACRO Ï4stepÏ* (form &optional *step-auto*)
  "Ï2Allows the user to single step an evaluated function or functions.Ï*"
  `(LET ((*step-level* -1)
	 (*step-max* 0)
	 (*step-array* (MAKE-ARRAY 200))
	 (*step-apply-p-array* (MAKE-ARRAY 200)))
	 ;Ï1; (*step-auto* ,*step-auto*))Ï*
     (WITH-STACK-LIST (environment si::*interpreter-environment*           ;Ï1! allow access to locally bound variablesÏ*
                                   si::*interpreter-function-environment*  ;Ï1! allow access to locally bound functionsÏ*
                                   nil) 
      (CATCH 'exit-stepper     ;Ï1; Upper level catch from step-cmdrÏ*
       (step-eval (QUOTE ,form) environment)))))
)

;Ï1This is for TRACE, mainly.  The idea is to do an apply,Ï*
;Ï1stepping under it but not showing the user the apply itself.Ï*
(DEFUN Ï4step-applyÏ* (fcn args &aux (*evalhook* #'step-hook))
  (CATCH-CONTINUATION-IF *step-function-not-recursive* 'exit-stepper nil nil  ;Ï1; Only set label to "EXIT-STEPPER" the first call.Ï*
    (UNWIND-PROTECT 
        (PROGN (SETQ *step-function-not-recursive* nil)
               (IF (ATOM fcn) (FORMAT t "Ï3~% Warning: Cannot step inside function, ~S~%Ï*" fcn))
               (APPLY fcn args))
      (SETQ *step-function-not-recursive* t))))
         
;Ï1; Main entry point.Ï*
(DEFUN Ï4step-hookÏ* (form &optional env &aux (*step-level* -1) (*step-max* 0)
		  ;Ï1; *step-auto* Ï*
		  (*step-array* (MAKE-ARRAY 200))
		  (*step-apply-p-array* (MAKE-ARRAY 200)))
  (step-eval form env))
  
;Ï1(defun step-hook (form &optional env &aux (*step-auto* t) (*step-level* -1) (*step-max* 0)Ï*
;		Ï1  (*step-array* (make-array 200))Ï*
;		Ï1  (*step-apply-p-array* (make-array 200)))Ï*
;Ï1  (step-eval form env))Ï*
  
;Ï1Check for macros, they are treated specially.Ï*
(DEFUN Ï4step-macro-pÏ* (form)
  (WHEN (CONSP form)
    (LET ((defn (si:fdefinition-safe (CAR form))))
      (EQ (CAR-SAFE defn) 'MACRO))))

;Ï1(DEFUN STEP-MACRO-P (FORM)Ï*
;Ï1  (AND (CONSP FORM)Ï*
;Ï1       (SYMBOLP (CAR FORM))Ï*
;Ï1       (FBOUNDP (CAR FORM))Ï*
;Ï1     (CONSP (SETQ FORM (SYMBOL-FUNCTION (CAR FORM)))) (EQ (CAR FORM) 'MACRO))) Ï*

(DEFUN Ï4step-auto-onÏ* (&optional (mode t))   ;Ï1change no-print to keywordÏ*
  "Ï2The STEP-AUTO-ON function allows the stepper to automatically step through
   the routine. This option remains in effect until specificaly turned off.Ï*"
  (SETQ *step-auto* mode))

(DEFUN Ï4step-auto-offÏ* ()
  "Ï2Disables automatic stepping.Ï*"
  (SETQ *step-auto* nil))

;Ï1; Print a form, suitably indented, marked, and truncated to one line.Ï*
(DEFUN Ï4step-print-formÏ* (form level apply-p)
  (TERPRI)
  (DO ((n (* 2 level) (1- n)))
      ((= n 0)
       nil)
    (WRITE-CHAR #\Space))
  (WRITE-CHAR (INT-CHAR (COND
			  (apply-p #\Ä)
			  ((step-macro-p form) #\Ñ)
			  (t #\Ü))))
  (WRITE-CHAR #\Space)
  (IF apply-p
     (PROGN
       (print-truncated (FUNCTION-NAME (CAR form)) 113)
       (PRINC "Ï3: Ï*")
       (print-elements-truncated (CDR form) 132 113))
     (print-truncated form 113)))  



;Ï1; This is evalhooked in in place of EVAL.  Works by calling step-cmdrÏ*
;Ï1; to let the user see what's going on and say what to do, then continuesÏ*
;Ï1; evaluation using either EVAL or EVALHOOK based on what the user typed.Ï*
;Ï1; Has special hair for macros and for atoms.Ï*

(DEFUN Ï4step-evalÏ* (*step-form* &optional environment)
  (sys:with-suggestions-menus-for si::step-eval     ;Ï1; NEW SUGGESTIONS!!!Ï*
   (PROG ((*step-level* (1+ *step-level*))
          *step-value*
          *step-values*
	  (ucl::*env* sys::environment)
          tem
          val)
         (WHEN (>= *step-level* (ARRAY-TOTAL-SIZE *step-array*))
           (ADJUST-ARRAY *step-array* (+ 100 *step-level*))
           (ADJUST-ARRAY *step-apply-p-array* (+ 100 *step-level*)))
      mc
         (SETF (AREF *step-array* *step-level*) *step-form*)
         (SETF (AREF *step-apply-p-array* *step-level*) nil)
         (COND
           ((ATOM *step-form*) (SETQ *step-values* (LIST (*eval *step-form*)))
                               (SETQ tem 'ATOM)
                               (GO rl))
           ((<= *step-level* *step-max*) (SETQ tem (step-cmdr *step-form* nil t)))
           (t (SETQ tem '*eval)))
         (COND
           ((step-macro-p *step-form*) (SETQ *step-form* (MACROEXPAND-1 *step-form*))
                                       (GO mc))
           ((EQ tem '*eval)
            (SETQ *step-values* (MULTIPLE-VALUE-LIST (EVALHOOK *step-form* nil nil environment))))
           ((EQ tem 'EVALHOOK)
            (SETQ *step-values* (MULTIPLE-VALUE-LIST (EVALHOOK *step-form* #'step-eval nil environment))))
           ((EQ tem 'APPLYHOOK)
            (SETQ *step-values*
                  (MULTIPLE-VALUE-LIST (EVALHOOK *step-form* nil #'step-applyhook environment))))
           ((FERROR () "Ï3Unknown function ~SÏ*" tem)))
      rl
         (SETQ *step-value* (SETQ val (CAR *step-values*)))
         (COND ((<= *step-level* *step-max*)
                (SETQ tem (step-cmdr *step-form* *step-values* (NEQ tem '*eval))))    ;Ï1; 2 eval1Ï*
               (t (SETQ tem '*eval))) 
         (AND (NEQ *step-value* val) (RETURN *step-value*))
         (COND ((NULL (CDR *step-values*))
                (RETURN (CAR *step-values*)))
               (t (RETURN (VALUES-LIST *step-values*)))))))
;Ï1    RTÏ*
;Ï1    (CONDÏ*
;Ï1      ((NULL (CDR *STEP-VALUES*))Ï*
;Ï1       (RETURN (CAR *STEP-VALUES*)))Ï*
;Ï1      (T (RETURN-NEXT-VALUE (CAR *STEP-VALUES*))Ï*
;Ï1         (SETQ *STEP-VALUES* (CDR *STEP-VALUES*))Ï*
;Ï1         (GO RT))))) Ï*

(DEFUN Ï4step-applyhookÏ* (function args &optional environment &aux
			 *interpreter-environment* *interpreter-function-environment*
			 (*step-form* (CONS function args)))
  environment ;Ï1; so compiler doesn't complain Ï*
  (PROG ((*step-level* (1+ *step-level*))
	 *step-value*
	 *step-values*
	 tem
	 val)
    (WHEN (>= *step-level* (ARRAY-TOTAL-SIZE *step-array*))
      (ADJUST-ARRAY *step-array* (+ 100 *step-level*))
      (ADJUST-ARRAY *step-apply-p-array* (+ 100 *step-level*)))
    mc
    (SETF (AREF *step-array* *step-level*) *step-form*)
    (SETF (AREF *step-apply-p-array* *step-level*) t)
    (COND
      ((<= *step-level* *step-max*) (SETQ tem (step-cmdr *step-form* nil t t)))
      (t (SETQ tem '*eval)))
    (COND
      ((EQ tem '*eval)
       (SETQ *step-values* (MULTIPLE-VALUE-LIST (APPLY (CAR *step-form*) (CDR *step-form*)))))
      ((EQ tem 'EVALHOOK)
       (SETQ *step-values*
	     (MULTIPLE-VALUE-LIST
	      (LET ((*evalhook* #'step-eval))
		(APPLY (CAR *step-form*) (CDR *step-form*))))))
      ((FERROR () "Ï3Unknown function ~SÏ*" tem)))
    rl
    (SETQ *step-value* (SETQ val (CAR *step-values*)))
    (COND ((<= *step-level* *step-max*)
           (SETQ tem (step-cmdr *step-form* *step-values* (NEQ tem '*eval) t)))
          (t (SETQ tem '*eval)))
    (AND (NEQ *step-value* val) (RETURN *step-value*))
    (COND ((NULL (CDR *step-values*))
           (RETURN (CAR *step-values*)))
          (t (RETURN (VALUES-LIST *step-values*))))))
;Ï1    RTÏ*
;Ï1    (COND ((NULL (CDR *STEP-VALUES*))Ï*
;Ï1           (RETURN (CAR *STEP-VALUES*)))Ï*
;Ï1          (T (RETURN-NEXT-VALUE (CAR *STEP-VALUES*))Ï*
;Ï1             (SETQ *STEP-VALUES* (CDR *STEP-VALUES*))Ï*
;Ï1             (GO RT))))) Ï*

;Ï1; PRINT abbreviated spacewise rather than listwiseÏ*

(DEFVAR Ï4print-truncated)Ï* ;Ï1YECHÏ*

(DEFUN Ï4terpri-if-insufficient-spaceÏ* (percent-width)
  (LET ((x (TRUNCATE (* percent-width (FUNCALL *standard-output* :inside-size)) 144)))
    (AND (>= (FUNCALL *standard-output* :read-cursorpos :pixel) x) (TERPRI)))) 

(DEFUN Ï4print-truncatedÏ* (sexp percent-width)
  (LET ((print-truncated (TRUNCATE (* percent-width (FUNCALL *standard-output* :inside-size)) 144)))
    (CATCH 'print-truncated
      (PRIN1 sexp (CLOSURE '(print-truncated *standard-output*) #'print-truncated-stream))))) 

(DEFUN Ï4print-elements-truncatedÏ* (LIST truncation-percent-width terpri-percent-width)
  (DOLIST (element list)
    (terpri-if-insufficient-space terpri-percent-width)
    (print-truncated element truncation-percent-width)
    (WRITE-CHAR #\Space))) 

(DEFUN Ï4print-truncated-streamÏ* (op &optional arg1 &rest rest)
  (CASE op
    (:tyo
     (COND
       ((>= (FUNCALL *standard-output* :read-cursorpos :pixel) print-truncated)
	(THROW 'print-truncated
	       ()))
       (t (FUNCALL *standard-output* :tyo arg1))))
    (:which-operations '(:tyo))
    (otherwise (STREAM-DEFAULT-HANDLER 'print-truncated-stream op arg1 rest)))) 



(EXPORT '(sys:*step-auto*           ;Ï1variableÏ*
	   sys:step-auto-on         ;Ï1functionÏ*
	   sys:step-auto-off        ;Ï1functionÏ*
	   )
	'sys)