(FILECREATED " 1-Aug-86 01:46:10" {ERIS}<LISPCORE>LIBRARY>CMLEXEC.;21 48733
changes to: (FNS \PICK.EVALQT \ADD-EXEC)
previous date: "31-Jul-86 20:02:28" {ERIS}<LISPCORE>LIBRARY>CMLEXEC.;19)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLEXECCOMS)
(RPAQQ CMLEXECCOMS
[(VARS CMLPROMPT)
(FNS CMLEXEC DO-APPLY-EVENT DO-HISTORY-SEARCH EVAL-INPUT EXEC-READ-LINE
GET-NEXT-HISTORY-EVENT HISTORY-ADD-TO-SPELLING-LISTS HISTORY-NTH PRINT-HISTORY
FIND-HISTORY-EVENTS PRINT-EVENT PRINT-EVENT-PROMPT PROCESS-EXEC-ID
SEARCH-FOR-EVENT-NUMBER \PICK.EVALQT)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (CHANGENAME (QUOTE \PROC.REPEATEDLYEVALQT)
(QUOTE EVALQT)
(QUOTE \PICK.EVALQT))
(SETQ BackgroundMenu)))
(STRUCTURES COMMAND-ENTRY EVENT EXEC-FONTS HISTORY)
(VARIABLES BREAK-COMMANDS CL:* ** *** *EXEC-FONTS* *NOT-YET-EVALUATED* + ++ +++ - / // ///
EXEC-COMMANDS *DEFAULT-EXECUTIVE*)
(FUNCTIONS CASE-EQUALP DEFCOMMAND EVENT-PROPS LISPXFORMAT)
(FNS \ADD-EXEC)
(ALISTS (BackgroundMenuCommands EXEC))
(PROP FILETYPE CMLEXEC)
(DEFINE-TYPES COMMANDS)
(COMMANDS ? ?= ?? ??T AFTER BEFORE CONN DA DIR DO-EVENTS FIX NDIR OK PB PL REMEMBER SHH UNDO
REDO FORGET)
(PROP EXEC COMMON-LISP INTERLISP)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA \ADD-EXEC CMLEXEC])
(RPAQQ CMLPROMPT "> ")
(DEFINEQ
(CMLEXEC
(CL:LAMBDA
(&KEY (PROMPT CMLPROMPT)
((:COMMANDS *THIS-EXEC-COMMANDS*)
NIL)
ENVIRONMENT
(FUNCTION (FUNCTION EVAL-INPUT))
((:READTABLE *READTABLE*)
CMLRDTBL)
TOP-LEVEL-P TITLE) (* lmm "31-Jul-86 19:51")
"A Common Lisp Exec. PROMPT"
(DECLARE (SPECIAL *THIS-EXEC-COMMANDS* *READTABLE*)) (* lmm "31-Jul-86 16:59")
(CL:WHEN TOP-LEVEL-P (ENTEREVALQT)) (*
"ENTEREVALQT is a hack from the old exec that handles top level"
"response to RESETLST and makes sure that if you control-D out"
"of a break window that the TTY gets reset. Can remove only after"
"RESETLST is fixed to use unwinders and the debugger uses 'em too")
(LET (*EXEC-ID* (#RPARS NIL)
*CURRENT-EVENT* VALUES (*CURRENT-EXECUTIVE-TYPE* (QUOTE COMMON-LISP))
(OUTPUT (GETSTREAM T (QUOTE OUTPUT))))
(DECLARE (SPECIAL *THIS-EXEC-COMMANDS* *READTABLE* #RPARS *EXEC-ID* *CURRENT-EXECUTIVE-TYPE*
*CURRENT-EVENT*)) (*
"rebind *READTABLE* to the Common Lisp one, this is a Common Lisp"
"Exec. #RPARS is in case the prettyprinter wants to print them out"
"Should be unnecessary (predicated on whether the readtable has"
"brackets in it, but in practice, not"
"*CURRENT-EVENT* is the event being processed. Some of the commands"
"want to know it."
" *CURRENT-EXECUTIVE-TYPE* is so that breaks will get the same kind")
(SETQ *EXEC-ID* (PROCESS-EXEC-ID (THIS.PROCESS)))
(LOOP (ERSETQ (PROGN (SETQ *CURRENT-EVENT* (GET-NEXT-HISTORY-EVENT LISPXHISTORY *EXEC-ID*
(NOT TOP-LEVEL-P)))
(* The TOP-LEVEL-P indicates that this is a reentry at the top level.
This optimization is for keeping HARDRESET from generating all new event
numbers for all execs that are open.)
(PRINT-EVENT-PROMPT *CURRENT-EVENT* PROMPT OUTPUT)
(DSPFONT (EXEC-FONTS-INPUT *EXEC-FONTS*)
OUTPUT)
(RESETLST
(PROG ((ORIGINAL-INPUT (CMLTRANSLATE (EXEC-READ-LINE)))
(LISPXHIST LISPXHIST)
(HELPCLOCK 0)
TODO INPUT)
(DECLARE (SPECIAL LISPXHIST HELPCLOCK))
(* "ORIGINAL-INPUT is what was typed"
"INPUT is what goes into the INPUT part of the event"
"TODO is what actually gets evaluated"
"HELPCLOCK is the time to start counting for deciding whether to break"
"LISPXHIST is rebound to itself, so that when it is -"
"set to *CURRENT-EVENT* later, it will have a local effect"
"LISPXHIST is used freely by the UNDO code to stash undoable info")
(DSPFONT (EXEC-FONTS-PRINTOUT *EXEC-FONTS*)
OUTPUT)
(SETQ INPUT ORIGINAL-INPUT)
(COND
((EQUAL INPUT (QUOTE (NIL)))
(* empty line, dont do anything)
(RETURN)))
RETRY
(* "process INPUT")
(SETQ TODO INPUT)
(COND
((AND (SYMBOLP (CAR INPUT))
(find COM in (APPEND *THIS-EXEC-COMMANDS* EXEC-COMMANDS)
when (STRING-EQUAL (CAR INPUT)
(COMMAND-ENTRY-NAME COM))
do (SETQ TODO COM)
(RETURN T)))
(ECASE (COMMAND-ENTRY-MODE TODO)
(:QUIET (*
"this command doesn't get saved on the history list")
(MAPC (SETQ VALUES (MULTIPLE-VALUE-LIST
(FUNCALL (
COMMAND-ENTRY-FUNCTION
TODO)
INPUT ENVIRONMENT)))
(FUNCTION (LAMBDA (X)
(SHOWPRINT X T *READTABLE*)))
)
(SETQ IT (CAR VALUES))
(* "just do it and return")
(RETURN))
(:HISTORY (* "create new input")
(SETQ INPUT (FUNCALL (COMMAND-ENTRY-FUNCTION
TODO)
INPUT ENVIRONMENT))
(SETF (EVENT-INPUT *CURRENT-EVENT*)
INPUT)
(*
"Do this now, even though done later, because"
"this also marks the event as 'used'")
(SETF (EVENT-PROPS *CURRENT-EVENT*)
(LIST* (QUOTE *HISTORY*)
ORIGINAL-INPUT
(EVENT-PROPS *CURRENT-EVENT*)))
(*
"could have generated a command, so loop")
(GO RETRY))
((NIL :EVAL) (*
"normal kind of macro command; just eval")
(SETQ TODO (BQUOTE
((FUNCALL (QUOTE (\, (
COMMAND-ENTRY-FUNCTION
TODO)))
(QUOTE (\, INPUT))
ENV))))))))
(SETF (EVENT-INPUT *CURRENT-EVENT*)
INPUT)
(AND ADDSPELLFLG (EQ TODO INPUT)
(HISTORY-ADD-TO-SPELLING-LISTS INPUT))
(SETQ LISPXHIST *CURRENT-EVENT*)
(DSPFONT (EXEC-FONTS-PRINTOUT *EXEC-FONTS*)
T)
(LET ((HELPCLOCK (CLOCK 2))
VALUES)
(DECLARE (SPECIAL HELPCLOCK))
(CL:SETQ +++ ++ ++ + + - - (CAR INPUT))
(*
"Common Lisp doesn't define what - should be when"
"input is in `apply' format. I guess you get the function")
(SETQ VALUES (MULTIPLE-VALUE-LIST (FUNCALL FUNCTION TODO
ENVIRONMENT)))
(CL:SETQ /// // // / / VALUES)
(CL:SETQ *** ** ** CL:* CL:* (SETQ IT (CAR VALUES)))
(CL:WHEN *CURRENT-EVENT* (SETF (EVENT-VALUE *CURRENT-EVENT*)
(CAR VALUES))
(SETF (EVENT-PROPS *CURRENT-EVENT*)
(LIST* (QUOTE LISPXVALUES)
VALUES
(EVENT-PROPS *CURRENT-EVENT*))))
(DSPFONT (EXEC-FONTS-VALUES *EXEC-FONTS*)
T)
(for X in VALUES do (SHOWPRINT X T *READTABLE*))
VALUES)))))))))
(DO-APPLY-EVENT
(LAMBDA (TODO) (* lmm "31-Jul-86 03:22")
(CL:IF (MACRO-FUNCTION (CAR TODO))
(CL:IF (EQ (ARGTYPE (CAR TODO))
3)
(FUNCALL (CAR TODO)
(CL:IF (CDDR TODO)
(CDR TODO)
(CADR TODO)))
(CL:EVAL TODO))
(CL:APPLY (CAR TODO)
(CADR TODO)))))
(DO-HISTORY-SEARCH
(LAMBDA (SPEC PRED-P VALUE-P) (* lmm "31-Jul-86 01:58")
(* SEARCHES HISTORY LIST, LOOKING FOR
SPEC (BOUND IN HISTORYFIND)%, AND
RESETTING *EVENTS* TO THE
CORRESPONDING TAIL.)
(PROG (PAT1 PAT2 TEM PRED)
(COND
((NOT PRED-P)
(SETQ PAT2 (EDITFPAT SPEC T))))
LP (COND
((COND
((AND (SETQ TEM (GETF (EVENT-PROPS (CAR *EVENTS*))
(QUOTE *HISTORY*)))
PAT2
(OR (EQ PAT2 (CAR TEM))
(EQ PAT2 (CAR (LISTP (CAR TEM)))))))
(PRED-P (APPLY* SPEC (CAR *EVENTS*)))
(PAT1 (EDIT4E PAT1 (CAR (EVENT-INPUT (CAR *EVENTS*)))))
(T (EDITFINDP (COND
(VALUE-P (GETF (EVENT-PROPS (CAR *EVENTS*))
(QUOTE LISPXVALUES)))
(T (EVENT-INPUT (CAR *EVENTS*))))
PAT2 T)))
(RETURN *EVENTS*))
(T (SETQ *EVENTS* (CDR *EVENTS*))))
LP1 (COND
((NULL *EVENTS*)
(RETURN NIL)))
(GO LP))))
(EVAL-INPUT
(LAMBDA (TODO ENV) (* lmm "31-Jul-86 19:58")
(if (CDR TODO)
then
(* this is the "apply" case -
we first check for input of things like macros in apply format or Interlisp
NLAMBDA functions (which have a MACRO-FUNCTION))
(if (MACRO-FUNCTION (CAR TODO))
then (if (EQ (ARGTYPE (CAR TODO))
3)
then (* this is an Interlisp NLAMBDA
function)
(FUNCALL (CAR TODO)
(CL:IF (CDDR TODO)
(CDR TODO)
(CADR TODO)))
else (* evaluate the entire input list as
if it were typed in with parens around
it, e.g. a "FOR I FROM 1 TO 10 DO ..."
possibly bogus "DWIM" case)
(CL:EVAL TODO))
else (* a normal apply case)
(CL:APPLY (CAR TODO)
(CADR TODO)))
else (* a normal eval case)
(CL:EVAL (CAR TODO)
ENV))))
(EXEC-READ-LINE
(LAMBDA NIL (* lmm "31-Jul-86 00:51")
(PROG ((LINE (LIST (FUNCALL LISPXREADFN T *READTABLE*)))
TEM SPACEFLG CHRCODE)
TOP (COND
((OR (LISTP (CAR LINE))
(NULL (READP T))) (*
"If there's nothing else to read or we got a list, return right away")
(CLEARBUF T) (*
"I don't know why this CLEARBUF is here, it was in READLINE")
(RETURN LINE)))
LP (SETQ SPACEFLG NIL)
LP1 (COND
((SYNTAXP (SETQ CHRCODE (PEEKCCODE T *READTABLE*))
(QUOTE EOL))
(READC T)
(COND
((AND LINE SPACEFLG)
(GO LP))
(T (GO OUT))))
((OR (SYNTAXP CHRCODE (QUOTE RIGHTPAREN)
*READTABLE*)
(SYNTAXP CHRCODE (QUOTE RIGHTBRACKET)
*READTABLE*))
(READ T *READTABLE*)
(AND (NULL (CDR LINE))
(SETQ LINE (NCONC1 LINE NIL))) (* A "]" is treated as NIL if it is
the second thing on the line when
EXEC-READ-LINE is called with
LISPXFLG=T.)
(GO OUT))
((AND (EQ CHRCODE (CHARCODE SPACE))
(SYNTAXP CHRCODE (QUOTE SEPR)
*READTABLE*)) (* SPACE the syntaxp check is to allow
for space being a read macro)
(SETQ SPACEFLG T)
(READC T)
(GO LP1)))
(SETQ LINE (NCONC1 LINE (APPLY* LISPXREADFN T *READTABLE*)))
(COND
((SYNTAXP (SETQ CHRCODE (CHCON1 (LASTC T)))
(QUOTE RIGHTBRACKET)
*READTABLE*)
(* The reason why readline is driven by the last character insead of doing a
peekc before reading is that due to readmacros, it is possible for several
things to be read, e.g. A B C ' (FOO) terminated by square bracket should
terminate the line. However, it is not sufficient just to check whether the
value read is a list or not since "()" and NIL must also be treated
differently.)
(GO OUT))
((NULL (SYNTAXP CHRCODE (QUOTE RIGHTPAREN)
*READTABLE*))
(GO LP))
((AND (NULL SPACEFLG)
(NULL (CDDR LINE)))
(* A list terminates the line if if called from LISPX and is both the firt
thing on a line and not preceded by a space.)
(GO OUT))
(T (GO LP)))
(GO LP)
OUT (COND
((AND (LISTP LINE)
CTRLUFLG) (* User typed control-u during
reading.)
(SETQ CTRLUFLG NIL)
(EDITE LINE)))
(RETURN LINE))))
(GET-NEXT-HISTORY-EVENT
(LAMBDA (HISTORY ID FIRST-ONLY) (* lmm "31-Jul-86 00:21")
(for EVENT in (HISTORY-EVENTS HISTORY) do (CL:WHEN (EQ (CADR (LISTP (EVENT-ID EVENT)))
ID)
(CL:IF (NULL (EVENT-INPUT EVENT))
(RETURN EVENT)
(GO $$OUT)))
(if FIRST-ONLY
then (* "only do this for the first event")
(GO $$OUT))
finally (SETQ EVENT (MAKE-EVENT :ID (LIST (INCF (HISTORY-INDEX HISTORY))
ID)))
(CL:PUSH EVENT (HISTORY-EVENTS HISTORY))
(SETF (CDR (NTHCDR (1- (HISTORY-SIZE HISTORY))
(HISTORY-EVENTS HISTORY)))
NIL)
(RETURN EVENT))))
(HISTORY-ADD-TO-SPELLING-LISTS
(LAMBDA (INPUT) (* lmm "31-Jul-86 02:22")
(COND
((CDR INPUT) (*
"Add to the spelling list if it has a definition")
(AND (LITATOM (CAR INPUT))
(FGETD (CAR INPUT))
(ADDSPELL (CAR INPUT)
2)))
((AND (CONSP (CAR INPUT))
(LITATOM (CAR (CAR INPUT)))) (* "looks like a valid function")
(AND (OR (FBOUNDP (CAR (CAR INPUT)))
(SPECIAL-FORM-P (CAR (CAR INPUT))))
(ADDSPELL (CAR (CAR INPUT))
2)))
((AND (SYMBOLP (CAR INPUT))
(BOUNDP (CAR INPUT)))
(ADDSPELL (CAR INPUT)
3)))))
(HISTORY-NTH
[LAMBDA (LST N ID) (* lmm "27-Jul-86 03:03")
(bind EVENT while LST do (if (<= N 0)
then (RETURN))
(SETQ EVENT (CAR LST))
(CL:IF (AND (EVENT-INPUT EVENT)
(OR (NOT (STRINGP ID))
(EQ (CADR (LISTP (EVENT-ID EVENT)))
ID)))
(if (<= (DECF N)
0)
then (RETURN LST)))
(pop LST])
(PRINT-HISTORY
(LAMBDA (HISTORY LINE SKIPFN NOVALUES FILE) (* lmm "31-Jul-86 01:28")
(SETQ FILE (GETSTREAM (OR FILE T)
(QUOTE OUTPUT)))
(PROG (HELPCLOCK (EVENTS (CL:IF LINE (FIND-HISTORY-EVENTS LINE HISTORY)
(HISTORY-EVENTS HISTORY))))
(TERPRI FILE)
(for X in EVENTS do (PRINT-EVENT X FILE)
(TERPRI FILE))
(TERPRI FILE)
(RETURN (VALUES)))))
(FIND-HISTORY-EVENTS
(LAMBDA (EVENT-SPEC HISTORY) (* lmm "31-Jul-86 03:36")
(PROG ((*EVENTS* (HISTORY-EVENTS HISTORY))
(ORIGINAL-EVENT-SPEC EVENT-SPEC)
SPEC TEM VALUE-P VAL PRED-P ALL-P)
(DECLARE (SPECIAL *EVENTS*))
(CL:IF (EQ (CAR *EVENTS*)
*CURRENT-EVENT*)
(pop *EVENTS*))
LP (CASE-EQUALP (SETQ SPEC (CAR EVENT-SPEC))
(ALL (SETQ ALL-P T)
(pop EVENT-SPEC)
(GO LP))
(F (COND
((SETQ TEM (CDR EVENT-SPEC)) (* Otherwise, F is not a special
symbol, e.g. user types REDO F,
meaning search for F itself.)
(SETQ EVENT-SPEC (CDR EVENT-SPEC))
(SETQ SPEC (CAR EVENT-SPEC))))
(DO-HISTORY-SEARCH SPEC PRED-P VALUE-P))
(SUCHTHAT (* What follows SUCHTHAT is a function
to be applied to the entire event;
and if true, approves that event.)
(SETQ PRED-P T)
(SETQ EVENT-SPEC (CDR EVENT-SPEC))
(SETQ SPEC (CAR EVENT-SPEC))
(DO-HISTORY-SEARCH SPEC PRED-P VALUE-P))
(= (SETQ VALUE-P T)
(GO LP))
(T (COND
((NOT (INTEGERP SPEC))
(DO-HISTORY-SEARCH SPEC PRED-P VALUE-P)
(* Does searching.)
)
((< SPEC 0) (* "count backward")
(SETQ *EVENTS* (HISTORY-NTH *EVENTS* (- SPEC)
(AND (NOT ALL-P)
*EXEC-ID*))))
(T (* ABSOLUTE EVENT NUMBER)
(SETQ *EVENTS* (SEARCH-FOR-EVENT-NUMBER *EVENTS* HISTORY SPEC))))))
(COND
((NULL *EVENTS*)
(COND
(ALL-P (RETURN VAL)))
(ERROR SPEC (QUOTE " ?")
T))
((NULL (SETQ EVENT-SPEC (CDR EVENT-SPEC)))
(COND
((NULL ALL-P)
(RETURN (LIST (CAR *EVENTS*))))
(T (SETQ VAL (NCONC1 VAL (CAR *EVENTS*)))
(SETQ EVENT-SPEC ORIGINAL-EVENT-SPEC)))))
(SETQ *EVENTS* (CDR *EVENTS*))
(SETQ VALUE-P NIL)
(SETQ PRED-P NIL)
(GO LP))))
(PRINT-EVENT
(LAMBDA (EVENT FILE) (* lmm "31-Jul-86 02:13")
(COND
((AND SKIPFN (APPLY* SKIPFN EVENT)) (* If SKIPFN applied to this entry is
T, it is skipped.)
)
(T (PROG ((INPUT (EVENT-INPUT EVENT))
Y TEM (POSITION (STRINGWIDTH "99/9999>" FILE))
EVENT#)
(CL:UNLESS (PRINT-EVENT-PROMPT EVENT CMLPROMPT FILE)
(SETQ EVENT# (ENTRY# HISTORY EVENT))
(FORMAT FILE "~D~A" EVENT# (EVENT-ID EVENT)))
(DSPXPOSITION POSITION FILE)
(DSPFONT (EXEC-FONTS-INPUT *EXEC-FONTS*)
FILE)
(if (SETQ TEM (LISTGET (EVENT-PROPS EVENT)
(QUOTE *HISTORY*)))
then (MAPRINT TEM FILE NIL NIL NIL (FUNCTION (LAMBDA (X FILE)
(PRIN2 X FILE))))
(TERPRI FILE)
(DSPXPOSITION POSITION FILE))
LP (COND
((SETQ Y (FMEMB HISTSTR0 (LISTP INPUT)))
(SETQ INPUT (LDIFF INPUT Y))))
(COND
((NLISTP INPUT)
(COND
((NULL INPUT)
(if (EVENT-PROPS EVENT)
then (* "don't do anything")
else (PRIN1 "<in progress>" FILE)))
(T (* "shouldn't happen?")
(PRIN2 INPUT FILE))))
((CDDR INPUT)
(MAPRINT INPUT FILE NIL NIL NIL (FUNCTION (LAMBDA (X FILE)
(SHOWPRIN2 X FILE)))))
((CDR INPUT) (* APPLY input)
(SHOWPRIN2 (CAR INPUT)
FILE)
(COND
((NULL (SETQ TEM (CADR INPUT)))
(PRIN1 ")" FILE))
(T (COND
((NLISTP TEM)
(SPACES 1 FILE)))
(SHOWPRIN2 TEM FILE))))
(T (* EVAL input)
(SHOWPRIN2 (CAR INPUT)
FILE))) (* shouldnt be any situations with two
"<c.r.>" s in a row, but just in case)
(COND
(Y (SETQ INPUT (CDR Y))
(TERPRI FILE)
(DSPXPOSITION POSITION FILE)
(GO LP)))
LP1 (LET ((PRINTOUT (GETF (EVENT-PROPS EVENT)
(QUOTE *LISPXPRINT*))))
(if PRINTOUT
then (DSPFONT (EXEC-FONTS-PRINTOUT *EXEC-FONTS*)
FILE)
(FRESHLINE FILE)
(MAPC PRINTOUT (FUNCTION (LAMBDA (X)
(LISPXREPRINT X FILE *READTABLE*))))))
(COND
((NOT NOVALUES)
(DSPFONT (EXEC-FONTS-VALUES *EXEC-FONTS*)
FILE)
(for X in (LISTGET (CDDDR EVENT)
(QUOTE LISPXVALUES)) do (FRESHLINE FILE)
(DSPXPOSITION POSITION FILE)
(SHOWPRINT X FILE))))
(FRESHLINE FILE))))))
(PRINT-EVENT-PROMPT
(LAMBDA (EVENT PROMPT OUTPUT) (* lmm "31-Jul-86 01:15")
(FRESH-LINE OUTPUT)
(if (CONSP (EVENT-ID EVENT))
then (DSPFONT (EXEC-FONTS-PROMPT *EXEC-FONTS*)
OUTPUT)
(DESTRUCTURING-BIND (INDEX ID)
(EVENT-ID EVENT)
(FORMAT OUTPUT "~A~D~A" ID INDEX PROMPT))
T)))
(PROCESS-EXEC-ID
(LAMBDA (X) (* lmm "30-Jul-86 22:32")
(OR (PROCESSPROP X (QUOTE ID))
(LET (ID (NAME (PROCESS.NAME X)))
(PROCESSPROP X (QUOTE ID)
(SETQ ID (COND
((STRPOS "EXEC" NAME 1 NIL T)
(COND
((EQ NAME (QUOTE EXEC))
"")
(T (CONCAT (SUBATOM NAME 6 -1)
"/"))))
(T (* under some other process)
(CONCAT NAME "/")))))
ID))))
(SEARCH-FOR-EVENT-NUMBER
(LAMBDA (EVENTS HISTORY SPEC) (* "lmm" "25-Jul-86 23:57")
(while EVENTS do (if (LET ((ID (EVENT-ID (CAR EVENTS))))
(COND
((LISTP ID)
(EQL (CAR ID)
SPEC))
(T (EQL SPEC (ENTRY# HISTORY (CAR EVENTS))))))
then (RETURN EVENTS)
else (pop EVENTS)))))
(\PICK.EVALQT
[LAMBDA NIL (* lmm " 1-Aug-86 01:45")
(CL:IF (EQ *DEFAULT-EXECUTIVE* (QUOTE COMMON-LISP))
(CMLEXEC :TOP-LEVEL-P T)
(EVALQT])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(CHANGENAME (QUOTE \PROC.REPEATEDLYEVALQT)
(QUOTE EVALQT)
(QUOTE \PICK.EVALQT))
(SETQ BackgroundMenu)
)
(DEFSTRUCT (COMMAND-ENTRY (:TYPE LIST)) NAME FUNCTION MODE DOCUMENTATION)
(DEFSTRUCT (EVENT (:TYPE LIST)) INPUT ID (VALUE *NOT-YET-EVALUATED*))
(DEFSTRUCT (EXEC-FONTS (:TYPE LIST)) PROMPT INPUT PRINTOUT VALUES)
(DEFSTRUCT (HISTORY (:TYPE LIST)) EVENTS INDEX SIZE MOD)
(DEFVAR BREAK-COMMANDS NIL "Current set of allowed commands to the debugger")
(DEFVAR CL:* NIL)
(DEFVAR ** NIL)
(DEFVAR *** NIL)
(DEFPARAMETER *EXEC-FONTS* (MAKE-EXEC-FONTS :PROMPT LITTLEFONT :INPUT BOLDFONT :PRINTOUT DEFAULTFONT
:VALUES DEFAULTFONT) )
(DEFVAR *NOT-YET-EVALUATED* "<not yet evaluated>" )
(DEFVAR + NIL)
(DEFVAR ++ NIL)
(DEFVAR +++ NIL)
(DEFVAR - NIL)
(DEFVAR / NIL "Holds a list of all the values returned by the most recent top-level EVAL.")
(DEFVAR // NIL "Gets the previous value of / when a new value is computed.")
(DEFVAR /// NIL "Gets the previous value of // when a new value is computed.")
(DEFVAR EXEC-COMMANDS NIL "Association list of executive commands & their expanders")
(DEFVAR *DEFAULT-EXECUTIVE* (QUOTE COMMON-LISP) "Default executive" )
(DEFMACRO CASE-EQUALP (SELECTOR &REST CASES)
(LET*
((KV (CL:IF (SYMBOLP SELECTOR)
SELECTOR
(GENSYM)))
(CLAUSES
(for STRING-CASE in CASES
collect
(COND
((FMEMB (CAR STRING-CASE)
(QUOTE (T OTHERWISE)))
(BQUOTE (T (\,@ (CDR STRING-CASE)))))
((NOT (CONSP (CAR STRING-CASE)))
(BQUOTE ((STRING.EQUAL (\, KV)
(QUOTE (\, (CAR STRING-CASE))))
(\,@ (CDR STRING-CASE)))))
(T (BQUOTE ((OR (\,@ (CL:DO ((X (CAR STRING-CASE)
(CDR X))
(Y NIL))
((CL:ATOM X)
(REVERSE Y))
(CL:PUSH (BQUOTE (STRING.EQUAL (\, KV)
(QUOTE (\, (CAR X)))))
Y))))
(\,@ (CDR STRING-CASE)))))))))
(CL:IF (EQ KV SELECTOR)
(BQUOTE (COND
(\,@ CLAUSES)))
(BQUOTE (LET (((\, KV)
(\, SELECTOR)))
(COND
(\,@ CLAUSES)))))))
(DEFDEFINER DEFCOMMAND COMMANDS
(NAME ARGUMENTS &ENVIRONMENT ENV &BODY BODY)
(LET ((COMMAND-LEVEL (QUOTE EXEC-COMMANDS))
(COMMAND-TYPE :EVAL)
(PREFIX "exec-"))
(if (LISTP NAME)
then (SETQ NAME (PROG1 (CAR NAME)
(for X in (CDR NAME)
do (ECASE X ((:QUIET :HISTORY :EVAL :MACRO)
(SETQ COMMAND-TYPE X))
(:BREAK (SETQ COMMAND-LEVEL
(QUOTE BREAK-COMMANDS))
(SETQ PREFIX "break-")))))
))
(LET* ((CMACRONAME (PACK* PREFIX NAME)))
(MULTIPLE-VALUE-BIND
(PARSED-BODY PARSED-DECLARATIONS PARSED-DOCSTRING)
(PARSE-DEFMACRO ARGUMENTS (QUOTE $$MACRO-FORM)
BODY NAME ENV :ENVIRONMENT (QUOTE $$MACRO-ENV))
(BQUOTE (PROGN (SETF (SYMBOL-FUNCTION (QUOTE (\, CMACRONAME)))
(CL:FUNCTION (CL:LAMBDA ($$MACRO-FORM
$$MACRO-ENV)
(\,@ PARSED-DECLARATIONS)
(CL:BLOCK (\, NAME)
(\, PARSED-BODY)))
))
(CL:PUSHNEW (QUOTE (\, (MAKE-COMMAND-ENTRY :NAME
NAME :FUNCTION
CMACRONAME :MODE
COMMAND-TYPE
:DOCUMENTATION
PARSED-DOCSTRING)))
(\, COMMAND-LEVEL))))))))
(DEFMACRO EVENT-PROPS (X) (BQUOTE (CDDDR (\, X))))
(DEFUN LISPXFORMAT (FORMAT &REST ARGS) (AND LISPXPRINTFLG LISPXHIST (CL:STRINGP FORMAT)
(LISPXPUT (QUOTE *LISPXPRINT*)
(LIST (CONS FORMAT ARGS))
T LISPXHIST))
(CL:APPLY (QUOTE FORMAT)
T FORMAT ARGS))
(DEFINEQ
(\ADD-EXEC
(CL:LAMBDA (&OPTIONAL (EXEC.TYPE *DEFAULT-EXECUTIVE*)
REGION) (* lmm " 1-Aug-86 00:33")
(LET* ((title (CASE EXEC.TYPE (COMMON-LISP "Common Lisp Exec")
(INTERLISP "Interlisp Exec")
(T "Lisp Executive")))
(window (CREATEW REGION title))
handle)
[WINDOWADDPROP window (QUOTE CLOSEFN)
(FUNCTION (LAMBDA (window)
(PROG [(proc (WINDOWPROP window (QUOTE PROCESS]
(RETURN (COND
((EQ (THIS.PROCESS)
proc)
(ADD.PROCESS (LIST (QUOTE CLOSEW)
(KWOTE window)))
(QUOTE DON'T))
((PROCESSP proc)
(DEL.PROCESS proc)
NIL]
(SETQ handle (ADD.PROCESS (BQUOTE (PROGN (TTYDISPLAYSTREAM (QUOTE (\, window)))
[\, (OR (GET EXEC.TYPE (QUOTE EXEC))
(QUOTE (EVALQT]
(\PICK.EVALQT)))
(QUOTE NAME)
(QUOTE EXEC)
(QUOTE RESTARTABLE)
T))
[WINDOWPROP window (QUOTE TITLE)
(CONCAT title (SUBSTRING (PROCESSPROP handle (QUOTE NAME))
(OR (STRPOS "#" (PROCESSPROP handle (QUOTE NAME)))
1]
(TTY.PROCESS handle)
handle)))
)
(ADDTOVAR BackgroundMenuCommands [EXEC (QUOTE (\ADD-EXEC *DEFAULT-EXECUTIVE*))
"Start a new Lisp Executive"
(SUBITEMS [Interlisp (QUOTE (\ADD-EXEC (QUOTE INTERLISP]
("Common Lisp" (QUOTE (\ADD-EXEC (QUOTE COMMON-LISP])
(PUTPROPS CMLEXEC FILETYPE COMPILE-FILE)
(DEF-DEFINE-TYPE COMMANDS "Commands to Lisp Executive" )
(DEFCOMMAND ? (&REST LINE) (IF LINE
THEN (IRM.LOOKUP (CAR LINE))
ELSE (FORMAT *TERMINAL-IO*
"You are typing at a Common Lisp Exec. Enter ~&")
(DSPFONT (EXEC-FONTS-INPUT *EXEC-FONTS*)
T)
(FORMAT *TERMINAL-IO* "<expression>")
(DSPFONT DEFAULTFONT T)
(FORMAT *TERMINAL-IO* " to evaluate an expression~&")
(DSPFONT (EXEC-FONTS-INPUT *EXEC-FONTS*)
T)
(FORMAT *TERMINAL-IO* "function(arg1 arg2 ...) ")
(DSPFONT DEFAULTFONT T)
(FORMAT *TERMINAL-IO* "to apply function to the arguments given~&")
(FORMAT *TERMINAL-IO* " ~& ~&or one of the following:~&~A~&"
(LET (COMMANDS)
(FOR X IN *THIS-EXEC-COMMANDS*
DO (PUSHNEW COMMANDS (CAR X)))
(FOR X IN EXEC-COMMANDS
DO (PUSHNEW COMMANDS (CAR X)))
COMMANDS))
(FORMAT *TERMINAL-IO*
"~& ~&? <name> will give more information about <name>~&")
))
(DEFCOMMAND (?= :BREAK) NIL (PRINT-ARGLIST (SMARTARGLIST (STKNAME LASTPOS)
T)
(STKARGS LASTPOS)
T 0))
(DEFCOMMAND (?? :QUIET) (&REST LINE) (PRINT-HISTORY LISPXHISTORY LINE)
(VALUES))
(DEFCOMMAND (??T :QUIET) (&REST LINE) (LET ((SYSPRETTYFLG T)
(PRETTYTRANFLG T))
(HISTORY-PRINT LISPXHISTORY LINE))
(VALUES))
(DEFCOMMAND (AFTER :EVAL) (NAME) (LISPXSTATE NAME (QUOTE AFTER)))
(DEFCOMMAND (BEFORE :EVAL) (NAME) (LISPXSTATE NAME (QUOTE BEFORE)))
(DEFCOMMAND (CONN :EVAL) (&OPTIONAL DIRECTORY) (/CNDIR DIRECTORY))
(DEFCOMMAND DA NIL (DATE))
(DEFCOMMAND (DIR :EVAL) (&REST LINE) (DODIR LINE))
(DEFCOMMAND DO-EVENTS (&REST INPUTS) (* execute the instructions on the
rest of the line)
(FOR INPUT IN INPUTS DO (PROG ((TODO (if (EQ (CAR (LISTP INPUT))
(QUOTE EVENT))
THEN (CDR INPUT)
ELSE (LIST INPUT)))
VALUES)
(AND ADDSPELLFLG (HISTORY-ADD-TO-SPELLING-LISTS TODO))
(SETQ VALUES (DO-EVENT TODO TODO ENV NIL))
(CL:WHEN (AND VALUES *CURRENT-EVENT*)
(CL:IF (SETQ TODO (GETF (EVENT-PROPS *CURRENT-EVENT*)
(QUOTE LISPXVALUES)))
(NCONC TODO VALUES)
(SETF (EVENT-PROPS *CURRENT-EVENT*)
(LIST* (QUOTE LISPXVALUES)
VALUES
(EVENT-PROPS *CURRENT-EVENT*)))))))
(SETQ *CURRENT-EVENT* NIL)
(VALUES))
(DEFCOMMAND (FIX :HISTORY) (&REST LINE)
(LET ((EVENTS (FIND-HISTORY-EVENTS (OR LINE (QUOTE (-1)))
LISPXHISTORY))
(LISPXID CMLPROMPT))
(DECLARE (SPECIAL LISPXID))
(LISPXFIX (COPY (IF (CDR EVENTS)
THEN (CONS (QUOTE DO-EVENTS)
(FOR EVENT IN EVENTS
COLLECT (IF (CDR (EVENT-INPUT EVENT))
THEN (CONS (QUOTE EVENT)
(EVENT-INPUT EVENT))
ELSE (CAR (EVENT-INPUT EVENT)))))
ELSE (EVENT-INPUT (CAR EVENTS)))))))
(DEFCOMMAND (NDIR :EVAL) (&REST LINE) (DODIR LINE (QUOTE (P COLUMNS 20))
(QUOTE *)
""))
(DEFCOMMAND (OK :BREAK) NIL (BREAKRETFROM (QUOTE CMLEXEC)))
(DEFCOMMAND PB (VAR) (PRINTBINDINGS VAR)
(VALUES))
(DEFCOMMAND PL (SYMBOL) (PRINTPROPS SYMBOL)
(VALUES))
(DEFCOMMAND (REMEMBER :EVAL) (&REST LINE) (MARKASCHANGED (GETEXPRESSIONFROMEVENTSPEC LINE)
(QUOTE EXPRESSIONS)))
(DEFCOMMAND (SHH :QUIET) (&REST LINE) (CL:IF (CDR LINE)
(CL:APPLY (CAR LINE)
(CL:IF (OR (CDDR LINE)
(EQ (ARGTYPE (CAR LINE))
3))
(CDR LINE)
(CADR LINE)))
(CL:EVAL (CAR LINE))))
(DEFCOMMAND UNDO (&REST LINE) (FOR EVENT IN (FIND-HISTORY-EVENTS (OR LINE (QUOTE (-1)))
LISPXHISTORY) DO (SETQ $$VAL (OR (UNDOLISPX2
EVENT)
$$VAL))
FINALLY (COND
((NULL $$VAL)
(FORMAT *TERMINAL-IO* "Nothing saved.~&")
(RETURN))
((EQ $$VAL (QUOTE already))
(RETURN (FORMAT *TERMINAL-IO* "Already undone.~&")))
(T (SETQ $$VAL (CAR (EVENT-INPUT EVENT)))))
(FORMAT *TERMINAL-IO* "~A undone.~&" (if (LISTP $$VAL)
THEN (CAR $$VAL)
ELSE $$VAL)))
(VALUES))
(DEFCOMMAND (REDO :HISTORY) (&REST LINE)
(LET ((EVENTS (FIND-HISTORY-EVENTS (OR LINE (QUOTE (-1)))
LISPXHISTORY))
(LISPXID CMLPROMPT))
(DECLARE (SPECIAL LISPXID))
(IF (CDR EVENTS)
THEN (CONS (QUOTE DO-EVENTS)
(FOR EVENT IN EVENTS COLLECT (IF (CDR (EVENT-INPUT EVENT))
THEN (CONS (QUOTE EVENT)
(EVENT-INPUT EVENT))
ELSE (CAR (EVENT-INPUT EVENT)))))
ELSE (EVENT-INPUT (CAR EVENTS)))))
(DEFCOMMAND FORGET (&REST LINE) (FOR EVENT IN (CL:IF LINE (FIND-HISTORY-EVENTS (OR LINE (QUOTE (-1)))
LISPXHISTORY)
(HISTORY-EVENTS LISPXHISTORY))
DO (UNDOLISPX2 EVENT T) FINALLY (FORMAT *TERMINAL-IO*
"Forgotten.~&"))
(VALUES))
(PUTPROPS COMMON-LISP EXEC (CMLEXEC :TOP-LEVEL-P T))
(PUTPROPS INTERLISP EXEC (EVALQT))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA \ADD-EXEC CMLEXEC)
)
(PUTPROPS CMLEXEC COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1843 31579 (CMLEXEC 1853 . 12302) (DO-APPLY-EVENT 12304 . 12796) (DO-HISTORY-SEARCH
12798 . 14316) (EVAL-INPUT 14318 . 15999) (EXEC-READ-LINE 16001 . 19430) (GET-NEXT-HISTORY-EVENT 19432
. 20561) (HISTORY-ADD-TO-SPELLING-LISTS 20563 . 21424) (HISTORY-NTH 21426 . 22169) (PRINT-HISTORY
22171 . 22696) (FIND-HISTORY-EVENTS 22698 . 25658) (PRINT-EVENT 25660 . 29597) (PRINT-EVENT-PROMPT
29599 . 30026) (PROCESS-EXEC-ID 30028 . 30788) (SEARCH-FOR-EVENT-NUMBER 30790 . 31346) (\PICK.EVALQT
31348 . 31577)) (37469 39577 (\ADD-EXEC 37479 . 39575)))))
STOP