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

Be more clever about (not) printing upgrade message.

Include stamp propagation test, which provides evidence for the Great Defsystem Bug.
parent 0e3db483
No related branches found
No related tags found
No related merge requests found
...@@ -167,7 +167,7 @@ ...@@ -167,7 +167,7 @@
though there might never be a next release though there might never be a next release
to provide it through <tt>require</tt>. to provide it through <tt>require</tt>.
</p> </p>
<table> <table border="1">
<tr><th></th> <tr><th></th>
<th align="left">Provide ASDF 3</th> <th align="left">Provide ASDF 3</th>
<th align="left">Provide ASDF 2</th> <th align="left">Provide ASDF 2</th>
......
...@@ -15,6 +15,7 @@ Some constraints: ...@@ -15,6 +15,7 @@ Some constraints:
(:export (:export
#:asym #:acall #:asymval #:asym #:acall #:asymval
#:*test-directory* #:*asdf-directory* #:*build-directory* #:*implementation* #:*test-directory* #:*asdf-directory* #:*build-directory* #:*implementation*
#:deftest #:is #:signals
#:assert-compare #:assert-equal #:assert-pathname-equal #:assert-pathnames-equal #:assert-compare #:assert-equal #:assert-pathname-equal #:assert-pathnames-equal
#:hash-table->alist #:hash-table->alist
#:load-asdf #:maybe-compile-asdf #:load-asdf #:maybe-compile-asdf
...@@ -105,8 +106,27 @@ Some constraints: ...@@ -105,8 +106,27 @@ Some constraints:
(redirect-outputs) ;; Put everything on standard output, for the sake of scripts (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) (defun pathname-components (p)
(when p (when p
(let ((p (pathname 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 @@ ...@@ -81,24 +81,6 @@
;;#+allegro (trace excl:run-shell-command sys:reap-os-subprocess) ;;#+allegro (trace excl:run-shell-command sys:reap-os-subprocess)
;;#+lispworks (trace system:run-shell-command system:pid-exit-status) ;;#+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 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 ...@@ -57,8 +57,8 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
(setf *asdf-version* asdf-version) (setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version))) (when (and existing-version (not (equal asdf-version existing-version)))
(push existing-version *previous-asdf-versions*) (push existing-version *previous-asdf-versions*)
(when (or *load-verbose* *verbose-out*) (when (or *verbose-out* *load-verbose*)
(format *trace-output* (format (or *verbose-out* *trace-output*)
(compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
existing-version asdf-version))))) existing-version asdf-version)))))
......
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