CMLEXEC: Fix FILETYPE property
It had CL:COMPILE-FILE, but the directory had LCOMs. Changed to :FAKE-COMPILE-FILE.
This commit is contained in:
rmkaplan
556
sources/CMLEXEC
556
sources/CMLEXEC
@@ -1,10 +1,11 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 8-Oct-2021 10:51:35"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>CMLEXEC.;2 92464
|
||||
(FILECREATED "19-Dec-2021 09:48:29" {DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLEXEC.;5 91886
|
||||
|
||||
previous date%: "21-Jan-93 11:16:01"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>CMLEXEC.;1)
|
||||
:CHANGES-TO (VARS CMLEXECCOMS)
|
||||
|
||||
:PREVIOUS-DATE " 8-Oct-2021 10:51:35"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>my-medley>sources>CMLEXEC.;3)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -18,7 +19,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(XCL:PROFILES "EXEC")
|
||||
(STRUCTURES COMMAND-ENTRY EXEC-EVENT-ID EXEC-EVENT HISTORY)
|
||||
(* ;
|
||||
"These are public except for command-entry.")
|
||||
"These are public except for command-entry.")
|
||||
(FUNCTIONS XCL::EXEC-CLOSEFN XCL::EXEC-SHRINKFN XCL::SETUP-EXEC-WINDOW
|
||||
XCL::EXEC-TITLE-FUNCTION FIX-FORM XCL::GET-PROCESS-PROFILE
|
||||
XCL::SAVE-CURRENT-EXEC-PROFILE XCL::SETF-GET-PROCESS-PROFILE XCL:SET-EXEC-TYPE
|
||||
@@ -29,7 +30,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(FUNCTIONS CIRCLAR-COPYER)
|
||||
(FNS COPY-CIRCLE)
|
||||
(* ;
|
||||
"CIRCLAR-COPYER and COPY-CIRCLE are the solution for AR#11172")
|
||||
"CIRCLAR-COPYER and COPY-CIRCLE are the solution for AR#11172")
|
||||
(FNS EXEC-READ DIR)
|
||||
(VARIABLES *PER-EXEC-VARIABLES* CL:* CL:** CL:*** + CL:++ CL:+++ - / CL:// CL:///
|
||||
*CURRENT-EVENT* *EXEC-ID* XCL:*EXEC-PROMPT* XCL:*EVAL-FUNCTION* *NOT-YET-EVALUATED*
|
||||
@@ -64,10 +65,10 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(FILESLOAD CMLUNDO PROFILE)
|
||||
|
||||
(XCL:DEFPROFILE "EXEC" (XCL:*DEBUGGER-PROMPT* "")
|
||||
(XCL:*EXEC-PROMPT* "")
|
||||
(*READTABLE* "XCL")
|
||||
(*PACKAGE* "XCL")
|
||||
(XCL:*EVAL-FUNCTION* 'CL:EVAL))
|
||||
(XCL:*EXEC-PROMPT* "")
|
||||
(*READTABLE* "XCL")
|
||||
(*PACKAGE* "XCL")
|
||||
(XCL:*EVAL-FUNCTION* 'CL:EVAL))
|
||||
|
||||
(CL:DEFSTRUCT (COMMAND-ENTRY (:TYPE LIST))
|
||||
ARGUMENTS
|
||||
@@ -148,39 +149,37 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(T (PRINT-EVENT-PROMPT *CURRENT-EVENT*)
|
||||
(DSPFONT INPUTFONT T)
|
||||
(CURSOR T) (* ;
|
||||
"make sure can edit (in case cursor smashed somehow?)")
|
||||
"make sure can edit (in case cursor smashed somehow?)")
|
||||
(CL:WHEN NIL (* ; "Old expression")
|
||||
(TTYIN "" NIL NIL 'LISPXREAD NIL NIL BUFFER-EXPR-FROM-BELOW *READTABLE*))
|
||||
(EXEC-READ-LINE (LET ((%#RPARS NIL)
|
||||
(FONTCHANGEFLG NIL)
|
||||
(*PRINT-ESCAPE* T)
|
||||
(*PRINT-RADIX* (NOT (= *READ-BASE* 10)))
|
||||
(*PRINT-BASE* *READ-BASE*)
|
||||
(*PRINT-LEVEL* NIL)
|
||||
(*PRINT-LENGTH* NIL)
|
||||
(*PRINT-GENSYM* ':REREAD)
|
||||
(*PRINT-ARRAY* T)
|
||||
(*PRINT-STRUCTURE* T))
|
||||
(DECLARE (CL:SPECIAL %#RPARS FONTCHANGEFLG)
|
||||
(FONTCHANGEFLG NIL)
|
||||
(*PRINT-ESCAPE* T)
|
||||
(*PRINT-RADIX* (NOT (= *READ-BASE* 10)))
|
||||
(*PRINT-BASE* *READ-BASE*)
|
||||
(*PRINT-LEVEL* NIL)
|
||||
(*PRINT-LENGTH* NIL)
|
||||
(*PRINT-GENSYM* ':REREAD)
|
||||
(*PRINT-ARRAY* T)
|
||||
(*PRINT-STRUCTURE* T))
|
||||
(DECLARE (CL:SPECIAL %#RPARS FONTCHANGEFLG)
|
||||
(* ;
|
||||
"others are already globally special ")
|
||||
)
|
||||
(CL:WITH-OUTPUT-TO-STRING
|
||||
(STR)
|
||||
(FOR X ON INPUT
|
||||
DO (IF CIRCLE-FLAG
|
||||
THEN (* ;
|
||||
"Edited by TT (31-May-1990) CL:PRIN1 can print circlar")
|
||||
(CL:PRIN1 (CAR X)
|
||||
STR)
|
||||
ELSEIF (LISTP (CAR X))
|
||||
THEN (PRINTDEF (CAR X)
|
||||
(POSITION STR)
|
||||
NIL NIL NIL STR)
|
||||
ELSE (PRIN2 (CAR X)
|
||||
STR))
|
||||
(AND (CDR X)
|
||||
(PRIN1 " " STR])
|
||||
"others are already globally special "))
|
||||
(CL:WITH-OUTPUT-TO-STRING (STR)
|
||||
(FOR X ON INPUT
|
||||
DO (IF CIRCLE-FLAG
|
||||
THEN (* ;
|
||||
"Edited by TT (31-May-1990) CL:PRIN1 can print circlar")
|
||||
(CL:PRIN1 (CAR X)
|
||||
STR)
|
||||
ELSEIF (LISTP (CAR X))
|
||||
THEN (PRINTDEF (CAR X)
|
||||
(POSITION STR)
|
||||
NIL NIL NIL STR)
|
||||
ELSE (PRIN2 (CAR X)
|
||||
STR))
|
||||
(AND (CDR X)
|
||||
(PRIN1 " " STR])
|
||||
|
||||
(CL:DEFUN XCL::GET-PROCESS-PROFILE (&OPTIONAL (XCL::PROCESS (THIS.PROCESS)))
|
||||
(PROCESSPROP XCL::PROCESS 'PROFILE))
|
||||
@@ -192,7 +191,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(XCL:SAVE-PROFILE XCL::PROFILE))))
|
||||
|
||||
(CL:DEFUN XCL::SETF-GET-PROCESS-PROFILE (&OPTIONAL (XCL::PROCESS (THIS.PROCESS))
|
||||
(XCL::PROFILE XCL:*PROFILE*))
|
||||
(XCL::PROFILE XCL:*PROFILE*))
|
||||
(CL:SETQ XCL::PROFILE (XCL::PROFILIZE XCL::PROFILE))
|
||||
(PROCESSPROP XCL::PROCESS 'PROFILE XCL::PROFILE)
|
||||
XCL::PROFILE)
|
||||
@@ -215,7 +214,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
"Start up an exec function in the proper profile, setting the default window title properly."
|
||||
(XCL:WITH-PROFILE (XCL:COPY-PROFILE XCL::PROFILE)
|
||||
(XCL::EXEC-TITLE-FUNCTION T (PROCESS-EXEC-ID (THIS.PROCESS)
|
||||
XCL::ID))
|
||||
XCL::ID))
|
||||
(CL:FUNCALL XCL::EXEC-FUNCTION)))
|
||||
|
||||
(CL:DEFSETF XCL::GET-PROCESS-PROFILE XCL::SETF-GET-PROCESS-PROFILE)
|
||||
@@ -226,13 +225,13 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
STR
|
||||
(RETRYFLAG NIL) (* ; "A really gross hack for RETRY to always break. It exists because: users can setq HELPFLAG anywhere (can't bind it in DO-EVENTand set it in RETRY), RETRY operates on commands (can't wrap the form with a binding of HELPFLAG).")
|
||||
)
|
||||
(DECLARE (CL:SPECIAL RETRYFLAG)) (* ;
|
||||
"RETRY command sets this variable if it wants to be sure to break.")
|
||||
(DECLARE (CL:SPECIAL RETRYFLAG)) (* ;
|
||||
"RETRY command sets this variable if it wants to be sure to break.")
|
||||
(DSPFONT PRINTOUTFONT T)
|
||||
(SETQ INPUT ORIGINAL-INPUT)
|
||||
RETRY
|
||||
(SETQ TODO (COPY-CIRCLE INPUT)) (* ;
|
||||
"Break EQ link between input and evaluated form (todo), so that in-place mods don't affect history.")
|
||||
(SETQ TODO (COPY-CIRCLE INPUT)) (* ;
|
||||
"Break EQ link between input and evaluated form (todo), so that in-place mods don't affect history.")
|
||||
[COND
|
||||
[[AND (OR (STRINGP (CAR INPUT))
|
||||
(CL:SYMBOLP (CAR INPUT)))
|
||||
@@ -260,14 +259,13 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(CL:WHEN *CURRENT-EVENT*
|
||||
(CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*)
|
||||
INPUT) (* ;
|
||||
" Overwrite the original input with the newly generated one.")
|
||||
" Overwrite the original input with the newly generated one.")
|
||||
(CL:SETF (EXEC-EVENT-PROPS *CURRENT-EVENT*)
|
||||
(LIST* '*HISTORY* ORIGINAL-INPUT (EXEC-EVENT-PROPS *CURRENT-EVENT*
|
||||
))))
|
||||
(LIST* '*HISTORY* ORIGINAL-INPUT (EXEC-EVENT-PROPS *CURRENT-EVENT*))))
|
||||
(GO RETRY) (* ; " could have generated a command")
|
||||
)
|
||||
((NIL :EVAL) (* ;
|
||||
" normal kind of command, just apply")
|
||||
" normal kind of command, just apply")
|
||||
[SETQ TODO `((CL:FUNCALL ',(COMMAND-ENTRY-FUNCTION COM)
|
||||
',INPUT
|
||||
',ENVIRONMENT]
|
||||
@@ -284,11 +282,11 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(CL:WHEN *EXEC-MAKE-UNDOABLE-P*
|
||||
[if (CDR TODO)
|
||||
then (SETQ TODO (CONS (OR (CDR (ASSOC (CAR TODO)
|
||||
LISPXFNS))
|
||||
(CAR TODO))
|
||||
(CDR TODO)))
|
||||
LISPXFNS))
|
||||
(CAR TODO))
|
||||
(CDR TODO)))
|
||||
else (SETQ TODO (LIST (XCL::MAKE-UNDOABLE (CAR TODO)
|
||||
NIL])]
|
||||
NIL])]
|
||||
(AND ADD-TO-SPELLING-LIST (HISTORY-ADD-TO-SPELLING-LISTS TODO))
|
||||
(SETQ LISPXHIST *CURRENT-EVENT*)
|
||||
(DSPFONT PRINTOUTFONT T)
|
||||
@@ -301,8 +299,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
[SETQ VALUES (CL:MULTIPLE-VALUE-LIST (CL:IF RETRYFLAG
|
||||
(LET ((HELPFLAG 'BREAK!))
|
||||
(DECLARE (CL:SPECIAL HELPFLAG
|
||||
))
|
||||
(DECLARE (CL:SPECIAL HELPFLAG))
|
||||
(CL:FUNCALL FUNCTION TODO
|
||||
ENVIRONMENT))
|
||||
(CL:FUNCALL FUNCTION TODO ENVIRONMENT))
|
||||
@@ -319,69 +316,66 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(for X in VALUES do (EXEC-PRINT X))
|
||||
VALUES))))
|
||||
|
||||
(CL:DEFUN EXEC (&KEY XCL::TOP-LEVEL-P (* ;
|
||||
"True of top level execs. Used for event number restarting and profile caching.")
|
||||
(XCL::WINDOW (WFROMDS (TTYDISPLAYSTREAM)))
|
||||
(CL:DEFUN EXEC (&KEY XCL::TOP-LEVEL-P (* ;
|
||||
"True of top level execs. Used for event number restarting and profile caching.")
|
||||
(XCL::WINDOW (WFROMDS (TTYDISPLAYSTREAM)))
|
||||
(* ; "Window for this exec, if any.")
|
||||
(XCL::TITLE NIL XCL::TITLE-SUPPLIED)(* ;
|
||||
"If given, specific title for this window.")
|
||||
((:COMMAND-TABLES *THIS-EXEC-COMMANDS*)
|
||||
(LIST *EXEC-COMMAND-TABLE*)) (* ;
|
||||
"List of hash tables to look up commands in.")
|
||||
XCL::ENVIRONMENT (* ;
|
||||
"Lexical environment to evaluate things in, default NIL.")
|
||||
XCL::PROMPT (* ;
|
||||
"Special prompt to use (optional).")
|
||||
((:FUNCTION XCL::FN)
|
||||
'EVAL-INPUT) (* ; "Function for processing input.")
|
||||
XCL::PROFILE (* ;
|
||||
"Optional profile, sets the exec's bindings.")
|
||||
XCL::ID (* ; "A handle on the exec.")
|
||||
&ALLOW-OTHER-KEYS (* ; "To catch obsolete calls")
|
||||
&AUX
|
||||
(*EXEC-ID* (PROCESS-EXEC-ID (THIS.PROCESS)
|
||||
XCL::ID))
|
||||
(XCL::PROFILE-CACHE (XCL::GET-PROCESS-PROFILE (THIS.PROCESS)))
|
||||
(XCL::TITLE NIL XCL::TITLE-SUPPLIED) (* ;
|
||||
"If given, specific title for this window.")
|
||||
((:COMMAND-TABLES *THIS-EXEC-COMMANDS*)
|
||||
(LIST *EXEC-COMMAND-TABLE*)) (* ;
|
||||
"List of hash tables to look up commands in.")
|
||||
XCL::ENVIRONMENT (* ;
|
||||
"Lexical environment to evaluate things in, default NIL.")
|
||||
XCL::PROMPT (* ; "Special prompt to use (optional).")
|
||||
((:FUNCTION XCL::FN)
|
||||
'EVAL-INPUT) (* ; "Function for processing input.")
|
||||
XCL::PROFILE (* ;
|
||||
"Optional profile, sets the exec's bindings.")
|
||||
XCL::ID (* ; "A handle on the exec.")
|
||||
&ALLOW-OTHER-KEYS (* ; "To catch obsolete calls")
|
||||
&AUX
|
||||
(*EXEC-ID* (PROCESS-EXEC-ID (THIS.PROCESS)
|
||||
XCL::ID))
|
||||
(XCL::PROFILE-CACHE (XCL::GET-PROCESS-PROFILE (THIS.PROCESS)))
|
||||
(* ;
|
||||
"The exec's cached profile (if entering from a hardreset).")
|
||||
)
|
||||
"The exec's cached profile (if entering from a hardreset).")
|
||||
)
|
||||
[CL:PROGV (MAPCAR *PER-EXEC-VARIABLES* (FUNCTION CAR))
|
||||
[MAPCAR *PER-EXEC-VARIABLES* (FUNCTION (LAMBDA (XCL::X)
|
||||
(EVAL (CADR XCL::X]
|
||||
(CL:WHEN (OR (NULL XCL::TOP-LEVEL-P)
|
||||
(NULL XCL::PROFILE-CACHE)) (* ; "If not hardresetting...")
|
||||
(CL:WHEN XCL::PROFILE (* ;
|
||||
"then initialize the profile vars.")
|
||||
(CL:WHEN XCL::PROFILE (* ; "then initialize the profile vars.")
|
||||
(XCL:RESTORE-PROFILE XCL::PROFILE))
|
||||
(CL:WHEN XCL::PROMPT (* ;
|
||||
"If a special prompt was provided (as from the debugger)...")
|
||||
"If a special prompt was provided (as from the debugger)...")
|
||||
(CL:SETQ XCL:*EXEC-PROMPT* XCL::PROMPT) (* ; "...use it.")
|
||||
))
|
||||
(CL:WHEN XCL::TOP-LEVEL-P
|
||||
(CL:IF (NULL XCL::PROFILE-CACHE) (* ;
|
||||
"This was a new entry into top level exec.")
|
||||
"This was a new entry into top level exec.")
|
||||
(CL:SETF (XCL::GET-PROCESS-PROFILE (THIS.PROCESS))
|
||||
(XCL:SAVE-PROFILE (XCL:COPY-PROFILE "EXEC")))
|
||||
(* ;
|
||||
"...make a fresh cache and save bindings into it.")
|
||||
(XCL:RESTORE-PROFILE XCL::PROFILE-CACHE) (* ;
|
||||
"...otherwise it was a HARDRESET.")
|
||||
"...make a fresh cache and save bindings into it.")
|
||||
(XCL:RESTORE-PROFILE XCL::PROFILE-CACHE) (* ; "...otherwise it was a HARDRESET.")
|
||||
))
|
||||
(CL:WHEN XCL::WINDOW
|
||||
(COND
|
||||
((NOT XCL::TITLE-SUPPLIED) (* ;
|
||||
"If no title was supplied, set it to the default.")
|
||||
"If no title was supplied, set it to the default.")
|
||||
(XCL::EXEC-TITLE-FUNCTION XCL::WINDOW *EXEC-ID*))
|
||||
(XCL::TITLE (* ;
|
||||
"If a non-nil title was supplied, set the title to it.")
|
||||
"If a non-nil title was supplied, set the title to it.")
|
||||
(WINDOWPROP XCL::WINDOW 'TITLE XCL::TITLE)))
|
||||
(TTYDISPLAYSTREAM (DECODE/WINDOW/OR/DISPLAYSTREAM XCL::WINDOW)))
|
||||
(LET [(*CURRENT-EVENT* NIL) (* ;
|
||||
"the event being processed. Used by some commands")
|
||||
"the event being processed. Used by some commands")
|
||||
(XCL::OLD-DS (CL:IF XCL::WINDOW
|
||||
(TTYDISPLAYSTREAM (DECODE/WINDOW/OR/DISPLAYSTREAM XCL::WINDOW)))]
|
||||
(CL:LOOP (CL:FORMAT T "~&~%%") (* ;
|
||||
"newlines to notice that this is a new instance of the exec")
|
||||
"newlines to notice that this is a new instance of the exec")
|
||||
(PROG1 [ERSETQ (CL:LOOP (* ; "loop until errors out")
|
||||
(CL:SETQ *CURRENT-EVENT* (GET-NEXT-HISTORY-EVENT
|
||||
LISPXHISTORY *EXEC-ID*
|
||||
@@ -397,25 +391,24 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE (CL:SPECIAL LISPXHIST HELPCLOCK))
|
||||
(CL:UNLESS (CL:EQUAL XCL::ORIGINAL-INPUT
|
||||
'(NIL))
|
||||
(DO-EVENT XCL::ORIGINAL-INPUT
|
||||
XCL::ENVIRONMENT XCL::FN)
|
||||
(DO-EVENT XCL::ORIGINAL-INPUT XCL::ENVIRONMENT
|
||||
XCL::FN)
|
||||
(CL:WHEN XCL::TOP-LEVEL-P
|
||||
(* ; "Used to determine whether to cache the settings of the profile back into the process (for retrieval in case of hardreset).")
|
||||
(XCL::SAVE-CURRENT-EXEC-PROFILE)))]
|
||||
(CL:WHEN XCL::WINDOW (TTYDISPLAYSTREAM XCL::OLD-DS)))])
|
||||
|
||||
(CL:DEFUN EXEC-EVAL (FORM &OPTIONAL ENVIRONMENT &KEY (PROMPT ">")
|
||||
(ID "eval/")
|
||||
((:TYPE *CURRENT-EXEC-TYPE*)
|
||||
'COMMON-LISP)) (* ; "Edited by JDS 16-Aug-90 12:55.")
|
||||
(ID "eval/")
|
||||
((:TYPE *CURRENT-EXEC-TYPE*)
|
||||
'COMMON-LISP)) (* ; "Edited by JDS 16-Aug-90 12:55.")
|
||||
(LET ((*CURRENT-EVENT* (GET-NEXT-HISTORY-EVENT LISPXHISTORY ID PROMPT T))
|
||||
(LISPXHIST LISPXHIST)
|
||||
(HELPCLOCK 0)
|
||||
VALUES)
|
||||
(DECLARE (CL:SPECIAL *CURRENT-EVENT* LISPXHIST HELPCLOCK))
|
||||
(SETQ VALUES (CL:MULTIPLE-VALUE-LIST (EVAL-INPUT (CL:SETF (EXEC-EVENT-INPUT
|
||||
*CURRENT-EVENT*)
|
||||
(LIST FORM))
|
||||
(SETQ VALUES (CL:MULTIPLE-VALUE-LIST (EVAL-INPUT (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*)
|
||||
(LIST FORM))
|
||||
ENVIRONMENT)))
|
||||
(SETQ IT (CAR VALUES))
|
||||
(COND
|
||||
@@ -455,8 +448,8 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
`(EXEC-VALUE-OF ',EVENT-SPEC))
|
||||
|
||||
(CL:DEFUN ADD-EXEC (&KEY (XCL::PROFILE XCL:*PROFILE*)
|
||||
XCL::REGION XCL::TTY (EXEC 'EXEC)
|
||||
XCL::ID &ALLOW-OTHER-KEYS)
|
||||
XCL::REGION XCL::TTY (EXEC 'EXEC)
|
||||
XCL::ID &ALLOW-OTHER-KEYS)
|
||||
(LET* [(XCL::WINDOW (XCL::SETUP-EXEC-WINDOW (CREATEW XCL::REGION "Exec")))
|
||||
(XCL::HANDLE (ADD.PROCESS
|
||||
`[PROGN (TTYDISPLAYSTREAM ',XCL::WINDOW)
|
||||
@@ -465,7 +458,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
',XCL::WINDOW)
|
||||
,(CASE EXEC
|
||||
(EXEC `(EXEC :TOP-LEVEL-P T :PROFILE ',XCL::PROFILE :ID
|
||||
',XCL::ID))
|
||||
',XCL::ID))
|
||||
(T `(XCL::ENTER-EXEC-FUNCTION ',EXEC ',XCL::PROFILE
|
||||
',XCL::ID)))]
|
||||
'NAME
|
||||
@@ -483,21 +476,21 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
((AND (READP T)
|
||||
(SYNTAXP (PEEKCCODE T T)
|
||||
'EOL)) (* ;
|
||||
"Avoid picking up end of line as a NIL.")
|
||||
"Avoid picking up end of line as a NIL.")
|
||||
(READC T)))
|
||||
(SETQ LINE (LIST (EXEC-READ BUFFER-STRING)))
|
||||
TOP (COND
|
||||
((LISTP (CAR LINE)) (* ;
|
||||
"If we got a list, return right away--it's a standard EVAL form of input")
|
||||
"If we got a list, return right away--it's a standard EVAL form of input")
|
||||
(GO OUT)))
|
||||
LP (SETQ SPACEFLG NIL) (* ; "to distinguish between")
|
||||
(* ; "FOO (A B)")
|
||||
(* ; "FOO(A B)")
|
||||
(* ;
|
||||
"the latter has no space and returns right away")
|
||||
"the latter has no space and returns right away")
|
||||
LP1 (COND
|
||||
((NOT (READP T)) (* ;
|
||||
"nothing more in line buffer, so must have consumed last thing on the line")
|
||||
"nothing more in line buffer, so must have consumed last thing on the line")
|
||||
(GO OUT))
|
||||
((NULL (SETQ CHRCODE (PEEKCCODE T T))) (* ; "PEEKCCODE can return NIL when stream is at EOF. However, we already checked for READP before getting here.")
|
||||
(GO OUT))
|
||||
@@ -510,7 +503,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(SHOULDNT))
|
||||
(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")
|
||||
" A %")%" is treated as NIL if it is the second thing on the line when EXEC-READ-LINE is called")
|
||||
(GO OUT))
|
||||
((EQ CHRCODE (CHARCODE SPACE))
|
||||
(SETQ SPACEFLG T)
|
||||
@@ -523,7 +516,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(SYNTAXP CHRCODE 'RIGHTBRACKET *READTABLE*)))
|
||||
(GO LP))
|
||||
((NOT SPACEFLG) (* ;
|
||||
"A list terminates the line if it is the second element on the line, not preceded by a space.")
|
||||
"A list terminates the line if it is the second element on the line, not preceded by a space.")
|
||||
|
||||
(* ;; "[JDS 1/12/88: This used to test (AND (NOT SPACEFLG) (READP T)), and loop if there were more input pending. This seems wrong, because when you type it should throw the carriage at once, and not depend on how fast you're typing. Further, when there's type-ahead, it's often followed by a SPACE, to prevent output pausing. With the old test here, that would hang up a final eval-quote form without executing it.]")
|
||||
|
||||
@@ -533,7 +526,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
OUT (RETURN (COND
|
||||
((AND (LISTP LINE)
|
||||
CTRLUFLG) (* ;
|
||||
"Edit interrupt during reading--forces structure editor use.")
|
||||
"Edit interrupt during reading--forces structure editor use.")
|
||||
(SETQ CTRLUFLG NIL)
|
||||
(LET ((*EDIT-INPUT-WITH-TTYIN* NIL))
|
||||
(FIX-FORM LINE)))
|
||||
@@ -553,7 +546,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(SETQ COM (GETHASH STR TABLE)))
|
||||
TABLE))))
|
||||
|
||||
(CL:DEFUN CIRCLAR-COPYER (INPUT) (* ; "Edited by TT 31-May-1990")
|
||||
(CL:DEFUN CIRCLAR-COPYER (INPUT) (* ; "Edited by TT 31-May-1990")
|
||||
(PROG (SCANBUF REST VAL NEW BODY ID AUX (CIRCLAR-FLAG NIL))
|
||||
(COND
|
||||
((NLISTP INPUT)
|
||||
@@ -580,9 +573,9 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(SETQ CIRCLAR-FLAG T)
|
||||
(RPLACD NEW (CDR ID)))
|
||||
(T [push REST (SETQ AUX (CONS (CADR NEW)
|
||||
(CDDR NEW]
|
||||
(CDDR NEW]
|
||||
(push SCANBUF (CONS (CDR NEW)
|
||||
AUX))
|
||||
AUX))
|
||||
(RPLACD NEW AUX)))
|
||||
(COND
|
||||
((NLISTP (CAR NEW)))
|
||||
@@ -591,9 +584,9 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(SETQ CIRCLAR-FLAG T)
|
||||
(RPLACA NEW (CDR ID)))
|
||||
(T [push REST (SETQ AUX (CONS (CAAR NEW)
|
||||
(CDAR NEW]
|
||||
(CDAR NEW]
|
||||
(push SCANBUF (CONS (CAR NEW)
|
||||
AUX))
|
||||
AUX))
|
||||
(RPLACA NEW AUX]
|
||||
(GO LP)))
|
||||
(DEFINEQ
|
||||
@@ -727,10 +720,10 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
"List of command hash-tables for the current executive")
|
||||
|
||||
(DEFGLOBALVAR *EXEC-COMMAND-TABLE* (HASHARRAY 30 NIL 'STRING-EQUAL-HASHBITS 'STRING-EQUAL)
|
||||
"hash-table for top level exec commands")
|
||||
"hash-table for top level exec commands")
|
||||
|
||||
(DEFGLOBALVAR *DEBUGGER-COMMAND-TABLE* (HASHARRAY 20 NIL 'STRING-EQUAL-HASHBITS 'STRING-EQUAL)
|
||||
"string-equal hash-table for debugger commands")
|
||||
"string-equal hash-table for debugger commands")
|
||||
|
||||
(CL:DEFVAR *CURRENT-EXEC-TYPE* NIL
|
||||
"Rebound under Exec; if NIL, means use default")
|
||||
@@ -1337,7 +1330,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
"Start an old-style LISPX window"])
|
||||
|
||||
(ADDTOVAR SYSTEMINITVARS (LISPXHISTORY NIL 0 100 100)
|
||||
(GREETHIST))
|
||||
(GREETHIST))
|
||||
|
||||
|
||||
|
||||
@@ -1347,24 +1340,23 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(DEF-DEFINE-TYPE COMMANDS "Exec Commands")
|
||||
|
||||
(DEFDEFINER (DEFCOMMAND [:NAME (CL:LAMBDA (WHOLE)
|
||||
(LET ((NAME (CL:SECOND WHOLE)))
|
||||
(CL:IF (CL:CONSP NAME)
|
||||
(CAR NAME)
|
||||
NAME)]) COMMANDS (NAME ARGUMENTS &ENVIRONMENT ENV
|
||||
&BODY BODY)
|
||||
(LET ((NAME (CL:SECOND WHOLE)))
|
||||
(CL:IF (CL:CONSP NAME)
|
||||
(CAR NAME)
|
||||
NAME)]) COMMANDS (NAME ARGUMENTS &ENVIRONMENT ENV
|
||||
&BODY BODY)
|
||||
[LET ((COMMAND-LEVEL '*EXEC-COMMAND-TABLE*)
|
||||
(COMMAND-TYPE :EVAL)
|
||||
(PREFIX "exec-"))
|
||||
[if (LISTP NAME)
|
||||
then (SETQ NAME (PROG1 (CAR NAME)
|
||||
[for X in (CDR NAME)
|
||||
do (CL:ECASE X
|
||||
((:QUIET :HISTORY :INPUT :EVAL :MACRO) (SETQ
|
||||
COMMAND-TYPE
|
||||
X))
|
||||
((:DEBUGGER :BREAK)
|
||||
(SETQ COMMAND-LEVEL '*DEBUGGER-COMMAND-TABLE*)
|
||||
(SETQ PREFIX "break-")))])]
|
||||
[for X in (CDR NAME) do (CL:ECASE X
|
||||
((:QUIET :HISTORY :INPUT :EVAL :MACRO)
|
||||
(SETQ COMMAND-TYPE X))
|
||||
((:DEBUGGER :BREAK)
|
||||
(SETQ COMMAND-LEVEL
|
||||
'*DEBUGGER-COMMAND-TABLE*)
|
||||
(SETQ PREFIX "break-")))])]
|
||||
(LET* ((CMACRONAME (PACK* PREFIX NAME))
|
||||
(STRINGNAME (STRING NAME)))
|
||||
(CL:MULTIPLE-VALUE-BIND (PARSED-BODY PARSED-DECLARATIONS PARSED-DOCSTRING)
|
||||
@@ -1397,32 +1389,32 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(CL:FORMAT T " ~20Tto apply function to the arguments given~&~%%or one of:")
|
||||
(FOR X ON (REVERSE *THIS-EXEC-COMMANDS*)
|
||||
DO (LET (COMS)
|
||||
[MAPHASH (CAR X)
|
||||
#'(CL:LAMBDA (VAL KEY)
|
||||
(AND [NOT (SOME (CDR X)
|
||||
#'(CL:LAMBDA (TAB)
|
||||
(GETHASH KEY TAB]
|
||||
(PUSH COMS (LIST KEY VAL]
|
||||
(CL:MAPC #'[CL:LAMBDA (COM)
|
||||
(CL:FORMAT T "~&")
|
||||
(DSPFONT INPUTFONT T)
|
||||
(CL:FORMAT T "~A " (CAR COM))
|
||||
(DSPFONT COMMENTFONT T)
|
||||
(PRINT-ARGLIST (COMMAND-ENTRY-ARGUMENTS (CADR COM)))
|
||||
(DSPFONT DEFAULTFONT T)
|
||||
(LET [(DOC (CL:DOCUMENTATION (CAR COM)
|
||||
'COMMANDS]
|
||||
(CL:WHEN DOC
|
||||
(TAB 20 1 T)
|
||||
(CL:FORMAT T "~A" DOC))]
|
||||
(CL:SORT COMS #'CL:STRING< :KEY #'CAR])
|
||||
[MAPHASH (CAR X)
|
||||
#'(CL:LAMBDA (VAL KEY)
|
||||
(AND [NOT (SOME (CDR X)
|
||||
#'(CL:LAMBDA (TAB)
|
||||
(GETHASH KEY TAB]
|
||||
(PUSH COMS (LIST KEY VAL]
|
||||
(CL:MAPC #'[CL:LAMBDA (COM)
|
||||
(CL:FORMAT T "~&")
|
||||
(DSPFONT INPUTFONT T)
|
||||
(CL:FORMAT T "~A " (CAR COM))
|
||||
(DSPFONT COMMENTFONT T)
|
||||
(PRINT-ARGLIST (COMMAND-ENTRY-ARGUMENTS (CADR COM)))
|
||||
(DSPFONT DEFAULTFONT T)
|
||||
(LET [(DOC (CL:DOCUMENTATION (CAR COM)
|
||||
'COMMANDS]
|
||||
(CL:WHEN DOC
|
||||
(TAB 20 1 T)
|
||||
(CL:FORMAT T "~A" DOC))]
|
||||
(CL:SORT COMS #'CL:STRING< :KEY #'CAR])
|
||||
(CL:VALUES))
|
||||
|
||||
(DEFCOMMAND ("??" :QUIET) (&REST EVENT-SPECS) "Show events specified EVENT-SPECS (or all events)"
|
||||
(IF (AND EVENT-SPECS (EQ (CAR EVENT-SPECS)
|
||||
':INPUT))
|
||||
':INPUT))
|
||||
THEN (PRINT-HISTORY LISPXHISTORY (CDR EVENT-SPECS)
|
||||
T)
|
||||
T)
|
||||
ELSE (PRINT-HISTORY LISPXHISTORY EVENT-SPECS))
|
||||
(CL:VALUES))
|
||||
|
||||
@@ -1435,21 +1427,19 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(DEFCOMMAND ("DIR" :EVAL) (&OPTIONAL PATHNAME &REST KEYWORDS) "Show directory listing for PATHNAME"
|
||||
[DODIR (CONS PATHNAME (MAPCAR KEYWORDS (FUNCTION (LAMBDA (CL:KEYWORD)
|
||||
(IF (CL:SYMBOLP CL:KEYWORD)
|
||||
THEN (CL:INTERN (CL:SYMBOL-NAME
|
||||
CL:KEYWORD)
|
||||
"INTERLISP")
|
||||
THEN (CL:INTERN (CL:SYMBOL-NAME CL:KEYWORD)
|
||||
"INTERLISP")
|
||||
ELSE CL:KEYWORD])
|
||||
|
||||
(DEFCOMMAND "DO-EVENTS" (&REST INPUTS &ENVIRONMENT ENV)
|
||||
"Execute the multiple events in INPUTS, using the environment ENV for all evaluations."
|
||||
[LET ((OUTER-EVENT (AND *CURRENT-EVENT* (COPY-EXEC-EVENT *CURRENT-EVENT*)))
|
||||
(* ;
|
||||
"DO-EVENT smashes *CURRENT-EVENT*, so we copy and save it.")
|
||||
"DO-EVENT smashes *CURRENT-EVENT*, so we copy and save it.")
|
||||
)
|
||||
(CL:WHEN OUTER-EVENT
|
||||
(CL:SETF (EXEC-EVENT-INPUT OUTER-EVENT)
|
||||
(CONS 'DO-EVENTS INPUTS)) (* ;
|
||||
"Each of these is fixed up below.")
|
||||
(CONS 'DO-EVENTS INPUTS)) (* ; "Each of these is fixed up below.")
|
||||
)
|
||||
(ERSETQ (CL:MAPL #'[CL:LAMBDA (INPUT)
|
||||
(LET ([TODO (CL:IF (EQ (CAR (LISTP (CAR INPUT)))
|
||||
@@ -1460,32 +1450,32 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(CL:WHEN ADDSPELLFLG (HISTORY-ADD-TO-SPELLING-LISTS TODO))
|
||||
(SETQ VALUES (DO-EVENT TODO ENV))
|
||||
(* ;
|
||||
"If it exists, *CURRENT-EVENT* gets smashed here.")
|
||||
"If it exists, *CURRENT-EVENT* gets smashed here.")
|
||||
(CL:WHEN OUTER-EVENT (* ; "If there is an outer event...")
|
||||
|
||||
(* ;;
|
||||
"Fix the outer event's list of inputs with the expanded input.")
|
||||
"Fix the outer event's list of inputs with the expanded input.")
|
||||
|
||||
(RPLACA INPUT (CAR (EXEC-EVENT-INPUT *CURRENT-EVENT*)))
|
||||
(CL:WHEN VALUES (* ;
|
||||
"If the last sub-event generated some values...")
|
||||
"If the last sub-event generated some values...")
|
||||
|
||||
(* ;;
|
||||
"Add the new values to the outer event's values.")
|
||||
"Add the new values to the outer event's values.")
|
||||
|
||||
[LET [(OLD-VALUES (CL:GETF (EXEC-EVENT-PROPS
|
||||
OUTER-EVENT)
|
||||
[LET [(OLD-VALUES (CL:GETF (EXEC-EVENT-PROPS
|
||||
OUTER-EVENT)
|
||||
'LISPXVALUES]
|
||||
(CL:IF OLD-VALUES
|
||||
(NCONC OLD-VALUES VALUES)
|
||||
(CL:SETF (EXEC-EVENT-PROPS OUTER-EVENT)
|
||||
(LIST* 'LISPXVALUES VALUES
|
||||
(EXEC-EVENT-PROPS
|
||||
OUTER-EVENT))))]))]
|
||||
(EXEC-EVENT-PROPS OUTER-EVENT))
|
||||
))]))]
|
||||
INPUTS))
|
||||
(CL:WHEN *CURRENT-EVENT* (* ; "If there was a current event...")
|
||||
(* ;
|
||||
"Smash saved values back from OUTER-EVENT.")
|
||||
"Smash saved values back from OUTER-EVENT.")
|
||||
(CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*)
|
||||
(EXEC-EVENT-INPUT OUTER-EVENT))
|
||||
(CL:SETF (EXEC-EVENT-ID *CURRENT-EVENT*)
|
||||
@@ -1496,19 +1486,18 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(EXEC-EVENT-PROPS OUTER-EVENT)))]
|
||||
(SETQ *CURRENT-EVENT* NIL) (* ; "Keeps the DO-EVENT which is evaluating us from setting the event's results to (the result of evaluating) the NIL we return. This is alright since *CURRENT-EVENT* is already pointed to by the history list.")
|
||||
(CL:VALUES) (* ;
|
||||
"We've evaluated all the subforms directly with DO-EVENT so we don't return a form to EVAL.")
|
||||
"We've evaluated all the subforms directly with DO-EVENT so we don't return a form to EVAL.")
|
||||
)
|
||||
|
||||
(DEFCOMMAND ("FIX" :HISTORY) (&REST EVENT-SPEC) "Edit input for specified events"
|
||||
[APPLY 'FIX-FORM (CL:MULTIPLE-VALUE-LIST (CIRCLAR-COPYER (EVENTS-INPUT
|
||||
(FIND-HISTORY-EVENTS
|
||||
(OR EVENT-SPEC '(-1))
|
||||
LISPXHISTORY])
|
||||
[APPLY 'FIX-FORM (CL:MULTIPLE-VALUE-LIST (CIRCLAR-COPYER (EVENTS-INPUT (FIND-HISTORY-EVENTS
|
||||
(OR EVENT-SPEC
|
||||
'(-1))
|
||||
LISPXHISTORY])
|
||||
|
||||
(DEFCOMMAND "FORGET" (&REST EVENT-SPEC) "Erase UNDO information (for specified events)."
|
||||
(FOR EVENT IN (FIND-HISTORY-EVENTS (OR EVENT-SPEC '(-1))
|
||||
LISPXHISTORY) DO (UNDOLISPX2 EVENT T)
|
||||
FINALLY (CL:FORMAT T "Forgotten.~&"))
|
||||
LISPXHISTORY) DO (UNDOLISPX2 EVENT T) FINALLY (CL:FORMAT T "Forgotten.~&"))
|
||||
(CL:VALUES))
|
||||
|
||||
(DEFCOMMAND "NAME" (COMMAND-NAME &OPTIONAL ARGUMENT-LIST &REST EVENT-SPEC)
|
||||
@@ -1517,8 +1506,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(CL:PUSH ARGUMENT-LIST EVENT-SPEC)
|
||||
(SETQ ARGUMENT-LIST NIL))
|
||||
[LET [(EVENTS (FIND-HISTORY-EVENTS EVENT-SPEC LISPXHISTORY))
|
||||
(ARGNAMES (FOR I FROM 1 AS X IN ARGUMENT-LIST
|
||||
COLLECT (PACK* 'ARG I]
|
||||
(ARGNAMES (FOR I FROM 1 AS X IN ARGUMENT-LIST COLLECT (PACK* 'ARG I]
|
||||
(CL:EVAL `(DEFCOMMAND (,COMMAND-NAME :HISTORY) ,ARGNAMES
|
||||
[SUBPAIR ',ARGNAMES (LIST ,@ARGNAMES)
|
||||
',(SUBPAIR ARGUMENT-LIST ARGNAMES (EVENTS-INPUT EVENTS)
|
||||
@@ -1536,7 +1524,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(DEFCOMMAND ("REDO" :HISTORY) (&REST EVENT-SPEC) "Re-execute specified event(s)"
|
||||
(EVENTS-INPUT (FIND-HISTORY-EVENTS (OR EVENT-SPEC '(-1))
|
||||
LISPXHISTORY)))
|
||||
LISPXHISTORY)))
|
||||
|
||||
(DEFCOMMAND ("REMEMBER" :EVAL) (&REST EVENT-SPEC)
|
||||
"Tell Manager to remember type-in from specified event(s)"
|
||||
@@ -1549,40 +1537,37 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(DEFCOMMAND "UNDO" (&REST EVENT-SPEC)
|
||||
"Undo side effects associated with the specified event (or last undoable one)"
|
||||
[FOR EVENT IN (FIND-HISTORY-EVENTS (OR EVENT-SPEC '(-1))
|
||||
LISPXHISTORY) DO (LET ((INPUT (CAR (EXEC-EVENT-INPUT EVENT)))
|
||||
(RESULT (UNDOLISPX2 EVENT)))
|
||||
(CL:IF (LISTP INPUT)
|
||||
(SETQ INPUT (CAR INPUT)))
|
||||
(COND
|
||||
((NULL RESULT)
|
||||
(CL:FORMAT T
|
||||
"No undo info saved for ~A.~&"
|
||||
INPUT))
|
||||
((EQ RESULT 'already)
|
||||
(CL:FORMAT T "~A already undone.~&"
|
||||
INPUT))
|
||||
(T (CL:FORMAT T "~A undone.~&" INPUT]
|
||||
LISPXHISTORY) DO (LET ((INPUT (CAR (EXEC-EVENT-INPUT EVENT)))
|
||||
(RESULT (UNDOLISPX2 EVENT)))
|
||||
(CL:IF (LISTP INPUT)
|
||||
(SETQ INPUT (CAR INPUT)))
|
||||
(COND
|
||||
((NULL RESULT)
|
||||
(CL:FORMAT T "No undo info saved for ~A.~&" INPUT))
|
||||
((EQ RESULT 'already)
|
||||
(CL:FORMAT T "~A already undone.~&" INPUT))
|
||||
(T (CL:FORMAT T "~A undone.~&" INPUT]
|
||||
(CL:VALUES))
|
||||
|
||||
(DEFCOMMAND ("USE" :HISTORY) (&REST LINE) "USE <new> [FOR <old>] [IN <event-spec>]"
|
||||
|
||||
(* ;;
|
||||
"this code stolen from LISPXUSE in HIST and edited. The structure is still pretty incomprehensible")
|
||||
"this code stolen from LISPXUSE in HIST and edited. The structure is still pretty incomprehensible")
|
||||
|
||||
[PROG (EVENT-SPECS EXPR ARGS VARS (STATE 'VARS)
|
||||
LST TEM USE-ARGS GENLST)
|
||||
LP [COND
|
||||
([OR (NULL LST)
|
||||
(NULL (CDR LINE))
|
||||
(NULL (CASE-EQUALP (CAR LINE) (* ;
|
||||
"look for one of the special keywords")
|
||||
(NULL (CASE-EQUALP (CAR LINE) (* ;
|
||||
"look for one of the special keywords")
|
||||
(FOR (COND
|
||||
((EQ STATE 'VARS)
|
||||
(SETQ VARS (NCONC1 VARS LST))
|
||||
(SETQ TEM (APPEND LST TEM))
|
||||
(SETQ STATE 'ARGS)
|
||||
(SETQ LST NIL)
|
||||
T)))
|
||||
((EQ STATE 'VARS)
|
||||
(SETQ VARS (NCONC1 VARS LST))
|
||||
(SETQ TEM (APPEND LST TEM))
|
||||
(SETQ STATE 'ARGS)
|
||||
(SETQ LST NIL)
|
||||
T)))
|
||||
(AND (COND
|
||||
((EQ STATE 'EXPR)
|
||||
NIL)
|
||||
@@ -1590,30 +1575,30 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
((EQ STATE 'ARGS)
|
||||
(SETQ ARGS (NCONC1 ARGS LST)))
|
||||
((EQ STATE 'VARS)(* ;
|
||||
"E.g. user types USE A AND B following previous USE command.")
|
||||
"E.g. user types USE A AND B following previous USE command.")
|
||||
(SETQ VARS (NCONC1 VARS LST]
|
||||
(SETQ STATE 'VARS)
|
||||
(SETQ LST NIL)
|
||||
T)))
|
||||
(IN (COND
|
||||
((AND (EQ STATE 'VARS)
|
||||
(NULL ARGS))
|
||||
(SETQ VARS (NCONC1 VARS LST))
|
||||
(SETQ TEM (APPEND LST TEM))
|
||||
(SETQ STATE 'EXPR)
|
||||
(SETQ LST NIL)
|
||||
T)
|
||||
((EQ STATE 'ARGS)
|
||||
(SETQ ARGS (NCONC1 ARGS LST))
|
||||
(SETQ STATE 'EXPR)
|
||||
(SETQ LST NIL)
|
||||
T]
|
||||
((AND (EQ STATE 'VARS)
|
||||
(NULL ARGS))
|
||||
(SETQ VARS (NCONC1 VARS LST))
|
||||
(SETQ TEM (APPEND LST TEM))
|
||||
(SETQ STATE 'EXPR)
|
||||
(SETQ LST NIL)
|
||||
T)
|
||||
((EQ STATE 'ARGS)
|
||||
(SETQ ARGS (NCONC1 ARGS LST))
|
||||
(SETQ STATE 'EXPR)
|
||||
(SETQ LST NIL)
|
||||
T]
|
||||
(SETQ LST (NCONC1 LST (COND
|
||||
(NIL (MEMBER (CAR LINE)
|
||||
TEM)
|
||||
|
||||
(* ;;
|
||||
"This enables USE A B FOR B A, USE A FOR B AND B FOR A, or USE A FOR B AND B C FOR A")
|
||||
"This enables USE A B FOR B A, USE A FOR B AND B FOR A, or USE A FOR B AND B C FOR A")
|
||||
|
||||
(LET ((TEMP (CONCAT "temp string")))
|
||||
(CL:PUSH (CONS (CAR LINE)
|
||||
@@ -1639,7 +1624,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(SETQ EXPR (MAPCAR (FIND-HISTORY-EVENTS EXPR LISPXHISTORY)
|
||||
(FUNCTION EXEC-EVENT-INPUT))) (* ;
|
||||
"EXPR is now a list of event inputs")
|
||||
"EXPR is now a list of event inputs")
|
||||
|
||||
(* ;; "at this point, VARS is a list of list of old things, the extra list corresponding to the clauses of an AND, e.g. ")
|
||||
|
||||
@@ -1651,60 +1636,68 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(IF (NULL ARGS)
|
||||
THEN [SETQ EXPR (FOR X IN EXPR
|
||||
JOIN (FOR VAR IN VARS
|
||||
COLLECT (IF (CL:CONSP (CAR X))
|
||||
THEN (CONS (CONS (CAR VAR)
|
||||
(CDAR X))
|
||||
(CDR X))
|
||||
ELSE (CONS (CAR VAR)
|
||||
(CDR X]
|
||||
JOIN (FOR VAR IN VARS
|
||||
COLLECT (IF (CL:CONSP (CAR X))
|
||||
THEN (CONS (CONS (CAR VAR)
|
||||
(CDAR X))
|
||||
(CDR X))
|
||||
ELSE (CONS (CAR VAR)
|
||||
(CDR X]
|
||||
ELSE (WHILE ARGS DO (SETQ EXPR (LISPXUSE1 (POP VARS)
|
||||
(POP ARGS)
|
||||
EXPR))
|
||||
FINALLY (COND
|
||||
(VARS (ERROR '"use what??" "" T)))
|
||||
[MAPC GENLST (FUNCTION (LAMBDA (X)
|
||||
(LISPXSUBST (CAR X)
|
||||
(CDR X)
|
||||
EXPR T]
|
||||
(POP ARGS)
|
||||
EXPR)) FINALLY (COND
|
||||
(VARS (ERROR '"use what??" "" T)))
|
||||
[MAPC GENLST (FUNCTION (LAMBDA (X)
|
||||
(LISPXSUBST
|
||||
(CAR X)
|
||||
(CDR X)
|
||||
EXPR T]
|
||||
|
||||
(* ;; "samples:")
|
||||
(* ;; "samples:")
|
||||
|
||||
(* ;; " USE A B C D FOR X Y means substitute A for X and B for Y and then do it again with C for X and D for Y")
|
||||
(* ;; " USE A B C D FOR X Y means substitute A for X and B for Y and then do it again with C for X and D for Y")
|
||||
|
||||
(* ;; " Equivalent to USE A C FOR X AND B D FOR Y")
|
||||
(* ;;
|
||||
" Equivalent to USE A C FOR X AND B D FOR Y")
|
||||
|
||||
(* ;; " USE A B C FOR D AND X Y Z FOR W means 3 operations:")
|
||||
(* ;;
|
||||
" USE A B C FOR D AND X Y Z FOR W means 3 operations:")
|
||||
|
||||
(* ;; " A for D and X for W in the first")
|
||||
(* ;;
|
||||
" A for D and X for W in the first")
|
||||
|
||||
(* ;; " B for D and Y for W in the second")
|
||||
(* ;;
|
||||
" B for D and Y for W in the second")
|
||||
|
||||
(* ;; " C for D and Z for W in the third")
|
||||
(* ;;
|
||||
" C for D and Z for W in the third")
|
||||
|
||||
(* ;; "USE A B C FOR D AND X FOR Y means 3 operations:")
|
||||
(* ;;
|
||||
"USE A B C FOR D AND X FOR Y means 3 operations:")
|
||||
|
||||
(* ;; " A for D and X for Y in first")
|
||||
(* ;; " A for D and X for Y in first")
|
||||
|
||||
(* ;; " B for D and X for Y in second, etc.")
|
||||
(* ;;
|
||||
" B for D and X for Y in second, etc.")
|
||||
|
||||
(* ;; "USE A B C FOR D AND X Y FOR Z causes error")
|
||||
(* ;;
|
||||
"USE A B C FOR D AND X Y FOR Z causes error")
|
||||
|
||||
(* ;; "")
|
||||
(* ;; "")
|
||||
|
||||
(* ;; " USE A B FOR B A will work correctly, but USE A FOR B AND B FOR A will result in all B's being changed to A's.")
|
||||
(* ;; " USE A B FOR B A will work correctly, but USE A FOR B AND B FOR A will result in all B's being changed to A's.")
|
||||
|
||||
(* ;; "")
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "The general rule is substitution proceeds from left to right with each %%'AND' handled separately. Whenever the number of variables exceeds the number of expressions available, the expressions multiply.")
|
||||
(* ;; "The general rule is substitution proceeds from left to right with each %%'AND' handled separately. Whenever the number of variables exceeds the number of expressions available, the expressions multiply.")
|
||||
|
||||
))
|
||||
))
|
||||
(RETURN (COND
|
||||
[(CDR EXPR)
|
||||
(CONS 'DO-EVENTS (for X in EXPR collect (COND
|
||||
((CDR X)
|
||||
(CONS 'EVENT X))
|
||||
(T (CAR X]
|
||||
((CDR X)
|
||||
(CONS 'EVENT X))
|
||||
(T (CAR X]
|
||||
(T (CAR EXPR])
|
||||
|
||||
(DEFCOMMAND "PP" (&OPTIONAL (NAME LASTWORD)
|
||||
@@ -1714,25 +1707,22 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(* ;; "returned from if no definitions found")
|
||||
|
||||
(for TYPE in [OR TYPES [TYPESOF NAME NIL NIL '? (FUNCTION (LAMBDA (TYPE)
|
||||
(NEQ (GET TYPE
|
||||
'EDITDEF)
|
||||
'NILL]
|
||||
(TYPESOF [SETQ NAME (OR (FIXSPELL NAME NIL USERWORDS NIL NIL
|
||||
[FUNCTION (LAMBDA (WORD)
|
||||
(TYPESOF
|
||||
WORD NIL
|
||||
'(FIELDS FILES)
|
||||
'CURRENT]
|
||||
NIL NIL NIL 'MUSTAPPROVE)
|
||||
(PROGN (CL:FORMAT *TERMINAL-IO*
|
||||
"No definitions found for ~S."
|
||||
NAME)
|
||||
(RETURN NIL]
|
||||
NIL NIL '? (FUNCTION (LAMBDA (TYPE)
|
||||
(NEQ (GET TYPE 'EDITDEF)
|
||||
'NILL]
|
||||
(NEQ (GET TYPE 'EDITDEF)
|
||||
'NILL]
|
||||
(TYPESOF [SETQ NAME (OR (FIXSPELL NAME NIL USERWORDS NIL NIL
|
||||
[FUNCTION (LAMBDA (WORD)
|
||||
(TYPESOF WORD NIL
|
||||
'(FIELDS FILES)
|
||||
'CURRENT]
|
||||
NIL NIL NIL 'MUSTAPPROVE)
|
||||
(PROGN (CL:FORMAT *TERMINAL-IO*
|
||||
"No definitions found for ~S." NAME)
|
||||
(RETURN NIL]
|
||||
NIL NIL '? (FUNCTION (LAMBDA (TYPE)
|
||||
(NEQ (GET TYPE 'EDITDEF)
|
||||
'NILL]
|
||||
do (CL:FORMAT *TERMINAL-IO* "~A definition for ~S:~%%" TYPE NAME)
|
||||
(SHOWDEF NAME TYPE)))
|
||||
(SHOWDEF NAME TYPE)))
|
||||
(CL:VALUES))
|
||||
|
||||
|
||||
@@ -1740,7 +1730,7 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(* ;; "Arrange to use the correct compiler")
|
||||
|
||||
|
||||
(PUTPROPS CMLEXEC FILETYPE CL:COMPILE-FILE)
|
||||
(PUTPROPS CMLEXEC FILETYPE :FAKE-COMPILE-FILE)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
|
||||
(ADDTOVAR NLAMA DIR)
|
||||
@@ -1751,22 +1741,22 @@ Copyright (c) 1985-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
(PUTPROPS CMLEXEC COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1991 1993 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3978 4383 (XCL::EXEC-CLOSEFN 3978 . 4383)) (4385 4721 (XCL::EXEC-SHRINKFN 4385 . 4721))
|
||||
(4723 4963 (XCL::SETUP-EXEC-WINDOW 4723 . 4963)) (4965 5211 (XCL::EXEC-TITLE-FUNCTION 4965 . 5211)) (
|
||||
5213 8519 (FIX-FORM 5213 . 8519)) (8521 8641 (XCL::GET-PROCESS-PROFILE 8521 . 8641)) (8643 8924 (
|
||||
XCL::SAVE-CURRENT-EXEC-PROFILE 8643 . 8924)) (8926 9216 (XCL::SETF-GET-PROCESS-PROFILE 8926 . 9216)) (
|
||||
9218 9785 (XCL:SET-EXEC-TYPE 9218 . 9785)) (9787 9869 (XCL:SET-DEFAULT-EXEC-TYPE 9787 . 9869)) (9871
|
||||
10282 (XCL::ENTER-EXEC-FUNCTION 9871 . 10282)) (10357 16750 (DO-EVENT 10357 . 16750)) (16752 23543 (
|
||||
EXEC 16752 . 23543)) (23545 24886 (EXEC-EVAL 23545 . 24886)) (24888 25619 (PRINT-ALL-DOCUMENTATION
|
||||
24888 . 25619)) (25621 26063 (PRINT-DOCUMENTATION 25621 . 26063)) (26146 27230 (ADD-EXEC 26146 . 27230
|
||||
)) (27232 30828 (EXEC-READ-LINE 27232 . 30828)) (30899 31385 (FIND-EXEC-COMMAND 30899 . 31385)) (31387
|
||||
33285 (CIRCLAR-COPYER 31387 . 33285)) (33286 34240 (COPY-CIRCLE 33296 . 34238)) (34318 37623 (
|
||||
EXEC-READ 34328 . 37489) (DIR 37491 . 37621)) (39885 67019 (DO-APPLY-EVENT 39895 . 40457) (
|
||||
DO-HISTORY-SEARCH 40459 . 41916) (EVAL-INPUT 41918 . 47347) (EVENTS-INPUT 47349 . 48727) (EXEC-PRIN1
|
||||
48729 . 48905) (EXEC-VALUE-OF 48907 . 49246) (GET-NEXT-HISTORY-EVENT 49248 . 50743) (
|
||||
HISTORY-ADD-TO-SPELLING-LISTS 50745 . 51733) (HISTORY-NTH 51735 . 52485) (PRINT-HISTORY 52487 . 53108)
|
||||
(FIND-HISTORY-EVENTS 53110 . 58171) (PRINT-EVENT 58173 . 62394) (PRINT-EVENT-PROMPT 62396 . 63600) (
|
||||
PROCESS-EXEC-ID 63602 . 64547) (SEARCH-FOR-EVENT-NUMBER 64549 . 65177) (\PICK.EVALQT 65179 . 65690) (
|
||||
LISPXREPRINT 65692 . 67017)) (68199 68298 (EXEC-PRINT 68199 . 68298)) (68300 68565 (EXEC-FORMAT 68300
|
||||
. 68565)))))
|
||||
(FILEMAP (NIL (4002 4407 (XCL::EXEC-CLOSEFN 4002 . 4407)) (4409 4745 (XCL::EXEC-SHRINKFN 4409 . 4745))
|
||||
(4747 4987 (XCL::SETUP-EXEC-WINDOW 4747 . 4987)) (4989 5235 (XCL::EXEC-TITLE-FUNCTION 4989 . 5235)) (
|
||||
5237 8404 (FIX-FORM 5237 . 8404)) (8406 8526 (XCL::GET-PROCESS-PROFILE 8406 . 8526)) (8528 8809 (
|
||||
XCL::SAVE-CURRENT-EXEC-PROFILE 8528 . 8809)) (8811 9097 (XCL::SETF-GET-PROCESS-PROFILE 8811 . 9097)) (
|
||||
9099 9666 (XCL:SET-EXEC-TYPE 9099 . 9666)) (9668 9750 (XCL:SET-DEFAULT-EXEC-TYPE 9668 . 9750)) (9752
|
||||
10159 (XCL::ENTER-EXEC-FUNCTION 9752 . 10159)) (10234 16465 (DO-EVENT 10234 . 16465)) (16467 23064 (
|
||||
EXEC 16467 . 23064)) (23066 24317 (EXEC-EVAL 23066 . 24317)) (24319 25050 (PRINT-ALL-DOCUMENTATION
|
||||
24319 . 25050)) (25052 25494 (PRINT-DOCUMENTATION 25052 . 25494)) (25577 26652 (ADD-EXEC 25577 . 26652
|
||||
)) (26654 30264 (EXEC-READ-LINE 26654 . 30264)) (30335 30821 (FIND-EXEC-COMMAND 30335 . 30821)) (30823
|
||||
32709 (CIRCLAR-COPYER 30823 . 32709)) (32710 33664 (COPY-CIRCLE 32720 . 33662)) (33742 37047 (
|
||||
EXEC-READ 33752 . 36913) (DIR 36915 . 37045)) (39301 66435 (DO-APPLY-EVENT 39311 . 39873) (
|
||||
DO-HISTORY-SEARCH 39875 . 41332) (EVAL-INPUT 41334 . 46763) (EVENTS-INPUT 46765 . 48143) (EXEC-PRIN1
|
||||
48145 . 48321) (EXEC-VALUE-OF 48323 . 48662) (GET-NEXT-HISTORY-EVENT 48664 . 50159) (
|
||||
HISTORY-ADD-TO-SPELLING-LISTS 50161 . 51149) (HISTORY-NTH 51151 . 51901) (PRINT-HISTORY 51903 . 52524)
|
||||
(FIND-HISTORY-EVENTS 52526 . 57587) (PRINT-EVENT 57589 . 61810) (PRINT-EVENT-PROMPT 61812 . 63016) (
|
||||
PROCESS-EXEC-ID 63018 . 63963) (SEARCH-FOR-EVENT-NUMBER 63965 . 64593) (\PICK.EVALQT 64595 . 65106) (
|
||||
LISPXREPRINT 65108 . 66433)) (67615 67714 (EXEC-PRINT 67615 . 67714)) (67716 67981 (EXEC-FORMAT 67716
|
||||
. 67981)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user