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

Fix test infrastructure, fix test scripts. Pass again on CCL.

parent 2f60807e
No related branches found
No related tags found
No related merge requests found
...@@ -6,13 +6,13 @@ ...@@ -6,13 +6,13 @@
# - quit with exit status >0 if an unhandled error occurs # - quit with exit status >0 if an unhandled error occurs
export CL_SOURCE_REGISTRY="$PWD" export CL_SOURCE_REGISTRY="$PWD"
export DEBUG_ASDF_TEST= unset DEBUG_ASDF_TEST
while getopts "duh" OPTION while getopts "duh" OPTION
do do
case $OPTION in case $OPTION in
d) d)
DEBUG_ASDF_TEST=1 export DEBUG_ASDF_TEST=t
;; ;;
u) u)
usage usage
......
...@@ -34,11 +34,11 @@ ...@@ -34,11 +34,11 @@
"Unless the environment variable DEBUG_ASDF_TEST "Unless the environment variable DEBUG_ASDF_TEST
is bound, write a message and exit on an error. If is bound, write a message and exit on an error. If
*asdf-test-debug* is true, enter the debugger." *asdf-test-debug* is true, enter the debugger."
(handler-case (handler-bind
(progn (funcall thunk) ((error (lambda (c)
(leave-lisp "~&Script succeeded~%" 0)) (format *error-output* "~a" c)
(error (c) (if (ignore-errors (funcall (find-symbol "GETENV" :asdf) "DEBUG_ASDF_TEST"))
(format *error-output* "~a" c) (break)
(if (ignore-errors (funcall (find-symbol "GETENV" :asdf) "DEBUG_ASDF_TEST")) (leave-lisp "~&Script failed~%" 1)))))
(break) (funcall thunk)
(leave-lisp "~&Script failed~%" 1))))) (leave-lisp "~&Script succeeded~%" 0)))
;;; -*- Lisp -*- ;;; -*- Lisp -*-
(load "script-support") (load "script-support")
(load (compile-file-pathname "../asdf")) (load (compile-file-pathname "../asdf"))
(quit-on-error (quit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*)) (setf asdf:*central-registry* '(*default-pathname-defaults*))
(asdf:operate 'asdf:load-op 'test-force) (asdf:operate 'asdf:load-op 'test-force)
(defvar file1-date (file-write-date (asdf:compile-file-pathname* "file1")))
;; unforced, date should stay same (let* ((file1 (asdf:compile-file-pathname* (truename "file1.lisp")))
(sleep 1) (file1-date (file-write-date file1)))
(asdf:operate 'asdf:load-op 'test-force)
(assert (= (file-write-date (asdf:compile-file-pathname* "file1")) file1-date)) (assert file1)
(assert file1-date)
;; unforced, date should stay same
(sleep 1)
(asdf:operate 'asdf:load-op 'test-force)
(assert (equal (file-write-date file1) file1-date))
;; forced, it should be later ;; forced, it should be later
(sleep 1) (sleep 1)
(asdf:operate 'asdf:load-op 'test-force :force t) (asdf:operate 'asdf:load-op 'test-force :force t)
(assert (> (file-write-date (asdf:compile-file-pathname* "file1")) file1-date))) (assert (> (file-write-date file1) file1-date))))
...@@ -5,12 +5,11 @@ ...@@ -5,12 +5,11 @@
(setf asdf:*central-registry* '(*default-pathname-defaults*)) (setf asdf:*central-registry* '(*default-pathname-defaults*))
(asdf:operate 'asdf:load-op 'static-and-serial) (asdf:operate 'asdf:load-op 'static-and-serial)
(defvar file1-date (file-write-date (asdf:compile-file-pathname* "file1"))) (let* ((file1 (asdf:compile-file-pathname* (truename "file1.lisp")))
(file1-date (file-write-date file1))
(asdf::*defined-systems* (make-hash-table :test 'equal))) ;; cheat
;; cheat ;; date should stay same
(setf asdf::*defined-systems* (make-hash-table :test 'equal)) (sleep 1)
(asdf:operate 'asdf:load-op 'static-and-serial)
;; date should stay same (assert (= (file-write-date file1) file1-date))))
(sleep 1)
(asdf:operate 'asdf:load-op 'static-and-serial)
(assert (= (file-write-date (asdf:compile-file-pathname* "file1")) file1-date)))
...@@ -7,30 +7,33 @@ ...@@ -7,30 +7,33 @@
(asdf:operate 'asdf:load-op 'test1) (asdf:operate 'asdf:load-op 'test1)
;; test that it compiled ;; test that it compiled
(defvar file1-date (file-write-date (asdf:compile-file-pathname* "file1"))) (let* ((file1 (asdf:compile-file-pathname* (truename "file1.lisp")))
(file2 (asdf:compile-file-pathname* (truename "file2.lisp")))
(file1-date (file-write-date file1)))
(assert (and file1-date (file-write-date (asdf:compile-file-pathname* "file2")))) (format t "~&test1 1: ~S ~S~%" file1 file1-date)
(assert file1-date)
(assert (file-write-date file2))
;; and loaded ;; and loaded
(assert (eval (intern (symbol-name '#:*file1*) :test-package))) (assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package)))
;; now remove one output file and check that the other is _not_ ;; now remove one output file and check that the other is _not_
;; recompiled ;; recompiled
(sleep 1) ; mtime has 1-second granularity, so pause here for fast machines (sleep 1) ; mtime has 1-second granularity, so pause here for fast machines
(asdf::run-shell-command "rm -f ~A" (asdf::run-shell-command "rm -f ~A" (namestring file2))
(namestring (asdf:compile-file-pathname* "file2"))) (asdf:operate 'asdf:load-op 'test1)
(asdf:operate 'asdf:load-op 'test1) (assert (= file1-date (file-write-date file1)))
(assert (= file1-date (file-write-date (asdf:compile-file-pathname* "file1")))) (assert (file-write-date file2))
(assert (file-write-date (asdf:compile-file-pathname* "file2")))
;; now touch file1 and check that file2 _is_ also recompiled ;; now touch file1 and check that file2 _is_ also recompiled
;; XXX run-shell-command loses if *default-pathname-defaults* is not the ;; XXX run-shell-command loses if *default-pathname-defaults* is not the
;; unix cwd. this is not a problem for run-tests.sh, but can be in general ;; unix cwd. this is not a problem for run-tests.sh, but can be in general
(let ((before (file-write-date (asdf:compile-file-pathname* "file2")))) (let ((before (file-write-date file2)))
(asdf::run-shell-command "touch file1.lisp") (asdf::run-shell-command "touch file1.lisp")
(sleep 1) (sleep 1)
(asdf:operate 'asdf:load-op 'test1) (asdf:operate 'asdf:load-op 'test1)
(assert (> (file-write-date (asdf:compile-file-pathname* "file2")) before)))) (assert (> (file-write-date file2) before)))))
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