From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 18 Aug 2001 04:52:33 +0000 (+0000)
Subject: Add additional information to .pkd file to support automatic evaluation
X-Git-Tag: 20090517-FFI~2586
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=901a9b1eed1485884a9de19b478c774c122a522a;p=mit-scheme.git

Add additional information to .pkd file to support automatic evaluation
of package-initialization expressions.  Major problems cropped up with
package extensions, which necessitated some redesign of CREF.
---

diff --git a/v7/src/6001/6001.pkg b/v7/src/6001/6001.pkg
index b3daec355..2df99bc23 100644
--- a/v7/src/6001/6001.pkg
+++ b/v7/src/6001/6001.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: 6001.pkg,v 1.11 1999/01/02 06:06:43 cph Exp $
+$Id: 6001.pkg,v 1.12 2001/08/18 04:50:08 cph Exp $
 
 Copyright (c) 1991-1999 Massachusetts Institute of Technology
 
@@ -22,6 +22,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 ;;;; 6.001 packaging
 
 (global-definitions "../runtime/runtime")
+(global-definitions "../edwin/edwinunx")
 
 (define-package (student)
   (parent ()))
@@ -133,4 +134,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  ;picture-scale
 	  ;picture-set!
 	  ;picture-v-reflect
-	  ))
\ No newline at end of file
+	  ))
+
+(extend-package (edwin)
+  (files "edextra"))
\ No newline at end of file
diff --git a/v7/src/6001/make.scm b/v7/src/6001/make.scm
index ed98da4f1..d40751463 100644
--- a/v7/src/6001/make.scm
+++ b/v7/src/6001/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 15.31 2001/08/17 13:00:29 cph Exp $
+$Id: make.scm,v 15.32 2001/08/18 04:50:22 cph Exp $
 
 Copyright (c) 1991-1999, 2001 Massachusetts Institute of Technology
 
