From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 27 Feb 2016 21:02:10 +0000 (-0800)
Subject: Split *default-pathname-defaults* into parameter/non-parameter.
X-Git-Tag: mit-scheme-pucked-9.2.12~261^2~124
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5cd5e82226e3b1689d9000d3e6763298fe2887c0;p=mit-scheme.git

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

diff --git a/src/runtime/pathnm.scm b/src/runtime/pathnm.scm
index 42a8c25be..366c247d5 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 (*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 46298a107..a7eebe301 100644
--- 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 486a98b67..e50101e45 100644
--- 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 104f31c83..1871d2acf 100644
--- 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)))