Commit 6bcc4baf authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

1.713: Clean some upgrade madness.

Introduce component-operation-time as an interface for POIU to hook on.
declare ignorables, to hush warnings on ECL without alarming Allegro.
Make run-tests return proper result code, fix make test-all.
make test-all => success
parent 93760349
......@@ -7,11 +7,12 @@ clnet_home := "/project/asdf/public_html/"
sourceDirectory := $(shell pwd)
lisps = allegro allegromodern ccl clisp sbcl
lisps ?= allegro ccl clisp ecl lispworks sbcl
## untested by me: abcl allegromodern cmucl
## FAIL: gclcvs
## maybe supported by asdf, never supported by our tests: cormancl mcl scl
ifndef lisp
lisp := sbcl
lisp ?= sbcl
# website, tag, install
......@@ -54,13 +55,11 @@ clean: FORCE
make -C doc clean
test: FORCE
@cd test; make clean;./ $(lisp) $(test-regex)
@cd test; make clean;./ ${lisp} ${test-glob}
test-all: FORCE
@for lisp in $(lisps); do \
make test lisp=$$lisp; \
@for lisp in ${lisps} ; do \
make test lisp=$$lisp || exit 1 ; \
sbcl --userinit /dev/null --sysinit /dev/null --load bin/make-helper.lisp \
--eval "(write-test-web-pages)" --eval "(quit)"
......@@ -63,7 +63,7 @@
(remove "asdf" excl::*autoload-package-name-alist* :test 'equalp :key 'car))
(let* ((asdf-version
;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
(subseq "VERSION:1.712" (1+ (length "VERSION"))))
(subseq "VERSION:1.713" (1+ (length "VERSION"))))
(existing-asdf (find-package :asdf))
(versym '#:*asdf-version*)
(existing-version (and existing-asdf
......@@ -72,8 +72,9 @@
'(#:perform #:explain #:output-files #:operation-done-p
#:perform-with-restarts #:component-relative-pathname
#:system-source-file #:operate)))
(unless (equal asdf-version existing-version)
#:system-source-file #:operate))
(already-there (equal asdf-version existing-version)))
(unless (and existing-asdf already-there)
(when existing-asdf
(format *error-output*
"~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
......@@ -107,6 +108,8 @@
(make-package name :nicknames nicknames :use use)))))
(find-sym (symbol package)
(find-symbol (string symbol) package))
(intern* (symbol package)
(intern (string symbol) package))
(remove-symbol (symbol package)
(let ((sym (find-sym symbol package)))
(when sym
......@@ -128,7 +131,7 @@
:when sym :do (fmakunbound sym)))
(ensure-export (package export)
(let ((syms (loop :for x :in export :collect
(intern (string x) package))))
(intern* x package))))
(do-external-symbols (sym package)
(unless (member sym syms)
(remove-symbol sym package)))
......@@ -174,10 +177,10 @@
:use '(:common-lisp :asdf-utilities)
:unintern `(#-ecl ,@redefined-functions
:unintern `(#-(or gcl ecl) ,@redefined-functions
#:*asdf-revision* #:around #:asdf-method-combination
#:split #:make-collector)
:fmakunbound `(#+ecl ,@redefined-functions
:fmakunbound `(#+(or gcl ecl) ,@redefined-functions
#:component-relative-pathname #:system-relative-pathname
......@@ -275,11 +278,31 @@
(eval `(defparameter ,(intern (string versym) (find-package :asdf))
(let* ((version (intern* versym :asdf))
(upvar (intern* '#:*upgraded-p* :asdf))
(upval0 (and (boundp upvar) (symbol-value upvar)))
(upval1 (if existing-version (cons existing-version upval0) upval0)))
(eval `(progn
(defparameter ,version ,asdf-version)
(defparameter ,upvar ',upval1))))))))
(in-package :asdf)
;; More cleanups in case of hot-upgrade. See
(when *upgraded-p*
(defmethod update-instance-for-redefined-class :after
((c compile-op) added deleted plist &key)
(declare (ignore added deleted))
(let ((system-p (getf plist 'system-p)))
(when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))
'(defmethod update-instance-for-redefined-class :after
((m module) added deleted plist &key)
(declare (ignorable deleted plist))
(when (member 'components-by-name added)
(compute-module-components-by-name m)))))
;;;; -------------------------------------------------------------------------
;;;; User-visible parameters
......@@ -322,6 +345,7 @@ Defaults to `t`.")
(defgeneric explain (operation component))
(defgeneric output-files (operation component))
(defgeneric input-files (operation component))
(defgeneric component-operation-time (operation component))
(defgeneric system-source-file (system)
(:documentation "Return the source file in which system is defined."))
......@@ -851,15 +875,6 @@ actually-existing directory."
:do (setf (gethash name (module-components-by-name module)) c))
;; Cleanup before hot-upgrade. See
(when (find-class 'module nil)
'(defmethod update-instance-for-redefined-class :after
((m module) added deleted plist &key)
(declare (ignore deleted plist))
(when (member 'components-by-name added)
(compute-module-components-by-name m)))))
(defclass module (component)
:initform nil
......@@ -1140,8 +1155,11 @@ to `~a` which is not a directory.~@:>"
(defclass html-file (doc-file)
((type :initform "html")))
(defmethod source-file-type ((component module) (s module)) :directory)
(defmethod source-file-type ((component module) (s module))
(declare (ignorable component s))
(defmethod source-file-type ((component source-file) (s module))
(declare (ignorable s))
(source-file-explicit-type component))
(defun merge-component-name-type (name &key type defaults)
......@@ -1301,12 +1319,17 @@ class specifier, not an operation."
;; original source file, then
(list (component-pathname c)))))
(defmethod input-files ((operation operation) (c module)) nil)
(defmethod input-files ((operation operation) (c module))
(declare (ignorable operation c))
(defmethod component-operation-time (o c)
(gethash (type-of o) (component-operation-times c)))
(defmethod operation-done-p ((o operation) (c component))
(let ((out-files (output-files o c))
(in-files (input-files o c))
(op-time (gethash (type-of o) (component-operation-times c))))
(op-time (component-operation-time o c)))
(flet ((earliest-out ()
(reduce #'min (mapcar #'safe-file-write-date out-files)))
(latest-in ()
......@@ -1569,6 +1592,7 @@ recursive calls to traverse.")
(class-of operation) (class-of c)))
(defmethod perform ((operation operation) (c module))
(declare (ignorable operation c))
(defmethod explain ((operation operation) (component component))
......@@ -1577,14 +1601,6 @@ recursive calls to traverse.")
;;;; -------------------------------------------------------------------------
;;;; compile-op
;; Cleanup before hot-upgrade. See
(when (find-class 'compile-op nil)
(defmethod update-instance-for-redefined-class :after
((c compile-op) added deleted plist &key)
(let ((system-p (getf plist 'system-p)))
(when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))
(defclass compile-op (operation)
((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
(on-warnings :initarg :on-warnings :accessor operation-on-warnings
......@@ -1636,6 +1652,7 @@ recursive calls to traverse.")
(error 'compile-error :component c :operation operation)))))
(defmethod output-files ((operation compile-op) (c cl-source-file))
(declare (ignorable operation))
(let ((p (lispize-pathname (component-pathname c))))
(list #-ecl (compile-file-pathname p)
......@@ -1644,12 +1661,15 @@ recursive calls to traverse.")
#+:broken-fasl-loader (list p)))
(defmethod perform ((operation compile-op) (c static-file))
(declare (ignorable operation c))
(defmethod output-files ((operation compile-op) (c static-file))
(declare (ignorable operation c))
(defmethod input-files ((op compile-op) (c static-file))
(defmethod input-files ((operation compile-op) (c static-file))
(declare (ignorable operation c))
......@@ -1671,6 +1691,7 @@ recursive calls to traverse.")
(perform operation component))
(defmethod perform-with-restarts ((o load-op) (c cl-source-file))
(declare (ignorable o))
(loop :with state = :initial
:until (or (eq state :success)
(eq state :failure)) :do
......@@ -1711,15 +1732,19 @@ recursive calls to traverse.")
(setf state :success))))))
(defmethod perform ((operation load-op) (c static-file))
(declare (ignorable operation c))
(defmethod operation-done-p ((operation load-op) (c static-file))
(declare (ignorable operation c))
(defmethod output-files ((o operation) (c component))
(defmethod output-files ((operation operation) (c component))
(declare (ignorable operation c))
(defmethod component-depends-on ((operation load-op) (c component))
(declare (ignorable operation))
(cons (list 'compile-op (component-name c))
......@@ -1729,19 +1754,23 @@ recursive calls to traverse.")
(defclass load-source-op (basic-load-op) ())
(defmethod perform ((o load-source-op) (c cl-source-file))
(declare (ignorable o))
(let ((source (component-pathname c)))
(setf (component-property c 'last-loaded-as-source)
(and (load source)
(defmethod perform ((operation load-source-op) (c static-file))
(declare (ignorable operation c))
(defmethod output-files ((operation load-source-op) (c component))
(declare (ignorable operation c))
;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right.
(defmethod component-depends-on ((o load-source-op) (c component))
(declare (ignorable o))
(let ((what-would-load-op-do (cdr (assoc 'load-op
(component-in-order-to c)))))
(mapcar (lambda (dep)
......@@ -1751,6 +1780,7 @@ recursive calls to traverse.")
(defmethod operation-done-p ((o load-source-op) (c source-file))
(declare (ignorable o))
(if (or (not (component-property c 'last-loaded-as-source))
(> (safe-file-write-date (component-pathname c))
(component-property c 'last-loaded-as-source)))
......@@ -1763,13 +1793,16 @@ recursive calls to traverse.")
(defclass test-op (operation) ())
(defmethod perform ((operation test-op) (c component))
(declare (ignorable operation c))
(defmethod operation-done-p ((operation test-op) (c system))
"Testing a system is _never_ done."
(declare (ignorable operation c))
(defmethod component-depends-on :around ((o test-op) (c system))
(declare (ignorable o))
(cons `(load-op ,(component-name c)) (call-next-method)))
......@@ -18,18 +18,14 @@
#'(lambda (w)
(princ w *error-output*)
(muffle-warning w))))
(compile-file *asdf-lisp* :output-file tmp))
(compile-file *asdf-lisp* :output-file tmp :print t :verbose t))
(declare (ignore result))
(leave-lisp "Testsuite failed: ASDF compiled with warnings" 1))
(leave-lisp "Testsuite failed: ASDF compiled with ERRORS" 2))
(when warnings-p
(format t "~&ASDF compiled with warnings. Please fix ECL.~%"))
(when (probe-file *asdf-fasl*)
(delete-file *asdf-fasl*))
(rename-file tmp *asdf-fasl*)
......@@ -86,6 +86,7 @@ do_tests() {
echo " $test_pass passing and $test_fail failing" >&2
if [ $test_fail -eq 0 ] ; then
echo "all tests apparently successful" >&2
echo success > ../tmp/results/status
echo "failing test(s): $failed_list" >&2
......@@ -190,8 +191,11 @@ if [ -z "$command" ] ; then
mkdir -p ../tmp/results
echo failure > ../tmp/results/status
thedate=`date "+%Y-%m-%d"`
do_tests "$command" "$eval" 2>&1 | \
tee "../tmp/results/${lisp}.text" "../tmp/results/${lisp}-${thedate}.save"
read a < ../tmp/results/status
[ success = "$a" ] ## exit code
Supports Markdown
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