From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 31 Aug 2008 07:28:05 +0000 (+0000)
Subject: Implement new mechanism to simplify initialization during cold load.
X-Git-Tag: 20090517-FFI~199
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b10af70a0b4b725866510fb60db92c272c8801ed;p=mit-scheme.git

Implement new mechanism to simplify initialization during cold load.
---

diff --git a/v7/src/runtime/boot.scm b/v7/src/runtime/boot.scm
index a179e2062..d9b82d456 100644
--- a/v7/src/runtime/boot.scm
+++ b/v7/src/runtime/boot.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: boot.scm,v 14.30 2008/02/10 06:14:03 cph Exp $
+$Id: boot.scm,v 14.31 2008/08/31 07:27:00 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -142,4 +142,27 @@ USA.
   (eq? object (default-object)))
 
 (define-integrable (default-object)
-  ((ucode-primitive object-set-type) (ucode-type constant) 7))
\ No newline at end of file
+  ((ucode-primitive object-set-type) (ucode-type constant) 7))
+
+(define (init-boot-inits!)
+  (set! boot-inits '())
+  unspecific)
+
+(define (add-boot-init! thunk)
+  (set! boot-inits (cons thunk boot-inits))
+  unspecific)
+
+(define (save-boot-inits! environment)
+  (let ((inits (reverse! boot-inits)))
+    (set! boot-inits)
+    ((ucode-primitive local-assignment) environment saved-boot-inits inits)))
+
+(define (run-boot-inits! environment)
+  (let ((inits
+	 ((ucode-primitive lexical-reference) environment saved-boot-inits)))
+    ((ucode-primitive unbind-variable) environment saved-boot-inits)
+    (for-each (lambda (init) (init))
+	      inits)))
+
+(define boot-inits)
+(define saved-boot-inits '|#[saved-boot-inits]|)
\ No newline at end of file
diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index 95f054d7a..6005b006e 100644
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.117 2008/08/24 07:20:09 cph Exp $
+$Id: make.scm,v 14.118 2008/08/31 07:28:05 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -401,14 +401,19 @@ USA.
 	    (let loop ((files files))
 	      (and (pair? files)
 		   (or (string=? (car (car files)) filename)
-		       (loop (cdr files))))))))
+		       (loop (cdr files)))))))
+	 (boot-defs
+	  (package/environment (name->package '(RUNTIME BOOT-DEFINITIONS)))))
      (lambda (filename environment)
        (if (not (or (string=? filename "make")
 		    (string=? filename "packag")
 		    (file-member? filename files1)
 		    (file-member? filename files2)))
-	   (eval (file->object filename #t #t)
-		 environment))
+	   (begin
+	     ((access init-boot-inits! boot-defs))
+	     (eval (file->object filename #t #t)
+		   environment)
+	     ((access save-boot-inits! boot-defs) environment)))
        unspecific))))
 
 ;;; Funny stuff is done.  Rest of sequence is standardized.
diff --git a/v7/src/runtime/mit-syntax.scm b/v7/src/runtime/mit-syntax.scm
index 00a7f72b2..9326ddc8b 100644
--- a/v7/src/runtime/mit-syntax.scm
+++ b/v7/src/runtime/mit-syntax.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: mit-syntax.scm,v 14.32 2008/01/30 20:02:32 cph Exp $
+$Id: mit-syntax.scm,v 14.33 2008/08/31 07:27:34 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -225,18 +225,26 @@ USA.
 			     variable-binding-theory)))))
     (lambda (form rename compare)
       compare				;ignore
-      (cond ((syntax-match? '((IDENTIFIER . MIT-BVL) + FORM) (cdr form))
-	     `(,(car form) ,(caadr form)
-			   (,(rename 'NAMED-LAMBDA) ,@(cdr form))))
-	    ((syntax-match? '((DATUM . MIT-BVL) + FORM) (cdr form))
-	     `(,(car form) ,(caadr form)
-			   (,(rename 'LAMBDA) ,(cdadr form) ,@(cddr form))))
-	    ((syntax-match? '(IDENTIFIER) (cdr form))
-	     `(,keyword ,(cadr form) ,(unassigned-expression)))
-	    ((syntax-match? '(IDENTIFIER EXPRESSION) (cdr form))
-	     `(,keyword ,(cadr form) ,(caddr form)))
-	    (else
-	     (ill-formed-syntax form))))))
+      (receive (name value) (parse-define-form form rename)
+	`(,keyword ,name ,value)))))
+
+(define (parse-define-form form rename)
+  (cond ((syntax-match? '((IDENTIFIER . MIT-BVL) + FORM) (cdr form))
+	 (parse-define-form
+	  `(,(car form) ,(caadr form)
+			(,(rename 'NAMED-LAMBDA) ,@(cdr form)))
+	  rename))
+	((syntax-match? '((DATUM . MIT-BVL) + FORM) (cdr form))
+	 (parse-define-form
+	  `(,(car form) ,(caadr form)
+			(,(rename 'LAMBDA) ,(cdadr form) ,@(cddr form)))
+	  rename))
+	((syntax-match? '(IDENTIFIER) (cdr form))
+	 (values (cadr form) (unassigned-expression)))
+	((syntax-match? '(IDENTIFIER EXPRESSION) (cdr form))
+	 (values (cadr form) (caddr form)))
+	(else
+	 (ill-formed-syntax form))))
 
 (define-classifier 'DEFINE-SYNTAX system-global-environment
   (lambda (form environment definition-environment history)
diff --git a/v7/src/runtime/sysmac.scm b/v7/src/runtime/sysmac.scm
index 0d825b154..9e4baf073 100644
--- a/v7/src/runtime/sysmac.scm
+++ b/v7/src/runtime/sysmac.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: sysmac.scm,v 14.19 2008/02/14 02:35:05 cph Exp $
+$Id: sysmac.scm,v 14.20 2008/08/31 07:27:37 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -94,4 +94,16 @@ USA.
 					     (IF (DEFAULT-OBJECT? CALLER)
 						 #F
 						 CALLER))))))
-	 (ill-formed-syntax form)))))
\ No newline at end of file
+	 (ill-formed-syntax form)))))
+
+(define-syntax define-deferred
+  (er-macro-transformer
+   (lambda (form rename compare)
+     compare
+      (receive (name value) (parse-define-form form rename)
+	`(,(rename 'BEGIN)
+	  (,(rename 'DEFINE) ,name)
+	  (,(rename 'ADD-BOOT-INIT!)
+	   (,(rename 'LAMBDA) ()
+			      (,(rename 'SET!) ,name ,value)
+			      ,(rename 'UNSPECIFIC))))))))
\ No newline at end of file