(in-package "SB!IMPL")
-(file-comment
- "$Header$")
-
(!begin-collecting-cold-init-forms)
(!cold-init-forms
(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)))
\f
-(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 #<PACKAGE "COMMON-LISP-USER">. 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 #<PACKAGE "COMMON-LISP-USER">
-;;; and signal PACKAGE-ERROR to the code which tried to
-;;; use the old illegal value of *PACKAGE*.
-;;; CONTINUE Leave *PACKAGE* set to #<PACKAGE "COMMON-LISP-USER">
-;;; and continue without signalling an error.
;;; a map from package names to packages
(defvar *package-names*)
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*)))
*package-names*)
res))
\f
-(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."
;; We just simple-stringify the name and call INTERN*, where the real
(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
then the second value is :internal, :external or :inherited to indicate
\f
;;; 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
(unintern symbol q)
(return t))))))))))
\f
-(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))
t))
\f
;;; 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))
\f
;;; 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
\f
;;; 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.
(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.
t)
\f
;;; 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
(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."
(let ((package (find-undeleted-package-or-lose package)))
\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)
(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))
;; Put shadowing symbols in the shadowing symbols list.
(setf (package-%shadowing-symbols pkg) (sixth spec))))
+ ;; FIXME: These assignments are also done at toplevel in
+ ;; boot-extensions.lisp. They should probably only be done once.
+ (/show0 "setting up *CL-PACKAGE* and *KEYWORD-PACKAGE*")
+ (setq *cl-package* (find-package "COMMON-LISP"))
+ (setq *keyword-package* (find-package "KEYWORD"))
+
(/show0 "about to MAKUNBOUND *!INITIAL-SYMBOLS*")
(makunbound '*!initial-symbols*) ; (so that it gets GCed)
- ;; Make some other packages that should be around in the cold load. The
- ;; COMMON-LISP-USER package is required by the ANSI standard, but not
- ;; completely specified by it, so in the cross-compilation host Lisp it could
- ;; contain various symbols, USE-PACKAGEs, or 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")))
+ ;; Make some other packages that should be around in the cold load.
+ ;; The COMMON-LISP-USER package is required by the ANSI standard,
+ ;; but not completely specified by it, so in the cross-compilation
+ ;; host Lisp it could contain various symbols, USE-PACKAGEs, or
+ ;; 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..
+ (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"
:nicknames '("CL-USER")
:use '("COMMON-LISP"
- ;; ANSI encourages us to put extension packages in the
- ;; USE list of COMMON-LISP-USER.
+ ;; ANSI encourages us to put extension packages
+ ;; in the USE list of COMMON-LISP-USER.
"SB!ALIEN" "SB!C-CALL" "SB!DEBUG"
"SB!EXT" "SB!GRAY" "SB!PROFILE"))
(/show0 "about to SETQ *IN-PACKAGE-INIT*")
(setq *in-package-init* nil)
- ;; FIXME: These assignments are also done at toplevel in
- ;; boot-extensions.lisp. They should probably only be done once.
- (setq *cl-package* (find-package "COMMON-LISP"))
- (setq *keyword-package* (find-package "KEYWORD"))
-
;; For the kernel core image wizards, set the package to *CL-PACKAGE*.
;;
- ;; FIXME: We should just set this to (FIND-PACKAGE "COMMON-LISP-USER")
- ;; once and for all here, instead of setting it once here and resetting
- ;; it later.
+ ;; FIXME: We should just set this to (FIND-PACKAGE
+ ;; "COMMON-LISP-USER") once and for all here, instead of setting it
+ ;; once here and resetting it later.
(setq *package* *cl-package*))
\f
(!cold-init-forms
projects / sbcl.git / blobdiff