0.8.3.5:

[sbcl.git] / src / code / target-package.lisp

diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp
index 8f81f62..5caa525 100644 (file)
--- a/src/code/target-package.lisp
+++ b/src/code/target-package.lisp
@@ -8,6 +8,9 @@
 ;;;;   symbol. A name conflict is said to occur when there would be more
 ;;;;   than one candidate symbol. Any time a name conflict is about to
 ;;;;   occur, a correctable error is signaled.
 ;;;;   symbol. A name conflict is said to occur when there would be more
 ;;;;   than one candidate symbol. Any time a name conflict is about to
 ;;;;   occur, a correctable error is signaled.

+;;;;
+;;;; FIXME: The code contains a lot of type declarations. Are they
+;;;; all really necessary?

 
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.
 
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.

@@ -24,11 +27,6 @@
 
 (!cold-init-forms
   (/show0 "entering !PACKAGE-COLD-INIT"))
 
 (!cold-init-forms
   (/show0 "entering !PACKAGE-COLD-INIT"))

-
-;;; the list of packages to use by default when no :USE argument is
-;;; supplied to MAKE-PACKAGE or other package creation forms
-(defvar *default-package-use-list*)
-(!cold-init-forms (setf *default-package-use-list* nil))

 \f
 ;;;; PACKAGE-HASHTABLE stuff
 
 \f
 ;;;; PACKAGE-HASHTABLE stuff
 

@@ -51,22 +49,26 @@
 ;;; the hashtable.
 (defun make-or-remake-package-hashtable (size
                                         &optional
 ;;; the hashtable.
 (defun make-or-remake-package-hashtable (size
                                         &optional

-                                        (res (%make-package-hashtable)))
-  (do ((n (logior (truncate size package-rehash-threshold) 1)
-         (+ n 2)))
-      ((positive-primep n)
-       (setf (package-hashtable-table res)
-            (make-array n))
-       (setf (package-hashtable-hash res)
-            (make-array n
-                        :element-type '(unsigned-byte 8)
-                        :initial-element 0))
-       (let ((size (truncate (* n package-rehash-threshold))))
-        (setf (package-hashtable-size res) size)
-        (setf (package-hashtable-free res) size))
-       (setf (package-hashtable-deleted res) 0)
-       res)
-    (declare (type fixnum n))))
+                                         res)
+  (flet ((actual-package-hashtable-size (size)
+           (loop for n of-type fixnum
+              from (logior (truncate size package-rehash-threshold) 1)
+              by 2
+              when (positive-primep n) return n)))
+    (let* ((n (actual-package-hashtable-size size))
+           (size (truncate (* n package-rehash-threshold)))
+           (table (make-array n))
+           (hash (make-array n
+                             :element-type '(unsigned-byte 8)
+                             :initial-element 0)))
+      (if res
+          (setf (package-hashtable-table res) table
+                (package-hashtable-hash res) hash
+                (package-hashtable-size res) size
+                (package-hashtable-free res) size
+                (package-hashtable-deleted res) 0)
+          (setf res (%make-package-hashtable table hash size)))
+      res)))

 \f
 ;;;; miscellaneous PACKAGE operations
 
 \f
 ;;;; miscellaneous PACKAGE operations
 

@@ -90,14 +92,10 @@
 
 (defun %package-hashtable-symbol-count (table)
   (let ((size (the fixnum
 
 (defun %package-hashtable-symbol-count (table)
   (let ((size (the fixnum

-               (- (the fixnum (package-hashtable-size table))
-                  (the fixnum
-                    (package-hashtable-deleted table))))))
-    (declare (fixnum size))
+               (- (package-hashtable-size table)
+                  (package-hashtable-deleted table)))))

     (the fixnum
     (the fixnum

-      (- size
-        (the fixnum
-          (package-hashtable-free table))))))
+      (- size (package-hashtable-free table)))))

 
 (defun package-internal-symbol-count (package)
   (%package-hashtable-symbol-count (package-internal-symbols package)))
 
 (defun package-internal-symbol-count (package)
   (%package-hashtable-symbol-count (package-internal-symbols package)))

@@ -191,9 +189,7 @@
         (sxhash (%sxhash-simple-string (symbol-name symbol)))
         (h2 (the fixnum (1+ (the fixnum (rem sxhash
                                              (the fixnum (- len 2))))))))
         (sxhash (%sxhash-simple-string (symbol-name symbol)))
         (h2 (the fixnum (1+ (the fixnum (rem sxhash
                                              (the fixnum (- len 2))))))))

