From 3da6b370365bfaf3c15c13b2560c8148f6e927a6 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 20 Aug 2001 21:02:43 +0000
Subject: [PATCH] More changes to .pkd files: now the information about loading
 and initialization is separated from the information about environments and
 bindings.  The load/initialization sequence as written in the .pkg file is
 preserved in the .pkd file.

---
 v7/src/cref/conpkg.scm    | 115 +++++++++++++++-----------
 v7/src/cref/object.scm    | 136 ++++++++++++++-----------------
 v7/src/cref/redpkg.scm    | 164 ++++++++++++++++++++++++--------------
 v7/src/cref/triv.pkg      | 109 +++++++++++++------------
 v7/src/runtime/packag.scm | 133 +++++++++++++++++--------------
 5 files changed, 361 insertions(+), 296 deletions(-)

diff --git a/v7/src/cref/conpkg.scm b/v7/src/cref/conpkg.scm
index 9a165f866..d83090690 100644
--- a/v7/src/cref/conpkg.scm
+++ b/v7/src/cref/conpkg.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: conpkg.scm,v 1.12 2001/08/20 02:48:57 cph Exp $
+$Id: conpkg.scm,v 1.13 2001/08/20 21:02:35 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -26,27 +26,41 @@ USA.
 	 (integrate-external "object"))
 
 (define (construct-external-descriptions pmodel)
-  (let* ((packages (pmodel/packages pmodel))
-	 (alist
-	  (append! (map (lambda (package)
-			  (cons package
-				(construct-external-description package #f)))
-			packages)
-		   (map (lambda (package)
-			  (cons package
-				(construct-external-description package #t)))
-			(list-transform-positive
-			    (pmodel/extra-packages pmodel)
-			  (lambda (package)
-			    (pair? (package/files package))))))))
-    (vector 'PACKAGE-DESCRIPTIONS	;tag
-	    2				;version
-	    (list->vector
-	     (map cdr
-		  (sort alist
-		    (lambda (a b)
-		      (package-structure<? (car a) (car b))))))
-	    (list->vector (map cdr alist)))))
+  (vector 'PACKAGE-DESCRIPTIONS		;tag
+	  2				;version
+	  (list->vector
+	   (map cdr
+		(sort (append!
+		       (map (lambda (package)
+			      (cons package (package->external package #f)))
+			    (pmodel/packages pmodel))
+		       (map (lambda (package)
+			      (cons package (package->external package #t)))
+			    (new-extension-packages pmodel)))
+		      (lambda (a b)
+			(package-structure<? (car a) (car b))))))
+	  (list->vector
+	   (map package-load->external
+		(list-transform-positive (pmodel/loads pmodel)
+		  (lambda (load)
+		    (or (pair? (package-load/file-cases load))
+			(pair? (package-load/initializations load))
+			(pair? (package-load/finalizations load)))))))))
+
+(define (new-extension-packages pmodel)
+  (list-transform-positive (pmodel/extra-packages pmodel)
+    (lambda (package)
+      (or (there-exists? (package/links package) link/new?)
+	  (there-exists? (package/sorted-bindings package)
+	    new-internal-binding?)))))
+
+(define (new-internal-binding? binding)
+  (and (binding/new? binding)
+       (binding/internal? binding)
+       (not (there-exists? (binding/links binding)
+	      (let ((package (binding/package binding)))
+		(lambda (link)
+		  (eq? (link/owner link) package)))))))
 
 (define (package-structure<? x y)
   (cond ((package/topological<? x y) true)
@@ -57,41 +71,24 @@ USA.
   (and (not (eq? x y))
        (let loop ((y (package/parent y)))
 	 (and y
+	      (not (eq? y 'UNKNOWN))
 	      (if (eq? x y)
 		  true
 		  (loop (package/parent y)))))))
 
-(define (construct-external-description package extension?)
+(define (package->external package extension?)
   (call-with-values (lambda () (split-links package))
     (lambda (exports imports)
       (vector (package/name package)
 	      (let loop ((package package))
 		(let ((parent (package/parent package)))
-		  (if parent
+		  (if (and parent (not (eq? parent 'UNKNOWN)))
 		      (cons (package/name parent) (loop parent))
 		      '())))
-	      (map (lambda (file-case)
-		     (cons (file-case/type file-case)
-			   (if (file-case/type file-case)
-			       (map (lambda (clause)
-				      (cons (file-case-clause/keys clause)
-					    (map-files clause)))
-				    (file-case/clauses file-case))
-			       (map-files
-				(car (file-case/clauses file-case))))))
-		   (package/file-cases package))
-	      (package/initialization package)
-	      (package/finalization package)
 	      (list->vector
 	       (map binding/name
 		    (list-transform-positive (package/sorted-bindings package)
-		      (lambda (binding)
-			(and (binding/new? binding)
-			     (binding/internal? binding)
-			     (not (there-exists? (binding/links binding)
-				    (lambda (link)
-				      (memq link
-					    (package/links package))))))))))
+		      new-internal-binding?)))
 	      (list->vector
 	       (map (lambda (link)
 		      (let ((source (link/source link))
@@ -121,10 +118,34 @@ USA.
     (if (pair? links)
 	(let ((link (car links))
 	      (links (cdr links)))
-	  (if (eq? (binding/package (link/source link)) package)
-	      (loop links (cons link exports) imports)
-	      (loop links exports (cons link imports))))
+	  (if (link/new? link)
+	      (if (eq? (binding/package (link/source link)) package)
+		  (loop links (cons link exports) imports)
+		  (loop links exports (cons link imports)))
+	      (loop links exports imports)))
 	(values exports imports))))
 
+(define (package-load->external description)
+  (vector (package/name (package-load/package description))
+	  (list->vector
+	   (map (lambda (file-case)
+		  (if (file-case/type file-case)
+		      (cons (file-case/type file-case)
+			    (map-clauses file-case))
+		      (map-files (car (file-case/clauses file-case)))))
+		(package-load/file-cases description)))
+	  (list->vector (package-load/initializations description))
+	  (list->vector (package-load/finalizations description))))
+
+(define (map-clauses file-case)
+  (list->vector
+   (map (lambda (clause)
+	  (cons (let ((keys (file-case-clause/keys clause)))
+		  (if (list? keys)
+		      (list->vector keys)
+		      keys))
+		(map-files clause)))
+	(file-case/clauses file-case))))
+
 (define (map-files clause)
-  (map ->namestring (file-case-clause/files clause)))
\ No newline at end of file
+  (list->vector (map ->namestring (file-case-clause/files clause))))
\ No newline at end of file
diff --git a/v7/src/cref/object.scm b/v7/src/cref/object.scm
index 9677aa2f3..5dd7d031f 100644
--- a/v7/src/cref/object.scm
+++ b/v7/src/cref/object.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: object.scm,v 1.13 2001/08/20 02:49:01 cph Exp $
+$Id: object.scm,v 1.14 2001/08/20 21:02:37 cph Exp $
 
 Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
 
@@ -24,49 +24,35 @@ USA.
 
 (declare (usual-integrations))
 
-(define-structure
-    (package-description
-     (type vector)
-     (named
-      (string->symbol "#[(cross-reference)package-description]"))
-     (constructor make-package-description (name parent))
-     (conc-name package-description/))
+(define-structure (package-description
+		   (constructor make-package-description (name parent))
+		   (conc-name package-description/))
   (name #f read-only #t)
   (file-cases '())
   (parent #f read-only #t)
-  (initialization #f)
-  (finalization #f)
+  (initializations '())
+  (finalizations '())
   (exports '())
   (imports '()))
 
-(define-structure
-    (pmodel
-     (type vector)
-     (named (string->symbol "#[(cross-reference)pmodel]"))
-     (conc-name pmodel/))
+(define-structure (pmodel (conc-name pmodel/))
   (root-package #f read-only #t)
   (primitive-package #f read-only #t)
   (packages #f read-only #t)
   (extra-packages #f read-only #t)
+  (loads #f read-only #t)
   (pathname #f read-only #t))
 
-(define-structure
-    (package
-     (type vector)
-     (named (string->symbol "#[(cross-reference)package]"))
-     (constructor make-package (name parent))
-     (conc-name package/)
-     (print-procedure
-      (standard-unparser-method 'PACKAGE
-	(lambda (package port)
-	  (write-char #\space port)
-	  (write (package/name package) port)))))
-
+(define-structure (package
+		   (constructor make-package (name parent))
+		   (conc-name package/)
+		   (print-procedure
+		    (standard-unparser-method 'PACKAGE
+		      (lambda (package port)
+			(write-char #\space port)
+			(write (package/name package) port)))))
   (name #f read-only #t)
-  (file-cases '())
   (files '())
-  (initialization #f)
-  (finalization #f)
   parent
   (children '())
   (bindings (make-rb-tree eq? symbol<?) read-only #t)
@@ -100,19 +86,24 @@ USA.
 (define-integrable (file-case-clause/files clause)
   (cdr clause))
 
-(define-structure
-    (binding
-     (type vector)
-     (named (string->symbol "#[(cross-reference)binding]"))
-     (constructor %make-binding (package name value-cell new?))
-     (conc-name binding/)
-     (print-procedure
-      (standard-unparser-method 'BINDING
-	(lambda (binding port)
-	  (write-char #\space port)
-	  (write (binding/name binding) port)
-	  (write-char #\space port)
-	  (write (package/name (binding/package binding)) port)))))
+(define-structure (package-load
+		   (conc-name package-load/))
+  (package #f read-only #t)
+  (file-cases '())
+  (initializations #f)
+  (finalizations #f))
+
+(define-structure (binding
+		   (constructor %make-binding (package name value-cell new?))
+		   (conc-name binding/)
+		   (print-procedure
+		    (standard-unparser-method 'BINDING
+		      (lambda (binding port)
+			(write-char #\space port)
+			(write (binding/name binding) port)
+			(write-char #\space port)
+			(write (package/name (binding/package binding))
+			       port)))))
   (package #f read-only #t)
   (name #f read-only #t)
   (value-cell #f read-only #t)
@@ -136,59 +127,48 @@ USA.
 (define (binding/internal? binding)
   (eq? binding (binding/source-binding binding)))
 
-(define-structure
-    (value-cell
-     (type vector)
-     (named (string->symbol "#[(cross-reference)value-cell]"))
-     (constructor make-value-cell ())
-     (conc-name value-cell/))
+(define-structure (value-cell
+		   (constructor make-value-cell ())
+		   (conc-name value-cell/))
   (bindings '())
   (expressions '())
   (source-binding #f))
 
-(define-structure
-    (link
-     (type vector)
-     (named (string->symbol "#[(cross-reference)link]"))
-     (constructor %make-link (source destination new?))
-     (conc-name link/))
+(define-structure (link
+		   (constructor %make-link (source destination owner new?))
+		   (conc-name link/))
   (source #f read-only #t)
   (destination #f read-only #t)
+  (owner #f read-only #t)
   (new? #f read-only #t))
 
-(define (make-link source-binding destination-binding owner-package new?)
-  (let ((link (%make-link source-binding destination-binding new?)))
+(define (make-link source-binding destination-binding owner new?)
+  (let ((link (%make-link source-binding destination-binding owner new?)))
     (set-binding/links! source-binding
 			(cons link (binding/links source-binding)))
-    (set-package/links! owner-package
-			(cons link (package/links owner-package)))
+    (set-package/links! owner (cons link (package/links owner)))
     link))
 
-(define-structure
-    (expression
-     (type vector)
-     (named (string->symbol "#[(cross-reference)expression]"))
-     (constructor make-expression (package file type))
-     (conc-name expression/))
+(define-structure (expression
+		   (constructor make-expression (package file type))
+		   (conc-name expression/))
   (package #f read-only #t)
   (file #f read-only #t)
   (type #f read-only #t)
   (references '())
   (value-cell #f))
 
-(define-structure
-    (reference
-     (type vector)
-     (named (string->symbol "#[(cross-reference)reference]"))
-     (constructor %make-reference (package name))
-     (conc-name reference/)
-     (print-procedure
-      (standard-unparser-method 'REFERENCE
-	(lambda (reference port)
-	  (write-char #\space port)
-	  (write (reference/name reference) port)
-	  (write-char #\space port)
-	  (write (package/name (reference/package reference)) port)))))
+(define-structure (reference
+		   (constructor %make-reference (package name))
+		   (conc-name reference/)
+		   (print-procedure
+		    (standard-unparser-method 'REFERENCE
+		      (lambda (reference port)
+			(write-char #\space port)
+			(write (reference/name reference) port)
+			(write-char #\space port)
+			(write (package/name (reference/package reference))
+			       port)))))
   (package #f read-only #t)
   (name #f read-only #t)
   (expressions '())
diff --git a/v7/src/cref/redpkg.scm b/v7/src/cref/redpkg.scm
index c05b8c684..6e787bac4 100644
--- a/v7/src/cref/redpkg.scm
+++ b/v7/src/cref/redpkg.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: redpkg.scm,v 1.17 2001/08/20 02:49:09 cph Exp $
+$Id: redpkg.scm,v 1.18 2001/08/20 21:02:41 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -30,10 +30,11 @@ USA.
     (with-values
 	(lambda ()
 	  (sort-descriptions (read-and-parse-model model-pathname)))
-      (lambda (packages extensions globals)
+      (lambda (packages extensions loads globals)
 	(descriptions->pmodel
 	 packages
 	 extensions
+	 loads
 	 (map (lambda (pathname)
 		(cons
 		 (->namestring pathname)
@@ -54,30 +55,61 @@ USA.
 			 #f)))))
 	      globals)
 	 model-pathname)))))
-
+
 (define (sort-descriptions descriptions)
-  (let ((packages '())
-	(extensions '())
-	(globals '()))
-    (let loop ((descriptions descriptions))
-      (for-each (lambda (description)
-		  (case (car description)
-		    ((DEFINE-PACKAGE)
-		     (set! packages (cons (cdr description) packages)))
-		    ((EXTEND-PACKAGE)
-		     (set! extensions (cons (cdr description) extensions)))
-		    ((GLOBAL-DEFINITIONS)
-		     (set! globals
-			   (append! globals (list-copy (cdr description)))))
-		    ((NESTED-DESCRIPTIONS)
-		     (loop (cdr description)))
-		    (else
-		     (error "Unknown description keyword:"
-			    (car description)))))
-		descriptions))
-    (values (reverse! packages)
-	    (reverse! extensions)
-	    globals)))
+  (letrec
+      ((loop
+	(lambda (descriptions packages extensions loads globals)
+	  (if (pair? descriptions)
+	      (let ((description (car descriptions))
+		    (descriptions (cdr descriptions)))
+		(case (car description)
+		  ((DEFINE-PACKAGE)
+		   (loop descriptions
+			 (cons (cdr description) packages)
+			 extensions
+			 (if (interesting-package-to-load? (cdr description))
+			     (cons (cdr description) loads)
+			     loads)
+			 globals))
+		  ((EXTEND-PACKAGE)
+		   (loop descriptions
+			 packages
+			 (cons (cdr description) extensions)
+			 (if (interesting-package-to-load? (cdr description))
+			     (cons (cdr description) loads)
+			     loads)
+			 globals))
+		  ((GLOBAL-DEFINITIONS)
+		   (loop descriptions
+			 packages
+			 extensions
+			 loads
+			 (append! (reverse (cdr description)) globals)))
+		  ((NESTED-DESCRIPTIONS)
+		   (call-with-values
+		       (lambda ()
+			 (loop (cdr description)
+			       packages
+			       extensions
+			       loads
+			       globals))
+		     (lambda (packages extensions loads globals)
+		       (loop descriptions packages extensions loads globals))))
+		  (else
+		   (error "Unknown description keyword:" (car description)))))
+	      (values packages extensions loads globals)))))
+    (call-with-values (lambda () (loop descriptions '() '() '() '()))
+      (lambda (packages extensions loads globals)
+	(values (reverse! packages)
+		(reverse! extensions)
+		(reverse! loads)
+		(reverse! globals))))))
+
+(define (interesting-package-to-load? description)
+  (or (pair? (package-description/file-cases description))
+      (pair? (package-description/initializations description))
+      (pair? (package-description/finalizations description))))
 
 (define (read-file-analyses! pmodel)
   (call-with-values (lambda () (cache-file-analyses! pmodel))
@@ -305,29 +337,37 @@ USA.
 		((FILES)
 		 (set-package-description/file-cases!
 		  package
-		  (append (package-description/file-cases package)
-			  (list (parse-filenames (cdr option))))))
+		  (append! (package-description/file-cases package)
+			   (list (parse-filenames (cdr option))))))
 		((FILE-CASE)
 		 (set-package-description/file-cases!
 		  package
-		  (append (package-description/file-cases package)
-			  (list (parse-file-case (cdr option))))))
+		  (append! (package-description/file-cases package)
+			   (list (parse-file-case (cdr option))))))
 		((EXPORT)
 		 (set-package-description/exports!
 		  package
-		  (append (package-description/exports package)
-			  (list (parse-import/export (cdr option))))))
+		  (append! (package-description/exports package)
+			   (list (parse-import/export (cdr option))))))
 		((IMPORT)
 		 (set-package-description/imports!
 		  package
-		  (append (package-description/imports package)
-			  (list (parse-import/export (cdr option))))))
+		  (append! (package-description/imports package)
+			   (list (parse-import/export (cdr option))))))
 		((INITIALIZATION)
-		 (if (package-description/initialization package)
-		     (error "Multiple INITIALIZATION options:" option))
-		 (set-package-description/initialization!
-		  package
-		  (parse-initialization (cdr option))))
+		 (let ((initialization (parse-initialization (cdr option))))
+		   (if initialization
+		       (set-package-description/initializations!
+			package
+			(append! (package-description/initializations package)
+				 (list initialization))))))
+		((FINALIZATION)
+		 (let ((finalization (parse-initialization (cdr option))))
+		   (if finalization
+		       (set-package-description/finalizations!
+			package
+			(append! (package-description/finalizations package)
+				 (list finalization))))))
 		(else
 		 (error "Unrecognized option keyword:" (car option)))))
 	    options))
@@ -362,9 +402,11 @@ USA.
   (->pathname filename))
 
 (define (parse-initialization initialization)
-  (if (not (and (pair? initialization) (null? (cdr initialization))))
-      (error "illegal initialization" initialization))
-  (car initialization))
+  (if (and (pair? initialization) (null? (cdr initialization)))
+      (car initialization)
+      (begin
+	(warn "Illegal initialization/finalization:" initialization)
+	#f)))
 
 (define (parse-import/export object)
   (if (not (and (pair? object)
@@ -390,7 +432,7 @@ USA.
 
 ;;;; Packages
 
-(define (descriptions->pmodel descriptions extensions globals pathname)
+(define (descriptions->pmodel descriptions extensions loads globals pathname)
   (let ((packages
 	 (map (lambda (description)
 		(make-package (package-description/name description) 'UNKNOWN))
@@ -439,12 +481,18 @@ USA.
 	    extension
 	    get-package
 	    #f))
-	 extensions))
-      (make-pmodel root-package
-		   (make-package primitive-package-name #f)
-		   packages
-		   extra-packages
-		   pathname))))
+	 extensions)
+	(make-pmodel root-package
+		     (make-package primitive-package-name #f)
+		     packages
+		     extra-packages
+		     (map (lambda (package)
+			    (process-package-load
+			     (get-package (package-description/name package)
+					  #f)
+			     package))
+			  loads)
+		     pathname)))))
 
 (define (process-globals-info file namestring get-package)
   (for-each-vector-element (vector-ref file 2)
@@ -461,11 +509,11 @@ USA.
 		  (set-package/parent! package #f))))
 	(let ((expression (make-expression package namestring #f)))
 	  ;; Unlinked internal names.
-	  (for-each-vector-element (vector-ref desc 5)
+	  (for-each-vector-element (vector-ref desc 2)
 	    (lambda (name)
 	      (bind! package name expression #f)))
 	  ;; Exported bindings.
-	  (for-each-vector-element (vector-ref desc 6)
+	  (for-each-vector-element (vector-ref desc 3)
 	    (lambda (entry)
 	      (let ((name (vector-ref entry 0))
 		    (external-package (get-package (vector-ref entry 1) #t))
@@ -478,7 +526,7 @@ USA.
 		       external-package external-name
 		       package #f))))
 	  ;; Imported bindings.
-	  (for-each-vector-element (vector-ref desc 7)
+	  (for-each-vector-element (vector-ref desc 4)
 	    (lambda (entry)
 	      (let ((external-package (get-package (vector-ref entry 1) #t))
 		    (external-name 
@@ -503,20 +551,12 @@ USA.
 
 (define (process-package-description package description get-package new?)
   (let ((file-cases (package-description/file-cases description)))
-    (set-package/file-cases! package
-			     (append! (package/file-cases package)
-				      (list-copy file-cases)))
     (set-package/files!
      package
      (append! (package/files package)
 	      (append-map! (lambda (file-case)
 			     (append-map cdr (cdr file-case)))
 			   file-cases))))
-  (let ((initialization (package-description/initialization description)))
-    (if (and initialization
-	     (package/initialization package))
-	(error "Multiple package initializations:" initialization))
-    (set-package/initialization! package initialization))
   (for-each (lambda (export)
 	      (let ((destination (get-package (car export) #t)))
 		(for-each (lambda (names)
@@ -536,6 +576,12 @@ USA.
 
 (define primitive-package-name
   (list (string->symbol "#[(cross-reference reader)primitives]")))
+
+(define (process-package-load package description)
+  (make-package-load package
+		     (package-description/file-cases description)
+		     (package-description/initializations description)
+		     (package-description/finalizations description)))
 
 ;;;; Binding and Reference
 
diff --git a/v7/src/cref/triv.pkg b/v7/src/cref/triv.pkg
index 2ffc0e6ef..5001efd19 100644
--- a/v7/src/cref/triv.pkg
+++ b/v7/src/cref/triv.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: triv.pkg,v 1.6 2001/08/20 02:49:18 cph Exp $
+$Id: triv.pkg,v 1.7 2001/08/20 21:02:43 cph Exp $
 
 Copyright (c) 2001 Massachusetts Institute of Technology
 
@@ -22,55 +22,58 @@ USA.
 
 ;;;; CREF Packaging: hand-compiled package for bootstrapping
 
-(let ((v
-       (let ((package
-	      (lambda (package-name ancestors files
-				    exported-names imported-names)
-		(vector package-name
-			ancestors
-			(list (cons #f files))
-			#f
-			#f
-			'#()
-			(list->vector
-			 (map (lambda (name)
-				(vector name (car ancestors)))
-			      exported-names))
-			(list->vector
-			 (map (lambda (n.p)
-				(vector (car n.p) (cdr n.p)))
-			      imported-names))
-			#f))))
-	 (vector (package '(cross-reference)
-			  '(())
-			  '("mset" "object" "toplev")
-			  '(cref/generate-all
-			    cref/generate-constructors
-			    cref/generate-cref
-			    cref/generate-cref-unusual
-			    cref/generate-trivial-constructor)
-			  '())
-		 (package '(cross-reference analyze-file)
-			  '((cross-reference) ())
-			  '("anfile")
-			  '(analyze-file)
-			  '())
-		 (package '(cross-reference constructor)
-			  '((cross-reference) ())
-			  '("conpkg")
-			  '(construct-external-descriptions)
-			  '())
-		 (package '(cross-reference formatter)
-			  '((cross-reference) ())
-			  '("forpkg")
-			  '(format-packages
-			    format-packages-unusual)
-			  '())
-		 (package '(cross-reference reader)
-			  '((cross-reference) ())
-			  '("redpkg")
-			  '(read-file-analyses!
-			    read-package-model
-			    resolve-references!)
-			  '((package-file? . (package))))))))
-  (vector 'PACKAGE-DESCRIPTIONS 2 v v))
\ No newline at end of file
+(vector
+ 'PACKAGE-DESCRIPTIONS
+ 2
+ (let ((package
+	(lambda (package-name ancestors exported-names imported-names)
+	  (vector package-name
+		  ancestors
+		  '#()
+		  (list->vector
+		   (map (lambda (name)
+			  (vector name (car ancestors)))
+			exported-names))
+		  (list->vector
+		   (map (lambda (n.p)
+			  (vector (car n.p) (cdr n.p)))
+			imported-names))
+		  #f))))
+   (vector (package '(cross-reference)
+		    '(())
+		    '(cref/generate-all
+		      cref/generate-constructors
+		      cref/generate-cref
+		      cref/generate-cref-unusual
+		      cref/generate-trivial-constructor)
+		    '())
+	   (package '(cross-reference analyze-file)
+		    '((cross-reference) ())
+		    '(analyze-file)
+		    '())
+	   (package '(cross-reference constructor)
+		    '((cross-reference) ())
+		    '(construct-external-descriptions)
+		    '())
+	   (package '(cross-reference formatter)
+		    '((cross-reference) ())
+		    '(format-packages
+		      format-packages-unusual)
+		    '())
+	   (package '(cross-reference reader)
+		    '((cross-reference) ())
+		    '(read-file-analyses!
+		      read-package-model
+		      resolve-references!)
+		    '((package-file? . (package))))))
+ (let ((files
+	(lambda (package-name . files)
+	  (vector package-name
+		  (vector (list->vector files))
+		  '#()
+		  '#()))))
+   (vector (files '(cross-reference) "mset" "object" "toplev")
+	   (files '(cross-reference analyze-file) "anfile")
+	   (files '(cross-reference constructor) "conpkg")
+	   (files '(cross-reference formatter) "forpkg")
+	   (files '(cross-reference reader) "redpkg"))))
\ No newline at end of file
diff --git a/v7/src/runtime/packag.scm b/v7/src/runtime/packag.scm
index 25631fca6..321986f80 100644
--- a/v7/src/runtime/packag.scm
+++ b/v7/src/runtime/packag.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: packag.scm,v 14.33 2001/08/20 02:48:31 cph Exp $
+$Id: packag.scm,v 14.34 2001/08/20 21:02:13 cph Exp $
 
 Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
 
@@ -238,55 +238,41 @@ USA.
 				(conc-name package-file/))
   (tag #f read-only #t)
   (version #f read-only #t)
-  (sorted-descriptions #f read-only #t)
-  (descriptions #f read-only #t))
+  (descriptions #f read-only #t)
+  (loads #f read-only #t))
 
 (define-structure (package-description (type vector)
 				       (conc-name package-description/))
   (name #f read-only #t)
   (ancestors #f read-only #t)
-  (file-cases #f read-only #t)
-  (initialization #f read-only #t)
-  (finalization #f read-only #t)
   (internal-names #f read-only #t)
   (exports #f read-only #t)
   (imports #f read-only #t)
   (extension? #f read-only #t))
 
+(define-structure (load-description (type vector)
+				    (conc-name load-description/))
+  (name #f read-only #t)
+  (file-cases #f read-only #t)
+  (initializations #f read-only #t)
+  (finalizations #f read-only #t))
+
 (define (package-file? object)
   (and (vector? object)
        (fix:= (vector-length object) 4)
        (eq? (package-file/tag object) 'PACKAGE-DESCRIPTIONS)
        (and (index-fixnum? (package-file/version object))
 	    (fix:= (package-file/version object) 2))
-       (let ((descriptions (package-file/sorted-descriptions object)))
-	 (and (vector? descriptions)
-	      (let ((n (vector-length descriptions)))
-		(let loop ((i 0))
-		  (or (fix:= i n)
-		      (and (package-description? (vector-ref descriptions i))
-			   (loop (fix:+ i 1))))))))
-       ;; This is the same as sorted-descriptions, in a different order.
-       ;; Don't bother to check it.
-       (vector? (package-file/descriptions object))))
+       (vector-of-type? (package-file/descriptions object)
+			package-description?)
+       (vector-of-type? (package-file/loads object)
+			load-description?)))
 
 (define (package-description? object)
   (and (vector? object)
-       (fix:= (vector-length object) 9)
+       (fix:= (vector-length object) 6)
        (package-name? (package-description/name object))
        (list-of-type? (package-description/ancestors object) package-name?)
-       (list-of-type? (package-description/file-cases object)
-	 (lambda (case)
-	   (and (pair? case)
-		(or (and (not (car case))
-			 (list-of-type? (cdr case) string?))
-		    (and (symbol? (car case))
-			 (list-of-type? (cdr case)
-			   (lambda (clause)
-			     (and (pair? clause)
-				  (or (list-of-type? (car clause) symbol?)
-				      (eq? (car clause) 'ELSE))
-				  (list-of-type? (cdr clause) string?)))))))))
        (vector-of-type? (package-description/internal-names object) symbol?)
        (vector-of-type? (package-description/exports object) link-description?)
        (vector-of-type? (package-description/imports object) link-description?)
@@ -302,12 +288,30 @@ USA.
 		   (package-name? (vector-ref object 1))
 		   (symbol? (vector-ref object 2))))
 	     (else #f))))
+
+(define (load-description? object)
+  (and (vector? object)
+       (fix:= (vector-length object) 4)
+       (package-name? (load-description/name object))
+       (vector-of-type? (load-description/file-cases object)
+	 (lambda (file-case)
+	   (if (pair? file-case)
+	       (and (symbol? (car file-case))
+		    (vector-of-type? (cdr file-case)
+		      (lambda (clause)
+			(and (pair? clause)
+			     (or (eq? (car clause) 'ELSE)
+				 (vector-of-type? (car clause) symbol?))
+			     (vector-of-type? (cdr clause) string?)))))
+	       (vector-of-type? file-case string?))))
+       (vector? (load-description/initializations object))
+       (vector? (load-description/finalizations object))))
 
 ;; CONSTRUCT-PACKAGES-FROM-FILE is called from the cold load and must
 ;; only use procedures that are inline-coded by the compiler.
 
 (define (construct-packages-from-file file)
-  (let ((descriptions (package-file/sorted-descriptions file))
+  (let ((descriptions (package-file/descriptions file))
 	(skip-package?
 	 (lambda (name)
 	   (or (null? name)
@@ -426,13 +430,13 @@ USA.
 ;; use procedures that are inline-coded by the compiler.
 
 (define (load-packages-from-file file options file-loader)
-  (let ((descriptions (package-file/descriptions file)))
-    (let ((n (vector-length descriptions)))
+  (let ((loads (package-file/loads file)))
+    (let ((n (vector-length loads)))
       (do ((i 0 (fix:+ i 1)))
 	  ((fix:= i n))
-	(let ((description (vector-ref descriptions i)))
+	(let ((description (vector-ref loads i)))
 	  (load-package-from-description
-	   (find-package (package-description/name description))
+	   (find-package (load-description/name description))
 	   description
 	   options
 	   file-loader))))))
@@ -441,26 +445,34 @@ USA.
   (let ((environment (package/environment package)))
     (let ((load-files
 	   (lambda (filenames)
-	     (do ((filenames filenames (cdr filenames)))
-		 ((not (pair? filenames)))
-	       (file-loader (car filenames) environment)))))
-      (do ((cases (package-description/file-cases description) (cdr cases)))
-	  ((not (pair? cases)))
-	(let ((case (car cases)))
-	  (let ((key (car case)))
-	    (if key
-		(let ((option (lookup-option key options)))
+	     (let ((n (vector-length filenames)))
+	       (do ((i 0 (fix:+ i 1)))
+		   ((fix:= i n))
+		 (file-loader (vector-ref filenames i) environment)))))
+	  (cases (load-description/file-cases description)))
+      (let ((n (vector-length cases)))
+	(do ((i 0 (fix:+ i 1)))
+	    ((fix:= i n))
+	  (let ((file-case (vector-ref cases i)))
+	    (if (pair? file-case)
+		(let ((option (lookup-option (car file-case) options)))
 		  (if (not option)
 		      (error "Missing key:" key))
-		  (do ((clauses (cdr case) (cdr clauses)))
-		      ((not (pair? clauses)))
-		    (let ((clause (car clauses)))
-		      (if (let loop ((options (car clause)))
-			    (and (pair? options)
-				 (or (eq? (car options) option)
-				     (loop (cdr options)))))
-			  (load-files (cdr clause))))))
-		(load-files (cdr case)))))))))
+		  (let ((clauses (cdr file-case)))
+		    (let ((n (vector-length clauses)))
+		      (do ((i 0 (fix:+ i 1)))
+			  ((fix:= i n))
+			(let ((clause (vector-ref clauses i)))
+			  (if (let ((keys (car clause)))
+				(or (eq? keys 'ELSE)
+				    (let ((n (vector-length keys)))
+				      (let loop ((i 0))
+					(and (fix:< i n)
+					     (or (eq? (vector-ref keys i)
+						      option)
+						 (loop (fix:+ i 1))))))))
+			      (load-files (cdr clause))))))))
+		(load-files file-case))))))))
 
 (define (lookup-option key options)
   (let loop ((options options))
@@ -470,23 +482,26 @@ USA.
 	     (loop (cdr options))))))
 
 (define (initialize-packages-from-file file)
-  (initialize/finalize file package-description/initialization "Initializing"))
+  (initialize/finalize file load-description/initializations "Initializing"))
 
 (define (finalize-packages-from-file file)
-  (initialize/finalize file package-description/finalization "Finalizing"))
+  (initialize/finalize file load-description/finalizations "Finalizing"))
 
 (define (initialize/finalize file selector verb)
-  (for-each-vector-element (package-file/descriptions file)
+  (for-each-vector-element (package-file/loads file)
     (lambda (description)
-      (let ((expression (selector description)))
-	(if expression
-	    (let ((name (package-description/name description))
+      (let ((expressions (selector description)))
+	(if (fix:> (vector-length expressions) 0)
+	    (let ((name (load-description/name description))
 		  (port (notification-output-port)))
 	      (fresh-line port)
 	      (write-string ";" port)
 	      (write-string verb port)
 	      (write-string " package " port)
 	      (write name port)
-	      (eval expression (find-package-environment name))
+	      (for-each-vector-element expressions
+		(let ((environment (find-package-environment name)))
+		  (lambda (expression)
+		    (eval expression environment))))
 	      (write-string " -- done" port)
 	      (newline port)))))))
\ No newline at end of file
-- 
2.25.1