From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 28 Feb 2016 06:10:19 +0000 (-0800)
Subject: Fix handling of *default-pathname-defaults*.
X-Git-Tag: mit-scheme-pucked-9.2.12~261^2~107
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=030f63ba6d899f177f688fd2542eb27b6474e9e7;p=mit-scheme.git

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 cbf281c37..c87c4ce79 100644
--- 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 be9a541fe..b8fef388a 100644
--- a/src/runtime/rep.scm
+++ b/src/runtime/rep.scm
@@ -111,7 +111,8 @@ USA.
   (port/set-default-directory (cmdl/port cmdl) pathname))
 
 (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 04151efe7..3a4449740 100644
--- 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