(FILECREATED "13-Aug-86 20:41:37" {ERIS}<LISPCORE>LIBRARY>CMLSTEP.;25 82765
changes to: (VARS CMLSTEPCOMS)
(FNS %%STEP-SPREADAPPLY* %%STEP-SPREADAPPLY %%STEP-.EVALFORM. %%STEP-PROG1
%%STEP-SETQ %%STEP-\EVPROGN %%STEP-COND %%STEP-PROGN %%STEP-OR %%STEP-AND
%%STEP-RETURN %%STEP-GO %%STEP-\PROG0 %%STEP-PROG %%STEP-\EVALFORM
%%STEP-AWAKEN %%STEP-BREAK-INTERRUPT CL:EVALHOOK APPLYHOOK %%STEP-EVALQT
%%STEP-EVAL)
(MACROS .STEP-EVALFORM.)
previous date: "13-Aug-86 17:34:00" {ERIS}<LISPCORE>LIBRARY>CMLSTEP.;23)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLSTEPCOMS)
(RPAQQ CMLSTEPCOMS ((* * CMLSTEP -- Single Stepper STEP -- By Kelly Roach *)
(INITVARS (%%*STEP-PRINT-LEVEL* 4)
(%%*STEP-PRINT-LENGTH* 5)
(%%*STEP-MAX-INDENTATION* 40)
(%%*STEP-STATE* NIL)
(%%*STEP-INDENTATION-LEVEL* 0))
(FNS %%STEP-AWAKEN %%STEP-CLOSE %%STEP-ABORT %%STEP-SLEEP %%STEP-STEP-FORM
%%STEP-EVAL-FORM)
(FNS %%STEP-PRINT %%STEP-PRINT-VALUES %%STEP-COMMAND-LOOP %%STEP-BREAK-LOOP
%%STEP-BREAK-INTERRUPT %%STEP-PARSE-FUNCTIONS %%STEP STEP)
(FNS %%STEP-INIT %%STEP-WHENSELECTEDFN)
(P (%%STEP-INIT))
(COMS (* This is all stuff that should be eliminated once the real EVALHOOK
mechanism is implemented. *)
(INITVARS (*EVALHOOK* NIL)
(*SKIP-EVALHOOK* NIL)
(*APPLYHOOK* NIL)
(*SKIP-APPLYHOOK* NIL))
(FNS CL:EVALHOOK APPLYHOOK)
(FNS %%STEP-LISPX %%STEP-EVALQT %%STEP-READ-EVAL-PRINT)
(FNS %%STEP-SPREADAPPLY* %%STEP-SPREADAPPLY %%STEP-.EVALFORM. %%STEP-APPLY*
%%STEP-APPLY %%STEP-\EVALFORM %%STEP-\EVAL %%STEP-EVAL)
(FNS %%STEP-PROG1 %%STEP-SETQ %%STEP-\EVPROGN %%STEP-COND %%STEP-PROGN
%%STEP-OR %%STEP-AND %%STEP-RETURN %%STEP-GO %%STEP-\PROG0 %%STEP-PROG
)
(* See example on page 323 *)
(INITVARS (*HOOKLEVEL* 0))
(FNS HOOK EVAL-HOOK-FUNCTION HOOK-TEST))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA %%STEP-APPLY* STEP)))))
(* * CMLSTEP -- Single Stepper STEP -- By Kelly Roach *)
(RPAQ? %%*STEP-PRINT-LEVEL* 4)
(RPAQ? %%*STEP-PRINT-LENGTH* 5)
(RPAQ? %%*STEP-MAX-INDENTATION* 40)
(RPAQ? %%*STEP-STATE* NIL)
(RPAQ? %%*STEP-INDENTATION-LEVEL* 0)
(DEFINEQ
(%%STEP-AWAKEN
(LAMBDA NIL (* kbr: "13-Aug-86 17:30")
(PROG (STEPMAINWINDOW STEPMENUWINDOW)
(SETQ %%*STEP-STATE* T)
(SETQ %%*STEP-INDENTATION-LEVEL* 0)
(SETQ STEPMAINWINDOW (WFROMDS (TTYDISPLAYSTREAM)))
(COND
((WINDOWPROP STEPMAINWINDOW (QUOTE STEPMENUWINDOW))
(* User is doing (STEP T) even though stepper is already on.
We do a couple things more here in case the stepper and the user have gotten
each other confused. Otherwise a NOOP. *)
(SETQ STEPMENUWINDOW (WINDOWPROP STEPMAINWINDOW (QUOTE STEPMENUWINDOW)))
(ATTACHWINDOW STEPMENUWINDOW STEPMAINWINDOW (QUOTE RIGHT)
(QUOTE TOP))
(OPENW STEPMENUWINDOW))
(T (SETQ STEPMENUWINDOW (OR (WINDOWPROP STEPMAINWINDOW (QUOTE STEPMENUWINDOW))
(ATTACHMENU %%STEP-MENU STEPMAINWINDOW (QUOTE RIGHT)
(QUOTE TOP))))))
(WINDOWPROP STEPMAINWINDOW (QUOTE STEPMENUWINDOW)
STEPMENUWINDOW)
(WINDOWPROP STEPMENUWINDOW (QUOTE STEPMAINWINDOW)
STEPMAINWINDOW)
(PROGN
(* Once EVALHOOK is implemented reasonably, it should be possible to eliminate
this PROGN I think. Currently, EVALHOOK doesn't work, so we fake changing the
behaviour of the read eval print loop merely by calling our own read eval
printer which returns to the normal read eval print loop after the stepper is
aborted. See function %%STEP-ABORT to see how that is done.
*)
(OR (STKPOS (QUOTE %%STEP-READ-EVAL-PRINT))
(%%STEP-READ-EVAL-PRINT))))))
(%%STEP-CLOSE
(LAMBDA NIL (* kbr: "12-Aug-86 22:50")
(PROG (STEPMAINWINDOW STEPMENUWINDOW)
(SETQ %%*STEP-STATE* NIL)
(SETQ *EVALHOOK* NIL)
(SETQ STEPMAINWINDOW (WFROMDS (TTYDISPLAYSTREAM)))
(SETQ STEPMENUWINDOW (WINDOWPROP STEPMAINWINDOW (QUOTE STEPMENUWINDOW)))
(DETACHWINDOW STEPMENUWINDOW)
(CLOSEW STEPMENUWINDOW)
(PROGN (* This PROGN should be eliminated
after real EVALHOOK is implemented.
*)
(RETFROM (QUOTE %%STEP-READ-EVAL-PRINT))))))
(%%STEP-ABORT
(LAMBDA NIL (* kbr: "13-Aug-86 11:06")
(PROG (STEPMAINWINDOW STEPMENUWINDOW)
(SETQ %%*STEP-STATE* NIL)
(SETQ *EVALHOOK* NIL))))
(%%STEP-SLEEP
(LAMBDA (FUNCTIONS) (* kbr: "12-Aug-86 16:17")
(COND
((NULL FUNCTIONS)
(SETQ FUNCTIONS 0)))
(PROG NIL
(SETQ %%*STEP-STATE* FUNCTIONS)
(SETQ *EVALHOOK* (FUNCTION %%STEP-COMMAND-LOOP))
(SETQ %%*STEP-INDENTATION-LEVEL* 0))))
(%%STEP-STEP-FORM
(LAMBDA (FORM ENVIRONMENT) (* kbr: "12-Aug-86 22:26")
(LET ((RESULTS (MULTIPLE-VALUE-LIST (CL:EVALHOOK FORM (FUNCTION %%STEP-COMMAND-LOOP)
NIL ENVIRONMENT))))
(%%STEP-PRINT-VALUES RESULTS)
(VALUES-LIST RESULTS))))
(%%STEP-EVAL-FORM
(LAMBDA (FORM ENVIRONMENT) (* kbr: "12-Aug-86 16:20")
(LET ((RESULTS (MULTIPLE-VALUE-LIST (CL:EVALHOOK FORM NIL NIL ENVIRONMENT))))
(%%STEP-PRINT-VALUES RESULTS)
(VALUES-LIST RESULTS))))
)
(DEFINEQ
(%%STEP-PRINT
(LAMBDA (FORM) (* kbr: "12-Aug-86 22:32")
(* %%STEP-PRINT is called to print a
form according to the current
indentation level, and according to
%%*STEP-PRINT-LEVEL* and
%%*STEP-PRINT-LENGTH* *)
(LET ((*PRINT-LEVEL* %%*STEP-PRINT-LEVEL*)
(*PRINT-LENGTH* %%*STEP-PRINT-LENGTH*)
(I (MIN %%*STEP-INDENTATION-LEVEL* %%*STEP-MAX-INDENTATION*)))
(FRESHLINE *STANDARD-OUTPUT*)
(SPACES I *STANDARD-OUTPUT*)
(CL:PRIN1 FORM *STANDARD-OUTPUT*))))
(%%STEP-PRINT-VALUES
(LAMBDA (VALUE-LIST) (* kbr: "12-Aug-86 22:32")
(* %%STEP-PRINT-VALUES is called to
print a list of values which were
returned from an evaluation.
*)
(PROG NIL
(FRESHLINE *STANDARD-OUTPUT*) (* In case of prints.
*)
(CL:IF (NOT (NULL VALUE-LIST))
(%%STEP-PRINT (CAR VALUE-LIST)))
(LET ((*PRINT-LEVEL %%*STEP-PRINT-LEVEL*)
(*PRINT-LENGTH %%*STEP-PRINT-LENGTH*))
(for VALUE in (CDR VALUE-LIST) do (PRINC " " *STANDARD-OUTPUT*)
(CL:PRIN1 VALUE *STANDARD-OUTPUT*)))
(TERPRI *STANDARD-OUTPUT*))))
(%%STEP-COMMAND-LOOP
(LAMBDA (FORM ENVIRONMENT) (* kbr: "13-Aug-86 11:06")
(* %%STEP-COMMAND-LOOP is the *EVALHOOK* when stepping.
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. *)
(COND
((NULL %%*STEP-STATE*) (* If aborted, just eval it.
*)
(CL:EVALHOOK FORM NIL NIL ENVIRONMENT))
((OR (EQ %%*STEP-STATE* T)
(AND (LISTP FORM)
(CL:MEMBER (CAR FORM)
%%*STEP-STATE*))) (* 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*)
(PROG1 (CL:PRIN1 (CL:EVALHOOK FORM NIL NIL ENVIRONMENT)
*STANDARD-OUTPUT*)
(TERPRI *STANDARD-OUTPUT*)))
(T (%%STEP-PRINT FORM)
(PROG (TEMP)
LOOP
(CASE (%%STEP-BREAK-LOOP)
(ABORT (%%STEP-ABORT))
(STEP (RETURN (%%STEP-STEP-FORM FORM ENVIRONMENT)))
(MACRO (CL:IF (SPECIAL-FORM-P (CAR FORM))
(SETQ TEMP NIL)
(MULTIPLE-VALUE-SETQ (FORM TEMP)
(MACROEXPAND FORM ENVIRONMENT)))
(CL:UNLESS TEMP (RETURN (%%STEP-STEP-FORM FORM ENVIRONMENT))))
(SKIP (RETURN (%%STEP-EVAL-FORM FORM ENVIRONMENT)))
(FINISH (%%STEP-ABORT)
(RETURN (CL:EVALHOOK FORM NIL NIL ENVIRONMENT)))
(PRINT (FRESHLINE *STANDARD-OUTPUT*)
(%%STEP-PRINT FORM *STANDARD-OUTPUT*)
(GO LOOP))
(PPRINT (FRESHLINE *STANDARD-OUTPUT*)
(LET ((SYSPRETTYFLG T))
(%%STEP-PRINT FORM *STANDARD-OUTPUT*))
(GO LOOP))
(BREAK (CL:BREAK "Step")
(TERPRI *STANDARD-OUTPUT*))
(RETURN (RETURN (%%STEP-RETURN)))
(↑ (THROW (QUOTE TOP-LEVEL-CATCHER)
NIL))))))))
(T (* Haven't found one yet.
*)
(CL:EVALHOOK FORM (FUNCTION %%STEP-COMMAND-LOOP)
NIL ENVIRONMENT)))))
(%%STEP-BREAK-LOOP
(LAMBDA (ANSWER) (* kbr: "13-Aug-86 10:26")
(PROG NIL
LOOP
(EVALQT (QUOTE :))
(GO LOOP))))
(%%STEP-BREAK-INTERRUPT
(LAMBDA (COMMAND) (* kbr: "13-Aug-86 17:26")
(* This function called via
%%STEP-WHENSELECTEDFN of STEP menu.
Returns COMMAND from break loop.
*)
(PROG NIL
(COND
((STKPOS (FUNCTION %%STEP-BREAK-LOOP))
(RETFROM (FUNCTION %%STEP-BREAK-LOOP)
COMMAND))))))
(%%STEP-PARSE-FUNCTIONS
(LAMBDA (LIST) (* kbr: "12-Aug-86 16:23")
(* Nice to know, but not an error.
*)
(* Picks out functions from the list,
and tells the user about those that
weren't. *)
(PROG (FUNCTIONS NON-FUNCTIONS)
(FOR FN IN LIST DO (CL:IF (AND (SYMBOLP FN)
(FBOUNDP FN))
(PUSH FUNCTIONS FN)
(PUSH NON-FUNCTIONS FN)))
(CL:IF NON-FUNCTIONS (FORMAT *ERROR-OUTPUT* "Non-functions ignored - ~S" NON-FUNCTIONS))
(RETURN FUNCTIONS))))
(%%STEP
(LAMBDA (FORMS) (* kbr: "12-Aug-86 19:16")
(* (STEP FORM) "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, If FORM is NIL, turn the stepper off,
(STEP &REST FUNCTIONS) looks for any of the functions and steps on them.
*)
(* With arg T or NIL , 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.
*)
(COND
((EQUAL FORMS (QUOTE (T)))
(%%STEP-AWAKEN)
T)
((EQUAL FORMS (QUOTE (NIL)))
(%%STEP-ABORT (TTY.PROCESS))
NIL)
((NULL FORMS)
(%%STEP-SLEEP)
T)
((SYMBOLP (CAR FORMS)) (* Check if function *)
(LET ((FUNCTIONS (%%STEP-PARSE-FUNCTIONS FORMS)))
(%%STEP-SLEEP FUNCTIONS)
FUNCTIONS))
(T (LET ((*EVALHOOK* (FUNCTION %%STEP-COMMAND-LOOP))
(%%*STEP-STATE* T)
(%%*STEP-INDENTATION-LEVEL* 0))) (* NOTE: TOY.EVAL should be changed
back to EVAL when real CML evalhook is
ready. *)
(TOY.EVAL (CAR FORMS))))))
(STEP
(LAMBDA $EXPR$ (* kbr: "12-Aug-86 16:30")
(%%STEP (for I from 1 to $EXPR$ collect (ARG $EXPR$ I)))))
)
(DEFINEQ
(%%STEP-INIT
(LAMBDA NIL (* kbr: "13-Aug-86 11:05")
(* %%STEP-INIT is called when CMLSTEP
is loaded. *)
(PROG NIL
(SETQ %%STEP-MENU (create MENU
TITLE ← "STEPPER"
ITEMS ← (QUOTE ((AWAKEN NIL "Turn stepping on.")
(CLOSE NIL "Turn stepping off. Close this menu.")
(ABORT NIL "Abort stepping mode.")
(STEP NIL
"Evaluate current expression in step mode.")
(SKIP NIL
"Evaluate current expression without stepping."
)
(MACRO NIL "Step macroexpansion.")
(FINISH NIL
"Finish evaluation, but without stepping.")
(PRINT NIL "Print current expression.")
(PPRINT NIL "Pretty-print current expression.")
(BREAK NIL "Enter break loop.")
(EVAL NIL
"Evaluate an arbitrary expression in current environment."
)
(RETURN NIL
"Prompt for value to return as result of current exp."
)
(↑ NIL "Throw to top level.")))
WHENSELECTEDFN ← (QUOTE %%STEP-WHENSELECTEDFN))))))
(%%STEP-WHENSELECTEDFN
(LAMBDA (ITEM MENU BUTTON) (* kbr: "13-Aug-86 10:40")
(PROG (COMMAND)
(SETQ COMMAND (CAR ITEM))
(PROCESS.EVAL (TTY.PROCESS)
(SELECTQ COMMAND
(AWAKEN (LIST (FUNCTION %%STEP-AWAKEN)))
(CLOSE (LIST (FUNCTION %%STEP-CLOSE)))
(LIST (FUNCTION %%STEP-BREAK-INTERRUPT)
(BQUOTE (QUOTE (\, COMMAND)))))))))
)
(%%STEP-INIT)
(* This is all stuff that should be eliminated once the real EVALHOOK mechanism is implemented.
*)
(RPAQ? *EVALHOOK* NIL)
(RPAQ? *SKIP-EVALHOOK* NIL)
(RPAQ? *APPLYHOOK* NIL)
(RPAQ? *SKIP-APPLYHOOK* NIL)
(DEFINEQ
(CL:EVALHOOK
(LAMBDA (FORM EVALHOOKFN APPLYHOOKFN ENV) (* kbr: "13-Aug-86 17:18")
(LET ((*EVALHOOK* EVALHOOKFN)
(*SKIP-EVALHOOK* T)
(*APPLYHOOK* APPLYHOOKFN)
(*SKIP-APPLYHOOK* NIL))
(%%STEP-EVAL FORM))))
(APPLYHOOK
(LAMBDA (FUNCTION ARGS EVALHOOKFN APPLYHOOKFN ENV) (* kbr: "13-Aug-86 17:19")
(LET ((*EVALHOOK* EVALHOOKFN)
(*SKIP-EVALHOOK* NIL)
(*APPLYHOOK* APPLYHOOKFN)
(*SKIP-APPLYHOOK* T))
(%%STEP-APPLY FUNCTION ARGS))))
)
(DEFINEQ
(%%STEP-LISPX
(LAMBDA (LISPXX LISPXID LISPXXMACROS LISPXXUSERFN LISPXFLG)(* lmm "11-Jul-86 18:01")
(* %%STEP-LISPX (for LISP eXec) is designed to save the user the task of
writing an exec by allowing him to easily tailor %%STEP-LISPX to his
applications. In this way, the user also gets the benefit of the history
features built into LISPX. %%STEP-LISPX determines the type of input, performs
any extra reads that are necessary, saves the input
(s) and the value on the history, and prints and returns the value.
(%%STEP-LISPX must do the printing since for history commands, see below,
nothing can be printed until the next call to LISPX.) -
-
There are currently six different classes of inputs:
(1) EVAL, i.e. forms; (2) APPLY, i.e. functions and arguments;
(3) forms without parentheses, i.e. lines, usually specifying CLISP
transformation, e.g. FOR X IN ... In this case the entire line is treated as a
form and EVALed; (4) commands, similar to edit macros, definitions are looked
up on LISPXMACROS; (5) user input, as determined by applying LISPXUSERFN.
If this yields T, the value of the event is the value of LISPXVALUE, which must
be set by LISPXUSERFN; and (6) history commands.
-
For types 1 thru 5, %%STEP-LISPX saves the inputs on the history list before
executing. Thus even if the operation is aborted, the user can redo it, fix it,
etc. -
For commands 1, 2, and 3, the function name is looked up on LISPXFNS.
if the user simply wants a different function called for tty inputs then in his
program, such as is the case with SETQ or SET, this can easily be done by
putting (fn1 . fn2) on the list LISPXFNS.
-
For commands of type 6, %%STEP-LISPX simply unreads the appropriate information
and exits. This means that if a user function calls %%STEP-LISPX when it cannot
interpret the input, history operations will work provided only that the user
function obtains its input via LISPXREAD, and that any inputs interpreted by
the user function also save the input on the history list.
This is the way BREAK1 uses LISPX.)
(* If LISPXFLG is T, any history commands are executed in this call to LISPX,
instead of unreading and exiting. This is used when the calling function knows
that the input should (must) be processed here, for example, in the E command
from the editor. Without this, E REDO would cause the input referred to by the
REDO command to be interpreted as edit commands instead of %%STEP-LISPX inputs.
If LISPXFLG is 'RETRY, CLOCK is backed up to force a BREAK on any error.)
(AND (NULL LISPXXMACROS)
(SETQ LISPXXMACROS LISPXMACROS))
(AND (NULL LISPXXUSERFN)
LISPXUSERFN
(FGETD (QUOTE LISPXUSERFN))
(SETQQ LISPXXUSERFN LISPXUSERFN))
(* If %%STEP-LISPX is called with its fifth argument, LISPXXUSERFN, non-NIL, it
is applied (with %%STEP-APPLY*)%. Otherwise, the top level value of LISPXUSERFN
is checked, and if non-NIL, LISPXUSERFN itself is called.
(The former is for calls from USEREXEC, the latter corresponds to the old way
of doing it. Similarly, if %%STEP-LISPX is called with its fourth argument,
LISPXXMACROS, non-NIL, it is used as the list of macros, otherwise the top
level value of LISPXMACROS is used.))
(PROG ((HELPCLOCK (CLOCK 2))
LISPXOP LISPXLISTFLG LISPXLINE (LISPXHIST LISPXHIST)
LISPY LISPZ LISPXVALUE LISPXTEM DONTSAVEFLG (HELPFLAG (COND
((EQ HELPFLAG (QUOTE BREAK!))
(* so that when you get in the break,
doesnt always break below that)
(GETTOPVAL (QUOTE HELPFLAG)))
(T HELPFLAG)))
LISPXVALUES)
(DECLARE (SPECVARS HELPFLAG LISPXVALUE LISPXVALUES))
(COND
((NULL LISPXX) (* Spurious right parentheses or
bracket.)
(RETURN (PRINT NIL T)))
((NLISTP LISPXX)
(SETQ LISPXLINE (READLINE T (LIST LISPXX)
T))
(* The third argument specifies that if there is juut a "]" or ")" on the line,
it should be read as a NIL, i.e. the line should be
(NIL)%. It also specifies that if the line begins with a list which is not
preceded by any spaces, the list is to terminate the line regardless of whether
or not it is terminated by a %]. Thus the usr can type fn
(args))
(SETQ LISPXX (CAR LISPXLINE))
(SETQ LISPXLINE (CDR LISPXLINE)) (* done this way so control-W will
work on first thing read from inside
of the readline.)
)
((AND (NULL REREADFLG)
(NOT (SYNTAXP (SETQ LISPXTEM (CHCON1 (LASTC T)))
(QUOTE RIGHTPAREN)
T))
(NOT (SYNTAXP LISPXTEM (QUOTE RIGHTBRACKET)
T))
(CDR (SETQ LISPXLINE (READLINE T (LIST LISPXX)
T))))
(* The expression input was a lis, although it was not terrnated with a right
parent or bracket, e.g. (QUOTE ZAP,) and furthermore there was something else
on the same line, so treat it as line input.
This enables user to type (QUOTE FOO) :EXPR)
(SETQ LISPXX LISPXLINE)))
TOP (COND
((LISTP LISPXX)
(SETQ LISPXOP (CAR LISPXX))
(SETQ LISPXLINE (CDR LISPXX))
(* This is for convenience of history commands: regardless of whether the
command was typed as a list or a line, LISPXOP is always the name of the
command, LISPXLINE its 'arguments'. If it turns out that LISPXOP is not a
history command, LISPXLINE will be set back to NIL
(below NOTCOM))
(SETQ LISPXLISTFLG T))
((NOT (LITATOM LISPXX))
(GO NOTCOM) (* User might have typed in a number
followed by something else)
)
(T (SETQ LISPXOP LISPXX)))
SELECT
(COND
((AND REREADFLG (EQ (SETQ LISPXTEM (CAR (LISTGET1 (CAAR LISPXHISTORY)
(QUOTE *HISTORY*))))
(QUOTE ORIGINAL))))
((SETQ LISPY (FASSOC LISPXOP LISPXXMACROS))
(AND LISPXLISTFLG (SETQ LISPXLINE NIL)) (* so historysave at DO-IT will get
called with the right aaguments.)
(SETQ DONTSAVEFLG (NULL (CADR LISPY)))
(GO DO-IT))
((SETQ LISPY (FASSOC LISPXOP LISPXHISTORYMACROS))
(SETQ DONTSAVEFLG (NULL (CADR LISPY)))
(GO REDOCOM)))
(SELECTQ LISPXOP
(ORIGINAL (GO REDOCOM))
(E (COND
((NULL LISPXLINE)
(GO NOTCOM)))
(SETQ LISPXX (SETQ LISPXOP (CAR LISPXLINE)))
(SETQ LISPXLINE (CDR LISPXLINE))
(GO NOTCOM))
((RETRY REDO REPEAT FIX USE ... redo repeat use fix retry)
(GO REDOCOM))
((name NAME)
(COND
((NULL LISPXLINE) (* To allow user to have NAME as the
name of a variable.)
(GO DO-IT)))
(GO REDOCOM))
((UNDO undo)
(AND (SETQ LISPXHIST (HISTORYSAVE LISPXHISTORY LISPXID NIL LISPXOP LISPXLINE))
(FRPLACA (CDDR LISPXHIST)
(UNDOLISPX LISPXLINE))))
((retry: RETRY:)
(AND (EQ REREADFLG (QUOTE ABORT))
(ERROR!))
(SETQ HELPFLAG (QUOTE BREAK!))
(SETQ LISPXX (CAR LISPXLINE))
(SETQ LISPXLINE (CDR LISPXLINE))
(GO TOP))
((forget FORGET)
(AND (EQ REREADFLG (QUOTE ABORT))
(ERROR!))
(MAPC (COND
(LISPXLINE (LISPXFIND LISPXHISTORY LISPXLINE (QUOTE ENTRIES)))
(T (CAR LISPXHISTORY)))
(FUNCTION (LAMBDA (X)
(UNDOLISPX2 X T))))
(PRINT (QUOTE forgotten)
T T))
(?? (AND (EQ REREADFLG (QUOTE ABORT))
(ERROR!))
(PRINTHISTORY (COND
((EQ (CAR LISPXLINE)
(QUOTE @@))
(SETQ LISPXLINE (CDR LISPXLINE))
ARCHIVELST)
(T LISPXHISTORY))
LISPXLINE NIL NIL T))
((archive ARCHIVE)
(AND (EQ REREADFLG (QUOTE ABORT))
(ERROR!)) (* Since these the commands do not
call HISTORYSAVE, we must check for
control-U followed by STOP here.)
(COND
(ARCHIVELST (FRPLACA ARCHIVELST (NCONC (SETQ LISPXTEM (LISPXFIND LISPXHISTORY
LISPXLINE
(QUOTE COPIES)))
(CAR ARCHIVELST)))
(FRPLACA (CDR ARCHIVELST)
(IPLUS (CADR ARCHIVELST)
(FLENGTH LISPXTEM)))
(PRINT (QUOTE archived)
T T))
(T (PRINT (QUOTE (no archive list))
T))))
(GO NOTCOM))
(RETURN (QUOTE %))
NOTCOM
(COND
((SETQ LISPY (GETPROP LISPXOP (QUOTE *HISTORY*)))
(* command defined by a NAME command.)
(COND
((NULL LISPXLINE)
(COND
((AND (OR (EQ LISPXID (QUOTE ←))
(EQ LISPXID (QUOTE :)))
(BOUNDP LISPXOP))
(* User typed command followd by just c.r.
since command is also the name of a variable, thats probably what he wants,
especially since he can always say REDO @ FOO)
(SETQ LISPY NIL))
(T (GO REDOCOM))))
((NULL (CAR LISPY))
(ERROR LISPXOP (QUOTE "doesn't take any arguments")))
(T (GO REDOCOM)))
(SETQ LISPY NIL))
((FMEMB LISPXOP LISPXCOMS)
(* Since LISPXOP is not one of the built in commands, and not on LISPXMACROS,
presumably the user has included it on LISPXCOMS because he is going to process
it in LISPXUSERFN. In any event, dont want to do any spelling correction.)
(AND LISPXLISTFLG (SETQ LISPXLINE NIL))
(GO DO-IT)))
(COND
(LISPXLISTFLG (* Input is a single list.)
(COND
((EQ (CAR LISPXX)
(QUOTE LAMBDA))
(SETQ LISPXLINE (LIST (LISPXREAD T T))))
(T (AND (LITATOM (CAR LISPXX))
(COND
((OR (FGETD (CAR LISPXX))
(GETLIS (CAR LISPXX)
MACROPROPS)
(GETLIS (CAR LISPXX)
(QUOTE (EXPR FILEDEF CLISPWORD))))
(AND ADDSPELLFLG (ADDSPELL (CAR LISPXX)
2)))
((AND DWIMFLG (SETQ LISPXOP (FIXSPELL (CAR LISPXX)
70 LISPXCOMS NIL LISPXX)))
(SETQ LISPXLINE (CDR LISPXX))
(GO SELECT))))
(AND LISPXLISTFLG (SETQ LISPXLINE NIL))))
(GO DO-IT))
((NULL LISPXLINE) (* Input is a single atom.)
(AND (LITATOM LISPXX)
(COND
((BOUNDP LISPXX)
(AND ADDSPELLFLG (ADDSPELL LISPXX 3)))
((AND DWIMFLG (SETQ LISPXOP (FIXSPELL LISPXX 70 LISPXCOMS NIL T)))
(COND
((LISTP LISPXOP) (* RUN-ON spelling error.)
(SETQ LISPXLINE (LIST (CDR LISPXOP)))
(SETQ LISPXOP (COND
((LISTP (CAR LISPXOP))
(* synonym)
(CADAR LISPXOP))
(T (CAR LISPXOP))))))
(SETQ LISPXX LISPXOP)
(GO SELECT))))
(GO DO-IT))
((NOT (LITATOM LISPXX)))
((FGETD LISPXX) (* put on SPELLINGS2 even though in
%%STEP-APPLY format since is also good
in %%STEP-EVAL format)
(AND ADDSPELLFLG (ADDSPELL LISPXX 2)))
((AND DWIMFLG (NULL (GETLIS LISPXX (QUOTE (EXPR FILEDEF))))
(SETQ LISPXOP (FIXSPELL LISPXX 70 LISPXCOMS NIL T)))
(COND
((LISTP LISPXOP)
(SETQ LISPXLINE (CONS (CDR LISPXOP)
LISPXLINE))
(SETQ LISPXOP (CAR LISPXOP))))
(SETQ LISPXX LISPXOP)
(GO SELECT)))
DO-IT
(AND (NULL DONTSAVEFLG)
(SETQ LISPXHIST (HISTORYSAVE LISPXHISTORY LISPXID NIL LISPXX LISPXLINE)))
(COND
(LISPY (SETQ LISPXVALUE (CAR (SETQ LISPXVALUES
(MULTIPLE-VALUE-LIST (LET ((LISPXLINE
(COND
(LISPXLISTFLG (CDR LISPXX))
(T (NLAMBDA.ARGS LISPXLINE)
))))
(%%STEP-EVAL (OR (CADR LISPY)
(CADDR LISPY))
LISPXID)))))))
((AND LISPXXUSERFN (FUNCALL LISPXXUSERFN LISPXX LISPXLINE))
(COND
(LISPXVALUES (SETQ LISPXVALUE (CAR LISPXVALUES)))
(T (SETQ LISPXVALUES (LIST LISPXVALUE)))))
(T (SETQ LISPXVALUE (CAR (SETQ LISPXVALUES
(MULTIPLE-VALUE-LIST
(COND
((NULL LISPXLINE) (* A form.)
(%%STEP-EVAL (COND
((NLISTP LISPXX)
LISPXX)
(T (LISPX/ LISPXX)))
LISPXID))
((OR (CDR LISPXLINE)
(AND CLISPFLG (LITATOM LISPXX)
(CAR LISPXLINE)
(LITATOM (CAR LISPXLINE))
(NEQ (SETQ LISPXTEM (NTHCHAR (CAR LISPXLINE)
1))
(QUOTE -))
(FMEMB LISPXTEM CLISPCHARS)
(NEQ (ARGTYPE LISPXX)
3)))
(* The special checks are to enable constructs like FOO ←T to work, even when
FOO is also the name of a function, i.e.
instead of applying FOO to ←T, (which would cause an unusal CDR ARGLIST error)
(FOO ← T) is evaluated, which will invoke DWIM.)
(COND
((NEQ (ARGTYPE LISPXX)
3)
(PRIN1 " = " T)
(PRINT (CONS LISPXX LISPXLINE)
T)))
(%%STEP-EVAL (LISPX/ (CONS LISPXX LISPXLINE))
LISPXID))
(T (%%STEP-APPLY (LISPX/ LISPXX)
(LISPX/ (CAR LISPXLINE)
LISPXX)
LISPXID)))))))))
(AND LISPXHIST (LISPXSTOREVALUE LISPXHIST LISPXVALUE LISPXVALUES))
(RETURN (PROGN (SETQ IT LISPXVALUE)
(for X in LISPXVALUES do (SHOWPRINT X T T))
(VALUES-LIST LISPXVALUES)))
REDOCOM
(SETQ LISPXX (COND
(LISPXLISTFLG (LIST LISPXX))
(T (CONS LISPXX LISPXLINE)))) (* The entire history command.)
(AND (NULL DONTSAVEFLG)
(SETQ LISPXHIST (HISTORYSAVE LISPXHISTORY LISPXID NIL NIL NIL (LIST (QUOTE *HISTORY*)
LISPXX
(QUOTE *GROUP*)
NIL))))
(SELECTQ LISPXOP
(ORIGINAL (SETQ LISPY (APPEND LISPXLINE)))
( (SETQ LISPY (LISPXUSEC LISPXLINE LISPXHISTORY)))
((retry RETRY)
(SETQ LISPY (CONS (QUOTE RETRY:)
(APPEND (LISPXFIND LISPXHISTORY LISPXLINE (QUOTE INPUT)
T)))))
((name NAME)
(SETQ LISPXTEM (CDR (OR (SETQ LISPZ (OR (FMEMB (QUOTE :)
LISPXLINE)
(FMEMB (QUOTE IN)
LISPXLINE)
(FMEMB (QUOTE in)
LISPXLINE)))
LISPXLINE))) (* LISPXTEM coresponds to the event
specification, LISPZ to the end of the
arguments, if any.)
(SETQ LISPZ (COND
((NULL LISPZ)
NIL)
((CDR (SETQ LISPZ (LDIFF (CDR LISPXLINE)
LISPZ)))
LISPZ)
((LISTP (CAR LISPZ)) (* user got confused and put in an
extra set of parens.)
(CAR LISPZ))
(T LISPZ)))
(SETQ LISPY (LISPXFIND LISPXHISTORY LISPXTEM (QUOTE INPUT)
T))
(RESETVARS ((EDITQUIETFLG T))
(MAPC LISPZ (FUNCTION (LAMBDA (X)
(COND
((NOT (HISTORYMATCH LISPY (EDITFPAT X T)))
(LISPXPRIN1 X T)
(MAPRINT LISPXTEM T (QUOTE
" does not appear in "
)
(QUOTE %
)
NIL NIL T)))))))
(/PUT (CAR LISPXLINE)
(QUOTE *HISTORY*)
(CONS LISPZ (CONS (APPEND LISPY)
(LISPXFIND LISPXHISTORY LISPXTEM (QUOTE COPIES)
T))))
(* The reason for storing the input separate frm the event
(s) is that the user may have performed NAME FOO USE -
meaning the USE input, rather than the normal input.
The reason for the append is that lispy will also be the input portion of the
name event on the history list, and we want it not to be smashed when that
entry is slips off the end of the history list.)
(/REMPROP (CAR LISPXLINE)
(QUOTE STATE))
(/SETATOMVAL (QUOTE LISPXCOMS)
(UNION (LIST (CAR LISPXLINE))
LISPXCOMS))
(/SETATOMVAL (QUOTE HISTORYCOMS)
(UNION (LIST (CAR LISPXLINE))
HISTORYCOMS))
(COND
((GETD (CAR LISPXLINE))
(MAPRINT (CONS (CAR LISPXLINE)
(QUOTE (is also the name of a function. When typed in, its
interpretation as a history command will take
precedence.)))
T "****Note: " (QUOTE %
)
NIL NIL T)))
(PRINT (CAR LISPXLINE)
T T))
((REDO redo REPEAT repeat)
(COND
((NULL (SOME LISPXLINE
(FUNCTION (LAMBDA (X TAIL)
(SELECTQ (CAR TAIL)
((WHILE UNTIL while until)
(COND
((AND (CDR TAIL)
(NEQ (CAR (SETQ LISPXTEM
(NLEFT LISPXLINE 1 TAIL))
)
(QUOTE F)))
(* backs up one)
(SETQ LISPXLINE
(AND LISPXTEM (LDIFF LISPXLINE
(CDR LISPXTEM))))
(AND (NULL (CDDR (SETQ LISPXTEM
(CDR TAIL))))
(OR (LISTP (CAR LISPXTEM))
(BOUNDP (CAR LISPXTEM))
(NOT (FNCHECK (CAR LISPXTEM)
T T T LISPXTEM)))
(SETQ LISPXTEM (CAR LISPXTEM)))
(COND
((OR (EQ (CAR TAIL)
(QUOTE UNTIL))
(EQ (CAR TAIL)
(QUOTE until)))
(SETQ LISPXTEM (LIST (QUOTE NOT)
LISPXTEM))))
T)))
((TIMES times)
(COND
((AND (NULL (CDR TAIL))
(SETQ LISPXTEM (NLEFT LISPXLINE 1
TAIL))
(NEQ (CAR LISPXTEM)
(QUOTE F)))
(SETQ LISPXLINE (LDIFF LISPXLINE LISPXTEM
))
(SETQ LISPXTEM (OR (NUMBERP (CAR LISPXTEM
))
T)))))
NIL)))))
(SETQ LISPXTEM (OR (EQ LISPXOP (QUOTE REPEAT))
(EQ LISPXOP (QUOTE repeat))))))
(SETQ LISPY (LISPXFIND LISPXHISTORY LISPXLINE (QUOTE INPUT)
T))
(COND
((EQ LISPXID (QUOTE *)) (* For editor.)
(SETQ LISPY (COPY LISPY)))
(T (* Cant allow same input to appear
twice in history.)
(SETQ LISPY (APPEND LISPY))))
(COND
(LISPXTEM (SETQ LISPY (LIST HISTSTR2 LISPXTEM LISPY)))))
((FIX fix)
(SETQ LISPY (COPY (LISPXFIND LISPXHISTORY (COND
((SETQ LISPXTEM (FMEMB (QUOTE -)
LISPXLINE))
(* User can say FIX -
and give the commands. Then he doesn't have to wait for editor to print EDIT,
and him to type OK at the end. Also, the commands stored on the history list in
this fashion can be reexecuted by a REDO FIX command.)
(LDIFF LISPXLINE LISPXTEM))
(T LISPXLINE))
(QUOTE INPUT)
T)))
(SETQ LISPY (COND
((STREAMPROP (GETSTREAM T)
(QUOTE FIXFN))
(%%STEP-APPLY* (STREAMPROP (GETSTREAM T)
(QUOTE FIXFN))
(GETSTREAM T)
LISPY
(CDR LISPXTEM)))
(T (LISPXFIX LISPY (CDR LISPXTEM)))))
(* usually defined as just a call to EDITL but can be advised to handle string
situations, such as in BARD. If the stream has a FIX function %%STEP-APPLY it
instead of the default)
)
((USE use)
(SETQ LISPY (LISPXUSE LISPXLINE LISPXHISTORY LISPXHIST)))
(... (COND
((NULL LISPXLINE)
(ERROR (QUOTE "... what??")
(QUOTE %)
T)))
(SETQ LISPY (LISPXFIND LISPXHISTORY NIL (QUOTE ENTRY)
T))
(SETQ LISPXTEM (COND
((LISTGET1 LISPY (QUOTE ...ARGS)))
((SETQ LISPXTEM (LISTGET1 LISPY (QUOTE USE-ARGS)))
(* The CAAAR is because CAR is the
list of USEARGS which is a list of
list of variables.)
(CONS (CAAAR LISPXTEM)
(CDR LISPXTEM)))
((SETQ LISPXTEM (LISTGET1 LISPY (QUOTE *HISTORY*)))
(* E.g. a lispxmacro or
lispxhistorymacro.)
(CONS (CADR LISPXTEM)
(LISPXGETINPUT LISPXTEM (CONS LISPXTEM (CDR LISPY)))))
(T (SETQ LISPY (LISPXFIND LISPXHISTORY NIL (QUOTE INPUT)
T))
(CONS (COND
((OR (NULL (CDR LISPY))
(EQ (CADR LISPY)
HISTSTR0))
(* %%STEP-EVAL input, substitute for
first argument which is CADAR)
(CADAR LISPY))
((NLISTP (CADR LISPY))
(* e.g. PP FOO)
(CADR LISPY))
(T (* %%STEP-APPLY input.
e.g. LOAD (FOO) substitute for FOO)
(CAADR LISPY)))
LISPY)))) (* LIPXTEM is now a dotted pair of
aagument and input.)
(NCONC LISPXHIST (LIST (QUOTE ...ARGS)
LISPXTEM))
(SETQ LISPY (LISPXUSE0 (LIST LISPXLINE)
(LIST (LIST (CAR LISPXTEM)))
(LIST (CDR LISPXTEM)))))
(SETQ LISPY (COND
((EQ (CAR LISPY)
LISPXOP) (* from lispxhistorymacro.)
(%%STEP-EVAL (OR (CADR LISPY)
(CADDR LISPY))
LISPXID))
((NULL (CAR LISPY)) (* Command defined by name command,
with no arguments)
(APPEND (CADR LISPY)))
(T (* From name command.)
(LISPXUSE0 (LIST LISPXLINE)
(LIST (CAR LISPY))
(LIST (CADR LISPY)))))))
(* LISPY is now the input.)
(AND (NULL REREADFLG)
(FMEMB HISTSTR2 (LISTP LISPY))
(SETQ REDOCNT -1))
(* the -1 is because the first thing that will happen will be a call to
lispxrepeatread which will increment redocnt to 0 the check is made here
instead of inside the selectq at REDO because of cases where user does USE on
an event involving aREPEAT input)
(AND LISPXHIST (FRPLACA LISPXHIST LISPY))
(COND
((EQ LISPXOP (QUOTE NAME))
(* NAME is handled as a history command so that the command is stored before it
tries to do the lookup, and to share in other common code.
but it is not actually redone or unread.)
)
(LISPXFLG (RESETVARS (READBUF)
(LISPXUNREAD LISPY LISPXHIST)
LP (COND
((NULL (SETQ READBUF (LISPXREADBUF READBUF)))
(RETURN)))
(%%STEP-LISPX (LISPXREAD T T)
LISPXID)
(GO LP)))
(T (LISPXUNREAD LISPY LISPXHIST)))
(RETURN LISPXHIST))))
(%%STEP-EVALQT
(LAMBDA (LISPXID) (* kbr: "13-Aug-86 17:29")
(PROG NIL
(COND
((NULL LISPXID)
(SETQQ LISPXID ←)
(ENTEREVALQT)))
(FRESHLINE T)
LP (PROMPTCHAR LISPXID T LISPXHISTORY) (* this errorset is so that
EVALQTFORMS dont get unnecessarily
evaluated following each error on
typein. they are only for control-d.)
(COND
((NULL (ERSETQ (LET ((*EVALHOOK* (FUNCTION %%STEP-COMMAND-LOOP)))
(%%STEP-LISPX (LISPXREAD T T)
LISPXID))))
(SETQ TOPLISPXBUFS (OR (CLBUFS T)
TOPLISPXBUFS))
(TERPRI T)))
(* User may turn stepper off for the remainder of the evaluation of some
particular top level form. So after each evaluation of a top level form, the
stepper is turned back on if not already on.
*)
(%%STEP-AWAKEN)
(GO LP))))
(%%STEP-READ-EVAL-PRINT
(LAMBDA NIL (* kbr: "13-Aug-86 11:29")
(PROG NIL
LP (%%STEP-EVALQT (QUOTE <))
(GO LP))))
)
(DEFINEQ
(%%STEP-SPREADAPPLY*
(LAMBDA (FN TAIL) (* kbr: "13-Aug-86 20:39")
(PROG (ANSWER)
(SETQ FN (%%STEP-FN FN))
(SETQ ANSWER (COND
((AND (LITATOM FN)
(fetch (LITATOM CCODEP) of FN))
(SPREADAPPLY* FN TAIL))
(T (BREAK1 NIL T))))
(RETURN ANSWER))))
(%%STEP-SPREADAPPLY
(LAMBDA (FN TAIL) (* kbr: "13-Aug-86 20:39")
(PROG (ANSWER DEF)
(SETQ FN (%%STEP-FN FN))
(SETQ ANSWER (COND
((AND (LITATOM FN)
(fetch (LITATOM CCODEP) of FN))
(SPREADAPPLY FN TAIL))
(T (SETQ DEF (GETD FN))
(EVAL (BQUOTE ((LAMBDA (\, (CADR DEF))
(for FORM in (QUOTE (\, (CDDR DEF)))
do (%%STEP-EVAL FORM)))
(\,@ (for FORM in TAIL collect (KWOTE FORM)))))))))
(RETURN ANSWER))))
(%%STEP-.EVALFORM.
(LAMBDA (FN TAIL) (* kbr: "13-Aug-86 20:38")
(%%STEP-APPLY (%%STEP-FN FN)
(for ELEMENT in TAIL collect (%%STEP-EVAL ELEMENT)))))
(%%STEP-APPLY*
(LAMBDA U (* lmm " 5-Jun-86 03:28")
(PROG ((DEF (AND (IGREATERP U 0)
(ARG U 1))))
LP (COND
((LITATOM DEF)
(COND
((fetch (LITATOM CCODEP) of DEF)
(COND
((EQ (fetch (LITATOM ARGTYPE) of DEF)
3)
(GO NOSPR))
(T (GO SPR))))
(T (* EXPR)
(SETQ DEF (OR (LISTP (fetch (LITATOM DEFPOINTER) of DEF))
(GO FAULT))))))
((CCODEP DEF)
(GO SPR))
((NLISTP DEF)
(GO FAULT)))
(SELECTQ (CAR DEF)
((LAMBDA CL:LAMBDA)
NIL)
(FUNARG (SETQ DEF (CADR DEF))
(GO LP))
(NLAMBDA (COND
((AND (CAR (LISTP (CDR DEF)))
(NLISTP (CADR DEF)))
(GO NOSPR))))
(OPENLAMBDA)
(GO FAULT))
SPR (RETURN (SELECTQ U
(1 (* no args)
(%%STEP-SPREADAPPLY* (ARG U 1)))
(2 (* 1 arg)
(%%STEP-SPREADAPPLY* (ARG U 1)
(ARG U 2)))
(3 (* 2 args)
(%%STEP-SPREADAPPLY* (ARG U 1)
(ARG U 2)
(ARG U 3)))
(4 (* 3 args)
(%%STEP-SPREADAPPLY* (ARG U 1)
(ARG U 2)
(ARG U 3)
(ARG U 4)))
(%%STEP-SPREADAPPLY (ARG U 1)
(for I from 2 to U collect (ARG U I)))))
FAULT
(RETURN (FAULTAPPLY DEF (for I from 2 to U collect (ARG U I))))
NOSPR
(* NLAMBDA*)
(RETURN (%%STEP-SPREADAPPLY* (ARG U 1)
(for I from 2 to U collect (ARG U I)))))))
(%%STEP-APPLY
(LAMBDA (U V \INTERNAL)
(DECLARE (SPECVARS \INTERNAL)) (* kbr: "12-Aug-86 20:07")
(PROGN (* body for APPLY, used by RETAPPLY
too)
(PROG ((DEF U))
LP (COND
((LITATOM DEF)
(COND
((NOT (fetch (LITATOM CCODEP) of DEF))
(* EXPR)
(SETQ DEF (fetch (LITATOM DEFPOINTER) of DEF)))
((EQ (fetch (LITATOM ARGTYPE) of DEF)
3)
(GO NLSTAR))
(T (GO NORMAL)))))
(COND
((LISTP DEF)
(SELECTQ (CAR DEF)
(NLAMBDA (AND (NLISTP (CADR DEF))
(CADR DEF)
(GO NLSTAR)))
(FUNARG (SETQ DEF (CADR DEF))
(GO LP))
NIL))
((NULL DEF)
(RETURN (FAULTAPPLY U V))))
NORMAL
(RETURN (%%STEP-SPREADAPPLY U V))
NLSTAR
(* NLAMBDA*)
(RETURN (%%STEP-SPREADAPPLY* U V))))))
(%%STEP-\EVALFORM
(LAMBDA (FORM TEMP)
(DECLARE (SPECVARS FORM)
(ADDTOVAR LAMS FAULTEVAL)) (* kbr: "12-Aug-86 19:57")
(* eval of LISTP)
(PROG NIL
RETRY
(COND
((LITATOM (SETQ TEMP (CAR FORM)))
(COND
((fetch (LITATOM CCODEP) of TEMP)
(SELECTQ (fetch (LITATOM ARGTYPE) of TEMP)
(1 (GO NLSPREAD))
(3 (GO NLNOSPREAD))
(GO EVLAM)))
(T (* EXPR OR UDF)
(SETQ TEMP (fetch (LITATOM DEFPOINTER) of TEMP))))))
(* TEMP is now definition of EXPR)
(TYPECASE TEMP (CLOSURE (* falls out))
(CONS (SELECTQ (CAR TEMP)
(NLAMBDA (COND
((OR (LISTP (SETQ TEMP (CADR TEMP)))
(NULL TEMP))
(GO NLSPREAD))
(T (GO NLNOSPREAD))))
((CL:LAMBDA LAMBDA OPENLAMBDA))
(GO FAULT)))
(T (GO FAULT)))
EVLAM
(* THIS FUNCTION'S DEFINITION VERY
DEPENDENT ON THE SPECIAL MACRO IN ALAP
FOR COMPILING IT. -
SEE CEVALFORM)
(RETURN (%%STEP-.EVALFORM. (CAR FORM)
(CDR FORM)))
NLSPREAD
(RETURN (%%STEP-SPREADAPPLY (CAR FORM)
(CDR FORM)))
NLNOSPREAD
(RETURN (%%STEP-SPREADAPPLY* (CAR FORM)
(CDR FORM)))
FAULT
(COND
((AND CLISPARRAY (LISTP (SETQ TEMP (GETHASH FORM CLISPARRAY))))
(SETQ FORM TEMP)
(GO RETRY)))
(RETURN (FAULTEVAL FORM)))))
(%%STEP-\EVAL
(LAMBDA (FORM) (* kbr: "12-Aug-86 19:40")
(COND
((LISTP FORM)
(%%STEP-\EVALFORM FORM))
((LITATOM FORM)
(\EVALVAR FORM))
((NUMBERP FORM)
FORM)
(T (\EVALOTHER FORM)))))
(%%STEP-EVAL
(LAMBDA (U \INTERNAL)
(DECLARE (SPECVARS \INTERNAL)) (* kbr: "13-Aug-86 17:24")
(COND
((AND *EVALHOOK* (PROG1 (NOT *SKIP-EVALHOOK*)
(SETQ *SKIP-EVALHOOK* NIL)))
(LET ((HOOKFN *EVALHOOK*)
(*EVALHOOK* NIL))
(%%STEP-APPLY* HOOKFN U)))
(T (%%STEP-\EVAL U)))))
)
(DEFINEQ
(%%STEP-PROG1
(NLAMBDA U
(DECLARE (SPECVARS *TAIL*)) (* kbr: "13-Aug-86 20:31")
(AND (LISTP U)
(PROG ((*TAIL* U))
(RETURN (PROG1 (%%STEP-EVAL (CAR *TAIL*))
(PROG NIL
LP (COND
((LISTP (SETQ *TAIL* (CDR *TAIL*)))
(%%STEP-EVAL (CAR *TAIL*))
(GO LP))))))))))
(%%STEP-SETQ
(NLAMBDA U (* kbr: "13-Aug-86 20:29")
(* (%%STEP-SETQ X Y + 3) MUST TRY TO
EVAL +)
(\SETVAR (CAR U)
(PROG ((*TAIL* (CDR U)))
(DECLARE (SPECVARS *TAIL*))
(RETURN (PROG1 (%%STEP-EVAL (CAR *TAIL*))
(PROG NIL
LP (COND
((LISTP (%%STEP-SETQ *TAIL* (CDR *TAIL*)))
(%%STEP-EVAL (CAR *TAIL*))
(GO LP))))))))))
(%%STEP-\EVPROGN
(LAMBDA (*TAIL*) (* kbr: "13-Aug-86 20:29")
(DECLARE (SPECVARS *TAIL*))
(PROG NIL
LP (COND
((CDR *TAIL*)
(%%STEP-EVAL (CAR *TAIL*))
(SETQ *TAIL* (CDR *TAIL*))
(GO LP))
(T (RETURN (%%STEP-EVAL (CAR *TAIL*))))))))
(%%STEP-COND
(NLAMBDA U
(DECLARE (SPECVARS *TAIL*)) (* kbr: "13-Aug-86 20:29")
(PROG ((*TAIL* U)
VAL)
LP (RETURN (COND
((NLISTP *TAIL*)
(COND
(*TAIL* (LISPERROR "UNUSUAL CDR ARG LIST" *TAIL*))
(T NIL)))
((SETQ VAL (%%STEP-EVAL (CAAR *TAIL*)))
(COND
((CDAR *TAIL*)
(%%STEP-\EVPROGN (CDAR *TAIL*)))
(T VAL)))
(T (SETQ *TAIL* (CDR *TAIL*))
(GO LP)))))))
(%%STEP-PROGN
(NLAMBDA U (* kbr: "13-Aug-86 20:27")
(* MUST be a NLAMBDA* with internal
call to EVAL for dwimsake)
(DECLARE (SPECVARS *TAIL*))
(AND (LISTP U)
(PROG ((*TAIL* U))
LP (COND
((NLISTP (CDR *TAIL*))
(RETURN (%%STEP-EVAL (CAR *TAIL*))))
(T (%%STEP-EVAL (CAR *TAIL*))
(SETQ *TAIL* (CDR *TAIL*))
(GO LP)))))))
(%%STEP-OR
(NLAMBDA U
(DECLARE (SPECVARS *TAIL*)) (* kbr: "13-Aug-86 20:27")
(AND (LISTP U)
(PROG ((*TAIL* U))
LP (RETURN (COND
((NLISTP (CDR *TAIL*))
(%%STEP-EVAL (CAR *TAIL*)))
(T (%%STEP-OR (%%STEP-EVAL (CAR *TAIL*))
(PROGN (SETQ *TAIL* (CDR *TAIL*))
(GO LP))))))))))
(%%STEP-AND
(NLAMBDA U
(DECLARE (SPECVARS *TAIL*)) (* kbr: "13-Aug-86 20:27")
(OR (NLISTP U)
(PROG ((*TAIL* U))
LP (RETURN (COND
((NLISTP (CDR *TAIL*))
(%%STEP-EVAL (CAR *TAIL*)))
((%%STEP-EVAL (CAR *TAIL*))
(SETQ *TAIL* (CDR *TAIL*))
(GO LP))))))))
(%%STEP-RETURN
(NLAMBDA (FORM)
(DECLARE (LOCALVARS . T)) (* kbr: "13-Aug-86 20:25")
(LET ((MV (MULTIPLE-VALUE-LIST (%%STEP-EVAL FORM))))
(PROG ((FRAME (\MYALINK)))
LP (COND
((EQ (fetch (FNHEADER FRAMENAME) of (fetch (FX NAMETABLE) of FRAME))
(FUNCTION %%STEP-\PROG0))
(SETQ FRAME (fetch (FX CLINK) of FRAME)) (* Its caller, i.e. PROG)
(\SMASHLINK NIL FRAME FRAME) (* Make us return to PROG with this
value)
(RETURN (VALUES-LIST MV)))
((NOT (fetch (FX INVALIDP) of (SETQ FRAME (fetch (FX CLINK) of FRAME))))
(GO LP))
(T (LISPERROR "ILLEGAL RETURN")))))))
(%%STEP-GO
(NLAMBDA U (* kbr: "13-Aug-86 20:26")
(PROG ((FRAME (\MYALINK))
(LABEL (CAR U))
GOTAIL FIRSTARG)
LP (COND
((EQ (fetch (FNHEADER FRAMENAME) of (fetch (FX NAMETABLE) of FRAME))
(FUNCTION %%STEP-\PROG0))
(COND
((SETQ GOTAIL (FMEMB LABEL (CDR (STACKGETBASEPTR (SETQ FIRSTARG
(fetch (BF IVAR)
of (fetch (FX BLINK)
of FRAME)))))))
(* first argument of \PROG0 is the
actual tail of the prog, which can
contain the labels. Second argument is
the "current" *TAIL*)
(STACKPUTBASEPTR (IPLUS FIRSTARG WORDSPERCELL)
GOTAIL) (* Reset *TAIL* in the \PROG0 frame)
(\SMASHLINK NIL FRAME FRAME) (* Fix it so we return to \PROG0 to
continue evaluating after label)
(RETURN NIL)))))
(COND
((NOT (fetch (FX INVALIDP) of (SETQ FRAME (fetch (FX CLINK) of FRAME))))
(GO LP))
(T (LISPERROR "UNDEFINED OR ILLEGAL GO" LABEL))))))
(%%STEP-\PROG0
(LAMBDA (*FIRSTTAIL* *TAIL* NNILS NVARS NTSIZE VARLST) (* kbr: "13-Aug-86 20:24")
(DECLARE (SPECVARS *TAIL* *FIRSTTAIL*))
(PROG NIL
(COND
(VARLST
(* * Create a nametable inside progframe where PROG pushed all those nils)
(PROG ((PROGFRAME (\MYALINK))
HEADER NT NILSTART)
(SETQ HEADER (fetch (FX FNHEADER) of PROGFRAME))
(SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART
(IDIFFERENCE (fetch (FX NEXTBLOCK)
of PROGFRAME)
(UNFOLD NNILS WORDSPERCELL)))
(UNFOLD NVARS WORDSPERCELL))
WORDSPERQUAD)))
(* NT is address of our synthesized
nametable: beginning of NIL's, not
counting additional PVARs we are about
to bind, rounded up to quadword)
(for VAR in VARLST as VALUEOFF from NILSTART by WORDSPERCELL
do (* evaluate initial values first)
(COND
((LISTP VAR)
(PUTBASEPTR \STACKSPACE VALUEOFF (\EVPROG1 (CDR VAR))))))
(* then build NT)
(UNINTERRUPTABLY
(for VAR in VARLST as VAR#
from (FOLDLO (IDIFFERENCE NILSTART (fetch (FX FIRSTPVAR)
of PROGFRAME))
WORDSPERCELL) as NT1 from (fetch (FNHEADER OVERHEADWORDS
) of T)
as NT2 from (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T)
NTSIZE)
do (PUTBASE NT NT1 (\ATOMVALINDEX (COND
((LISTP VAR)
(CAR VAR))
(T VAR))))
(PUTBASE NT NT2 (IPLUS PVARCODE VAR#)))
(replace (FNHEADER #FRAMENAME) of NT with (QUOTE %%STEP-PROG))
(replace (FNHEADER NTSIZE) of NT with NTSIZE)
(* Do I need to worry about STK, NA,
PV, START, ARGTYPE NLOCALS ? -
no)
(replace (FX NAMETABLE) of PROGFRAME with NT)))))
EVLP
(COND
((NULL (SETQ *TAIL* (CDR *TAIL*)))
(RETURN NIL))
(T (%%STEP-EVAL (OR (LISTP (CAR *TAIL*))
(GO EVLP)))
(GO EVLP))))))
(%%STEP-PROG
(NLAMBDA U (* kbr: "13-Aug-86 20:24")
(* %%STEP-PROG unpacks the argument
list and changes any EVAL type forms
by evaluating the form and then
smashing the name and value)
(* NOTE --- this mechanism might confuse DWIM someday because the arguments
inside the %%STEP-PROG are evaluated at a time when the %%STEP-PROG frame is in
a very funny state: the "values" are the variables, and the variables are NIL)
(%%STEP-PROG ((NVARS 0)
(VARLST (CAR U))
NTSIZE NNILS)
(for VAR in VARLST do (* Count number of vars to bind, check
validity)
(COND
((OR (NULL (\DTEST (COND
((LISTP VAR)
(SETQ VAR (CAR VAR)))
(T VAR))
(QUOTE LITATOM)))
(EQ VAR T))
(LISPERROR "ATTEMPT TO BIND NIL OR T" VAR)))
(add NVARS 1))
(RETURN (.CALLAFTERPUSHINGNILS. (SETQ NNILS (IPLUS NVARS (SETQ NTSIZE (CEIL (ADD1 NVARS)
WORDSPERQUAD))
(FOLDHI (fetch (FNHEADER OVERHEADWORDS)
of T)
WORDSPERCELL)
(SUB1 CELLSPERQUAD)))
(%%STEP-\PROG0 U U NNILS NVARS NTSIZE VARLST))))))
)
(* See example on page 323 *)
(RPAQ? *HOOKLEVEL* 0)
(DEFINEQ
(HOOK
(LAMBDA (X) (* kbr: "12-Aug-86 21:16")
(LET ((*EVALHOOK* (QUOTE EVAL-HOOK-FUNCTION)))
(%%STEP-EVAL X))))
(EVAL-HOOK-FUNCTION
(LAMBDA (FORM ENVIRONMENT) (* kbr: "12-Aug-86 21:43")
(LET ((*HOOKLEVEL* (+ *HOOKLEVEL* 1)))
(FORMAT *TRACE-OUTPUT* "~%%~V@TForm: ~S" (CL:* *HOOKLEVEL* 2)
FORM)
(LET ((VALUES (MULTIPLE-VALUE-LIST (CL:EVALHOOK FORM (FUNCTION EVAL-HOOK-FUNCTION)
NIL ENVIRONMENT))))
(* Slight change here because of some
problem with FORMAT *)
(FORMAT *TRACE-OUTPUT* "~%%~V@TValue: ~S" (CL:* *HOOKLEVEL* 2)
VALUES)
(VALUES-LIST VALUES)))))
(HOOK-TEST
(LAMBDA NIL (* kbr: "12-Aug-86 21:51")
(HOOK (QUOTE (CONS (CL:FLOOR *PRINT-BASE* 3)
(QUOTE B))))))
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA %%STEP-APPLY* STEP)
)
(PRETTYCOMPRINT CMLSTEPCOMS)
(RPAQQ CMLSTEPCOMS ((* * CMLSTEP -- Single Stepper STEP -- By Kelly Roach *)
(INITVARS (%%*STEP-PRINT-LEVEL* 4)
(%%*STEP-PRINT-LENGTH* 5)
(%%*STEP-MAX-INDENTATION* 40)
(%%*STEP-STATE* NIL)
(%%*STEP-INDENTATION-LEVEL* 0))
(FNS %%STEP-AWAKEN %%STEP-CLOSE %%STEP-ABORT %%STEP-SLEEP %%STEP-STEP-FORM
%%STEP-EVAL-FORM)
(FNS %%STEP-PRINT %%STEP-PRINT-VALUES %%STEP-COMMAND-LOOP %%STEP-BREAK-LOOP
%%STEP-BREAK-INTERRUPT %%STEP-PARSE-FUNCTIONS %%STEP STEP)
(FNS %%STEP-INIT %%STEP-WHENSELECTEDFN)
(P (%%STEP-INIT))
(COMS (* This is all stuff that should be eliminated once the real EVALHOOK
mechanism is implemented. *)
(INITVARS (*EVALHOOK* NIL)
(*SKIP-EVALHOOK* NIL)
(*APPLYHOOK* NIL)
(*SKIP-APPLYHOOK* NIL))
(FNS CL:EVALHOOK APPLYHOOK)
(FNS %%STEP-LISPX %%STEP-EVALQT %%STEP-READ-EVAL-PRINT)
(FNS %%STEP-SPREADAPPLY* %%STEP-SPREADAPPLY %%STEP-.EVALFORM. %%STEP-APPLY*
%%STEP-APPLY %%STEP-\EVALFORM %%STEP-\EVAL %%STEP-EVAL)
(FNS %%STEP-PROG1 %%STEP-SETQ %%STEP-\EVPROGN %%STEP-COND %%STEP-PROGN
%%STEP-OR %%STEP-AND %%STEP-RETURN %%STEP-GO %%STEP-\PROG0 %%STEP-PROG
)
(* See example on page 323 *)
(INITVARS (*HOOKLEVEL* 0))
(FNS HOOK EVAL-HOOK-FUNCTION HOOK-TEST))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA %%STEP-PROG %%STEP-GO %%STEP-AND %%STEP-OR %%STEP-PROGN
%%STEP-COND %%STEP-SETQ %%STEP-PROG1)
(NLAML %%STEP-RETURN)
(LAMA %%STEP-APPLY* STEP)))))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA %%STEP-PROG %%STEP-GO %%STEP-AND %%STEP-OR %%STEP-PROGN %%STEP-COND %%STEP-SETQ
%%STEP-PROG1)
(ADDTOVAR NLAML %%STEP-RETURN)
(ADDTOVAR LAMA %%STEP-APPLY* STEP)
)
(PUTPROPS CMLSTEP COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3126 7017 (%%STEP-AWAKEN 3136 . 5023) (%%STEP-CLOSE 5025 . 5798) (%%STEP-ABORT 5800 .
6026) (%%STEP-SLEEP 6028 . 6369) (%%STEP-STEP-FORM 6371 . 6729) (%%STEP-EVAL-FORM 6731 . 7015)) (7018
16235 (%%STEP-PRINT 7028 . 7919) (%%STEP-PRINT-VALUES 7921 . 8998) (%%STEP-COMMAND-LOOP 9000 . 12543)
(%%STEP-BREAK-LOOP 12545 . 12744) (%%STEP-BREAK-INTERRUPT 12746 . 13399) (%%STEP-PARSE-FUNCTIONS 13401
. 14389) (%%STEP 14391 . 16043) (STEP 16045 . 16233)) (16236 18956 (%%STEP-INIT 16246 . 18456) (
%%STEP-WHENSELECTEDFN 18458 . 18954)) (19203 19787 (CL:EVALHOOK 19213 . 19494) (APPLYHOOK 19496 .
19785)) (19788 57413 (%%STEP-LISPX 19798 . 55892) (%%STEP-EVALQT 55894 . 57211) (
%%STEP-READ-EVAL-PRINT 57213 . 57411)) (57414 65983 (%%STEP-SPREADAPPLY* 57424 . 57871) (
%%STEP-SPREADAPPLY 57873 . 58673) (%%STEP-.EVALFORM. 58675 . 58912) (%%STEP-APPLY* 58914 . 61424) (
%%STEP-APPLY 61426 . 62962) (%%STEP-\EVALFORM 62964 . 65271) (%%STEP-\EVAL 65273 . 65571) (%%STEP-EVAL
65573 . 65981)) (65984 78732 (%%STEP-PROG1 65994 . 66517) (%%STEP-SETQ 66519 . 67282) (
%%STEP-\EVPROGN 67284 . 67663) (%%STEP-COND 67665 . 68353) (%%STEP-PROGN 68355 . 69002) (%%STEP-OR
69004 . 69520) (%%STEP-AND 69522 . 69981) (%%STEP-RETURN 69983 . 70899) (%%STEP-GO 70901 . 72640) (
%%STEP-\PROG0 72642 . 76420) (%%STEP-PROG 76422 . 78730)) (78798 79970 (HOOK 78808 . 78996) (
EVAL-HOOK-FUNCTION 78998 . 79765) (HOOK-TEST 79767 . 79968)))))
STOP