From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 24 May 2010 05:11:11 +0000 (-0700)
Subject: Add LOAD-WITH-BOOT-INITS! for testing.
X-Git-Tag: 20100708-Gtk~58
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=949746e13adfb7aa48bdfd3eb48f916813e6555b;p=mit-scheme.git

Add LOAD-WITH-BOOT-INITS! for testing.
---

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index 3d90a3395..80ab3ae2d 100644
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -142,6 +142,15 @@ USA.
 (define-integrable (default-object)
   ((ucode-primitive object-set-type) (ucode-type constant) 7))
 
+(define (load-with-boot-inits! . arguments)
+  (receive (value inits)
+      (fluid-let ((boot-inits '()))
+	(let ((value (apply load arguments)))
+	  (values value (reverse! boot-inits))))
+    (for-each (lambda (init) (init))
+	      inits)
+    value))
+
 (define (init-boot-inits!)
   (set! boot-inits '())
   unspecific)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index f8957ef26..e2f95aa83 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -166,6 +166,7 @@ USA.
 	  without-interrupts)
   (export (runtime)
 	  add-boot-init!
+	  load-with-boot-inits!
 	  run-boot-inits!))
 
 (define-package (runtime equality)