0.9.18.45

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

diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index 226e4c4..6f8f1a0 100644 (file)
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -13,7 +13,7 @@
 
 #!-sb-fluid (declaim (freeze-type logical-pathname logical-host))
 \f
-;;;; UNIX-HOST stuff
+;;;; PHYSICAL-HOST stuff
 
 (def!struct (unix-host
              (:make-load-form-fun make-unix-host-load-form)
@@ -26,15 +26,36 @@
                        (unparse-directory #'unparse-unix-directory)
                        (unparse-file #'unparse-unix-file)
                        (unparse-enough #'unparse-unix-enough)
+                       (unparse-directory-separator "/")
+                       (simplify-namestring #'simplify-unix-namestring)
                        (customary-case :lower))))
-
 (defvar *unix-host* (make-unix-host))
-
 (defun make-unix-host-load-form (host)
   (declare (ignore host))
   '*unix-host*)
 
-(defvar *physical-host* *unix-host*)
+(def!struct (win32-host
+             (:make-load-form-fun make-win32-host-load-form)
+             (:include host
+                       (parse #'parse-win32-namestring)
+                       (parse-native #'parse-native-win32-namestring)
+                       (unparse #'unparse-win32-namestring)
+                       (unparse-native #'unparse-native-win32-namestring)
+                       (unparse-host #'unparse-win32-host)
+                       (unparse-directory #'unparse-win32-directory)
+                       (unparse-file #'unparse-win32-file)
+                       (unparse-enough #'unparse-win32-enough)
+                       (unparse-directory-separator "\\")
+                       (simplify-namestring #'simplify-win32-namestring)
+                       (customary-case :upper))))
+(defparameter *win32-host* (make-win32-host))
+(defun make-win32-host-load-form (host)
+  (declare (ignore host))
+  '*win32-host*)
+
+(defvar *physical-host*
+  #!-win32 *unix-host*
+  #!+win32 *win32-host*)
 
 ;;; Return a value suitable, e.g., for preinitializing
 ;;; *DEFAULT-PATHNAME-DEFAULTS* before *DEFAULT-PATHNAME-DEFAULTS* is
@@ -440,7 +461,7 @@ the operating system native pathname conventions."
                  (if (and (eq dir :back)
                           results
                           (not (member (car results)
-                                       '(:back :wild-inferiors))))
+                                       '(:back :wild-inferiors :relative :absolute))))
                      (pop results)
                      (push dir results))))
           (dolist (dir (maybe-diddle-case dir2 diddle-case))
@@ -506,12 +527,10 @@ the operating system native pathname conventions."
                 (error "~S is not allowed as a directory component." piece))))
        (results)))
     (simple-string
-     `(:absolute
-       ,(maybe-diddle-case directory diddle-case)))
+     `(:absolute ,(maybe-diddle-case directory diddle-case)))
     (string
      `(:absolute
-       ,(maybe-diddle-case (coerce directory 'simple-string)
-                           diddle-case)))))
+       ,(maybe-diddle-case (coerce directory 'simple-string) diddle-case)))))
 
 (defun make-pathname (&key host
                            (device nil devp)
@@ -839,7 +858,8 @@ 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 (funcall (host-parse-native host) namestr start end))
+             (host
+              (funcall (host-parse-native host) namestr start end))
              ((pathname-host defaults)
               (funcall (host-parse-native (pathname-host defaults))
                        namestr
@@ -1250,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
@@ -1263,6 +1284,12 @@ PARSE-NAMESTRING."
 
 ;;;; utilities
 
+(defun simplify-namestring (namestring &optional host)
+  (funcall (host-simplify-namestring
+            (or host
+                (pathname-host (sane-default-pathname-defaults))))
+           namestring))
+
 ;;; Canonicalize a logical pathname word by uppercasing it checking that it
 ;;; contains only legal characters.
 (defun logical-word-or-lose (word)
@@ -1283,7 +1310,7 @@ PARSE-NAMESTRING."
                              is not alphanumeric or hyphen:~%  ~S"
                  :args (list ch)
                  :namestring word :offset i))))
-    (coerce word 'base-string)))
+    (coerce word 'string))) ; why not simple-string?
 
 ;;; Given a logical host or string, return a logical host. If ERROR-P
 ;;; is NIL, then return NIL when no such host exists.
@@ -1532,13 +1559,15 @@ PARSE-NAMESTRING."
            (version-supplied (not (or (null version)
                                       (eq version :unspecific)))))
       (when name
-        (when (and (null type) (position #\. name :start 1))
+        (when (and (null type)
+                   (typep name 'string)
+                   (position #\. name :start 1))
           (error "too many dots in the name: ~S" pathname))
         (strings (unparse-logical-piece name)))
       (when type-supplied
         (unless name
           (error "cannot specify the type without a file: ~S" pathname))
-        (when (typep type 'simple-string)
+        (when (typep type 'string)
           (when (position #\. type)
             (error "type component can't have a #\. inside: ~S" pathname)))
         (strings ".")
@@ -1661,3 +1690,4 @@ PARSE-NAMESTRING."
       ;; FIXME: now that we have a SYS host that the system uses, it
       ;; might be cute to search in "SYS:TRANSLATIONS;<name>.LISP"
       (error "logical host ~S not found" host)))
+