;;;; 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.
(!cold-init-forms
(/show0 "entering !PACKAGE-COLD-INIT"))
-
-(defvar *default-package-use-list*)
-(!cold-init-forms
- (setf *default-package-use-list* '("COMMON-LISP")))
-#!+sb-doc
-(setf (fdocumentation '*default-package-use-list* 'variable)
- "the list of packages to use by default when no :USE argument is supplied
- to MAKE-PACKAGE or other package creation forms")
\f
;;;; PACKAGE-HASHTABLE stuff
;;; 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
;;; ANSI says (in the definition of DELETE-PACKAGE) that these, and
;;; most other operations, are unspecified for deleted packages. We
;;; just do the easy thing and signal errors in that case.
-(macrolet ((def-frob (ext real)
+(macrolet ((def (ext real)
`(defun ,ext (x) (,real (find-undeleted-package-or-lose x)))))
- (def-frob package-nicknames package-%nicknames)
- (def-frob package-use-list package-%use-list)
- (def-frob package-used-by-list package-%used-by-list)
- (def-frob package-shadowing-symbols package-%shadowing-symbols))
+ (def package-nicknames package-%nicknames)
+ (def package-use-list package-%use-list)
+ (def package-used-by-list package-%used-by-list)
+ (def package-shadowing-symbols package-%shadowing-symbols))
(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
- (- 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)))
(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)
(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)
- (entry-hash (length (the simple-string
- (symbol-name symbol)))
+ (entry-hash (length (symbol-name symbol))
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)
(,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))
(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
(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
- "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."
+ will ultimately be present in the package. The default value of
+ 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.
(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*))
(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.
(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))
(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.
:use '("COMMON-LISP"
;; ANSI encourages us to put extension packages
;; in the USE list of COMMON-LISP-USER.
- "SB!ALIEN" "SB!C-CALL" "SB!DEBUG"
+ "SB!ALIEN" "SB!ALIEN" "SB!DEBUG"
"SB!EXT" "SB!GRAY" "SB!PROFILE"))
;; Now do the *!DEFERRED-USE-PACKAGES*.
projects / sbcl.git / blobdiff