X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpackage.lisp;h=11a6a2e699f4993a3d6e178d6715912f52f8d47d;hb=58084279740fc96c6ffcd14e86dca73b71b7c288;hp=7a64d3ab3fcfca4b6e5d65ed470d1479f70ecaef;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/code/package.lisp b/src/code/package.lisp index 7a64d3a..11a6a2e 100644 --- a/src/code/package.lisp +++ b/src/code/package.lisp @@ -32,22 +32,22 @@ (sb!xc:deftype hash-vector () '(simple-array (unsigned-byte 8) (*))) -(sb!xc:defstruct (package-hashtable (:constructor %make-package-hashtable ()) - (:copier nil)) +(sb!xc:defstruct (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 REQUIRED-ARGUMENT - (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 REQUIRED-ARGUMENT - (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)) @@ -56,8 +56,9 @@ ;;; KLUDGE: We use DEF!STRUCT to define this not because we need to ;;; manipulate target package objects on the cross-compilation host, ;;; but only because its MAKE-LOAD-FORM function needs to be hooked -;;; into the pre-CLOS DEF!STRUCT MAKE-LOAD-FORM system. The DEF!STRUCT -;;; side-effect of defining a new PACKAGE type on the +;;; into the pre-CLOS DEF!STRUCT MAKE-LOAD-FORM system so that we can +;;; compile things like IN-PACKAGE in warm init before CLOS is set up. +;;; The DEF!STRUCT side effect of defining a new PACKAGE type on the ;;; cross-compilation host is just a nuisance, and in order to avoid ;;; breaking the cross-compilation host, we need to work around it ;;; around by putting the new PACKAGE type (and the PACKAGEP predicate @@ -93,8 +94,8 @@ ;; packages that use this package (%used-by-list () :type list) ;; PACKAGE-HASHTABLEs of internal & external symbols - (internal-symbols (required-argument) :type package-hashtable) - (external-symbols (required-argument) :type package-hashtable) + (internal-symbols (missing-arg) :type package-hashtable) + (external-symbols (missing-arg) :type package-hashtable) ;; shadowing symbols (%shadowing-symbols () :type list) ;; documentation string for this package @@ -110,7 +111,7 @@ "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) body-decls + (multiple-value-bind (body decls) (parse-body body-decls nil) (let ((flet-name (gensym "DO-SYMBOLS-"))) `(block nil (flet ((,flet-name (,var) @@ -121,9 +122,6 @@ (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))) @@ -158,9 +156,6 @@ (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)))))) @@ -186,9 +181,6 @@ (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))))))) @@ -227,10 +219,16 @@ (inherited-symbol-p (gensym)) (BLOCK (gensym))) `(let* ((,these-packages ,package-list) - (,packages `,(mapcar #'(lambda (package) - (if (packagep package) - package - (find-package package))) + (,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)))) @@ -243,6 +241,7 @@ `(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) @@ -253,7 +252,8 @@ (car ,',packages)))) (when ,symbols (setf ,',vector (package-hashtable-table ,symbols)) - (setf ,',hash-vector (package-hashtable-hash ,symbols))))) + (setf ,',hash-vector + (package-hashtable-hash ,symbols))))) (:external `(let ((,symbols (package-external-symbols (car ,',packages)))) @@ -279,27 +279,29 @@ (,',init-macro ,(car ',ordered-types))))))) (when ,packages ,(when (null symbol-types) - (error 'program-error + (error 'simple-program-error :format-control - "Must supply at least one of :internal, :external, or ~ - :inherited.")) + "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." + "~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 + (position-if #',',real-symbol-p + (the hash-vector ,',hash-vector) :start (if ,',counter (1+ ,',counter) 0))) @@ -311,7 +313,8 @@ ,@(when (member :external ',ordered-types) `((:external (setf ,',counter - (position-if #',',real-symbol-p ,',hash-vector + (position-if #',',real-symbol-p + (the hash-vector ,',hash-vector) :start (if ,',counter (1+ ,',counter) 0))) @@ -325,7 +328,9 @@ (flet ((,',inherited-symbol-p (number) (when (,',real-symbol-p number) (let* ((p (position - number ,',hash-vector + number + (the hash-vector + ,',hash-vector) :start (if ,',counter (1+ ,',counter) 0))) @@ -336,11 +341,13 @@ (car ,',packages))) :inherited))))) (setf ,',counter - (position-if #',',inherited-symbol-p - ,',hash-vector - :start (if ,',counter - (1+ ,',counter) - 0)))) + (when ,',hash-vector + (position-if #',',inherited-symbol-p + (the hash-vector + ,',hash-vector) + :start (if ,',counter + (1+ ,',counter) + 0))))) (cond (,',counter (return-from ,',BLOCK