@@ -32,12 +32,9 @@ USA.
      (pathname-as-directory "6001")
      (lambda ()
        (load-package-set "6001")
-       (let ((edwin (->environment '(edwin))))
-	 (load "edextra" edwin)
-	 (if (and (eq? 'UNIX microcode-id/operating-system)
-		  (string-ci=? "HP-UX" microcode-id/operating-system-variant))
-	     (load "floppy" edwin)))))))
-((access initialize-package! (->environment '(student scode-rewriting))))
+       (if (and (eq? 'UNIX microcode-id/operating-system)
+		(string-ci=? "HP-UX" microcode-id/operating-system-variant))
+	   (load "floppy" (->environment '(edwin))))))))
 (add-identification! "6.001" 15 30)
 
 ;;; Customize the runtime system:
diff --git a/v7/src/compiler/base/make.scm b/v7/src/compiler/base/make.scm
index 949948914..f56a70969 100644
--- a/v7/src/compiler/base/make.scm
+++ b/v7/src/compiler/base/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 4.112 2001/08/17 13:00:45 cph Exp $
+$Id: make.scm,v 4.113 2001/08/18 04:52:33 cph Exp $
 
 Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
 
@@ -34,10 +34,4 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
      (load-option 'HASH-TABLE)
      (load-option 'RB-TREE)
      (load-package-set "compiler")))
-  (let ((initialize-package!
-	 (lambda (package-name)
-	   ((environment-lookup (->environment package-name)
-				'INITIALIZE-PACKAGE!)))))
-    (initialize-package! '(COMPILER MACROS))
-    (initialize-package! '(COMPILER DECLARATIONS)))
   (add-identification! (string-append "Liar (" architecture-name ")") 4 111))
\ No newline at end of file
diff --git a/v7/src/cref/conpkg.scm b/v7/src/cref/conpkg.scm
index efa43cded..6d80c4503 100644
--- a/v7/src/cref/conpkg.scm
+++ b/v7/src/cref/conpkg.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: conpkg.scm,v 1.10 2001/08/16 20:02:58 cph Exp $
+$Id: conpkg.scm,v 1.11 2001/08/18 04:48:34 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -28,22 +28,31 @@ USA.
 (define (construct-external-descriptions pmodel)
   (let* ((packages (pmodel/packages pmodel))
 	 (alist
-	  (map (lambda (package)
-		 (cons package (construct-external-description package)))
-	       packages)))
+	  (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 (lambda (package)
-		    (cdr (assq package alist)))
-		  (sort packages package-structure<?)))
+	     (map cdr
+		  (sort alist
+		    (lambda (a b)
+		      (package-structure<? (car a) (car b))))))
 	    (list->vector (map cdr alist)))))
 
-(define (construct-external-description package)
+(define (construct-external-description package extension?)
   (call-with-values
       (lambda ()
 	(split-bindings-list (package/sorted-bindings package)))
-    (lambda (internal external)
+    (lambda (internal exports imports)
       (vector (package/name package)
 	      (let loop ((package package))
 		(let ((parent (package/parent package)))
@@ -66,46 +75,59 @@ USA.
 		   (package/file-cases package))
 	      (package/initialization package)
 	      (package/finalization package)
+	      (list->vector internal)
 	      (list->vector
-	       (map binding/name
-		    (list-transform-negative internal
-		      (lambda (binding)
-			(pair? (binding/links binding))))))
-	      (list->vector
-	       (map (lambda (binding)
+	       (map (lambda (n.l)
 		      (list->vector
-		       (cons (binding/name binding)
+		       (cons (car n.l)
 			     (map (lambda (link)
 				    (let ((dest (link/destination link)))
 				      (cons (package/name
 					     (binding/package dest))
 					    (binding/name dest))))
-				  (binding/links binding)))))
-		    (list-transform-positive internal
-		      (lambda (binding)
-			(pair? (binding/links binding))))))
+				  (cdr n.l)))))
+		    exports))
 	      (list->vector
-	       (map (lambda (binding)
-		      (let ((source (binding/source-binding binding)))
-			(if (eq? (binding/name binding) (binding/name source))
-			    (vector (binding/name binding)
+	       (map (lambda (n.s)
+		      (let ((name (car n.s))
+			    (source (cdr n.s)))
+			(if (eq? name (binding/name source))
+			    (vector name
 				    (package/name (binding/package source)))
-			    (vector (binding/name binding)
+			    (vector name
 				    (package/name (binding/package source))
 				    (binding/name source)))))
-		    external))))))
-
+		    imports))
+	      extension?))))
+
 (define (split-bindings-list bindings)
-  (let loop ((bindings bindings) (internal '()) (external '()))
+  (let loop ((bindings bindings) (internal '()) (exports '()) (imports '()))
     (if (pair? bindings)
-	(if (binding/internal? (car bindings))
-	    (loop (cdr bindings)
-		  (cons (car bindings) internal)
-		  external)
-	    (loop (cdr bindings)
-		  internal
-		  (cons (car bindings) external)))
-	(values (reverse! internal) (reverse! external)))))
+	(let ((binding (car bindings))
+	      (bindings (cdr bindings)))
+	  (let ((name (binding/name binding))
+		(source (binding/source-binding binding))
+		(links
+		 (list-transform-positive (binding/links binding) link/new?)))
+	    (if (and source
+		     (or (binding/new? binding)
+			 (pair? links)))
+		(if (eq? binding source)
+		    (if (pair? links)
+			(loop bindings
+			      internal
+			      (cons (cons name links) exports)
+			      imports)
+			(loop bindings
+			      (cons name internal)
+			      exports
+			      imports))
+		    (loop bindings
+			  internal
+			  exports
+			  (cons (cons name source) imports)))
+		(loop bindings internal exports imports))))
+	(values (reverse! internal) (reverse! exports) (reverse! imports)))))
 
 (define (package-structure<? x y)
   (cond ((package/topological<? x y) true)
diff --git a/v7/src/cref/make.scm b/v7/src/cref/make.scm
index 1646ac323..4be6c4f3d 100644
--- a/v7/src/cref/make.scm
+++ b/v7/src/cref/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 1.22 2001/08/17 13:00:53 cph Exp $
+$Id: make.scm,v 1.23 2001/08/18 04:48:16 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -34,4 +34,4 @@ USA.
      (lambda ()
        (load-option 'RB-TREE)
        (load-package-set "cref")))))
-(add-identification! "CREF" 2 0)
\ No newline at end of file
+(add-identification! "CREF" 2 1)
\ No newline at end of file
diff --git a/v7/src/cref/object.scm b/v7/src/cref/object.scm
index bd7b3141d..df82d6783 100644
--- a/v7/src/cref/object.scm
+++ b/v7/src/cref/object.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: object.scm,v 1.11 2001/08/15 02:59:54 cph Exp $
+$Id: object.scm,v 1.12 2001/08/18 04:48:44 cph Exp $
 
 Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
 
@@ -44,11 +44,11 @@ USA.
      (type vector)
      (named (string->symbol "#[(cross-reference)pmodel]"))
      (conc-name pmodel/))
-  (root-package false read-only true)
-  (primitive-package false read-only true)
-  (packages false read-only true)
-  (extra-packages false read-only true)
-  (pathname false read-only true))
+  (root-package #f read-only #t)
+  (primitive-package #f read-only #t)
+  (packages #f read-only #t)
+  (extra-packages #f read-only #t)
+  (pathname #f read-only #t))
 
 (define-structure
     (package
@@ -103,7 +103,7 @@ USA.
     (binding
      (type vector)
      (named (string->symbol "#[(cross-reference)binding]"))
-     (constructor %make-binding (package name value-cell))
+     (constructor %make-binding (package name value-cell new?))
      (conc-name binding/)
      (print-procedure
       (standard-unparser-method 'BINDING
@@ -112,14 +112,15 @@ USA.
 	  (write (binding/name binding) port)
 	  (write-char #\space port)
 	  (write (package/name (binding/package binding)) port)))))
-  (package false read-only true)
-  (name false read-only true)
-  (value-cell false read-only true)
+  (package #f read-only #t)
+  (name #f read-only #t)
+  (value-cell #f read-only #t)
+  (new? #f)
   (references '())
   (links '()))
 
-(define (make-binding package name value-cell)
-  (let ((binding (%make-binding package name value-cell)))
+(define (make-binding package name value-cell new?)
+  (let ((binding (%make-binding package name value-cell new?)))
     (set-value-cell/bindings!
      value-cell
      (cons binding (value-cell/bindings value-cell)))
@@ -142,34 +143,35 @@ USA.
      (conc-name value-cell/))
   (bindings '())
   (expressions '())
-  (source-binding false))
+  (source-binding #f))
 
 (define-structure
     (link
      (type vector)
      (named (string->symbol "#[(cross-reference)link]"))
-     (constructor %make-link)
+     (constructor %make-link (source destination new?))
      (conc-name link/))
-  (source false read-only true)
-  (destination false read-only true))
+  (source #f read-only #t)
+  (destination #f read-only #t)
+  (new? #f read-only #t))
 
-(define (make-link source-binding destination-binding)
-  (let ((link (%make-link source-binding destination-binding)))
+(define (make-link source-binding destination-binding new?)
+  (let ((link (%make-link source-binding destination-binding new?)))
     (set-binding/links! source-binding
 			(cons link (binding/links source-binding)))
     link))
-
+
 (define-structure
     (expression
      (type vector)
      (named (string->symbol "#[(cross-reference)expression]"))
      (constructor make-expression (package file type))
      (conc-name expression/))
-  (package false read-only true)
-  (file false read-only true)
-  (type false read-only true)
+  (package #f read-only #t)
+  (file #f read-only #t)
+  (type #f read-only #t)
   (references '())
-  (value-cell false))
+  (value-cell #f))
 
 (define-structure
     (reference
@@ -184,23 +186,22 @@ USA.
 	  (write (reference/name reference) port)
 	  (write-char #\space port)
 	  (write (package/name (reference/package reference)) port)))))
-  (package false read-only true)
-  (name false read-only true)
+  (package #f read-only #t)
+  (name #f read-only #t)
   (expressions '())
-  (binding false))
-
+  (binding #f))
+
 (define (symbol-list=? x y)
-  (if (null? x)
-      (null? y)
-      (and (not (null? y))
+  (if (pair? x)
+      (and (pair? y)
 	   (eq? (car x) (car y))
-	   (symbol-list=? (cdr x) (cdr y)))))
+	   (symbol-list=? (cdr x) (cdr y)))
+      (not (pair? y))))
 
 (define (symbol-list<? x y)
-  (and (not (null? y))
-       (if (or (null? x)
-	       (symbol<? (car x) (car y)))
-	   true
+  (and (pair? y)
+       (or (not (pair? x))
+	   (symbol<? (car x) (car y))
 	   (and (eq? (car x) (car y))
 		(symbol-list<? (cdr x) (cdr y))))))
 
diff --git a/v7/src/cref/redpkg.scm b/v7/src/cref/redpkg.scm
index 29c9924fe..fdf55707a 100644
--- a/v7/src/cref/redpkg.scm
+++ b/v7/src/cref/redpkg.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: redpkg.scm,v 1.15 2001/08/16 20:50:26 cph Exp $
+$Id: redpkg.scm,v 1.16 2001/08/18 04:48:59 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -103,15 +103,20 @@ USA.
 	(changes? (list #f)))
     (let ((result
 	   (let ((caches (if (file-exists? pathname) (fasload pathname) '())))
-	     (append-map! (lambda (package)
-			    (map (lambda (pathname)
-				   (cons package
-					 (cache-file-analysis! pmodel
-							       caches
-							       pathname
-							       changes?)))
-				 (package/files package)))
-			  (pmodel/packages pmodel)))))
+	     (let ((cache-packages
+		    (lambda (packages)
+		      (append-map!
+		       (lambda (package)
+			 (map (lambda (pathname)
+				(cons package
+				      (cache-file-analysis! pmodel
+							    caches
+							    pathname
+							    changes?)))
+			      (package/files package)))
+		       packages))))
+	       (append! (cache-packages (pmodel/packages pmodel))
+			(cache-packages (pmodel/extra-packages pmodel)))))))
       (if (car changes?)
 	  (fasdump (map cdr result) pathname))
       (values result (car changes?)))))
@@ -172,7 +177,7 @@ USA.
 		   (else
 		    (error "Illegal reference name" name)))))
 	 (if name
-	     (bind! package name expression)))))
+	     (bind! package name expression #t)))))
    entries))
 
 (define (resolve-references! pmodel)
@@ -424,7 +429,7 @@ USA.
 		 (set-package/children!
 		  parent
 		  (cons package (package/children parent)))))
-	   (process-package-description package description get-package))
+	   (process-package-description package description get-package #t))
 	 packages
 	 descriptions)
 	(for-each
@@ -432,7 +437,8 @@ USA.
 	   (process-package-description
 	    (get-package (package-description/name extension) #f)
 	    extension
-	    get-package))
+	    get-package
+	    #f))
 	 extensions))
       (make-pmodel root-package
 		   (make-package primitive-package-name #f)
@@ -457,24 +463,38 @@ USA.
 	  ;; Unlinked internal names: just bind them.
 	  (for-each-vector-element (vector-ref desc 5)
 	    (lambda (name)
-	      (bind! package name expression)))
-	  ;; Exported bindings: bind the internal and external names.
-	  ;; Perhaps should link them here.
+	      (bind! package name expression #f)))
+	  ;; Exported bindings: bind the name and link it to the
+	  ;; external names.
 	  (for-each-vector-element (vector-ref desc 6)
 	    (lambda (entry)
-	      (bind! package (vector-ref entry 0) expression)
-	      (let ((n (vector-length entry)))
-		(do ((i 1 (fix:+ i 1)))
-		    ((fix:= i n))
-		  (let ((p.n (vector-ref entry i)))
-		    (bind! (get-package (car p.n) #t)
-			   (cdr p.n)
-			   expression))))))
-	  ;; Imported bindings: bind just the internal name.
+	      (let ((name (vector-ref entry 0)))
+		(bind! package name expression #f)
+		(let ((n (vector-length entry)))
+		  (do ((i 1 (fix:+ i 1)))
+		      ((fix:= i n))
+		    (let ((p.n (vector-ref entry i)))
+		      (link! package
+			     name
+			     (get-package (car p.n) #t)
+			     (cdr p.n)
+			     #f)))))))
+	  ;; Imported bindings: bind just the external name and link
+	  ;; it to the internal name.
 	  (for-each-vector-element (vector-ref desc 7)
 	    (lambda (entry)
-	      (bind! package (vector-ref entry 0) expression))))))))
-
+	      (let ((external-package (get-package (vector-ref entry 1) #t))
+		    (external-name 
+		     (if (fix:= (vector-length entry) 2)
+			 (vector-ref entry 0)
+			 (vector-ref entry 2))))
+		(bind! external-package external-name expression #f)
+		(link! external-package
+		       external-name
+		       package
+		       (vector-ref entry 0)
+		       #f)))))))))
+
 (define (package-lookup package name)
   (let package-loop ((package package))
     (or (package/find-binding package name)
@@ -486,7 +506,7 @@ USA.
     (lambda (package)
       (symbol-list=? name (package/name package)))))
 
-(define (process-package-description package description get-package)
+(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)
@@ -506,14 +526,16 @@ USA.
 	      (let ((destination (get-package (car export) #t)))
 		(for-each (lambda (names)
 			    (link! package (car names)
-				   destination (cdr names)))
+				   destination (cdr names)
+				   new?))
 			  (cdr export))))
 	    (package-description/exports description))
   (for-each (lambda (import)
 	      (let ((source (get-package (car import) #t)))
 		(for-each (lambda (names)
 			    (link! source (cdr names)
-				   package (car names)))
+				   package (car names)
+				   new?))
 			  (cdr import))))
 	    (package-description/imports description)))
 
@@ -522,35 +544,46 @@ USA.
 
 ;;;; Binding and Reference
 
-(define (bind! package name expression)
-  (let ((value-cell (binding/value-cell (intern-binding! package name))))
+(define (bind! package name expression new?)
+  (let ((value-cell (binding/value-cell (intern-binding! package name new?))))
     (set-expression/value-cell! expression value-cell)
     (set-value-cell/expressions!
      value-cell
      (cons expression (value-cell/expressions value-cell)))))
 
-(define (link! source-package source-name destination-package destination-name)
-  (if (package/find-binding destination-package destination-name)
-      (error "Attempt to reinsert binding" destination-name))
-  (let ((source-binding (intern-binding! source-package source-name)))
+(define (link! source-package source-name
+	       destination-package destination-name
+	       new?)
+  (let ((source-binding (intern-binding! source-package source-name new?))
+	(destination-binding
+	 (package/find-binding destination-package destination-name)))
+    (if (and destination-binding
+	     (not (eq? (binding/value-cell destination-binding)
+		       (binding/value-cell source-binding))))
+	(error "Attempt to reinsert binding:" destination-name))
     (let ((destination-binding
 	   (make-binding destination-package
 			 destination-name
-			 (binding/value-cell source-binding))))
+			 (binding/value-cell source-binding)
+			 new?)))
       (rb-tree/insert! (package/bindings destination-package)
 		       destination-name
 		       destination-binding)
-      (make-link source-binding destination-binding))))
-
-(define (intern-binding! package name)
-  (or (package/find-binding package name)
-      (let ((binding
-	     (let ((value-cell (make-value-cell)))
-	       (let ((binding (make-binding package name value-cell)))
-		 (set-value-cell/source-binding! value-cell binding)
-		 binding))))
-	(rb-tree/insert! (package/bindings package) name binding)
-	binding)))
+      (make-link source-binding destination-binding new?))))
+
+(define (intern-binding! package name new?)
+  (let ((binding (package/find-binding package name)))
+    (if binding
+	(begin
+	  (if new? (set-binding/new?! binding #t))
+	  binding)
+	(let ((binding
+	       (let ((value-cell (make-value-cell)))
+		 (let ((binding (make-binding package name value-cell new?)))
+		   (set-value-cell/source-binding! value-cell binding)
+		   binding))))
+	  (rb-tree/insert! (package/bindings package) name binding)
+	  binding))))
 
 (define (make-reference package name expression)
   (let ((references (package/references package))
diff --git a/v7/src/cref/triv.pkg b/v7/src/cref/triv.pkg
index 4b756d6b3..2c7fdaa32 100644
--- a/v7/src/cref/triv.pkg
+++ b/v7/src/cref/triv.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: triv.pkg,v 1.4 2001/08/16 20:59:56 cph Exp $
+$Id: triv.pkg,v 1.5 2001/08/18 04:49:06 cph Exp $
 
 Copyright (c) 2001 Massachusetts Institute of Technology
 
@@ -24,7 +24,8 @@ USA.
 
 (let ((v
        (let ((package
-	      (lambda (package-name ancestors files exported-names)
+	      (lambda (package-name ancestors files
+				    exported-names imported-names)
 		(vector package-name
 			ancestors
 			(list (cons #f files))
@@ -35,7 +36,11 @@ USA.
 			 (map (lambda (name)
 				(vector name (cons (car ancestors) name)))
 			      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")
@@ -43,26 +48,29 @@ USA.
 			    cref/generate-constructors
 			    cref/generate-cref
 			    cref/generate-cref-unusual
-			    cref/generate-trivial-constructor))
+			    cref/generate-trivial-constructor)
+			  '())
 		 (package '(cross-reference analyze-file)
 			  '((cross-reference) ())
 			  '("anfile")
-			  '(analyze-file))
+			  '(analyze-file)
+			  '())
 		 (package '(cross-reference constructor)
 			  '((cross-reference) ())
 			  '("conpkg")
-			  '(construct-external-descriptions))
-
+			  '(construct-external-descriptions)
+			  '())
 		 (package '(cross-reference formatter)
 			  '((cross-reference) ())
 			  '("forpkg")
 			  '(format-packages
-			    format-packages-unusual))
-
+			    format-packages-unusual)
+			  '())
 		 (package '(cross-reference reader)
 			  '((cross-reference) ())
 			  '("redpkg")
 			  '(read-file-analyses!
 			    read-package-model
-			    resolve-references!))))))
+			    resolve-references!)
+			  '((package-file? . (package))))))))
   (vector 'PACKAGE-DESCRIPTIONS 2 v v))
\ No newline at end of file
diff --git a/v7/src/runtime/packag.scm b/v7/src/runtime/packag.scm
index c67fcf14e..3860f2780 100644
--- a/v7/src/runtime/packag.scm
+++ b/v7/src/runtime/packag.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: packag.scm,v 14.31 2001/08/17 12:50:15 cph Exp $
+$Id: packag.scm,v 14.32 2001/08/18 04:47:26 cph Exp $
 
 Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
 
@@ -199,7 +199,9 @@ USA.
 			     (load component environment syntax-table #t)))))))
 	      (if alternate-loader
 		  (alternate-loader load-component options)
-		  (load-packages-from-file file options load-component))))))))
+		  (begin
+		    (load-packages-from-file file options load-component)
+		    (initialize-packages-from-file file)))))))))
   ;; Make sure that everything we just loaded is purified.  If the
   ;; program runs before it gets purified, some of its run-time state
   ;; can end up being purified also.
@@ -248,7 +250,8 @@ USA.
   (finalization #f read-only #t)
   (internal-names #f read-only #t)
   (internal-bindings #f read-only #t)
-  (external-bindings #f read-only #t))
+  (external-bindings #f read-only #t)
+  (extension? #f read-only #t))
 
 (define (package-file? object)
   (and (vector? object)
@@ -269,7 +272,7 @@ USA.
 
 (define (package-description? object)
   (and (vector? object)
-       (fix:= (vector-length object) 8)
+       (fix:= (vector-length object) 9)
        (package-name? (package-description/name object))
        (list-of-type? (package-description/ancestors object) package-name?)
        (list-of-type? (package-description/file-cases object)
@@ -306,8 +309,12 @@ USA.
 		(symbol? (vector-ref binding 0))
 		(package-name? (vector-ref binding 1))
 		(or (fix:= (vector-length binding) 2)
-		    (symbol? (vector-ref binding 2))))))))
+		    (symbol? (vector-ref binding 2))))))
+       (boolean? (package-description/extension? 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))
 	(skip-package?
@@ -332,6 +339,7 @@ USA.
 
 (define (construct-normal-package-from-description description)
   (let ((name (package-description/name description))
+	(extension? (package-description/extension? description))
 	(environment
 	 (extend-package-environment
 	  (let ((ancestors (package-description/ancestors description)))
@@ -350,7 +358,8 @@ USA.
 		(or (package/child package (car path))
 		    (error "Unable to find package:"
 			   (list-difference name (cdr path)))))
-	  (package/add-child! package (car path) environment)))))
+	  (if (not (and extension? (package/child package (car path))))
+	      (package/add-child! package (car path) environment))))))
 
 (define (create-links-from-description description)
   (let ((environment
@@ -425,6 +434,9 @@ USA.
 (define-primitives
   link-variables)
 
+;; LOAD-PACKAGES-FROM-FILE is called from the cold load and must only
+;; 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)))
@@ -467,4 +479,26 @@ USA.
     (and (pair? options)
 	 (if (eq? (car (car options)) key)
 	     (cdr (car options))
-	     (loop (cdr options))))))
\ No newline at end of file
+	     (loop (cdr options))))))
+
+(define (initialize-packages-from-file file)
+  (initialize/finalize file package-description/initialization "Initializing"))
+
+(define (finalize-packages-from-file file)
+  (initialize/finalize file package-description/finalization "Finalizing"))
+
+(define (initialize/finalize file selector verb)
+  (for-each-vector-element (package-file/descriptions file)
+    (lambda (description)
+      (let ((expression (selector description)))
+	(if expression
+	    (let ((name (package-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))
+	      (write-string " -- done" port)
+	      (newline port)))))))
\ No newline at end of file
diff --git a/v7/src/win32/make.scm b/v7/src/win32/make.scm
index 9241059fa..8be59c913 100644
--- a/v7/src/win32/make.scm
+++ b/v7/src/win32/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 1.7 2001/08/17 13:01:32 cph Exp $
+$Id: make.scm,v 1.8 2001/08/18 04:52:08 cph Exp $
 
 Copyright (c) 1993-1999, 2001 Massachusetts Institute of Technology
 
@@ -23,7 +23,7 @@ USA.
 ;;;; Win32 subsystem: System Construction
 
 (declare (usual-integrations))
-
+
 (with-working-directory-pathname (directory-pathname (current-load-pathname))
   (lambda ()
     ((access with-directory-rewriting-rule
@@ -33,51 +33,4 @@ USA.
      (lambda ()
        (load "ffimacro")
        (load-package-set "win32")))))
-
-;((package/reference (find-package '(WIN32))
-;		    'INITIALIZE-PACKAGE!))
-(add-identification! "Win32" 1 5)
-
-
-(define (package-initialize package-name procedure-name mandatory?)
-  (define (print-name string)
-    (display "\n")
-    (display string)
-    (display " (")
-    (let loop ((name package-name))
-      (if (not (null? name))
-	  (begin
-	    (if (not (eq? name package-name))
-		(display " "))
-	    (display (system-pair-car (car name)))
-	    (loop (cdr name)))))
-    (display ")"))
-
-  (define (package-reference name)
-    (package/environment (find-package name)))
-
-  (let ((env (package-reference package-name)))
-    (cond ((not (lexical-unreferenceable? env procedure-name))
-	   (print-name "initialize:")
-	   (if (not (eq? procedure-name 'INITIALIZE-PACKAGE!))
-	       (begin
-		 (display " [")
-		 (display (system-pair-car procedure-name))
-		 (display "]")))
-	   ((lexical-reference env procedure-name)))
-	  ((not mandatory?)
-	   (print-name "* skipping:"))
-	  (else
-	   ;; Missing mandatory package! Report it and die.
-	   (print-name "Package")
-	   (display " is missing initialization procedure ")
-	   (display (system-pair-car procedure-name))
-	   (fatal-error "Could not initialize a required package.")))))
-
-
-(package-initialize '(win32) 'initialize-protection-list-package! #t)
-(package-initialize '(win32) 'initialize-module-package! #t)
-(package-initialize '(win32) 'initialize-package! #t)
-(package-initialize '(win32) 'init-wf_user! #t)
-(package-initialize '(win32 scheme-graphics) 'initialize-package! #t)
-(package-initialize '(win32 dib) 'initialize-package! #t)
\ No newline at end of file
+(add-identification! "Win32" 1 5)
\ No newline at end of file
diff --git a/v7/src/win32/win32.pkg b/v7/src/win32/win32.pkg
index a73ee7fc2..a69b71a58 100644
--- a/v7/src/win32/win32.pkg
+++ b/v7/src/win32/win32.pkg
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: win32.pkg,v 1.12 2000/04/13 03:13:46 cph Exp $
+$Id: win32.pkg,v 1.13 2001/08/18 04:52:11 cph Exp $
 
-Copyright (c) 1993-2000 Massachusetts Institute of Technology
+Copyright (c) 1993-2001 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -16,20 +16,14 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
 |#
 
 ;;;; WIN32 Packaging
 
 (global-definitions "../runtime/runtime")
 
-;(define-package (win32)
-;  (parent ())
-;  (file-case os-type
-;   ((nt) "winuser" "wingdi" "win_ffi")
-;   (else))
-;  (initialization (initialize-package!)))
-
 (define-package (win32)
   (parent ())
   (files "winuser"
@@ -51,15 +45,17 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  win32-clipboard-write-text
 	  win32-screen-height
 	  win32-screen-width)
-  (initialization (initialize-package!))
-)
+  (initialization
+   (begin
+     (initialize-protection-list-package!)
+     (initialize-module-package!)
+     (initialize-package!)
+     (init-wf_user!))))
 
 
 (define-package (win32 scheme-graphics)
   (files "graphics")
   (parent (win32))
-;  (export ()
-;          win32-graphics-device-type)
   (export ()
 	  win32/define-color
 	  win32/find-color)
@@ -77,9 +73,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (import (runtime graphics)
 	  graphics-device/buffer?
 	  make-image-type)
-  (initialization (initialize-package!))
-)
+  (initialization (initialize-package!)))
 
 (define-package (win32 dib)
   (files "dib")
-  (parent (win32)))
\ No newline at end of file
+  (parent (win32))
+  (initialization (initialize-package!)))
\ No newline at end of file