;;; the entry is unused. If it is one, then it is deleted.
;;; Double-hashing is used for collision resolution.
-(sb!xc:deftype hash-vector () '(simple-array (unsigned-byte 8) (*)))
+(def!type hash-vector () '(simple-array (unsigned-byte 8) (*)))
-(sb!xc:defstruct (package-hashtable (:constructor %make-package-hashtable ())
- (:copier nil))
+(def!struct (package-hashtable
+ (:constructor %make-package-hashtable
+ (table hash size &aux (free size)))
+ (:copier nil))
;; The g-vector of symbols.
- ;; FIXME: could just be type SIMPLE-VECTOR, with (MISSING-ARG) default
- (table nil :type (or simple-vector null))
+ (table (missing-arg) :type simple-vector)
;; The i-vector of pname hash values.
- ;; FIXME: could just be type HASH-VECTOR, with (MISSING-ARG) default
- (hash nil :type (or hash-vector null))
+ (hash (missing-arg) :type hash-vector)
;; The total number of entries allowed before resizing.
;;
;; FIXME: CAPACITY would be a more descriptive name. (This is
;; related to but not quite the same as HASH-TABLE-SIZE, so calling
;; it SIZE seems somewhat misleading.)
- (size 0 :type index)
+ (size (missing-arg) :type index)
;; The remaining number of entries that can be made before we have to rehash.
- (free 0 :type index)
+ (free (missing-arg) :type index)
;; The number of deleted entries.
(deleted 0 :type index))
\f
;;; around by putting the new PACKAGE type (and the PACKAGEP predicate
;;; too..) into SB!XC. -- WHN 20000309
(def!struct (sb!xc:package
- (:constructor internal-make-package)
- (:make-load-form-fun (lambda (p)
- (values `(find-undeleted-package-or-lose
- ',(package-name p))
- nil)))
- (:predicate sb!xc:packagep))
+ (:constructor internal-make-package)
+ (:make-load-form-fun (lambda (p)
+ (values `(find-undeleted-package-or-lose
+ ',(package-name p))
+ nil)))
+ (:predicate sb!xc:packagep))
#!+sb-doc
"the standard structure for the description of a package"
;; the name of the package, or NIL for a deleted package
;; shadowing symbols
(%shadowing-symbols () :type list)
;; documentation string for this package
- (doc-string nil :type (or simple-string null)))
+ (doc-string nil :type (or simple-string null))
+ ;; package locking
+ #!+sb-package-locks
+ (lock nil :type boolean)
+ #!+sb-package-locks
+ (%implementation-packages nil :type list))
\f
;;;; iteration macros
(defmacro-mundanely do-symbols ((var &optional
- (package '*package*)
- result-form)
- &body body-decls)
+ (package '*package*)
+ result-form)
+ &body body-decls)
#!+sb-doc
"DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}*
Executes the FORMs at least once for each symbol accessible in the given
PACKAGE with VAR bound to the current symbol."
- (multiple-value-bind (body decls) (parse-body body-decls nil)
+ (multiple-value-bind (body decls)
+ (parse-body body-decls :doc-string-allowed nil)
(let ((flet-name (gensym "DO-SYMBOLS-")))
`(block nil
- (flet ((,flet-name (,var)
- ,@decls
- (tagbody ,@body)))
- (let* ((package (find-undeleted-package-or-lose ,package))
- (shadows (package-%shadowing-symbols package)))
- (flet ((iterate-over-hash-table (table ignore)
- (let ((hash-vec (package-hashtable-hash table))
- (sym-vec (package-hashtable-table table)))
- (declare (type (simple-array (unsigned-byte 8) (*))
- hash-vec)
- (type simple-vector sym-vec))
- (dotimes (i (length sym-vec))
- (when (>= (aref hash-vec i) 2)
- (let ((sym (aref sym-vec i)))
- (declare (inline member))
- (unless (member sym ignore :test #'string=)
- (,flet-name sym))))))))
- (iterate-over-hash-table (package-internal-symbols package) nil)
- (iterate-over-hash-table (package-external-symbols package) nil)
- (dolist (use (package-%use-list package))
- (iterate-over-hash-table (package-external-symbols use)
- shadows)))))
- (let ((,var nil))
- (declare (ignorable ,var))
- ,@decls
- ,result-form)))))
+ (flet ((,flet-name (,var)
+ ,@decls
+ (tagbody ,@body)))
+ (let* ((package (find-undeleted-package-or-lose ,package))
+ (shadows (package-%shadowing-symbols package)))
+ (flet ((iterate-over-hash-table (table ignore)
+ (let ((hash-vec (package-hashtable-hash table))
+ (sym-vec (package-hashtable-table table)))
+ (dotimes (i (length sym-vec))
+ (when (>= (aref hash-vec i) 2)
+ (let ((sym (aref sym-vec i)))
+ (declare (inline member))
+ (unless (member sym ignore :test #'string=)
+ (,flet-name sym))))))))
+ (iterate-over-hash-table (package-internal-symbols package) nil)
+ (iterate-over-hash-table (package-external-symbols package) nil)
+ (dolist (use (package-%use-list package))
+ (iterate-over-hash-table (package-external-symbols use)
+ shadows)))))
+ (let ((,var nil))
+ (declare (ignorable ,var))
+ ,@decls
+ ,result-form)))))
(defmacro-mundanely do-external-symbols ((var &optional
- (package '*package*)
- result-form)
- &body body-decls)
+ (package '*package*)
+ result-form)
+ &body body-decls)
#!+sb-doc
"DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}*
Executes the FORMs once for each external symbol in the given PACKAGE with
VAR bound to the current symbol."
- (multiple-value-bind (body decls) (parse-body body-decls nil)
+ (multiple-value-bind (body decls)
+ (parse-body body-decls :doc-string-allowed nil)
(let ((flet-name (gensym "DO-SYMBOLS-")))
`(block nil
- (flet ((,flet-name (,var)
- ,@decls
- (tagbody ,@body)))
- (let* ((package (find-undeleted-package-or-lose ,package))
- (table (package-external-symbols package))
- (hash-vec (package-hashtable-hash table))
- (sym-vec (package-hashtable-table table)))
- (declare (type (simple-array (unsigned-byte 8) (*))
- hash-vec)
- (type simple-vector sym-vec))
- (dotimes (i (length sym-vec))
- (when (>= (aref hash-vec i) 2)
- (,flet-name (aref sym-vec i))))))
- (let ((,var nil))
- (declare (ignorable ,var))
- ,@decls
- ,result-form)))))
+ (flet ((,flet-name (,var)
+ ,@decls
+ (tagbody ,@body)))
+ (let* ((package (find-undeleted-package-or-lose ,package))
+ (table (package-external-symbols package))
+ (hash-vec (package-hashtable-hash table))
+ (sym-vec (package-hashtable-table table)))
+ (dotimes (i (length sym-vec))
+ (when (>= (aref hash-vec i) 2)
+ (,flet-name (aref sym-vec i))))))
+ (let ((,var nil))
+ (declare (ignorable ,var))
+ ,@decls
+ ,result-form)))))
(defmacro-mundanely do-all-symbols ((var &optional
- result-form)
- &body body-decls)
+ result-form)
+ &body body-decls)
#!+sb-doc
"DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}*
Executes the FORMs once for each symbol in every package with VAR bound
to the current symbol."
- (multiple-value-bind (body decls) (parse-body body-decls nil)
+ (multiple-value-bind (body decls)
+ (parse-body body-decls :doc-string-allowed nil)
(let ((flet-name (gensym "DO-SYMBOLS-")))
`(block nil
- (flet ((,flet-name (,var)
- ,@decls
- (tagbody ,@body)))
- (dolist (package (list-all-packages))
- (flet ((iterate-over-hash-table (table)
- (let ((hash-vec (package-hashtable-hash table))
- (sym-vec (package-hashtable-table table)))
- (declare (type (simple-array (unsigned-byte 8) (*))
- hash-vec)
- (type simple-vector sym-vec))
- (dotimes (i (length sym-vec))
- (when (>= (aref hash-vec i) 2)
- (,flet-name (aref sym-vec i)))))))
- (iterate-over-hash-table (package-internal-symbols package))
- (iterate-over-hash-table (package-external-symbols package)))))
- (let ((,var nil))
- (declare (ignorable ,var))
- ,@decls
- ,result-form)))))
+ (flet ((,flet-name (,var)
+ ,@decls
+ (tagbody ,@body)))
+ (dolist (package (list-all-packages))
+ (flet ((iterate-over-hash-table (table)
+ (let ((hash-vec (package-hashtable-hash table))
+ (sym-vec (package-hashtable-table table)))
+ (dotimes (i (length sym-vec))
+ (when (>= (aref hash-vec i) 2)
+ (,flet-name (aref sym-vec i)))))))
+ (iterate-over-hash-table (package-internal-symbols package))
+ (iterate-over-hash-table (package-external-symbols package)))))
+ (let ((,var nil))
+ (declare (ignorable ,var))
+ ,@decls
+ ,result-form)))))
\f
;;;; WITH-PACKAGE-ITERATOR
(defmacro-mundanely with-package-iterator ((mname package-list
- &rest symbol-types)
- &body body)
+ &rest symbol-types)
+ &body body)
#!+sb-doc
"Within the lexical scope of the body forms, MNAME is defined via macrolet
such that successive invocations of (MNAME) will return the symbols,
one by one, from the packages in PACKAGE-LIST. SYMBOL-TYPES may be
any of :INHERITED :EXTERNAL :INTERNAL."
(let* ((packages (gensym))
- (these-packages (gensym))
- (ordered-types (let ((res nil))
- (dolist (kind '(:inherited :external :internal)
- res)
- (when (member kind symbol-types)
- (push kind res))))) ; Order SYMBOL-TYPES.
- (counter (gensym))
- (kind (gensym))
- (hash-vector (gensym))
- (vector (gensym))
- (package-use-list (gensym))
- (init-macro (gensym))
- (end-test-macro (gensym))
- (real-symbol-p (gensym))
- (inherited-symbol-p (gensym))
- (BLOCK (gensym)))
+ (these-packages (gensym))
+ (ordered-types (let ((res nil))
+ (dolist (kind '(:inherited :external :internal)
+ res)
+ (when (member kind symbol-types)
+ (push kind res))))) ; Order SYMBOL-TYPES.
+ (counter (gensym))
+ (kind (gensym))
+ (hash-vector (gensym))
+ (vector (gensym))
+ (package-use-list (gensym))
+ (init-macro (gensym))
+ (end-test-macro (gensym))
+ (real-symbol-p (gensym))
+ (inherited-symbol-p (gensym))
+ (BLOCK (gensym)))
`(let* ((,these-packages ,package-list)
- (,packages `,(mapcar (lambda (package)
- (if (packagep package)
- package
- ;; Maybe FIND-PACKAGE-OR-DIE?
- (or (find-package package)
- (error 'simple-package-error
- ;; could be a character
- :name (string package)
- :format-control "~@<~S does not name a package ~:>"
- :format-arguments (list package)))))
- (if (consp ,these-packages)
- ,these-packages
- (list ,these-packages))))
- (,counter nil)
- (,kind (car ,packages))
- (,hash-vector nil)
- (,vector nil)
- (,package-use-list nil))
+ (,packages `,(mapcar (lambda (package)
+ (if (packagep package)
+ package
+ ;; Maybe FIND-PACKAGE-OR-DIE?
+ (or (find-package package)
+ (error 'simple-package-error
+ ;; could be a character
+ :name (string package)
+ :format-control "~@<~S does not name a package ~:>"
+ :format-arguments (list package)))))
+ (if (consp ,these-packages)
+ ,these-packages
+ (list ,these-packages))))
+ (,counter nil)
+ (,kind (car ,packages))
+ (,hash-vector nil)
+ (,vector nil)
+ (,package-use-list nil))
,(if (member :inherited ordered-types)
- `(setf ,package-use-list (package-%use-list (car ,packages)))
- `(declare (ignore ,package-use-list)))
+ `(setf ,package-use-list (package-%use-list (car ,packages)))
+ `(declare (ignore ,package-use-list)))
(macrolet ((,init-macro (next-kind)
- (declare (optimize (inhibit-warnings 3)))
- (let ((symbols (gensym)))
- `(progn
- (setf ,',kind ,next-kind)
- (setf ,',counter nil)
- ,(case next-kind
- (:internal
- `(let ((,symbols (package-internal-symbols
- (car ,',packages))))
- (when ,symbols
- (setf ,',vector (package-hashtable-table ,symbols))
- (setf ,',hash-vector
- (package-hashtable-hash ,symbols)))))
- (:external
- `(let ((,symbols (package-external-symbols
- (car ,',packages))))
- (when ,symbols
- (setf ,',vector (package-hashtable-table ,symbols))
- (setf ,',hash-vector
- (package-hashtable-hash ,symbols)))))
- (:inherited
- `(let ((,symbols (and ,',package-use-list
- (package-external-symbols
- (car ,',package-use-list)))))
- (when ,symbols
- (setf ,',vector (package-hashtable-table ,symbols))
- (setf ,',hash-vector
- (package-hashtable-hash ,symbols)))))))))
- (,end-test-macro (this-kind)
- `,(let ((next-kind (cadr (member this-kind
- ',ordered-types))))
- (if next-kind
- `(,',init-macro ,next-kind)
- `(if (endp (setf ,',packages (cdr ,',packages)))
- (return-from ,',BLOCK)
- (,',init-macro ,(car ',ordered-types)))))))
- (when ,packages
- ,(when (null symbol-types)
- (error 'simple-program-error
- :format-control
- "At least one of :INTERNAL, :EXTERNAL, or ~
- :INHERITED must be supplied."))
- ,(dolist (symbol symbol-types)
- (unless (member symbol '(:internal :external :inherited))
- (error 'program-error
- :format-control
- "~S is not one of :INTERNAL, :EXTERNAL, or :INHERITED."
- :format-argument symbol)))
- (,init-macro ,(car ordered-types))
- (flet ((,real-symbol-p (number)
- (> number 1)))
- (macrolet ((,mname ()
- (declare (optimize (inhibit-warnings 3)))
- `(block ,',BLOCK
- (loop
- (case ,',kind
- ,@(when (member :internal ',ordered-types)
- `((:internal
- (setf ,',counter
- (position-if #',',real-symbol-p
- ,',hash-vector
- :start (if ,',counter
- (1+ ,',counter)
- 0)))
- (if ,',counter
- (return-from ,',BLOCK
- (values t (svref ,',vector ,',counter)
- ,',kind (car ,',packages)))
- (,',end-test-macro :internal)))))
- ,@(when (member :external ',ordered-types)
- `((:external
- (setf ,',counter
- (position-if #',',real-symbol-p
- ,',hash-vector
- :start (if ,',counter
- (1+ ,',counter)
- 0)))
- (if ,',counter
- (return-from ,',BLOCK
- (values t (svref ,',vector ,',counter)
- ,',kind (car ,',packages)))
- (,',end-test-macro :external)))))
- ,@(when (member :inherited ',ordered-types)
- `((:inherited
- (flet ((,',inherited-symbol-p (number)
- (when (,',real-symbol-p number)
- (let* ((p (position
- number ,',hash-vector
- :start (if ,',counter
- (1+ ,',counter)
- 0)))
- (s (svref ,',vector p)))
- (eql (nth-value
- 1 (find-symbol
- (symbol-name s)
- (car ,',packages)))
- :inherited)))))
- (setf ,',counter
- (position-if #',',inherited-symbol-p
- ,',hash-vector
- :start (if ,',counter
- (1+ ,',counter)
- 0))))
- (cond (,',counter
- (return-from
- ,',BLOCK
- (values t (svref ,',vector ,',counter)
- ,',kind (car ,',packages))
- ))
- (t
- (setf ,',package-use-list
- (cdr ,',package-use-list))
- (cond ((endp ,',package-use-list)
- (setf ,',packages (cdr ,',packages))
- (when (endp ,',packages)
- (return-from ,',BLOCK))
- (setf ,',package-use-list
- (package-%use-list
- (car ,',packages)))
- (,',init-macro ,(car
- ',ordered-types)))
- (t (,',init-macro :inherited)
- (setf ,',counter nil)))))))))))))
- ,@body)))))))
+ (declare (optimize (inhibit-warnings 3)))
+ (let ((symbols (gensym)))
+ `(progn
+ (setf ,',kind ,next-kind)
+ (setf ,',counter nil)
+ ,(case next-kind
+ (:internal
+ `(let ((,symbols (package-internal-symbols
+ (car ,',packages))))
+ (when ,symbols
+ (setf ,',vector (package-hashtable-table ,symbols))
+ (setf ,',hash-vector
+ (package-hashtable-hash ,symbols)))))
+ (:external
+ `(let ((,symbols (package-external-symbols
+ (car ,',packages))))
+ (when ,symbols
+ (setf ,',vector (package-hashtable-table ,symbols))
+ (setf ,',hash-vector
+ (package-hashtable-hash ,symbols)))))
+ (:inherited
+ `(let ((,symbols (and ,',package-use-list
+ (package-external-symbols
+ (car ,',package-use-list)))))
+ (when ,symbols
+ (setf ,',vector (package-hashtable-table ,symbols))
+ (setf ,',hash-vector
+ (package-hashtable-hash ,symbols)))))))))
+ (,end-test-macro (this-kind)
+ `,(let ((next-kind (cadr (member this-kind
+ ',ordered-types))))
+ (if next-kind
+ `(,',init-macro ,next-kind)
+ `(if (endp (setf ,',packages (cdr ,',packages)))
+ (return-from ,',BLOCK)
+ (,',init-macro ,(car ',ordered-types)))))))
+ (when ,packages
+ ,(when (null symbol-types)
+ (error 'simple-program-error
+ :format-control
+ "At least one of :INTERNAL, :EXTERNAL, or ~
+ :INHERITED must be supplied."))
+ ,(dolist (symbol symbol-types)
+ (unless (member symbol '(:internal :external :inherited))
+ (error 'program-error
+ :format-control
+ "~S is not one of :INTERNAL, :EXTERNAL, or :INHERITED."
+ :format-argument symbol)))
+ (,init-macro ,(car ordered-types))
+ (flet ((,real-symbol-p (number)
+ (> number 1)))
+ (macrolet ((,mname ()
+ (declare (optimize (inhibit-warnings 3)))
+ `(block ,',BLOCK
+ (loop
+ (case ,',kind
+ ,@(when (member :internal ',ordered-types)
+ `((:internal
+ (setf ,',counter
+ (position-if #',',real-symbol-p
+ (the hash-vector ,',hash-vector)
+ :start (if ,',counter
+ (1+ ,',counter)
+ 0)))
+ (if ,',counter
+ (return-from ,',BLOCK
+ (values t (svref ,',vector ,',counter)
+ ,',kind (car ,',packages)))
+ (,',end-test-macro :internal)))))
+ ,@(when (member :external ',ordered-types)
+ `((:external
+ (setf ,',counter
+ (position-if #',',real-symbol-p
+ (the hash-vector ,',hash-vector)
+ :start (if ,',counter
+ (1+ ,',counter)
+ 0)))
+ (if ,',counter
+ (return-from ,',BLOCK
+ (values t (svref ,',vector ,',counter)
+ ,',kind (car ,',packages)))
+ (,',end-test-macro :external)))))
+ ,@(when (member :inherited ',ordered-types)
+ `((:inherited
+ (flet ((,',inherited-symbol-p (number)
+ (when (,',real-symbol-p number)
+ (let* ((p (position
+ number
+ (the hash-vector
+ ,',hash-vector)
+ :start (if ,',counter
+ (1+ ,',counter)
+ 0)))
+ (s (svref ,',vector p)))
+ (eql (nth-value
+ 1 (find-symbol
+ (symbol-name s)
+ (car ,',packages)))
+ :inherited)))))
+ (setf ,',counter
+ (when ,',hash-vector
+ (position-if #',',inherited-symbol-p
+ (the hash-vector
+ ,',hash-vector)
+ :start (if ,',counter
+ (1+ ,',counter)
+ 0)))))
+ (cond (,',counter
+ (return-from
+ ,',BLOCK
+ (values t (svref ,',vector ,',counter)
+ ,',kind (car ,',packages))
+ ))
+ (t
+ (setf ,',package-use-list
+ (cdr ,',package-use-list))
+ (cond ((endp ,',package-use-list)
+ (setf ,',packages (cdr ,',packages))
+ (when (endp ,',packages)
+ (return-from ,',BLOCK))
+ (setf ,',package-use-list
+ (package-%use-list
+ (car ,',packages)))
+ (,',init-macro ,(car
+ ',ordered-types)))
+ (t (,',init-macro :inherited)
+ (setf ,',counter nil)))))))))))))
+ ,@body)))))))
projects / sbcl.git / blobdiff