From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 7 Oct 2018 00:06:49 +0000 (-0700)
Subject: Change the loader so that it can load R7RS source files.
X-Git-Tag: mit-scheme-pucked-9.2.19~2^2~13
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9f67bcd9f6c364c84fb81d250a2c09c5fc56d072;p=mit-scheme.git

Change the loader so that it can load R7RS source files.

Now to make compiled files work.  :)
---

diff --git a/src/runtime/library-database.scm b/src/runtime/library-database.scm
index 2b43e9404..ff26459c9 100644
--- a/src/runtime/library-database.scm
+++ b/src/runtime/library-database.scm
@@ -72,9 +72,6 @@ USA.
 
 (define library-db?
   (make-bundle-predicate 'library-database))
-
-(define-deferred host-library-db
-  (make-library-db 'host))
 
 (define (make-library name . keylist)
   (if name
diff --git a/src/runtime/library-loader.scm b/src/runtime/library-loader.scm
index 19413bdd0..69b7dd733 100644
--- a/src/runtime/library-loader.scm
+++ b/src/runtime/library-loader.scm
@@ -31,7 +31,7 @@ USA.
 
 ;;;; Syntax
 
-(define-automatic-property '->scode '(name imports exports syntaxed-contents)
+(define-automatic-property 'scode '(name imports exports contents)
   #f
   (lambda (name imports exports contents)
     (make-scode-declaration
@@ -41,6 +41,12 @@ USA.
 		(exports ,(map library-export->list exports))))
      (make-scode-quotation contents))))
 
+(define (eval-r7rs-source source db)
+  (let ((program (register-r7rs-source! source db)))
+    (if program
+	(scode-eval (library-contents program)
+		    (library-environment program)))))
+
 (define-automatic-property 'contents
     '(parsed-contents imports exports imports-environment)
   #f
diff --git a/src/runtime/library-standard.scm b/src/runtime/library-standard.scm
index f15501806..976fb08a6 100644
--- a/src/runtime/library-standard.scm
+++ b/src/runtime/library-standard.scm
@@ -29,6 +29,12 @@ USA.
 
 (declare (usual-integrations))
 
+(define-deferred host-library-db
+  (make-library-db 'host))
+
+(define (finish-host-library-db!)
+  (add-standard-libraries! host-library-db))
+
 (define (add-standard-libraries! db)
   (register-libraries! (make-standard-libraries) db))
 
diff --git a/src/runtime/load.scm b/src/runtime/load.scm
index a9ed8a812..8c1d14f13 100644
--- a/src/runtime/load.scm
+++ b/src/runtime/load.scm
@@ -52,6 +52,9 @@ USA.
 				value))
 			  #f))
 
+(define-deferred current-load-library-db
+  (make-unsettable-parameter host-library-db))
+
 (define-deferred param:eval-unit
   (make-unsettable-parameter #f
     (lambda (value)
@@ -86,7 +89,7 @@ USA.
       load/suppress-loading-message?))
 
 (define (load pathname #!optional environment syntax-table purify?)
-  syntax-table				;ignored
+  (declare (ignore syntax-table))
   (let ((environment
 	 (if (default-object? environment)
 	     (current-load-environment)
@@ -113,7 +116,7 @@ USA.
 
 (define (file-loadable? pathname)
   (receive (pathname* loader notifier) (choose-load-method pathname)
-    loader notifier
+    (declare (ignore loader notifier))
     (if pathname* #t #f)))
 
 (define (choose-load-method pathname)
@@ -143,14 +146,17 @@ USA.
 
 (define (source-loader pathname)
   (lambda (environment purify?)
-    purify?
-    (call-with-input-file pathname
-      (lambda (port)
-	(let loop ((value unspecific))
-	  (let ((sexp (read port)))
-	    (if (eof-object? sexp)
-		value
-		(loop (repl-eval sexp environment)))))))))
+    (declare (ignore purify?))
+    (let ((source (read-r7rs-source pathname)))
+      (if source
+	  (eval-r7rs-source source (current-load-library-db))
+	  (call-with-input-file pathname
+	    (lambda (port)
+	      (let loop ((value unspecific))
+		(let ((sexp (read port)))
+		  (if (eof-object? sexp)
+		      value
+		      (loop (repl-eval sexp environment)))))))))))
 
 (define (wrap-loader pathname loader)
   (lambda (environment purify?)
diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 82c4cc10b..c76c91dfe 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -475,7 +475,7 @@ USA.
    (runtime hash)
    (runtime dynamic)
    (runtime regular-sexpression)
-   (runtime library database)
+   (runtime library standard)
    ;; Microcode data structures
    (runtime history)
    (runtime scode)
@@ -560,6 +560,8 @@ USA.
    (runtime structure-parser)
    (runtime swank)
    (runtime stack-sampler)
+   ;; Done very late since it will look up lots of global variables.
+   ((runtime library standard) finish-host-library-db!)
    ;; Last since it turns on runtime handling of microcode errors.
    ((runtime microcode-errors) initialize-error-hooks!)))
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 16bc6ec0c..dee2664fc 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3160,6 +3160,7 @@ USA.
 	  built-in-object-file
 	  condition-type:not-loading
 	  current-load-environment
+	  current-load-library-db
 	  current-load-pathname
 	  fasl-file?
 	  fasload
@@ -5838,7 +5839,6 @@ USA.
   (parent (runtime library))
   (export (runtime library)
 	  define-automatic-property
-	  host-library-db
 	  library-contents
 	  library-db?
 	  library-environment
@@ -5879,6 +5879,8 @@ USA.
 (define-package (runtime library parser)
   (files "library-parser")
   (parent (runtime library))
+  (export (runtime)
+	  read-r7rs-source)
   (export (runtime library)
 	  library-name=?
 	  library-name?
@@ -5889,12 +5891,13 @@ USA.
 	  r7rs-source-program
 	  r7rs-source-libraries
 	  r7rs-source?
-	  read-r7rs-source
 	  register-r7rs-source!))
 
 (define-package (runtime library standard)
   (files "library-standard")
   (parent (runtime library))
+  (export (runtime)
+	  host-library-db)
   (export (runtime library)
 	  add-standard-libraries!
 	  check-standard-libraries!
@@ -5916,5 +5919,5 @@ USA.
   (export ()
 	  environment			;R7RS
 	  )
-  (export (runtime library)
-	  imports->environment))
\ No newline at end of file
+  (export (runtime)
+	  eval-r7rs-source))
\ No newline at end of file