Extend DEFPACKAGE to accept uninterned symbols as the names to export… (#1822)
…. 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
GitHub
commit
b41ae0cbbe
@ -1,15 +1,15 @@
|
||||
(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:RPAQQ IL:LLPACKAGECOMS
|
||||
@ -83,9 +83,9 @@
|
||||
|
||||
(IL:FUNCTIONS IL:\\INDEXATOMPNAME)
|
||||
(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:\;
|
||||
"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 DO-EXTERNAL-SYMBOLS XCL:DO-LOCAL-SYMBOLS XCL:DO-INTERNAL-SYMBOLS DO-SYMBOLS
|
||||
DO-ALL-SYMBOLS)
|
||||
@ -96,7 +96,7 @@
|
||||
(IL:FUNCTIONS IL:BRIEFLY-DESCRIBE-SYMBOL APROPOS APROPOS-LIST)
|
||||
|
||||
(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-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)
|
||||
`(AND ,IL:FATP (NOT (NULL (IL:FOR IL:I IL:FROM ,IL:OFFSET
|
||||
IL:TO (IL:SUB1 (IL:IPLUS ,IL:OFFSET ,IL:LEN))
|
||||
`(AND ,IL:FATP (NOT (NULL (IL:FOR IL:I IL:FROM ,IL:OFFSET IL:TO (IL:SUB1 (IL:IPLUS ,IL:OFFSET
|
||||
,IL:LEN))
|
||||
IL:SUCHTHAT (IL:IGREATERP (IL:\\GETBASEFAT ,IL:BASE IL:I)
|
||||
IL:\\MAXTHINCHAR))))))
|
||||
IL:\\MAXTHINCHAR))))))
|
||||
|
||||
(DEFMACRO IL:\\PACKAGIFY (IL:OBJ)
|
||||
"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)
|
||||
(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:FATP IL:BASE IL:I
|
||||
)))))
|
||||
IL:|do| (IL:\\PUTBASECHAR IL:FATP IL:BASE IL:I (IL:NUMERIC-UPCASE (IL:\\GETBASECHAR IL:FATP
|
||||
IL:BASE IL:I)))))
|
||||
|
||||
(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."
|
||||
@ -240,13 +239,13 @@
|
||||
T)
|
||||
(UNLESS (EQL (IL:\\GETBASECHAR IL:FATP IL:BASE IL:JNDEX)
|
||||
(IL:NUMERIC-UPCASE (IL:\\GETBASECHAR IL:SYMBOL-FATP IL:SYMBOL-BASE
|
||||
(IL:ADD1 IL:KNDEX))))
|
||||
(IL:ADD1 IL:KNDEX))))
|
||||
(RETURN NIL)))
|
||||
(RETURN T))))
|
||||
|
||||
(DEFSTRUCT (PACKAGE-HASHTABLE (:CONSTRUCTOR %MAKE-PACKAGE-HASHTABLE)
|
||||
(:COPIER NIL)
|
||||
(:PRINT-FUNCTION PRINT-PACKAGE-HASHTABLE))
|
||||
(:COPIER NIL)
|
||||
(: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."
|
||||
TABLE
|
||||
HASH
|
||||
@ -255,9 +254,9 @@
|
||||
DELETED)
|
||||
|
||||
(DEFSTRUCT (PACKAGE (:CONC-NAME %PACKAGE-)
|
||||
(:CONSTRUCTOR %MAKE-PACKAGE)
|
||||
(:PREDICATE PACKAGEP)
|
||||
(:PRINT-FUNCTION PRINT-PACKAGE))
|
||||
(:CONSTRUCTOR %MAKE-PACKAGE)
|
||||
(:PREDICATE PACKAGEP)
|
||||
(:PRINT-FUNCTION PRINT-PACKAGE))
|
||||
INDEX
|
||||
(TABLES (LIST NIL))
|
||||
NAME NAMESYMBOL NICKNAMES (USE-LIST NIL)
|
||||
@ -321,7 +320,7 @@
|
||||
"The current package, in which read symbols are intern'ed.")
|
||||
|
||||
(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
|
||||
"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:OFFST (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| IL:PRINT-NAME)))
|
||||
(IL:UNINTERRUPTABLY
|
||||
(IL:\\CREATE.SYMBOL IL:BASE IL:OFFST IL:LEN IL:FATP (IL:\\FATCHARSEENP IL:BASE
|
||||
IL:OFFST IL:LEN IL:FATP)))))
|
||||
(IL:\\CREATE.SYMBOL IL:BASE IL:OFFST IL:LEN IL:FATP (IL:\\FATCHARSEENP IL:BASE IL:OFFST
|
||||
IL:LEN IL:FATP)))))
|
||||
|
||||
|
||||
|
||||
@ -367,12 +366,11 @@
|
||||
)
|
||||
|
||||
|
||||
(XCL:DEFGLOBALVAR IL:*PACKAGE-FROM-NAME* (IL:HASHARRAY 255 'IL:ERROR 'IL:STRINGHASHBITS
|
||||
'IL:STREQUAL)
|
||||
"An equal hashtable from package names to packages.")
|
||||
(XCL:DEFGLOBALVAR IL:*PACKAGE-FROM-NAME* (IL:HASHARRAY 255 'IL:ERROR 'IL:STRINGHASHBITS 'IL:STREQUAL)
|
||||
"An equal hashtable from package names to packages.")
|
||||
|
||||
(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
|
||||
"The total number of packages that the system may have (excluding the 'uninterned' package).")
|
||||
@ -499,9 +497,9 @@
|
||||
(RETURN IL:X)))))
|
||||
|
||||
(DEFUN MAKE-PACKAGE (NAME &KEY (USE '("LISP"))
|
||||
NICKNAMES PREFIX-NAME (EXTERNAL-ONLY NIL)
|
||||
(INTERNAL-SYMBOLS 10)
|
||||
(EXTERNAL-SYMBOLS 10))
|
||||
NICKNAMES PREFIX-NAME (EXTERNAL-ONLY NIL)
|
||||
(INTERNAL-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."
|
||||
(DECLARE (SPECIAL IL:*PACKAGE-FROM-INDEX* IL:*PACKAGE-FROM-NAME*))
|
||||
(WHEN (FIND-PACKAGE NAME)
|
||||
@ -518,14 +516,143 @@
|
||||
:INDEX %PACKAGE-INDEX)))
|
||||
(USE-PACKAGE USE PACKAGE)
|
||||
(IL:ENTER-NEW-NICKNAMES PACKAGE (IF (IL:STREQUAL NAME (SYMBOL-NAME PREFIX-NAME))
|
||||
NICKNAMES
|
||||
(CONS PREFIX-NAME NICKNAMES)))
|
||||
NICKNAMES
|
||||
(CONS PREFIX-NAME NICKNAMES)))
|
||||
(IL:PUTHASH NAME PACKAGE IL:*PACKAGE-FROM-NAME*)
|
||||
(SETF (AREF IL:*PACKAGE-FROM-INDEX* %PACKAGE-INDEX)
|
||||
PACKAGE)))
|
||||
(IL:DEFINEQ
|
||||
|
||||
(xcl:defpackage
(il:nlambda il:args (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:symbol 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 (quote 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:symbol 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)))
)
|
||||
(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)))
|
||||
(PUSHNEW IL:SYM IL:CSET :TEST 'EQ))))
|
||||
(DOLIST (IL:P IL:USE-LIST)
|
||||
(DO-EXTERNAL-SYMBOLS
|
||||
(IL:SYM IL:P)
|
||||
(MULTIPLE-VALUE-BIND (IL:S IL:W)
|
||||
(IL:FIND-EXTERNAL-SYMBOL (SYMBOL-NAME IL:SYM)
|
||||
IL:PKG)
|
||||
(WHEN (AND IL:W (NOT (EQ IL:S IL:SYM))
|
||||
(NOT (IL:FMEMB (INTERN (SYMBOL-NAME IL:SYM)
|
||||
PACKAGE)
|
||||
IL:SHADOWING-SYMBOLS)))
|
||||
(PUSHNEW IL:SYM IL:CSET :TEST 'EQ))))))
|
||||
(DO-EXTERNAL-SYMBOLS (IL:SYM IL:P)
|
||||
(MULTIPLE-VALUE-BIND (IL:S IL:W)
|
||||
(IL:FIND-EXTERNAL-SYMBOL (SYMBOL-NAME IL:SYM)
|
||||
IL:PKG)
|
||||
(WHEN (AND IL:W (NOT (EQ IL:S IL:SYM))
|
||||
(NOT (IL:FMEMB (INTERN (SYMBOL-NAME IL:SYM)
|
||||
PACKAGE)
|
||||
IL:SHADOWING-SYMBOLS)))
|
||||
(PUSHNEW IL:SYM IL:CSET :TEST 'EQ))))))
|
||||
(T (DO-EXTERNAL-SYMBOLS (IL:SYM IL:PKG)
|
||||
(MULTIPLE-VALUE-BIND (IL:S IL:W)
|
||||
(FIND-SYMBOL (SYMBOL-NAME IL:SYM)
|
||||
@ -800,7 +926,7 @@
|
||||
(UNLESS (AND IL:W (EQ IL:S IL:SYM))
|
||||
(WHEN (OR (EQ IL:W :INTERNAL)
|
||||
(EQ IL:W :EXTERNAL)) (IL:* IL:\;
|
||||
" If it was shadowed, we don't want Unintern to fail")
|
||||
" If it was shadowed, we don't want Unintern to fail")
|
||||
(SETF (%PACKAGE-SHADOWING-SYMBOLS PACKAGE)
|
||||
(DELETE IL:S (%PACKAGE-SHADOWING-SYMBOLS PACKAGE)))
|
||||
(UNINTERN IL:S PACKAGE))
|
||||
@ -873,7 +999,7 @@
|
||||
(SXHASH (IL:SYMBOL-HASH IL:SYMBOL-BASE 1 IL:SYMBOL-LENGTH IL:SYMBOL-FATP))
|
||||
(IL:H2 (IL:REHASH-FACTOR SXHASH IL:LEN)))
|
||||
(DECLARE (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 32))
|
||||
IL:VEC)
|
||||
IL:VEC)
|
||||
(TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 8))
|
||||
IL:HASH))
|
||||
(COND
|
||||
@ -886,7 +1012,7 @@
|
||||
((>= IL:SIZE IL:HASHTABLE-SIZE-LIMIT)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"We've spilled over into needing the list-of-tables feature, so add to the list.")
|
||||
"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
|
||||
'(UNSIGNED-BYTE 32))))
|
||||
@ -898,7 +1024,7 @@
|
||||
(IL:ADD-SYMBOL IL:TABLE SYMBOL))
|
||||
(T
|
||||
(IL:* IL:|;;|
|
||||
"The initial table is still smaller than the limit. Increase its size.")
|
||||
"The initial table is still smaller than the limit. Increase its size.")
|
||||
|
||||
(LET ((IL:SIZE (PACKAGE-HASHTABLE-SIZE IL:TABLE))
|
||||
(IL:VEC1 (CAR IL:VEC))
|
||||
@ -909,8 +1035,7 @@
|
||||
(DOTIMES (IL:I IL:LEN)
|
||||
(WHEN (IL:IGREATERP (AREF IL:HASH1 IL:I)
|
||||
1)
|
||||
(IL:ADD-SYMBOL IL:TABLE (IL:\\INDEXATOMPNAME (AREF IL:VEC1
|
||||
IL:I))))))
|
||||
(IL:ADD-SYMBOL IL:TABLE (IL:\\INDEXATOMPNAME (AREF IL:VEC1 IL:I))))))
|
||||
)))
|
||||
(T (LET ((IL:THIS-HASH (CAR (IL:FLAST IL:HASH)))
|
||||
(IL:THIS-VEC (CAR (IL:FLAST IL:VEC))))
|
||||
@ -926,10 +1051,9 @@
|
||||
(SETF (AREF IL:THIS-HASH IL:I)
|
||||
(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)
|
||||
&BODY IL:FORMS)
|
||||
(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)
|
||||
&BODY IL:FORMS)
|
||||
"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)))
|
||||
(IL:HASH (OR IL:HASH-TABLE-HASH (IL:GENSYM)))
|
||||
@ -947,7 +1071,7 @@
|
||||
,IL:HASH
|
||||
,IL:LIMIT)
|
||||
(DECLARE (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 8))
|
||||
,IL:HASH)
|
||||
,IL:HASH)
|
||||
(TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 32))
|
||||
,IL:VEC))
|
||||
(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:OUTER-LOOP
|
||||
(IL:SETQ ,IL:HASH (IL:POP ,IL:HASHS))
|
||||
(IL:* IL:\; "Hashvalues")
|
||||
(IL:SETQ ,IL:VEC (IL:POP ,IL:VECS)) (IL:* IL:\; "The symbol vector")
|
||||
(IL:SETQ ,IL:HASH (IL:POP ,IL:HASHS)) (IL:* IL:\; "Hashvalues")
|
||||
(IL:SETQ ,IL:VEC (IL:POP ,IL:VECS)) (IL:* IL:\; "The symbol vector")
|
||||
(IL:SETQ ,IL:INDEX-VAR (IL:IREMAINDER ,SXHASH ,IL:LEN))
|
||||
(IL:* IL:\; "Starting probe.")
|
||||
(IL:SETQ ,IL:LIMIT ,IL:LEN)
|
||||
@ -972,37 +1095,34 @@
|
||||
|
||||
(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)))
|
||||
(WHEN (IL:\\SYMBOL-EQUALBASE ,IL:SYMBOL-VAR ,IL:BASE ,IL:OFFSET ,IL:LENGTH
|
||||
,IL:FATP)
|
||||
(GO IL:DOIT)))
|
||||
((EQL 0 ,IL:EHASH) (IL:* IL:\;
|
||||
"Found an empty hash slot, so it's not in this table.")
|
||||
"Found an empty hash slot, so it's not in this table.")
|
||||
(COND
|
||||
((NULL ,IL:HASHS)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"we've run out of sub-tables to look in. Give the we-couldn't-find-it signal.")
|
||||
"we've run out of sub-tables to look in. Give the we-couldn't-find-it signal.")
|
||||
|
||||
(IL:SETQ ,IL:INDEX-VAR NIL)
|
||||
(GO IL:DOIT))
|
||||
(T (GO IL:OUTER-LOOP))))
|
||||
((EQL 0 (IL:SETQ ,IL:LIMIT (IL:SUB1 ,IL:LIMIT)))
|
||||
(IL:* IL:\;
|
||||
"We.ve been thru the whole table, so it's not in this table.")
|
||||
"We.ve been thru the whole table, so it's not in this table.")
|
||||
(COND
|
||||
((NULL ,IL:HASHS)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"we've run out of sub-tables to look in. Give the we-couldn't-find-it signal.")
|
||||
"we've run out of sub-tables to look in. Give the we-couldn't-find-it signal.")
|
||||
|
||||
(IL:SETQ ,IL:INDEX-VAR NIL)
|
||||
(GO IL:DOIT))
|
||||
(T (GO IL:OUTER-LOOP)))))
|
||||
(IL:SETQ ,IL:INDEX-VAR (IL:SYMBOL-HASH-REPROBE ,IL:INDEX-VAR ,IL:H2
|
||||
,IL:LEN))
|
||||
(IL:SETQ ,IL:INDEX-VAR (IL:SYMBOL-HASH-REPROBE ,IL:INDEX-VAR ,IL:H2 ,IL:LEN))
|
||||
(GO LOOP)
|
||||
IL:DOIT
|
||||
(RETURN (PROGN ,@IL:FORMS))))))
|
||||
@ -1051,12 +1171,12 @@
|
||||
(IL:SETQ IL:WHERE :INTERNAL)
|
||||
(IL:SETQ IL:DONE T))))
|
||||
(IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-INTERNAL-SYMBOLS PACKAGE)
|
||||
IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH IL:EHASH
|
||||
NIL NIL)
|
||||
IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH IL:EHASH NIL
|
||||
NIL)
|
||||
(WHEN IL:FOUND
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Was (cl:return-from find-symbol* (cl:values cl:symbol :internal))")
|
||||
"Was (cl:return-from find-symbol* (cl:values cl:symbol :internal))")
|
||||
|
||||
(IL:SETQ IL:WHERE :INTERNAL)
|
||||
(IL:SETQ IL:DONE T)))))
|
||||
@ -1071,12 +1191,12 @@
|
||||
(IL:SETQ IL:WHERE :EXTERNAL)
|
||||
(IL:SETQ IL:DONE T))))
|
||||
(IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)
|
||||
IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH IL:EHASH
|
||||
NIL NIL)
|
||||
IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH IL:EHASH NIL
|
||||
NIL)
|
||||
(WHEN IL:FOUND
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Was (cl:return-from find-symbol* (cl:values cl:symbol :external))")
|
||||
"Was (cl:return-from find-symbol* (cl:values cl:symbol :external))")
|
||||
|
||||
(IL:SETQ IL:SYM SYMBOL)
|
||||
(IL:SETQ IL:WHERE :EXTERNAL)
|
||||
@ -1101,13 +1221,13 @@
|
||||
IL:TABLE))
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Was (cl:return-from find-symbol* (cl:values cl:symbol :inherited))")
|
||||
"Was (cl:return-from find-symbol* (cl:values cl:symbol :inherited))")
|
||||
|
||||
(IL:SETQ IL:WHERE :INHERITED)
|
||||
(IL:SETQ IL:DONE T))))
|
||||
(IL:WITH-SYMBOL (IL:FOUND SYMBOL (CAR IL:TABLE)
|
||||
IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH
|
||||
IL:EHASH NIL NIL)
|
||||
IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH
|
||||
IL:EHASH NIL NIL)
|
||||
(WHEN IL:FOUND
|
||||
(UNLESS (EQ IL:PREV IL:HEAD)
|
||||
(SHIFTF (CDR IL:PREV)
|
||||
@ -1116,7 +1236,7 @@
|
||||
IL:TABLE))
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Was (cl:return-from find-symbol* (cl:values cl:symbol :inherited))")
|
||||
"Was (cl:return-from find-symbol* (cl:values cl:symbol :inherited))")
|
||||
|
||||
(IL:SETQ IL:SYM SYMBOL)
|
||||
(IL:SETQ IL:WHERE :INHERITED)
|
||||
@ -1134,17 +1254,17 @@
|
||||
(T (IL:ERROR "Not a string " IL:NAME))))
|
||||
(COND
|
||||
((NULL PACKAGE) (IL:* IL:\;
|
||||
"XCL extension, makes uninterned symbols")
|
||||
"XCL extension, makes uninterned symbols")
|
||||
(MAKE-SYMBOL IL:NAME))
|
||||
(T (IL:* IL:\;
|
||||
"Package is at least non-null")
|
||||
"Package is at least non-null")
|
||||
(IL:SETQ PACKAGE (IL:\\PACKAGIFY PACKAGE))
|
||||
(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:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| IL:NAME))
|
||||
(IL:FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| IL:NAME)))
|
||||
(IL:INTERN* IL:BASE IL:OFFSET IL:LENGTH IL:FATP (IL:\\FATCHARSEENP IL:BASE
|
||||
IL:OFFSET IL:LENGTH IL:FATP)
|
||||
(IL:INTERN* IL:BASE IL:OFFSET IL:LENGTH IL:FATP (IL:\\FATCHARSEENP IL:BASE IL:OFFSET
|
||||
IL:LENGTH IL:FATP)
|
||||
PACKAGE NIL)))))
|
||||
|
||||
(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: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:EHASH NIL IL:TABLE-HASH)
|
||||
IL:EHASH NIL IL:TABLE-HASH)
|
||||
(SETF (AREF IL:TABLE-HASH IL:INDEX)
|
||||
1)
|
||||
(INCF (PACKAGE-HASHTABLE-DELETED IL:TABLE)))))
|
||||
@ -1196,7 +1316,7 @@
|
||||
(IL:FIND-EXTERNAL-SYMBOL IL:NAME IL:P)
|
||||
(WHEN IL:W (PUSHNEW IL:S IL:CSET))))
|
||||
(WHEN (CDR IL:CSET) (IL:* IL:\;
|
||||
"If there is more than one, handle the conflict")
|
||||
"If there is more than one, handle the conflict")
|
||||
(IL:RESOLVE-UNINTERN-CONFLICT SYMBOL IL:CSET PACKAGE)))
|
||||
(SETF (%PACKAGE-SHADOWING-SYMBOLS PACKAGE)
|
||||
(DELETE SYMBOL IL:SHADOWING-SYMBOLS :TEST #'EQ)))
|
||||
@ -1207,8 +1327,8 @@
|
||||
(OR (EQ IL:W :INTERNAL)
|
||||
(EQ IL:W :EXTERNAL)))
|
||||
(IL:NUKE-SYMBOL (IF (EQ IL:W :INTERNAL)
|
||||
(%PACKAGE-INTERNAL-SYMBOLS PACKAGE)
|
||||
(%PACKAGE-EXTERNAL-SYMBOLS PACKAGE))
|
||||
(%PACKAGE-INTERNAL-SYMBOLS PACKAGE)
|
||||
(%PACKAGE-EXTERNAL-SYMBOLS PACKAGE))
|
||||
IL:NAME)
|
||||
(IF (EQ (SYMBOL-PACKAGE SYMBOL)
|
||||
PACKAGE)
|
||||
@ -1291,9 +1411,9 @@
|
||||
)
|
||||
|
||||
(DEFMACRO DO-EXTERNAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*)
|
||||
IL:RESULT-FORM)
|
||||
&BODY
|
||||
(IL:CODE IL:DECLS))
|
||||
IL:RESULT-FORM)
|
||||
&BODY
|
||||
(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."
|
||||
(LET ((IL:VARS (IL:MAKE-DO-SYMBOLS-VARS)))
|
||||
`(PROG (,IL:VAR ,@IL:VARS)
|
||||
@ -1304,9 +1424,9 @@
|
||||
IL:CODE))))
|
||||
|
||||
(DEFMACRO XCL:DO-LOCAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*)
|
||||
IL:RESULT-FORM)
|
||||
&BODY
|
||||
(IL:CODE IL:DECLS))
|
||||
IL:RESULT-FORM)
|
||||
&BODY
|
||||
(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."
|
||||
(LET* ((IL:DONE-INTERNAL (IL:GENSYM))
|
||||
(IL:DONE-EXTERNAL (IL:GENSYM))
|
||||
@ -1318,13 +1438,11 @@
|
||||
,@IL:DECLS
|
||||
(WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE)
|
||||
(GO ,IL:DONE-INTERNAL))
|
||||
,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS
|
||||
,PACKAGE)
|
||||
,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS ,PACKAGE)
|
||||
`(GO ,IL:DONE-INTERNAL)
|
||||
IL:CODE)
|
||||
,IL:DONE-INTERNAL
|
||||
,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-EXTERNAL-SYMBOLS
|
||||
,PACKAGE)
|
||||
,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-EXTERNAL-SYMBOLS ,PACKAGE)
|
||||
`(GO ,IL:DONE-EXTERNAL)
|
||||
IL:CODE)
|
||||
,IL:DONE-EXTERNAL
|
||||
@ -1332,9 +1450,9 @@
|
||||
(RETURN ,IL:RESULT-FORM))))
|
||||
|
||||
(DEFMACRO XCL:DO-INTERNAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*)
|
||||
IL:RESULT-FORM)
|
||||
&BODY
|
||||
(IL:CODE IL:DECLS))
|
||||
IL:RESULT-FORM)
|
||||
&BODY
|
||||
(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."
|
||||
(LET* ((IL:DONE-INTERNAL (IL:GENSYM))
|
||||
(IL:VARS (IL:MAKE-DO-SYMBOLS-VARS))
|
||||
@ -1345,8 +1463,7 @@
|
||||
,@IL:DECLS
|
||||
(WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE)
|
||||
(GO ,IL:DONE-INTERNAL))
|
||||
,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS
|
||||
,PACKAGE)
|
||||
,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS ,PACKAGE)
|
||||
`(GO ,IL:DONE-INTERNAL)
|
||||
IL:CODE)
|
||||
,IL:DONE-INTERNAL
|
||||
@ -1354,9 +1471,9 @@
|
||||
(RETURN ,IL:RESULT-FORM))))
|
||||
|
||||
(DEFMACRO DO-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*)
|
||||
IL:RESULT-FORM)
|
||||
&BODY
|
||||
(IL:CODE IL:DECLS))
|
||||
IL:RESULT-FORM)
|
||||
&BODY
|
||||
(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."
|
||||
(LET* ((IL:DONE-INTERNAL (IL:GENSYM))
|
||||
(IL:DONE-EXTERNAL (IL:GENSYM))
|
||||
@ -1375,13 +1492,11 @@
|
||||
,@IL:DECLS
|
||||
(WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE)
|
||||
(GO ,IL:DONE-INTERNAL))
|
||||
,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS
|
||||
,PACKAGE)
|
||||
,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS ,PACKAGE)
|
||||
`(GO ,IL:DONE-INTERNAL)
|
||||
IL:CODE)
|
||||
,IL:DONE-INTERNAL
|
||||
,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-EXTERNAL-SYMBOLS
|
||||
,PACKAGE)
|
||||
,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-EXTERNAL-SYMBOLS ,PACKAGE)
|
||||
`(GO ,IL:DONE-EXTERNAL)
|
||||
IL:CODE)
|
||||
,IL:DONE-EXTERNAL
|
||||
@ -1390,29 +1505,29 @@
|
||||
(IL:SETQ ,IL:VAR NIL)
|
||||
(RETURN ,IL:RESULT-FORM))
|
||||
(IL:SETQ ,IL:THIS-INHERIT (CAR ,IL:INHERITS))
|
||||
,@(IL:MAKE-DO-SYMBOLS-CODE
|
||||
IL:VARS IL:VAR IL:THIS-INHERIT `(PROGN (IL:SETQ ,IL:INHERITS (CDR ,IL:INHERITS))
|
||||
(GO ,IL:NEXT-INHERIT))
|
||||
`((WHEN (OR (NOT ,IL:SHADOWED)
|
||||
(EQ (FIND-SYMBOL (SYMBOL-NAME ,IL:VAR)
|
||||
,IL:N-PACKAGE)
|
||||
,IL:VAR))
|
||||
,@IL:CODE))))))
|
||||
,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR IL:THIS-INHERIT
|
||||
`(PROGN (IL:SETQ ,IL:INHERITS (CDR ,IL:INHERITS))
|
||||
(GO ,IL:NEXT-INHERIT))
|
||||
`((WHEN (OR (NOT ,IL:SHADOWED)
|
||||
(EQ (FIND-SYMBOL (SYMBOL-NAME ,IL:VAR)
|
||||
,IL:N-PACKAGE)
|
||||
,IL:VAR))
|
||||
,@IL:CODE))))))
|
||||
|
||||
(DEFMACRO DO-ALL-SYMBOLS ((IL:VAR &OPTIONAL IL:RESULT-FORM)
|
||||
&BODY
|
||||
(IL:CODE IL:DECLS))
|
||||
&BODY
|
||||
(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."
|
||||
(LET* ((IL:PACKAGE-LOOP (IL:GENSYM))
|
||||
(IL:TAG (IL:GENSYM))
|
||||
(IL:PACKAGE-LIST (IL:GENSYM))
|
||||
(IL:VARS (IL:MAKE-DO-SYMBOLS-VARS))
|
||||
(IL:INTERNAL-CODE (IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR
|
||||
`(%PACKAGE-INTERNAL-SYMBOLS (CAR ,IL:PACKAGE-LIST))
|
||||
(IL:INTERNAL-CODE (IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS
|
||||
(CAR ,IL:PACKAGE-LIST))
|
||||
`(GO ,IL:TAG)
|
||||
IL:CODE))
|
||||
(IL:EXTERNAL-CODE (IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR
|
||||
`(%PACKAGE-EXTERNAL-SYMBOLS (CAR ,IL:PACKAGE-LIST))
|
||||
(IL:EXTERNAL-CODE (IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-EXTERNAL-SYMBOLS
|
||||
(CAR ,IL:PACKAGE-LIST))
|
||||
`(PROGN (IL:SETQ ,IL:PACKAGE-LIST (CDR ,IL:PACKAGE-LIST))
|
||||
(GO ,IL:PACKAGE-LOOP))
|
||||
IL:CODE)))
|
||||
@ -1494,12 +1609,10 @@
|
||||
(LET ((PACKAGE (IL:\\PACKAGIFY PACKAGE)))
|
||||
(IF IL:EXTERNAL-ONLY
|
||||
(DO-EXTERNAL-SYMBOLS (SYMBOL PACKAGE)
|
||||
(IF (IL:APROPOS-SEARCH SYMBOL IL:BASE IL:OFFSET IL:LENGTH
|
||||
IL:FATP)
|
||||
(IF (IL:APROPOS-SEARCH SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP)
|
||||
(PUSH SYMBOL LIST)))
|
||||
(DO-SYMBOLS (SYMBOL PACKAGE)
|
||||
(IF (IL:APROPOS-SEARCH SYMBOL IL:BASE IL:OFFSET IL:LENGTH
|
||||
IL:FATP)
|
||||
(IF (IL:APROPOS-SEARCH SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP)
|
||||
(PUSH SYMBOL LIST)))))))
|
||||
LIST))
|
||||
|
||||
@ -1510,7 +1623,7 @@
|
||||
|
||||
(DEFUN IL:FIND-EXTERNAL-SYMBOL (STRING PACKAGE)
|
||||
(IL:SETQ STRING (IL:MKSTRING STRING)) (IL:* IL:\;
|
||||
"Convert symbols to strings (for the reader)")
|
||||
"Convert symbols to strings (for the reader)")
|
||||
(LET* ((IL:BASE (IL:|ffetch| (IL:STRINGP IL:BASE) 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))
|
||||
@ -1526,8 +1639,7 @@
|
||||
IL:RESULT))
|
||||
(VALUES IL:SYM (NOT (IL:IEQP IL:RESULT -1))))
|
||||
(IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)
|
||||
IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH IL:EHASH NIL
|
||||
NIL)
|
||||
IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH IL:EHASH NIL NIL)
|
||||
(VALUES SYMBOL IL:FOUND)))))
|
||||
|
||||
(DEFUN IL:FIND-EXACT-SYMBOL (SYMBOL PACKAGE)
|
||||
@ -1562,32 +1674,40 @@
|
||||
|
||||
(IL:ADDTOVAR IL:LAMA )
|
||||
)
|
||||
(IL:PUTPROPS IL:LLPACKAGE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1992))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL (9779 10219 (IL:\\UPCASEBASE 9779 . 10219)) (10221 11342 (IL:APROPOS-SEARCH 10221 .
|
||||
11342)) (12882 12964 (PACKAGE-NAME 12882 . 12964)) (12966 13058 (PACKAGE-NICKNAMES 12966 . 13058)) (
|
||||
13060 13168 (PACKAGE-SHADOWING-SYMBOLS 13060 . 13168)) (13170 13260 (PACKAGE-USE-LIST 13170 . 13260))
|
||||
(13262 13360 (PACKAGE-USED-BY-LIST 13262 . 13360)) (13362 14517 (IL:MAKE-PACKAGE-HASHTABLE 13362 .
|
||||
14517)) (14519 14681 (PRINT-PACKAGE 14519 . 14681)) (14683 15074 (PRINT-PACKAGE-HASHTABLE 14683 .
|
||||
15074)) (16142 16923 (MAKE-SYMBOL 16142 . 16923)) (18034 18444 (IL:\\PKG-FIND-FREE-PACKAGE-INDEX 18034
|
||||
. 18444)) (18501 18647 (IL:SETF-SYMBOL-PACKAGE 18501 . 18647)) (18649 18741 (SYMBOL-PACKAGE 18649 .
|
||||
18741)) (21512 21684 (IL:INTERNAL-SYMBOL-COUNT 21512 . 21684)) (21686 21804 (IL:EXTERNAL-SYMBOL-COUNT
|
||||
21686 . 21804)) (21806 22962 (IL:ENTER-NEW-NICKNAMES 21806 . 22962)) (22964 23390 (
|
||||
IL:MAKE-PRIME-HASHTABLE-SIZE 22964 . 23390)) (23392 25061 (MAKE-PACKAGE 23392 . 25061)) (25062 28355 (
|
||||
XCL:DEFPACKAGE 25075 . 28353)) (28404 28626 (FIND-PACKAGE 28404 . 28626)) (28628 31966 (USE-PACKAGE
|
||||
28628 . 31966)) (31968 32448 (IN-PACKAGE 31968 . 32448)) (32450 32724 (XCL:PKG-GOTO 32450 . 32724)) (
|
||||
32726 33826 (RENAME-PACKAGE 32726 . 33826)) (33828 35279 (XCL:DELETE-PACKAGE 33828 . 35279)) (35281
|
||||
38227 (EXPORT 35281 . 38227)) (38229 39472 (UNEXPORT 38229 . 39472)) (39474 41118 (IMPORT 39474 .
|
||||
41118)) (41120 42398 (SHADOWING-IMPORT 41120 . 42398)) (42400 43454 (SHADOW 42400 . 43454)) (43456
|
||||
44111 (UNUSE-PACKAGE 43456 . 44111)) (44175 44481 (LIST-ALL-PACKAGES 44175 . 44481)) (44538 48313 (
|
||||
IL:ADD-SYMBOL 44538 . 48313)) (52637 53940 (IL:INTERN* 52637 . 53940)) (53942 59790 (IL:FIND-SYMBOL*
|
||||
53942 . 59790)) (59792 61243 (INTERN 59792 . 61243)) (61245 61823 (FIND-SYMBOL 61245 . 61823)) (61881
|
||||
62781 (IL:NUKE-SYMBOL 61881 . 62781)) (62783 64903 (UNINTERN 62783 . 64903)) (64905 66048 (
|
||||
IL:MOBY-UNINTERN 64905 . 66048)) (66107 66179 (IL:\\INDEXATOMPNAME 66107 . 66179)) (66291 66438 (
|
||||
IL:MAKE-DO-SYMBOLS-VARS 66291 . 66438)) (66440 67895 (IL:MAKE-DO-SYMBOLS-CODE 66440 . 67895)) (75495
|
||||
76020 (FIND-ALL-SYMBOLS 75495 . 76020)) (76022 76301 (IL:BRIEFLY-DESCRIBE-SYMBOL 76022 . 76301)) (
|
||||
76303 77817 (APROPOS 76303 . 77817)) (77819 79476 (APROPOS-LIST 77819 . 79476)) (79580 81153 (
|
||||
IL:FIND-EXTERNAL-SYMBOL 79580 . 81153)) (81155 81675 (IL:FIND-EXACT-SYMBOL 81155 . 81675)) (81677
|
||||
81757 (IL:PACKAGE-NAME-AS-SYMBOL 81677 . 81757)) (81759 81908 (IL:\\FIND.PACKAGE.INTERNAL 81759 .
|
||||
81908)))))
|
||||
(IL:FILEMAP (NIL (5304 5829 (IL:PACKAGE-LISTIFY 5304 . 5829)) (5831 6219 (IL:\\SIMPLE-STRINGIFY 5831
|
||||
. 6219)) (6221 6713 (IL:SYMBOL-LISTIFY 6221 . 6713)) (6715 6777 (IL:COPY-STRING 6715 . 6777)) (6779
|
||||
7517 (IL:\\SYMBOL-EQUALBASE 6779 . 7517)) (7521 7957 (IL:\\FATCHARSEENP 7521 . 7957)) (7959 8487 (
|
||||
IL:\\PACKAGIFY 7959 . 8487)) (8489 9526 (IL:\\STRING-EQUALBASE 8489 . 9526)) (9528 9752 (
|
||||
IL:NUMERIC-UPCASE 9528 . 9752)) (9754 10111 (IL:\\UPCASEBASE 9754 . 10111)) (10113 11230 (
|
||||
IL:APROPOS-SEARCH 10113 . 11230)) (12750 12832 (PACKAGE-NAME 12750 . 12832)) (12834 12926 (
|
||||
PACKAGE-NICKNAMES 12834 . 12926)) (12928 13036 (PACKAGE-SHADOWING-SYMBOLS 12928 . 13036)) (13038 13128
|
||||
(PACKAGE-USE-LIST 13038 . 13128)) (13130 13228 (PACKAGE-USED-BY-LIST 13130 . 13228)) (13230 14385 (
|
||||
IL:MAKE-PACKAGE-HASHTABLE 13230 . 14385)) (14387 14549 (PRINT-PACKAGE 14387 . 14549)) (14551 14942 (
|
||||
PRINT-PACKAGE-HASHTABLE 14551 . 14942)) (16006 16787 (MAKE-SYMBOL 16006 . 16787)) (17838 18248 (
|
||||
IL:\\PKG-FIND-FREE-PACKAGE-INDEX 17838 . 18248)) (18305 18451 (IL:SETF-SYMBOL-PACKAGE 18305 . 18451))
|
||||
(18453 18545 (SYMBOL-PACKAGE 18453 . 18545)) (18587 20224 (IL:SYMBOL-HASH 18587 . 20224)) (20226 20358
|
||||
(IL:REHASH-FACTOR 20226 . 20358)) (20360 20526 (IL:SYMBOL-HASH-REPROBE 20360 . 20526)) (20528 20919 (
|
||||
IL:ENTRY-HASH 20528 . 20919)) (20968 21314 (IL:COUNT-PACKAGE-HASHTABLE 20968 . 21314)) (21316 21488 (
|
||||
IL:INTERNAL-SYMBOL-COUNT 21316 . 21488)) (21490 21608 (IL:EXTERNAL-SYMBOL-COUNT 21490 . 21608)) (21610
|
||||
22766 (IL:ENTER-NEW-NICKNAMES 21610 . 22766)) (22768 23194 (IL:MAKE-PRIME-HASHTABLE-SIZE 22768 .
|
||||
23194)) (23196 24845 (MAKE-PACKAGE 23196 . 24845)) (24846 34317 (XCL:DEFPACKAGE 24859 . 34315)) (34366
|
||||
34588 (FIND-PACKAGE 34366 . 34588)) (34590 37951 (USE-PACKAGE 34590 . 37951)) (37953 38433 (
|
||||
IN-PACKAGE 37953 . 38433)) (38435 38709 (XCL:PKG-GOTO 38435 . 38709)) (38711 39811 (RENAME-PACKAGE
|
||||
38711 . 39811)) (39813 41264 (XCL:DELETE-PACKAGE 39813 . 41264)) (41266 44212 (EXPORT 41266 . 44212))
|
||||
(44214 45457 (UNEXPORT 44214 . 45457)) (45459 47103 (IMPORT 45459 . 47103)) (47105 48385 (
|
||||
SHADOWING-IMPORT 47105 . 48385)) (48387 49441 (SHADOW 48387 . 49441)) (49443 50098 (UNUSE-PACKAGE
|
||||
49443 . 50098)) (50162 50468 (LIST-ALL-PACKAGES 50162 . 50468)) (50525 54208 (IL:ADD-SYMBOL 50525 .
|
||||
54208)) (54210 58263 (IL:WITH-SYMBOL 54210 . 58263)) (58265 59568 (IL:INTERN* 58265 . 59568)) (59570
|
||||
65402 (IL:FIND-SYMBOL* 59570 . 65402)) (65404 66855 (INTERN 65404 . 66855)) (66857 67435 (FIND-SYMBOL
|
||||
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
|
||||
|
||||
Binary file not shown.
Loading…
x
Reference in New Issue
Block a user