From 6650da86e6506be800ce7883e41e0c2bf19a8097 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Mon, 3 Feb 2014 09:19:45 -0700 Subject: [PATCH] Fluidize (runtime directory) variable *expand-directory-prefixes?*. --- src/runtime/dosdir.scm | 10 +++++++--- src/runtime/dospth.scm | 2 +- src/runtime/make.scm | 1 + src/runtime/ntdir.scm | 17 +++++++++++------ src/runtime/os2dir.scm | 10 +++++++--- src/runtime/runtime.pkg | 5 +++-- src/runtime/unxdir.scm | 10 +++++++--- src/runtime/unxpth.scm | 2 +- 8 files changed, 38 insertions(+), 19 deletions(-) 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) ((#\$) -- 2.25.1