Fix handling of *default-pathname-defaults*.

Problem is that this variable is readable as well, so for now we have to keep it
up to date.  This is kind of a pain.

diff --git a/src/runtime/pathnm.scm b/src/runtime/pathnm.scm
index cbf281c37e9b64f53304bef4eb77c50b30495d83..c87c4ce7942ef03a5adf5387f5694c345ee5d509 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 (get-default-pathname-defaults))
+       (defaults (param: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
-                 (get-default-pathname-defaults))))))
+                 (param: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)
-             (get-default-pathname-defaults))))
+             (param:default-pathname-defaults))))
     (let ((pathname (enough-pathname pathname defaults)))
       (let ((namestring (pathname->namestring pathname)))
        (if (host=? (%pathname-host pathname) (%pathname-host defaults))
@@ -439,17 +439,27 @@ these rules:
 (define *default-pathname-defaults*)
 (define param:default-pathname-defaults)
 
-;;; Kludge to support FLUID-LET:
-(define (get-default-pathname-defaults)
-  (if (default-object? *default-pathname-defaults*)
-      (param:default-pathname-defaults)
+(define (make-param:default-pathname-defaults)
+  (make-general-parameter #f
+                         identity-procedure
+                         defaults-getter
+                         defaults-setter))
+
+(define (defaults-getter defaults)
+  (if (eq? defaults *default-pathname-defaults*)
+      defaults
       *default-pathname-defaults*))
 
+(define (defaults-setter set-param defaults)
+  (set-param defaults)
+  (set! *default-pathname-defaults* defaults)
+  unspecific)
+
 (define (merge-pathnames pathname #!optional defaults default-version)
   (let* ((defaults
           (if (and (not (default-object? defaults)) defaults)
               (->pathname defaults)
-              (get-default-pathname-defaults)))
+              (param:default-pathname-defaults)))
         (pathname (pathname-arg pathname defaults 'MERGE-PATHNAMES)))
     (make-pathname
      (or (%pathname-host pathname) (%pathname-host defaults))
@@ -479,7 +489,7 @@ these rules:
   (let* ((defaults
           (if (and (not (default-object? defaults)) defaults)
               (->pathname defaults)
-              (get-default-pathname-defaults)))
+              (param:default-pathname-defaults)))
         (pathname (pathname-arg pathname defaults 'ENOUGH-PATHNAME)))
     (let ((usual
           (lambda (component default)
@@ -723,9 +733,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* #!default)
-  (set! param:default-pathname-defaults
-       (make-parameter (make-pathname local-host #f #f #f #f #f)))
+  (set! param:default-pathname-defaults (make-param:default-pathname-defaults))
+  (param:default-pathname-defaults (make-pathname local-host #f #f #f #f #f))
   (set! library-directory-path
        (make-parameter
         (map pathname-as-directory

diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm
index be9a541fed227289b849adeda60cb32dccbfaadf..b8fef388a5b5dc712d0ca3ab6393d8fd78ce21f2 100644 (file)
--- a/src/runtime/rep.scm
+++ b/src/runtime/rep.scm
@@ -111,7 +111,8 @@ USA.
   (port/set-default-directory (cmdl/port cmdl) pathname))
 \f
 (define (cmdl/start cmdl message)
-  (let ((port (cmdl/port cmdl)))
+  (let ((port (cmdl/port cmdl))
+       (pathname-defaults (param:default-pathname-defaults)))
     (let ((thunk
           (lambda ()
             (parameterize*
@@ -126,29 +127,29 @@ USA.
                    (cons param:standard-error-hook #f)
                    (cons param:standard-warning-hook #f)
                    (cons param:standard-breakpoint-hook #f)
-                   (cons param:default-pathname-defaults
-                         (param:default-pathname-defaults))
+                   (cons param:default-pathname-defaults pathname-defaults)
                    (cons dynamic-handler-frames '())
                    (cons param:bound-restarts
                          (if (cmdl/parent cmdl) (param:bound-restarts) '())))
              (lambda ()
-               (let loop ((message message))
-                 (loop
-                  (bind-abort-restart cmdl
-                    (lambda ()
-                      (deregister-all-events)
-                      (with-interrupt-mask interrupt-mask/all
-                        (lambda (interrupt-mask)
-                          interrupt-mask
-                          (unblock-thread-events)
-                          (ignore-errors
-                           (lambda ()
-                             ((->cmdl-message message) cmdl)))
-                          (call-with-current-continuation
-                           (lambda (continuation)
-                             (with-create-thread-continuation continuation
-                               (lambda ()
-                                 ((cmdl/driver cmdl) cmdl)))))))))))))))
+               (fluid-let ((*default-pathname-defaults* pathname-defaults))
+                 (let loop ((message message))
+                   (loop
+                    (bind-abort-restart cmdl
+                      (lambda ()
+                        (deregister-all-events)
+                        (with-interrupt-mask interrupt-mask/all
+                          (lambda (interrupt-mask)
+                            interrupt-mask
+                            (unblock-thread-events)
+                            (ignore-errors
+                             (lambda ()
+                               ((->cmdl-message message) cmdl)))
+                            (call-with-current-continuation
+                             (lambda (continuation)
+                               (with-create-thread-continuation continuation
+                                 (lambda ()
+                                   ((cmdl/driver cmdl) cmdl))))))))))))))))
          (mutex (port/thread-mutex port)))
       (let ((thread (current-thread))
            (owner (thread-mutex-owner mutex)))

diff --git a/src/runtime/wrkdir.scm b/src/runtime/wrkdir.scm
index 04151efe79445e5074a9787979bcf18de159963e..3a44497406c36e2995267757f9d1a8a449793864 100644 (file)
--- a/src/runtime/wrkdir.scm
+++ b/src/runtime/wrkdir.scm
@@ -44,8 +44,7 @@ USA.
          (pathname-as-directory
           ((ucode-primitive working-directory-pathname))))))
     (working-directory-pathname pathname)
-    (param:default-pathname-defaults pathname))
-  unspecific)
+    (param:default-pathname-defaults pathname)))
 
 (define working-directory-pathname)
 
@@ -76,9 +75,10 @@ USA.
 
 (define (with-working-directory-pathname name thunk)
   (let ((pathname (new-pathname name)))
-    (parameterize* (list (cons param:default-pathname-defaults pathname)
-                        (cons working-directory-pathname pathname))
-      thunk)))
+    (fluid-let ((*default-pathname-defaults* pathname))
+      (parameterize* (list (cons param:default-pathname-defaults pathname)
+                          (cons working-directory-pathname pathname))
+       thunk))))
 
 (define (new-pathname name)
   (pathname-simplify