From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Tue, 27 Jan 2004 14:23:57 +0000 (+0000)
Subject: 0.8.7.24:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=ffd0723ac8c26916d35d806e1eaad60557fb4a96;p=sbcl.git

0.8.7.24:
	More pathname fun, *sigh*
	... make logical pathnames respect print/read consistency (version
		*is* significant for them)
	... adjust the pathname tests so that they test equality rather
		than namestring equality, but minus version testing
		because that's too complicated right now.
---

diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp
index 61195bd..07e9a4e 100644
--- a/src/code/pathname.lisp
+++ b/src/code/pathname.lisp
@@ -37,7 +37,7 @@
 			(lambda (x)
 			  (logical-host-name (%pathname-host x))))
 		       (unparse-directory #'unparse-logical-directory)
-		       (unparse-file #'unparse-unix-file)
+		       (unparse-file #'unparse-logical-file)
 		       (unparse-enough #'unparse-enough-namestring)
 		       (customary-case :upper)))
   (name "" :type simple-base-string)
diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index fa8b426..5fd2744 100644
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -1413,6 +1413,36 @@ a host-structure or string."
 		  (t (error "invalid keyword: ~S" piece))))))
        (apply #'concatenate 'simple-string (strings))))))
 
+(defun unparse-logical-file (pathname)
+  (declare (type pathname pathname))
+    (collect ((strings))
+    (let* ((name (%pathname-name pathname))
+	   (type (%pathname-type pathname))
+	   (version (%pathname-version pathname))
+	   (type-supplied (not (or (null type) (eq type :unspecific))))
+	   (version-supplied (not (or (null version)
+				      (eq version :unspecific)))))
+      (when name
+	(when (and (null type) (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-base-string)
+	  (when (position #\. type)
+	    (error "type component can't have a #\. inside: ~S" pathname)))
+	(strings ".")
+	(strings (unparse-logical-piece type)))
+      (when version-supplied
+	(unless type-supplied
+	  (error "cannot specify the version without a type: ~S" pathname))
+	(etypecase version
+	  ((member :newest) (strings ".NEWEST"))
+	  ((member :wild) (strings ".*"))
+	  (fixnum (strings ".") (strings (format nil "~D" version))))))
+    (apply #'concatenate 'simple-string (strings))))
+
 ;;; Unparse a logical pathname string.
 (defun unparse-enough-namestring (pathname defaults)
   (let* ((path-directory (pathname-directory pathname))
@@ -1449,7 +1479,7 @@ a host-structure or string."
   (concatenate 'simple-string
 	       (logical-host-name (%pathname-host pathname)) ":"
 	       (unparse-logical-directory pathname)
-	       (unparse-unix-file pathname)))
+	       (unparse-logical-file pathname)))
 
 ;;;; logical pathname translations
 
diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp
index 9b93d33..3d5c721 100644
--- a/tests/pathnames.impure.lisp
+++ b/tests/pathnames.impure.lisp
@@ -264,8 +264,13 @@
 
         ;; FIXME: test version handling in LPNs
         )
-      do (assert (string= (namestring (apply #'merge-pathnames params))
-                          (namestring expected-result))))
+      do (let ((result (apply #'merge-pathnames params)))
+	   (macrolet ((frob (op)
+			`(assert (equal (,op result) (,op expected-result)))))
+	     (frob pathname-host)
+	     (frob pathname-directory)
+	     (frob pathname-name)
+	     (frob pathname-type))))
 
 ;;; host-namestring testing
 (assert (string=
@@ -293,5 +298,21 @@
 (assert (raises-error? (merge-pathnames (make-string-output-stream))
 		       type-error))
 
+;;; ensure read/print consistency (or print-not-readable-error) on
+;;; pathnames:
+(let ((pathnames (list
+		  (make-pathname :name "foo" :type "txt" :version :newest)
+		  (make-pathname :name "foo" :type "txt" :version 1)
+		  (make-pathname :name "foo" :type ".txt")
+		  (make-pathname :name "foo." :type "txt")
+		  (parse-namestring "SCRATCH:FOO.TXT.1")
+		  (parse-namestring "SCRATCH:FOO.TXT.NEWEST")
+		  (parse-namestring "SCRATCH:FOO.TXT"))))
+  (dolist (p pathnames)
+    (handler-case
+	(let ((*print-readably* t))
+	  (assert (equal (read-from-string (format nil "~S" p)) p)))
+      (print-not-readable () nil))))
+
 ;;;; success
 (quit :unix-status 104)
diff --git a/version.lisp-expr b/version.lisp-expr
index 2b76a5d..6a13f9e 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".)
-"0.8.7.23"
+"0.8.7.24"