github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-04-26 04:08:08 +00:00
Code Issues Projects Releases Wiki Activity

Extend DEFPACKAGE to accept uninterned symbols as the names to export… (#1822)

Browse Source 
…. They are treated the same as strings: the `symbol-name` is first
interned in the package before being exported.
This is defined as the behavior in CLtL2, and using uninterned symbols
appears to be common practice in other Common Lisp code.
This commit is contained in:
Matt Heffron
2024-09-23 10:28:16 -07:00
committed by GitHub
parent 548d3f1567 a85d6287ae
commit b41ae0cbbe
2 changed files with 275 additions and 155 deletions
Download Patch File Download Diff File Expand all files Collapse all files

430
sources/LLPACKAGE
View File

@@ -1,15 +1,15 @@
(DEFINE-FILE-INFO PACKAGE "LISP" READTABLE "XCL" BASE 10) (DEFINE-FILE-INFO PACKAGE "LISP" READTABLE "XCL" BASE 10)
(IL:FILECREATED "24-Oct-2021 10:20:31" IL:|{DSK}<home>larry>medley>sources>LLPACKAGE.;4| 82444 (IL:FILECREATED " 5-Sep-2024 17:42:20" IL:|{DSK}<home>matt>Interlisp>medley>sources>LLPACKAGE.;3| 87515
IL:|changes| IL:|to:| (IL:FUNCTIONS IL:FIND-EXTERNAL-SYMBOL IL:FIND-SYMBOL*) :EDIT-BY "mth"
IL:|previous| IL:|date:| "22-Sep-92 11:47:31" IL:|{DSK}<home>larry>medley>sources>LLPACKAGE.;1| :CHANGES-TO (IL:FNS XCL:DEFPACKAGE)
:PREVIOUS-DATE " 4-Sep-2024 13:17:23" IL:|{DSK}<home>matt>Interlisp>medley>sources>LLPACKAGE.;2|
) )
; Copyright (c) 1986-1987, 1990-1992 by Venue & Xerox Corporation.
(IL:PRETTYCOMPRINT IL:LLPACKAGECOMS) (IL:PRETTYCOMPRINT IL:LLPACKAGECOMS)
(IL:RPAQQ IL:LLPACKAGECOMS (IL:RPAQQ IL:LLPACKAGECOMS
@@ -83,9 +83,9 @@
(IL:FUNCTIONS IL:\\INDEXATOMPNAME) (IL:FUNCTIONS IL:\\INDEXATOMPNAME)
(IL:* IL:\; (IL:* IL:\;
 "Defined in EXPORTS.ALL and used by the DO-SYMBOLS macro")  "Defined in EXPORTS.ALL and used by the DO-SYMBOLS macro")
(IL:DECLARE\: IL:EVAL@COMPILE (IL:* IL:\; (IL:DECLARE\: IL:EVAL@COMPILE (IL:* IL:\;
 "These are used in expanding the DO-SYMBOLS macro, which is used in this file.")  "These are used in expanding the DO-SYMBOLS macro, which is used in this file.")
(IL:FUNCTIONS IL:MAKE-DO-SYMBOLS-VARS IL:MAKE-DO-SYMBOLS-CODE)) (IL:FUNCTIONS IL:MAKE-DO-SYMBOLS-VARS IL:MAKE-DO-SYMBOLS-CODE))
(IL:FUNCTIONS DO-EXTERNAL-SYMBOLS XCL:DO-LOCAL-SYMBOLS XCL:DO-INTERNAL-SYMBOLS DO-SYMBOLS (IL:FUNCTIONS DO-EXTERNAL-SYMBOLS XCL:DO-LOCAL-SYMBOLS XCL:DO-INTERNAL-SYMBOLS DO-SYMBOLS
DO-ALL-SYMBOLS) DO-ALL-SYMBOLS)
@@ -96,7 +96,7 @@
(IL:FUNCTIONS IL:BRIEFLY-DESCRIBE-SYMBOL APROPOS APROPOS-LIST) (IL:FUNCTIONS IL:BRIEFLY-DESCRIBE-SYMBOL APROPOS APROPOS-LIST)
(IL:* IL:|;;| (IL:* IL:|;;|
 "Reader and printer's interface to packages (plus *PACKAGE-FROM-INDEX* above)")  "Reader and printer's interface to packages (plus *PACKAGE-FROM-INDEX* above)")
(IL:FUNCTIONS IL:FIND-EXTERNAL-SYMBOL) (IL:FUNCTIONS IL:FIND-EXTERNAL-SYMBOL)
(IL:FUNCTIONS IL:FIND-EXACT-SYMBOL IL:PACKAGE-NAME-AS-SYMBOL IL:\\FIND.PACKAGE.INTERNAL) (IL:FUNCTIONS IL:FIND-EXACT-SYMBOL IL:PACKAGE-NAME-AS-SYMBOL IL:\\FIND.PACKAGE.INTERNAL)
@@ -175,10 +175,10 @@
) )
(DEFMACRO IL:\\FATCHARSEENP (IL:BASE IL:OFFSET IL:LEN IL:FATP) (DEFMACRO IL:\\FATCHARSEENP (IL:BASE IL:OFFSET IL:LEN IL:FATP)
`(AND ,IL:FATP (NOT (NULL (IL:FOR IL:I IL:FROM ,IL:OFFSET `(AND ,IL:FATP (NOT (NULL (IL:FOR IL:I IL:FROM ,IL:OFFSET IL:TO (IL:SUB1 (IL:IPLUS ,IL:OFFSET
IL:TO (IL:SUB1 (IL:IPLUS ,IL:OFFSET ,IL:LEN)) ,IL:LEN))
IL:SUCHTHAT (IL:IGREATERP (IL:\\GETBASEFAT ,IL:BASE IL:I) IL:SUCHTHAT (IL:IGREATERP (IL:\\GETBASEFAT ,IL:BASE IL:I)
IL:\\MAXTHINCHAR)))))) IL:\\MAXTHINCHAR))))))
(DEFMACRO IL:\\PACKAGIFY (IL:OBJ) (DEFMACRO IL:\\PACKAGIFY (IL:OBJ)
"If OBJ isn't already a package, turn the symbol or string into the package of that name." "If OBJ isn't already a package, turn the symbol or string into the package of that name."
@@ -220,9 +220,8 @@
(DEFUN IL:\\UPCASEBASE (IL:BASE IL:OFFSET IL:LENGTH IL:FATP) (DEFUN IL:\\UPCASEBASE (IL:BASE IL:OFFSET IL:LENGTH IL:FATP)
(IL:|for| IL:I IL:|from| IL:OFFSET IL:|to| (IL:IPLUS IL:OFFSET IL:LENGTH) (IL:|for| IL:I IL:|from| IL:OFFSET IL:|to| (IL:IPLUS IL:OFFSET IL:LENGTH)
IL:|do| (IL:\\PUTBASECHAR IL:FATP IL:BASE IL:I (IL:NUMERIC-UPCASE (IL:\\GETBASECHAR IL:|do| (IL:\\PUTBASECHAR IL:FATP IL:BASE IL:I (IL:NUMERIC-UPCASE (IL:\\GETBASECHAR IL:FATP
IL:FATP IL:BASE IL:I IL:BASE IL:I)))))
)))))
(DEFUN IL:APROPOS-SEARCH (SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP) (DEFUN IL:APROPOS-SEARCH (SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP)
"The symbol to substring comparison macro for APROPOS and APROPOS-LIST. The string is assumed to already be uppercase." "The symbol to substring comparison macro for APROPOS and APROPOS-LIST. The string is assumed to already be uppercase."
@@ -240,13 +239,13 @@
T) T)
(UNLESS (EQL (IL:\\GETBASECHAR IL:FATP IL:BASE IL:JNDEX) (UNLESS (EQL (IL:\\GETBASECHAR IL:FATP IL:BASE IL:JNDEX)
(IL:NUMERIC-UPCASE (IL:\\GETBASECHAR IL:SYMBOL-FATP IL:SYMBOL-BASE (IL:NUMERIC-UPCASE (IL:\\GETBASECHAR IL:SYMBOL-FATP IL:SYMBOL-BASE
(IL:ADD1 IL:KNDEX)))) (IL:ADD1 IL:KNDEX))))
(RETURN NIL))) (RETURN NIL)))
(RETURN T)))) (RETURN T))))
(DEFSTRUCT (PACKAGE-HASHTABLE (:CONSTRUCTOR %MAKE-PACKAGE-HASHTABLE) (DEFSTRUCT (PACKAGE-HASHTABLE (:CONSTRUCTOR %MAKE-PACKAGE-HASHTABLE)
(:COPIER NIL) (:COPIER NIL)
(:PRINT-FUNCTION PRINT-PACKAGE-HASHTABLE)) (:PRINT-FUNCTION PRINT-PACKAGE-HASHTABLE))
"Packages are implemented using a special kind of hashtable (this one). 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." "Packages are implemented using a special kind of hashtable (this one). 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."
TABLE TABLE
HASH HASH
@@ -255,9 +254,9 @@
DELETED) DELETED)
(DEFSTRUCT (PACKAGE (:CONC-NAME %PACKAGE-) (DEFSTRUCT (PACKAGE (:CONC-NAME %PACKAGE-)
(:CONSTRUCTOR %MAKE-PACKAGE) (:CONSTRUCTOR %MAKE-PACKAGE)
(:PREDICATE PACKAGEP) (:PREDICATE PACKAGEP)
(:PRINT-FUNCTION PRINT-PACKAGE)) (:PRINT-FUNCTION PRINT-PACKAGE))
INDEX INDEX
(TABLES (LIST NIL)) (TABLES (LIST NIL))
NAME NAMESYMBOL NICKNAMES (USE-LIST NIL) NAME NAMESYMBOL NICKNAMES (USE-LIST NIL)
@@ -321,7 +320,7 @@
"The current package, in which read symbols are intern'ed.") "The current package, in which read symbols are intern'ed.")
(DEFVAR XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES* '("LISP" "INTERLISP" "XEROX-COMMON-LISP") (DEFVAR XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES* '("LISP" "INTERLISP" "XEROX-COMMON-LISP")
"Packages whose deletion requires confirmation.") "Packages whose deletion requires confirmation.")
(XCL:DEFGLOBALVAR IL:*LISP-PACKAGE* NIL (XCL:DEFGLOBALVAR IL:*LISP-PACKAGE* NIL
"Global for internal references to the lisp package.") "Global for internal references to the lisp package.")
@@ -357,8 +356,8 @@
(IL:LEN (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| IL:PRINT-NAME)) (IL:LEN (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| IL:PRINT-NAME))
(IL:OFFST (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| IL:PRINT-NAME))) (IL:OFFST (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| IL:PRINT-NAME)))
(IL:UNINTERRUPTABLY (IL:UNINTERRUPTABLY
(IL:\\CREATE.SYMBOL IL:BASE IL:OFFST IL:LEN IL:FATP (IL:\\FATCHARSEENP IL:BASE (IL:\\CREATE.SYMBOL IL:BASE IL:OFFST IL:LEN IL:FATP (IL:\\FATCHARSEENP IL:BASE IL:OFFST
IL:OFFST IL:LEN IL:FATP))))) IL:LEN IL:FATP)))))
@@ -367,12 +366,11 @@
) )
(XCL:DEFGLOBALVAR IL:*PACKAGE-FROM-NAME* (IL:HASHARRAY 255 'IL:ERROR 'IL:STRINGHASHBITS (XCL:DEFGLOBALVAR IL:*PACKAGE-FROM-NAME* (IL:HASHARRAY 255 'IL:ERROR 'IL:STRINGHASHBITS 'IL:STREQUAL)
'IL:STREQUAL) "An equal hashtable from package names to packages.")
"An equal hashtable from package names to packages.")
(XCL:DEFGLOBALVAR IL:*PACKAGE-FROM-INDEX* (MAKE-ARRAY 256 ':INITIAL-ELEMENT NIL) (XCL:DEFGLOBALVAR IL:*PACKAGE-FROM-INDEX* (MAKE-ARRAY 256 ':INITIAL-ELEMENT NIL)
"Index to package converter.") "Index to package converter.")
(DEFCONSTANT XCL:*TOTAL-PACKAGES-LIMIT* 255 (DEFCONSTANT XCL:*TOTAL-PACKAGES-LIMIT* 255
"The total number of packages that the system may have (excluding the 'uninterned' package).") "The total number of packages that the system may have (excluding the 'uninterned' package).")
@@ -499,9 +497,9 @@
(RETURN IL:X))))) (RETURN IL:X)))))
(DEFUN MAKE-PACKAGE (NAME &KEY (USE '("LISP")) (DEFUN MAKE-PACKAGE (NAME &KEY (USE '("LISP"))
NICKNAMES PREFIX-NAME (EXTERNAL-ONLY NIL) NICKNAMES PREFIX-NAME (EXTERNAL-ONLY NIL)
(INTERNAL-SYMBOLS 10) (INTERNAL-SYMBOLS 10)
(EXTERNAL-SYMBOLS 10)) (EXTERNAL-SYMBOLS 10))
"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." "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."
(DECLARE (SPECIAL IL:*PACKAGE-FROM-INDEX* IL:*PACKAGE-FROM-NAME*)) (DECLARE (SPECIAL IL:*PACKAGE-FROM-INDEX* IL:*PACKAGE-FROM-NAME*))
(WHEN (FIND-PACKAGE NAME) (WHEN (FIND-PACKAGE NAME)
@@ -518,14 +516,143 @@
:INDEX %PACKAGE-INDEX))) :INDEX %PACKAGE-INDEX)))
(USE-PACKAGE USE PACKAGE) (USE-PACKAGE USE PACKAGE)
(IL:ENTER-NEW-NICKNAMES PACKAGE (IF (IL:STREQUAL NAME (SYMBOL-NAME PREFIX-NAME)) (IL:ENTER-NEW-NICKNAMES PACKAGE (IF (IL:STREQUAL NAME (SYMBOL-NAME PREFIX-NAME))
NICKNAMES NICKNAMES
(CONS PREFIX-NAME NICKNAMES))) (CONS PREFIX-NAME NICKNAMES)))
(IL:PUTHASH NAME PACKAGE IL:*PACKAGE-FROM-NAME*) (IL:PUTHASH NAME PACKAGE IL:*PACKAGE-FROM-NAME*)
(SETF (AREF IL:*PACKAGE-FROM-INDEX* %PACKAGE-INDEX) (SETF (AREF IL:*PACKAGE-FROM-INDEX* %PACKAGE-INDEX)
PACKAGE))) PACKAGE)))
(IL:DEFINEQ (IL:DEFINEQ
(xcl:defpackage (XCL:DEFPACKAGE
(IL:NLAMBDA IL:ARGS (IL:* IL:\; "Edited 4-Sep-2024 13:17 by mth")
(IL:* IL:\; "Edited 2-Dec-87 10:39 by raf")
(IL:SETQ IL:ARGS (XCL:REMOVE-COMMENTS IL:ARGS))
(LET
((PACKAGE (FIND-PACKAGE (CAR IL:ARGS))))
(COND
((PACKAGEP PACKAGE) (IL:* IL:\;
 "If one already exists, test compatability of package definitions")
(IL:|for| IL:OPTION IL:|in| (CDR IL:ARGS)
IL:|do|
(LET* ((IL:KEY (COND
((KEYWORDP IL:OPTION)
IL:OPTION)
((IL:LISTP IL:OPTION)
(CAR IL:OPTION))
(T (IL:ERROR "Bad option for defpackage " IL:OPTION))))
(VALUES (COND
((KEYWORDP IL:OPTION)
(LIST T))
((IL:LISTP IL:OPTION)
(CDR IL:OPTION))
(T (IL:ERROR "Bad option for defpackage " IL:OPTION)))))
(IL:SELECTQ IL:KEY
((:INTERNAL-SYMBOLS :EXTERNAL-SYMBOLS)
NIL)
(:EXTERNAL-ONLY (IF (NOT (%PACKAGE-EXTERNAL-ONLY PACKAGE))
(IL:ERROR
"Package NOT :external-only as asserted by defpackage: "
PACKAGE)))
(:PREFIX-NAME (SETF (%PACKAGE-NAMESYMBOL PACKAGE)
(MAKE-SYMBOL (CAR VALUES))))
(:USE (USE-PACKAGE VALUES PACKAGE))
(:NICKNAMES (IL:ENTER-NEW-NICKNAMES PACKAGE VALUES))
(:EXPORT (EXPORT (IL:FOR IL:SYMBOL IL:IN VALUES
IL:COLLECT (IL:IF (IL:LITATOM IL:SYMBOL)
IL:THEN (IL:IF (SYMBOL-PACKAGE IL:SYMBOL)
IL:THEN IL:SYMBOL
IL:ELSE (INTERN (SYMBOL-NAME
IL:SYMBOL)
PACKAGE))
IL:ELSEIF (IL:STRINGP IL:SYMBOL)
IL:THEN (INTERN IL:SYMBOL PACKAGE)
IL:ELSE (IL:ERROR
"Bad object in :export option of defpackage "
IL:SYMBOL)))
PACKAGE))
(:IMPORT (IMPORT VALUES PACKAGE))
((:SHADOW :SHADOWING-IMPORT)
(LET ((IL:SYMBOLS-TO-SHADOW (IL:MAPCONC
VALUES
(IL:FUNCTION (IL:LAMBDA (SYMBOL)
(COND
((NOT
(IL:MEMB SYMBOL
(
%PACKAGE-SHADOWING-SYMBOLS
PACKAGE)))
(LIST SYMBOL))))))))
(IL:SELECTQ IL:KEY
(:SHADOW (SHADOW IL:SYMBOLS-TO-SHADOW PACKAGE))
(:SHADOWING-IMPORT
(SHADOWING-IMPORT IL:SYMBOLS-TO-SHADOW PACKAGE))
NIL)))
(IL:ERROR "Bad keyword for defpackage " IL:KEY)))))
(T (IL:* IL:\;
 "Otherwise, make a new package to spec")
(LET
((IL:POST-MAKE-FORMS NIL))
(IL:SETQ PACKAGE
(IL:APPLY 'MAKE-PACKAGE
(CONS (CAR IL:ARGS)
(IL:|for| IL:OPTION IL:|in| (CDR IL:ARGS)
IL:|join| (LET ((IL:KEY (COND
((KEYWORDP IL:OPTION)
IL:OPTION)
((IL:LISTP IL:OPTION)
(CAR IL:OPTION))
(T (IL:ERROR "Bad option for defpackage "
IL:OPTION))))
(VALUES (COND
((KEYWORDP IL:OPTION)
(LIST T))
((IL:LISTP IL:OPTION)
(CDR IL:OPTION))
(T (IL:ERROR "Bad option for defpackage "
IL:OPTION)))))
(IL:SELECTQ IL:KEY
((:USE :NICKNAMES)
(LIST IL:KEY (IL:|if| (CAR VALUES)
IL:|then| VALUES
IL:|else|
(IL:* IL:\; "Handles case where NIL is being used to explicitly say the package's :USE list is empty, since the default is to use LISP.")
NIL)))
((:PREFIX-NAME :INTERNAL-SYMBOLS :EXTERNAL-SYMBOLS
:EXTERNAL-ONLY)
(LIST IL:KEY (CAR VALUES)))
((:SHADOW :EXPORT :IMPORT :SHADOWING-IMPORT)
(IL:SETQ IL:POST-MAKE-FORMS
(CONS (CONS IL:KEY VALUES)
IL:POST-MAKE-FORMS))
NIL)
(IL:ERROR "Bad keyword for defpackage " IL:KEY)))))))
(IL:MAPC
IL:POST-MAKE-FORMS
(IL:FUNCTION (IL:LAMBDA (IL:FORM)
(IL:SELECTQ (CAR IL:FORM)
(:SHADOW (SHADOW (CDR IL:FORM)
PACKAGE))
(:EXPORT (EXPORT
(IL:FOR IL:SYMBOL IL:IN (CDR IL:FORM)
IL:COLLECT (IL:IF (IL:LITATOM IL:SYMBOL)
IL:THEN (IL:IF (SYMBOL-PACKAGE IL:SYMBOL)
IL:THEN IL:SYMBOL
IL:ELSE (INTERN (SYMBOL-NAME
IL:SYMBOL)
PACKAGE))
IL:ELSEIF (IL:STRINGP IL:SYMBOL)
IL:THEN (INTERN IL:SYMBOL PACKAGE)
IL:ELSE (IL:ERROR
"Bad object in :export option of defpackage "
IL:SYMBOL)))
PACKAGE))
(:IMPORT (IMPORT (CDR IL:FORM)
PACKAGE))
(:SHADOWING-IMPORT
(SHADOWING-IMPORT (CDR IL:FORM)
PACKAGE))
(IL:SHOULDNT "Bogus form on post-make-forms"))))))))
(PACKAGE-NAME PACKAGE))))
) )
@@ -569,16 +696,15 @@
(NOT (IL:FMEMB IL:SYM IL:SHADOWING-SYMBOLS))) (NOT (IL:FMEMB IL:SYM IL:SHADOWING-SYMBOLS)))
(PUSHNEW IL:SYM IL:CSET :TEST 'EQ)))) (PUSHNEW IL:SYM IL:CSET :TEST 'EQ))))
(DOLIST (IL:P IL:USE-LIST) (DOLIST (IL:P IL:USE-LIST)
(PUSHNEW IL:SYM IL:CSET :TEST 'EQ)))) (DO-EXTERNAL-SYMBOLS (IL:SYM IL:P)
(DOLIST (IL:P IL:USE-LIST) (MULTIPLE-VALUE-BIND (IL:S IL:W)
(DO-EXTERNAL-SYMBOLS (IL:FIND-EXTERNAL-SYMBOL (SYMBOL-NAME IL:SYM)
(IL:SYM IL:P) IL:PKG)
(MULTIPLE-VALUE-BIND (IL:S IL:W) (WHEN (AND IL:W (NOT (EQ IL:S IL:SYM))
(IL:FIND-EXTERNAL-SYMBOL (SYMBOL-NAME IL:SYM) (NOT (IL:FMEMB (INTERN (SYMBOL-NAME IL:SYM)
IL:PKG) PACKAGE)
(WHEN (AND IL:W (NOT (EQ IL:S IL:SYM)) IL:SHADOWING-SYMBOLS)))
(NOT (IL:FMEMB (INTERN (SYMBOL-NAME IL:SYM) (PUSHNEW IL:SYM IL:CSET :TEST 'EQ))))))
PACKAGE)
(T (DO-EXTERNAL-SYMBOLS (IL:SYM IL:PKG) (T (DO-EXTERNAL-SYMBOLS (IL:SYM IL:PKG)
(MULTIPLE-VALUE-BIND (IL:S IL:W) (MULTIPLE-VALUE-BIND (IL:S IL:W)
(FIND-SYMBOL (SYMBOL-NAME IL:SYM) (FIND-SYMBOL (SYMBOL-NAME IL:SYM)
@@ -800,7 +926,7 @@
(UNLESS (AND IL:W (EQ IL:S IL:SYM)) (UNLESS (AND IL:W (EQ IL:S IL:SYM))
(WHEN (OR (EQ IL:W :INTERNAL) (WHEN (OR (EQ IL:W :INTERNAL)
(EQ IL:W :EXTERNAL)) (IL:* IL:\; (EQ IL:W :EXTERNAL)) (IL:* IL:\;
(WHEN (OR (EQ IL:W :INTERNAL)  " If it was shadowed, we don't want Unintern to fail")
(SETF (%PACKAGE-SHADOWING-SYMBOLS PACKAGE) (SETF (%PACKAGE-SHADOWING-SYMBOLS PACKAGE)
(DELETE IL:S (%PACKAGE-SHADOWING-SYMBOLS PACKAGE))) (DELETE IL:S (%PACKAGE-SHADOWING-SYMBOLS PACKAGE)))
(UNINTERN IL:S PACKAGE)) (UNINTERN IL:S PACKAGE))
@@ -873,7 +999,7 @@
(SXHASH (IL:SYMBOL-HASH IL:SYMBOL-BASE 1 IL:SYMBOL-LENGTH IL:SYMBOL-FATP)) (SXHASH (IL:SYMBOL-HASH IL:SYMBOL-BASE 1 IL:SYMBOL-LENGTH IL:SYMBOL-FATP))
(IL:H2 (IL:REHASH-FACTOR SXHASH IL:LEN))) (IL:H2 (IL:REHASH-FACTOR SXHASH IL:LEN)))
(DECLARE (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 32)) (DECLARE (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 32))
(IL:H2 (IL:REHASH-FACTOR SXHASH IL:LEN))) IL:VEC)
(TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 8)) (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 8))
IL:HASH)) IL:HASH))
(COND (COND
@@ -886,7 +1012,7 @@
((>= IL:SIZE IL:HASHTABLE-SIZE-LIMIT) ((>= IL:SIZE IL:HASHTABLE-SIZE-LIMIT)
(IL:* IL:|;;| (IL:* IL:|;;|
 "We've spilled over into needing the list-of-tables feature, so add to the list.")
(IL:SETQ IL:VEC (IL:NCONC1 IL:VEC (MAKE-ARRAY IL:LEN :ELEMENT-TYPE (IL:SETQ IL:VEC (IL:NCONC1 IL:VEC (MAKE-ARRAY IL:LEN :ELEMENT-TYPE
'(UNSIGNED-BYTE 32)))) '(UNSIGNED-BYTE 32))))
@@ -898,7 +1024,7 @@
(IL:ADD-SYMBOL IL:TABLE SYMBOL)) (IL:ADD-SYMBOL IL:TABLE SYMBOL))
(T (T
(IL:* IL:|;;| (IL:* IL:|;;|
(T  "The initial table is still smaller than the limit. Increase its size.")
(LET ((IL:SIZE (PACKAGE-HASHTABLE-SIZE IL:TABLE)) (LET ((IL:SIZE (PACKAGE-HASHTABLE-SIZE IL:TABLE))
(IL:VEC1 (CAR IL:VEC)) (IL:VEC1 (CAR IL:VEC))
@@ -909,8 +1035,7 @@
(DOTIMES (IL:I IL:LEN) (DOTIMES (IL:I IL:LEN)
(WHEN (IL:IGREATERP (AREF IL:HASH1 IL:I) (WHEN (IL:IGREATERP (AREF IL:HASH1 IL:I)
1) 1)
(WHEN (IL:IGREATERP (AREF IL:HASH1 IL:I) (IL:ADD-SYMBOL IL:TABLE (IL:\\INDEXATOMPNAME (AREF IL:VEC1 IL:I))))))
1)
))) )))
(T (LET ((IL:THIS-HASH (CAR (IL:FLAST IL:HASH))) (T (LET ((IL:THIS-HASH (CAR (IL:FLAST IL:HASH)))
(IL:THIS-VEC (CAR (IL:FLAST IL:VEC)))) (IL:THIS-VEC (CAR (IL:FLAST IL:VEC))))
@@ -926,10 +1051,9 @@
(SETF (AREF IL:THIS-HASH IL:I) (SETF (AREF IL:THIS-HASH IL:I)
(IL:ENTRY-HASH IL:SYMBOL-LENGTH SXHASH))))))))) (IL:ENTRY-HASH IL:SYMBOL-LENGTH SXHASH)))))))))
(IL:ENTRY-HASH IL:SYMBOL-LENGTH SXHASH))))))))) (DEFMACRO IL:WITH-SYMBOL ((IL:INDEX-VAR IL:SYMBOL-VAR IL:TABLE IL:BASE IL:OFFSET IL:LENGTH IL:FATP
SXHASH IL:ENTRY-HASH IL:HASH-TABLE-TABLE IL:HASH-TABLE-HASH)
(DEFMACRO IL:WITH-SYMBOL ((IL:INDEX-VAR IL:SYMBOL-VAR IL:TABLE IL:BASE IL:OFFSET IL:LENGTH &BODY IL:FORMS)
IL:FATP SXHASH IL:ENTRY-HASH IL:HASH-TABLE-TABLE
"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." "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."
(LET ((IL:VEC (OR IL:HASH-TABLE-TABLE (IL:GENSYM))) (LET ((IL:VEC (OR IL:HASH-TABLE-TABLE (IL:GENSYM)))
(IL:HASH (OR IL:HASH-TABLE-HASH (IL:GENSYM))) (IL:HASH (OR IL:HASH-TABLE-HASH (IL:GENSYM)))
@@ -947,7 +1071,7 @@
,IL:HASH ,IL:HASH
,IL:LIMIT) ,IL:LIMIT)
(DECLARE (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 8)) (DECLARE (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 8))
,IL:LIMIT) ,IL:HASH)
(TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 32)) (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 32))
,IL:VEC)) ,IL:VEC))
(PROG (,IL:INDEX-VAR ,IL:SYMBOL-VAR ,IL:EHASH) (PROG (,IL:INDEX-VAR ,IL:SYMBOL-VAR ,IL:EHASH)
@@ -955,9 +1079,8 @@
(IL:* IL:|;;| "Loop thru all the hash tables looking for the symbol.") (IL:* IL:|;;| "Loop thru all the hash tables looking for the symbol.")
IL:OUTER-LOOP IL:OUTER-LOOP
(IL:SETQ ,IL:HASH (IL:POP ,IL:HASHS)) (IL:* IL:\; "Hashvalues")
IL:OUTER-LOOP (IL:SETQ ,IL:VEC (IL:POP ,IL:VECS)) (IL:* IL:\; "The symbol vector")
(IL:SETQ ,IL:HASH (IL:POP ,IL:HASHS))
(IL:SETQ ,IL:INDEX-VAR (IL:IREMAINDER ,SXHASH ,IL:LEN)) (IL:SETQ ,IL:INDEX-VAR (IL:IREMAINDER ,SXHASH ,IL:LEN))
(IL:* IL:\; "Starting probe.") (IL:* IL:\; "Starting probe.")
(IL:SETQ ,IL:LIMIT ,IL:LEN) (IL:SETQ ,IL:LIMIT ,IL:LEN)
@@ -972,37 +1095,34 @@
(IL:* IL:|;;| "SIngle-byte hash matches; try the whole name.") (IL:* IL:|;;| "SIngle-byte hash matches; try the whole name.")
(IL:* IL:|;;| "SIngle-byte hash matches; try the whole name.") (IL:SETQ ,IL:SYMBOL-VAR (IL:\\INDEXATOMPNAME (AREF ,IL:VEC ,IL:INDEX-VAR)))
(WHEN (IL:\\SYMBOL-EQUALBASE ,IL:SYMBOL-VAR ,IL:BASE ,IL:OFFSET ,IL:LENGTH
(IL:SETQ ,IL:SYMBOL-VAR (IL:\\INDEXATOMPNAME (AREF ,IL:VEC
,IL:INDEX-VAR)))
,IL:FATP) ,IL:FATP)
(GO IL:DOIT))) (GO IL:DOIT)))
((EQL 0 ,IL:EHASH) (IL:* IL:\; ((EQL 0 ,IL:EHASH) (IL:* IL:\;
(GO IL:DOIT)))  "Found an empty hash slot, so it's not in this table.")
(COND (COND
((NULL ,IL:HASHS) ((NULL ,IL:HASHS)
(IL:* IL:|;;| (IL:* IL:|;;|
 "we've run out of sub-tables to look in. Give the we-couldn't-find-it signal.")
(IL:SETQ ,IL:INDEX-VAR NIL) (IL:SETQ ,IL:INDEX-VAR NIL)
(GO IL:DOIT)) (GO IL:DOIT))
(T (GO IL:OUTER-LOOP)))) (T (GO IL:OUTER-LOOP))))
((EQL 0 (IL:SETQ ,IL:LIMIT (IL:SUB1 ,IL:LIMIT))) ((EQL 0 (IL:SETQ ,IL:LIMIT (IL:SUB1 ,IL:LIMIT)))
(IL:* IL:\; (IL:* IL:\;
((EQL 0 (IL:SETQ ,IL:LIMIT (IL:SUB1 ,IL:LIMIT)))  "We.ve been thru the whole table, so it's not in this table.")
(COND (COND
((NULL ,IL:HASHS) ((NULL ,IL:HASHS)
(IL:* IL:|;;| (IL:* IL:|;;|
 "we've run out of sub-tables to look in. Give the we-couldn't-find-it signal.")
(IL:SETQ ,IL:INDEX-VAR NIL) (IL:SETQ ,IL:INDEX-VAR NIL)
(GO IL:DOIT)) (GO IL:DOIT))
(T (GO IL:OUTER-LOOP))))) (T (GO IL:OUTER-LOOP)))))
(GO IL:DOIT)) (IL:SETQ ,IL:INDEX-VAR (IL:SYMBOL-HASH-REPROBE ,IL:INDEX-VAR ,IL:H2 ,IL:LEN))
(T (GO IL:OUTER-LOOP)))))
(GO LOOP) (GO LOOP)
IL:DOIT IL:DOIT
(RETURN (PROGN ,@IL:FORMS)))))) (RETURN (PROGN ,@IL:FORMS))))))
@@ -1051,12 +1171,12 @@
(IL:SETQ IL:WHERE :INTERNAL) (IL:SETQ IL:WHERE :INTERNAL)
(IL:SETQ IL:DONE T)))) (IL:SETQ IL:DONE T))))
(IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-INTERNAL-SYMBOLS PACKAGE) (IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-INTERNAL-SYMBOLS PACKAGE)
(IL:SETQ IL:DONE T)))) IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH IL:EHASH NIL
(IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-INTERNAL-SYMBOLS PACKAGE) NIL)
(WHEN IL:FOUND (WHEN IL:FOUND
(IL:* IL:|;;| (IL:* IL:|;;|
 "Was (cl:return-from find-symbol* (cl:values cl:symbol :internal))")
(IL:SETQ IL:WHERE :INTERNAL) (IL:SETQ IL:WHERE :INTERNAL)
(IL:SETQ IL:DONE T))))) (IL:SETQ IL:DONE T)))))
@@ -1071,12 +1191,12 @@
(IL:SETQ IL:WHERE :EXTERNAL) (IL:SETQ IL:WHERE :EXTERNAL)
(IL:SETQ IL:DONE T)))) (IL:SETQ IL:DONE T))))
(IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE) (IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)
(IL:SETQ IL:DONE T)))) IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH IL:EHASH NIL
(IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE) NIL)
(WHEN IL:FOUND (WHEN IL:FOUND
(IL:* IL:|;;| (IL:* IL:|;;|
 "Was (cl:return-from find-symbol* (cl:values cl:symbol :external))")
(IL:SETQ IL:SYM SYMBOL) (IL:SETQ IL:SYM SYMBOL)
(IL:SETQ IL:WHERE :EXTERNAL) (IL:SETQ IL:WHERE :EXTERNAL)
@@ -1101,13 +1221,13 @@
IL:TABLE)) IL:TABLE))
(IL:* IL:|;;| (IL:* IL:|;;|
 "Was (cl:return-from find-symbol* (cl:values cl:symbol :inherited))")
(IL:SETQ IL:WHERE :INHERITED) (IL:SETQ IL:WHERE :INHERITED)
(IL:SETQ IL:DONE T)))) (IL:SETQ IL:DONE T))))
(IL:WITH-SYMBOL (IL:FOUND SYMBOL (CAR IL:TABLE) (IL:WITH-SYMBOL (IL:FOUND SYMBOL (CAR IL:TABLE)
(IL:SETQ IL:DONE T)))) IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH
(IL:WITH-SYMBOL (IL:FOUND SYMBOL (CAR IL:TABLE) IL:EHASH NIL NIL)
(WHEN IL:FOUND (WHEN IL:FOUND
(UNLESS (EQ IL:PREV IL:HEAD) (UNLESS (EQ IL:PREV IL:HEAD)
(SHIFTF (CDR IL:PREV) (SHIFTF (CDR IL:PREV)
@@ -1116,7 +1236,7 @@
IL:TABLE)) IL:TABLE))
(IL:* IL:|;;| (IL:* IL:|;;|
 "Was (cl:return-from find-symbol* (cl:values cl:symbol :inherited))")
(IL:SETQ IL:SYM SYMBOL) (IL:SETQ IL:SYM SYMBOL)
(IL:SETQ IL:WHERE :INHERITED) (IL:SETQ IL:WHERE :INHERITED)
@@ -1134,17 +1254,17 @@
(T (IL:ERROR "Not a string " IL:NAME)))) (T (IL:ERROR "Not a string " IL:NAME))))
(COND (COND
((NULL PACKAGE) (IL:* IL:\; ((NULL PACKAGE) (IL:* IL:\;
(COND  "XCL extension, makes uninterned symbols")
(MAKE-SYMBOL IL:NAME)) (MAKE-SYMBOL IL:NAME))
(T (IL:* IL:\; (T (IL:* IL:\;
(MAKE-SYMBOL IL:NAME))  "Package is at least non-null")
(IL:SETQ PACKAGE (IL:\\PACKAGIFY PACKAGE)) (IL:SETQ PACKAGE (IL:\\PACKAGIFY PACKAGE))
(LET ((IL:BASE (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| IL:NAME)) (LET ((IL:BASE (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| IL:NAME))
(IL:OFFSET (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| IL:NAME)) (IL:OFFSET (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| IL:NAME))
(IL:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| IL:NAME)) (IL:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| IL:NAME))
(IL:FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| IL:NAME))) (IL:FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| IL:NAME)))
(IL:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| IL:NAME)) (IL:INTERN* IL:BASE IL:OFFSET IL:LENGTH IL:FATP (IL:\\FATCHARSEENP IL:BASE IL:OFFSET
(IL:FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| IL:NAME))) IL:LENGTH IL:FATP)
PACKAGE NIL))))) PACKAGE NIL)))))
(DEFUN FIND-SYMBOL (IL:NAME &OPTIONAL (PACKAGE *PACKAGE*)) (DEFUN FIND-SYMBOL (IL:NAME &OPTIONAL (PACKAGE *PACKAGE*))
@@ -1173,7 +1293,7 @@
(IL:HASH (IL:SYMBOL-HASH IL:BASE IL:OFFSET IL:LENGTH IL:FATP)) (IL:HASH (IL:SYMBOL-HASH IL:BASE IL:OFFSET IL:LENGTH IL:FATP))
(IL:EHASH (IL:ENTRY-HASH IL:LENGTH IL:HASH))) (IL:EHASH (IL:ENTRY-HASH IL:LENGTH IL:HASH)))
(IL:WITH-SYMBOL (IL:INDEX SYMBOL IL:TABLE IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH (IL:WITH-SYMBOL (IL:INDEX SYMBOL IL:TABLE IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH
(IL:EHASH (IL:ENTRY-HASH IL:LENGTH IL:HASH))) IL:EHASH NIL IL:TABLE-HASH)
(SETF (AREF IL:TABLE-HASH IL:INDEX) (SETF (AREF IL:TABLE-HASH IL:INDEX)
1) 1)
(INCF (PACKAGE-HASHTABLE-DELETED IL:TABLE))))) (INCF (PACKAGE-HASHTABLE-DELETED IL:TABLE)))))
@@ -1196,7 +1316,7 @@
(IL:FIND-EXTERNAL-SYMBOL IL:NAME IL:P) (IL:FIND-EXTERNAL-SYMBOL IL:NAME IL:P)
(WHEN IL:W (PUSHNEW IL:S IL:CSET)))) (WHEN IL:W (PUSHNEW IL:S IL:CSET))))
(WHEN (CDR IL:CSET) (IL:* IL:\; (WHEN (CDR IL:CSET) (IL:* IL:\;
(WHEN IL:W (PUSHNEW IL:S IL:CSET))))  "If there is more than one, handle the conflict")
(IL:RESOLVE-UNINTERN-CONFLICT SYMBOL IL:CSET PACKAGE))) (IL:RESOLVE-UNINTERN-CONFLICT SYMBOL IL:CSET PACKAGE)))
(SETF (%PACKAGE-SHADOWING-SYMBOLS PACKAGE) (SETF (%PACKAGE-SHADOWING-SYMBOLS PACKAGE)
(DELETE SYMBOL IL:SHADOWING-SYMBOLS :TEST #'EQ))) (DELETE SYMBOL IL:SHADOWING-SYMBOLS :TEST #'EQ)))
@@ -1207,8 +1327,8 @@
(OR (EQ IL:W :INTERNAL) (OR (EQ IL:W :INTERNAL)
(EQ IL:W :EXTERNAL))) (EQ IL:W :EXTERNAL)))
(IL:NUKE-SYMBOL (IF (EQ IL:W :INTERNAL) (IL:NUKE-SYMBOL (IF (EQ IL:W :INTERNAL)
(EQ IL:W :EXTERNAL))) (%PACKAGE-INTERNAL-SYMBOLS PACKAGE)
(IL:NUKE-SYMBOL (IF (EQ IL:W :INTERNAL) (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE))
IL:NAME) IL:NAME)
(IF (EQ (SYMBOL-PACKAGE SYMBOL) (IF (EQ (SYMBOL-PACKAGE SYMBOL)
PACKAGE) PACKAGE)
@@ -1291,9 +1411,9 @@
) )
(DEFMACRO DO-EXTERNAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*) (DEFMACRO DO-EXTERNAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*)
IL:RESULT-FORM)
(DEFMACRO DO-EXTERNAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*) &BODY
IL:RESULT-FORM) (IL:CODE IL:DECLS))
"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." "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 ((IL:VARS (IL:MAKE-DO-SYMBOLS-VARS))) (LET ((IL:VARS (IL:MAKE-DO-SYMBOLS-VARS)))
`(PROG (,IL:VAR ,@IL:VARS) `(PROG (,IL:VAR ,@IL:VARS)
@@ -1304,9 +1424,9 @@
IL:CODE)))) IL:CODE))))
(DEFMACRO XCL:DO-LOCAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*) (DEFMACRO XCL:DO-LOCAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*)
IL:RESULT-FORM)
(DEFMACRO XCL:DO-LOCAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*) &BODY
IL:RESULT-FORM) (IL:CODE IL:DECLS))
"Do-Local-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* Executes the Forms at least once for each symbol actually in the given Package with Var bound to the current symbol." "Do-Local-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* Executes the Forms at least once for each symbol actually in the given Package with Var bound to the current symbol."
(LET* ((IL:DONE-INTERNAL (IL:GENSYM)) (LET* ((IL:DONE-INTERNAL (IL:GENSYM))
(IL:DONE-EXTERNAL (IL:GENSYM)) (IL:DONE-EXTERNAL (IL:GENSYM))
@@ -1318,13 +1438,11 @@
,@IL:DECLS ,@IL:DECLS
(WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE) (WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE)
(GO ,IL:DONE-INTERNAL)) (GO ,IL:DONE-INTERNAL))
(WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE) ,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS ,PACKAGE)
(GO ,IL:DONE-INTERNAL))
`(GO ,IL:DONE-INTERNAL) `(GO ,IL:DONE-INTERNAL)
IL:CODE) IL:CODE)
,IL:DONE-INTERNAL ,IL:DONE-INTERNAL
IL:CODE) ,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-EXTERNAL-SYMBOLS ,PACKAGE)
,IL:DONE-INTERNAL
`(GO ,IL:DONE-EXTERNAL) `(GO ,IL:DONE-EXTERNAL)
IL:CODE) IL:CODE)
,IL:DONE-EXTERNAL ,IL:DONE-EXTERNAL
@@ -1332,9 +1450,9 @@
(RETURN ,IL:RESULT-FORM)))) (RETURN ,IL:RESULT-FORM))))
(DEFMACRO XCL:DO-INTERNAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*) (DEFMACRO XCL:DO-INTERNAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*)
IL:RESULT-FORM)
(DEFMACRO XCL:DO-INTERNAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*) &BODY
IL:RESULT-FORM) (IL:CODE IL:DECLS))
"Do-Internal-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* Executes the Forms at least once for each symbol actually in the given Package and not exported with Var bound to the current symbol." "Do-Internal-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* Executes the Forms at least once for each symbol actually in the given Package and not exported with Var bound to the current symbol."
(LET* ((IL:DONE-INTERNAL (IL:GENSYM)) (LET* ((IL:DONE-INTERNAL (IL:GENSYM))
(IL:VARS (IL:MAKE-DO-SYMBOLS-VARS)) (IL:VARS (IL:MAKE-DO-SYMBOLS-VARS))
@@ -1345,8 +1463,7 @@
,@IL:DECLS ,@IL:DECLS
(WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE) (WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE)
(GO ,IL:DONE-INTERNAL)) (GO ,IL:DONE-INTERNAL))
(WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE) ,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS ,PACKAGE)
(GO ,IL:DONE-INTERNAL))
`(GO ,IL:DONE-INTERNAL) `(GO ,IL:DONE-INTERNAL)
IL:CODE) IL:CODE)
,IL:DONE-INTERNAL ,IL:DONE-INTERNAL
@@ -1354,9 +1471,9 @@
(RETURN ,IL:RESULT-FORM)))) (RETURN ,IL:RESULT-FORM))))
(DEFMACRO DO-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*) (DEFMACRO DO-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*)
IL:RESULT-FORM)
(DEFMACRO DO-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*) &BODY
IL:RESULT-FORM) (IL:CODE IL:DECLS))
"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." "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* ((IL:DONE-INTERNAL (IL:GENSYM)) (LET* ((IL:DONE-INTERNAL (IL:GENSYM))
(IL:DONE-EXTERNAL (IL:GENSYM)) (IL:DONE-EXTERNAL (IL:GENSYM))
@@ -1375,13 +1492,11 @@
,@IL:DECLS ,@IL:DECLS
(WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE) (WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE)
(GO ,IL:DONE-INTERNAL)) (GO ,IL:DONE-INTERNAL))
(WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE) ,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS ,PACKAGE)
(GO ,IL:DONE-INTERNAL))
`(GO ,IL:DONE-INTERNAL) `(GO ,IL:DONE-INTERNAL)
IL:CODE) IL:CODE)
,IL:DONE-INTERNAL ,IL:DONE-INTERNAL
IL:CODE) ,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-EXTERNAL-SYMBOLS ,PACKAGE)
,IL:DONE-INTERNAL
`(GO ,IL:DONE-EXTERNAL) `(GO ,IL:DONE-EXTERNAL)
IL:CODE) IL:CODE)
,IL:DONE-EXTERNAL ,IL:DONE-EXTERNAL
@@ -1390,29 +1505,29 @@
(IL:SETQ ,IL:VAR NIL) (IL:SETQ ,IL:VAR NIL)
(RETURN ,IL:RESULT-FORM)) (RETURN ,IL:RESULT-FORM))
(IL:SETQ ,IL:THIS-INHERIT (CAR ,IL:INHERITS)) (IL:SETQ ,IL:THIS-INHERIT (CAR ,IL:INHERITS))
(RETURN ,IL:RESULT-FORM)) ,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR IL:THIS-INHERIT
(IL:SETQ ,IL:THIS-INHERIT (CAR ,IL:INHERITS)) `(PROGN (IL:SETQ ,IL:INHERITS (CDR ,IL:INHERITS))
,@(IL:MAKE-DO-SYMBOLS-CODE (GO ,IL:NEXT-INHERIT))
IL:VARS IL:VAR IL:THIS-INHERIT `(PROGN (IL:SETQ ,IL:INHERITS (CDR ,IL:INHERITS)) `((WHEN (OR (NOT ,IL:SHADOWED)
(GO ,IL:NEXT-INHERIT)) (EQ (FIND-SYMBOL (SYMBOL-NAME ,IL:VAR)
`((WHEN (OR (NOT ,IL:SHADOWED) ,IL:N-PACKAGE)
(EQ (FIND-SYMBOL (SYMBOL-NAME ,IL:VAR) ,IL:VAR))
,IL:N-PACKAGE) ,@IL:CODE))))))
(DEFMACRO DO-ALL-SYMBOLS ((IL:VAR &OPTIONAL IL:RESULT-FORM) (DEFMACRO DO-ALL-SYMBOLS ((IL:VAR &OPTIONAL IL:RESULT-FORM)
&BODY
(DEFMACRO DO-ALL-SYMBOLS ((IL:VAR &OPTIONAL IL:RESULT-FORM) (IL:CODE IL:DECLS))
"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." "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* ((IL:PACKAGE-LOOP (IL:GENSYM)) (LET* ((IL:PACKAGE-LOOP (IL:GENSYM))
(IL:TAG (IL:GENSYM)) (IL:TAG (IL:GENSYM))
(IL:PACKAGE-LIST (IL:GENSYM)) (IL:PACKAGE-LIST (IL:GENSYM))
(IL:VARS (IL:MAKE-DO-SYMBOLS-VARS)) (IL:VARS (IL:MAKE-DO-SYMBOLS-VARS))
(IL:PACKAGE-LIST (IL:GENSYM)) (IL:INTERNAL-CODE (IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS
(IL:VARS (IL:MAKE-DO-SYMBOLS-VARS)) (CAR ,IL:PACKAGE-LIST))
`(GO ,IL:TAG) `(GO ,IL:TAG)
IL:CODE)) IL:CODE))
`(GO ,IL:TAG) (IL:EXTERNAL-CODE (IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-EXTERNAL-SYMBOLS
IL:CODE)) (CAR ,IL:PACKAGE-LIST))
`(PROGN (IL:SETQ ,IL:PACKAGE-LIST (CDR ,IL:PACKAGE-LIST)) `(PROGN (IL:SETQ ,IL:PACKAGE-LIST (CDR ,IL:PACKAGE-LIST))
(GO ,IL:PACKAGE-LOOP)) (GO ,IL:PACKAGE-LOOP))
IL:CODE))) IL:CODE)))
@@ -1494,12 +1609,10 @@
(LET ((PACKAGE (IL:\\PACKAGIFY PACKAGE))) (LET ((PACKAGE (IL:\\PACKAGIFY PACKAGE)))
(IF IL:EXTERNAL-ONLY (IF IL:EXTERNAL-ONLY
(DO-EXTERNAL-SYMBOLS (SYMBOL PACKAGE) (DO-EXTERNAL-SYMBOLS (SYMBOL PACKAGE)
(IF IL:EXTERNAL-ONLY (IF (IL:APROPOS-SEARCH SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP)
(DO-EXTERNAL-SYMBOLS (SYMBOL PACKAGE)
(PUSH SYMBOL LIST))) (PUSH SYMBOL LIST)))
(DO-SYMBOLS (SYMBOL PACKAGE) (DO-SYMBOLS (SYMBOL PACKAGE)
(PUSH SYMBOL LIST))) (IF (IL:APROPOS-SEARCH SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP)
(DO-SYMBOLS (SYMBOL PACKAGE)
(PUSH SYMBOL LIST))))))) (PUSH SYMBOL LIST)))))))
LIST)) LIST))
@@ -1510,7 +1623,7 @@
(DEFUN IL:FIND-EXTERNAL-SYMBOL (STRING PACKAGE) (DEFUN IL:FIND-EXTERNAL-SYMBOL (STRING PACKAGE)
(IL:SETQ STRING (IL:MKSTRING STRING)) (IL:* IL:\; (IL:SETQ STRING (IL:MKSTRING STRING)) (IL:* IL:\;
(DEFUN IL:FIND-EXTERNAL-SYMBOL (STRING PACKAGE)  "Convert symbols to strings (for the reader)")
(LET* ((IL:BASE (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| STRING)) (LET* ((IL:BASE (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| STRING))
(IL:OFFSET (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| STRING)) (IL:OFFSET (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| STRING))
(IL:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| STRING)) (IL:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| STRING))
@@ -1526,8 +1639,7 @@
IL:RESULT)) IL:RESULT))
(VALUES IL:SYM (NOT (IL:IEQP IL:RESULT -1)))) (VALUES IL:SYM (NOT (IL:IEQP IL:RESULT -1))))
(IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE) (IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)
(VALUES IL:SYM (NOT (IL:IEQP IL:RESULT -1)))) IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH IL:EHASH NIL NIL)
(IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)
(VALUES SYMBOL IL:FOUND))))) (VALUES SYMBOL IL:FOUND)))))
(DEFUN IL:FIND-EXACT-SYMBOL (SYMBOL PACKAGE) (DEFUN IL:FIND-EXACT-SYMBOL (SYMBOL PACKAGE)
@@ -1562,32 +1674,40 @@
(IL:ADDTOVAR IL:LAMA ) (IL:ADDTOVAR IL:LAMA )
) )
(IL:ADDTOVAR IL:LAMA )
(IL:DECLARE\: IL:DONTCOPY (IL:DECLARE\: IL:DONTCOPY
(IL:PUTPROPS IL:LLPACKAGE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1992)) (IL:FILEMAP (NIL (5304 5829 (IL:PACKAGE-LISTIFY 5304 . 5829)) (5831 6219 (IL:\\SIMPLE-STRINGIFY 5831
(IL:DECLARE\: IL:DONTCOPY . 6219)) (6221 6713 (IL:SYMBOL-LISTIFY 6221 . 6713)) (6715 6777 (IL:COPY-STRING 6715 . 6777)) (6779
(IL:FILEMAP (NIL (9779 10219 (IL:\\UPCASEBASE 9779 . 10219)) (10221 11342 (IL:APROPOS-SEARCH 10221 . 7517 (IL:\\SYMBOL-EQUALBASE 6779 . 7517)) (7521 7957 (IL:\\FATCHARSEENP 7521 . 7957)) (7959 8487 (
11342)) (12882 12964 (PACKAGE-NAME 12882 . 12964)) (12966 13058 (PACKAGE-NICKNAMES 12966 . 13058)) ( IL:\\PACKAGIFY 7959 . 8487)) (8489 9526 (IL:\\STRING-EQUALBASE 8489 . 9526)) (9528 9752 (
13060 13168 (PACKAGE-SHADOWING-SYMBOLS 13060 . 13168)) (13170 13260 (PACKAGE-USE-LIST 13170 . 13260)) IL:NUMERIC-UPCASE 9528 . 9752)) (9754 10111 (IL:\\UPCASEBASE 9754 . 10111)) (10113 11230 (
(13262 13360 (PACKAGE-USED-BY-LIST 13262 . 13360)) (13362 14517 (IL:MAKE-PACKAGE-HASHTABLE 13362 . IL:APROPOS-SEARCH 10113 . 11230)) (12750 12832 (PACKAGE-NAME 12750 . 12832)) (12834 12926 (
14517)) (14519 14681 (PRINT-PACKAGE 14519 . 14681)) (14683 15074 (PRINT-PACKAGE-HASHTABLE 14683 . PACKAGE-NICKNAMES 12834 . 12926)) (12928 13036 (PACKAGE-SHADOWING-SYMBOLS 12928 . 13036)) (13038 13128
15074)) (16142 16923 (MAKE-SYMBOL 16142 . 16923)) (18034 18444 (IL:\\PKG-FIND-FREE-PACKAGE-INDEX 18034 (PACKAGE-USE-LIST 13038 . 13128)) (13130 13228 (PACKAGE-USED-BY-LIST 13130 . 13228)) (13230 14385 (
. 18444)) (18501 18647 (IL:SETF-SYMBOL-PACKAGE 18501 . 18647)) (18649 18741 (SYMBOL-PACKAGE 18649 . IL:MAKE-PACKAGE-HASHTABLE 13230 . 14385)) (14387 14549 (PRINT-PACKAGE 14387 . 14549)) (14551 14942 (
18741)) (21512 21684 (IL:INTERNAL-SYMBOL-COUNT 21512 . 21684)) (21686 21804 (IL:EXTERNAL-SYMBOL-COUNT PRINT-PACKAGE-HASHTABLE 14551 . 14942)) (16006 16787 (MAKE-SYMBOL 16006 . 16787)) (17838 18248 (
21686 . 21804)) (21806 22962 (IL:ENTER-NEW-NICKNAMES 21806 . 22962)) (22964 23390 ( IL:\\PKG-FIND-FREE-PACKAGE-INDEX 17838 . 18248)) (18305 18451 (IL:SETF-SYMBOL-PACKAGE 18305 . 18451))
IL:MAKE-PRIME-HASHTABLE-SIZE 22964 . 23390)) (23392 25061 (MAKE-PACKAGE 23392 . 25061)) (25062 28355 ( (18453 18545 (SYMBOL-PACKAGE 18453 . 18545)) (18587 20224 (IL:SYMBOL-HASH 18587 . 20224)) (20226 20358
XCL:DEFPACKAGE 25075 . 28353)) (28404 28626 (FIND-PACKAGE 28404 . 28626)) (28628 31966 (USE-PACKAGE (IL:REHASH-FACTOR 20226 . 20358)) (20360 20526 (IL:SYMBOL-HASH-REPROBE 20360 . 20526)) (20528 20919 (
28628 . 31966)) (31968 32448 (IN-PACKAGE 31968 . 32448)) (32450 32724 (XCL:PKG-GOTO 32450 . 32724)) ( IL:ENTRY-HASH 20528 . 20919)) (20968 21314 (IL:COUNT-PACKAGE-HASHTABLE 20968 . 21314)) (21316 21488 (
32726 33826 (RENAME-PACKAGE 32726 . 33826)) (33828 35279 (XCL:DELETE-PACKAGE 33828 . 35279)) (35281 IL:INTERNAL-SYMBOL-COUNT 21316 . 21488)) (21490 21608 (IL:EXTERNAL-SYMBOL-COUNT 21490 . 21608)) (21610
38227 (EXPORT 35281 . 38227)) (38229 39472 (UNEXPORT 38229 . 39472)) (39474 41118 (IMPORT 39474 . 22766 (IL:ENTER-NEW-NICKNAMES 21610 . 22766)) (22768 23194 (IL:MAKE-PRIME-HASHTABLE-SIZE 22768 .
41118)) (41120 42398 (SHADOWING-IMPORT 41120 . 42398)) (42400 43454 (SHADOW 42400 . 43454)) (43456 23194)) (23196 24845 (MAKE-PACKAGE 23196 . 24845)) (24846 34317 (XCL:DEFPACKAGE 24859 . 34315)) (34366
44111 (UNUSE-PACKAGE 43456 . 44111)) (44175 44481 (LIST-ALL-PACKAGES 44175 . 44481)) (44538 48313 ( 34588 (FIND-PACKAGE 34366 . 34588)) (34590 37951 (USE-PACKAGE 34590 . 37951)) (37953 38433 (
IL:ADD-SYMBOL 44538 . 48313)) (52637 53940 (IL:INTERN* 52637 . 53940)) (53942 59790 (IL:FIND-SYMBOL* IN-PACKAGE 37953 . 38433)) (38435 38709 (XCL:PKG-GOTO 38435 . 38709)) (38711 39811 (RENAME-PACKAGE
53942 . 59790)) (59792 61243 (INTERN 59792 . 61243)) (61245 61823 (FIND-SYMBOL 61245 . 61823)) (61881 38711 . 39811)) (39813 41264 (XCL:DELETE-PACKAGE 39813 . 41264)) (41266 44212 (EXPORT 41266 . 44212))
62781 (IL:NUKE-SYMBOL 61881 . 62781)) (62783 64903 (UNINTERN 62783 . 64903)) (64905 66048 ( (44214 45457 (UNEXPORT 44214 . 45457)) (45459 47103 (IMPORT 45459 . 47103)) (47105 48385 (
IL:MOBY-UNINTERN 64905 . 66048)) (66107 66179 (IL:\\INDEXATOMPNAME 66107 . 66179)) (66291 66438 ( SHADOWING-IMPORT 47105 . 48385)) (48387 49441 (SHADOW 48387 . 49441)) (49443 50098 (UNUSE-PACKAGE
IL:MAKE-DO-SYMBOLS-VARS 66291 . 66438)) (66440 67895 (IL:MAKE-DO-SYMBOLS-CODE 66440 . 67895)) (75495 49443 . 50098)) (50162 50468 (LIST-ALL-PACKAGES 50162 . 50468)) (50525 54208 (IL:ADD-SYMBOL 50525 .
76020 (FIND-ALL-SYMBOLS 75495 . 76020)) (76022 76301 (IL:BRIEFLY-DESCRIBE-SYMBOL 76022 . 76301)) ( 54208)) (54210 58263 (IL:WITH-SYMBOL 54210 . 58263)) (58265 59568 (IL:INTERN* 58265 . 59568)) (59570
76303 77817 (APROPOS 76303 . 77817)) (77819 79476 (APROPOS-LIST 77819 . 79476)) (79580 81153 ( 65402 (IL:FIND-SYMBOL* 59570 . 65402)) (65404 66855 (INTERN 65404 . 66855)) (66857 67435 (FIND-SYMBOL
IL:FIND-EXTERNAL-SYMBOL 79580 . 81153)) (81155 81675 (IL:FIND-EXACT-SYMBOL 81155 . 81675)) (81677 66857 . 67435)) (67493 68389 (IL:NUKE-SYMBOL 67493 . 68389)) (68391 70505 (UNINTERN 68391 . 70505)) (
70507 71650 (IL:MOBY-UNINTERN 70507 . 71650)) (71709 71781 (IL:\\INDEXATOMPNAME 71709 . 71781)) (71893
72040 (IL:MAKE-DO-SYMBOLS-VARS 71893 . 72040)) (72042 73497 (IL:MAKE-DO-SYMBOLS-CODE 72042 . 73497))
(73501 74279 (DO-EXTERNAL-SYMBOLS 73501 . 74279)) (74281 75627 (XCL:DO-LOCAL-SYMBOLS 74281 . 75627)) (
75629 76745 (XCL:DO-INTERNAL-SYMBOLS 75629 . 76745)) (76747 79045 (DO-SYMBOLS 76747 . 79045)) (79047
80729 (DO-ALL-SYMBOLS 79047 . 80729)) (80797 81322 (FIND-ALL-SYMBOLS 80797 . 81322)) (81324 81603 (
IL:BRIEFLY-DESCRIBE-SYMBOL 81324 . 81603)) (81605 83119 (APROPOS 81605 . 83119)) (83121 84688 (
APROPOS-LIST 83121 . 84688)) (84792 86319 (IL:FIND-EXTERNAL-SYMBOL 84792 . 86319)) (86321 86841 (
IL:FIND-EXACT-SYMBOL 86321 . 86841)) (86843 86923 (IL:PACKAGE-NAME-AS-SYMBOL 86843 . 86923)) (86925
87074 (IL:\\FIND.PACKAGE.INTERNAL 86925 . 87074)))))
IL:STOP IL:STOP

BIN
sources/LLPACKAGE.LCOM
View File

Binary file not shown.