[Sbcl-commits] CVS: sbcl/src/code target-pathname.lisp,1.62,1.63

[Nikodemus S. <de...@us...>]

Update of /cvsroot/sbcl/sbcl/src/code
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv6435/src/code

Modified Files:
	target-pathname.lisp 
Log Message:
1.0.31.17: LOGICAL-PATHNAME signals a TYPE-ERROR

 * LOGICAL-PATHNAME is specified to signal a TYPE-ERROR if pathspec is
   incorrect.


Index: target-pathname.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-pathname.lisp,v
retrieving revision 1.62
retrieving revision 1.63
diff -u -d -r1.62 -r1.63
--- target-pathname.lisp	20 May 2009 13:51:53 -0000	1.62
+++ target-pathname.lisp	18 Sep 2009 11:31:24 -0000	1.63
@@ -1510,6 +1510,14 @@
 ;;; 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 @@
            (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