From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 28 Sep 2009 02:22:10 +0000 (-0700)
Subject: Fix bug in cold-load sequence.
X-Git-Tag: 20100708-Gtk~304
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=24ba860dc3282a0f903573d37ebcbd43eb783a5c;p=mit-scheme.git

Fix bug in cold-load sequence.
---

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 310737daa..87299030d 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -202,18 +202,21 @@ USA.
   (package/environment (find-package name)))
 
 (define (package-initialization-sequence specs)
-  (let loop ((specs specs))
-    (if (pair? specs)
-	(let ((spec (car specs)))
-	  (if (or (not (pair? spec))
-		  (symbol? (car spec)))
-	      (package-initialize spec #f #t)
-	      (package-initialize (car spec)
-				  (cadr spec)
-				  (if (pair? (cddr spec))
-				      (caddr spec)
-				      #t)))
-	  (loop (cdr specs))))))
+  (do ((specs specs (cdr specs)))
+      ((not (pair? specs)) unspecific)
+    (let ((spec (car specs)))
+      (cond ((eq? (car spec) 'OPTIONAL)
+	     (package-initialize (cadr spec)
+				 (and (pair? (cddr spec))
+				      (caddr spec))
+				 #f))
+	    ((pair? (car spec))
+	     (package-initialize (car spec)
+				 (and (pair? (cdr spec))
+				      (cadr spec))
+				 #t))
+	    (else
+	     (package-initialize spec #f #t))))))
 
 (define (remember-to-purify purify? filename value)
   (if purify?
@@ -492,7 +495,7 @@ USA.
    (RUNTIME WORKING-DIRECTORY)
    (RUNTIME LOAD)
    (RUNTIME SIMPLE-FILE-OPS)
-   ((RUNTIME OS-PRIMITIVES) INITIALIZE-MIME-TYPES! #f)
+   (OPTIONAL (RUNTIME OS-PRIMITIVES) INITIALIZE-MIME-TYPES!)
    ;; Syntax
    (RUNTIME NUMBER-PARSER)
    (RUNTIME PARSER)
@@ -520,19 +523,19 @@ USA.
    ;; Graphics.  The last type initialized is the default for
    ;; MAKE-GRAPHICS-DEVICE, only the types that are valid for the
    ;; operating system are actually loaded and initialized.
-   ((RUNTIME STARBASE-GRAPHICS) #f #f)
-   (RUNTIME X-GRAPHICS)
-   ((RUNTIME OS2-GRAPHICS) #f #f)
+   (OPTIONAL (RUNTIME STARBASE-GRAPHICS))
+   (OPTIONAL (RUNTIME X-GRAPHICS))
+   (OPTIONAL (RUNTIME OS2-GRAPHICS))
    ;; Emacs -- last because it installs hooks everywhere which must be initted.
    (RUNTIME EMACS-INTERFACE)
    ;; More debugging
-   ((RUNTIME CONTINUATION-PARSER) INITIALIZE-SPECIAL-FRAMES! #f)
+   (OPTIONAL (RUNTIME CONTINUATION-PARSER) INITIALIZE-SPECIAL-FRAMES!)
    (RUNTIME URI)
    (RUNTIME RFC2822-HEADERS)
    (RUNTIME HTTP-SYNTAX)
    (RUNTIME HTTP-CLIENT)
    (RUNTIME HTML-FORM-CODEC)
-   ((RUNTIME WIN32-REGISTRY) #f #f)))
+   (OPTIONAL (RUNTIME WIN32-REGISTRY))))
 
 (let ((obj (file->object "site" #t #f)))
   (if obj
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 1aa268e31..046cb36e8 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -60,8 +60,7 @@ USA.
   (parent ())
   (export ()
 	  write-mit-scheme-copyright
-	  write-mit-scheme-license)
-  (initialization (initialize-package!)))
+	  write-mit-scheme-license))
 
 (define-package (runtime bit-string)
   (files "bitstr")
diff --git a/src/runtime/version.scm b/src/runtime/version.scm
index 309218e1c..d32e95962 100644
--- a/src/runtime/version.scm
+++ b/src/runtime/version.scm
@@ -30,15 +30,16 @@ USA.
 
 (define copyright-years)
 
-(define (initialize-package!)
-  (set! copyright-years
-	(let ((now 2009)
-	      (then 1986))
-	  (iota (+ (- now then) 1) then)))
-  (add-subsystem-identification! "Release" '(7 7 90 "+"))
-  (snarf-microcode-version!)
-  (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-subsystem-identification! "Runtime" '(15 7)))
+(add-boot-init!
+ (lambda ()
+   (set! copyright-years
+	 (let ((now 2009)
+	       (then 1986))
+	   (iota (+ (- now then) 1) then)))
+   (add-subsystem-identification! "Release" '(7 7 90 "+"))
+   (snarf-microcode-version!)
+   (add-event-receiver! event:after-restore snarf-microcode-version!)
+   (add-subsystem-identification! "Runtime" '(15 7))))
 
 (define (snarf-microcode-version!)
   (add-subsystem-identification! "Microcode"