;;; We make no attempt to be fully general; our table doesn't need to be
;;; able to express features which we don't happen to use.
(export '(package-data
- package-data-name
- package-data-nicknames
- package-data-export
- package-data-reexport
- package-data-import-from
- package-data-use))
+ package-data-name
+ package-data-export
+ package-data-reexport
+ package-data-import-from
+ package-data-use))
(defstruct package-data
;; a string designator for the package name
(name (error "missing PACKAGE-DATA-NAME datum"))
;; a doc string
(doc (error "missing PACKAGE-DOC datum"))
- ;; a list of string designators for package nicknames
- nicknames
;; a tree containing names for exported symbols which'll be set up at package
;; creation time, and NILs, which are ignored. (This is a tree in order to
;; allow constructs like '("ENOSPC" #!+LINUX ("EDQUOT" "EISNAM" "ENAVAIL"
;; can without referring to any other packages.
(dolist (package-data package-data-list)
(let* ((package (make-package
- (package-data-name package-data)
- :nicknames (package-data-nicknames package-data)
- :use nil)))
- #-clisp ; As of "2.27 (released 2001-07-17) (built 3215971334)"
- ; CLISP didn't support DOCUMENTATION on PACKAGE values.
- (progn
- #!+sb-doc (setf (documentation package t)
- (package-data-doc package-data)))
- ;; Walk the tree of exported names, exporting each name.
- (labels ((recurse (tree)
- (etypecase tree
- ;; FIXME: The comments above say the structure is a tree,
- ;; but here we're sleazily treating it as though
- ;; dotted lists never occur. Replace this LIST case
- ;; with separate NULL and CONS cases to fix this.
- (list (mapc #'recurse tree))
- (string (export (intern tree package) package)))))
- (recurse (package-data-export package-data)))))
+ (package-data-name package-data)
+ ;; Note: As of 0.7.0, the only nicknames we use
+ ;; for our implementation packages are hacks
+ ;; not needed at cross-compile time (e.g. the
+ ;; deprecated SB-C-CALL nickname for SB-ALIEN).
+ ;; So support for nicknaming during xc is gone,
+ ;; since any nicknames are hacked in during
+ ;; cold init.
+ :nicknames nil
+ :use nil)))
+ (progn
+ #!+sb-doc (setf (documentation package t)
+ (package-data-doc package-data)))
+ ;; Walk the tree of exported names, exporting each name.
+ (labels ((recurse (tree)
+ (etypecase tree
+ ;; FIXME: The comments above say the structure is a tree,
+ ;; but here we're sleazily treating it as though
+ ;; dotted lists never occur. Replace this LIST case
+ ;; with separate NULL and CONS cases to fix this.
+ (list (mapc #'recurse tree))
+ (string (export (intern tree package) package)))))
+ (recurse (package-data-export package-data)))))
;; Now that all packages exist, we can set up package-package
;; references.
(dolist (package-data package-data-list)
(use-package (package-data-use package-data)
- (package-data-name package-data))
+ (package-data-name package-data))
(dolist (sublist (package-data-import-from package-data))
- (let* ((from-package (first sublist))
- (symbol-names (rest sublist))
- (symbols (mapcar (lambda (name)
- ;; old way, broke for importing symbols
- ;; like SB!C::DEBUG-SOURCE-FORM into
- ;; SB!DI -- WHN 19990714
- #+nil
- (let ((s (find-symbol name from-package)))
- (unless s
- (error "can't find ~S in ~S"
- name
- from-package))
- s)
- ;; new way, works for SB!DI stuff
- ;; -- WHN 19990714
- (intern name from-package))
- symbol-names)))
- (import symbols (package-data-name package-data)))))
+ (let* ((from-package (first sublist))
+ (symbol-names (rest sublist))
+ (symbols (mapcar (lambda (name)
+ ;; old way, broke for importing symbols
+ ;; like SB!C::DEBUG-SOURCE-FORM into
+ ;; SB!DI -- WHN 19990714
+ #+nil
+ (let ((s (find-symbol name from-package)))
+ (unless s
+ (error "can't find ~S in ~S"
+ name
+ from-package))
+ s)
+ ;; new way, works for SB!DI stuff
+ ;; -- WHN 19990714
+ (intern name from-package))
+ symbol-names)))
+ (import symbols (package-data-name package-data)))))
;; Now that all package-package references exist, we can handle
;; REEXPORT operations. (We have to wait until now because they
- ;; interact with USE operations.) KLUDGE: This code doesn't detect
- ;; dependencies and do exports in proper order to work around them, so
- ;; it could break randomly (with build-time errors, not with silent
- ;; errors or runtime errors) if multiple levels of re-exportation are
- ;; used, e.g. package A exports X, package B uses A and reexports X,
- ;; and package C uses B and reexports X. That doesn't seem to be an
- ;; issue in the current code, and it's hard to see why anyone would
- ;; want to do it, and it should be straightforward (though tedious) to
- ;; extend the code here to deal with that if it ever becomes necessary.
- (dolist (package-data package-data-list)
- (let ((package (find-package (package-data-name package-data))))
- (dolist (symbol-name (package-data-reexport package-data))
- (multiple-value-bind (symbol status)
- (find-symbol symbol-name package)
- (unless status
- (error "No symbol named ~S is accessible in ~S."
- symbol-name
- package))
- (when (eq (symbol-package symbol) package)
- (error "~S is not inherited/imported, but native to ~S."
- symbol-name
- package))
- (export symbol package))))))
+ ;; interact with USE operations.) This code handles dependencies
+ ;; properly, but is somewhat ugly.
+ (let (done)
+ (labels
+ ((reexport (package-data)
+ (let ((package (find-package (package-data-name package-data))))
+ (cond
+ ((member package done))
+ ((null (package-data-reexport package-data))
+ (push package done))
+ (t
+ (mapcar #'reexport
+ (remove-if-not
+ (lambda (x)
+ (member x (package-data-use package-data)
+ :test #'string=))
+ package-data-list
+ :key #'package-data-name))
+ (dolist (symbol-name (package-data-reexport package-data))
+ (multiple-value-bind (symbol status)
+ (find-symbol symbol-name package)
+ (unless status
+ (error "No symbol named ~S is accessible in ~S."
+ symbol-name package))
+ (when (eq (symbol-package symbol) package)
+ (error
+ "~S is not inherited/imported, but native to ~S."
+ symbol-name package))
+ (export symbol package)))
+ (push package done))))))
+ (dolist (x package-data-list)
+ (reexport x))
+ (assert (= (length done) (length package-data-list))))))
projects / sbcl.git / blobdiff