(!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
;;; 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)))
\f
(defvar *package* (error "*PACKAGE* should be initialized in cold load!")
#!+sb-doc "the current package")
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))
(setf (aref (package-hashtable-table table) index) nil)
(incf (package-hashtable-deleted table)))))
\f
-;;; 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*)))
(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.
(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))
\f
(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)
(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."
(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))
(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)
"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))
\f
;;;; 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)
(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
;; 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"
: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*.