Commit b2a21d0e authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Be more clever about (not) printing upgrade message.

Include stamp propagation test, which provides evidence for the Great Defsystem Bug.
parent 0e3db483
......@@ -167,7 +167,7 @@
though there might never be a next release
to provide it through <tt>require</tt>.
</p>
<table>
<table border="1">
<tr><th></th>
<th align="left">Provide ASDF 3</th>
<th align="left">Provide ASDF 2</th>
......
......@@ -15,6 +15,7 @@ Some constraints:
(:export
#:asym #:acall #:asymval
#:*test-directory* #:*asdf-directory* #:*build-directory* #:*implementation*
#:deftest #:is #:signals
#:assert-compare #:assert-equal #:assert-pathname-equal #:assert-pathnames-equal
#:hash-table->alist
#:load-asdf #:maybe-compile-asdf
......@@ -105,8 +106,27 @@ Some constraints:
(redirect-outputs) ;; Put everything on standard output, for the sake of scripts
;;; Helpful for debugging
;;; Poor man's test suite, lacking stefil.
(defmacro deftest (name formals &body body)
`(defun ,name ,formals ,@body))
(defmacro is (x)
`(progn
(format *error-output* "~&Checking whether ~S~%" ',x)
(finish-output *error-output*)
(assert ,x)))
(defmacro signals (condition sexp)
`(progn
(format *error-output* "~&Checking whether ~S signals ~S~%" ',sexp ',condition)
(finish-output *error-output*)
(handler-case
,sexp
(,condition () t)
(t (c)
(error "Expression ~S raises signal ~S, not ~S" ',sexp c ',condition))
(:no-error ()
(error "Expression ~S fails to raise condition ~S" ',sexp ',condition)))))
;;; Helpful for debugging
(defun pathname-components (p)
(when p
(let ((p (pathname p)))
......
(in-package :asdf-test)
(eval-note :file1)
(in-package :asdf-test)
(eval-note :file2)
;; NB: this file is supposed to work using old defsystems
;; including not just ASDF2, but also legacy defsystems from allegro, genera, lispworks
(unless (find-package :asdf-test)
(load (merge-pathnames
(make-pathname :defaults *load-pathname*
:name "script-support" :directory '(:relative :back))
*load-pathname*)))
(unless (find-package :asdf)
(asdf-test::load-asdf)
(asdf-test::frob-packages))
(in-package :asdf-test)
(DBG :foo)
(defparameter *eval-notes* ())
(defun note-eval (when file)
(format t "~&XXX ~S ~S~%" when file)
(push `(,when ,file #|,*load-pathname* ,*compile-file-pathname*|#) *eval-notes*))
(defun eval-notes ()
(prog1 (reverse *eval-notes*) (setf *eval-notes* nil)))
(defmacro eval-note (&optional x)
`(progn
(eval-when (:compile-toplevel) (note-eval :compile-toplevel ',x))
(eval-when (:load-toplevel) (note-eval :load-toplevel ',x))
(eval-when (:execute) (note-eval :execute ',x))))
(eval-note :tsp)
(defvar *tsp* (asdf::pathname-directory-pathname *load-pathname*))
(defparameter asdf::*asdf-cache* nil) ;; disable any surrounding cache on ASDF3.
#+allegro
(excl:defsystem :test-stamp-propagation
(:default-pathname #.*tsp*)
(:definitions
"file1.lisp"
"file2.lisp"))
#+genera
(sct:defsystem :test-stamp-propagation
(:default-pathname #.*tsp* :patchable nil)
(:definitions
"file1.lisp"
"file2.lisp"))
#+lispworks
(scm:defsystem :test-stamp-propagation
(:default-pathname #.*tsp*)
:members ("file1" "file2")
:rules ((:in-order-to :compile ("file2")
(:caused-by (:compile "file1"))
(:requires (:load "file1")))))
#+asdf
(asdf:defsystem :test-stamp-propagation
:pathname #.*tsp* :source-file nil
:serial t
:components
((:file "file1")
(:file "file2")))
#+mk-defsystem
(mk:defsystem :test-stamp-propagation
(:default-pathname #.*tsp* :patchable nil)
(:serial
"file1.lisp"
"file2.lisp"))
(defvar *default-defsystem* (or #+(or allegro genera lispworks) :native
#+asdf :asdf
#+mk-defsystem :mk-defsystem))
(defun reload (&optional (defsystem *default-defsystem*))
(format t "~&ASDF-CACHE ~S~%" asdf::*asdf-cache*)
(setf *eval-notes* nil)
(setf *compile-verbose* t *load-verbose* t)
(ecase defsystem
#+asdf
(:asdf
(note-eval :compiling :system)
(asdf:compile-system :test-stamp-propagation)
(note-eval :loading :system)
(asdf:load-system :test-stamp-propagation))
#+mk-defsystem
(:mk-defsystem
(note-eval :compiling :system)
(mk:compile-system :test-stamp-propagation)
(note-eval :loading :system)
(mk:load-system :test-stamp-propagation))
(:native
(note-eval :compiling :system)
#+allegro (excl:compile-system :test-stamp-propagation)
#+lispworks (scm:compile-system :test-stamp-propagation)
#+genera (sct:compile-system :test-stamp-propagation)
(note-eval :loading :system)
#+allegro (excl:load-system :test-stamp-propagation)
#+lispworks (scm:load-system :test-stamp-propagation)
#+genera (sct:load-system :test-stamp-propagation)))
(let ((n (eval-notes)))
(format t "~&EVAL-NOTES ~S~%" n)
n))
#-genera
(defun touch-file1.lisp ()
(touch-file (asdf::subpathname *tsp* "file1.lisp")
:in-filesystem t))
#-genera
(defun touch-file1.fasl (&optional (defsystem *default-defsystem*))
(touch-file (funcall
(case defsystem (:asdf 'asdf::compile-file-pathname*) (t 'compile-file-pathname))
(asdf::subpathname *tsp* "file1.lisp"))
:in-filesystem t))
(defun sanitize-log (log)
(remove-duplicates
(remove '(:loading :system) log :test 'equal)
:test 'equal :from-end t))
(defun test-defsystem (&optional (defsystem *default-defsystem*))
(format t "~&Testing stamp propagation by defsystem ~S~%" defsystem)
(DBG "loading system")
(reload defsystem)
(sleep 1)
(DBG "touching first source file and reloading")
(DBG "defsystem should recompile & reload everything")
(touch-file1.lisp)
(assert-equal (sanitize-log (reload defsystem))
'((:compiling :system) (:compile-toplevel :file1) (:load-toplevel :file1)
(:compile-toplevel :file2) (:load-toplevel :file2)))
(sleep 1)
(DBG "touching first fasl file and reloading")
(DBG "defsystem should reload it, recompile & reload the other")
(touch-file1.fasl defsystem)
(assert-equal (sanitize-log (reload defsystem))
'((:compiling :system) (:load-toplevel :file1)
(:compile-toplevel :file2) (:load-toplevel :file2))))
(test-defsystem :asdf)
#+(or genera)
(test-defsystem :native)
#+(or allegro lispworks)
(signals error (test-defsystem :native))
#+mkdefsystem
(signals error (test-defsystem :mk-defsystem))
......@@ -81,24 +81,6 @@
;;#+allegro (trace excl:run-shell-command sys:reap-os-subprocess)
;;#+lispworks (trace system:run-shell-command system:pid-exit-status)
;; Poor man's test suite, lacking stefil.
(defmacro deftest (name formals &body body)
`(defun ,name ,formals ,@body))
(defmacro is (x)
`(progn
(format! *error-output* "~&Checking whether ~S~%" ',x)
(assert ,x)))
(defmacro signals (condition sexp)
`(progn
(format! *error-output* "~&Checking whether ~S signals ~S~%" ',sexp ',condition)
(handler-case
,sexp
(,condition () t)
(t (c)
(error "Expression ~S raises signal ~S, not ~S" ',sexp c ',condition))
(:no-error ()
(error "Expression ~S fails to raise condition ~S" ',sexp ',condition)))))
#|
Testing run-program
|#
......
(load (subpathname *test-directory* "stamp-propagation/test-stamp-propagation.lisp"))
......@@ -57,8 +57,8 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
(setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version)))
(push existing-version *previous-asdf-versions*)
(when (or *load-verbose* *verbose-out*)
(format *trace-output*
(when (or *verbose-out* *load-verbose*)
(format (or *verbose-out* *trace-output*)
(compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
existing-version asdf-version)))))
......
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