-    (declare (simple-vector vec)
-            (type (simple-array (unsigned-byte 8)) hash)
-            (fixnum len sxhash h2))
+    (declare (fixnum len sxhash h2))

     (cond ((zerop (the fixnum (package-hashtable-free table)))
           (make-or-remake-package-hashtable (* (package-hashtable-size table)
                                                2)
     (cond ((zerop (the fixnum (package-hashtable-free table)))
           (make-or-remake-package-hashtable (* (package-hashtable-size table)
                                                2)

@@ -207,19 +203,18 @@
           (do ((i (rem sxhash len) (rem (+ i h2) len)))
               ((< (the fixnum (aref hash i)) 2)
                (if (zerop (the fixnum (aref hash i)))
           (do ((i (rem sxhash len) (rem (+ i h2) len)))
               ((< (the fixnum (aref hash i)) 2)
                (if (zerop (the fixnum (aref hash i)))

-                   (decf (the fixnum (package-hashtable-free table)))
-                   (decf (the fixnum (package-hashtable-deleted table))))
+                   (decf (package-hashtable-free table))
+                   (decf (package-hashtable-deleted table)))

                (setf (svref vec i) symbol)
                (setf (aref hash i)
                (setf (svref vec i) symbol)
                (setf (aref hash i)

-                     (entry-hash (length (the simple-string
-                                              (symbol-name symbol)))
+                     (entry-hash (length (symbol-name symbol))

                                  sxhash)))
             (declare (fixnum i)))))))
 
                                  sxhash)))
             (declare (fixnum i)))))))
 

-;;; 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.

 (defmacro with-symbol ((index-var symbol-var table string length sxhash
                                  entry-hash)
                       &body forms)
 (defmacro with-symbol ((index-var symbol-var table string length sxhash
                                  entry-hash)
                       &body forms)

@@ -230,9 +225,7 @@
            (,len (length ,vec))
            (,h2 (1+ (the index (rem (the index ,sxhash)
                                      (the index (- ,len 2)))))))
            (,len (length ,vec))
            (,h2 (1+ (the index (rem (the index ,sxhash)
                                      (the index (- ,len 2)))))))

-       (declare (type (simple-array (unsigned-byte 8) (*)) ,hash)
-               (simple-vector ,vec)
-               (type index ,len ,h2))
+       (declare (type index ,len ,h2))

        (prog ((,index-var (rem (the index ,sxhash) ,len))
              ,symbol-var ,ehash)
         (declare (type (or index null) ,index-var))
        (prog ((,index-var (rem (the index ,sxhash) ,len))
              ,symbol-var ,ehash)
         (declare (type (or index null) ,index-var))

@@ -242,8 +235,7 @@
                (setq ,symbol-var (svref ,vec ,index-var))
                (let* ((,name (symbol-name ,symbol-var))
                       (,name-len (length ,name)))
                (setq ,symbol-var (svref ,vec ,index-var))
                (let* ((,name (symbol-name ,symbol-var))
                       (,name-len (length ,name)))

-                 (declare (simple-string ,name)
-                          (type index ,name-len))
+                 (declare (type index ,name-len))

                  (when (and (= ,name-len ,length)
                             (string= ,string ,name
                                      :end1 ,length
                  (when (and (= ,name-len ,length)
                             (string= ,string ,name
                                      :end1 ,length

@@ -300,18 +292,19 @@
             (push n (package-%nicknames package)))))))
 
 (defun make-package (name &key
             (push n (package-%nicknames package)))))))
 
 (defun make-package (name &key

-                         (use *default-package-use-list*)
+                         (use '#.*default-package-use-list*)

                          nicknames
                          (internal-symbols 10)
                          (external-symbols 10))
   #!+sb-doc
                          nicknames
                          (internal-symbols 10)
                          (external-symbols 10))
   #!+sb-doc

-  "Makes a new package having the specified Name and Nicknames. The
-  package will inherit all external symbols from each package in
-  the use list. :INTERNAL-SYMBOLS and :EXTERNAL-SYMBOLS are
+  #.(format nil
+     "Make a new package having the specified NAME, NICKNAMES, and 
+  USE list. :INTERNAL-SYMBOLS and :EXTERNAL-SYMBOLS are

   estimates for the number of internal and external symbols which
   will ultimately be present in the package. The default value of
   estimates for the number of internal and external symbols which
   will ultimately be present in the package. The default value of

-  USE is implementation-dependent, and in this implementation 
-  it is simply NIL."
+  USE is implementation-dependent, and in this implementation
+  it is ~S."
+     *default-package-use-list*)

 
   ;; Check for package name conflicts in name and nicknames, then
   ;; make the package.
 
   ;; Check for package name conflicts in name and nicknames, then
   ;; make the package.

@@ -359,7 +352,10 @@
         (name (string name))
         (found (find-package name)))
     (unless (or (not found) (eq found package))
         (name (string name))
         (found (find-package name)))
     (unless (or (not found) (eq found package))

-      (error "A package named ~S already exists." name))
+      (error 'simple-package-error
+            :package name
+            :format-control "A package named ~S already exists."
+            :format-arguments (list name)))

     (remhash (package-%name package) *package-names*)
     (dolist (n (package-%nicknames package))
       (remhash n *package-names*))
     (remhash (package-%name package) *package-names*)
     (dolist (n (package-%nicknames package))
       (remhash n *package-names*))

