github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-03-09 12:40:30 +00:00
Code Issues Projects Releases Wiki Activity

import an LOOP macro (#1579)

Browse Source 
* import an LOOP macro
* add to loadup

* change CML-LOOP to XCL-LOOP finish
* Change package to LOOP, no nickname; 'loop' and 'loop-finish' are in LISP package
 Install copyright/acknowledgement
This commit is contained in:
Larry Masinter
2024-03-16 19:57:20 -07:00
committed by GitHub
parent c66583e7b0
commit 8e07e25b9a
8 changed files with 1577 additions and 113 deletions
Download Patch File Download Diff File Expand all files Collapse all files

17
internal/loadups/LOADUP-LISP
View File

@@ -1,11 +1,13 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "31-Jul-2023 18:22:53" |{DSK}<home>frank>il>medley>gmedley>sources>LOADUP-LISP.;2| 5235
(FILECREATED "14-Mar-2024 12:16:33" |{DSK}<home>larry>il>medley>internal>loadups>LOADUP-LISP.;2| 5426
:EDIT-BY "lmm"
:CHANGES-TO (FNS LOADUP-LISP)
:PREVIOUS-DATE "27-Feb-2023 17:15:53"
|{DSK}<home>frank>il>medley>gmedley>sources>LOADUP-LISP.;1|)
:PREVIOUS-DATE "31-Jul-2023 18:22:53"
|{DSK}<home>larry>il>medley>internal>loadups>LOADUP-LISP.;1|)
(PRETTYCOMPRINT LOADUP-LISPCOMS)
@@ -18,7 +20,8 @@
(DEFINEQ
(LOADUP-LISP
(LAMBDA (DRIBBLEFILE) (* \; "Edited 26-Feb-2023 12:17 by lmm")
(LAMBDA (DRIBBLEFILE) (* \; "Edited 14-Mar-2024 12:16 by lmm")
(* \; "Edited 26-Feb-2023 12:17 by lmm")
(* \; "Edited 13-Jul-2022 14:09 by rmk")
(* \; "Edited 4-Mar-2022 19:13 by larry")
(* \; "Edited 29-Apr-2021 22:30 by rmk:")
@@ -107,6 +110,10 @@
(PACKAGE-ENABLE)
(* |;;| " Added late")
(LOADUP '(XCL-LOOP))
(* |;;| " networking code -- should make it optional but too many cross dependencies")
(LOADUP '(PUP 10MBDRIVER LEAF LLETHER DPUPFTP LOCALFILE DSKDISPLAY COURIER LLNS TRSERVER SPP
@@ -123,5 +130,5 @@
(GLOBALVARS MAKESYSFILENAME MEDLEY-INIT-VARS MEDLEYDIR SYSTEMINITVARS USERRECLST)
)
(DECLARE\: DONTCOPY
(FILEMAP (NIL (649 5029 (LOADUP-LISP 659 . 5027)))))
(FILEMAP (NIL (673 5220 (LOADUP-LISP 683 . 5218)))))
STOP

BIN
internal/loadups/LOADUP-LISP.LCOM
View File

Binary file not shown.

54
sources/CMLSPECIALFORMS
View File

@@ -1,20 +1,20 @@
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
(IL:FILECREATED "16-May-90 14:43:08" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLSPECIALFORMS.;2| 20313
(DEFINE-FILE-INFO PACKAGE "LISP" READTABLE "XCL" BASE 10)
IL:|changes| IL:|to:| (IL:VARS IL:CMLSPECIALFORMSCOMS)
(IL:FILECREATED "15-Mar-2024 20:39:04" IL:|{DSK}<home>larry>il>medley>sources>CMLSPECIALFORMS.;4| 19873
IL:|previous| IL:|date:| "13-Jun-88 18:25:25"
IL:|{DSK}<usr>local>lde>lispcore>sources>CMLSPECIALFORMS.;1|)
:EDIT-BY "lmm"
:CHANGES-TO (IL:VARS IL:CMLSPECIALFORMSCOMS)
:PREVIOUS-DATE "15-Mar-2024 10:39:44" IL:|{DSK}<home>larry>il>medley>sources>CMLSPECIALFORMS.;2|
)
; Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved.
(IL:PRETTYCOMPRINT IL:CMLSPECIALFORMSCOMS)
(IL:RPAQQ IL:CMLSPECIALFORMSCOMS
((IL:COMS (IL:FUNCTIONS LOOP)
(IL:COMS (IL:FUNCTIONS IDENTITY)
(XCL:OPTIMIZERS IDENTITY))
((IL:COMS (IL:COMS (IL:FUNCTIONS IDENTITY)
(XCL:OPTIMIZERS IDENTITY))
(IL:FUNCTIONS UNLESS WHEN))
(IL:FUNCTIONS FLET LABELS IL:SELECTQ)
(IL:COMS
@@ -31,8 +31,7 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>CMLSPECIALFORMS.;1|)
(IL:COMS
(IL:* IL:|;;|
 "Hacks for Interlisp NLAMBDAs that should look like functions")
(IL:* IL:|;;| "Hacks for Interlisp NLAMBDAs that should look like functions")
(IL:PROP IL:MACRO IL:FRPTQ IL:SETN IL:SUB1VAR IL:*))
(IL:COMS (IL:FNS IL:BQUOTIFY)
@@ -53,13 +52,6 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>CMLSPECIALFORMS.;1|)
(IL:NLAML)
(IL:LAMA)))))
(DEFMACRO LOOP (&REST FORMS)
(LET ((TAG (GENSYM)))
`(PROG NIL
,TAG
,@FORMS
(GO ,TAG))))
(DEFUN IDENTITY (THING)
(IL:* IL:|;;| "Returns what was passed to it. Default for :key options.")
@@ -67,7 +59,7 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>CMLSPECIALFORMS.;1|)
THING)
(XCL:DEFOPTIMIZER IDENTITY (X)
X)
X)
(DEFMACRO UNLESS (TEST &BODY BODY)
`(COND
@@ -223,10 +215,10 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>CMLSPECIALFORMS.;1|)
(DEFMACRO DO (VARS END-TEST &BODY BODY &ENVIRONMENT ENV)
(%DO-TRANSLATE VARS END-TEST BODY NIL ENV))
(%DO-TRANSLATE VARS END-TEST BODY NIL ENV))
(DEFMACRO DO* (BINDS END-TEST &REST BODY &ENVIRONMENT ENV)
(%DO-TRANSLATE BINDS END-TEST BODY T ENV))
(%DO-TRANSLATE BINDS END-TEST BODY T ENV))
(DEFUN %DO-TRANSLATE (VARS END-TEST BODY SEQUENTIALP ENV)
(LET ((VARS-AND-INITIAL-VALUES (MAPCAR #'(LAMBDA (X)
@@ -263,7 +255,7 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>CMLSPECIALFORMS.;1|)
(GO ,TAG)))))
(DEFMACRO DOLIST ((VAR LISTFORM &OPTIONAL RESULTFORM)
&BODY BODY &ENVIRONMENT ENV)
&BODY BODY &ENVIRONMENT ENV)
(LET ((TAIL (GENSYM)))
(MULTIPLE-VALUE-BIND
(BODY DECL)
@@ -278,7 +270,7 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>CMLSPECIALFORMS.;1|)
(SETQ ,TAIL (CDR ,TAIL)))))))
(DEFMACRO DOTIMES ((VAR COUNTFORM &OPTIONAL RESULTFORM)
&BODY BODY &ENVIRONMENT ENV)
&BODY BODY &ENVIRONMENT ENV)
(LET ((MAX (GENSYM)))
(MULTIPLE-VALUE-BIND (BODY DECLS)
(XCL:PARSE-BODY BODY ENV)
@@ -298,7 +290,7 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>CMLSPECIALFORMS.;1|)
(CLAUSES
(MAPCAR
#'(LAMBDA
(CASE)
(CASE)
(LET ((KEY-LIST (CAR CASE))
(CONSEQUENTS (OR (CDR CASE)
(LIST NIL))))
@@ -341,10 +333,10 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>CMLSPECIALFORMS.;1|)
(IL:PUTPROPS IL:SETN IL:MACRO (= . IL:SETQ))
(IL:PUTPROPS IL:SUB1VAR IL:MACRO ((IL:X)
(IL:SETQ IL:X (IL:SUB1 IL:X))))
(IL:SETQ IL:X (IL:SUB1 IL:X))))
(IL:PUTPROPS IL:* IL:MACRO ((IL:X . IL:Y)
'IL:X))
'IL:X))
(IL:DEFINEQ
(il:bquotify
@@ -479,9 +471,11 @@ IL:|{DSK}<usr>local>lde>lispcore>sources>CMLSPECIALFORMS.;1|)
(IL:ADDTOVAR IL:LAMA )
)
(IL:PUTPROPS IL:CMLSPECIALFORMS IL:COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987
1988 1990))
(IL:DECLARE\: IL:DONTCOPY
(IL:FILEMAP (NIL (13354 18024 (IL:BQUOTIFY 13367 . 18022)) (19227 19633 (IL:CLEAR-CLISPARRAY 19240 .
19631)))))
(IL:FILEMAP (NIL (2492 2613 (IDENTITY 2492 . 2613)) (2681 2773 (UNLESS 2681 . 2773)) (2775 2845 (WHEN
2775 . 2845)) (2847 4614 (FLET 2847 . 4614)) (4616 6669 (LABELS 4616 . 6669)) (6671 8466 (IL:SELECTQ
6671 . 8466)) (8513 8624 (DO 8513 . 8624)) (8626 8738 (DO* 8626 . 8738)) (8740 10291 (%DO-TRANSLATE
8740 . 10291)) (10293 10883 (DOLIST 10293 . 10883)) (10885 11388 (DOTIMES 10885 . 11388)) (11390 12562
(CASE 11390 . 12562)) (13026 17696 (IL:BQUOTIFY 13039 . 17694)) (18899 19305 (IL:CLEAR-CLISPARRAY
18912 . 19303)))))
IL:STOP

BIN
sources/CMLSPECIALFORMS.LCOM
View File

Binary file not shown.

154
sources/PACKAGE-STARTUP
View File

@@ -1,24 +1,24 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10 FORMAT XCCS)
(FILECREATED " 1-Aug-2021 18:08:23" 
|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>PACKAGE-STARTUP.;9| 36725
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|changes| |to:| (FUNCTIONS PACKAGE-ENABLE)
(FILECREATED "16-Mar-2024 08:28:55" |{DSK}<home>larry>il>medley>sources>PACKAGE-STARTUP.;2| 36546
|previous| |date:| "29-Jul-2021 20:33:07"
|{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>PACKAGE-STARTUP.;8|)
:EDIT-BY "lmm"
:CHANGES-TO (VARIABLES CMLSYMBOLS.MACROS)
:PREVIOUS-DATE " 1-Aug-2021 18:08:23" |{DSK}<home>larry>il>medley>sources>PACKAGE-STARTUP.;1|
)
; Copyright (c) 1986-1988, 1990-1991, 2021 by Venue & Xerox Corporation.
(PRETTYCOMPRINT PACKAGE-STARTUPCOMS)
(RPAQQ PACKAGE-STARTUPCOMS
(
(* |;;;| "Initialize the package system (LLPACKAGE must be loaded)")
(* |;;;| "Initialize the package system (LLPACKAGE must be loaded)")
(* |;;| "Simple definitions for the init. Improved in CMLPACKAGE")
(* |;;| "Simple definitions for the init. Improved in CMLPACKAGE")
(FUNCTIONS RETURN-FIRST-OF-THREE ERROR-MISSING-EXTERNAL-SYMBOL)
(P (MOVD? 'ERROR-MISSING-EXTERNAL-SYMBOL 'RESOLVE-MISSING-EXTERNAL-SYMBOL)
@@ -29,20 +29,20 @@
(MOVD? 'ERROR 'RESOLVE-IMPORT-CONFLICT)
(MOVD? 'ERROR 'RESOLVE-UNINTERN-CONFLICT)
(MOVD? 'RETURN-FIRST-OF-THREE 'RESOLVE-READER-CONFLICT)
(* \;
 "In pre-package init all symbols are prefixed, thus the INTERLISP symbol is always default")
(* \;
 "In pre-package init all symbols are prefixed, thus the INTERLISP symbol is always default")
)
(* |;;| "Reader changes")
(* |;;| "Reader changes")
(FUNCTIONS CHECK-SYMBOL-NAMESTRING \\NEW.READ.SYMBOL \\NEW.MKATOM)
(VARIABLES LITATOM-PACKAGE-CONVERSION-ENABLED)
(* |;;| "Initialization tables and functions")
(* |;;| "Initialization tables and functions")
(VARIABLES CMLSYMBOLS.VARS CMLSYMBOLS.FNNAMES CMLSYMBOLS.DECLARATORS CMLSYMBOLS.TYPENAMES
CMLSYMBOLS.MACROS CMLSYMBOLS.SPECIALFORMS CMLSYMBOLS.LAMBDA.LIST.KEYWORDS)
(VARIABLES (* \; "Be very careful with this.")
(VARIABLES (* \; "Be very careful with this.")
CMLSYMBOLS.SHARED)
(FUNCTIONS LITATOM.EXISTS)
(VARIABLES LITATOM-PACKAGE-CONVERSION-TABLE)
@@ -51,13 +51,13 @@
(FUNCTIONS PACKAGE-INIT PACKAGE-CLEAR PACKAGE-MAKE PACKAGE-HIERARCHY-INIT PACKAGE-ENABLE
PACKAGE-DISABLE)
(* |;;| "A hack for initialization")
(* |;;| "A hack for initialization")
(FUNCTIONS ID)
(PROP (FILETYPE MAKEFILE-ENVIRONMENT)
PACKAGE-STARTUP)
(* |;;| "Initialize package system, plus functions needed in llpackage at init time")
(* |;;| "Initialize package system, plus functions needed in llpackage at init time")
(DECLARE\: DONTEVAL@LOAD DOCOPY (P (MOVD? 'EQ 'EQL)
(MOVD? 'LENGTH 'CL:LENGTH)
@@ -98,8 +98,8 @@
(MOVD? 'RETURN-FIRST-OF-THREE 'RESOLVE-READER-CONFLICT)
(* \;
 "In pre-package init all symbols are prefixed, thus the INTERLISP symbol is always default")
(* \;
 "In pre-package init all symbols are prefixed, thus the INTERLISP symbol is always default")
@@ -126,12 +126,12 @@
(CL:DEFUN \\NEW.READ.SYMBOL (BASE OFFSET LEN FATP PACKAGE EXTERNALP NONNUMERICP)
"Read a number or symbol from the string defined by BASE OFFSET LEN FATP PACKAGE is NIL if no package was specified, a package object or a string if an unknown package was typed (causes error). EXTERNALP is true if symbol was typed with one colon, which requires that the symbol exist and be external (unless it was a keyword). NONNUMERICP is true if we know the symbol is not a number, e.g., some characters in it were escaped."
(DECLARE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-ENABLED *READTABLE* FILERDTBL CODERDTBL
*PACKAGE* *LISP-PACKAGE* *INTERLISP-PACKAGE*))
(DECLARE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-ENABLED *READTABLE* FILERDTBL CODERDTBL *PACKAGE*
*LISP-PACKAGE* *INTERLISP-PACKAGE*))
(OR (AND (NOT NONNUMERICP)
(\\PARSE.NUMBER BASE OFFSET LEN FATP))
(AND
(* |;;| "The reader conversion feature is contained in this expression")
(* |;;| "The reader conversion feature is contained in this expression")
LITATOM-PACKAGE-CONVERSION-ENABLED
(NULL PACKAGE)
@@ -142,13 +142,13 @@
(FIND-SYMBOL* BASE OFFSET LEN FATP *LISP-PACKAGE*)
(LET ((ILSYM (FIND-SYMBOL* BASE OFFSET LEN FATP *INTERLISP-PACKAGE*)))
(COND
((NULL ILSYM) (* \; "No IL symbol, try CL")
((NULL ILSYM) (* \; "No IL symbol, try CL")
CLSYM)
((NULL CLSYM) (* \; "No CL symbol, use IL")
((NULL CLSYM) (* \; "No CL symbol, use IL")
ILSYM)
((EQ ILSYM CLSYM) (* \; "SAME")
((EQ ILSYM CLSYM) (* \; "SAME")
ILSYM)
(T (* \; "Both symbols exist, resolve. During the INIT where packages are turned off this is defined to return its first argument.")
(T (* \; "Both symbols exist, resolve. During the INIT where packages are turned off this is defined to return its first argument.")
(RESOLVE-READER-CONFLICT ILSYM CLSYM CLSYMWHERE)))))))
(COND
((STRINGP PACKAGE)
@@ -164,8 +164,8 @@
(COND
((EQ ACCESSIBLE :EXTERNAL)
CL:SYMBOL)
((CL::%PACKAGE-EXTERNAL-ONLY PACKAGE) (* \;
 "External only packages don't error creating external symbols on read")
((CL::%PACKAGE-EXTERNAL-ONLY PACKAGE) (* \;
 "External only packages don't error creating external symbols on read")
(INTERN* BASE OFFSET LEN FATP (\\FATCHARSEENP BASE OFFSET LEN FATP)
(OR PACKAGE *PACKAGE*)
T))
@@ -182,20 +182,20 @@
(UNLESSRDSYS (COND
((AND (EQ LEN 1)
(ILEQ FIRSTCHAR \\MAXTHINCHAR)
|\\OneCharAtomBase|) (* \;
 "The one-character atoms live in well known places, no need to hash")
|\\OneCharAtomBase|) (* \;
 "The one-character atoms live in well known places, no need to hash")
(RETURN (COND
((IGREATERP FIRSTCHAR (CHARCODE "9"))
(\\ADDBASE |\\OneCharAtomBase| (IDIFFERENCE FIRSTCHAR 10)))
((IGEQ FIRSTCHAR (CHARCODE "0"))
(* \;
 "These one-character atoms are integers")
(* \;
 "These one-character atoms are integers")
(IDIFFERENCE FIRSTCHAR (CHARCODE "0")))
(T (\\ADDBASE |\\OneCharAtomBase| FIRSTCHAR)))))
((AND (ILEQ FIRSTCHAR (CHARCODE "9"))
(SETQ TEMP (\\PARSE.NUMBER BASE OFFST LEN FATP)))
(* |;;| "\\PARSE.NUMBER returns a number or NIL")
(* |;;| "\\PARSE.NUMBER returns a number or NIL")
(RETURN TEMP))))
(RETURN (CL:VALUES (INTERN* BASE OFFST LEN FATP FATCHARSEENP *INTERLISP-PACKAGE* T)))))
@@ -312,7 +312,7 @@
"WRITE-STRING" "WRITE-TO-STRING" "Y-OR-N-P" "YES-OR-NO-P" "ZEROP"))
(CL:DEFPARAMETER CMLSYMBOLS.DECLARATORS '("DECLARATION" "FTYPE" "FUNCTION" "IGNORE" "INLINE"
"NOTINLINE" "OPTIMIZE" "SPECIAL" "TYPE"))
"NOTINLINE" "OPTIMIZE" "SPECIAL" "TYPE"))
(CL:DEFPARAMETER CMLSYMBOLS.TYPENAMES
'("ARRAY" "ATOM" "BIGNUM" "BIT" "BIT-VECTOR" "CHARACTER" "COMMON" "COMPILED-FUNCTION" "COMPLEX"
@@ -326,20 +326,19 @@
'("AND" "ASSERT" "CASE" "CCASE" "CHECK-TYPE" "COND" "CTYPECASE" "DECF" "DEFCONSTANT"
"DEFINE-MODIFY-MACRO" "DEFINE-SETF-METHOD" "DEFMACRO" "DEFPARAMETER" "DEFSETF" "DEFSTRUCT"
"DEFTYPE" "DEFUN" "DEFVAR" "DO" "DO*" "DO-ALL-SYMBOLS" "DO-EXTERNAL-SYMBOLS" "DO-SYMBOLS"
"DOLIST" "DOTIMES" "ECASE" "ETYPECASE" "INCF" "LOCALLY" "LOOP" "MULTIPLE-VALUE-BIND"
"MULTIPLE-VALUE-LIST" "MULTIPLE-VALUE-SETQ" "OR" "POP" "PROG" "PROG*" "PROG1" "PROG2"
"PSETF" "PSETQ" "PUSH" "PUSHNEW" "REMF" "RETURN" "ROTATEF" "SETF" "SHIFTF" "STEP" "TIME"
"TRACE" "TYPECASE" "UNLESS" "UNTRACE" "WHEN" "WITH-INPUT-FROM-STRING" "WITH-OPEN-FILE"
"WITH-OPEN-STREAM" "WITH-OUTPUT-TO-STRING"))
"DOLIST" "DOTIMES" "ECASE" "ETYPECASE" "INCF" "LOCALLY" "LOOP" "LOOP-FINISH"
"MULTIPLE-VALUE-BIND" "MULTIPLE-VALUE-LIST" "MULTIPLE-VALUE-SETQ" "OR" "POP" "PROG"
"PROG*" "PROG1" "PROG2" "PSETF" "PSETQ" "PUSH" "PUSHNEW" "REMF" "RETURN" "ROTATEF" "SETF"
"SHIFTF" "STEP" "TIME" "TRACE" "TYPECASE" "UNLESS" "UNTRACE" "WHEN"
"WITH-INPUT-FROM-STRING" "WITH-OPEN-FILE" "WITH-OPEN-STREAM" "WITH-OUTPUT-TO-STRING"))
(CL:DEFPARAMETER CMLSYMBOLS.SPECIALFORMS
'("BLOCK" "CATCH" "COMPILER-LET" "DECLARE" "EVAL-WHEN" "FLET" "FUNCTION" "GO" "IF" "LABELS"
"LAMBDA" "LET" "LET*" "MACROLET" "MULTIPLE-VALUE-CALL" "MULTIPLE-VALUE-PROG1" "PROGN"
"PROGV" "QUOTE" "RETURN-FROM" "SETQ" "TAGBODY" "THE" "THROW" "UNWIND-PROTECT"))
(CL:DEFPARAMETER CMLSYMBOLS.LAMBDA.LIST.KEYWORDS '("&ALLOW-OTHER-KEYS" "&AUX" "&BODY"
"&ENVIRONMENT" "&KEY" "&OPTIONAL"
"&REST" "&WHOLE"))
(CL:DEFPARAMETER CMLSYMBOLS.LAMBDA.LIST.KEYWORDS '("&ALLOW-OTHER-KEYS" "&AUX" "&BODY" "&ENVIRONMENT"
"&KEY" "&OPTIONAL" "&REST" "&WHOLE"))
(CL:DEFPARAMETER CMLSYMBOLS.SHARED
'("+" "-" "/" "<" "<=" "=" ">" ">=" "&ALLOW-OTHER-KEYS" "&AUX" "&BODY" "&ENVIRONMENT" "&KEY"
@@ -361,7 +360,7 @@
"RPLACA" "RPLACD" "SATISFIES" "SEQUENCE" "SET" "STRING" "STRING-EQUAL" "STREAM" "STREAMP"
"T" "TAILP" "THE" "TIME" "TRACE" "TYPE" "TYPEP" "UNTRACE" "WRITE")
(* |;;;| "Symbols shared by the Interlisp and Lisp packages.")
(* |;;;| "Symbols shared by the Interlisp and Lisp packages.")
)
@@ -388,7 +387,7 @@
(CL:DEFUN NAMESTRING-CONVERSION-CLAUSE (BASE OFFSET LEN FATP)
(* |;;;| "Check whether a given namestring has a prefix that would indicate membership in a package. If so, return the first clause out of the conversion table that matched. Otherwise, return NIL.")
(* |;;;| "Check whether a given namestring has a prefix that would indicate membership in a package. If so, return the first clause out of the conversion table that matched. Otherwise, return NIL.")
(DECLARE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE))
(CL:DOLIST (CONVERSION-LIST LITATOM-PACKAGE-CONVERSION-TABLE NIL)
@@ -399,13 +398,13 @@
(COND
((AND (IGREATERP LEN PREFIX-LENGTH)
(\\STRING-EQUALBASE PREFIX BASE OFFSET PREFIX-LENGTH FATP)
(NOT (|for| X |in| EXCEPTIONS
|suchthat| (\\STRING-EQUALBASE X BASE OFFSET LEN FATP))))
(NOT (|for| X |in| EXCEPTIONS |suchthat| (\\STRING-EQUALBASE X BASE OFFSET LEN
FATP))))
(RETURN CONVERSION-LIST))))))
(CL:DEFUN CONVERT-LITATOM (ATOM)
(* |;;| "Conditionally move an INTERLISP litatom into a package based on the naming conventions in LITATOM-PACKAGE-CONVERSION-TABLE.")
(* |;;| "Conditionally move an INTERLISP litatom into a package based on the naming conventions in LITATOM-PACKAGE-CONVERSION-TABLE.")
(LET* ((BASE (|ffetch| (CL:SYMBOL PNAMEBASE) |of| ATOM))
(LEN (|ffetch| (CL:SYMBOL PNAMELENGTH) |of| ATOM))
@@ -417,17 +416,17 @@
(WHERE (CL:FOURTH CLAUSE))
(PREFIX-LENGTH (|ffetch| (STRINGP LENGTH)
PREFIX)))
(\\LITATOM.EATCHARS ATOM PREFIX-LENGTH) (* \; "Take off the pseudo-package prefix. This makes the symbol inaccessible in INTERLISP (because not rehashed).")
(\\LITATOM.EATCHARS ATOM PREFIX-LENGTH) (* \; "Take off the pseudo-package prefix. This makes the symbol inaccessible in INTERLISP (because not rehashed).")
(COND
(CL:PACKAGE-NAME (* \;
 " Symbol is interned, put it in the package.")
(CL:PACKAGE-NAME (* \;
 " Symbol is interned, put it in the package.")
(INTERN-LITATOM ATOM (CL:FIND-PACKAGE CL:PACKAGE-NAME)
:WHERE WHERE)))
T))
(CL:DEFUN CONCOCT-SYMBOL (STRING)
(* |;;| "Create a symbol in the LISP package. Conflicting symbols must already have been converted and defined by CONVERT-LITATOM. Given a string, if a symbol by that name exists in INTERLISP (and doesn't conflict) we INTERN-LITATOM it into the LISP package, making that its home. Otherwise, we create a new one.")
(* |;;| "Create a symbol in the LISP package. Conflicting symbols must already have been converted and defined by CONVERT-LITATOM. Given a string, if a symbol by that name exists in INTERLISP (and doesn't conflict) we INTERN-LITATOM it into the LISP package, making that its home. Otherwise, we create a new one.")
(DECLARE (CL:SPECIAL *LISP-PACKAGE* *INTERLISP-PACKAGE* CMLSYMBOLS.SHARED))
(LET (ILSYM CLSYM)
@@ -437,27 +436,27 @@
(CL:WHEN (EQ WHERE :INTERNAL)
(EXPORT SYM *LISP-PACKAGE*))
(SETQ CLSYM SYM)
WHERE) (* \;
 "The CL symbol already exists. Make it external. If the symbol is shared, import it into IL.")
WHERE) (* \;
 "The CL symbol already exists. Make it external. If the symbol is shared, import it into IL.")
(CL:WHEN (CL:MEMBER STRING CMLSYMBOLS.SHARED :TEST 'STREQUAL)
(IMPORT CLSYM *INTERLISP-PACKAGE*)))
(* |;;| "From this point down, the CL symbol doesn't yet exist.")
(* |;;| "From this point down, the CL symbol doesn't yet exist.")
((CL:MEMBER STRING CMLSYMBOLS.SHARED :TEST 'STREQUAL)
(* \; "The symbol is shared. Create it in CL and import it to IL. NOTE that the symbol should never be found in IL.")
(* \; "The symbol is shared. Create it in CL and import it to IL. NOTE that the symbol should never be found in IL.")
(COND
((CL:FIND-SYMBOL STRING *INTERLISP-PACKAGE*)
(CL:ERROR "Shared symbol found in IL: ~S" STRING)
(* |;;| "(intern-litatom ilsym *lisp-package* :where :external)")
(* |;;| "(intern-litatom ilsym *lisp-package* :where :external)")
)
(T (LET ((SYM (CL:INTERN STRING *LISP-PACKAGE*)))
(EXPORT SYM *LISP-PACKAGE*)
(IMPORT SYM *INTERLISP-PACKAGE*)))))
(T (* \;
 "Symbol doesn't exist, so just create it in LISP.")
(T (* \;
 "Symbol doesn't exist, so just create it in LISP.")
(EXPORT (CL:INTERN STRING *LISP-PACKAGE*)
*LISP-PACKAGE*)))))
@@ -491,8 +490,8 @@
(COND
((|fetch| (LITATOM FATPNAMEP) |of| LITATOM)
(ERROR (CONCAT "Can't move fat LITATOM |" LITATOM "| into LISP package")))
(T (|for| I |from| 0 |to| LEN |as| J |from| N
|do| (\\PUTBASETHIN PNBASE I (\\GETBASETHIN PNBASE J)))))
(T (|for| I |from| 0 |to| LEN |as| J |from| N |do| (\\PUTBASETHIN PNBASE I
(\\GETBASETHIN PNBASE J)))))
(|replace| (PNAMEBASE PNAMELENGTH) |of| PNBASE |with| LEN))
LITATOM)
@@ -507,7 +506,7 @@
(CL:DEFUN PACKAGE-CLEAR ()
"Clear the global package data (used by FIND-PACKAGE) and reset the globals that hold the existing packages."
(DECLARE (CL:SPECIAL *PACKAGE-FROM-NAME* *PACKAGE-FROM-INDEX* *PACKAGE* *LISP-PACKAGE*
*KEYWORD-PACKAGE* *INTERLISP-PACKAGE*))
*KEYWORD-PACKAGE* *INTERLISP-PACKAGE*))
(CLRHASH *PACKAGE-FROM-NAME*)
(CL:DOTIMES (I (ADD1 *TOTAL-PACKAGES-LIMIT*))
(CL:SETF (CL:AREF *PACKAGE-FROM-INDEX* I)
@@ -521,7 +520,7 @@
(CL:DEFUN PACKAGE-MAKE ()
"Create, but do not fill with symbols, the base packages that need to exist. Also enables the package qualifier characters in the readtables and saves the old definitions of \\READ.SYMBOL and \\MKATOM."
(DECLARE (CL:SPECIAL *LISP-PACKAGE* *KEYWORD-PACKAGE* *INTERLISP-PACKAGE* *PACKAGE*
HASHTABLE-SIZE-LIMIT))
HASHTABLE-SIZE-LIMIT))
(SETQ *INTERLISP-PACKAGE* (CL:MAKE-PACKAGE "INTERLISP" :USE NIL :NICKNAMES '("IL")
:PREFIX-NAME "IL" :EXTERNAL-ONLY T :EXTERNAL-SYMBOLS 32749))
(SETQ *LISP-PACKAGE* (CL:MAKE-PACKAGE "LISP" :USE NIL :NICKNAMES '("CL" "COMMON-LISP")
@@ -545,20 +544,20 @@
(CL:DEFUN PACKAGE-HIERARCHY-INIT (&OPTIONAL (CONVERT? NIL))
(* |;;;| "Fill all the initial system packages with their proper symbols, moving litatoms into appropriate places and such. If convert? is non-nil then symbols whose pnames have fake package qualifiers, like cl:length, will be converted IN PLACE to remove the qualifier. If conversion takes place you cannot fully disable the package system.")
(* |;;;| "Fill all the initial system packages with their proper symbols, moving litatoms into appropriate places and such. If convert? is non-nil then symbols whose pnames have fake package qualifiers, like cl:length, will be converted IN PLACE to remove the qualifier. If conversion takes place you cannot fully disable the package system.")
(DECLARE (CL:SPECIAL *INTERLISP-PACKAGE* *KEYWORD-PACKAGE* CMLSYMBOLS.LAMBDA.LIST.KEYWORDS
CMLSYMBOLS.SPECIALFORMS CMLSYMBOLS.MACROS CMLSYMBOLS.TYPENAMES
CMLSYMBOLS.FNNAMES CMLSYMBOLS.DECLARATORS CMLSYMBOLS.VARS))
CMLSYMBOLS.SPECIALFORMS CMLSYMBOLS.MACROS CMLSYMBOLS.TYPENAMES CMLSYMBOLS.FNNAMES
CMLSYMBOLS.DECLARATORS CMLSYMBOLS.VARS))
(* |;;| "Fill the INTERLISP package with its symbols.")
(* |;;| "Fill the INTERLISP package with its symbols.")
(MAPATOMS #'(CL:LAMBDA (ATOM)
(CL:IF (OR (NULL CONVERT?)
(NULL (CONVERT-LITATOM ATOM)))
(INTERN-LITATOM ATOM *INTERLISP-PACKAGE* :WHERE :EXTERNAL))))
(* |;;| "Fill the LISP package with its symbols.")
(* |;;| "Fill the LISP package with its symbols.")
(CL:DOLIST (I (APPEND CMLSYMBOLS.VARS CMLSYMBOLS.FNNAMES CMLSYMBOLS.DECLARATORS
CMLSYMBOLS.TYPENAMES CMLSYMBOLS.MACROS CMLSYMBOLS.SPECIALFORMS
@@ -569,7 +568,7 @@
(CL:DEFUN PACKAGE-ENABLE (&OPTIONAL (PACKAGE *INTERLISP-PACKAGE*))
"Turn on the package system, making PACKAGE the current one and redefining \\READ.SYMBOL and \\MKATOM appropriatly."
(DECLARE (CL:SPECIAL *INTERLISP-PACKAGE* *PACKAGE* *OLD-INTERLISP-READ-ENVIRONMENT*
*PER-EXEC-VARIABLES*))
*PER-EXEC-VARIABLES*))
(|replace| REPACKAGE |of| *OLD-INTERLISP-READ-ENVIRONMENT* |with| *INTERLISP-PACKAGE*)
(|replace| REPACKAGE |of| *DEFINE-FILE-INFO-ENV* |with| *INTERLISP-PACKAGE*)
(COND
@@ -643,16 +642,15 @@
(PACKAGE-INIT)
)
(PUTPROPS PACKAGE-STARTUP COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 2021))
(DECLARE\: DONTCOPY
(FILEMAP (NIL (3123 3218 (RETURN-FIRST-OF-THREE 3123 . 3218)) (3220 3358 (
ERROR-MISSING-EXTERNAL-SYMBOL 3220 . 3358)) (3963 4931 (CHECK-SYMBOL-NAMESTRING 3963 . 4931)) (4933
8094 (\\NEW.READ.SYMBOL 4933 . 8094)) (8096 9802 (\\NEW.MKATOM 8096 . 9802)) (23600 23682 (
LITATOM.EXISTS 23600 . 23682)) (24362 25328 (NAMESTRING-CONVERSION-CLAUSE 24362 . 25328)) (25330 26579
(CONVERT-LITATOM 25330 . 26579)) (26581 28650 (CONCOCT-SYMBOL 26581 . 28650)) (28652 28946 (
TRANSFER-SYMBOL 28652 . 28946)) (28948 29656 (INTERN-LITATOM 28948 . 29656)) (29658 30285 (
\\LITATOM.EATCHARS 29658 . 30285)) (30287 30564 (PACKAGE-INIT 30287 . 30564)) (30566 31143 (
PACKAGE-CLEAR 30566 . 31143)) (31145 32540 (PACKAGE-MAKE 31145 . 32540)) (32542 33863 (
PACKAGE-HIERARCHY-INIT 32542 . 33863)) (33865 35478 (PACKAGE-ENABLE 33865 . 35478)) (35480 36123 (
PACKAGE-DISABLE 35480 . 36123)) (36170 36196 (ID 36170 . 36196)))))
(FILEMAP (NIL (3015 3110 (RETURN-FIRST-OF-THREE 3015 . 3110)) (3112 3250 (
ERROR-MISSING-EXTERNAL-SYMBOL 3112 . 3250)) (3857 4825 (CHECK-SYMBOL-NAMESTRING 3857 . 4825)) (4827
7985 (\\NEW.READ.SYMBOL 4827 . 7985)) (7987 9697 (\\NEW.MKATOM 7987 . 9697)) (23437 23519 (
LITATOM.EXISTS 23437 . 23519)) (24199 25205 (NAMESTRING-CONVERSION-CLAUSE 24199 . 25205)) (25207 26462
(CONVERT-LITATOM 25207 . 26462)) (26464 28537 (CONCOCT-SYMBOL 26464 . 28537)) (28539 28833 (
TRANSFER-SYMBOL 28539 . 28833)) (28835 29543 (INTERN-LITATOM 28835 . 29543)) (29545 30224 (
\\LITATOM.EATCHARS 29545 . 30224)) (30226 30503 (PACKAGE-INIT 30226 . 30503)) (30505 31078 (
PACKAGE-CLEAR 30505 . 31078)) (31080 32471 (PACKAGE-MAKE 31080 . 32471)) (32473 33785 (
PACKAGE-HIERARCHY-INIT 32473 . 33785)) (33787 35396 (PACKAGE-ENABLE 33787 . 35396)) (35398 36041 (
PACKAGE-DISABLE 35398 . 36041)) (36088 36114 (ID 36088 . 36114)))))
STOP

BIN
sources/PACKAGE-STARTUP.LCOM
View File

Binary file not shown.

1465
sources/XCL-LOOP Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
sources/XCL-LOOP.DFASL Normal file
View File

Binary file not shown.