From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Tue, 1 Jun 2004 15:27:23 +0000 (+0000)
Subject: 0.8.10.76:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=e73a30c901ab234291aefc9f1e73507650628892;p=sbcl.git

0.8.10.76:
        Squish bug #330
        ... PARSE-NAMESTRING now accepts any valid pathname designator as
              its defaults argument.
        ... Poke at it with a regression stick.
---

diff --git a/BUGS b/BUGS
index e701579..ad88107 100644
--- a/BUGS
+++ b/BUGS
@@ -1428,13 +1428,6 @@ WORKAROUND:
      in the wrapper, and then to update the instance just run through
      all the old wrappers in order from oldest to newest.
 
-330: "PARSE-NAMESTRING should accept namestrings as the default argument"
-  (parse-namestring "foo" nil "/") 
-  debugger invoked on a TYPE-ERROR in thread 3138:
-    The value "/" is not of type PATHNAME.
-  According to the PARSE-NAMESTRING dictionary entry the
-  default-pathname parameter can be any pathname designator.
-
 331: "lazy creation of CLOS classes for user-defined conditions"
     (defstruct foo)
     (defstruct (bar (:include foo)))
diff --git a/NEWS b/NEWS
index 369e216..8bebd46 100644
--- a/NEWS
+++ b/NEWS
@@ -2415,6 +2415,8 @@ changes in sbcl-0.8.11 relative to sbcl-0.8.10:
     beginnings of a semantically meaningful condition hierarchy is
     under development, for use in SB-EXT:MUFFLE-CONDITIONS and by
     IDEs.
+  * fixed bug: PARSE-NAMESTRING now accepts any valid pathaname
+    designator as the defaults argument.
   * fixed bug: Displaced arrays whose displaced-to array has become
     too small now cause ARRAY-DIMENSION to signal an error, providing
     for safer bounds-checking. (reported by Bruno Haible)
diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index 5210a0f..86d1f21 100644
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -716,9 +716,8 @@ a host-structure or string."
 			 host
 			 (defaults *default-pathname-defaults*)
 			 &key (start 0) end junk-allowed)
-  (declare (type pathname-designator thing)
+  (declare (type pathname-designator thing defaults)
 	   (type (or list host string (member :unspecific)) host)
-	   (type pathname defaults)
 	   (type index start)
 	   (type (or index null) end)
 	   (type (or t null) junk-allowed)
@@ -775,8 +774,18 @@ a host-structure or string."
                               supported in this implementation:~%  ~S"
 			      host))
 		      (host
-		       host))))
-    (declare (type (or null host) found-host))
+		       host)))
+	;; According to ANSI defaults may be any valid pathname designator
+	(defaults (etypecase defaults
+		    (pathname   
+		     defaults)
+		    (string
+		     (aver (pathnamep *default-pathname-defaults*))
+		     (parse-namestring defaults))
+		    (stream
+		     (truename defaults)))))
+    (declare (type (or null host) found-host)
+	     (type pathname defaults))
     (etypecase thing
       (simple-string
        (%parse-namestring thing found-host defaults start end junk-allowed))
diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp
index 3d5c721..a58c08e 100644
--- a/tests/pathnames.impure.lisp
+++ b/tests/pathnames.impure.lisp
@@ -314,5 +314,22 @@
 	  (assert (equal (read-from-string (format nil "~S" p)) p)))
       (print-not-readable () nil))))
 
+;;; BUG 330: "PARSE-NAMESTRING should accept namestrings as the default argument"
+;;; ...and streams as well
+(assert (equal (parse-namestring "foo" nil "/")
+	       (parse-namestring "foo" nil #P"/")))
+(let ((test "parse-namestring-test.tmp"))
+  (unwind-protect
+       (with-open-file (f test :direction :output)
+	 ;; FIXME: This test is a bit flaky, since we only check that
+	 ;; no error is signalled. The dilemma here is "what is the
+	 ;; correct result when defaults is a _file_, not a
+	 ;; directory". Currently (0.8.10.73) we get #P"foo" here (as
+	 ;; opposed to eg. #P"/path/to/current/foo"), which is
+	 ;; possibly mildly surprising but probably conformant.
+	 (assert (parse-namestring "foo" nil f)))
+    (when (probe-file test)
+      (delete-file test))))
+
 ;;;; success
 (quit :unix-status 104)
diff --git a/version.lisp-expr b/version.lisp-expr
index 9ddd599..0b23868 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.10.75"
+"0.8.10.76"