Change WITH-EVAL-UNIT to change the current working directory if it is

given a pathname URI.  Rename SET-CURRENT-LOAD-ENVIRONMENT! and
WITH-CURRENT-LOAD-ENVIRONMENT to SET-LOAD-ENVIRONMENT! and
WITH-LOAD-ENVIRONMENT, respectively.

diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm
index dd32fc9686f1da1b61db73f3ade376ce38226543..a726cb5c136a0fc3f2d116a9b63eb9f405d2eee2 100644 (file)
--- a/v7/src/runtime/load.scm
+++ b/v7/src/runtime/load.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: load.scm,v 14.99 2007/10/12 02:00:22 cph Exp $
+$Id: load.scm,v 14.100 2007/10/12 02:12:11 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -122,10 +122,11 @@ USA.
 (define (wrap-loader pathname loader)
   (lambda (environment purify?)
     (lambda ()
-      (fluid-let ((*current-load-environment* environment))
-       (with-eval-unit (pathname->uri pathname)
-         (lambda ()
-           (loader environment purify?)))))))
+      (with-load-environment environment
+       (lambda ()
+         (with-eval-unit (pathname->uri pathname)
+           (lambda ()
+             (loader environment purify?))))))))
 \f
 (define (fasload pathname #!optional suppress-notifications?)
   (receive (pathname* loader notifier) (choose-fasload-method pathname)
@@ -249,8 +250,13 @@ USA.
     (thunk)))
 \f
 (define (with-eval-unit uri thunk)
-  (fluid-let ((*eval-unit* (->absolute-uri uri 'WITH-EVAL-UNIT)))
-    (thunk)))
+  (let ((uri (->absolute-uri uri 'WITH-EVAL-UNIT)))
+    (fluid-let ((*eval-unit* uri))
+      (let ((pathname (uri->pathname uri #f)))
+       (if pathname
+           (with-working-directory-pathname (directory-pathname pathname)
+             thunk)
+           (thunk))))))
 
 (define (current-eval-unit #!optional error?)
   (let ((unit *eval-unit*))
@@ -269,17 +275,18 @@ USA.
        (nearest-repl/environment)
        env)))
 
-(define (with-current-load-environment environment thunk)
-  (guarantee-environment environment 'WITH-CURRENT-LOAD-ENVIRONMENT)
-  (fluid-let ((*current-load-environment* environment))
-    (thunk)))
-
-(define (set-current-load-environment! env)
+(define (set-load-environment! environment)
+  (guarantee-environment environment 'SET-LOAD-ENVIRONMENT!)
   (if (not (eq? *current-load-environment* 'NONE))
       (begin
-       (set! *current-load-environment* env)
+       (set! *current-load-environment* environment)
        unspecific)))
 
+(define (with-load-environment environment thunk)
+  (guarantee-environment environment 'WITH-LOAD-ENVIRONMENT)
+  (fluid-let ((*current-load-environment* environment))
+    (thunk)))
+
 (define (load/push-hook! hook)
   (if (not load/loading?) (error condition-type:not-loading))
   (set! load/after-load-hooks (cons hook load/after-load-hooks))

diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm
index a20dc8430f1344b4f1313f710aa20b103edcdd8f..48aa7b40cb705ab2d5d21b61a66efa00fdab0aa6 100644 (file)
--- a/v7/src/runtime/rep.scm
+++ b/v7/src/runtime/rep.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: rep.scm,v 14.69 2007/10/12 01:08:02 cph Exp $
+$Id: rep.scm,v 14.70 2007/10/12 02:12:13 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -780,7 +780,7 @@ USA.
 (define (ge environment)
   (let ((environment (->environment environment 'GE)))
     (set-repl/environment! (nearest-repl) environment)
-    (set-current-load-environment! environment)
+    (set-load-environment! environment)
     environment))
 
 (define (->environment object #!optional caller)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 98afd5c4736987c69097c184b516c5bbc1a9c658..dd644ee99e7e19b0e407ded97a166b69c9cf568b 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.628 2007/10/12 02:00:24 cph Exp $
+$Id: runtime.pkg,v 14.629 2007/10/12 02:12:14 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -2425,14 +2425,13 @@ USA.
          load/push-hook!
          load/suppress-loading-message?
          set-command-line-parser!
+         set-load-environment!
          simple-command-line-parser
          system-library-uri
          system-uri
-         with-current-load-environment
          with-eval-unit
+         with-load-environment
          with-loader-base-uri)
-  (export (runtime rep)
-         set-current-load-environment!)
   (initialization (initialize-package!)))
 
 (define-package (runtime microcode-errors)