From: Matt Birkholz Date: Sun, 2 Feb 2014 21:34:55 +0000 (-0700) Subject: Fluidize *default-pathname-defaults*. X-Git-Tag: mit-scheme-pucked-9.2.12~401^2~28 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d361ab256864acca7f8c28aeb36d7a11702c3ccc;p=mit-scheme.git Fluidize *default-pathname-defaults*. --- diff --git a/doc/ref-manual/os-interface.texi b/doc/ref-manual/os-interface.texi index d2e52d73c..257365084 100644 --- a/doc/ref-manual/os-interface.texi +++ b/doc/ref-manual/os-interface.texi @@ -543,11 +543,12 @@ from @var{defaults} together. @defvr variable *default-pathname-defaults* @cindex defaulting, of pathname -This is the default pathname-defaults pathname; if any pathname -primitive that needs a set of defaults is not given one, it uses this -one. @code{set-working-directory-pathname!} sets this variable to a new -value, computed by merging the new working directory with the variable's -old value. +The value of this fluid (@pxref{Fluids}) is the default +pathname-defaults pathname; if any pathname primitive that needs a set +of defaults is not given one, it uses this one. +@code{set-working-directory-pathname!} sets this fluid to a new value, +computed by merging the new working directory with the fluid's old +value. @end defvr @deffn procedure pathname-default pathname device directory name type version @@ -840,16 +841,13 @@ directory, before changing the working directory. @end deffn @deffn procedure with-working-directory-pathname filename thunk -This procedure temporarily rebinds the current working directory to -@var{filename}, invokes @var{thunk} (a procedure of no arguments), then -restores the previous working directory and returns the value yielded by -@var{thunk}. @var{Filename} is coerced to a pathname using -@code{pathname-as-directory}. In addition to binding the working -directory, @code{with-working-directory-pathname} also binds the -variable @code{*default-pathname-defaults*}, merging the old value of -that variable with the new working directory pathname. Both bindings -are performed in exactly the same way as dynamic binding of a variable -(@pxref{Dynamic Binding}). +This procedure dynamically binds (@pxref{Dynamic Binding}) the current +working directory to @var{filename} and returns the value of +@var{thunk} (a procedure of no arguments). @var{Filename} is coerced +to a pathname using @code{pathname-as-directory}. In addition to +binding the working directory, @code{with-working-directory-pathname} +also dynamically binds the @code{*default-pathname-defaults*} fluid, +merging the old value with the new working directory pathname. @end deffn @node File Manipulation, Directory Reader, Working Directory, Operating-System Interface diff --git a/src/runtime/pathnm.scm b/src/runtime/pathnm.scm index 01c4fe7e6..ca0377f02 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 (fluid *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*))))) + (fluid *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*))) + (fluid *default-pathname-defaults*)))) (let ((pathname (enough-pathname pathname defaults))) (let ((namestring (pathname->namestring pathname))) (if (host=? (%pathname-host pathname) (%pathname-host defaults)) @@ -442,7 +442,7 @@ these rules: (let* ((defaults (if (and (not (default-object? defaults)) defaults) (->pathname defaults) - *default-pathname-defaults*)) + (fluid *default-pathname-defaults*))) (pathname (pathname-arg pathname defaults 'MERGE-PATHNAMES))) (make-pathname (or (%pathname-host pathname) (%pathname-host defaults)) @@ -472,7 +472,7 @@ these rules: (let* ((defaults (if (and (not (default-object? defaults)) defaults) (->pathname defaults) - *default-pathname-defaults*)) + (fluid *default-pathname-defaults*))) (pathname (pathname-arg pathname defaults 'ENOUGH-PATHNAME))) (let ((usual (lambda (component default) @@ -717,7 +717,7 @@ these rules: (set! host-types types) (set! local-host (make-host host-type #f)))) (set! *default-pathname-defaults* - (make-pathname local-host #f #f #f #f #f)) + (make-fluid (make-pathname local-host #f #f #f #f #f))) (set! library-directory-path (map pathname-as-directory (vector->list ((ucode-primitive microcode-library-path 0))))) diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index 9c2215d96..fc55b18cb 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -127,12 +127,11 @@ USA. standard-error-hook #f standard-warning-hook #f standard-breakpoint-hook #f + *default-pathname-defaults* (fluid *default-pathname-defaults*) (lambda () (fluid-let ((dynamic-handler-frames '()) (*bound-restarts* - (if (cmdl/parent cmdl) *bound-restarts* '())) - (*default-pathname-defaults* - *default-pathname-defaults*)) + (if (cmdl/parent cmdl) *bound-restarts* '()))) (let loop ((message message)) (loop (bind-abort-restart cmdl diff --git a/src/runtime/wrkdir.scm b/src/runtime/wrkdir.scm index a7bfe1720..29b421bc4 100644 --- a/src/runtime/wrkdir.scm +++ b/src/runtime/wrkdir.scm @@ -39,7 +39,7 @@ USA. (pathname-as-directory ((ucode-primitive working-directory-pathname)))))) (set-fluid! *working-directory-pathname* pathname) - (set! *default-pathname-defaults* pathname)) + (set-fluid! *default-pathname-defaults* pathname)) unspecific) (define *working-directory-pathname* (make-fluid #f)) @@ -64,14 +64,15 @@ USA. 'SET-WORKING-DIRECTORY-PATHNAME! (list name))) (set-fluid! *working-directory-pathname* pathname) - (set! *default-pathname-defaults* pathname) + (set-fluid! *default-pathname-defaults* pathname) (cmdl/set-default-directory (nearest-cmdl) pathname) pathname)) (define (with-working-directory-pathname name thunk) (let ((pathname (new-pathname name))) - (fluid-let ((*default-pathname-defaults* pathname)) - (let-fluid *working-directory-pathname* pathname thunk)))) + (let-fluids *default-pathname-defaults* pathname + *working-directory-pathname* pathname + thunk))) (define (new-pathname name) (pathname-simplify