X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Ftarget-package.lisp;h=035da80ba5580b6b722ebf47995ad32f98145d24;hb=cd176690400f8b6fa23faa4dc6fa8494bcbce480;hp=4bf4b3f12fac1f677486ac8cd7cc26baf56b8ff2;hpb=ce02ab2ecd9c6ae2e570abd8c93ebf3be55bbdad;p=sbcl.git diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 4bf4b3f..035da80 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -91,21 +91,22 @@ (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)))) +(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* (error "*PACKAGE* should be initialized in cold load!") #!+sb-doc "the current package") @@ -261,7 +262,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)) @@ -273,11 +274,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*))) @@ -424,7 +425,7 @@ (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)) @@ -434,7 +435,7 @@ (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) @@ -447,7 +448,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." @@ -833,7 +834,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) @@ -859,9 +860,6 @@ ;;;; 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) @@ -870,24 +868,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 @@ -959,7 +961,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"