From a647f35a48924c9bc1914e1286418309fc69704e Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 19 Oct 2010 14:30:03 +0000 Subject: [PATCH] 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. --- NEWS | 14 ++++++++------ src/code/pathname.lisp | 31 +++++++++++++++++++++++++++++++ src/code/target-pathname.lisp | 4 ++-- src/code/unix-pathname.lisp | 33 ++------------------------------- src/code/win32-pathname.lisp | 41 +++++++---------------------------------- tests/filesys.pure.lisp | 3 +-- tests/pathnames.impure.lisp | 2 +- version.lisp-expr | 2 +- 8 files changed, 53 insertions(+), 77 deletions(-) diff --git a/NEWS b/NEWS index 97e9aca..6d636a4 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4