@@ -525,7 +521,7 @@
   (let* ((package (find-undeleted-package-or-lose package))
         (name (symbol-name symbol))
         (shadowing-symbols (package-%shadowing-symbols package)))
   (let* ((package (find-undeleted-package-or-lose package))
         (name (symbol-name symbol))
         (shadowing-symbols (package-%shadowing-symbols package)))

-    (declare (list shadowing-symbols) (simple-string name))
+    (declare (list shadowing-symbols))

 
     ;; If a name conflict is revealed, give use a chance to shadowing-import
     ;; one of the accessible symbols.
 
     ;; If a name conflict is revealed, give use a chance to shadowing-import
     ;; one of the accessible symbols.

@@ -544,9 +540,9 @@
           (let ((sym (read *query-io*)))
             (cond
              ((not (symbolp sym))
           (let ((sym (read *query-io*)))
             (cond
              ((not (symbolp sym))

-              (format *query-io* "~S is not a symbol."))
+              (format *query-io* "~S is not a symbol." sym))

              ((not (member sym cset))
              ((not (member sym cset))

-              (format *query-io* "~S is not one of the conflicting symbols."))
+              (format *query-io* "~S is not one of the conflicting symbols." sym))

              (t
               (shadowing-import sym package)
               (return-from unintern t)))))))
              (t
               (shadowing-import sym package)
               (return-from unintern t)))))))

@@ -575,9 +571,9 @@
        (t
         (error "~S is neither a symbol nor a list of symbols." thing))))
 
        (t
         (error "~S is neither a symbol nor a list of symbols." thing))))
 

-;;; Like UNINTERN, but if symbol is inherited chases down the package
-;;; it is inherited from and uninterns it there. Used for
-;;; name-conflict resolution. Shadowing symbols are not uninterned
+;;; This is like UNINTERN, except if SYMBOL is inherited, it chases
+;;; down the package it is inherited from and uninterns it there. Used
+;;; for name-conflict resolution. Shadowing symbols are not uninterned

 ;;; since they do not cause conflicts.
 (defun moby-unintern (symbol package)
   (unless (member symbol (package-%shadowing-symbols package))
 ;;; since they do not cause conflicts.
 (defun moby-unintern (symbol package)
   (unless (member symbol (package-%shadowing-symbols package))

@@ -822,7 +818,8 @@
          (when cset
            (cerror
             "Unintern the conflicting symbols in the ~2*~A package."
          (when cset
            (cerror
             "Unintern the conflicting symbols in the ~2*~A package."

-            "Use'ing package ~A results in name conflicts for these symbols:~%~S"
+            "Using package ~A results in name conflicts for these symbols:~%~
+              ~S"

             (package-%name pkg) cset (package-%name package))
            (dolist (s cset) (moby-unintern s package))))
 
             (package-%name pkg) cset (package-%name package))
            (dolist (s cset) (moby-unintern s package))))
 

@@ -881,7 +878,8 @@
        (do-symbols (symbol package)
          (when (and (eq (symbol-package symbol) package)
                     (or (not external-only)
        (do-symbols (symbol package)
          (when (and (eq (symbol-package symbol) package)
                     (or (not external-only)

-                        (eq (find-symbol (symbol-name symbol) package)
+                        (eq (nth-value 1 (find-symbol (symbol-name symbol)
+                                                      package))

                             :external))
                     (search string (symbol-name symbol) :test #'char-equal))
            (push symbol result)))
                             :external))
                     (search string (symbol-name symbol) :test #'char-equal))
            (push symbol result)))

@@ -942,7 +940,9 @@
        (add-symbol external symbol))
 
       ;; Put shadowing symbols in the shadowing symbols list.
        (add-symbol external symbol))
 
       ;; Put shadowing symbols in the shadowing symbols list.

-      (setf (package-%shadowing-symbols pkg) (sixth spec))))
+      (setf (package-%shadowing-symbols pkg) (sixth spec))
+      ;; Set the package documentation
+      (setf (package-doc-string pkg) (seventh spec))))

 
   ;; FIXME: These assignments are also done at toplevel in
   ;; boot-extensions.lisp. They should probably only be done once.
 
   ;; FIXME: These assignments are also done at toplevel in
   ;; boot-extensions.lisp. They should probably only be done once.