From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 12 Oct 2007 02:12:14 +0000 (+0000)
Subject: Change WITH-EVAL-UNIT to change the current working directory if it is
X-Git-Tag: 20090517-FFI~422
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9579f1deb52289ef4e4f470063f6011c8ffb0a04;p=mit-scheme.git

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 dd32fc968..a726cb5c1 100644
--- 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?))))))))
 
 (define (fasload pathname #!optional suppress-notifications?)
   (receive (pathname* loader notifier) (choose-fasload-method pathname)
@@ -249,8 +250,13 @@ USA.
     (thunk)))
 
 (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 a20dc8430..48aa7b40c 100644
--- 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 98afd5c47..dd644ee99 100644
--- 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)