Email Archive: sbcl-commits (read-only)
|
[Sbcl-commits] CVS: sbcl/src/code pathname.lisp, 1.22,
1.23 target-pathname.lisp, 1.64, 1.65 unix-pathname.lisp, 1.9,
1.10 win32-pathname.lisp, 1.16, 1.17
From: Nikodemus Siivola <demoss@us...> - 2010-10-19 14:30
|
Update of /cvsroot/sbcl/sbcl/src/code
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv14079/src/code
Modified Files:
pathname.lisp target-pathname.lisp unix-pathname.lisp
win32-pathname.lisp
Log Message:
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.
Index: pathname.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/pathname.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- pathname.lisp 22 Aug 2008 14:31:30 -0000 1.22
+++ pathname.lisp 19 Oct 2010 14:30:03 -0000 1.23
@@ -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))))
Index: target-pathname.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-pathname.lisp,v
retrieving revision 1.64
retrieving revision 1.65
diff -u -d -r1.64 -r1.65
--- target-pathname.lisp 17 Mar 2010 14:28:00 -0000 1.64
+++ target-pathname.lisp 19 Oct 2010 14:30:03 -0000 1.65
@@ -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 "\\")
Index: unix-pathname.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/unix-pathname.lisp,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -d -r1.9 -r1.10
--- unix-pathname.lisp 20 May 2009 13:51:53 -0000 1.9
+++ unix-pathname.lisp 19 Oct 2010 14:30:03 -0000 1.10
@@ -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))))
Index: win32-pathname.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/win32-pathname.lisp,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- win32-pathname.lisp 28 Nov 2009 22:53:45 -0000 1.16
+++ win32-pathname.lisp 19 Oct 2010 14:30:03 -0000 1.17
@@ -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))))
|
Thread View
| Thread | Author | Date |
|---|---|---|
| [Sbcl-commits] CVS: sbcl/src/code pathname.lisp, 1.22, 1.23 target-pathname.lisp, 1.64, 1.65 unix-pathname.lisp, 1.9, 1.10 win32-pathname.lisp, 1.16, 1.17 | Nikodemus Siivola <demoss@us...> |