1.0.43.75: pathnames: both Unix and Win32 use UNPARSE-PHYSICAL-DIRECTORY

  Refactor duplicated code and start using / instead of \ to separate
  directories in Lisp namestrings -- less escaping, easier to think
  about and read.

diff --git a/NEWS b/NEWS
index 97e9aca..6d636a4 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -23,6 +23,14 @@ changes relative to sbcl-1.0.43:
     Branches are simplified before performing if/if-conversion, and simple
     equivalent branches (that only read the same constant or variable) are
     merged.
+  * improvements to the Windows port:
+    ** change: canonical unparsing form for pathname namestrings now uses / as
+       directory separator. NATIVE-NAMESTRING still uses \ as the separator.
+    ** bug fix: stackoverwriting due to incorrect usage of PeekConsoleInput
+       on Windows. (thanks to Kalyanov Dmitry)
+    ** bug fix: build now works on cygwin with GCC 4.x installed. (thanks to
+       Kalyanov Dmitry)
+    ** bug fix: run-sbcl.sh now works on Cygwin. (thanks to Kalyanov Dmitry)
   * bug fix: compiler failed to derive the result-type of MAKE-ARRAY as
     (AND VECTOR (NOT SIMPLE-ARRAY)) when appropriate. (lp#309130)
   * bug fix: (THE (VALUES ...)) in LOAD-TIME-VALUE caused a compiler-error.
@@ -32,12 +40,6 @@ changes relative to sbcl-1.0.43:
     spuriously when reading from a pipe (lp#643686)
   * bug fix: more efficient timer expiry should avoid starvation on systems
     where number of SIGALRMs per second is restricted. (lp#375515)
-  * improvements to the Windows port:
-    ** bug fix: stackoverwriting due to incorrect usage of PeekConsoleInput
-       on Windows. (thanks to Kalyanov Dmitry)
-    ** bug fix: build now works on cygwin with GCC 4.x installed. (thanks to
-       Kalyanov Dmitry)
-    ** bug fix: run-sbcl.sh now works on Cygwin. (thanks to Kalyanov Dmitry)
   * bug fix: non-unicode builds no longer fail (broken since 1.0.36.15).
   * bug fix: compile-times no longer scale linearly with the size of
     quoted lists in source-code. (lp#654289)

diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp
index efed381..7f9d4cf 100644 (file)
--- a/src/code/pathname.lisp
+++ b/src/code/pathname.lisp
@@ -126,3 +126,34 @@
                                                   name
                                                   type
                                                   version))))
