X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpathnames.impure.lisp;h=a46c6e0d225cb6d72fc01ca3c0218378d8b48f38;hb=95f17ca63742f8c164309716b35bc25545a849a6;hp=891c589cc1cd00fa94a78d7f15fcae7b445c9731;hpb=6cb4f9ea3f4e35a5a8e75922833e14575ae92180;p=sbcl.git

diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp
index 891c589..a46c6e0 100644
--- a/tests/pathnames.impure.lisp
+++ b/tests/pathnames.impure.lisp
@@ -369,5 +369,92 @@
                                :name :wild :type nil)))
   (assert (string= (namestring pathname) "SYS:**;*"))
   (assert (string= (write-to-string pathname :readably t) "#P\"SYS:**;*\"")))
+
+;;; reported by James Y Knight on sbcl-devel 2006-05-17
+(let ((p1 (make-pathname :directory '(:relative "bar")))
+      (p2 (make-pathname :directory '(:relative :back "foo"))))
+  (assert (equal (merge-pathnames p1 p2)
+                 (make-pathname :directory '(:relative :back "foo" "bar")))))
+
+;;; construct native namestrings even if the directory is empty (means
+;;; that same as if (:relative))
+(assert (equal (sb-ext:native-namestring (make-pathname :directory '(:relative)
+                                                        :name "foo"
+                                                        :type "txt"))
+               (sb-ext:native-namestring (let ((p (make-pathname :directory nil
+                                                                 :name "foo"
+                                                                 :type "txt")))
+                                           (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" "/")))
+
+;;; Check the handling of NIL, :UNSPECIFIC, the empty string, and
+;;; non-NIL strings in NATIVE-NAMESTRING implementations.  Revised by
+;;; RMK 2007-11-28, attempting to preserve the apparent intended
+;;; denotation of SBCL's then-current pathname implementation.
+(assert (equal
+         (loop with components = (list nil :unspecific "" "a")
+               for name in components
+               appending (loop for type in components
+                               as pathname = (make-pathname
+                                              #+win32 "C"
+                                              :directory '(:absolute "tmp")
+                                              :name name :type type)
+                               collect (ignore-errors
+                                         (sb-ext:native-namestring pathname))))
+         #-win32
+            #|type  NIL       :UNSPECIFIC   ""        "a"         |#
+#|name       |#
+#|NIL        |#   '("/tmp/"   "/tmp/"       NIL       NIL
+#|:UNSPECIFIC|#     "/tmp/"   "/tmp/"       NIL       NIL
+#|""         |#     "/tmp/"   "/tmp/"       "/tmp/."  "/tmp/.a"
+#|"a"        |#     "/tmp/a"  "/tmp/a"      "/tmp/a." "/tmp/a.a")
 
+         #+win32
+            #|type  NIL           :UNSPECIFIC   ""            "a"     |#
+#|name       |#
+#|NIL        |#   '("C:\\tmp\\"   "C:\\tmp\\"   NIL           NIL
+#|:UNSPECIFIC|#     "C:\\tmp\\"   "C:\\tmp\\"   NIL           NIL
+#|""         |#     "C:\\tmp\\"   "C:\\tmp\\"   "C:\\tmp\\."  "C:\\tmp\\.a"
+#|"a"        |#     "C:\\tmp\\a"  "C:\\tmp\\a"  "C:\\tmp\\a." "C:\\tmp\\a.a")))
 ;;;; success