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

ASDF 1.602: pass more tests.

* made it easier to debug tests. export DEBUG_ASDF_TEST=t
* add ECL support to tests: passes all 18 scripts, but have to ignore compile warnings.
* lots of whitespace issues, including ones that made .gitignore not work!
parent b575ccb3
No related branches found
Tags 1.602
No related merge requests found
Showing
with 124 additions and 93 deletions
......@@ -12,7 +12,6 @@ test/conf.d/
test/dir1/
test/dir2/
# We build these at various stages in the make process
LICENSE
website/output/
......@@ -21,9 +20,9 @@ tmp/
lift-local.config
*.dribble
*.fasl
*.dfsl
*.cfsl
*.fas
*.dfsl
*.cfsl
*.fas
*.lib
*.o
*.*fsl
......
......@@ -63,7 +63,7 @@
(let ((sym (find-symbol "*ASDF-REVISION*" asdf)))
(when sym
(unexport sym asdf)
(unintern sym))))))
(unintern sym asdf))))))
#+ecl (require 'cmp)
......@@ -187,7 +187,7 @@
;;;;
(defparameter *asdf-version*
;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
(subseq "VERSION:1.601" (1+ (length "VERSION"))))
(subseq "VERSION:1.602" (1+ (length "VERSION"))))
(defun asdf-version ()
*asdf-version*)
......@@ -679,7 +679,7 @@ and NIL NAME and TYPE components" ;;; what about VERSION???
(defun component-parent-pathname (component)
(aif (component-parent component)
(component-pathname it)
*default-pathname-defaults*))
(truename *default-pathname-defaults*)))
(defmethod component-relative-pathname ((component module))
(or (slot-value component 'relative-pathname)
......@@ -690,8 +690,8 @@ and NIL NAME and TYPE components" ;;; what about VERSION???
:host (pathname-host (component-parent-pathname component))))))
(defmethod component-pathname ((component component))
(let ((*default-pathname-defaults* (component-parent-pathname component)))
(merge-pathnames (component-relative-pathname component))))
(merge-pathnames (component-relative-pathname component)
(component-parent-pathname component)))
(defmethod component-property ((c component) property)
(cdr (assoc property (slot-value c 'properties) :test #'equal)))
......@@ -932,6 +932,7 @@ to `~a` which is not a directory.~@:>"
;;; a component with no parent is a system
(defmethod find-component ((module (eql nil)) name &optional version)
(declare (ignorable module))
(let ((m (find-system name nil)))
(if (and m (version-satisfies m version)) m)))
......@@ -988,7 +989,7 @@ to `~a` which is not a directory.~@:>"
(defmethod shared-initialize :after ((operation operation) slot-names
&key force
&allow-other-keys)
(declare (ignore slot-names force))
(declare (ignorable operation slot-names force))
;; empty method to disable initarg validity checking
)
......@@ -2188,8 +2189,8 @@ with a different configuration, so the configuration would be re-read then."
(defmethod process-output-translations ((x null) &key
(inherit *default-output-translations*)
collect)
(declare (ignorable x))
(inherit-output-translations inherit :collect collect))
(defmethod process-output-translations ((form cons) &key
(inherit *default-output-translations*)
collect)
......@@ -2505,8 +2506,8 @@ with a different configuration, so the configuration would be re-read then."
(defmethod process-source-registry ((x null) &key
(inherit *default-source-registries*)
collect)
(declare (ignorable x))
(inherit-source-registry inherit :collect collect))
(defmethod process-source-registry ((form cons) &key
(inherit *default-source-registries*)
collect)
......
......@@ -12,11 +12,11 @@
(compile-file "asdf.lisp"))
(declare (ignore result))
(cond (warnings-p
(leave-lisp "Testuite failed: ASDF compiled with warnings" 1))
#-ecl ;;; ECL gives warnings that it shouldn't!
(leave-lisp "Testsuite failed: ASDF compiled with warnings" 1))
(errors-p
(leave-lisp "Testuite failed: ASDF compiled with ERRORS" 2))
(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)))
......@@ -15,7 +15,7 @@ http://ilc2009.scheming.org/
(already-compiled :initarg :already-compiled :reader test-already-compiled)
(expected :initarg :expected :reader test-expected)))
(defmacro define-test (test-name system-name
(defmacro define-test (test-name system-name
&key operation-name already-compiled expected)
`(progn
(push ',test-name *all-tests*)
......@@ -34,7 +34,7 @@ http://ilc2009.scheming.org/
(defmethod asdf:operation-done-p ((o asdf:compile-op) (c test-file))
(declare (ignorable o))
(member (asdf:component-name c) (test-already-compiled *test*)
(member (asdf:component-name c) (test-already-compiled *test*)
:test #'string=))
(defmethod asdf:operation-done-p ((o asdf:operation) (c test-file))
......@@ -70,7 +70,7 @@ http://ilc2009.scheming.org/
(first steps) *steps*)))
;(format t "~2%STEPS: ~S~3%" *steps*)
(dolist (expectation (test-expected *test*))
(destructuring-bind (op file &rest at)
(destructuring-bind (op file &rest at)
expectation
;(format t "~2%Expectation: ~S~3%" expectation)
(check-type file string)
......@@ -81,8 +81,8 @@ http://ilc2009.scheming.org/
(fail "~S was not ~A" file op)
(loop for (relationship file2) on at by #'cddr do
(check-type file2 string)
(let* ((op2 (ecase relationship
(:after-loading :loaded)
(let* ((op2 (ecase relationship
(:after-loading :loaded)
(:after-compiling :compiled)))
(pos2 (position (cons op2 file2) *steps*
:test #'equal)))
......@@ -92,7 +92,7 @@ http://ilc2009.scheming.org/
((< pos pos2)
(fail "Wrong order between ~A of ~S and ~A of ~S"
op file op2 file2))))))))
(:did-not-compile
(:did-not-compile
(when (member (cons :compiled file) *steps*)
(fail "~A compiled but should not have" file)))
(:did-not-load
......@@ -147,7 +147,7 @@ http://ilc2009.scheming.org/
:operation-name asdf:load-op
:already-compiled ()
:expected ((:compiled "a" :after-compiling "g" :after-compiling "k"
:after-compiling "h" :after-loading "g"
:after-compiling "h" :after-loading "g"
:after-loading "k" :after-loading "h")
(:loaded "a" :after-compiling "a")
(:compiled "b")
......@@ -213,7 +213,7 @@ http://ilc2009.scheming.org/
(asdf:defsystem system-5
:components ((:test-file "a")
(:test-file "b" :depends-on ("a")
:in-order-to ((asdf:compile-op
:in-order-to ((asdf:compile-op
(asdf:load-op "a"))))))
(define-test test-5 system-5
......
;;; -*- Lisp -*-
(load "script-support")
(load "../asdf")
(exit-on-error
(exit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(in-package :asdf)
(setf asdf::*load-preference-files* t)
......
;;; -*- Lisp -*-
(in-package #:common-lisp)
(defpackage #:test-preferences-1-asdf-system
(defpackage #:test-preferences-1-asdf-system
(:use #:common-lisp #:asdf))
(in-package #:asdf)
......@@ -10,23 +10,23 @@
((:file "test-preferences-1"))
:in-order-to ((test-op (load-op test-preferences-system-1))))
(defmethod operation-done-p
(defmethod operation-done-p
((o test-op)
(c (eql (find-system 'test-preferences-system-1))))
(values nil))
(defmethod load-preferences
((system (eql (find-system 'test-preferences-system-1)))
((system (eql (find-system 'test-preferences-system-1)))
(operation test-op))
;; the default load-preferences does nothing for anything other than a
;; the default load-preferences does nothing for anything other than a
;; basic-load-op. So, ... we hack it
(load (make-pathname
:name "test-preferences-system-test"
:type "lisp"
:defaults *default-pathname-defaults*)))
(defmethod preference-file-for-system/operation
((system (eql (find-system 'test-preferences-system-1)))
(defmethod preference-file-for-system/operation
((system (eql (find-system 'test-preferences-system-1)))
(operation load-op))
(make-pathname
:name "test-preferences-system-load"
......
......@@ -9,11 +9,11 @@
(exit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(defmethod asdf:preference-file-for-system/operation
(defmethod asdf:preference-file-for-system/operation
((system (eql (asdf:find-system 'test1))) operation)
(merge-pathnames (make-pathname :name "test1" :type "preferences")))
(merge-pathnames (make-pathname :name "test1" :type "preferences")))
(asdf:operate 'asdf:load-op 'test1)
(assert (null *test6*)))
......@@ -9,12 +9,12 @@
(exit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(defmethod asdf:preference-file-for-system/operation
(defmethod asdf:preference-file-for-system/operation
((system (eql (asdf:find-system 'test1))) operation)
(merge-pathnames (make-pathname :name "test1" :type "preferences")))
(merge-pathnames (make-pathname :name "test1" :type "preferences")))
(setf asdf::*load-preference-files* t)
(asdf:operate 'asdf:load-op 'test1)
(assert (eq *test6* :yes)))
......@@ -5,7 +5,7 @@
(let ((*system-definition-search-functions*
'(sysdef-central-registry-search))
(*central-registry* (list "/tmp/ok-1/" "/tmp/bad" "/tmp/ok-2/")))
(handler-bind
(handler-bind
((error (lambda (c)
(when (find-restart 'remove-entry-from-registry)
(invoke-restart 'remove-entry-from-registry)))))
......@@ -19,7 +19,7 @@
(let ((*system-definition-search-functions*
'(sysdef-central-registry-search))
(*central-registry* (list "/tmp/ok-1/" "/tmp/bad" "/tmp/ok-2/")))
(handler-bind
(handler-bind
((error (lambda (c)
(when (find-restart 'coerce-entry-to-directory)
(invoke-restart 'coerce-entry-to-directory)))))
......
......@@ -26,9 +26,11 @@ fi
sok=1
do_tests() {
rm -f *.$2 || true
( cd .. && echo '(load "test/compile-asdf.lisp")' | $1 )
if [ $? -eq 0 ] ; then
command=$1 eval=$2 fasl_ext=$3
rm -f *.$fasl_ext ~/.cache/common-lisp/"`pwd`"/*.$fasl_ext || true
( cd .. && $command $eval '(load "test/compile-asdf.lisp")' )
if [ $? -eq 0 ] ; then
echo "Compiled OK"
test_count=0
test_pass=0
test_fail=0
......@@ -37,12 +39,12 @@ if [ $? -eq 0 ] ; then
do
echo "Testing: $i" >&2
test_count=`expr "$test_count" + 1`
rm -f *.$2 || true
if $1 < $i ; then
echo "Using $1, $i passed" >&2
rm -f *.$fasl_ext ~/.cache/common-lisp/"`pwd`"/*.$fasl_ext || true
if $command $eval "(load \"$i\")" ; then
echo "Using $command, $i passed" >&2
test_pass=`expr "$test_pass" + 1`
else
echo "Using $1, $i failed" >&2
echo "Using $command, $i failed" >&2
test_fail=`expr "$test_fail" + 1`
failed_list="$failed_list $i"
sok=0
......@@ -50,7 +52,7 @@ if [ $? -eq 0 ] ; then
done
echo >&2
echo "-#---------------------------------------" >&2
echo "Using $1" >&2
echo "Using $command" >&2
echo "Ran $test_count tests: " >&2
echo " $test_pass passing and $test_fail failing" >&2
if [ $test_fail -eq 0 ] ; then
......@@ -60,7 +62,7 @@ if [ $? -eq 0 ] ; then
fi
echo "-#---------------------------------------" >&2
echo >&2
fi
fi
}
# terminate on error
......@@ -75,23 +77,31 @@ case "$lisp" in
sbcl)
if type sbcl ; then
fasl_ext="fasl"
command="sbcl --userinit /dev/null --sysinit /dev/null --noinform --noprogrammer"
command="sbcl --noinform --userinit /dev/null --sysinit /dev/null"
nodebug="--disable-debugger"
eval="--eval"
fi ;;
clisp)
if type clisp ; then
fasl_ext="fas"
command=`which clisp`
command="$command -norc -ansi -I - "
command="$command -norc -ansi -I "
nodebug="-on-error exit"
eval="-x"
fi ;;
allegro)
if type alisp ; then
fasl_ext="fasl"
command="alisp -q -batch "
command="alisp -q "
nodebug="-batch"
eval="-eval"
fi ;;
allegromodern)
if type mlisp ; then
fasl_ext="fasl"
command="mlisp -q -batch "
command="mlisp -q"
nodebug="-batch"
eval="-eval"
fi ;;
ccl)
if type ccl ; then
......@@ -104,15 +114,30 @@ case "$lisp" in
i?86|ppc) fasl_bits=32 ;;
esac
fasl_ext="${fasl_os}${fasl_bits}fsl"
command="ccl --no-init --quiet --batch "
command="ccl --no-init --quiet"
nodebug="--batch"
eval="--eval"
fi ;;
cmucl)
if type lisp ; then
fasl_ext="x86f"
command="lisp -batch -noinit"
command="lisp -noinit"
nodebug="-batch"
eval="-eval"
fi ;;
ecl)
if type ecl ; then
fasl_ext="fas"
command=`which ecl`
command="$command -norc"
eval="-eval"
fi ;;
esac
if [ -z "${DEBUG_ASDF_TEST}" ] ; then
command="$command $nodebug"
fi
create_asds () {
mkdir -p {conf.d,dir1,dir2/{dir3,dir4}}
for i in dir1 dir2; do touch "$i"/test.asd; done
......@@ -131,6 +156,7 @@ else
mkdir -p results
echo $command
thedate=`date "+%Y-%m-%d"`
do_tests "$command" $fasl_ext 2>&1 | tee "results/${lisp}.text" "results/${lisp}-${thedate}.save"
do_tests "$command" "$eval" "$fasl_ext" 2>&1 | \
tee "results/${lisp}.text" "results/${lisp}-${thedate}.save"
clean_up
fi
......@@ -28,9 +28,14 @@
(error "Don't know how to quit Lisp; wanting to use exit code ~a" return))
(defmacro quit-on-error (&body body)
`(handler-case
(progn ,@body
`(call-quitting-on-error (lambda () ,@body)))
(defun call-quitting-on-error (thunk)
(handler-case
(progn (funcall thunk)
(leave-lisp "~&Script succeeded~%" 0))
(error (c)
(format *error-output* "~a" c)
(leave-lisp "~&Script failed~%" 1))))
(if (ignore-errors (funcall (find-symbol "GETENV" :asdf) "DEBUG_ASDF_TEST"))
(break)
(leave-lisp "~&Script failed~%" 1)))))
#|
make sure that serial t and static-files don't cause full rebuilds all
make sure that serial t and static-files don't cause full rebuilds all
the time...
|#
......
......@@ -2,7 +2,7 @@
(load "script-support")
(load "../asdf")
(quit-on-error
(quit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(asdf:load-system 'test-module-pathnames)
(flet ((submodule (module name)
......@@ -23,7 +23,7 @@
(pathname-foo (asdf:component-relative-pathname static))
'((:relative "level2") "static" "file"))
nil
"Didn't get the name of static.file right")))
"Didn't get the name of static.file right")))
(assert (find-package :test-package) nil
"package test-package not found")
(assert (find-symbol (symbol-name '*file-tmp*) :test-package) nil
......@@ -32,8 +32,8 @@
nil "symbol `*file-tmp*` has wrong value")
#| ; must be adapted to ABL
(assert (probe-file (merge-pathnames
(make-pathname
(assert (probe-file (merge-pathnames
(make-pathname
:name "file1"
:type (pathname-type (compile-file-pathname "x"))
:directory '(:relative "sources" "level1"))))
......@@ -47,8 +47,8 @@
#| ; must be adapted to ABL
(assert (probe-file (merge-pathnames
(make-pathname
(assert (probe-file (merge-pathnames
(make-pathname
:name "file2"
:type (pathname-type (compile-file-pathname "x"))
:directory '(:relative "sources" "level1" "level2"))))
......
......@@ -28,28 +28,28 @@
(in-package #:test-nested-components.system)
(defsystem test-nested-components-a
:components
:components
((:module "nested-components"
:pathname ""
:components ((:file "test-nested-1")))))
(defsystem test-nested-components-b
:pathname ""
:components
:components
((:file "test-nested-1")))
(defsystem db-agraph-preflight
:components
:components
((:module "preflight-checks"
:components ((:file "preflight")))))
(defsystem db-agraph-preflight-2
:pathname "preflight-checks"
:components
:components
((:file "preflight")))
#|
newer traverse always fails
older traverse fails when db-agraph-preflight is evaluated, ok
when loaded or compiled
|#
\ No newline at end of file
older traverse fails when db-agraph-preflight is evaluated, ok
when loaded or compiled
|#
......@@ -6,10 +6,10 @@
(load "../asdf")
(in-package #:common-lisp-user)
(quit-on-error
(quit-on-error
(setf asdf:*central-registry* nil)
(load (merge-pathnames "test-nested-components-1.asd"))
(print
(print
(list
:a
(asdf::traverse (make-instance 'asdf:compile-op)
......@@ -28,7 +28,7 @@
(asdf:oos 'asdf:compile-op 'test-nested-components-a)
(asdf:oos 'asdf:compile-op 'test-nested-components-b)
(print
(print
(list
(asdf::traverse (make-instance 'asdf:load-op)
(asdf:find-system 'test-nested-components-a))
......@@ -56,7 +56,7 @@
. #<ASDF:MODULE "preflight-checks" {11B799A9}>)
(#<ASDF:LOAD-OP NIL {11D04FE9}>
. #<ASDF:SYSTEM "test-nested-components-a" {11AEDD59}>))
((#<ASDF:COMPILE-OP NIL {11E4D9B1}>
. #<ASDF:CL-SOURCE-FILE "preflight" {11C94B89}>)
(#<ASDF:COMPILE-OP NIL {11E4D9B1}>
......@@ -65,4 +65,4 @@
. #<ASDF:CL-SOURCE-FILE "preflight" {11C94B89}>)
(#<ASDF:LOAD-OP NIL {11E4A911}>
. #<ASDF:SYSTEM "test-nested-components-b" {11C92819}>)))
|#
\ No newline at end of file
|#
(in-package :cl-user)
;;; -*- Lisp -*-
(in-package :cl-user)
(load "script-support")
(load "../asdf")
(quit-on-error
(defun module () 1)
(load "test-package.asd")
(defclass module () ())
(load "test-package.asd")
)
(load "test-package.asd"))
......@@ -9,25 +9,30 @@
;#+allegro
;(trace excl.osi:command-output)
(defvar *caught-error* nil)
(quit-on-error
(quit-on-error
(format t "trlc1 1~%")
(when (probe-file "try-reloading-dependency.asd")
(asdf:run-shell-command "rm -f ~A"
(namestring "try-reloading-dependency.asd")))
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(setf asdf::*defined-systems* (asdf::make-defined-systems-table))
(handler-bind ((error (lambda (c)
(format t "trlc1 2~%")
(handler-bind ((error (lambda (c)
(format t "~&Caught error ~s" c)
(setf *caught-error* t)
(asdf:run-shell-command
"cp try-reloading-dependency.hidden try-reloading-dependency.asd")
(format t "trlc1 5~%")
(multiple-value-bind (name mode)
(find-symbol (symbol-name 'retry) :asdf)
(assert (eq mode :external) nil "Mode of ~s was not external" name)
(format t "trlc1 6~%")
(let ((restart (find-restart name c)))
(format t "trlc1 7~%")
(assert restart)
(format t "~&restart: ~S~&" restart)
(when restart (invoke-restart restart)))))))
(format t "trlc1 3~%")
(asdf:oos 'asdf:load-op 'try-reloading-1))
(assert *caught-error*)
)
(format t "trlc1 4~%")
(assert *caught-error*))
......@@ -12,7 +12,7 @@
(merge-pathnames path defaults))
(defun ensure-recursive-directory (path)
(concatenate
(concatenate
'string
(namestring
(ensure-directory-pathname path))
......
......@@ -5,7 +5,7 @@
(load "script-support")
(load "../asdf")
(quit-on-error
(quit-on-error
(flet ((system-load-time (name)
(let ((data (asdf::system-registered-p name)))
(when data
......
......@@ -5,7 +5,7 @@
(load "script-support")
(load "../asdf")
(quit-on-error
(quit-on-error
(flet ((system-load-time (name)
(let ((data (asdf::system-registered-p name)))
(when data
......
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