X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcold%2Fset-up-cold-packages.lisp;h=c2669712d1e41867b763fc81dd7922b075a1e03c;hb=7ff2233608f1f110e112ae576fa829618ce181ae;hp=d3c1e2b8b2798d9081f71f2f3a90426bb610af99;hpb=6139c89c89f45c03509e4f3156293ff656716a8c;p=sbcl.git diff --git a/src/cold/set-up-cold-packages.lisp b/src/cold/set-up-cold-packages.lisp index d3c1e2b..c266971 100644 --- a/src/cold/set-up-cold-packages.lisp +++ b/src/cold/set-up-cold-packages.lisp @@ -15,11 +15,11 @@ ;;; 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-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")) @@ -50,79 +50,87 @@ ;; can without referring to any other packages. (dolist (package-data package-data-list) (let* ((package (make-package - (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))) - #-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))))))