From c68bcaf1847f17a7c67887b3e9daae367ac38323 Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Fri, 18 Sep 2009 11:31:23 +0000
Subject: [PATCH] 1.0.31.17: LOGICAL-PATHNAME signals a TYPE-ERROR

 * LOGICAL-PATHNAME is specified to signal a TYPE-ERROR if pathspec is
   incorrect.
---
 NEWS                          |  2 ++
 src/code/target-pathname.lisp | 27 +++++++++++++++++++++------
 tests/pathnames.impure.lisp   |  8 ++++++++
 version.lisp-expr             |  2 +-
 4 files changed, 32 insertions(+), 7 deletions(-)

diff --git a/NEWS b/NEWS
index 7b5d25d6d..919ba5fd9 100644
--- a/NEWS
+++ b/NEWS
@@ -8,6 +8,8 @@ changes relative to sbcl-1.0.31
     in DEFMETHOD forms (reported by Pluijzer)
   * bug fix: DELETE-FILE once again works on logical pathnames (regression
     since 1.0.30.49)
+  * bug fix: LOGICAL-PATHNAME signals a TYPE-ERROR if pathspec is specified
+    incorrectly.
   * bug fix: redefinition of a class via DEFCLASS without :DEFAULT-INITARGS
     removes previous default initargs (reported by Lars Rune Nøstdal and
     Samium Gromoff)
diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index 04c584595..54a3116c9 100644
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -1510,6 +1510,14 @@ system's syntax for files."
 ;;; loaded yet.
 (defvar *logical-pathname-defaults*)
 
+(defun logical-namestring-p (x)
+  (and (stringp x)
+       (ignore-errors
+         (typep (pathname x) 'logical-pathname))))
+
+(deftype logical-namestring ()
+  `(satisfies logical-namestring-p))
+
 (defun logical-pathname (pathspec)
   #!+sb-doc
   "Converts the pathspec argument to a logical-pathname and returns it."
@@ -1517,12 +1525,19 @@ system's syntax for files."
            (values logical-pathname))
   (if (typep pathspec 'logical-pathname)
       pathspec
-      (let ((res (parse-namestring pathspec nil *logical-pathname-defaults*)))
-        (when (eq (%pathname-host res)
-                  (%pathname-host *logical-pathname-defaults*))
-          (error "This logical namestring does not specify a host:~%  ~S"
-                 pathspec))
-        res)))
+      (flet ((oops (problem)
+               (error 'simple-type-error
+                      :datum pathspec
+                      :expected-type 'logical-namestring
+                      :format-control "~S is not a valid logical namestring:~%  ~A"
+                      :format-arguments (list pathspec problem))))
+        (let ((res (handler-case
+                       (parse-namestring pathspec nil *logical-pathname-defaults*)
+                     (error (e) (oops e)))))
+          (when (eq (%pathname-host res)
+                    (%pathname-host *logical-pathname-defaults*))
+            (oops "no host specified"))
+          res))))
 
 ;;;; logical pathname unparsing
 
diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp
index 54ad01a91..e70812f7b 100644
--- a/tests/pathnames.impure.lisp
+++ b/tests/pathnames.impure.lisp
@@ -470,4 +470,12 @@
     (assert (probe-file test))
     (assert (delete-file test))
     (assert (not (probe-file test)))))
+
+(with-test (:name :logical-pathname-type-error)
+  (assert (eq :type-error-ok
+              (handler-case (logical-pathname "FOO.txt")
+                (type-error () :type-error-ok))))
+  (assert (eq :type-error-ok
+              (handler-case (logical-pathname "SYS:%")
+                (type-error () :type-error-ok)))))
 ;;;; success
diff --git a/version.lisp-expr b/version.lisp-expr
index dcabfed49..c9840d535 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.31.16"
+"1.0.31.17"
-- 
2.11.4.GIT