Clean up loader's handling of pathname and environment.

diff --git a/src/runtime/load.scm b/src/runtime/load.scm
index 7a72c6ad64fc77f02f0c12318c8451f41c871e6b..bfa1b8fbea1cc86a4f34d6dd4481e0450e43a358 100644 (file)
--- 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?))))))
 \f
 (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)))
 \f
-(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 ac35bdb646ebdddf19176bf7c2ff80655863cbce..24035f413fffa5af3eec311b75485b03a24a9f40 100644 (file)
--- 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 655a69e378aaf026da789641654445a1d0144ed7..59d13a93b4c17b6175a6cafe30578e37b029c9dd 100644 (file)
--- 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 5d5820c18c80daede5ced74921131f05eb6d6532..5a36e8c58970bdc8c44f34a69db1e6bf49fbdcee 100644 (file)
--- 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))))))))))
 \f
 (define (make-expansion-environment pathname)
   (let ((environment (extend-top-level-environment expander-environment)))