From 030f63ba6d899f177f688fd2542eb27b6474e9e7 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 27 Feb 2016 22:10:19 -0800 Subject: [PATCH] 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. --- src/runtime/pathnm.scm | 33 +++++++++++++++++++++------------ src/runtime/rep.scm | 41 +++++++++++++++++++++-------------------- src/runtime/wrkdir.scm | 10 +++++----- 3 files changed, 47 insertions(+), 37 deletions(-) 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 -- 2.25.1