X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcold%2Fset-up-cold-packages.lisp;h=0b6fb57205695f19b4f654245d85c6a6c1b2803b;hb=dccd283c6fedf7fe61d2d2bede328a6b7d92f7be;hp=9db2eebedb0d4dd56769d51e1e56ba9149bb0f98;hpb=e8b69b1dd5564a4237b1bdc1060820c3b820cde2;p=sbcl.git diff --git a/src/cold/set-up-cold-packages.lisp b/src/cold/set-up-cold-packages.lisp index 9db2eeb..0b6fb57 100644 --- a/src/cold/set-up-cold-packages.lisp +++ b/src/cold/set-up-cold-packages.lisp @@ -15,19 +15,16 @@ ;;; 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" @@ -53,72 +50,89 @@ ;; 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))) + #-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))))) ;; 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))))))