Fluidize *default-pathname-defaults*.

diff --git a/doc/ref-manual/os-interface.texi b/doc/ref-manual/os-interface.texi
index d2e52d73c692b28e80704291f094929789ed72ef..257365084af80f9f0a142535f7377ac9f54ba061 100644 (file)
--- a/doc/ref-manual/os-interface.texi
+++ b/doc/ref-manual/os-interface.texi
@@ -543,11 +543,12 @@ from @var{defaults} together.
 
 @defvr variable *default-pathname-defaults*
 @cindex defaulting, of pathname
-This is the default pathname-defaults pathname; if any pathname
-primitive that needs a set of defaults is not given one, it uses this
-one.  @code{set-working-directory-pathname!} sets this variable to a new
-value, computed by merging the new working directory with the variable's
-old value.
+The value of this fluid (@pxref{Fluids}) is the default
+pathname-defaults pathname; if any pathname primitive that needs a set
+of defaults is not given one, it uses this one.
+@code{set-working-directory-pathname!} sets this fluid to a new value,
+computed by merging the new working directory with the fluid's old
+value.
 @end defvr
 
 @deffn procedure pathname-default pathname device directory name type version
@@ -840,16 +841,13 @@ directory, before changing the working directory.
 @end deffn
 
 @deffn procedure with-working-directory-pathname filename thunk
-This procedure temporarily rebinds the current working directory to
-@var{filename}, invokes @var{thunk} (a procedure of no arguments), then
-restores the previous working directory and returns the value yielded by
-@var{thunk}.  @var{Filename} is coerced to a pathname using
-@code{pathname-as-directory}.  In addition to binding the working
-directory, @code{with-working-directory-pathname} also binds the
-variable @code{*default-pathname-defaults*}, merging the old value of
-that variable with the new working directory pathname.  Both bindings
-are performed in exactly the same way as dynamic binding of a variable
-(@pxref{Dynamic Binding}).
+This procedure dynamically binds (@pxref{Dynamic Binding}) the current
+working directory to @var{filename} and returns the value of
+@var{thunk} (a procedure of no arguments).  @var{Filename} is coerced
+to a pathname using @code{pathname-as-directory}.  In addition to
+binding the working directory, @code{with-working-directory-pathname}
+also dynamically binds the @code{*default-pathname-defaults*} fluid,
+merging the old value with the new working directory pathname.
 @end deffn
 
 @node File Manipulation, Directory Reader, Working Directory, Operating-System Interface

diff --git a/src/runtime/pathnm.scm b/src/runtime/pathnm.scm
index 01c4fe7e60f620585a88262628a702ca56819a21..ca0377f0262aa2d02cfeecb2c143d5e20c0d8b5b 100644 (file)
--- a/src/runtime/pathnm.scm
+++ b/src/runtime/pathnm.scm
@@ -328,7 +328,7 @@ these rules:
 
 (define (uri->pathname uri #!optional error?)
   (let ((uri (->uri uri (and error? 'URI->PATHNAME)))
-       (defaults *default-pathname-defaults*)
+       (defaults (fluid *default-pathname-defaults*))
        (finish
         (lambda (device path keyword)
           (receive (directory name type)
@@ -389,7 +389,7 @@ these rules:
             (pathname-host
              (if (and (not (default-object? defaults)) defaults)
                  defaults
-                 *default-pathname-defaults*)))))
+                 (fluid *default-pathname-defaults*))))))
     (cond ((string? namestring)
           ((host-type/operation/parse-namestring (host/type host))
            namestring host))
@@ -422,7 +422,7 @@ these rules:
   (let ((defaults
          (if (and (not (default-object? defaults)) defaults)
              (->pathname defaults)
-             *default-pathname-defaults*)))
+             (fluid *default-pathname-defaults*))))
     (let ((pathname (enough-pathname pathname defaults)))
       (let ((namestring (pathname->namestring pathname)))
        (if (host=? (%pathname-host pathname) (%pathname-host defaults))
@@ -442,7 +442,7 @@ these rules:
   (let* ((defaults
           (if (and (not (default-object? defaults)) defaults)
               (->pathname defaults)
-              *default-pathname-defaults*))
+              (fluid *default-pathname-defaults*)))
         (pathname (pathname-arg pathname defaults 'MERGE-PATHNAMES)))
     (make-pathname
      (or (%pathname-host pathname) (%pathname-host defaults))
@@ -472,7 +472,7 @@ these rules:
   (let* ((defaults
           (if (and (not (default-object? defaults)) defaults)
               (->pathname defaults)
-              *default-pathname-defaults*))
+              (fluid *default-pathname-defaults*)))
         (pathname (pathname-arg pathname defaults 'ENOUGH-PATHNAME)))
     (let ((usual
           (lambda (component default)
@@ -717,7 +717,7 @@ these rules:
       (set! host-types types)
       (set! local-host (make-host host-type #f))))
   (set! *default-pathname-defaults*
-       (make-pathname local-host #f #f #f #f #f))
+       (make-fluid (make-pathname local-host #f #f #f #f #f)))
   (set! library-directory-path
        (map pathname-as-directory
             (vector->list ((ucode-primitive microcode-library-path 0)))))

diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm
index 9c2215d964e18813a95210c20e6f49b15984abaf..fc55b18cbbbfc8dd639e6b769464146447673d36 100644 (file)
--- a/src/runtime/rep.scm
+++ b/src/runtime/rep.scm
@@ -127,12 +127,11 @@ USA.
              standard-error-hook #f
              standard-warning-hook #f
              standard-breakpoint-hook #f
+             *default-pathname-defaults* (fluid *default-pathname-defaults*)
              (lambda ()
                (fluid-let ((dynamic-handler-frames '())
                            (*bound-restarts*
-                            (if (cmdl/parent cmdl) *bound-restarts* '()))
-                           (*default-pathname-defaults*
-                            *default-pathname-defaults*))
+                            (if (cmdl/parent cmdl) *bound-restarts* '())))
                  (let loop ((message message))
                    (loop
                     (bind-abort-restart cmdl

diff --git a/src/runtime/wrkdir.scm b/src/runtime/wrkdir.scm
index a7bfe1720e80ae59c5bf8a101af2bfb7e05201d3..29b421bc4d318c5c25ff572b09744ed43d5d9c06 100644 (file)
--- a/src/runtime/wrkdir.scm
+++ b/src/runtime/wrkdir.scm
@@ -39,7 +39,7 @@ USA.
          (pathname-as-directory
           ((ucode-primitive working-directory-pathname))))))
     (set-fluid! *working-directory-pathname* pathname)
-    (set! *default-pathname-defaults* pathname))
+    (set-fluid! *default-pathname-defaults* pathname))
   unspecific)
 
 (define *working-directory-pathname* (make-fluid #f))
@@ -64,14 +64,15 @@ USA.
                              'SET-WORKING-DIRECTORY-PATHNAME!
                              (list name)))
     (set-fluid! *working-directory-pathname* pathname)
-    (set! *default-pathname-defaults* pathname)
+    (set-fluid! *default-pathname-defaults* pathname)
     (cmdl/set-default-directory (nearest-cmdl) pathname)
     pathname))
 
 (define (with-working-directory-pathname name thunk)
   (let ((pathname (new-pathname name)))
-    (fluid-let ((*default-pathname-defaults* pathname))
-      (let-fluid *working-directory-pathname* pathname thunk))))
+    (let-fluids *default-pathname-defaults* pathname
+               *working-directory-pathname* pathname
+      thunk)))
 
 (define (new-pathname name)
   (pathname-simplify