From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 20 May 2018 23:59:38 +0000 (-0700)
Subject: Clean up loader's handling of pathname and environment.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~19
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0c0b36bae12c93dea9934e735c0fa764fa769f7e;p=mit-scheme.git

Clean up loader's handling of pathname and environment.
---

diff --git a/src/runtime/load.scm b/src/runtime/load.scm
index 7a72c6ad6..bfa1b8fbe 100644
--- a/src/runtime/load.scm
+++ b/src/runtime/load.scm
@@ -39,11 +39,34 @@ USA.
 (define-deferred param:after-load-hooks
   (make-settable-parameter '()))
 
-(define-deferred param:current-load-environment
-  (make-settable-parameter #!default))
+(define-deferred current-load-environment
+  (make-general-parameter #!default
+			  (lambda (object)
+			    (if (default-object? object)
+				object
+				(guarantee environment? object)))
+			  default-parameter-merger
+			  (lambda (value)
+			    (if (default-object? value)
+				(nearest-repl/environment)
+				value))
+			  #f))
 
 (define-deferred param:eval-unit
-  (make-unsettable-parameter #f))
+  (make-unsettable-parameter #f
+    (lambda (value)
+      (and value
+	   (->absolute-uri value)))))
+
+(define-deferred current-load-pathname
+  (make-forwarding-parameter param:eval-unit
+    (lambda (pathname)
+      (pathname->uri (merge-pathnames pathname)))
+    (lambda (eval-unit)
+      (let ((pathname (and eval-unit (uri->pathname eval-unit #f))))
+	(if (not pathname)
+	    (error condition-type:not-loading))
+	pathname))))
 
 (define-deferred param:loading?
   (make-unsettable-parameter #f))
@@ -132,11 +155,10 @@ USA.
 (define (wrap-loader pathname loader)
   (lambda (environment purify?)
     (lambda ()
-      (with-load-environment environment
+      (parameterize* (list (cons current-load-pathname pathname)
+			   (cons current-load-environment environment))
 	(lambda ()
-	  (with-eval-unit (pathname->uri pathname)
-	    (lambda ()
-	      (loader environment purify?))))))))
+	  (loader environment purify?))))))
 
 (define (fasload pathname #!optional suppress-notifications?)
   (receive (pathname* loader notifier) (choose-fasload-method pathname)
@@ -260,38 +282,6 @@ USA.
        (write (enough-namestring pathname) port)))
     (thunk)))
 
-(define (with-eval-unit uri thunk)
-  (parameterize*
-   (list (cons param:eval-unit (->absolute-uri uri 'with-eval-unit)))
-   thunk))
-
-(define (current-eval-unit #!optional error?)
-  (let ((unit (param:eval-unit)))
-    (if (and (not unit)
-	     (if (default-object? error?) #t error?))
-	(error condition-type:not-loading))
-    unit))
-
-(define (current-load-pathname)
-  (or (uri->pathname (current-eval-unit) #f)
-      (error condition-type:not-loading)))
-
-(define (current-load-environment)
-  (let ((env (param:current-load-environment)))
-    (if (default-object? env)
-	(nearest-repl/environment)
-	env)))
-
-(define (set-load-environment! environment)
-  (guarantee environment? environment 'set-load-environment!)
-  (if (not (default-object? (param:current-load-environment)))
-      (param:current-load-environment environment)))
-
-(define (with-load-environment environment thunk)
-  (guarantee environment? environment 'with-load-environment)
-  (parameterize* (list (cons param:current-load-environment environment))
-    thunk))
-
 (define (load/push-hook! hook)
   (if (not (param:loading?)) (error condition-type:not-loading))
   (param:after-load-hooks (cons hook (param:after-load-hooks))))
diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm
index ac35bdb64..24035f413 100644
--- a/src/runtime/rep.scm
+++ b/src/runtime/rep.scm
@@ -792,7 +792,6 @@ USA.
 (define (ge environment)
   (let ((environment (->environment environment 'ge)))
     (set-repl/environment! (nearest-repl) environment)
-    (set-load-environment! environment)
     environment))
 
 (define (->environment object #!optional caller)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 655a69e37..59d13a93b 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3153,7 +3153,6 @@ USA.
 	  (load-noisily load)
 	  built-in-object-file
 	  condition-type:not-loading
-	  current-eval-unit
 	  current-load-environment
 	  current-load-pathname
 	  fasl-file?
@@ -3165,11 +3164,8 @@ USA.
 	  load/push-hook!
 	  param:loading?
 	  param:suppress-loading-message?
-	  set-load-environment!
 	  system-library-uri
 	  system-uri
-	  with-eval-unit
-	  with-load-environment
 	  with-loader-base-uri)
   (export (runtime)
 	  load/purification-root))
diff --git a/src/ssp/xhtml-expander.scm b/src/ssp/xhtml-expander.scm
index 5d5820c18..5a36e8c58 100644
--- a/src/ssp/xhtml-expander.scm
+++ b/src/ssp/xhtml-expander.scm
@@ -74,17 +74,16 @@ USA.
 
 (define (read/expand-xml-file pathname environment)
   (let ((pathname (merge-pathnames pathname)))
-    (with-eval-unit (pathname->uri pathname)
+    (with-working-directory-pathname (directory-pathname pathname)
       (lambda ()
-	(with-working-directory-pathname (directory-pathname pathname)
+	(parameterize* (list (cons current-load-pathname pathname)
+			     (cons current-load-environment environment))
 	  (lambda ()
-	    (with-load-environment environment
-	      (lambda ()
-		(fluid-let ((*sabbr-table* (make-strong-eq-hash-table)))
-		  (read-xml-file pathname
-				 `((scheme ,(pi-expander environment))
-				   (svar ,svar-expander)
-				   (sabbr ,sabbr-expander))))))))))))
+	    (fluid-let ((*sabbr-table* (make-strong-eq-hash-table)))
+	      (read-xml-file pathname
+			     `((scheme ,(pi-expander environment))
+			       (svar ,svar-expander)
+			       (sabbr ,sabbr-expander))))))))))
 
 (define (make-expansion-environment pathname)
   (let ((environment (extend-top-level-environment expander-environment)))