(FILECREATED "27-Feb-86 18:29:23" {ERIS}<LISPCORE>CML>LAB>CMLPACKAGES.;48 106354
changes to: (FNS READSYMBOL NEWMKATOM \NEWLITPRIN RENAME-PACKAGE INTERN FIND-SYMBOL
FIND-PACKAGE UNINTERN EXPORT UNEXPORT IMPORT SHADOWING-IMPORT SHADOW
PACKAGE-LISTIFY USE-PACKAGE UNUSE-PACKAGE \NEWMKATOM PACKAGE-INIT)
(PROPS (ALLOC-SYMBOL CL:PRIMITIVE)
(; HASHREADMACRO))
(VARS CMLPACKAGESCOMS)
(MACROS DO-SYMBOLS DO-EXTERNAL-SYMBOLS \SIMPLE-STRINGIFY \PACKAGIFY)
previous date: "25-Feb-86 15:41:24" {ERIS}<LISPCORE>CML>LAB>CMLPACKAGES.;43)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLPACKAGESCOMS)
(RPAQQ CMLPACKAGESCOMS
[(* * - " Original code based on CMU's Spice Lisp." -
" Re-Written by Rob MacLachlan. Earlier version written by" -
" Lee Schumacher. Apropos & iteration macros courtesy of Skef Wholey." -
" Modifications for Xerox Common Lisp by Ron Fischer.")
(RECORDS PACKAGE)
(FNS PRINT-PACKAGE)
(INITVARS (*PACKAGE* NIL))
(* * " An equal hashtable from package names to packages." -)
[INITVARS (*PACKAGE-NAMES* (MAKE-HASH-TABLE :TEST (FUNCTION EQUAL]
(* * " Lots of people want the keyword package and Lisp package without a lot" -
" of fuss, so we give them their own variables." -)
(INITVARS (*LISP-PACKAGE* NIL)
(*KEYWORD-PACKAGE* NIL))
(* * " Find-Package -- Public")
(FNS FIND-PACKAGE PARSE-BODY)
(* * " Package-Hashtables" - -
" Packages are implemented using a special kind of hashtable. It is" -
" an open hashtable with a parallel 8-bit I-vector of hash-codes. The" -
" primary purpose of the hash for each entry is to reduce paging by" -
" allowing collisions and misses to be detected without paging in the" -
" symbol and pname for an entry. If the hash for an entry doesn't" -
" match that for the symbol that we are looking for, then we can" -
" go on without touching the symbol, pname, or even hastable vector." -
" It turns out that, contrary to my expectations, paging is a very" -
" important consideration the design of the package representation." -
" Using a similar scheme without the entry hash, the fasloader was" -
" spending more than half its time paging in INTERN." -
" The hash code also indicates the status of an entry. If it zero," -
" the the entry is unused. If it is one, then it is deleted." -
" Double-hashing is used for collision resolution.")
(RECORDS PACKAGE-HASHTABLE)
(* * " The number of deleted entries." -
" The maximum density we allow in a package hashtable.")
(VARS (PACKAGE-REHASH-THRESHOLD .5))
(* * " Entry-Hash -- Internal" - -
" Compute a number from the sxhash of the pname and the length which" -
" must be between 2 and 255.")
(MACROS ENTRY-HASH \PACKAGIFY \SIMPLE-STRINGIFY)
(* * " Make-Package-Hashtable -- Internal" - -
" Make a package hashtable having a prime number of entries at least" -
" as great as (/ size package-rehash-threshold). If Res is supplied," -
" then it is destructively modified to produce the result. This is" -
" useful when changing the size, since there are many pointers to" - " the hashtable.")
(FNS MAKE-PACKAGE-HASHTABLE)
(* * " Internal-Symbol-Count, External-Symbols-Count -- Internal" - -
" Return internal and external symbols.")
(MACROS COUNT-PACKAGE-HASHTABLE)
(FNS INTERNAL-SYMBOL-COUNT EXTERNAL-SYMBOL-COUNT)
(* * " Add-Symbol -- Internal" - -
" Add a symbol to a package hashtable. The symbol is assumed" - " not to be present.")
(FNS ADD-SYMBOL)
(* * " With-Symbol -- Internal" - -
" Find where the symbol named String is stored in Table. Index-Var" -
" is bound to the index, or NIL if it is not present. Symbol-Var" -
" is bound to the symbol. Length and Hash are the length and sxhash" -
" of String. Entry-Hash is the entry-hash of the string and length.")
(MACROS WITH-SYMBOL)
(* * " Nuke-Symbol -- Internal" - -
" Delete the entry for String in Table. The entry must exist.")
(FNS NUKE-SYMBOL)
(* * " Iteration macros." -
" Instead of using slow, silly successor functions, we make the iteration" -
" guys be big PROG's. Yea!")
(DECLARE: EVAL@COMPILE DONTCOPY (*)
(MACROS DO-SYMBOLS DO-EXTERNAL-SYMBOLS DO-ALL-SYMBOLS))
(FNS MAKE-DO-SYMBOLS-VARS MAKE-DO-SYMBOLS-CODE)
(* * " Enter-New-Nicknames -- Internal" - -
" Enter any new Nicknames for Package into *package-names*." -
" If there is a conflict then give the user a chance to do" - " something about it.")
(FNS ENTER-NEW-NICKNAMES)
(* * " Make-Package -- Public" - -
" Check for package name conflicts in name and nicknames, then" -
" make the package. Do a use-package for each thing in the use list" -
" so that checking for conflicting exports among used packages is done.")
(FNS MAKE-PACKAGE)
(* * " In-Package -- Public" - - " Like Make-Package, only different.")
(FNS IN-PACKAGE)
(* * " Rename-Package -- Public" - -
" Change the name if we can, blast any old nicknames and then" -
" add in any new ones.")
(FNS RENAME-PACKAGE)
(* * " List-All-Packages -- Public")
(FNS LIST-ALL-PACKAGES)
(* * " Intern -- Public" - - " Simple-stringify the name and call intern*.")
(FNS INTERN)
(* * " Find-Symbol -- Public" - - " Ditto.")
(FNS FIND-SYMBOL)
(* * " Intern* -- Internal" - -
" If the symbol doesn't exist then create it, special-casing" - " the keyword package."
)
(FNS INTERN*)
(* * " Find-Symbol* -- Internal" - -
" Check internal and external symbols, then scan down the list" -
" of hashtables for inherited symbols. When an inherited symbol" -
" is found pull that table to the beginning of the list.")
(FNS FIND-SYMBOL*)
(* * " Find-External-Symbol -- Internal" - -
" Similar to Find-Symbol, but only looks for an external symbol." -
" This is used for fast name-conflict checking.")
(FNS FIND-EXTERNAL-SYMBOL)
(* * " Unintern -- Public" - -
" If we are uninterning a shadowing symbol, then a name conflict can" -
" result, otherwise just nuke the symbol.")
(FNS UNINTERN)
(* * " Symbol-Listify -- Internal" - -
" Take a symbol-or-list-of-symbols and return a list, checking types.")
(FNS SYMBOL-LISTIFY)
(* * " Moby-Unintern -- Internal" - -
" Like Unintern, but if symbol is inherited chases down the" -
" package it is inherited from and uninterns it there. Used" -
" for name-conflict resolution. Shadowing symbols are not" -
" uninterned since they do not cause conflicts.")
(FNS MOBY-UNINTERN)
(* * " Export -- Public")
(FNS EXPORT)
(* * " Unexport -- Public" - -
" Check that all symbols are available, then move from external to" - " internal.")
(FNS UNEXPORT)
(* * " Import -- Public")
(FNS IMPORT)
(* * " Shadowing-Import -- Public" - -
" If a conflicting symbol is present, unintern it, otherwise just" -
" stick the symbol in.")
(FNS SHADOWING-IMPORT)
(* * " Shadow -- Public")
(FNS SHADOW)
(* * " Package-Listify -- Internal" - -
" Return a list of packages given a package-or-string-or-symbol or" -
" list thereof, or die trying.")
(FNS PACKAGE-LISTIFY)
(* * " Use-Package -- Public" - -
" Do stuff to use a package, with all kinds of fun name-conflict" - " checking.")
(FNS USE-PACKAGE)
(* * " Unuse-Package -- Public")
(FNS UNUSE-PACKAGE)
(* * " Find-All-Symbols -- Public")
(FNS FIND-ALL-SYMBOLS)
(* * " Apropos and Apropos-List.")
(FNS BRIEFLY-DESCRIBE-SYMBOL APROPOS-SEARCH CL:APROPOS APROPOS-LIST)
(* * While edits to the code above have changed it from the original Spice source the
majority of low level support occurs below here.)
(* * The first draft of packages for Interlisp-D is implemented by using a free byte in the
litatom structure (defined in the copied and altered definition now called SYMBOL)
%. A vector (\PKG-INDEX-TO-PACKAGE-VECTOR)
is used to relate these numbers to packages, and the packages themselves contain their
INDEX in the vector.)
(DECLARE: EVAL@COMPILE DONTCOPY (*)
(EXPORT (RECORDS SYMBOL)
(CONSTANTS MAX-NUMBER-PACKAGES \INTERLISP-PACKAGE-INDEX
\UNINTERNED-PACKAGE-INDEX))
(* Note that you can't change the \INTERLISP-PACKAGE-INDEX unless you initialize all
atom package cells to the new number at package enable time)
(* If you move \UNINTERNED-PACKAGE-INDEX you'll want to change the arrangements in
\PKG-FIND-FREE-PACKAGE-INDEX))
(INITVARS (\PKG-INDEX-TO-PACKAGE-VECTOR (MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)))
(* PACKAGE-INIT depends on the free marker being NIL)
(FNS \PKG-FIND-FREE-PACKAGE-INDEX)
(* \PKG-FIND-FREE-PACKAGE-INDEX and \UNINTERNED-PACKAGE-INDEX are all neatly arranged so that
SYMBOL-PACKAGE can find NIL in the index vector and NIL can also be the free slot marker)
(MACROS SETF-SYMBOL-PACKAGE SYMBOL-PACKAGE)
(FNS SETF-SYMBOL-PACKAGE SYMBOL-PACKAGE)
(DECLARE: EVAL@LOAD DONTCOPY (*)
(FILES (SOURCE PROP)
LLBASIC APRINT))
(FNS NEWMKATOM \NEWMKATOM \NEWMKATOM.NEW \NEWLITPRIN)
(* * " Initialization.")
(VARS (*INTERLISP-PACKAGE* NIL)
(OLDMKATOM NIL)
(\OLDMKATOM NIL)
(\OLDMKATOM.NEW NIL)
(\OLDLITPRIN NIL))
(FNS PACKAGE-INIT PACKAGE-CLEAR ENABLE-PACKAGES DISABLE-PACKAGES)
(* * "Spice compatability stuff")
(FNS PRIMEP)
(MACROS PRIMITIVE)
(PROP CL:PRIMITIVE ALLOC-SYMBOL SET-PACKAGE SXHASH-SIMPLE-STRING SXHASH-SIMPLE-SUBSTRING)
(P (MOVD (QUOTE REMAINDER)
(QUOTE REM))
(MOVD (QUOTE ERROR)
(QUOTE CERROR))
(MOVD (QUOTE *)
(QUOTE CL:DECLARE)))
(* * "Vertical bar semicolon reader macro for package qualified litatom syntax.")
(INITVARS (\PKG.SYMBOL.STRING (MAKE-STRING 256))
(\PKG.PACKAGE.STRING (MAKE-STRING 256)))
(PROP HASHREADMACRO ;)
(FNS READSYMBOL)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA UNUSE-PACKAGE USE-PACKAGE SHADOW SHADOWING-IMPORT IMPORT UNEXPORT EXPORT
UNINTERN FIND-SYMBOL INTERN RENAME-PACKAGE APROPOS-LIST CL:APROPOS
IN-PACKAGE MAKE-PACKAGE MAKE-PACKAGE-HASHTABLE])
(* * - " Original code based on CMU's Spice Lisp." -
" Re-Written by Rob MacLachlan. Earlier version written by" -
" Lee Schumacher. Apropos & iteration macros courtesy of Skef Wholey." -
" Modifications for Xerox Common Lisp by Ron Fischer.")
[DECLARE: EVAL@COMPILE
(DEFSTRUCT (PACKAGE (:CONSTRUCTOR INTERNAL-MAKE-PACKAGE)
(:PREDICATE PACKAGEP)
(:PRINT-FUNCTION PRINT-PACKAGE))
INDEX (*
"Package to index hack.")
(TABLES (LIST NIL)) (*
" A list of all the hashtables for inherited symbols.")
NAME (*
" The string name of the package.")
NICKNAMES (*
" List of nickname strings.")
(USE-LIST NIL) (*
" List of packages we use.")
(USED-BY-LIST NIL) (*
" List of packages that use this package.")
INTERNAL-SYMBOLS (*
" Hashtable of internal symbols.")
EXTERNAL-SYMBOLS (*
" Hashtable of external symbols.")
(SHADOWING-SYMBOLS NIL) (*
" List of shadowing symbols.")
)
]
(/DECLAREDATATYPE (QUOTE PACKAGE)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER))
(QUOTE ((PACKAGE 0 POINTER)
(PACKAGE 2 POINTER)
(PACKAGE 4 POINTER)
(PACKAGE 6 POINTER)
(PACKAGE 8 POINTER)
(PACKAGE 10 POINTER)
(PACKAGE 12 POINTER)
(PACKAGE 14 POINTER)
(PACKAGE 16 POINTER)))
(QUOTE 18))
(DEFINEQ
(PRINT-PACKAGE
[CL:LAMBDA (S STREAM D)
(MULTIPLE-VALUE-BIND (IU IT)
(INTERNAL-SYMBOL-COUNT S)
(MULTIPLE-VALUE-BIND (EU ET)
(EXTERNAL-SYMBOL-COUNT S)
(PRINTOUT STREAM "#<The " (PACKAGE-NAME S)
" package, " IU "/" IT " internal, " EU "/" ET " external>"])
)
(RPAQ? *PACKAGE* NIL)
(* * " An equal hashtable from package names to packages." -)
(RPAQ? *PACKAGE-NAMES* (MAKE-HASH-TABLE :TEST (FUNCTION EQUAL)))
(* * " Lots of people want the keyword package and Lisp package without a lot" -
" of fuss, so we give them their own variables." -)
(RPAQ? *LISP-PACKAGE* NIL)
(RPAQ? *KEYWORD-PACKAGE* NIL)
(* * " Find-Package -- Public")
(DEFINEQ
(FIND-PACKAGE
(CL:LAMBDA (NAME) (* raf
"20-Feb-86 17:40")
(GETHASH (STRING NAME)
*PACKAGE-NAMES* NIL)))
(PARSE-BODY
[CL:LAMBDA (BODY) (* raf
"31-Jan-86 17:38")
(CL:DO ((B BODY (CDR B))
(DECLS NIL)
(DOC NIL)
(TEMP NIL))
((NULL B)
(LIST (CL:NREVERSE DECLS)
DOC NIL))
(COND
((AND (STRINGP (CAR B))
(CDR B)
(NULL DOC))
(CL:SETQ DOC (CAR B)))
((NOT (CL:LISTP (CAR B)))
(RETURN (LIST (CL:NREVERSE DECLS)
DOC B)))
((EQ (CAAR B)
(QUOTE CL:DECLARE))
(CL:PUSH (CAR B)
DECLS))
((AND (SYMBOLP (CAAR B))
(MACRO-FUNCTION (CAAR B))
[CL:LISTP (CL:SETQ TEMP (MACROEXPAND-1 (CAR B]
(EQ (CAR TEMP)
(QUOTE CL:DECLARE)))
(CL:PUSH (CAR B)
DECLS))
(T (RETURN (LIST (CL:NREVERSE DECLS)
DOC B])
)
(* * " Package-Hashtables" - -
" Packages are implemented using a special kind of hashtable. It is" -
" an open hashtable with a parallel 8-bit I-vector of hash-codes. The" -
" primary purpose of the hash for each entry is to reduce paging by" -
" allowing collisions and misses to be detected without paging in the" -
" symbol and pname for an entry. If the hash for an entry doesn't" -
" match that for the symbol that we are looking for, then we can" -
" go on without touching the symbol, pname, or even hastable vector." -
" It turns out that, contrary to my expectations, paging is a very" -
" important consideration the design of the package representation." -
" Using a similar scheme without the entry hash, the fasloader was" -
" spending more than half its time paging in INTERN." -
" The hash code also indicates the status of an entry. If it zero," -
" the the entry is unused. If it is one, then it is deleted." -
" Double-hashing is used for collision resolution.")
[DECLARE: EVAL@COMPILE
(DEFSTRUCT [PACKAGE-HASHTABLE (:CONSTRUCTOR INTERNAL-MAKE-PACKAGE-HASHTABLE)
(:COPIER NIL)
(:PREDICATE NIL)
(:PRINT-FUNCTION (LAMBDA (TABLE STREAM D)
(PRIN3 "#<Package-Hashtable: Size = " STREAM)
(PRIN1 (PACKAGE-HASHTABLE-SIZE TABLE)
STREAM)
(PRIN3 ", Free = " STREAM)
(PRIN1 (PACKAGE-HASHTABLE-FREE TABLE)
STREAM)
(PRIN3 ", Deleted = " STREAM)
(PRIN1 (PACKAGE-HASHTABLE-DELETED TABLE)
STREAM)
(PRIN3 ">" STREAM]
TABLE (*
" The g-vector of symbols.")
HASH (*
" The i-vector of pname hash values.")
SIZE (*
" The maximum number of entries allowed.")
FREE (*
" The entries that can be made before we have to rehash.")
DELETED)
]
(/DECLAREDATATYPE (QUOTE PACKAGE-HASHTABLE)
(QUOTE (POINTER POINTER POINTER POINTER POINTER))
(QUOTE ((PACKAGE-HASHTABLE 0 POINTER)
(PACKAGE-HASHTABLE 2 POINTER)
(PACKAGE-HASHTABLE 4 POINTER)
(PACKAGE-HASHTABLE 6 POINTER)
(PACKAGE-HASHTABLE 8 POINTER)))
(QUOTE 10))
(* * " The number of deleted entries." -
" The maximum density we allow in a package hashtable.")
(RPAQQ PACKAGE-REHASH-THRESHOLD .5)
(* * " Entry-Hash -- Internal" - -
" Compute a number from the sxhash of the pname and the length which" -
" must be between 2 and 255.")
(DECLARE: EVAL@COMPILE
(DEFMACRO ENTRY-HASH (CL:LENGTH SXHASH)
(BQUOTE (+ (REM (LOGXOR (\, CL:LENGTH)
(\, SXHASH)
(ASH (\, SXHASH)
-8)
(ASH (\, SXHASH)
-16)
(ASH (\, SXHASH)
-19))
254)
2)))
[DEFMACRO \PACKAGIFY (OBJ)
(BQUOTE (TYPECASE (\, OBJ)
(PACKAGE (\, OBJ))
(SIMPLE-STRING (FIND-PACKAGE (\, OBJ)))
[SYMBOL (FIND-PACKAGE (SYMBOL-NAME (\, OBJ]
(OTHERWISE (ERROR "Not a package, string or symbol: " (\, OBJ]
[DEFMACRO \SIMPLE-STRINGIFY (OBJ)
(BQUOTE (CL:IF (SIMPLE-STRING-P (\, OBJ))
(\, OBJ)
(COERCE (\, OBJ)
(QUOTE SIMPLE-STRING]
)
(* * " Make-Package-Hashtable -- Internal" - -
" Make a package hashtable having a prime number of entries at least" -
" as great as (/ size package-rehash-threshold). If Res is supplied," -
" then it is destructively modified to produce the result. This is" -
" useful when changing the size, since there are many pointers to" - " the hashtable.")
(DEFINEQ
(MAKE-PACKAGE-HASHTABLE
[CL:LAMBDA (SIZE &OPTIONAL (RES (INTERNAL-MAKE-PACKAGE-HASHTABLE))) (* raf
" 7-Feb-86 15:46")
(CL:DO ((N (LOGIOR (FIX (FQUOTIENT SIZE PACKAGE-REHASH-THRESHOLD))
1)
(+ N 2)))
((PRIMEP N)
(SETF (PACKAGE-HASHTABLE-TABLE RES)
(MAKE-ARRAY N))
(SETF (PACKAGE-HASHTABLE-HASH RES)
(MAKE-ARRAY N :ELEMENT-TYPE (QUOTE (UNSIGNED-BYTE 8))
:INITIAL-ELEMENT 0))
(LET [(SIZE (FIX (CL:* N PACKAGE-REHASH-THRESHOLD]
(SETF (PACKAGE-HASHTABLE-SIZE RES)
SIZE)
(SETF (PACKAGE-HASHTABLE-FREE RES)
SIZE))
(SETF (PACKAGE-HASHTABLE-DELETED RES)
0)
RES)
(CL:DECLARE (FIXNUM N])
)
(* * " Internal-Symbol-Count, External-Symbols-Count -- Internal" - -
" Return internal and external symbols.")
(DECLARE: EVAL@COMPILE
[DEFMACRO COUNT-PACKAGE-HASHTABLE (TABLE)
(BQUOTE (LET [(SIZE (- (PACKAGE-HASHTABLE-SIZE (\, TABLE))
(PACKAGE-HASHTABLE-DELETED (\, TABLE]
(VALUES (- SIZE (PACKAGE-HASHTABLE-FREE (\, TABLE)))
SIZE]
)
(DEFINEQ
(INTERNAL-SYMBOL-COUNT
(CL:LAMBDA (PACKAGE)
(COUNT-PACKAGE-HASHTABLE (PACKAGE-INTERNAL-SYMBOLS PACKAGE))))
(EXTERNAL-SYMBOL-COUNT
(CL:LAMBDA (PACKAGE)
(COUNT-PACKAGE-HASHTABLE (PACKAGE-EXTERNAL-SYMBOLS PACKAGE))))
)
(* * " Add-Symbol -- Internal" - -
" Add a symbol to a package hashtable. The symbol is assumed" - " not to be present.")
(DEFINEQ
(ADD-SYMBOL
[CL:LAMBDA (TABLE SYMBOL) (* raf
" 5-Feb-86 13:58")
(LET* [(VEC (PACKAGE-HASHTABLE-TABLE TABLE))
(HASH (PACKAGE-HASHTABLE-HASH TABLE))
(LEN (CL:LENGTH VEC))
(SXHASH (PRIMITIVE SXHASH-SIMPLE-STRING (SYMBOL-NAME SYMBOL)))
(H2 (1+ (REM SXHASH (- LEN 2]
(CL:DECLARE (SIMPLE-VECTOR VEC)
(TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 8))
HASH))
(COND
[(ZEROP (PACKAGE-HASHTABLE-FREE TABLE))
(MAKE-PACKAGE-HASHTABLE (CL:* (PACKAGE-HASHTABLE-SIZE TABLE)
2)
TABLE)
(ADD-SYMBOL TABLE SYMBOL)
(DOTIMES (I LEN)
(CL:WHEN (> (AREF HASH I)
1)
(ADD-SYMBOL TABLE (SVREF VEC I]
(T (CL:DO ((I (REM SXHASH LEN)
(REM (+ I H2)
LEN)))
((< (AREF HASH I)
2)
(CL:IF (ZEROP (AREF HASH I))
(DECF (PACKAGE-HASHTABLE-FREE TABLE))
(DECF (PACKAGE-HASHTABLE-DELETED TABLE)))
(SETF (SVREF VEC I)
SYMBOL)
(SETF (AREF HASH I)
(ENTRY-HASH (CL:LENGTH (SYMBOL-NAME SYMBOL))
SXHASH])
)
(* * " With-Symbol -- Internal" - -
" Find where the symbol named String is stored in Table. Index-Var" -
" is bound to the index, or NIL if it is not present. Symbol-Var" -
" is bound to the symbol. Length and Hash are the length and sxhash" -
" of String. Entry-Hash is the entry-hash of the string and length.")
(DECLARE: EVAL@COMPILE
[DEFMACRO WITH-SYMBOL ((INDEX-VAR SYMBOL-VAR TABLE STRING CL:LENGTH SXHASH ENTRY-HASH)
&BODY FORMS)
(LET ((VEC (GENSYM))
(HASH (GENSYM))
(LEN (GENSYM))
(H2 (GENSYM))
(NAME (GENSYM))
(NAME-LEN (GENSYM))
(EHASH (GENSYM)))
(BQUOTE (LET* [((\, VEC)
(PACKAGE-HASHTABLE-TABLE (\, TABLE)))
((\, HASH)
(PACKAGE-HASHTABLE-HASH (\, TABLE)))
((\, LEN)
(CL:LENGTH (\, VEC)))
((\, H2)
(1+ (REM (\, SXHASH)
(- (\, LEN)
2]
(CL:DECLARE (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 8))
(\, HASH))
(SIMPLE-VECTOR (\, VEC)))
(PROG (((\, INDEX-VAR)
(REM (\, SXHASH)
(\, LEN)))
(\, SYMBOL-VAR)
(\, EHASH))
LOOP
(SETQ (\, EHASH)
(AREF (\, HASH)
(\, INDEX-VAR)))
(COND [(EQL (\, EHASH)
(\, ENTRY-HASH))
(SETQ (\, SYMBOL-VAR)
(SVREF (\, VEC)
(\, INDEX-VAR)))
(LET* [((\, NAME)
(SYMBOL-NAME (\, SYMBOL-VAR)))
((\, NAME-LEN)
(CL:LENGTH (\, NAME]
(CL:DECLARE (SIMPLE-STRING (\, NAME)))
(CL:WHEN (AND (= (\, NAME-LEN)
(\, CL:LENGTH))
(STRING= (\, STRING)
(\, NAME)
:END1
(\, CL:LENGTH)
:END2
(\, NAME-LEN)))
(GO DOIT]
((ZEROP (\, EHASH))
(SETQ (\, INDEX-VAR)
NIL)
(GO DOIT)))
(SETQ (\, INDEX-VAR)
(REM (+ (\, INDEX-VAR)
(\, H2))
(\, LEN)))
(GO LOOP)
DOIT
(RETURN (PROGN (\,@ FORMS]
)
(* * " Nuke-Symbol -- Internal" - -
" Delete the entry for String in Table. The entry must exist.")
(DEFINEQ
(NUKE-SYMBOL
[CL:LAMBDA (TABLE STRING)
(CL:DECLARE (SIMPLE-STRING STRING))
(LET* ((CL:LENGTH (CL:LENGTH STRING))
(HASH (PRIMITIVE SXHASH-SIMPLE-STRING STRING))
(EHASH (ENTRY-HASH CL:LENGTH HASH)))
(WITH-SYMBOL (INDEX SYMBOL TABLE STRING CL:LENGTH HASH EHASH)
(SETF (AREF (PACKAGE-HASHTABLE-HASH TABLE)
INDEX)
1)
(INCF (PACKAGE-HASHTABLE-DELETED TABLE])
)
(* * " Iteration macros." -
" Instead of using slow, silly successor functions, we make the iteration" -
" guys be big PROG's. Yea!")
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
[DEFMACRO DO-SYMBOLS ((VAR &OPTIONAL (PACKAGE (QUOTE *PACKAGE*))
RESULT-FORM)
&REST FORMS)
"Do-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}*
Executes the Forms at least once for each symbol accessible in the given
Package with Var bound to the current symbol."
(LET* ((DONE-INTERNAL (GENSYM))
(DONE-EXTERNAL (GENSYM))
(NEXT-INHERIT (GENSYM))
(VARS (MAKE-DO-SYMBOLS-VARS))
(STUFF (PARSE-BODY FORMS))
(CODE (THIRD STUFF))
(N-PACKAGE (GENSYM))
(SHADOWED (GENSYM))
(INHERITS (GENSYM))
(THIS-INHERIT (GENSYM)))
(BQUOTE (PROG* (((\, N-PACKAGE)
(\, PACKAGE))
((\, SHADOWED)
(PACKAGE-SHADOWING-SYMBOLS (\, N-PACKAGE)))
[(\, INHERITS)
(CDR (PACKAGE-TABLES (\, N-PACKAGE]
(\, VAR)
(\,@ VARS)
(\, THIS-INHERIT))
(\,@ (CL:FIRST STUFF))
(\,@ (MAKE-DO-SYMBOLS-CODE VARS VAR (BQUOTE (PACKAGE-INTERNAL-SYMBOLS
(\, PACKAGE)))
(BQUOTE (GO (\, DONE-INTERNAL)))
CODE))
(\, DONE-INTERNAL)
(\,@ (MAKE-DO-SYMBOLS-CODE VARS VAR (BQUOTE (PACKAGE-EXTERNAL-SYMBOLS
(\, PACKAGE)))
(BQUOTE (GO (\, DONE-EXTERNAL)))
CODE))
(\, DONE-EXTERNAL)
(\, NEXT-INHERIT)
(CL:WHEN (NULL (\, INHERITS))
(SETQ (\, VAR)
NIL)
(RETURN (\, RESULT-FORM)))
(SETQ (\, THIS-INHERIT)
(CAR (\, INHERITS)))
(\,@ (MAKE-DO-SYMBOLS-CODE
VARS VAR THIS-INHERIT [BQUOTE (PROGN (SETQ (\, INHERITS)
(CDR (\, INHERITS)))
(GO (\, NEXT-INHERIT]
(BQUOTE ((CL:WHEN (OR (NOT (\, SHADOWED))
(EQ (FIND-SYMBOL (SYMBOL-NAME (\, VAR))
(\, N-PACKAGE))
(\, VAR)))
(\,@ CODE]
[DEFMACRO DO-EXTERNAL-SYMBOLS ((VAR &OPTIONAL (PACKAGE (QUOTE *PACKAGE*))
RESULT-FORM)
&REST FORMS)
"Do-External-Symbols (Var [Package [Result-Form]])
{Declaration}* {Tag | Statement}*
Executes the Forms once for each external symbol in the given Package with
Var bound to the current symbol."
(LET ((VARS (MAKE-DO-SYMBOLS-VARS))
(STUFF (PARSE-BODY FORMS)))
(BQUOTE (PROG ((\, VAR)
(\,@ VARS))
(\,@ (CL:FIRST STUFF))
(\,@ (MAKE-DO-SYMBOLS-CODE VARS VAR (BQUOTE (PACKAGE-EXTERNAL-SYMBOLS
(\, PACKAGE)))
[BQUOTE (RETURN (PROGN (SETQ (\, VAR)
NIL)
(\, RESULT-FORM]
(THIRD STUFF]
[DEFMACRO DO-ALL-SYMBOLS ((VAR &OPTIONAL RESULT-FORM)
&REST FORMS)
"Do-All-Symbols (Var [Package [Result-Form]])
{Declaration}* {Tag | Statement}*
Executes the Forms once for each symbol in each package with Var bound
to the current symbol."
(LET* ((PACKAGE-LOOP (GENSYM))
(TAG (GENSYM))
(PACKAGE-LIST (GENSYM))
(VARS (MAKE-DO-SYMBOLS-VARS))
(STUFF (PARSE-BODY FORMS))
(CODE (THIRD STUFF))
(INTERNAL-CODE (MAKE-DO-SYMBOLS-CODE VARS VAR [BQUOTE (PACKAGE-INTERNAL-SYMBOLS
(CAR (\, PACKAGE-LIST]
(BQUOTE (GO (\, TAG)))
CODE))
(EXTERNAL-CODE (MAKE-DO-SYMBOLS-CODE VARS VAR [BQUOTE (PACKAGE-EXTERNAL-SYMBOLS
(CAR (\, PACKAGE-LIST]
[BQUOTE (PROGN (SETQ (\, PACKAGE-LIST)
(CDR (\, PACKAGE-LIST)))
(GO (\, PACKAGE-LOOP]
CODE)))
(BQUOTE (PROG ((\, PACKAGE-LIST)
(\, VAR)
(\,@ VARS))
(\,@ (CL:FIRST STUFF))
(SETQ (\, PACKAGE-LIST)
(LIST-ALL-PACKAGES))
(\, PACKAGE-LOOP)
(CL:WHEN (NULL (\, PACKAGE-LIST))
(SETQ (\, VAR)
NIL)
(RETURN (\, RESULT-FORM)))
(\,@ INTERNAL-CODE)
(\, TAG)
(\,@ EXTERNAL-CODE]
)
)
(DEFINEQ
(MAKE-DO-SYMBOLS-VARS
[CL:LAMBDA NIL (* raf
"31-Jan-86 18:24")
(BQUOTE ((\, (GENSYM))
(\, (GENSYM))
(\, (GENSYM))
(\, (GENSYM])
(MAKE-DO-SYMBOLS-CODE
[CL:LAMBDA (VARS VAR HASH-TABLE EXIT-FORM FORMS)
(LET ((INDEX (CL:FIRST VARS))
(HASH-VECTOR (SECOND VARS))
(HASH (THIRD VARS))
(TERMINUS (FOURTH VARS))
(TOP (GENSYM)))
(BQUOTE ((SETQ (\, INDEX)
0)
(SETQ (\, HASH-VECTOR)
(PACKAGE-HASHTABLE-TABLE (\, HASH-TABLE)))
(SETQ (\, HASH)
(PACKAGE-HASHTABLE-HASH (\, HASH-TABLE)))
[SETQ (\, TERMINUS)
(CL:LENGTH (THE SIMPLE-VECTOR (\, HASH-VECTOR]
(\, TOP)
(CL:IF (= (\, INDEX)
(\, TERMINUS))
(\, EXIT-FORM))
(CL:WHEN (> (AREF (THE (SIMPLE-ARRAY (UNSIGNED-BYTE 8))
(\, HASH))
(\, INDEX))
1)
(SETQ (\, VAR)
(SVREF (\, HASH-VECTOR)
(\, INDEX)))
(\,@ FORMS))
(INCF (\, INDEX))
(GO (\, TOP])
)
(* * " Enter-New-Nicknames -- Internal" - -
" Enter any new Nicknames for Package into *package-names*." -
" If there is a conflict then give the user a chance to do" - " something about it.")
(DEFINEQ
(ENTER-NEW-NICKNAMES
[CL:LAMBDA (PACKAGE NICKNAMES) (* raf
" 5-Feb-86 17:43")
(CHECK-TYPE NICKNAMES LIST)
(DOLIST (N NICKNAMES)
(LET* ((N (STRING N))
(FOUND (GETHASH N *PACKAGE-NAMES*)))
(COND
((NOT FOUND)
(SETF (GETHASH N *PACKAGE-NAMES*)
PACKAGE)
(CL:PUSH N (PACKAGE-NICKNAMES PACKAGE)))
((EQ FOUND PACKAGE))
[(STRING= (PACKAGE-NAME FOUND)
N)
(CERROR "Ignore this nickname."
"~S is a package name, so it cannot be a nickname for ~S."
(LIST N (PACKAGE-NAME PACKAGE]
(T (CERROR "Redefine this nickname." "~S is already a nickname for ~S."
(LIST N (PACKAGE-NAME FOUND)))
(SETF (GETHASH N *PACKAGE-NAMES*)
PACKAGE)
(CL:PUSH N (PACKAGE-NICKNAMES PACKAGE])
)
(* * " Make-Package -- Public" - -
" Check for package name conflicts in name and nicknames, then" -
" make the package. Do a use-package for each thing in the use list" -
" so that checking for conflicting exports among used packages is done.")
(DEFINEQ
(MAKE-PACKAGE
(CL:LAMBDA (NAME &KEY (USE (QUOTE ("LISP")))
NICKNAMES
(INTERNAL-SYMBOLS 10)
(EXTERNAL-SYMBOLS 10)) (* raf
"19-Feb-86 22:24")
(CL:WHEN (FIND-PACKAGE NAME)
(ERROR "A package with this name already exists: " NAME))
(LET* ((NAME (STRING NAME))
(PACKAGE-INDEX (\PKG-FIND-FREE-PACKAGE-INDEX))
(PACKAGE (INTERNAL-MAKE-PACKAGE :NAME NAME :INTERNAL-SYMBOLS (MAKE-PACKAGE-HASHTABLE
INTERNAL-SYMBOLS)
:EXTERNAL-SYMBOLS
(MAKE-PACKAGE-HASHTABLE EXTERNAL-SYMBOLS)
:INDEX PACKAGE-INDEX)))
(USE-PACKAGE USE PACKAGE)
(ENTER-NEW-NICKNAMES PACKAGE NICKNAMES)
(SETF (GETHASH NAME *PACKAGE-NAMES*)
PACKAGE)
(SETF (AREF \PKG-INDEX-TO-PACKAGE-VECTOR PACKAGE-INDEX)
PACKAGE))))
)
(* * " In-Package -- Public" - - " Like Make-Package, only different.")
(DEFINEQ
(IN-PACKAGE
[CL:LAMBDA (NAME &REST KEYS &KEY NICKNAMES USE) (* raf
"30-Jan-86 01:13")
(LET ((PACKAGE (FIND-PACKAGE NAME)))
(COND
(PACKAGE (USE-PACKAGE USE PACKAGE)
(ENTER-NEW-NICKNAMES PACKAGE NICKNAMES)
(SETQ *PACKAGE* PACKAGE))
(T (SETQ *PACKAGE* (CL:APPLY (FUNCTION MAKE-PACKAGE)
NAME KEYS])
)
(* * " Rename-Package -- Public" - -
" Change the name if we can, blast any old nicknames and then" - " add in any new ones.")
(DEFINEQ
(RENAME-PACKAGE
(CL:LAMBDA (PACKAGE NAME &OPTIONAL (NICKNAMES NIL)) (* raf
"20-Feb-86 17:25")
(LET* ((PACKAGE (\PACKAGIFY PACKAGE))
(NAME (\SIMPLE-STRINGIFY NAME))
(FOUND (FIND-PACKAGE NAME)))
(CL:UNLESS (OR (NOT FOUND)
(EQ FOUND PACKAGE))
(CL:ERROR "A package named ~S already exists." NAME))
(REMHASH (PACKAGE-NAME PACKAGE)
*PACKAGE-NAMES*)
(SETF (PACKAGE-NAME PACKAGE)
NAME)
(SETF (GETHASH NAME *PACKAGE-NAMES*)
PACKAGE)
(DOLIST (N (PACKAGE-NICKNAMES PACKAGE))
(REMHASH N *PACKAGE-NAMES*))
(SETF (PACKAGE-NICKNAMES PACKAGE)
NIL)
(ENTER-NEW-NICKNAMES PACKAGE NICKNAMES)
PACKAGE)))
)
(* * " List-All-Packages -- Public")
(DEFINEQ
(LIST-ALL-PACKAGES
[LAMBDA NIL (* raf
" 5-Feb-86 14:05")
(LET ((RES NIL))
(CL:MAPHASH (FUNCTION (CL:LAMBDA (K V)
(CL:DECLARE (IGNORE K))
(CL:PUSHNEW V RES)))
*PACKAGE-NAMES*)
RES])
)
(* * " Intern -- Public" - - " Simple-stringify the name and call intern*.")
(DEFINEQ
(INTERN
(CL:LAMBDA (NAME &OPTIONAL (PACKAGE *PACKAGE*)) (* raf
"20-Feb-86 17:24")
(LET ((NAME (\SIMPLE-STRINGIFY NAME))
(PACKAGE (\PACKAGIFY PACKAGE)))
(CL:DECLARE (SIMPLE-STRING NAME))
(INTERN* NAME (CL:LENGTH NAME)
PACKAGE))))
)
(* * " Find-Symbol -- Public" - - " Ditto.")
(DEFINEQ
(FIND-SYMBOL
(CL:LAMBDA (NAME &OPTIONAL (PACKAGE *PACKAGE*)) (* raf
"20-Feb-86 17:26")
(LET ((NAME (\SIMPLE-STRINGIFY NAME))
(PACKAGE (\PACKAGEIFY PACKAGE)))
(CL:DECLARE (SIMPLE-STRING NAME))
(FIND-SYMBOL* NAME (CL:LENGTH NAME)
PACKAGE))))
)
(* * " Intern* -- Internal" - -
" If the symbol doesn't exist then create it, special-casing" - " the keyword package.")
(DEFINEQ
(INTERN*
[CL:LAMBDA (NAME CL:LENGTH PACKAGE) (* raf
"10-Feb-86 15:16")
(CL:DECLARE (SIMPLE-STRING NAME))
(MULTIPLE-VALUE-BIND (SYMBOL WHERE)
(FIND-SYMBOL* NAME CL:LENGTH PACKAGE)
(CL:IF WHERE (VALUES SYMBOL WHERE)
(LET ((SYMBOL (PRIMITIVE ALLOC-SYMBOL (SUBSEQ NAME 0 CL:LENGTH)
PACKAGE)))
(COND
((EQ PACKAGE *KEYWORD-PACKAGE*)
(ADD-SYMBOL (PACKAGE-EXTERNAL-SYMBOLS PACKAGE)
SYMBOL)
(SET SYMBOL SYMBOL))
(T (ADD-SYMBOL (PACKAGE-INTERNAL-SYMBOLS PACKAGE)
SYMBOL)))
(VALUES SYMBOL NIL])
)
(* * " Find-Symbol* -- Internal" - -
" Check internal and external symbols, then scan down the list" -
" of hashtables for inherited symbols. When an inherited symbol" -
" is found pull that table to the beginning of the list.")
(DEFINEQ
(FIND-SYMBOL*
[CL:LAMBDA (STRING CL:LENGTH PACKAGE) (* raf
" 5-Feb-86 14:32")
(CL:DECLARE (SIMPLE-STRING STRING))
(LET* ((HASH (PRIMITIVE SXHASH-SIMPLE-SUBSTRING STRING CL:LENGTH))
(EHASH (ENTRY-HASH CL:LENGTH HASH)))
[WITH-SYMBOL (FOUND SYMBOL (PACKAGE-INTERNAL-SYMBOLS PACKAGE)
STRING CL:LENGTH HASH EHASH)
(CL:WHEN FOUND (RETURN-FROM FIND-SYMBOL* (VALUES SYMBOL :INTERNAL]
[WITH-SYMBOL (FOUND SYMBOL (PACKAGE-EXTERNAL-SYMBOLS PACKAGE)
STRING CL:LENGTH HASH EHASH)
(CL:WHEN FOUND (RETURN-FROM FIND-SYMBOL* (VALUES SYMBOL :EXTERNAL]
(LET ((HEAD (PACKAGE-TABLES PACKAGE)))
(CL:DO ((PREV HEAD TABLE)
(TABLE (CDR HEAD)
(CDR TABLE)))
((NULL TABLE)
(VALUES NIL NIL))
(WITH-SYMBOL (FOUND SYMBOL (CAR TABLE)
STRING CL:LENGTH HASH EHASH)
(CL:WHEN FOUND (CL:UNLESS (EQ PREV HEAD)
(SHIFTF (CDR PREV)
(CDR TABLE)
(CDR HEAD)
TABLE))
(RETURN-FROM FIND-SYMBOL* (VALUES SYMBOL :INHERITED])
)
(* * " Find-External-Symbol -- Internal" - -
" Similar to Find-Symbol, but only looks for an external symbol." -
" This is used for fast name-conflict checking.")
(DEFINEQ
(FIND-EXTERNAL-SYMBOL
[CL:LAMBDA (STRING PACKAGE)
(CL:DECLARE (SIMPLE-STRING STRING))
(LET* ((CL:LENGTH (CL:LENGTH STRING))
(HASH (PRIMITIVE SXHASH-SIMPLE-STRING STRING))
(EHASH (ENTRY-HASH CL:LENGTH HASH)))
(WITH-SYMBOL (FOUND SYMBOL (PACKAGE-EXTERNAL-SYMBOLS PACKAGE)
STRING CL:LENGTH HASH EHASH)
(VALUES SYMBOL FOUND])
)
(* * " Unintern -- Public" - -
" If we are uninterning a shadowing symbol, then a name conflict can" -
" result, otherwise just nuke the symbol.")
(DEFINEQ
(UNINTERN
[CL:LAMBDA (SYMBOL &OPTIONAL (PACKAGE *PACKAGE*)) (* raf
"20-Feb-86 17:28")
(LET* ((NAME (SYMBOL-NAME SYMBOL))
(PACKAGE (\PACKAGIFY PACKAGE))
(SHADOWING-SYMBOLS (PACKAGE-SHADOWING-SYMBOLS PACKAGE)))
(CL:DECLARE (LIST SHADOWING-SYMBOLS)
(SIMPLE-STRING NAME))
(* *
" If a name conflict is revealed, give use a chance to shadowing-import"
" one of the available symbols.")
[CL:WHEN (CL:MEMBER SYMBOL SHADOWING-SYMBOLS)
(LET ((CSET NIL))
[DOLIST (P (PACKAGE-USE-LIST PACKAGE))
(MULTIPLE-VALUE-BIND (S W)
(FIND-EXTERNAL-SYMBOL NAME P)
(CL:WHEN W (CL:PUSHNEW S CSET]
(CL:WHEN (CDR CSET)
(LOOP (CERROR "prompt for a symbol to shadowing-import."
"Uninterning symbol ~S causes name conflict among these symbols:~~S"
SYMBOL CSET)
(LET ((SYM (READ *QUERY-IO*)))
(COND
((NOT (SYMBOLP SYM))
(FORMAT *QUERY-IO* "~S is not a symbol."))
((NOT (CL:MEMBER SYM CSET))
(FORMAT *QUERY-IO*
"~S is not one of the conflicting symbols."))
(T (SHADOWING-IMPORT SYM PACKAGE)
(RETURN-FROM UNINTERN T]
(MULTIPLE-VALUE-BIND (S W)
(FIND-SYMBOL NAME PACKAGE)
(CL:DECLARE (IGNORE S))
(COND
((OR (EQ W :INTERNAL)
(EQ W :EXTERNAL))
(NUKE-SYMBOL (CL:IF (EQ W :INTERNAL)
(PACKAGE-INTERNAL-SYMBOLS PACKAGE)
(PACKAGE-EXTERNAL-SYMBOLS PACKAGE))
NAME)
(CL:IF (EQ (SYMBOL-PACKAGE SYMBOL)
PACKAGE)
(PRIMITIVE SET-PACKAGE SYMBOL NIL))
T)
(T NIL])
)
(* * " Symbol-Listify -- Internal" - -
" Take a symbol-or-list-of-symbols and return a list, checking types.")
(DEFINEQ
(SYMBOL-LISTIFY
[CL:LAMBDA (THING) (* raf
"28-Jan-86 17:37")
(COND
((CL:LISTP THING)
(DOLIST (S THING)
(CL:UNLESS (SYMBOLP S)
(CL:ERROR "~S is not a symbol." S)))
THING)
((SYMBOLP THING)
(LIST THING))
(T (CL:ERROR "~S is neither a symbol nor a list of symbols." THING])
)
(* * " Moby-Unintern -- Internal" - -
" Like Unintern, but if symbol is inherited chases down the" -
" package it is inherited from and uninterns it there. Used" -
" for name-conflict resolution. Shadowing symbols are not" -
" uninterned since they do not cause conflicts.")
(DEFINEQ
(MOBY-UNINTERN
[CL:LAMBDA (SYMBOL PACKAGE) (* raf
" 5-Feb-86 15:13")
(CL:UNLESS (CL:MEMBER SYMBOL (PACKAGE-SHADOWING-SYMBOLS PACKAGE))
(OR (UNINTERN SYMBOL PACKAGE)
(LET ((NAME (SYMBOL-NAME SYMBOL)))
(MULTIPLE-VALUE-BIND (S W)
(FIND-SYMBOL NAME PACKAGE)
(CL:DECLARE (IGNORE S))
(CL:WHEN (EQ W :INHERITED)
(DOLIST (Q (PACKAGE-USE-LIST PACKAGE))
(MULTIPLE-VALUE-BIND (U X)
(FIND-EXTERNAL-SYMBOL NAME Q)
(CL:DECLARE (IGNORE U))
(CL:WHEN X (UNINTERN SYMBOL Q)
(RETURN-FROM MOBY-UNINTERN T])
)
(* * " Export -- Public")
(DEFINEQ
(EXPORT
(CL:LAMBDA (SYMBOLS &OPTIONAL (PACKAGE *PACKAGE*)) (* raf
"20-Feb-86 17:34")
(LET ((SYMS NIL)
(PACKAGE (\PACKAGIFY PACKAGE)))
(* * " Punt any symbols that are already external.")
[DOLIST (SYM (SYMBOL-LISTIFY SYMBOLS))
(MULTIPLE-VALUE-BIND (S W)
(FIND-EXTERNAL-SYMBOL (SYMBOL-NAME SYM)
PACKAGE)
(CL:DECLARE (IGNORE S))
(CL:UNLESS (OR W (CL:MEMBER SYM SYMS))
(CL:PUSH SYM SYMS]
(* * " Find symbols and packages with conflicts.")
[LET ((USED-BY (PACKAGE-USED-BY-LIST PACKAGE))
(CPACKAGES NIL)
(CSET NIL))
[DOLIST (SYM SYMS)
(LET ((NAME (SYMBOL-NAME SYM)))
(DOLIST (P USED-BY)
(MULTIPLE-VALUE-BIND (S W)
(FIND-SYMBOL NAME P)
(CL:WHEN [AND W (NOT (EQ S SYM))
(NOT (CL:MEMBER S (PACKAGE-SHADOWING-SYMBOLS
P]
(CL:PUSHNEW SYM CSET)
(CL:PUSHNEW P CPACKAGES]
(CL:WHEN CSET (CERROR "skip exporting these symbols or unintern all conflicting ones." "Exporting these symbols from the ~A package:~~S~~
results in name conflicts with these packages:~~{~A ~}" (PACKAGE-NAME PACKAGE)
CSET
(CL:MAPCAR (FUNCTION PACKAGE-NAME)
CPACKAGES))
(CL:IF (Y-OR-N-P "Unintern all conflicting symbols? ")
(DOLIST (P CPACKAGES)
(DOLIST (SYM CSET)
(MOBY-UNINTERN SYM P)))
(SETQ SYMS (NSET-DIFFERENCE SYMS CSET]
(* *
" Check that all symbols are available. If not, ask to import them.")
(LET ((MISSING NIL)
(IMPORTS NIL))
[DOLIST (SYM SYMS)
(MULTIPLE-VALUE-BIND (S W)
(FIND-SYMBOL (SYMBOL-NAME SYM)
PACKAGE)
(COND
((NOT (AND W (EQ S SYM)))
(CL:PUSH SYM MISSING))
((EQ W :INHERITED)
(CL:PUSH SYM IMPORTS]
(CL:WHEN MISSING (CERROR "Import these symbols into the ~A package."
"These symbols are not available in the ~A package:~~S"
(PACKAGE-NAME PACKAGE)
MISSING)
(IMPORT MISSING PACKAGE))
(IMPORT IMPORTS PACKAGE))
(* * " And now, three pages later, we export the suckers.")
(LET ((INTERNAL (PACKAGE-INTERNAL-SYMBOLS PACKAGE))
(EXTERNAL (PACKAGE-EXTERNAL-SYMBOLS PACKAGE)))
(DOLIST (SYM SYMS)
(NUKE-SYMBOL INTERNAL (SYMBOL-NAME SYM))
(ADD-SYMBOL EXTERNAL SYM)))
T)))
)
(* * " Unexport -- Public" - -
" Check that all symbols are available, then move from external to" - " internal.")
(DEFINEQ
(UNEXPORT
(CL:LAMBDA (SYMBOLS &OPTIONAL (PACKAGE *PACKAGE*)) (* raf
"20-Feb-86 17:35")
(LET ((SYMS NIL)
(PACKAGE (\PACKAGIFY PACKAGE)))
[DOLIST (SYM (SYMBOL-LISTIFY SYMBOLS))
(MULTIPLE-VALUE-BIND (S W)
(FIND-SYMBOL (SYMBOL-NAME SYM)
PACKAGE)
(COND
((OR (NOT W)
(NOT (EQ S SYM)))
(CL:ERROR "~S is not available in the ~A package." SYM (SYMBOL-NAME
PACKAGE)))
((EQ W :EXTERNAL)
(CL:PUSHNEW SYM SYMS]
[LET ((INTERNAL (PACKAGE-INTERNAL-SYMBOLS PACKAGE))
(EXTERNAL (PACKAGE-EXTERNAL-SYMBOLS PACKAGE)))
(DOLIST (SYM SYMS)
(ADD-SYMBOL INTERNAL SYM)
(NUKE-SYMBOL EXTERNAL (SYMBOL-NAME SYM]
T)))
)
(* * " Import -- Public")
(DEFINEQ
(IMPORT
(CL:LAMBDA (SYMBOLS &OPTIONAL (PACKAGE *PACKAGE*)) (* raf
"20-Feb-86 17:36")
(LET ((SYMS NIL)
(CSET NIL)
(PACKAGE (\PACKAGIFY PACKAGE)))
[DOLIST (SYM (SYMBOL-LISTIFY SYMBOLS))
(MULTIPLE-VALUE-BIND (S W)
(FIND-SYMBOL (SYMBOL-NAME SYM)
PACKAGE)
(COND
[(NOT W)
(LET [(FOUND (CL:MEMBER SYM SYMS :TEST (FUNCTION STRING=]
(CL:IF FOUND (CL:WHEN (NOT (EQ (CAR FOUND)
SYM))
(CL:PUSH SYM CSET))
(CL:PUSH SYM SYMS]
((NOT (EQ S SYM))
(CL:PUSH SYM CSET))
((EQ W :INHERITED)
(CL:PUSH SYM SYMS]
(CL:WHEN CSET (CERROR "Import these symbols with Shadowing-Import."
"Importing these symbols into the ~A package causes a name conflict:~~S"
(PACKAGE-NAME PACKAGE)
CSET))
(LET ((INTERNAL (PACKAGE-INTERNAL-SYMBOLS PACKAGE)))
(DOLIST (SYM SYMS)
(ADD-SYMBOL INTERNAL SYM)))
(SHADOWING-IMPORT CSET PACKAGE))))
)
(* * " Shadowing-Import -- Public" - -
" If a conflicting symbol is present, unintern it, otherwise just" - " stick the symbol in."
)
(DEFINEQ
(SHADOWING-IMPORT
(CL:LAMBDA (SYMBOLS &OPTIONAL (PACKAGE *PACKAGE*)) (* raf
"20-Feb-86 17:37")
[LET* ((PACKAGE (\PACKAGIFY PACKAGE))
(INTERNAL (PACKAGE-INTERNAL-SYMBOLS PACKAGE)))
(DOLIST (SYM (SYMBOL-LISTIFY SYMBOLS))
(MULTIPLE-VALUE-BIND (S W)
(FIND-SYMBOL (SYMBOL-NAME SYM)
PACKAGE)
(CL:UNLESS (AND W (EQ S SYM))
(CL:WHEN (OR (EQ W :INTERNAL)
(EQ W :EXTERNAL)) (*
" If it was shadowed, we don't want Unintern to flame out...")
[SETF (PACKAGE-SHADOWING-SYMBOLS PACKAGE)
(CL:DELETE S (THE LIST (PACKAGE-SHADOWING-SYMBOLS PACKAGE
]
(UNINTERN S PACKAGE))
(ADD-SYMBOL INTERNAL SYM))
(CL:PUSHNEW SYM (PACKAGE-SHADOWING-SYMBOLS PACKAGE]
T))
)
(* * " Shadow -- Public")
(DEFINEQ
(SHADOW
(CL:LAMBDA (SYMBOLS &OPTIONAL (PACKAGE *PACKAGE*)) (* raf
"20-Feb-86 17:38")
[LET* ((PACKAGE (\PACKAGIFY PACKAGE))
(INTERNAL (PACKAGE-INTERNAL-SYMBOLS PACKAGE)))
(DOLIST (SYM (SYMBOL-LISTIFY SYMBOLS))
(LET ((NAME (SYMBOL-NAME SYM)))
(MULTIPLE-VALUE-BIND (S W)
(FIND-SYMBOL NAME PACKAGE)
(CL:WHEN (OR (NOT W)
(EQ W :INHERITED))
(SETQ S (PRIMITIVE ALLOC-SYMBOL NAME PACKAGE))
(ADD-SYMBOL INTERNAL S))
(CL:PUSHNEW S (PACKAGE-SHADOWING-SYMBOLS PACKAGE]
T))
)
(* * " Package-Listify -- Internal" - -
" Return a list of packages given a package-or-string-or-symbol or" -
" list thereof, or die trying.")
(DEFINEQ
(PACKAGE-LISTIFY
(CL:LAMBDA (THING) (* raf
"20-Feb-86 17:43")
(LET ((RES NIL))
(DOLIST (THING (CL:IF (CL:LISTP THING)
THING
(LIST THING)))
(CL:PUSH [CL:IF (PACKAGEP THING)
THING
(COND
((\PACKAGIFY THING))
(T (CERROR "Package doesn't exist (OK to create it): " THING)
(MAKE-PACKAGE THING]
RES))
RES)))
)
(* * " Use-Package -- Public" - -
" Do stuff to use a package, with all kinds of fun name-conflict" - " checking.")
(DEFINEQ
(USE-PACKAGE
(CL:LAMBDA (PACKAGES-TO-USE &OPTIONAL (PACKAGE *PACKAGE*)) (* raf
"20-Feb-86 17:49")
[LET ((PACKAGES (PACKAGE-LISTIFY PACKAGES-TO-USE))
(PACKAGE (\PACKAGIFY PACKAGE)))
(* * " Loop over each package, use'ing one at a time...")
(DOLIST
(PKG PACKAGES)
(CL:UNLESS (CL:MEMBER PKG (PACKAGE-USE-LIST PACKAGE))
[LET ((CSET NIL)
(SHADOWING-SYMBOLS (PACKAGE-SHADOWING-SYMBOLS PACKAGE))
(USE-LIST (PACKAGE-USE-LIST PACKAGE)))
(* * " If the number of symbols already available is less than the" -
" number to be inherited then it is faster to run the test the" -
" other way. This is particularly valuable in the case of" -
" a new package use'ing Lisp.")
[COND
[(< [+ (INTERNAL-SYMBOL-COUNT PACKAGE)
(EXTERNAL-SYMBOL-COUNT PACKAGE)
(LET ((RES 0))
(DOLIST (P USE-LIST RES)
(INCF RES (EXTERNAL-SYMBOL-COUNT P]
(EXTERNAL-SYMBOL-COUNT PKG))
[DO-SYMBOLS (SYM PACKAGE)
(MULTIPLE-VALUE-BIND (S W)
(FIND-EXTERNAL-SYMBOL (SYMBOL-NAME SYM)
PKG)
(CL:WHEN (AND W (NOT (EQ S SYM))
(NOT (CL:MEMBER SYM SHADOWING-SYMBOLS)))
(CL:PUSH SYM CSET]
(DOLIST (P USE-LIST)
(DO-EXTERNAL-SYMBOLS
(SYM P)
(MULTIPLE-VALUE-BIND
(S W)
(FIND-EXTERNAL-SYMBOL (SYMBOL-NAME SYM)
PKG)
(CL:WHEN (AND W (NOT (EQ S SYM))
(NOT (CL:MEMBER (INTERN (SYMBOL-NAME SYM)
PACKAGE)
SHADOWING-SYMBOLS)))
(CL:PUSH SYM CSET]
(T (DO-EXTERNAL-SYMBOLS (SYM PKG)
(MULTIPLE-VALUE-BIND (S W)
(FIND-SYMBOL (SYMBOL-NAME SYM)
PACKAGE)
(CL:WHEN (AND W (NOT (EQ S SYM))
(NOT (CL:MEMBER S SHADOWING-SYMBOLS)))
(CL:PUSH S CSET]
(CL:WHEN CSET (CERROR "unintern the conflicting symbols in the ~2*~A package."
"Use'ing package ~A results in name conflicts for these symbols:~~S"
(PACKAGE-NAME PKG)
CSET
(PACKAGE-NAME PACKAGE))
(DOLIST (S CSET)
(MOBY-UNINTERN S PACKAGE]
(CL:PUSH PKG (PACKAGE-USE-LIST PACKAGE))
(CL:PUSH (PACKAGE-EXTERNAL-SYMBOLS PKG)
(CDR (PACKAGE-TABLES PACKAGE)))
(CL:PUSH PACKAGE (PACKAGE-USED-BY-LIST PKG]
T))
)
(* * " Unuse-Package -- Public")
(DEFINEQ
(UNUSE-PACKAGE
(CL:LAMBDA (PACKAGES-TO-UNUSE &OPTIONAL (PACKAGE *PACKAGE*)) (* raf
"20-Feb-86 17:45")
[LET ((PACKAGE (\PACKAGIFY PACKAGE)))
(DOLIST (P (PACKAGE-LISTIFY PACKAGES-TO-UNUSE))
[SETF (PACKAGE-USE-LIST PACKAGE)
(CL:DELETE P (THE LIST (PACKAGE-USE-LIST PACKAGE]
[SETF (PACKAGE-TABLES PACKAGE)
(CL:DELETE (PACKAGE-EXTERNAL-SYMBOLS P)
(THE LIST (PACKAGE-TABLES PACKAGE]
(SETF (PACKAGE-USED-BY-LIST P)
(CL:DELETE PACKAGE (THE LIST (PACKAGE-USED-BY-LIST P]
T))
)
(* * " Find-All-Symbols -- Public")
(DEFINEQ
(FIND-ALL-SYMBOLS
(CL:LAMBDA (STRING-OR-SYMBOL)
"Return a list of all symbols in the system having the specified name."
(LET ((STRING (STRING STRING-OR-SYMBOL))
(RES NIL))
(CL:MAPHASH [FUNCTION (CL:LAMBDA (K V)
(CL:DECLARE (IGNORE K))
(MULTIPLE-VALUE-BIND (S W)
(FIND-SYMBOL STRING V)
(CL:WHEN W (CL:PUSHNEW S RES]
*PACKAGE-NAMES*)
RES)))
)
(* * " Apropos and Apropos-List.")
(DEFINEQ
(BRIEFLY-DESCRIBE-SYMBOL
(CL:LAMBDA (SYMBOL) (* raf
" 5-Feb-86 14:10")
(FRESH-LINE)
(PRIN1 SYMBOL)
(CL:WHEN (BOUNDP SYMBOL)
(WRITE-STRING ", value: ")
(PRIN1 (SYMBOL-VALUE SYMBOL)))
(CL:IF (FBOUNDP SYMBOL)
(WRITE-STRING " (defined)"))))
(APROPOS-SEARCH
[CL:LAMBDA (SYMBOL STRING) (* raf
"31-Jan-86 17:56")
(CL:DO* ((INDEX 0 (1+ INDEX))
(NAME (SYMBOL-NAME SYMBOL))
(CL:LENGTH (CL:LENGTH STRING))
(TERMINUS (- (CL:LENGTH NAME)
CL:LENGTH)))
((> INDEX TERMINUS)
NIL)
(CL:IF (CL:DO ((JNDEX 0 (1+ JNDEX))
(KNDEX INDEX (1+ KNDEX)))
((= JNDEX CL:LENGTH)
T)
(CL:UNLESS (CHAR-EQUAL (SCHAR STRING JNDEX)
(SCHAR NAME KNDEX))
(RETURN NIL)))
(RETURN T])
(CL:APROPOS
(CL:LAMBDA (STRING &OPTIONAL PACKAGE EXTERNAL-ONLY) (* raf
"30-Jan-86 00:28")
(LET [(STRING (CL:IF (SYMBOLP STRING)
(SYMBOL-NAME STRING)
(COERCE STRING (QUOTE SIMPLE-STRING]
(CL:DECLARE (SIMPLE-STRING STRING))
[CL:IF (NULL PACKAGE)
(DO-ALL-SYMBOLS (SYMBOL)
(CL:IF (APROPOS-SEARCH SYMBOL STRING)
(BRIEFLY-DESCRIBE-SYMBOL SYMBOL)))
(LET [(PACKAGE (CAR (PACKAGE-LISTIFY PACKAGE]
(CL:IF EXTERNAL-ONLY (DO-EXTERNAL-SYMBOLS (SYMBOL PACKAGE)
(CL:IF (APROPOS-SEARCH SYMBOL STRING)
(BRIEFLY-DESCRIBE-SYMBOL SYMBOL)))
(DO-SYMBOLS (SYMBOL PACKAGE)
(CL:IF (APROPOS-SEARCH SYMBOL STRING)
(BRIEFLY-DESCRIBE-SYMBOL SYMBOL]
NIL)))
(APROPOS-LIST
(CL:LAMBDA (STRING &OPTIONAL PACKAGE EXTERNAL-ONLY)
"Identical to Apropos, except that it returns a list of the symbols
found instead of describing them."
(LET ([STRING (CL:IF (SYMBOLP STRING)
(SYMBOL-NAME STRING)
(COERCE STRING (QUOTE SIMPLE-STRING]
(LIST (QUOTE NIL)))
(CL:DECLARE (SIMPLE-STRING STRING))
[CL:IF (NULL PACKAGE)
(DO-ALL-SYMBOLS (SYMBOL)
(CL:IF (APROPOS-SEARCH SYMBOL STRING)
(CL:PUSH SYMBOL LIST)))
(LET [(PACKAGE (CAR (PACKAGE-LISTIFY PACKAGE]
(CL:IF EXTERNAL-ONLY (DO-EXTERNAL-SYMBOLS (SYMBOL PACKAGE)
(CL:IF (APROPOS-SEARCH SYMBOL STRING)
(CL:PUSH SYMBOL LIST)))
(DO-SYMBOLS (SYMBOL PACKAGE)
(CL:IF (APROPOS-SEARCH SYMBOL STRING)
(CL:PUSH SYMBOL LIST]
LIST)))
)
(* * While edits to the code above have changed it from the original Spice source the
majority of low level support occurs below here.)
(* * The first draft of packages for Interlisp-D is implemented by using a free byte in the
litatom structure (defined in the copied and altered definition now called SYMBOL) %. A vector
(\PKG-INDEX-TO-PACKAGE-VECTOR) is used to relate these numbers to packages, and the packages
themselves contain their INDEX in the vector.)
(DECLARE: EVAL@COMPILE DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(ACCESSFNS SYMBOL ((DEFINITIONCELL (\DEFCELL DATUM))
(PROPCELL (\PROPCELL DATUM))
(VCELL (\VALCELL DATUM))
(PNAMECELL (\PNAMECELL DATUM)))
(* * VCELL can also be accessed directly from a value index via the
record VALINDEX (as in \SETGLOBALVAL.UFN) -
Similarly, PNAMEINDEX accesses PNAMECELL for use by \MKATOM and UNCOPYATOM)
(TYPE? (LITATOM DATUM))
(BLOCKRECORD PROPCELL ((NIL BITS 1)
(GENSYMP FLAG)
(FATPNAMEP FLAG)
(NIL BITS 5)
(PROPLIST POINTER)))
(BLOCKRECORD PNAMECELL ((PACKAGE BITS 8)
(PNAMESTR POINTER))))
]
(DECLARE: EVAL@COMPILE
(RPAQQ MAX-NUMBER-PACKAGES 255)
(RPAQQ \INTERLISP-PACKAGE-INDEX 0)
(RPAQQ \UNINTERNED-PACKAGE-INDEX 1)
(CONSTANTS MAX-NUMBER-PACKAGES \INTERLISP-PACKAGE-INDEX \UNINTERNED-PACKAGE-INDEX)
)
(* END EXPORTED DEFINITIONS)
)
(RPAQ? \PKG-INDEX-TO-PACKAGE-VECTOR (MAKE-ARRAY 256 :INITIAL-ELEMENT NIL))
(* PACKAGE-INIT depends on the free marker being NIL)
(DEFINEQ
(\PKG-FIND-FREE-PACKAGE-INDEX
[CL:LAMBDA NIL (* raf
"10-Feb-86 15:51")
(* * Starts counting at 2 because 0 is Interlisp and 1 is uninterned
symbols)
(CL:DO ((I 2 (INCF I)))
((= I MAX-NUMBER-PACKAGES)
(ERROR "Package space full" NIL))
(CL:IF (NULL (AREF \PKG-INDEX-TO-PACKAGE-VECTOR I))
(RETURN I])
)
(* \PKG-FIND-FREE-PACKAGE-INDEX and \UNINTERNED-PACKAGE-INDEX are all neatly arranged so that
SYMBOL-PACKAGE can find NIL in the index vector and NIL can also be the free slot marker)
(DECLARE: EVAL@COMPILE
[PUTPROPS SETF-SYMBOL-PACKAGE DMACRO ((obj value)
(freplace (SYMBOL PACKAGE)
of obj with (if value then (PACKAGE-INDEX value)
else \UNINTERNED-PACKAGE-INDEX]
[PUTPROPS SYMBOL-PACKAGE DMACRO ((obj)
(AREF \PKG-INDEX-TO-PACKAGE-VECTOR (ffetch (SYMBOL PACKAGE)
of obj]
)
(DEFINEQ
(SETF-SYMBOL-PACKAGE
[LAMBDA (SYMBOL PACKAGE) (* raf
"10-Feb-86 15:45")
(freplace (SYMBOL PACKAGE) of SYMBOL with (if PACKAGE
then (PACKAGE-INDEX PACKAGE)
else \UNINTERNED-PACKAGE-INDEX])
(SYMBOL-PACKAGE
[LAMBDA (SYMBOL) (* raf
"10-Feb-86 15:57")
(AREF \PKG-INDEX-TO-PACKAGE-VECTOR (ffetch (SYMBOL PACKAGE) of SYMBOL])
)
(DECLARE: EVAL@LOAD DONTCOPY
(FILESLOAD (SOURCE PROP)
LLBASIC APRINT)
)
(DEFINEQ
(NEWMKATOM
[LAMBDA (X PACKAGE) (* raf
"27-Feb-86 17:51")
(COND
((STRINGP X)
(\NEWMKATOM (ffetch (STRINGP BASE) of X)
(ffetch (STRINGP OFFST) of X)
(LET ((LEN (ffetch (STRINGP LENGTH) of X)))
(COND
((IGREATERP LEN \PNAMELIMIT)
(LISPERROR "ATOM TOO LONG" X))
(T LEN)))
(ffetch (STRINGP FATSTRINGP) of X)
PACKAGE))
((OR (LITATOM X)
(NUMBERP X))
X)
(T (PACK* X])
(\NEWMKATOM
[LAMBDA (BASE OFFST LEN FATP PACKAGE) (* raf
"20-Feb-86 15:38")
(COND
((OR (NULL PACKAGE)
(EQ (QUOTE NOBIND)
PACKAGE))
(SETQ PACKAGE *INTERLISP-PACKAGE*)))
(PROG [HASH HASHENT ATM# PNBASE FIRSTCHAR FIRSTBYTE REPROBE SYMBOLPACKAGEINDEX
(FATCHARSEENP (AND FATP (NOT (NULL (for I from OFFST
to (SUB1 (IPLUS OFFST LEN))
suchthat (IGREATERP (\GETBASEFAT BASE I)
\MAXTHINCHAR]
(* Because
FATCHARSEENP is used in
an EQ check later, it
must be NIL or T only,
hence the (NOT
(NULL ...)))
(COND
((EQ LEN 0) (* The Zero-length
atom has hash code zero)
(SETQ HASH 0)
(SETQ FIRSTBYTE 255)
(GO LP)))
(SETQ FIRSTCHAR (UNLESSRDSYS (\GETBASECHAR FATP BASE OFFST)
(NTHCHARCODE BASE OFFST))) (* Grab the first
character of the atom)
[UNLESSRDSYS (COND
[(AND (EQ LEN 1)
(ILEQ FIRSTCHAR \MAXTHINCHAR)
\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. Sigh)
(IDIFFERENCE FIRSTCHAR (CHARCODE "0")))
(T (\ADDBASE \OneCharAtomBase FIRSTCHAR]
((AND (ILEQ FIRSTCHAR (CHARCODE "9"))
(SETQ HASHENT (MKNUMATOM BASE OFFST LEN FATP)))
(* MKNUMATOM returns
a number or NIL)
(RETURN HASHENT] (* Calculate first
probe)
(SETQ FIRSTBYTE (LOGAND FIRSTCHAR 255)) (* First byte is used
to compute hash and
reprobe. Use lower
order byte of first
character, since
chances are that has
the most information)
(COMPUTE.ATOM.HASH BASE OFFST LEN FIRSTBYTE FATP) (* Build a hash value
for this atom from the
PNAME)
LP (* Top of the
probe-and-compare-PNAMEs
loop.)
[COND
((NEQ 0 (SETQ HASHENT (\GETBASE \AtomHashTable HASH))) (* HASHENT is one
greater than the atom
number, so that atom
zero can be stored.
Go from atom number to
pname, compare strings)
(COND
((UNLESSRDSYS [AND (EQ [ffetch (PNAMEBASE PNAMELENGTH)
of (SETQ PNBASE (ffetch (PNAMEINDEX PNAMEBASE)
of (SETQ ATM# (SUB1 HASHENT]
LEN)
[EQ FATCHARSEENP (AND (PROG1 (EQ 0 (ffetch (PNAMEBASE
PNAMEFATPADDINGBYTE
)
of PNBASE))
(* Extra memory references to get the FATPNAMEP bit, so do a quick and
dirty heuristic, based on the fact that the second byte of a fatpname is
always 0--wouldn't be worth it if the fatbit were more easily accessible)
)
(ffetch (LITATOM FATPNAMEP)
of (\ADDBASE \ATOMSPACE ATM#]
(PROG1 [EQ (ffetch (PACKAGE INDEX)
PACKAGE)
(SETQ SYMBOLPACKAGEINDEX (ffetch (SYMBOL PACKAGE)
of (\ADDBASE
\ATOMSPACE
ATM#]
(* Ignore atoms in
other packages)
)
(PROG1 (NEQ SYMBOLPACKAGEINDEX \UNINTERNED-PACKAGE-INDEX)
(* Ignore uninterned
atoms)
)
(COND
[FATCHARSEENP (* FATCHARSEENP=T now
implies that both the
probe and target are
fat)
(for B1 from 1 to LEN as B2
from OFFST always (* Loop thru the
characters in the
putative atom and the
existing PNAME, to see
if they're the same)
(EQ (\GETBASEFAT PNBASE B1)
(\GETBASEFAT BASE B2]
[FATP (* The incoming
string is fat, but
there are no fat
characters in the
PNAME.)
(for B1 from 1 to LEN as B2 from
OFFST
always (EQ (\GETBASETHIN PNBASE B1)
(\GETBASEFAT BASE B2]
(T (* Both the incoming
string of chars and the
PNAME are thin.)
(for B1 from 1 to LEN as B2 from OFFST
always (EQ (\GETBASETHIN PNBASE B1)
(\GETBASETHIN BASE B2]
(EQ (\INDEXATOMPNAME (SETQ ATM# (SUB1 HASHENT)))
BASE))
(RETURN (\ADDBASE \ATOMSPACE ATM#)))
(T (* Doesn't match, so
reprobe. Want reprobe
to be variable,
preferably independent
of primary probe.)
[SETQ HASH (IPLUS16 HASH (OR REPROBE (SETQ REPROBE (ATOM.HASH.REPROBE HASH
FIRSTBYTE]
(GO LP] (* Not found, must
make new atom)
(RETURN (\NEWMKATOM.NEW BASE OFFST LEN HASH FATP FATCHARSEENP PACKAGE])
(\NEWMKATOM.NEW
[LAMBDA (BASE OFFST LEN HASH FATP FATCHARSEENP PACKAGE) (* raf
"10-Feb-86 13:58")
(DECLARE (GLOBALVARS \STORAGEFULL \INTERRUPTSTATE))
(COND
((NULL PACKAGE)
(SETQ PACKAGE *INTERLISP-PACKAGE*)))
(PROG (ATM PB CPP PNBASE)
[COND
(\PNAMES.IN.BLOCKS? (SETQ PNBASE (\ALLOCBLOCK (COND
(FATCHARSEENP
(* Allocate us a
bunch of word-sized
chars in pname space)
(FOLDHI (ADD1 LEN)
WORDSPERCELL))
(T (* Allocation is in
CELLS)
(FOLDHI (ADD1 LEN)
BYTESPERCELL]
(RETURN (UNINTERRUPTABLY
(COND
((EVENP (SETQ ATM \AtomFrLst)
\MDSIncrement) (* MDS pages are
allocated in two-page
chunks now)
(PROG ((PN (FOLDLO ATM WORDSPERPAGE)))
(COND
((IGEQ PN (IDIFFERENCE \LastAtomPage 1))
(\MKATOM.FULL)))
(\MAKEMDSENTRY PN (LOGOR \TT.NOREF \TT.ATOM \LITATOM))
(* Make entry in MDS
type table)
(\INITATOMPAGE PN) (* Make Def'n,
TopVal, and Plist pages
exist, and initialize)
))
((EQ ATM \MaxAtomFrLst) (* This test is fast)
(\MP.ERROR \MP.ATOMSFULL "No more atoms left")))
[COND
((NOT \PNAMES.IN.BLOCKS?)
(SETQ PB \NxtPnByte)
(COND
((ODDP PB)
(SHOULDNT "ODDP value in \NxtPnByte ")))
(SETQ CPP \CurPnPage) (* PNAME will start
on this page)
(COND
([ILESSP (IDIFFERENCE \CharsPerPnPage PB)
(COND
(FATCHARSEENP (UNFOLD (ADD1 LEN)
BYTESPERWORD))
(T (ADD1 LEN] (* Not enough space
left on this pname page
to hold all the
characters for the new
atom.)
(\GCPNAMES)))
(SETQ PNBASE (\VAG2 (IPLUS \PnCharsFirstSegment (LRSH CPP 8))
(IPLUS (LLSH (LOGAND CPP 255)
8)
(LRSH PB 1]
(replace (PNAMEINDEX PNAMEBASE) of ATM with PNBASE)
(* PNAME starts on
byte 1 always -
byte 0 is the length)
(COND
(FATCHARSEENP (\BLT (\ADDBASE PNBASE 1)
(\ADDBASE BASE OFFST)
LEN))
[FATP (for I from OFFST as J from 1 to LEN
do (\PUTBASETHIN PNBASE J (\GETBASEFAT BASE I]
(T (\MOVEBYTES BASE OFFST PNBASE 1 LEN)))
(replace (PNAMEBASE PNAMELENGTH) of PNBASE with LEN)
(\PUTBASE \AtomHashTable HASH (SETQ \AtomFrLst (ADD1 ATM)))
(* Ugly, they just
both happen to want to
be set to (ADD1 ATM))
[COND
(\PNAMES.IN.BLOCKS? (* Make the pname
block permanent, since
the replace above did
not addref it)
(\ADDREF PNBASE))
(T
(* * Would like to use (CEIL (ADD1 LEN) BYTESPERWORD) in the following,
but it will produce a (LOGAND ... -2) and the DLion 4K control store
doesn't have negative arithmetic in ucode.)
(SETQ.NOREF \NxtPnByte (IMOD (IPLUS PB (LOGAND (IPLUS LEN 2)
65534))
\CharsPerPnPage))
(COND
((EQ 0 \NxtPnByte)
(\GCPNAMES]
(SETQ ATM (\ADDBASE \ATOMSPACE ATM))
(COND
(FATCHARSEENP (freplace (LITATOM FATPNAMEP) of ATM with T)))
(freplace (SYMBOL PACKAGE) of ATM with (PACKAGE-INDEX PACKAGE))
ATM)])
(\NEWLITPRIN
[LAMBDA (X SA STREAM) (* raf
"27-Feb-86 17:27")
(DECLARE (USEDFREE \THISFILELINELENGTH *PACKAGE*))
[COND
((NEQ (ffetch (SYMBOL PACKAGE) of X)
(PACKAGE-INDEX *PACKAGE*)) (* If the current
package is different
from the litatom's then
print the package name
syntax before the chars
of the litatom)
(.SPACECHECK. STREAM 2)
(\OUTCHAR STREAM (APPLY* (FUNCTION CHARCODE)
\CML.READPREFIX))
(\OUTCHAR STREAM (CHARCODE ";"))
[LET* ((P (SYMBOL-PACKAGE X))
(PN (PACKAGE-NAME P))
(PNL (CL:LENGTH PN)))
(.SPACECHECK. STREAM PNL)
(for I from 0 to (SUB1 PNL) do (\OUTCHAR STREAM (CHAR-CODE (AREF PN I]
(.SPACECHECK. STREAM 1)
(\OUTCHAR STREAM (CHARCODE ";"]
(COND
((EQ X (QUOTE %.))
(COND
(SA (.SPACECHECK. STREAM 2)
(\OUTCHAR STREAM (CHARCODE %%)))
(T (.SPACECHECK. STREAM 1)))
(\OUTCHAR STREAM (CHARCODE %.)))
[SA (LET (NESCAPES)
[.SPACECHECK. STREAM (IPLUS (\NATOMCHARS X)
(SETQ NESCAPES
(for C inatom X bind (FIRSTFLG ← T)
SYN
count (PROG1 (AND (fetch (READCODE ESCQUOTE)
of (SETQ SYN
(\SYNCODE SA C)))
(OR FIRSTFLG
(fetch (READCODE
INNERESCQUOTE
)
of SYN)))
(SETQ FIRSTFLG NIL]
(COND
((EQ NESCAPES 0) (* Won't need to
check)
(SETQ NESCAPES NIL))
((NULL NESCAPES) (* If we didn't need
to check linelength
above, then don't know
whether escapes are
needed)
(SETQ NESCAPES T)))
(for C inatom X bind (FIRSTFLG ← T)
SYN do (AND NESCAPES (fetch (READCODE ESCQUOTE)
of (SETQ SYN
(\SYNCODE SA C)))
(OR FIRSTFLG (fetch (READCODE
INNERESCQUOTE)
of SYN))
(\OUTCHAR STREAM (CHARCODE %%)))
(\OUTCHAR STREAM C)
(SETQ FIRSTFLG NIL]
(T (.SPACECHECK. STREAM (\NATOMCHARS X))
(for C inatom X do (\OUTCHAR STREAM C])
)
(* * " Initialization.")
(RPAQQ *INTERLISP-PACKAGE* NIL)
(RPAQQ OLDMKATOM NIL)
(RPAQQ \OLDMKATOM NIL)
(RPAQQ \OLDMKATOM.NEW NIL)
(RPAQQ \OLDLITPRIN NIL)
(DEFINEQ
(PACKAGE-INIT
(CL:LAMBDA NIL (* raf
"25-Feb-86 15:37")
(IN-PACKAGE "LISP" :USE NIL :NICKNAMES (QUOTE ("CL" "COMMONLISP")))
(IN-PACKAGE "SYSTEM")
(IN-PACKAGE "USER")
(IN-PACKAGE "DEBUG")
(SETQ *LISP-PACKAGE* (FIND-PACKAGE "LISP"))
(SETQ *KEYWORD-PACKAGE* (FIND-PACKAGE "KEYWORD"))
(* * "Build the (bogus) Interlisp package.")
(IN-PACKAGE "INTERLISP" :USE NIL :NICKNAMES (QUOTE ("IL")))
(SETQ *INTERLISP-PACKAGE* (FIND-PACKAGE "INTERLISP"))
(SETF (AREF \PKG-INDEX-TO-PACKAGE-VECTOR (PACKAGE-INDEX *INTERLISP-PACKAGE*))
NIL) (* Free the package
slot the system just
created)
(SETF (PACKAGE-INDEX *INTERLISP-PACKAGE*)
\INTERLISP-PACKAGE-INDEX)
(* * (MAPATOMS (FUNCTION (LAMBDA (ATOM)
(LET ((NAME (SYMBOL-NAME ATOM))) (INTERN* NAME
(CL:LENGTH NAME) *INTERLISP-PACKAGE*))))))
(* Move the Interlisp
symbols into their
package)
(* * (MAPC CMLSYMBOLS (FUNCTION (LAMBDA
(SYMBOL) (LET ((NAME (SYMBOL-NAME SYMBOL)))
(INTERN* NAME (CL:LENGTH NAME) *LISP-PACKAGE*))))))
(* Pick the CML
symbols out and put
them into their own
package)
NIL))
(PACKAGE-CLEAR
(CL:LAMBDA NIL
(CLRHASH *PACKAGE-NAMES*)
(for I from 0 to 255 do (SETF (AREF \PKG-INDEX-TO-PACKAGE-VECTOR I)
NIL))))
(ENABLE-PACKAGES
(CL:LAMBDA NIL (* raf
"19-Feb-86 21:34")
[if (NULL OLDMKATOM)
then (SETQ OLDMKATOM (GETD (QUOTE MKATOM)))
(SETQ \OLDMKATOM (GETD (QUOTE \MKATOM)))
(SETQ \OLDMKATOM.NEW (GETD (QUOTE \MKATOM.NEW)))
(SETQ \OLDLITPRIN (GETD (QUOTE \LITPRIN]
(MOVD (QUOTE NEWMKATOM)
(QUOTE MKATOM))
(MOVD (QUOTE \NEWMKATOM)
(QUOTE \MKATOM))
(MOVD (QUOTE \NEWMKATOM.NEW)
(QUOTE \MKATOM.NEW))
(MOVD (QUOTE \NEWLITPRIN)
(QUOTE \LITPRIN))))
(DISABLE-PACKAGES
(CL:LAMBDA NIL (* raf
"19-Feb-86 21:33")
(if OLDMKATOM
then (MOVD OLDMKATOM (QUOTE MKATOM))
(MOVD \OLDMKATOM (QUOTE \MKATOM))
(MOVD \OLDMKATOM.NEW (QUOTE \MKATOM.NEW))
(MOVD \OLDLITPRIN (QUOTE \LITPRIN))
else (printout PROMPTWINDOW "Packages not enabled." T))))
)
(* * "Spice compatability stuff")
(DEFINEQ
(PRIMEP
[CL:LAMBDA (N) (* raf
" 5-Feb-86 17:20")
(COND
((= 1 N)
T)
((= 2 N)
NIL)
(T (CL:DO ((D (1- N)
(1- D)))
((= 1 D)
T)
(CL:WHEN (= 0 (IREMAINDER N D))
(RETURN NIL])
)
(DECLARE: EVAL@COMPILE
[DEFMACRO PRIMITIVE (FN &REST ARGS)
(BQUOTE ((\, (OR (GET FN (QUOTE CL:PRIMITIVE))
(ERROR "Unknown primitive op" FN)))
(\,@ ARGS]
)
(PUTPROPS ALLOC-SYMBOL CL:PRIMITIVE NEWMKATOM)
(PUTPROPS SET-PACKAGE CL:PRIMITIVE SETF-SYMBOL-PACKAGE)
(PUTPROPS SXHASH-SIMPLE-STRING CL:PRIMITIVE STRINGHASHBITS)
(PUTPROPS SXHASH-SIMPLE-SUBSTRING CL:PRIMITIVE STRINGHASHBITS)
(MOVD (QUOTE REMAINDER)
(QUOTE REM))
(MOVD (QUOTE ERROR)
(QUOTE CERROR))
(MOVD (QUOTE *)
(QUOTE CL:DECLARE))
(* * "Vertical bar semicolon reader macro for package qualified litatom syntax.")
(RPAQ? \PKG.SYMBOL.STRING (MAKE-STRING 256))
(RPAQ? \PKG.PACKAGE.STRING (MAKE-STRING 256))
(PUTPROPS ; HASHREADMACRO READSYMBOL)
(DEFINEQ
(READSYMBOL
[LAMBDA (STREAM RDTBL) (* raf
"27-Feb-86 18:18")
(* * Interlisp's package qualified litatom syntax uses a semicolon to
separate the package name chars and litatom name chars.
Right now we're using this crufty readmacro to implement it.
Recognition of a qualified atom should go into \SUBREAD, calling INTERN or
INTERN*)
(DECLARE (GLOBALVARS \PKG.SYMBOL.STRING \PKG.PACKAGE.STRING))
(LET ((SHIFTEDCHARSET (UNFOLD (ffetch (STREAM CHARSET) of STREAM)
256))
EXTERNAL BASE CHAR SYMBOL)
(* * Read chars up to the next semicolon into \PKG.PACKAGE.STRING)
(SETQ BASE (ffetch (STRINGP XBASE) of \PKG.PACKAGE.STRING))
(for I from 0 to 127 until (EQ (CHARCODE ";")
(SETQ CHAR (\NSIN STREAM SHIFTEDCHARSET
SHIFTEDCHARSET)))
do (\PUTBASEFAT BASE I CHAR) finally (freplace (STRINGP LENGTH) of
\PKG.PACKAGE.STRING
with I))
(* * Determine if there are one or two semicolons, denoting respectively
external and internal litatoms)
(SETQ EXTERNAL (if (NEQ (CHARCODE ";")
(\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET))
then NIL
else (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)
T))
(* * Read chars up to the next break into \PKG.SYMBOL.STRING)
(SETQ BASE (ffetch (STRINGP XBASE) of \PKG.SYMBOL.STRING))
(for I from 0 to 127 until [fetch (READCODE STOPATOM)
of (\SYNCODE RDTBL (SETQ CHAR
(\NSPEEK STREAM
SHIFTEDCHARSET
SHIFTEDCHARSET]
do (\PUTBASEFAT BASE I CHAR)
(\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)
finally (freplace (STRINGP LENGTH) of \PKG.SYMBOL.STRING with I))
(* * Create the symbol and if its was marked external, make it so)
(SETQ SYMBOL (INTERN \PKG.SYMBOL.STRING \PKG.PACKAGE.STRING))
(if EXTERNAL
then (EXPORT SYMBOL \PKG.PACKAGE.STRING))
SYMBOL])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA UNUSE-PACKAGE USE-PACKAGE SHADOW SHADOWING-IMPORT IMPORT UNEXPORT EXPORT UNINTERN
FIND-SYMBOL INTERN RENAME-PACKAGE APROPOS-LIST CL:APROPOS IN-PACKAGE
MAKE-PACKAGE MAKE-PACKAGE-HASHTABLE)
)
(PUTPROPS CMLPACKAGES COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (14537 14903 (PRINT-PACKAGE 14547 . 14901)) (15316 16764 (FIND-PACKAGE 15326 . 15585) (
PARSE-BODY 15587 . 16762)) (21478 22442 (MAKE-PACKAGE-HASHTABLE 21488 . 22440)) (22875 23121 (
INTERNAL-SYMBOL-COUNT 22885 . 23001) (EXTERNAL-SYMBOL-COUNT 23003 . 23119)) (23257 24923 (ADD-SYMBOL
23267 . 24921)) (28745 29241 (NUKE-SYMBOL 28755 . 29239)) (35454 36979 (MAKE-DO-SYMBOLS-VARS 35464 .
35778) (MAKE-DO-SYMBOLS-CODE 35780 . 36977)) (37186 38392 (ENTER-NEW-NICKNAMES 37196 . 38390)) (38654
39801 (MAKE-PACKAGE 38664 . 39799)) (39885 40427 (IN-PACKAGE 39895 . 40425)) (40567 41502 (
RENAME-PACKAGE 40577 . 41500)) (41548 41987 (LIST-ALL-PACKAGES 41558 . 41985)) (42076 42479 (INTERN
42086 . 42477)) (42536 42950 (FIND-SYMBOL 42546 . 42948)) (43084 44023 (INTERN* 43094 . 44021)) (44268
45886 (FIND-SYMBOL* 44278 . 45884)) (46063 46489 (FIND-EXTERNAL-SYMBOL 46073 . 46487)) (46650 49247 (
UNINTERN 46660 . 49245)) (49371 49878 (SYMBOL-LISTIFY 49381 . 49876)) (50171 51221 (MOBY-UNINTERN
50181 . 51219)) (51256 54892 (EXPORT 51266 . 54890)) (55020 56169 (UNEXPORT 55030 . 56167)) (56204
57755 (IMPORT 56214 . 57753)) (57902 59216 (SHADOWING-IMPORT 57912 . 59214)) (59251 60112 (SHADOW
59261 . 60110)) (60269 61016 (PACKAGE-LISTIFY 60279 . 61014)) (61145 64998 (USE-PACKAGE 61155 . 64996)
) (65040 65779 (UNUSE-PACKAGE 65050 . 65777)) (65823 66377 (FIND-ALL-SYMBOLS 65833 . 66375)) (66419
69971 (BRIEFLY-DESCRIBE-SYMBOL 66429 . 66853) (APROPOS-SEARCH 66855 . 67687) (CL:APROPOS 67689 . 68843
) (APROPOS-LIST 68845 . 69969)) (71892 72444 (\PKG-FIND-FREE-PACKAGE-INDEX 71902 . 72442)) (73181
73950 (SETF-SYMBOL-PACKAGE 73191 . 73662) (SYMBOL-PACKAGE 73664 . 73948)) (74031 97785 (NEWMKATOM
74041 . 74777) (\NEWMKATOM 74779 . 86212) (\NEWMKATOM.NEW 86214 . 93236) (\NEWLITPRIN 93238 . 97783))
(97970 101543 (PACKAGE-INIT 97980 . 100136) (PACKAGE-CLEAR 100138 . 100349) (ENABLE-PACKAGES 100351 .
101044) (DISABLE-PACKAGES 101046 . 101541)) (101584 102046 (PRIMEP 101594 . 102044)) (102855 105902 (
READSYMBOL 102865 . 105900)))))
STOP