Split *default-pathname-defaults* into parameter/non-parameter.

diff --git a/src/runtime/pathnm.scm b/src/runtime/pathnm.scm
index 42a8c25be7c159a6a76c83ce601d4e703fe3777a..366c247d5909e3246af46f491f02c98ee21922ff 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 (get-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*))))))
+                 (get-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*))))
+             (get-default-pathname-defaults))))
     (let ((pathname (enough-pathname pathname defaults)))
       (let ((namestring (pathname->namestring pathname)))
        (if (host=? (%pathname-host pathname) (%pathname-host defaults))
@@ -437,12 +437,19 @@ these rules:
 ;;;; Pathname Merging
 
 (define *default-pathname-defaults*)
+(define default-pathname-defaults)
+
+;;; Kludge to support FLUID-LET:
+(define (get-default-pathname-defaults)
+  (if (default-object? *default-pathname-defaults*)
+      (default-pathname-defaults)
+      *default-pathname-defaults*))
 
 (define (merge-pathnames pathname #!optional defaults default-version)
   (let* ((defaults
           (if (and (not (default-object? defaults)) defaults)
               (->pathname defaults)
-              (*default-pathname-defaults*)))
+              (get-default-pathname-defaults)))
         (pathname (pathname-arg pathname defaults 'MERGE-PATHNAMES)))
     (make-pathname
      (or (%pathname-host pathname) (%pathname-host defaults))
@@ -472,7 +479,7 @@ these rules:
   (let* ((defaults
           (if (and (not (default-object? defaults)) defaults)
               (->pathname defaults)
-              (*default-pathname-defaults*)))
+              (get-default-pathname-defaults)))
         (pathname (pathname-arg pathname defaults 'ENOUGH-PATHNAME)))
     (let ((usual
           (lambda (component default)
@@ -716,7 +723,8 @@ these rules:
            (vector-set! types index (make-unimplemented-host-type index))))
       (set! host-types types)
       (set! local-host (make-host host-type #f))))
-  (set! *default-pathname-defaults*
+  (set! *default-pathname-defaults* #!default)
+  (set! default-pathname-defaults
        (make-parameter (make-pathname local-host #f #f #f #f #f)))
   (set! library-directory-path
        (make-parameter

diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm
index 46298a10711514f1896781f227f9e7586a764456..a7eebe3011cbac347375ab2a36f513b812463a25 100644 (file)
--- a/src/runtime/rep.scm
+++ b/src/runtime/rep.scm
@@ -128,8 +128,7 @@ USA.
                    (cons standard-error-hook #f)
                    (cons standard-warning-hook #f)
                    (cons standard-breakpoint-hook #f)
-                   (cons *default-pathname-defaults*
-                         (*default-pathname-defaults*))
+                   (cons default-pathname-defaults (default-pathname-defaults))
                    (cons dynamic-handler-frames '())
                    (cons *bound-restarts*
                          (if (cmdl/parent cmdl) (*bound-restarts*) '())))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 486a98b6789f8b166e9bec016ec93f12241efc4e..e50101e45825c25c5ce68262c5981c60e9379526 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3138,6 +3138,7 @@ USA.
          ->namestring
          ->pathname
          ->truename
+         default-pathname-defaults
          directory-namestring
          directory-pathname
          directory-pathname-as-file

diff --git a/src/runtime/wrkdir.scm b/src/runtime/wrkdir.scm
index 104f31c831f6b79e4cd99446bb4785eb4b9f2fd4..1871d2acfaff164395a978a3b0904c0035d3c324 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))))))
     (*working-directory-pathname* pathname)
-    (*default-pathname-defaults* pathname))
+    (default-pathname-defaults pathname))
   unspecific)
 
 (define *working-directory-pathname* (make-parameter #f))
@@ -64,13 +64,13 @@ USA.
                              'SET-WORKING-DIRECTORY-PATHNAME!
                              (list name)))
     (*working-directory-pathname* pathname)
-    (*default-pathname-defaults* pathname)
+    (default-pathname-defaults pathname)
     (cmdl/set-default-directory (nearest-cmdl) pathname)
     pathname))
 
 (define (with-working-directory-pathname name thunk)
   (let ((pathname (new-pathname name)))
-    (parameterize* (list (cons *default-pathname-defaults* pathname)
+    (parameterize* (list (cons default-pathname-defaults pathname)
                         (cons *working-directory-pathname* pathname))
       thunk)))