X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpathnames.impure.lisp;h=c81cb5a221e4eaa02c1c9c8ec017148a93b0f58f;hb=e1905b479292158bd2bacdebb81e27b4da041097;hp=6993c55f1c9620e7052b8257dfc8c172b957f9cd;hpb=85487ad136765c62450eb42a906c085932217cda;p=sbcl.git

diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp
index 6993c55..c81cb5a 100644
--- a/tests/pathnames.impure.lisp
+++ b/tests/pathnames.impure.lisp
@@ -387,5 +387,45 @@
                                            (assert (not (pathname-directory p)))
                                            p))))
 
+;;; reported by Richard Kreuter: PATHNAME and MERGE-PATHNAMES used to
+;;; be unsafely-flushable. Since they are known to return non-nil values
+;;; only, the test-node of the IF is flushed, and since the function
+;;; is unsafely-flushable, out it goes, and bad pathname designators
+;;; breeze through.
+;;;
+;;; These tests rely on using a stream that appears as a file-stream
+;;; but isn't a valid pathname-designator.
+(assert (eq :false
+            (if (ignore-errors (pathname sb-sys::*tty*)) :true :false)))
+(assert (eq :false
+            (if (ignore-errors (merge-pathnames sb-sys::*tty*)) :true :false)))
+
+;;; This used to return "quux/bar.lisp"
+(assert (equal #p"quux/bar.fasl"
+               (let ((*default-pathname-defaults* #p"quux/"))
+                 (compile-file-pathname "foo.lisp" :output-file "bar"))))
+(assert (equal #p"quux/bar.fasl"
+               (let ((*default-pathname-defaults* #p"quux/"))
+                 (compile-file-pathname "bar.lisp"))))
 
+(enough-namestring #p".a*")
+
+
+(assert (eq 99
+            (pathname-version
+             (translate-pathname
+              (make-pathname :name "foo" :type "bar" :version 99)
+              (make-pathname :name :wild :type :wild :version :wild)
+              (make-pathname :name :wild :type :wild :version :wild)))))
+
+(assert (eq 99
+            (pathname-version
+             (translate-pathname
+              (make-pathname :name "foo" :type "bar" :version 99)
+              (make-pathname :name :wild :type :wild :version :wild)
+              (make-pathname :name :wild :type :wild :version nil)))))
+
+;;; enough-namestring relative to root
+(assert (equal "foo" (enough-namestring "/foo" "/")))
+
 ;;;; success