Skip to content
Snippets Groups Projects
Commit 679fd396 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

1.638: don't use :unspecific for ABCL either.

Add janderson's pathname test script to our test suite.
parent fc24d396
No related branches found
No related tags found
No related merge requests found
......@@ -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)
......
;;; -*- 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*)
......@@ -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)))))))
......@@ -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
......
......@@ -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)
......
......@@ -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))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment