X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcold%2Fset-up-cold-packages.lisp;h=6533047ddd6134cdcf8f2b41927df1f629b67c50;hb=50f728671defadb8f7b1e8691c984cb0e6aba17c;hp=5de7da94b12877822b9d0ae5189fe0c5f298a612;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git

diff --git a/src/cold/set-up-cold-packages.lisp b/src/cold/set-up-cold-packages.lisp
index 5de7da9..6533047 100644
--- a/src/cold/set-up-cold-packages.lisp
+++ b/src/cold/set-up-cold-packages.lisp
@@ -9,8 +9,6 @@
 
 (in-package "SB-COLD")
 
-;;;; $Header$
-
 ;;; an entry in the table which describes the non-standard part (i.e. not
 ;;; CL/CL-USER/KEYWORD) of the package structure of the SBCL system
 ;;;
@@ -18,7 +16,6 @@
 ;;; 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
@@ -28,8 +25,6 @@
   (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"
@@ -56,10 +51,20 @@
     (dolist (package-data package-data-list)
       (let* ((package (make-package
 		       (package-data-name package-data)
-		       :nicknames (package-data-nicknames 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)))
-	#!+sb-doc (setf (documentation package t)
-			(package-data-doc package-data))
+	#-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
@@ -98,26 +103,36 @@
 
     ;; 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))))))