X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-package.lisp;h=ab640e9c4b7a5ad35092ec13ab724575801bc368;hb=f9c9b95e86c05a63192533e2d57050ae48a62472;hp=be3cbd1fd5b1867b9266c3b7856f255903b1e9b7;hpb=416152f084604094445a758ff399871132dff2bd;p=sbcl.git diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index be3cbd1..ab640e9 100644 --- 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. +;;;; +;;;; 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. @@ -24,14 +27,6 @@ (!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") ;;;; PACKAGE-HASHTABLE stuff @@ -54,22 +49,26 @@ ;;; 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))) ;;;; miscellaneous PACKAGE operations @@ -84,23 +83,19 @@ ;;; 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))) @@ -135,12 +130,29 @@ (!cold-init-forms (setf *!deferred-use-packages* nil)) -;;; FIXME: I rewrote this. Test it and the stuff that calls it. +(define-condition bootstrap-package-not-found (condition) + ((name :initarg :name :reader bootstrap-package-name))) +(defun debootstrap-package (&optional condition) + (invoke-restart + (find-restart-or-control-error 'debootstrap-package condition))) + (defun find-package (package-designator) (flet ((find-package-from-string (string) (declare (type string string)) - (values (gethash string *package-names*)))) - (declare (inline find-package-from-string)) + (let ((packageoid (gethash string *package-names*))) + (when (and (null packageoid) + (not *in-package-init*) ; KLUDGE + (let ((mismatch (mismatch "SB!" string))) + (and mismatch (= mismatch 3)))) + (restart-case + (signal 'bootstrap-package-not-found :name string) + (debootstrap-package () + (return-from find-package + (if (string= string "SB!XC") + (find-package "COMMON-LISP") + (find-package + (substitute #\- #\! string :count 1))))))) + packageoid))) (typecase package-designator (package package-designator) (symbol (find-package-from-string (symbol-name package-designator))) @@ -194,9 +206,7 @@ (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) @@ -210,19 +220,18 @@ (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) @@ -233,9 +242,7 @@ (,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)) @@ -245,8 +252,7 @@ (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 @@ -303,16 +309,19 @@ (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. @@ -360,7 +369,10 @@ (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*)) @@ -425,17 +437,17 @@ (defun list-all-packages () #!+sb-doc - "Returns a list of all existing packages." + "Return a list of all existing packages." (let ((res ())) - (maphash #'(lambda (k v) - (declare (ignore k)) - (pushnew v res)) + (maphash (lambda (k v) + (declare (ignore k)) + (pushnew v res)) *package-names*) res)) (defun intern (name &optional (package (sane-package))) #!+sb-doc - "Returns a symbol having the specified name, creating it if necessary." + "Return a symbol having the specified name, creating it if necessary." ;; We just simple-stringify the name and call INTERN*, where the real ;; logic is. (let ((name (if (simple-string-p name) @@ -448,7 +460,7 @@ (defun find-symbol (name &optional (package (sane-package))) #!+sb-doc - "Returns the symbol named String in Package. If such a symbol is found + "Return the symbol named String in Package. If such a symbol is found then the second value is :internal, :external or :inherited to indicate how the symbol is accessible. If no symbol is found then both values are NIL." @@ -526,7 +538,7 @@ (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. @@ -545,9 +557,9 @@ (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)) - (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))))))) @@ -576,9 +588,9 @@ (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)) @@ -823,7 +835,8 @@ (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)))) @@ -834,7 +847,7 @@ (defun unuse-package (packages-to-unuse &optional (package (sane-package))) #!+sb-doc - "Remove Packages-To-Unuse from the use list for Package." + "Remove PACKAGES-TO-UNUSE from the USE list for PACKAGE." (let ((package (find-undeleted-package-or-lose package))) (dolist (p (package-listify packages-to-unuse)) (setf (package-%use-list package) @@ -851,18 +864,15 @@ "Return a list of all symbols in the system having the specified name." (let ((string (string string-or-symbol)) (res ())) - (maphash #'(lambda (k v) - (declare (ignore k)) - (multiple-value-bind (s w) (find-symbol string v) - (when w (pushnew s res)))) + (maphash (lambda (k v) + (declare (ignore k)) + (multiple-value-bind (s w) (find-symbol string v) + (when w (pushnew s res)))) *package-names*) res)) ;;;; APROPOS and APROPOS-LIST -;;; KLUDGE: All the APROPOS stuff should probably be byte-compiled, since it's -;;; only likely to be used interactively. -- WHN 19990827 - (defun briefly-describe-symbol (symbol) (fresh-line) (prin1 symbol) @@ -871,24 +881,29 @@ (when (fboundp symbol) (write-string " (fbound)"))) -(defun apropos-list (string-designator &optional package external-only) +(defun apropos-list (string-designator + &optional + package-designator + external-only) #!+sb-doc "Like APROPOS, except that it returns a list of the symbols found instead of describing them." - (if package - (let ((string (stringify-name string-designator "APROPOS search")) - (result nil)) - (do-symbols (symbol package) - (when (and (eq (symbol-package symbol) package) - (or (not external-only) - (eq (find-symbol (symbol-name symbol) package) - :external)) - (search string (symbol-name symbol) :test #'char-equal)) - (push symbol result))) - result) - (mapcan (lambda (package) - (apropos-list string-designator package external-only)) - (list-all-packages)))) + (if package-designator + (let ((package (find-undeleted-package-or-lose package-designator)) + (string (stringify-name string-designator "APROPOS search")) + (result nil)) + (do-symbols (symbol package) + (when (and (eq (symbol-package symbol) package) + (or (not external-only) + (eq (nth-value 1 (find-symbol (symbol-name symbol) + package)) + :external)) + (search string (symbol-name symbol) :test #'char-equal)) + (push symbol result))) + result) + (mapcan (lambda (package) + (apropos-list string-designator package external-only)) + (list-all-packages)))) (defun apropos (string-designator &optional package external-only) #!+sb-doc @@ -942,7 +957,9 @@ (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. @@ -968,7 +985,7 @@ :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*.