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