+
+;;; This is used both for Unix and Windows: while we accept both
+;;; \ and / as directory separators on Windows, we print our
+;;; own always with /, which is much less confusing what with
+;;; being \ needing to be escaped.
+(defun unparse-physical-directory (pathname)
+  (declare (pathname pathname))
+  (unparse-physical-directory-list (%pathname-directory pathname)))
+
+(defun unparse-physical-directory-list (directory)
+  (declare (list directory))
+  (collect ((pieces))
+    (when directory
+      (ecase (pop directory)
+       (:absolute
+        (pieces "/"))
+       (:relative))
+      (dolist (dir directory)
+        (typecase dir
+         ((member :up)
+          (pieces "../"))
+         ((member :back)
+          (error ":BACK cannot be represented in namestrings."))
+         ((member :wild-inferiors)
+          (pieces "**/"))
+         ((or simple-string pattern (member :wild))
+          (pieces (unparse-physical-piece dir))
+          (pieces "/"))
+         (t
+          (error "invalid directory component: ~S" dir)))))
+    (apply #'concatenate 'simple-string (pieces))))

diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index 762f472..196f50a 100644 (file)
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -23,7 +23,7 @@
                        (unparse #'unparse-unix-namestring)
                        (unparse-native #'unparse-native-unix-namestring)
                        (unparse-host #'unparse-unix-host)
-                       (unparse-directory #'unparse-unix-directory)
+                       (unparse-directory #'unparse-physical-directory)
                        (unparse-file #'unparse-unix-file)
                        (unparse-enough #'unparse-unix-enough)
                        (unparse-directory-separator "/")
@@ -42,7 +42,7 @@
                        (unparse #'unparse-win32-namestring)
                        (unparse-native #'unparse-native-win32-namestring)
                        (unparse-host #'unparse-win32-host)
-                       (unparse-directory #'unparse-win32-directory)
+                       (unparse-directory #'unparse-physical-directory)
                        (unparse-file #'unparse-win32-file)
                        (unparse-enough #'unparse-win32-enough)
                        (unparse-directory-separator "\\")

diff --git a/src/code/unix-pathname.lisp b/src/code/unix-pathname.lisp
index 82b39b7..05c8307 100644 (file)
--- a/src/code/unix-pathname.lisp
+++ b/src/code/unix-pathname.lisp
@@ -132,35 +132,6 @@
   ;; 2002-05-09
   "")
 
-(defun unparse-unix-directory-list (directory)
-  (declare (type list directory))
-  (collect ((pieces))
-    (when directory
-      (ecase (pop directory)
-        (:absolute
-         (pieces "/"))
-        (:relative
-         ;; nothing special
-         ))
-      (dolist (dir directory)
-        (typecase dir
-          ((member :up)
-           (pieces "../"))
-          ((member :back)
-           (error ":BACK cannot be represented in namestrings."))
-          ((member :wild-inferiors)
-           (pieces "**/"))
-          ((or simple-string pattern (member :wild))
-           (pieces (unparse-physical-piece dir))
-           (pieces "/"))
-          (t
-           (error "invalid directory component: ~S" dir)))))
-    (apply #'concatenate 'simple-string (pieces))))
-
-(defun unparse-unix-directory (pathname)
-  (declare (type pathname pathname))
-  (unparse-unix-directory-list (%pathname-directory pathname)))
-
 (defun unparse-unix-file (pathname)
   (declare (type pathname pathname))
   (collect ((strings))
@@ -195,7 +166,7 @@
 (defun unparse-unix-namestring (pathname)
   (declare (type pathname pathname))
   (concatenate 'simple-string
-               (unparse-unix-directory pathname)
+               (unparse-physical-directory pathname)
                (unparse-unix-file pathname)))
 
 (defun unparse-native-unix-namestring (pathname as-file)
@@ -268,7 +239,7 @@
                      pathname-directory)
                     (t
                      (bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
-        (strings (unparse-unix-directory-list result-directory)))
+        (strings (unparse-physical-directory-list result-directory)))
       (let* ((pathname-type (%pathname-type pathname))
              (type-needed (and pathname-type
                                (not (eq pathname-type :unspecific))))

diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp
index a982f68..38cc6f0 100644 (file)
--- a/src/code/win32-pathname.lisp
+++ b/src/code/win32-pathname.lisp
@@ -159,7 +159,7 @@
   ;; FIXME: same as UNPARSE-UNIX-HOST.  That's probably not good.
   "")
 
-(defun unparse-win32-device (pathname)
+(defun unparse-win32-device (pathname &optional native)
   (declare (type pathname pathname))
   (let ((device (pathname-device pathname))
         (directory (pathname-directory pathname)))
@@ -170,36 +170,9 @@
           ((and (consp directory) (eq :relative (car directory)))
            (error "No printed representation for a relative UNC pathname."))
           (t
-           (concatenate 'simple-string "\\\\" device)))))
-
-(defun unparse-win32-directory-list (directory)
-  (declare (type list directory))
-  (collect ((pieces))
-    (when directory
-      (ecase (pop directory)
-        (:absolute
-         (pieces "\\"))
-        (:relative
-         ;; nothing special
-         ))
-      (dolist (dir directory)
-        (typecase dir
-          ((member :up)
-           (pieces "..\\"))
-          ((member :back)
-           (error ":BACK cannot be represented in namestrings."))
-          ((member :wild-inferiors)
-           (pieces "**\\"))
-          ((or simple-string pattern (member :wild))
-           (pieces (unparse-physical-piece dir))
-           (pieces "\\"))
-          (t
-           (error "invalid directory component: ~S" dir)))))
-    (apply #'concatenate 'simple-string (pieces))))
-
-(defun unparse-win32-directory (pathname)
-  (declare (type pathname pathname))
-  (unparse-win32-directory-list (%pathname-directory pathname)))
+           (if native
+               (concatenate 'simple-string "\\\\" device)
+               (concatenate 'simple-string "//" device))))))
 
 (defun unparse-win32-file (pathname)
   (declare (type pathname pathname))
@@ -234,7 +207,7 @@
   (declare (type pathname pathname))
   (concatenate 'simple-string
                (unparse-win32-device pathname)
-               (unparse-win32-directory pathname)
+               (unparse-physical-directory pathname)
                (unparse-win32-file pathname)))
 
 (defun unparse-native-win32-namestring (pathname as-file)
@@ -252,7 +225,7 @@
     (coerce
      (with-output-to-string (s)
        (when device
-         (write-string (unparse-win32-device pathname) s))
+         (write-string (unparse-win32-device pathname t) s))
        (when directory
          (ecase (car directory)
            (:absolute (write-char #\\ s))
@@ -311,7 +284,7 @@
                      pathname-directory)
                     (t
                      (bug "Bad fallthrough in ~S" 'unparse-unix-enough)))))
-        (strings (unparse-unix-directory-list result-directory)))
+        (strings (unparse-physical-directory-list result-directory)))
       (let* ((pathname-type (%pathname-type pathname))
              (type-needed (and pathname-type
                                (not (eq pathname-type :unspecific))))

diff --git a/tests/filesys.pure.lisp b/tests/filesys.pure.lisp
index 4be0257..f6ac941 100644 (file)
--- a/tests/filesys.pure.lisp
+++ b/tests/filesys.pure.lisp
@@ -32,8 +32,7 @@
   ;; We know a little bit about the structure of this result;
   ;; let's test to make sure that this test file is in it.
   (assert (find-if (lambda (pathname)
-                     (search #-win32 "tests/filesys.pure.lisp"
-                             #+win32 "tests\\filesys.pure.lisp"
+                     (search "tests/filesys.pure.lisp"
                              (namestring pathname)))
                    dir)))
 ;;; In sbcl-0.9.7 DIRECTORY failed on pathnames with character-set

diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp
index d361b28..99d94c8 100644 (file)
--- a/tests/pathnames.impure.lisp
+++ b/tests/pathnames.impure.lisp
@@ -486,7 +486,7 @@
                 for name in components
                 appending (loop for type in components
                                 as pathname = (make-pathname
-                                               #+win32 "C"
+                                               #+win32 :device #+win32 "C"
                                                :directory '(:absolute "tmp")
                                                :name name :type type)
                                 collect (ignore-errors

diff --git a/version.lisp-expr b/version.lisp-expr
index fbf5fe4..1cfd126 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.43.74"
+"1.0.43.75"