1.0.11.35: fixed bug 417

[sbcl.git] / src / code / target-pathname.lisp

diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index eee1e6a..f32e656 100644 (file)
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -111,7 +111,7 @@
 
 ;;; Hash table searching maps a logical pathname's host to its
 ;;; physical pathname translation.
-(defvar *logical-hosts* (make-hash-table :test 'equal))
+(defvar *logical-hosts* (make-hash-table :test 'equal :synchronized t))
 \f
 ;;;; patterns
 
@@ -858,7 +858,7 @@ a host-structure or string."
      (let* ((end (%check-vector-sequence-bounds namestr start end)))
        (multiple-value-bind (new-host device directory file type version)
            (cond
-             (host 
+             (host
               (funcall (host-parse-native host) namestr start end))
              ((pathname-host defaults)
               (funcall (host-parse-native (pathname-host defaults))
@@ -1270,8 +1270,9 @@ PARSE-NAMESTRING."
                (frob %pathname-name)
                (frob %pathname-type)
                (if (eq from-host *unix-host*)
-                   (if (eq (%pathname-version to) :wild)
-                       (%pathname-version from)
+                   (if (or (eq (%pathname-version to) :wild)
+                           (eq (%pathname-version to) nil))
+                       (%pathname-version source)
                        (%pathname-version to))
                    (frob %pathname-version)))))))))
 \f
@@ -1337,11 +1338,12 @@ PARSE-NAMESTRING."
 ;;; a new one if necessary.
 (defun intern-logical-host (thing)
   (declare (values logical-host))
-  (or (find-logical-host thing nil)
-      (let* ((name (logical-word-or-lose thing))
-             (new (make-logical-host :name name)))
-        (setf (gethash name *logical-hosts*) new)
-        new)))
+  (with-locked-hash-table (*logical-hosts*)
+    (or (find-logical-host thing nil)
+        (let* ((name (logical-word-or-lose thing))
+               (new (make-logical-host :name name)))
+          (setf (gethash name *logical-hosts*) new)
+          new))))
 \f
 ;;;; logical pathname parsing