X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-package.lisp;h=a8a8ea7254d111cb4dda18c4344e62cd87741fac;hb=3eb39e017e52b5d704e7d33405c873af52a533fd;hp=baa3ef8ba8ac3c7489a7c3e1a4899cf1112bce1c;hpb=95a6db7329b91dd90d165dd4057b9b5098d34aa2;p=sbcl.git diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index baa3ef8..a8a8ea7 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -24,14 +24,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 @@ -84,57 +76,34 @@ ;;; 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)) - -(flet ((stuff (table) - (let ((size (the fixnum - (- (the fixnum (package-hashtable-size table)) - (the fixnum - (package-hashtable-deleted table)))))) - (declare (fixnum size)) - (values (the fixnum - (- size - (the fixnum - (package-hashtable-free table)))) - size)))) - (defun package-internal-symbol-count (package) - (stuff (package-internal-symbols package))) - (defun package-external-symbol-count (package) - (stuff (package-external-symbols package)))) + (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)) + (the fixnum + (- size + (the fixnum + (package-hashtable-free table)))))) + +(defun package-internal-symbol-count (package) + (%package-hashtable-symbol-count (package-internal-symbols package))) + +(defun package-external-symbol-count (package) + (%package-hashtable-symbol-count (package-external-symbols package))) -(defvar *package* () ; actually initialized in cold load +(defvar *package* (error "*PACKAGE* should be initialized in cold load!") #!+sb-doc "the current package") ;;; FIXME: should be declared of type PACKAGE, with no NIL init form, ;;; after I get around to cleaning up DOCUMENTATION -;;; -;;; FIXME: Setting *PACKAGE* to a non-PACKAGE value (even a plausible -;;; one, like :CL-USER) makes the system fairly unusable, without -;;; generating useful diagnostics. Is it possible to handle this -;;; situation more gracefully by replacing references to *PACKAGE* -;;; with references to (DEFAULT-PACKAGE) and implementing -;;; DEFAULT-PACKAGE so that it checks for the PACKAGEness of *PACKAGE* -;;; and helps the user to fix any problem (perhaps going through -;;; CERROR)? -;;; Error: An attempt was made to use the *PACKAGE* variable when it was -;;; bound to the illegal (non-PACKAGE) value ~S. This is -;;; forbidden by the ANSI specification and could have made -;;; the system very confused. The *PACKAGE* variable has been -;;; temporarily reset to #. How -;;; would you like to proceed? -;;; NAMED Set *PACKAGE* to ~S (which is the package which is -;;; named by the old illegal ~S value of *PACKAGE*, and -;;; is thus very likely the intended value) and continue -;;; without signalling an error. -;;; ERROR Leave *PACKAGE* set to # -;;; and signal PACKAGE-ERROR to the code which tried to -;;; use the old illegal value of *PACKAGE*. -;;; CONTINUE Leave *PACKAGE* set to # -;;; and continue without signalling an error. ;;; a map from package names to packages (defvar *package-names*) @@ -285,7 +254,7 @@ DOIT (return (progn ,@forms)))))) -;;; Delete the entry for String in Table. The entry must exist. +;;; Delete the entry for STRING in TABLE. The entry must exist. (defun nuke-symbol (table string) (declare (simple-string string)) (let* ((length (length string)) @@ -297,11 +266,11 @@ (setf (aref (package-hashtable-table table) index) nil) (incf (package-hashtable-deleted table))))) -;;; Enter any new Nicknames for Package into *package-names*. +;;; Enter any new NICKNAMES for PACKAGE into *PACKAGE-NAMES*. ;;; If there is a conflict then give the user a chance to do ;;; something about it. (defun enter-new-nicknames (package nicknames) - (check-type nicknames list) + (declare (type list nicknames)) (dolist (n nicknames) (let* ((n (package-namify n)) (found (gethash n *package-names*))) @@ -326,16 +295,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. @@ -448,17 +420,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 *package*)) +(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) @@ -469,9 +441,9 @@ (length name) (find-undeleted-package-or-lose package)))) -(defun find-symbol (name &optional (package *package*)) +(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." @@ -541,7 +513,7 @@ ;;; If we are uninterning a shadowing symbol, then a name conflict can ;;; result, otherwise just nuke the symbol. -(defun unintern (symbol &optional (package *package*)) +(defun unintern (symbol &optional (package (sane-package))) #!+sb-doc "Makes Symbol no longer present in Package. If Symbol was present then T is returned, otherwise NIL. If Package is Symbol's home @@ -599,9 +571,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)) @@ -617,7 +589,7 @@ (unintern symbol q) (return t)))))))))) -(defun export (symbols &optional (package *package*)) +(defun export (symbols &optional (package (sane-package))) #!+sb-doc "Exports Symbols from Package, checking that no name conflicts result." (let ((package (find-undeleted-package-or-lose package)) @@ -692,7 +664,7 @@ t)) ;;; Check that all symbols are accessible, then move from external to internal. -(defun unexport (symbols &optional (package *package*)) +(defun unexport (symbols &optional (package (sane-package))) #!+sb-doc "Makes Symbols no longer exported from Package." (let ((package (find-undeleted-package-or-lose package)) @@ -715,7 +687,7 @@ ;;; Check for name conflict caused by the import and let the user ;;; shadowing-import if there is. -(defun import (symbols &optional (package *package*)) +(defun import (symbols &optional (package (sane-package))) #!+sb-doc "Make Symbols accessible as internal symbols in Package. If a symbol is already accessible then it has no effect. If a name conflict @@ -755,7 +727,7 @@ ;;; If a conflicting symbol is present, unintern it, otherwise just ;;; stick the symbol in. -(defun shadowing-import (symbols &optional (package *package*)) +(defun shadowing-import (symbols &optional (package (sane-package))) #!+sb-doc "Import Symbols into package, disregarding any name conflict. If a symbol of the same name is present, then it is uninterned. @@ -774,7 +746,7 @@ (pushnew sym (package-%shadowing-symbols package))))) t) -(defun shadow (symbols &optional (package *package*)) +(defun shadow (symbols &optional (package (sane-package))) #!+sb-doc "Make an internal symbol in Package with the same name as each of the specified symbols, adding the new symbols to the Package-Shadowing-Symbols. @@ -794,7 +766,7 @@ t) ;;; Do stuff to use a package, with all kinds of fun name-conflict checking. -(defun use-package (packages-to-use &optional (package *package*)) +(defun use-package (packages-to-use &optional (package (sane-package))) #!+sb-doc "Add all the Packages-To-Use to the use list for Package so that the external symbols of the used packages are accessible as internal @@ -855,9 +827,9 @@ (push package (package-%used-by-list pkg))))) t) -(defun unuse-package (packages-to-unuse &optional (package *package*)) +(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) @@ -874,18 +846,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) @@ -894,24 +863,28 @@ (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 (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 @@ -945,8 +918,8 @@ (let* ((pkg (apply #'make-package (first spec))) (internal (package-internal-symbols pkg)) (external (package-external-symbols pkg))) - (/show0 "back from MAKE-PACKAGE") - #!+sb-show (sb!sys:%primitive print (package-name pkg)) + (/show0 "back from MAKE-PACKAGE, PACKAGE-NAME=..") + (/primitive-print (package-name pkg)) ;; Put internal symbols in the internal hashtable and set package. (dolist (symbol (second spec)) @@ -983,7 +956,7 @@ ;; nicknames that we don't want in our target SBCL. For that reason, ;; we handle it specially, not dumping the host Lisp version at ;; genesis time.. - (assert (not (find-package "COMMON-LISP-USER"))) + (aver (not (find-package "COMMON-LISP-USER"))) ;; ..but instead making our own from scratch here. (/show0 "about to MAKE-PACKAGE COMMON-LISP-USER") (make-package "COMMON-LISP-USER" @@ -991,7 +964,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*.