File [eris]<LispCore>LIBRARY>CMLEXEC!23

(FILECREATED " 5-Aug-86 16:54:46" {ERIS}<LISPCORE>LIBRARY>CMLEXEC.;23 24179  

      changes to:  (FNS EXEC-READ-LINE CMLEXEC DO-EVENT) (COMMANDS OK DO-EVENTS) (VARS CMLEXECCOMS)

      previous date: " 1-Aug-86 01:46:10" {ERIS}<LISPCORE>LIBRARY>CMLEXEC.;21)


(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT CMLEXECCOMS)

(RPAQQ CMLEXECCOMS ((VARS CMLPROMPT) (FNS CMLEXEC DO-EVENT 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 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 ((:READTABLE *READTABLE*) CMLRDTBL) TOP-LEVEL-P TITLE) (DECLARE (SPECIAL *THIS-EXEC-COMMANDS* *READTABLE*)) (* lmm " 5-Aug-86 16:08") (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* (*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 (LET ((ORIGINAL-INPUT (CMLTRANSLATE (EXEC-READ-LINE))) (LISPXHIST LISPXHIST) (HELPCLOCK 0)) (DECLARE (SPECIAL LISPXHIST HELPCLOCK)) (CL:UNLESS (EQUAL ORIGINAL-INPUT (QUOTE (NIL))) (DO-EVENT ORIGINAL-INPUT ENVIRONMENT)))))))))
)

(DO-EVENT
(LAMBDA (ORIGINAL-INPUT ENVIRONMENT) (* lmm " 5-Aug-86 16:15") (PROG (TODO INPUT VALUES) (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*) T) (SETQ INPUT ORIGINAL-INPUT) 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)) (CL:WHEN *CURRENT-EVENT* (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)))))))) (CL:WHEN *CURRENT-EVENT* (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) (RETURN (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 (EVAL-INPUT 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 " 5-Aug-86 16:54") (* "code stolen from READLINE") (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") (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 &ENVIRONMENT ENV) (* execute the instructions on the rest of the line) (FOR INPUT IN INPUTS DO (PROG ((TODO (COND ((EQ (CAR (LISTP INPUT)) (QUOTE EVENT)) (CDR INPUT)) (T (LIST INPUT)))) VALUES) (AND ADDSPELLFLG (HISTORY-ADD-TO-SPELLING-LISTS TODO)) (LET (*CURRENT-EVENT*) (DECLARE (SPECIAL *CURRENT-EVENT*)) (SETQ VALUES (DO-EVENT TODO ENV))) (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 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 (1435 15601 (CMLEXEC 1445 . 3302) (DO-EVENT 3304 . 5917) (DO-APPLY-EVENT 5919 . 6167) (
DO-HISTORY-SEARCH 6169 . 6932) (EVAL-INPUT 6934 . 7634) (EXEC-READ-LINE 7636 . 9528) (
GET-NEXT-HISTORY-EVENT 9530 . 10057) (HISTORY-ADD-TO-SPELLING-LISTS 10059 . 10557) (HISTORY-NTH 10559
 . 10847) (PRINT-HISTORY 10849 . 11194) (FIND-HISTORY-EVENTS 11196 . 12713) (PRINT-EVENT 12715 . 14565
) (PRINT-EVENT-PROMPT 14567 . 14846) (PROCESS-EXEC-ID 14848 . 15177) (SEARCH-FOR-EVENT-NUMBER 15179 . 
15452) (\PICK.EVALQT 15454 . 15599)) (18623 19545 (\ADD-EXEC 18633 . 19543)))))
STOP