Commit 1722af58 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

More test system tweaks.

parent 08635fc3
...@@ -286,7 +286,8 @@ valid_upgrade_test_p () { ...@@ -286,7 +286,8 @@ valid_upgrade_test_p () {
# my old ubuntu clisp 2.44.1 is wired in with an antique ASDF 1.374 from CLC that can't be downgraded. # my old ubuntu clisp 2.44.1 is wired in with an antique ASDF 1.374 from CLC that can't be downgraded.
# 2.00[0-7] use UID, which fails on that CLISP and was removed afterwards. # 2.00[0-7] use UID, which fails on that CLISP and was removed afterwards.
# Note that for the longest time, CLISP has included 2.011 in its distribution. # Note that for the longest time, CLISP has included 2.011 in its distribution.
clisp:2.00[0-7]:*) : ;; # Since we punt on the upgrade, let's only do the test once, for 2.26.
clisp:2.00[0-7]:*|clisp:1.*|clisp:2.0[01]*|clisp:2.2[0-5]:*) : ;;
# Skip, CMUCL has problems before 2.014.7 due to source-registry upgrade # Skip, CMUCL has problems before 2.014.7 due to source-registry upgrade
# Weird unidentified problems before 2.018, so we punt equally for everything before, # Weird unidentified problems before 2.018, so we punt equally for everything before,
# and only need to test it once: above, for 2.017. # and only need to test it once: above, for 2.017.
...@@ -319,7 +320,7 @@ run_upgrade_tests () { ...@@ -319,7 +320,7 @@ run_upgrade_tests () {
echo "or more interactively (and maybe with rlwrap or in emacs), start with:" echo "or more interactively (and maybe with rlwrap or in emacs), start with:"
echo "$cmd" echo "$cmd"
echo "then copy/paste:" echo "then copy/paste:"
echo "(load\"$su\") (da) (test-upgrade $method \"$tag\")" echo "(load\"$su\") (asdf-test::da) (test-upgrade $method \"$tag\")"
exit 1 ;} exit 1 ;}
fi ; done ; done 2>&1 | tee build/results/${lisp}-upgrade.text fi ; done ; done 2>&1 | tee build/results/${lisp}-upgrade.text
} }
......
...@@ -75,7 +75,7 @@ Some constraints: ...@@ -75,7 +75,7 @@ Some constraints:
(namestring (make-pathname :name nil :type nil :defaults path)))))) (namestring (make-pathname :name nil :type nil :defaults path))))))
;;; Survival utilities ;;; Survival utilities
(defun asym (name &optional package (errorp t)) (defun asym (name &optional package errorp)
(let* ((pname (or package :asdf)) (let* ((pname (or package :asdf))
(package (find-package pname))) (package (find-package pname)))
(if package (if package
...@@ -290,7 +290,7 @@ is bound, write a message and exit on an error. If ...@@ -290,7 +290,7 @@ is bound, write a message and exit on an error. If
(acall :print-condition-backtrace (acall :print-condition-backtrace
c :count 69 :stream *error-output*)) c :count 69 :stream *error-output*))
(leave-test "Script failed" 1)))))) (leave-test "Script failed" 1))))))
(funcall (or (asym :call-with-asdf-cache :asdf nil) 'funcall) thunk) (funcall (or (asym :call-with-asdf-cache) 'funcall) thunk)
(leave-test "Script succeeded" 0))))) (leave-test "Script succeeded" 0)))))
(when *quit-when-done* (when *quit-when-done*
(exit-lisp result)))) (exit-lisp result))))
...@@ -453,24 +453,30 @@ is bound, write a message and exit on an error. If ...@@ -453,24 +453,30 @@ is bound, write a message and exit on an error. If
(clean-asdf-system)) (clean-asdf-system))
(defun configure-asdf () (defun configure-asdf ()
(when (asym :getenvp nil nil) (format t "Configuring ASDF~%")
(when (asym :getenvp)
(format t "Enabling debugging~%")
(setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST")))) (setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST"))))
(eval `(trace ,@(loop :for s :in *trace-symbols* :collect (asym s)))) (when *trace-symbols*
(when (asym :initialize-source-registry nil nil) (format t "Tracing~{ ~A~}~%" *trace-symbols*)
(eval `(trace ,@(loop :for s :in *trace-symbols* :collect (asym s)))))
(when (asym :initialize-source-registry)
(acall :initialize-source-registry (acall :initialize-source-registry
`(:source-registry :ignore-inherited-configuration))) `(:source-registry :ignore-inherited-configuration)))
(when (asym :initialize-output-translations nil nil) (when (asym :initialize-output-translations)
(acall :initialize-output-translations (acall :initialize-output-translations
`(:output-translations `(:output-translations
((,*asdf-directory*) ,(output-location "asdf")) ((,(namestring *asdf-directory*)) ,(output-location "asdf"))
(t ,(output-location "root")) (t ,(output-location "root"))
:ignore-inherited-configuration))) :ignore-inherited-configuration)))
(when (asym :*central-registry* nil nil) (when (asym :*central-registry*)
(set (asym :*central-registry*) `(,*test-directory*))) (set (asym :*central-registry*) `(,*test-directory*)))
(format t "Being a bit verbose~%")
(when (asym :*asdf-verbose*) (setf (asymval :*asdf-verbose*) t)) (when (asym :*asdf-verbose*) (setf (asymval :*asdf-verbose*) t))
(when (asym :*verbose-out*) (setf (asymval :*verbose-out*) *standard-output*)) (when (asym :*verbose-out*) (setf (asymval :*verbose-out*) *standard-output*))
(when (asym :system-source-directory nil nil) (when (and (asym :locate-system) (asym :pathname-directory-pathname))
(let ((x (acall :system-source-directory :test-module-depend))) (format t "Comparing directories~%")
(let ((x (acall :pathname-directory-pathname (nth-value 2 (acall :locate-system :test-asdf)))))
(assert-pathname-equal *test-directory* x) ;; not always EQUAL (!) (assert-pathname-equal *test-directory* x) ;; not always EQUAL (!)
(unless (equal *test-directory* x) (unless (equal *test-directory* x)
(format t "Interestingly, while *test-directory* has components~% ~S~%~ (format t "Interestingly, while *test-directory* has components~% ~S~%~
...@@ -531,16 +537,15 @@ is bound, write a message and exit on an error. If ...@@ -531,16 +537,15 @@ is bound, write a message and exit on an error. If
(t (t
(format t "Loading old asdf ~A via ~A~%" tag old-method) (format t "Loading old asdf ~A via ~A~%" tag old-method)
(funcall old-method tag)))) (funcall old-method tag))))
(configure-asdf) (when (find-package :asdf)
(when (asym :*asdf-verbose* nil nil) (setf (asymval :*asdf-verbose*) t)) (configure-asdf))
(when (asym :*verbose-out* nil nil) (setf (asymval :*verbose-out*) *standard-output*))
(format t "Now loading new asdf via method ~A~%" new-method) (format t "Now loading new asdf via method ~A~%" new-method)
(funcall new-method) (funcall new-method)
(format t "Testing it~%") (format t "Testing it~%")
(register-directory *test-directory*) (register-directory *test-directory*)
(load-test-system :test-module-depend) (load-test-system :test-module-depend)
(assert (eval (intern (symbol-name '#:*file1*) :test-package))) (assert (asymval '#:*file1* :test-package))
(assert (eval (intern (symbol-name '#:*file3*) :test-package))))) (assert (asymval '#:*file3* :test-package))))
;; These are shorthands for interactive debugging of test scripts: ;; These are shorthands for interactive debugging of test scripts:
(!a (!a
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment