From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Mon, 3 Feb 2014 16:19:45 +0000 (-0700)
Subject: Fluidize (runtime directory) variable *expand-directory-prefixes?*.
X-Git-Tag: mit-scheme-pucked-9.2.12~401^2~25
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6650da86e6506be800ce7883e41e0c2bf19a8097;p=mit-scheme.git

Fluidize (runtime directory) variable *expand-directory-prefixes?*.
---

diff --git a/src/runtime/dosdir.scm b/src/runtime/dosdir.scm
index 106038d16..228cee84d 100644
--- a/src/runtime/dosdir.scm
+++ b/src/runtime/dosdir.scm
@@ -30,7 +30,10 @@ USA.
 (declare (usual-integrations))
 
 (define directory-read/adjust-patterns? true)
-(define *expand-directory-prefixes?* true)
+(define *expand-directory-prefixes?*)
+
+(define (initialize-package!)
+  (set! *expand-directory-prefixes?* (make-fluid true)))
 
 (define (directory-read pattern #!optional sort?)
   (if (if (default-object? sort?) true sort?)
@@ -53,8 +56,9 @@ USA.
 	     (merge-pathnames pathname directory-path))
 	   (let ((pathnames
 		  (let ((fnames (generate-directory-pathnames directory-path)))
-		    (fluid-let ((*expand-directory-prefixes?* false))
-		      (map ->pathname fnames)))))
+		    (let-fluid *expand-directory-prefixes?* false
+		      (lambda ()
+			(map ->pathname fnames))))))
 	     (if (and (eq? (pathname-name pattern) 'WILD)
 		      (eq? (pathname-type pattern) 'WILD))
 		 pathnames
diff --git a/src/runtime/dospth.scm b/src/runtime/dospth.scm
index f2b81ee84..801708e61 100644
--- a/src/runtime/dospth.scm
+++ b/src/runtime/dospth.scm
@@ -113,7 +113,7 @@ USA.
 		     (cdr components))))))
     (let ((end (string-length string)))
       (if (or (= 0 end)
-	      (not *expand-directory-prefixes?*))
+	      (not (fluid *expand-directory-prefixes?*)))
 	  components
 	  (case (string-ref string 0)
 	    ((#\$)
diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 6f6857fad..5fbf25630 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -494,6 +494,7 @@ USA.
    (RUNTIME PATHNAME UNIX)
    (RUNTIME PATHNAME DOS)
    (RUNTIME PATHNAME)
+   (RUNTIME DIRECTORY)
    (RUNTIME WORKING-DIRECTORY)
    (RUNTIME LOAD)
    (RUNTIME SIMPLE-FILE-OPS)
diff --git a/src/runtime/ntdir.scm b/src/runtime/ntdir.scm
index 139616548..799cfcccc 100644
--- a/src/runtime/ntdir.scm
+++ b/src/runtime/ntdir.scm
@@ -29,7 +29,10 @@ USA.
 
 (declare (usual-integrations))
 
-(define *expand-directory-prefixes?* #t)
+(define *expand-directory-prefixes?*)
+
+(define (initialize-package!)
+  (set! *expand-directory-prefixes?* (make-fluid #t)))
 
 (define (directory-read pattern #!optional sort? full?)
   (let ((sort? (if (default-object? sort?) #t sort?))
@@ -54,8 +57,9 @@ USA.
 	   (lambda (pathname)
 	     (merge-pathnames pathname directory-path)))
 	 (let ((fnames (generate-directory-pathnames pattern)))
-	   (fluid-let ((*expand-directory-prefixes?* #f))
-	     (map ->pathname fnames))))))
+	   (let-fluid *expand-directory-prefixes?* #f
+	     (lambda ()
+	       (map ->pathname fnames)))))))
 
 (define (generate-directory-pathnames pathname)
   (let ((channel (directory-channel-open (->namestring pathname))))
@@ -74,9 +78,10 @@ USA.
 	     (cons (merge-pathnames (car entry) directory-path)
 		   (cdr entry))))
 	 (let ((entries (generate-directory-entries pattern)))
-	   (fluid-let ((*expand-directory-prefixes?* #f))
-	     (map (lambda (entry) (cons (->pathname (car entry)) (cdr entry)))
-		  entries))))))
+	   (let-fluid *expand-directory-prefixes?* #f
+	     (lambda ()
+	       (map (lambda (entry) (cons (->pathname (car entry)) (cdr entry)))
+		    entries)))))))
 
 (define (generate-directory-entries pathname)
   (let ((channel (directory-channel-open (->namestring pathname))))
diff --git a/src/runtime/os2dir.scm b/src/runtime/os2dir.scm
index cb5e9f224..66f7edd60 100644
--- a/src/runtime/os2dir.scm
+++ b/src/runtime/os2dir.scm
@@ -29,7 +29,10 @@ USA.
 
 (declare (usual-integrations))
 
-(define *expand-directory-prefixes?* #t)
+(define *expand-directory-prefixes?*)
+
+(define (initialize-package!)
+  (set! *expand-directory-prefixes?* (make-fluid #t)))
 
 (define (directory-read pattern #!optional sort?)
   (if (if (default-object? sort?) #t sort?)
@@ -42,8 +45,9 @@ USA.
 	   (lambda (pathname)
 	     (merge-pathnames pathname directory-path)))
 	 (let ((fnames (generate-directory-pathnames pattern)))
-	   (fluid-let ((*expand-directory-prefixes?* #f))
-	     (map ->pathname fnames))))))
+	   (let-fluid *expand-directory-prefixes?* #f
+	     (lambda ()
+	       (map ->pathname fnames)))))))
 
 (define (generate-directory-pathnames pathname)
   (let ((channel (directory-channel-open (->namestring pathname))))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 47aade8a6..a3ddc5176 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1614,7 +1614,8 @@ USA.
   (export (runtime pathname)
 	  *expand-directory-prefixes?*)
   (export ()
-	  directory-read))
+	  directory-read)
+  (initialization (initialize-package!)))
 
 (os-type-case
  ((unix)
@@ -6063,4 +6064,4 @@ USA.
 	  stack-sampler:debug-internal-errors?
 	  stack-sampler:show-expressions?
 	  with-stack-sampling)
-  (initialization (initialize-package!)))
\ No newline at end of file
+  (initialization (initialize-package!)))
diff --git a/src/runtime/unxdir.scm b/src/runtime/unxdir.scm
index a61fed0cd..56c5bddb5 100644
--- a/src/runtime/unxdir.scm
+++ b/src/runtime/unxdir.scm
@@ -29,7 +29,10 @@ USA.
 
 (declare (usual-integrations))
 
-(define *expand-directory-prefixes?* true)
+(define *expand-directory-prefixes?*)
+
+(define (initialize-package!)
+  (set! *expand-directory-prefixes?* (make-fluid true)))
 
 (define (directory-read pattern #!optional sort?)
   (if (if (default-object? sort?) true sort?)
@@ -52,8 +55,9 @@ USA.
 	     (merge-pathnames pathname directory-path))
 	   (let ((pathnames
 		  (let ((fnames (generate-directory-pathnames directory-path)))
-		    (fluid-let ((*expand-directory-prefixes?* false))
-		      (map ->pathname fnames)))))
+		    (let-fluid *expand-directory-prefixes?* false
+		      (lambda ()
+			(map ->pathname fnames))))))
 	     (if (and (eq? (pathname-name pattern) 'WILD)
 		      (eq? (pathname-type pattern) 'WILD))
 		 pathnames
diff --git a/src/runtime/unxpth.scm b/src/runtime/unxpth.scm
index 6cb79660c..b0f873943 100644
--- a/src/runtime/unxpth.scm
+++ b/src/runtime/unxpth.scm
@@ -82,7 +82,7 @@ USA.
 		   (cdr components)))))
     (let ((end (string-length string)))
       (if (or (= 0 end)
-	      (not *expand-directory-prefixes?*))
+	      (not (fluid *expand-directory-prefixes?*)))
 	  components
 	  (case (string-ref string 0)
 	    ((#\$)