From 679fd396fcdccd3041a13679712250f13b974f9c Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Mon, 15 Mar 2010 19:34:12 -0400
Subject: [PATCH] 1.638: don't use :unspecific for ABCL either. Add janderson's
 pathname test script to our test suite.

---
 asdf.lisp                      |   6 +-
 test/asdf-pathname-test.script | 276 +++++++++++++++++++++++++++++++++
 test/compile-asdf.lisp         |  52 ++++---
 test/run-tests.sh              |  11 +-
 test/script-support.lisp       |   6 +-
 test/wild-module.script        |   1 -
 6 files changed, 320 insertions(+), 32 deletions(-)
 create mode 100644 test/asdf-pathname-test.script

diff --git a/asdf.lisp b/asdf.lisp
index d85f021f..423733e6 100644
--- a/asdf.lisp
+++ b/asdf.lisp
@@ -250,7 +250,7 @@
   ;; This parameter isn't actually user-visible
   ;; -- please use the exported function ASDF:ASDF-VERSION below.
   ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
-  (subseq "VERSION:1.637" (1+ (length "VERSION"))))
+  (subseq "VERSION:1.638" (1+ (length "VERSION"))))
 
 (defun asdf-version ()
   "Exported interface to the version of ASDF currently installed. A string.
@@ -495,7 +495,7 @@ starting the separation from the end, e.g. when called with arguments
           (setf end start))))))
 
 (defun split-name-type (filename)
-  (let ((unspecific #-clisp :unspecific #+clisp nil))
+  (let ((unspecific #-(or clisp armedbear) :unspecific #+(or clisp armedbear) nil))
     (destructuring-bind (name &optional (type unspecific))
         (split-string filename :max 2 :separator ".")
       (if (equal name "")
@@ -1083,7 +1083,7 @@ to `~a` which is not a directory.~@:>"
   ;; NOTE that the host and device slots will be taken from the defaults,
   ;; but that should only matter if you either (a) use absolute pathnames, or
   ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of
-  ;; ASDF:MERGE-PATHNAMES*
+  ;; ASDF-UTILITIES:MERGE-PATHNAMES*
   (etypecase name
     (pathname
      name)
diff --git a/test/asdf-pathname-test.script b/test/asdf-pathname-test.script
new file mode 100644
index 00000000..880bcef7
--- /dev/null
+++ b/test/asdf-pathname-test.script
@@ -0,0 +1,276 @@
+;;; -*- Lisp -*-
+(load "script-support")
+(load-asdf)
+
+;;; test asdf pathname specifications
+;;;
+;;; this is intended to run in a directory like '/test/20100310T000000Z/sbcl', in which it creates a
+;;; test transcript. the tests construct a simple system/module/source-file system definition and
+;;; verify that component pathname specifications refere to lisp source files in the directories
+;;;   '/test/{system1,system2}/'
+;;; any failure is recorded as a transcript entry which indicates
+;;;   ( ( system-pathname module-pathname file-pathname ) missing-pathnames )
+;;; where missing pathnames is a list of the component-pathname values which failed to designate an intended file.
+;;; of there, if the pathname is logical, both the logical and physical pathname appears.
+;;; where NIL appears, the probe-file succeeded.
+;;;
+;;; the test creates the logical host "ASDFTEST" and the system "test-system".
+;;; both are removed at the conclusion.
+;;;
+;;; 20100314:
+;;; (:module "a/b/c.d") => (make-pathname :directory '(:relative "a" "b" "c.d"))
+;;; (:file "a/b/c.d") => (make-pathname :directory '(:relative "a" "b") :name "c.d" :type "lisp"))
+;;; (:static-file "a/b/c.d") => (make-pathname :directory '(:relative "a" "b") :name "c" :type "d"))
+;;; (:module "/a/b/c.d") => (make-pathname :directory '(:absolute "a" "b" "c.d"))
+;;; (:file "/a/b/c.d") => (make-pathname :directory '(:absolute "a" "b") :name "c.d" :type "lisp"))
+;;; (:static-file "/a/b/c.d") => (make-pathname :directory '(:absolute "a" "b") :name "c" :type "d"))
+;;;
+;;; (:file "file2.lisp") means #p"file2.lisp.lisp"
+;;; (:static-file "file2.lisp") means #p"file2.lisp"
+;;; (:file "module1-1/file3.lisp") means #p"module1-1/file3.lisp.lisp" (assuming /)
+;;; (:static-file "module1-1/file3.lisp") means #p"module1-1/file3.lisp"
+
+(defun test-component-pathnames (&key (root (make-pathname :directory (pathname-directory (truename *load-pathname*))))
+                                 (delete-host t)
+                                 (support-string-pathnames nil))
+  (unwind-protect
+    (let* ((bin-type (pathname-type (compile-file-pathname "test.lisp")))
+           (root-directory-namestring (format nil "~{/~a~}/" (rest (pathname-directory root))))
+           (system-count 0)
+           (system-failures 0)
+           (file-count 0)
+           (file-failures 0)
+           (directory-count 0)
+           (directory-failures 0)
+           (*print-pretty* nil)
+           (start-time 0))
+
+      (with-open-file (result-stream "output.txt" :direction :output :if-exists :supersede :if-does-not-exist :create)
+        (flet ((src-dir (&rest path) (append (pathname-directory root) (cons "asdf-src" path)))
+               (bin-dir (&rest path) (append (pathname-directory root) (cons "asdf-bin" path))))
+          (setf (logical-pathname-translations "ASDFTEST")
+                `((,(format nil "**;*.~a" bin-type)
+                   ,(make-pathname :directory (bin-dir :wild-inferiors) :name :wild :type bin-type :version nil))
+                  (,(format nil "**;*.~a.*" bin-type)
+                   ,(make-pathname :directory (bin-dir :wild-inferiors) :name :wild :type bin-type))
+                  ("**;*.*"
+                   ,(make-pathname :directory (src-dir :wild-inferiors) :name :wild :type :wild :version nil))
+                  ("**;*.*.*"
+                   ,(make-pathname :directory (src-dir :wild-inferiors) :name :wild :type :wild))))
+
+          (let ((failures nil)
+                (systems `(,(make-pathname :directory (src-dir "system1") :name nil :type nil)
+                           ,(make-pathname :host "ASDFTEST" :directory '(:absolute "system1"))
+                           ,(parse-namestring "ASDFTEST:system1;")
+                           ,@(when support-string-pathnames
+                               `(,(format nil "~{/~a~}/asdf-src/system1" (rest (pathname-directory root)))))))
+
+                (modules `(nil
+                           ,(make-pathname :directory '(:relative) :name nil :type nil)
+                           ,(make-pathname :directory '(:relative "module2") :name nil :type nil)
+                           ,(make-pathname :directory '(:relative "module2" "module3") :name nil :type nil)
+                           ,(make-pathname :directory (src-dir "system2" "module4") :name nil :type nil)
+                           ,(make-pathname :host "ASDFTEST" :directory '(:absolute "system2" "module4") :name nil :type nil)
+                           ,(parse-namestring "ASDFTEST:system2;module4;")
+                           ,@(when support-string-pathnames
+                               `(""
+                                 "module2"
+                                 "module2/"
+                                 "module2/module3"
+                                 "module2/module3/"
+                                 ,(concatenate 'string root-directory-namestring "asdf-src/system1/module1")
+                                 ,(concatenate 'string root-directory-namestring "asdf-src/system1/module1/")
+                                 ,(concatenate 'string root-directory-namestring "asdf-src/system1/module2/")
+                                 ,(concatenate 'string root-directory-namestring "asdf-src/system1/module2/module3/")
+                                 ,(concatenate 'string root-directory-namestring "asdf-src/system2/module4/")))))
+
+                (files `(nil
+                         ,(make-pathname :directory '(:relative) :name "untyped-file" :type nil)
+                         "file"
+                         ,(make-pathname :directory '(:relative) :name "file" :type "lisp")
+                         "typed-file.type"
+                         ,(make-pathname :directory '(:relative "module2") :name  "untyped-file" :type nil)
+                         ,(make-pathname :directory '(:relative "module2") :name  "file" :type "lisp")
+                         ,(make-pathname :directory '(:relative "module2" "module3") :name  "file" :type "lisp")
+                         ,(make-pathname :directory (src-dir "system1" "module1") :name "untyped-file" :type nil)
+                         ,(make-pathname :directory (src-dir "system1" "module1") :name "file" :type "lisp")
+                         ,(make-pathname :directory (src-dir "system1" "module2") :name "untyped-file" :type nil)
+                         ,(make-pathname :directory (src-dir "system1" "module2") :name "file" :type "lisp")
+                         ,(make-pathname :directory (src-dir "system1" "module2" "module3") :name "file" :type "lisp")
+                         ,(make-pathname :directory (src-dir "system2" "module4") :name "file" :type "lisp")
+                         ,(make-pathname :host "ASDFTEST" :directory '(:absolute "system2" "module4") :name "file" :type "lisp")
+                         ,(parse-namestring "ASDFTEST:system2;module4;file.lisp")
+                         ,@(when support-string-pathnames
+                             `(,(concatenate 'string root-directory-namestring "asdf-src/system1/module1/file.lisp")))))
+                
+                (test-files (remove-duplicates
+                             (sort (loop
+                                     ;; enumerate (system x module x file) pathname variations for relative
+                                     ;; file component names. no additions for the absolute specifications,
+                                     ;; as they should reiterate one of the relative names
+                                     for directory in (list (src-dir "system1")
+                                                            (src-dir "system1" "module1")
+                                                            (src-dir "system1" "module2")
+                                                            (src-dir "system1" "module2" "module3")
+                                                            (src-dir "system2" "module4"))
+                                     ;; :pathname #p"untyped-file"
+                                     collect (make-pathname :directory directory :name "untyped-file" :type nil)
+                                     ;; :file "file"
+                                     collect (make-pathname :directory directory :name "file" :type "lisp")     ; for source files
+                                     collect (make-pathname :directory directory :name "file" :type nil)        ; for static files
+                                     ;; :file "typed-file.type"
+                                     collect (make-pathname :directory directory :name "typed-file.type" :type "lisp")  ; for source files
+                                     collect (make-pathname :directory directory :name "typed-file" :type "type")       ; for static files for :pathname arg
+                                     ;; :static-file "static-file.type"
+                                     collect (make-pathname :directory directory :name "static-file" :type "type")
+                                     ;; :file "module2/file"
+                                     collect (make-pathname :directory directory :name "file" :type "lisp")
+                                     ;; :file "module2/typep-file.type"
+                                     collect (make-pathname :directory directory :name "typed-file.type" :type "lisp")          ; for source files
+                                     collect (make-pathname :directory directory :name "typed-file.type" :type nil)          ; for static files
+                                     ;; :static-file "module2/static-file.type"
+                                     collect (make-pathname :directory directory :name "static-file" :type "type")
+
+                                     ;;; source file pathname variations
+                                     collect (make-pathname :directory (append directory '("module2")) :name  "untyped-file" :type nil)
+                                     collect (make-pathname :directory (append directory '("module2")) :name  "file" :type "lisp")
+                                         collect (make-pathname :directory (append directory '("module2")) :name  "typed-file.type" :type "lisp")
+                                     collect (make-pathname :directory (append directory '("module2")) :name  "static-file" :type "type")
+                                     collect (make-pathname :directory (append directory '("module2" "module3")) :name  "file" :type "lisp")
+                                     collect (make-pathname :directory (append directory '("module2" "module3")) :name  "file" :type "lisp"))
+                                   #'string-lessp
+                                   ;; generate an alternative key in case namestring fails on a name w/ a dot
+                                   :key #'(lambda (p) (format nil "~{~a~^.~}~@[.~a~]~@[.~a~]" (rest (pathname-directory p)) (pathname-name p) (pathname-type p))))
+                             :test #'equalp :from-end t)))
+
+            (dolist (file test-files)
+              (ensure-directories-exist file)
+              (with-open-file (stream file :direction :output :if-exists :supersede :if-does-not-exist :create) stream))
+
+            (multiple-value-bind (second minute hour day month year) (decode-universal-time (setf start-time (get-universal-time)) 0)
+              (let ((header (format nil "~4,'0d~2,'0d~2,'0dT~2,'0d~2,'0d~2,'0dZ : ~a ~a ~a"
+                                    year month day hour minute second
+                                    (lisp-implementation-type)
+                                    (lisp-implementation-version)
+                                    asdf::*asdf-version*)))
+                (format result-stream ";;; ~a~%~%" header)
+                (format *trace-output* "~%;;; ~a~%~%" header)))
+            (sleep 1)
+
+            (dolist (system-pathname systems)
+              (dolist (module-pathname modules)
+                (dolist (file-pathname files)
+                  (let ((configuration (list system-pathname module-pathname file-pathname))
+                        (system-definition `(asdf:defsystem :system1 :pathname ,system-pathname
+                                             :components ((:module :module1 :pathname ,module-pathname
+                                                           :components ((:file "file" :pathname ,file-pathname)
+                                                                        (:file "module2/file" :pathname ,file-pathname)
+                                                                        ,@(unless (or (typep system-pathname 'logical-pathname)
+                                                                                      (typep module-pathname 'logical-pathname))
+                                                                            `((:file "typed-file.type" :pathname ,file-pathname)
+                                                                              (:static-file "static-file.type" :pathname ,file-pathname)
+                                                                              (:file "module2/typed-file.type" :pathname ,file-pathname)
+                                                                              (:static-file "module2/static-file.type" :pathname ,file-pathname)
+                                                                              (:static-file ,(concatenate 'string root-directory-namestring
+                                                                                                          "asdf-src/system1/module1/file.lisp")
+                                                                                            :pathname ,file-pathname)))))))))
+
+                    (block :test-system
+                      (handler-bind
+                        ((error (lambda (c)
+                                  (incf system-failures)
+                                  (format result-stream "~&~%***~%error: ~a~%~:w"
+                                          c system-definition)
+                                  #+sbcl (sb-debug:backtrace 69)
+                                  #+clozure (ccl:print-call-history :count 69 :start-frame-number 1)
+                                  #+clisp (system::print-backtrace)
+                                  (return-from :test-system))))
+                        (unless (and (or (typep system-pathname 'logical-pathname)
+                                         (typep module-pathname 'logical-pathname))
+                                     (and (stringp file-pathname) (find #\. file-pathname)))
+                          (incf system-count)
+                          (let* ((system (eval system-definition))
+                                 (module (first (asdf:module-components system)))
+                                 (file-components (asdf:module-components module)))
+                            (incf file-count (length file-components))
+                            (incf directory-count 2)
+                            (labels ((translate-if-needed (pathname)
+                                       (if (typep pathname 'logical-pathname)
+                                         (cons (translate-logical-pathname pathname) pathname)
+                                         pathname))
+                                     (test-module (module)
+                                       (incf directory-count)
+                                       (unless #-clisp (probe-file (asdf:component-pathname module))
+                                               #+clisp (ext:probe-directory (asdf:component-pathname module))
+                                         (incf directory-failures)
+                                         (push (list (type-of module) (asdf:component-name module)
+                                                     (translate-if-needed (asdf:component-pathname module))
+                                                     configuration
+                                                     (list (when (asdf:component-parent module) (asdf:component-pathname  (asdf:component-parent module)))))
+                                               failures)))
+                                     (test-file (file)
+                                       (incf file-count)
+                                       (unless (ignore-errors
+                                                (with-open-file (stream (asdf:component-pathname file) :direction :output :if-exists :supersede :if-does-not-exist :error)
+                                                  (print start-time stream)))
+                                         (incf file-failures)
+                                         (push (list (type-of file) (asdf:component-name file)
+                                                     (translate-if-needed (asdf:component-pathname file))
+                                                     configuration
+                                                     (list (asdf:component-pathname  (asdf:component-system file))
+                                                           (asdf:component-pathname  (asdf:component-parent file))))
+                                               failures))))
+                              (test-module system)
+                              (test-module module)
+                              (dolist (file file-components) (test-file file)))))))))))
+
+            (format result-stream "~% target files [~s]~:{~% ~s -> ~s~}~%"
+                    (length test-files)
+                    (mapcar #'(lambda (file)
+                                (list file (if (probe-file file)
+                                             (if (> (file-write-date file) start-time)
+                                               :ok
+                                               :untouched)
+                                             :missing)))
+                            test-files))
+
+            (format result-stream "~&~%~% translations: ~a: ~:w" "ASDFTEST" (logical-pathname-translations "ASDFTEST"))
+
+            (format result-stream "~&~%~% variations:~% systems: ~:w~% modules: ~:w~% files: ~:w"
+                    systems modules files)
+
+            (let ((homogeneous-failures 0) (*print-length* nil))
+              (format result-stream "~&~%~% pathname failures [~s]:" (length failures))
+              (dolist (failure failures)
+                (destructuring-bind (type name intended-pathname configuration parent-pathnames) failure
+                  (format result-stream "~&~%~:[ ~;!~]~a~24T~s~%  missing:~24T~s~%  configuration:~24T~s~%  parent pathnames:~24T~s"
+                          (flet ((logical-p (p) (typep p 'logical-pathname)))
+                            (when (or (every #'logical-p configuration) (notany #'logical-p configuration))
+                              (incf homogeneous-failures)))
+                          type name intended-pathname configuration parent-pathnames)))
+              (terpri result-stream)
+              (print (print `(:result :type ,(lisp-implementation-type) :version ,(lisp-implementation-version)
+                                      :file ,(pathname result-stream)
+                                      :system-failures (,system-failures ,system-count)
+                                      :directory-failures (,directory-failures ,directory-count)
+                                      :file-failures (,file-failures ,file-count)
+                                      :homogeneous ,homogeneous-failures)
+                            result-stream)
+                     *trace-output*)
+              (terpri *trace-output*)
+              (force-output *trace-output*)
+              (and (zerop system-failures) (zerop directory-failures)
+                   (zerop file-failures) (zerop homogeneous-failures)))))))
+    (when delete-host
+      (setf (logical-pathname-translations "ASDFTEST") nil))
+    (remhash "test-system" asdf::*defined-systems*)))
+
+#+clisp (trace asdf-utilities:merge-pathnames* make-pathname asdf::merge-component-name-type)
+
+(quit-on-error
+ (or (test-component-pathnames :delete-host t :support-string-pathnames nil)
+     (leave-lisp "test failed" 1)))
+
+;;; (load "LIBRARY:de;setf;utility;asdf;cp-test.lisp")
+;;; (logical-pathname-translations "ASDFTEST")
+;;; (gethash "test-system" asdf::*defined-systems*)
diff --git a/test/compile-asdf.lisp b/test/compile-asdf.lisp
index 8d274d56..0818e32b 100644
--- a/test/compile-asdf.lisp
+++ b/test/compile-asdf.lisp
@@ -2,25 +2,35 @@
 
 (load (make-pathname :name "script-support" :defaults *load-pathname*))
 
-(cond ((probe-file *asdf-lisp*)
-       (ensure-directories-exist *asdf-fasl*)
-       (multiple-value-bind (result warnings-p errors-p)
-           ;; style warnings shouldn't abort the compilation [2010/02/03:rpg]
-           (handler-bind ((style-warning
-                           #'(lambda (w)
-                               (princ w *error-output*)
-                               (muffle-warning w))))
-             (compile-file *asdf-lisp*
-                           :output-file *asdf-fasl*))
-         (declare (ignore result))
-         (cond (warnings-p
+(cond
+  ((not (probe-file *asdf-lisp*))
+   (leave-lisp "Testsuite failed: unable to find ASDF source" 3))
+  ((and (probe-file *asdf-fasl*)
+        (> (file-write-date *asdf-fasl*) (file-write-date *asdf-lisp*)))
+   (leave-lisp "Reusing previously-compiled ASDF" 0))
+  (t
+   (let ((tmp (make-pathname :name "asdf-tmp" :defaults *asdf-fasl*)))
+     (ensure-directories-exist *asdf-fasl*)
+     (multiple-value-bind (result warnings-p errors-p)
+         ;; style warnings shouldn't abort the compilation [2010/02/03:rpg]
+         (handler-bind ((style-warning
+                         #'(lambda (w)
+                             (princ w *error-output*)
+                             (muffle-warning w))))
+           (compile-file *asdf-lisp* :output-file tmp))
+       (declare (ignore result))
+       (cond
+         (warnings-p
                 ;;; ECL gives warnings that it shouldn't!
-                #+ecl (leave-lisp "ASDF compiled with warnings. Please fix ECL." 0)
-                #-ecl
-                (leave-lisp "Testsuite failed: ASDF compiled with warnings" 1))
-               (errors-p
-                (leave-lisp "Testsuite failed: ASDF compiled with ERRORS" 2))
-               (t
-                (leave-lisp "ASDF compiled cleanly" 0)))))
-      (t
-       (leave-lisp "Testsuite failed: unable to find ASDF source" 3)))
+          #+ecl (leave-lisp "ASDF compiled with warnings. Please fix ECL." 0)
+          #-ecl
+          (leave-lisp "Testsuite failed: ASDF compiled with warnings" 1))
+         (errors-p
+          (leave-lisp "Testsuite failed: ASDF compiled with ERRORS" 2))
+         (t
+          #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic
+          (posix:copy-file tmp *asdf-fasl* :method :rename)
+          #-clisp
+          (rename-file tmp *asdf-fasl*
+                       #+clozure :if-exists #+clozure :rename-and-delete)
+          (leave-lisp "ASDF compiled cleanly" 0)))))))
diff --git a/test/run-tests.sh b/test/run-tests.sh
index e1447fc1..f3e4990a 100755
--- a/test/run-tests.sh
+++ b/test/run-tests.sh
@@ -101,7 +101,7 @@ if [ -z $1 ] ; then
     lisp="sbcl"
 fi
 
-command=
+command= flags= nodebug= eval=
 case "$lisp" in
   sbcl)
     command=sbcl
@@ -144,18 +144,17 @@ case "$lisp" in
   gclcvs)
     export GCL_ANSI=t
     command=gclcvs
-    flags="-q"
+    flags="-batch"
     eval="-eval" ;;
+  abcl)
+    command=abcl
+    eval="--eval" ;;
   *)
     echo "Unsupported lisp: $1" >&2
     echo "Please add support to run-tests.sh" >&2
     exit 42 ;;
 esac
 
-if [ -z "$command" ] ; then
-    echo "lisp implementation not recognized: $1" >&2
-    exit 43
-fi
 if ! type "$command" ; then
     echo "lisp implementation not found: $command" >&2
     exit 43
diff --git a/test/script-support.lisp b/test/script-support.lisp
index f030e4c5..6759a67f 100644
--- a/test/script-support.lisp
+++ b/test/script-support.lisp
@@ -23,7 +23,10 @@
 ;; http://www.cliki.net/cl-launch
 (defun leave-lisp (message return)
   (when message
-    (format *error-output* message))
+    (format *error-output* message)
+    (terpri *error-output*))
+  (finish-output *error-output*)
+  (finish-output *standard-output*)
   #+allegro
   (excl:exit return)
   #+clisp
@@ -60,6 +63,7 @@ is bound, write a message and exit on an error.  If
                    (format *error-output* "ABORTING:~% ~S~%" c)
                    #+sbcl (sb-debug:backtrace 69)
                    #+clozure (ccl:print-call-history :count 69 :start-frame-number 1)
+                   #+clisp (system::print-backtrace)
                    (format *error-output* "ABORTING:~% ~S~%" c)
                    (leave-lisp "~&Script failed~%" 1))))))
     (funcall thunk)
diff --git a/test/wild-module.script b/test/wild-module.script
index b2ab96b5..40a3a781 100644
--- a/test/wild-module.script
+++ b/test/wild-module.script
@@ -2,7 +2,6 @@
 (load "script-support")
 (load-asdf)
 (quit-on-error
- (load-asdf)
  (load "../wild-modules")
  (setf asdf:*central-registry* '(*default-pathname-defaults*))
  (asdf:operate 'asdf:load-op 'wild-module))
-- 
GitLab