From a0317bc159295199cd7a4d255a0367b173f54821 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Thu, 9 Apr 2015 03:30:57 -0400
Subject: [PATCH] Remember failures and show them at the end.

---
 .gitignore                  |   1 +
 doc/Makefile                |   9 ++-
 tools/asdf-tools.asd        |  11 +--
 tools/build.lisp            |  31 ++++----
 tools/failure.lisp          | 140 ++++++++++++++++++++++++++++++++++++
 tools/git.lisp              |  32 ++++-----
 tools/install-asdf.lisp     |   2 +-
 tools/main.lisp             |  39 ++++------
 tools/release.lisp          | 106 +++++++++++++--------------
 tools/test-all.lisp         |  80 +++++++++++----------
 tools/test-basic.lisp       |   8 +--
 tools/test-environment.lisp |  40 ++++++-----
 tools/test-scripts.lisp     |  22 ++++--
 tools/test-upgrade.lisp     |  22 +++---
 14 files changed, 339 insertions(+), 204 deletions(-)
 create mode 100644 tools/failure.lisp

diff --git a/.gitignore b/.gitignore
index b17f0de93..024ee67a8 100644
--- a/.gitignore
+++ b/.gitignore
@@ -24,6 +24,7 @@ doc/asdf.vrs
 doc/asdf.t2d/
 doc/asdf.dvi
 doc/version.texinfo
+doc/*.log
 *.tmp
 
 LICENSE
diff --git a/doc/Makefile b/doc/Makefile
index 632804cff..c9c4fce44 100644
--- a/doc/Makefile
+++ b/doc/Makefile
@@ -16,16 +16,19 @@ version.texinfo: ../version.lisp-expr
 	head -n 1 $^ | perl -ne 'm|\"(.*)\"|; print "\@set VERSION $$1\n"' > $@
 
 manual-html: asdf.texinfo version.texinfo
-	makeinfo --html asdf.texinfo
+	makeinfo --html asdf.texinfo \
+	2>&1 > manual-html.log || { echo "failed. See log in manual-html.log" ; exit 1 ;}
 
 asdf.html: asdf.texinfo version.texinfo
-	makeinfo --html --no-split --no-headers -o asdf.html asdf.texinfo
+	makeinfo --html --no-split --no-headers -o asdf.html asdf.texinfo \
+	2>&1 > asdf.html.log || { echo "failed. See log in asdf.html.log" ; exit 1 ;}
 
 asdf.info: asdf.texinfo version.texinfo
 	makeinfo asdf.texinfo
 
 asdf.pdf: asdf.texinfo version.texinfo
-	texi2pdf asdf.texinfo
+	texi2pdf asdf.texinfo \
+	2>&1 > asdf.pdf.log || { echo "failed. See log in asdf.pdf.log" ; exit 1 ;}
 
 website: all
 	rsync -lt --no-g ${webfiles} ${website}
diff --git a/tools/asdf-tools.asd b/tools/asdf-tools.asd
index 0c616db02..661d45709 100644
--- a/tools/asdf-tools.asd
+++ b/tools/asdf-tools.asd
@@ -8,16 +8,17 @@
                (:feature :sbcl "sb-introspect"))
   :components
   ((:file "package")
-   (:file "main" :depends-on ("package"))
+   (:file "failure" :depends-on ("package"))
+   (:file "main" :depends-on ("failure"))
    (:file "pathnames" :depends-on ("package"))
-   (:file "git" :depends-on ("package"))
-   (:file "build" :depends-on ("pathnames"))
-   (:file "version" :depends-on ("pathnames"))
+   (:file "version" :depends-on ("failure"))
    (:file "invoke-lisp" :depends-on ("package"))
    (:file "test-environment" :depends-on ("pathnames" "invoke-lisp" "main"))
+   (:file "build" :depends-on ("test-environment"))
+   (:file "git" :depends-on ("test-environment"))
    (:file "test-basic" :depends-on ("test-environment"))
    (:file "test-scripts" :depends-on ("test-environment"))
    (:file "test-upgrade" :depends-on ("test-environment" "git"))
    (:file "test-all" :depends-on ("test-environment"))
    (:file "installation" :depends-on ("test-environment"))
-   (:file "release" :depends-on ("version" "test-environment"))))
+   (:file "release" :depends-on ("version" "test-environment" "git"))))
diff --git a/tools/build.lisp b/tools/build.lisp
index 48f9780c3..6313b572d 100644
--- a/tools/build.lisp
+++ b/tools/build.lisp
@@ -1,40 +1,37 @@
 (in-package :asdf-tools)
 
-(defun build-asdf ()
+(deftestcmd build-asdf ()
   "make sure asdf.lisp is built"
-  (load-system :asdf)
-  (success))
+  (load-system :asdf))
 
 ;;; Documentation
-(defun doc ()
+(deftestcmd doc ()
   "build documentation in doc/ directory"
-  (run '(make) :directory (pn "doc/"))
-  (success))
+  (with-failure-context ("in doc/ directory")
+    (run* '(make) :directory (pn "doc/"))))
 
-(defun website ()
+(deftestcmd website ()
   "publish documentation onto the public website"
-  (run '(make website) :directory (pn "doc/"))
-  (success))
+  (with-failure-context ("in doc/ directory")
+    (run* '(make website) :directory (pn "doc/"))))
 
 
 ;;; Line counting
-(defun wc ()
+(deftestcmd wc ()
   "count lines of lisp code in asdf and uiop"
   (with-asdf-dir ()
     (flet ((lisp-only (x) (remove "lisp" x :test-not 'equal :key 'pathname-type)))
       (let ((driver-files (mapcar #'(lambda (x) (subpathname "uiop/" x)) (lisp-only (uiop-files))))
             (defsystem-files (lisp-only (asdf-defsystem-files))))
-        (run `(pipe (wc ,@driver-files) (sort -n)))
+        (run* `(pipe (wc ,@driver-files) (sort -n)))
         (terpri)
-        (run `(pipe (wc header.lisp ,@defsystem-files) (sort -n)))
+        (run* `(pipe (wc header.lisp ,@defsystem-files) (sort -n)))
         (terpri)
-        (run `(pipe (wc header.lisp ,@driver-files ,@defsystem-files) (tail -n 1))))))
-  (success))
+        (run* `(pipe (wc header.lisp ,@driver-files ,@defsystem-files) (tail -n 1)))))))
 
 
 ;;; debug the source registry that is being used to execute these tools.
-(defun list-source-registry ()
+(deftestcmd list-source-registry ()
   "Display the source-registry cache"
   (writeln (sort (alexandria:hash-table-alist asdf::*source-registry*)
-                 'string< :key 'car))
-  (success))
+                 'string< :key 'car)))
diff --git a/tools/failure.lisp b/tools/failure.lisp
new file mode 100644
index 000000000..8a69f00ee
--- /dev/null
+++ b/tools/failure.lisp
@@ -0,0 +1,140 @@
+;;;; Useful information when failing.
+(in-package :asdf-tools)
+
+(defvar *fail-fast* nil)
+(defvar *fail-verbose* nil)
+(defvar *execution-context* nil) ;; context for debugging information
+(defvar *failures* nil)
+(defvar *failurep* nil)
+
+;;;(defvar *failure-handler* nil)
+
+(define-condition execution-error (error)
+  ())
+
+(defmethod print-object ((failure execution-error) stream)
+  (if *print-escape*
+      (print-unreadable-object (failure stream :type t :identity nil)
+        (let ((*print-escape* nil))
+          (print-object failure stream)))
+      (princ "FAILED" stream)))
+
+(define-condition execution-failure (execution-error)
+  ((context :initform nil :initarg :context :reader failure-context)
+   (reason :initarg :reason :reader failure-reason)))
+
+(defmethod print-object ((failure execution-failure) stream)
+  (if *print-escape* (call-next-method)
+      (format stream "~@[In ~{~A~^, ~}: ~]~:[FAILED~;~:*~A~]"
+              (reverse (remove nil (failure-context failure)))
+              (failure-reason failure))))
+
+(define-condition execution-failures (execution-error)
+  ((failures :initform nil :initarg :failures :reader failure-list)))
+
+(defmethod print-object ((failures execution-failures) stream)
+  (if *print-escape* (call-next-method)
+      (format stream "Failure~@[~P~:*~{~&~A~&~}~]"
+              (reverse (failure-list failures)))))
+
+(defun make-error (&optional reason &rest arguments)
+  (etypecase reason
+    (error reason)
+    (string (make-condition 'simple-error
+                            :format-control reason :format-arguments arguments))
+    (null (make-failures))
+    (symbol (apply 'make-condition reason arguments))))
+
+(defun fail! (&rest reason-arguments)
+  (error (apply 'make-error reason-arguments)))
+
+(defun success (&rest values)
+  "Return magic values that signal success"
+  (cond
+    ((successp values) (apply 'values values))
+    ((failurep values) (apply 'values values))
+    (t (apply 'values t '#:success values))))
+
+(defun failure (&optional failures)
+  "Return magic values that signal failure"
+  (values nil '#:failure failures))
+
+(defun successp (value-list)
+  (and (length>=n-p value-list 2)
+       (equal (subseq value-list 0 2)
+              (multiple-value-list (success)))))
+
+(defun success-values (value-list)
+  (subseq value-list 2))
+
+(defun failurep (value-list)
+  (and (length>=n-p value-list 2)
+       (equal (subseq value-list 0 2)
+              (subseq (multiple-value-list (failure)) 0 2))))
+
+(defun failure-failures (value-list)
+  (third value-list))
+
+(defun success-if (test &rest failure-args)
+  "If TEST, return success, otherwise, return failure with FAILURE-ARGS"
+  (if test
+      (success)
+      (apply 'fail! (or failure-args '("failed")))))
+
+(defun failure-if (test &rest failure-args)
+  "If not TEST, return success, otherwise, return failure with FAILURE-ARGS"
+  (apply 'success-if (not test) failure-args))
+
+(defun make-failure (&optional reason &rest arguments)
+  (if (typep reason 'execution-error)
+      reason
+      (make-condition 'execution-failure
+                      :context *execution-context*
+                      :reason (apply 'make-error reason arguments))))
+
+(defun make-failures (&optional list)
+  (make-condition 'execution-failures :failures list))
+
+(defmacro with-failure-context ((&optional context) &body body)
+  `(call-with-failure-context (lambda () ,@body) ,context))
+
+(defun register-failures (failure)
+  (let ((failure (make-failure failure)))
+    (etypecase failure
+      (execution-failures
+       (setf *failures* (append (failure-list failure) *failures*)))
+      (execution-failure
+       (push failure *failures*)))
+    failure))
+
+(defun call-with-failure-context (thunk context)
+  (let ((toplevel (null *execution-context*))
+        (*execution-context* (cons context *execution-context*))
+        (fail-fast *fail-fast*)
+        (*fail-fast* t))
+    (labels ((compute ()
+               (block nil
+                 (handler-bind ((error (lambda (c)
+                                         (register-failures c)
+                                         (if (and fail-fast (not toplevel))
+                                             (error (make-failures))
+                                             (return (failure))))))
+                   (funcall thunk))))
+             (doit ()
+               (let ((results (multiple-value-list (compute))))
+                 (if (and toplevel *failures*) (failure (reverse *failures*)) (apply 'success results)))))
+      (if toplevel
+          (let ((*failures* nil)) (doit))
+          (doit)))))
+
+(defmacro without-stopping (() &body body)
+  `(call-without-stopping ,@(mapcar (lambda (form) `(lambda () ,form)) body)))
+
+(defun call-without-stopping (&rest thunks)
+  (let ((failurep nil)
+        (*fail-fast* nil))
+    (dolist (thunk thunks)
+      (when (failurep (multiple-value-list (with-failure-context () (funcall thunk))))
+        (setf failurep t)))
+    (failure-if failurep (make-failures))))
+
diff --git a/tools/git.lisp b/tools/git.lisp
index 3c55892a4..137a1fc77 100644
--- a/tools/git.lisp
+++ b/tools/git.lisp
@@ -4,22 +4,15 @@
 ;; Note that the debian git at git://git.debian.org/git/pkg-common-lisp/cl-asdf.git is stale,
 ;; as we currently build directly from upstream at git://common-lisp.net/projects/asdf/asdf.git
 
-(defun run* (cmd &rest keys)
-  (multiple-value-bind (out err code)
-      (apply 'run cmd keys)
-    (if (eql 0 code)
-        (success)
-        (values nil out err code))))
-
 (defun git (cmd &rest keys)
   (with-asdf-dir ()
-    (apply 'run* (cons "git" cmd) keys)))
+    (apply 'run* `(git ,@cmd) keys)))
 
-(defun clean ()
+(deftestcmd clean ()
   "clean the checkout with git clean -xfd"
   (git '(clean -xfd)))
 
-(defun %push ()
+(deftestcmd %push ()
   "push git branches master and release upstream"
   (dolist (x '((status)
                (push --tags cl.net release master)
@@ -28,7 +21,7 @@
                (status)))
     (git x)))
 
-(defun merge-master-into-release ()
+(deftestcmd merge-master-into-release ()
   "merge git branch master into release"
   (dolist (x '((checkout master)
                (merge release)
@@ -43,17 +36,18 @@
     "RELEASE" "STABLE" ;; These were misguided attempts for what should have been branches
     "README" "emp")) ;; Mistakes
 
-(defun fix-local-git-tags ()
+(deftestcmd fix-local-git-tags ()
   "delete wrongful tags from local git repository"
-  (dolist (tag *wrongful-tags*)
-    (git `(tag -d ,tag) :on-error nil)))
+  (without-stopping ()
+    (dolist (tag *wrongful-tags*)
+      (git `(tag -d ,tag) :on-error nil))))
 
-(defun fix-remote-git-tags (&optional (remote "origin"))
+(deftestcmd fix-remote-git-tags ((remote "origin"))
   "delete wrongful tags from remote git repository"
-  (dolist (tag *wrongful-tags*)
-    (git `(push ,remote (:refs/tags/,tag)) :on-error nil)))
+  (without-stopping ()
+    (dolist (tag *wrongful-tags*)
+      (git `(push ,remote (:refs/tags/,tag)) :on-error nil))))
 
-(defun git-all-committed-p ()
+(deftestcmd git-all-committed-p ()
   "is your checkout clean, with all files committed?"
   (null (nth-value 1 (git '(status -s) :output :lines))))
-
diff --git a/tools/install-asdf.lisp b/tools/install-asdf.lisp
index b07e9a7d5..787509e30 100755
--- a/tools/install-asdf.lisp
+++ b/tools/install-asdf.lisp
@@ -30,7 +30,7 @@ Note that if you're using it with LispWorks (known to only provide ASDF 2
 as of LispWorks 6.1 in 2015), you first have to create a command-line
 executable for LispWorks this way:
 
-       echo '(hcl:save-image "lispworks" :environment nil)' > si.lisp
+       echo '(hcl:save-image "lispworks-console" :environment nil)' > si.lisp
        lispworks-6-1-0-x86-linux -siteinit - -init - -build si.lisp
 |#
 
diff --git a/tools/main.lisp b/tools/main.lisp
index 23e79c7ca..153130389 100644
--- a/tools/main.lisp
+++ b/tools/main.lisp
@@ -1,17 +1,6 @@
 ;;;; Generic code to interface a Lisp script to the shell command-line.
 (in-package :asdf-tools)
 
-(defun success (&optional (success t))
-  "Return magic values that signal success (default), or failure depending on SUCCESS"
-  (if success
-      (values t '#:success)
-      (values nil '#:failure)))
-
-(defun failure ()
-  "Return magic values that signal failure"
-  (success nil))
-
-
 (defun re (arg)
   "Read-Eval function (the RE of REPL)
 (the Print and Loop parts are not here)"
@@ -52,7 +41,7 @@ Unless EARLYP is true, return NIL if the symbol is not fbound."
     git-all-committed-p
     bump-version bump ;; version
     test-load-systems test-clean-load test-basic %load install-asdf ;; test-basic
-    %test %t test-scripts ;; test-scripts
+    test %t test-scripts ;; test-scripts
     test-upgrade u extract-tagged-asdf extract-all-tagged-asdf extract ;; test-upgrade
     test-all-clean-load test-all-scripts test-all-no-upgrade test-all-upgrade ;; test-all
     test-all test-all-scripts-no-stop test-all-upgrade-no-stop
@@ -99,20 +88,18 @@ based on a list of targets"
 ;;; Main entry point.
 ;;; NB: For access control, you could check that only exported symbols are used as entry points.
 (defun process-arguments (args)
-  (block nil
-    (unless args
-      (format t "No command provided~%")
-      (return))
-    (if-let ((fun (find-command (first args))))
-      (let ((results (multiple-value-list (apply fun (rest args)))))
-        ;; Don't print anything on success for regular commands, otherwise print all values returned.
-        (cond
-          ((equal results (multiple-value-list (success))))
-          ((equal results (multiple-value-list (failure))) (format t "~&Command failed.~%"))
-          (t (format t "~&~{~S~%~}" results)))
-        (return (first results))))
-    (format t "Command ~A not found~%" (first args))
-    (return nil)))
+  (if-let ((fun (and args (find-command (first args)))))
+    (let ((results (multiple-value-list (apply fun (rest args)))))
+      ;; Don't print anything on success for regular commands, otherwise print all values returned.
+      (if (failurep results)
+          (format t "~&Failure:~{~& ~A~}~&" (failure-failures results))
+          (format t "~{~&~S~&~}" (if (successp results) (success-values results) results)))
+      (apply 'values results))
+    (progn
+      (if args
+        (format t "Command ~A not found~%" (first args))
+        (format t "No command provided~%"))
+      nil)))
 
 ;;; For a multi-call binary, use these cl-launch or buildapp arguments: --dispatch-entry asdf-tools/asdf-tools::main
 (defun main (argv)
diff --git a/tools/release.lisp b/tools/release.lisp
index 3d954b2bb..99e65b626 100644
--- a/tools/release.lisp
+++ b/tools/release.lisp
@@ -31,39 +31,37 @@
 
 (defun tarname (name) (strcat name ".tar.gz"))
 
-(defun make-tarball-from-git (name base files &key (type "tar.gz"))
+(deftestcmd make-tarball-from-git (name base files (type "tar.gz"))
   (with-asdf-dir (base)
     (let ((tarball (strcat name "." type)))
-      (run `(git archive -o ,(pn "build" tarball)
-                 :prefix (,name /) ,*version* -- ,@files) :show t)))
-  (success))
+      (git `(archive -o ,(pn "build" tarball)
+                     :prefix (,name /) ,*version* -- ,@files) :show t))))
 
-(defun make-tarball-from-git-plus (name base files &key asdf-lisp version-file)
+(deftestcmd make-tarball-from-git-plus (name base files asdf-lisp version-file)
   ;; make a tarball, then add build/asdf.lisp to it
-  (make-tarball-from-git name base files :type "tar")
+  (make-tarball-from-git name base files "tar")
   (let* ((tarball (strcat name ".tar")))
     (with-asdf-dir ("build/")
       (when asdf-lisp
         (build-asdf)
         (ensure-directories-exist (pn "build" name "build/"))
-        (run `(cp -a asdf.lisp (,name /build/)))
+        (run* `(cp -a asdf.lisp (,name /build/)))
         ;; TODO: find which tar it is and tell --uid 0 --gid 0 to BSD tar
         ;; and --owner root --group root to GNU tar,
         ;; falling back to nothing. Sigh.
-        (run `(env "COPYFILE_DISABLE=1"
+        (run* `(env "COPYFILE_DISABLE=1"
                    tar "-rf" ,tarball (,name /build/asdf.lisp)) :show t)
-        (run `(rm -f (,name /build/asdf.lisp)))
+        (run* `(rm -f (,name /build/asdf.lisp)))
         (delete-empty-directory (pn "build" name "build/")))
       (when version-file
         (ensure-directories-exist (pn "build" name ""))
-        (run `(cp -a ../version.lisp-expr (,name /)))
-        (run `(env "COPYFILE_DISABLE=1"
+        (run* `(cp -a ../version.lisp-expr (,name /)))
+        (run* `(env "COPYFILE_DISABLE=1"
                    tar "-rf" ,tarball (,name /version.lisp-expr)) :show t)
-        (run `(rm -f (,name /version.lisp-expr))))
+        (run* `(rm -f (,name /version.lisp-expr))))
       (let ((dir (pn "build" name "")))
         (when (directory-exists-p dir) (delete-empty-directory dir)))
-      (run `(gzip -f9 ,tarball) :show t)))
-  (success))
+      (run* `(gzip -f9 ,tarball) :show t))))
 
 (defun uiop-files ()
   "list files in uiop"
@@ -74,7 +72,7 @@
   (make-tarball-from-git-plus
    (driver-name) "uiop/"
    (remove "version.lisp-expr" (uiop-files) :test 'equal)
-   :version-file t))
+   nil t))
 
 
 (defun asdf-defsystem-files ()
@@ -96,19 +94,17 @@
 (defun asdf-lisp-name ()
   (format nil "asdf-~A.lisp" *version*))
 
-(defun make-asdf-lisp ()
+(deftestcmd make-asdf-lisp ()
   (build-asdf)
   (concatenate-files (list (pn "build/asdf.lisp"))
-                     (pn "build/" (asdf-lisp-name)))
-  (success))
+                     (pn "build/" (asdf-lisp-name))))
 
-(defun make-archive ()
+(deftestcmd make-archive ()
   "build tarballs for release"
   (make-driver-tarball)
   (make-asdf-defsystem-tarball)
   (make-git-tarball)
-  (make-asdf-lisp)
-  (success))
+  (make-asdf-lisp))
 
 
 ;;; Publishing tarballs onto the public repository
@@ -117,32 +113,30 @@
 (defvar *clnet-asdf-public* "/project/asdf/public_html/")
 (defun public-path (x) (strcat *clnet-asdf-public* x))
 
-(defun publish-archive ()
+(deftestcmd publish-archive ()
   "publish tarballs to the website"
   (let ((tarballs (mapcar 'tarname (list (driver-name) (asdf-defsystem-name) (asdf-git-name)))))
-    (run `(rsync "--times" "--chmod=a+rX,ug+w"
-                 ,@tarballs ,(asdf-lisp-name) (,*clnet* ":" ,(public-path "archives/")))
-         :show t :directory (pn "build/")))
+    (run* `(rsync "--times" "--chmod=a+rX,ug+w"
+                  ,@tarballs ,(asdf-lisp-name) (,*clnet* ":" ,(public-path "archives/")))
+          :show t :directory (pn "build/")))
   (format t "~&To download the tarballs, point your browser at:~%
         http://common-lisp.net/project/asdf/archives/
-~%")
-  (success))
+~%"))
 
-(defun link-archive ()
+(deftestcmd link-archive ()
   "symlink new tarballs on the website"
-  (run (format nil "ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S"
-               (tarname (driver-name))
-               (public-path "archives/uiop.tar.gz")
-               (tarname (asdf-defsystem-name))
-               (public-path "archives/asdf-defsystem.tar.gz")
-               (tarname (asdf-git-name))
-               (public-path "archives/asdf.tar.gz")
-               (asdf-lisp-name)
-               (public-path "archives/asdf.lisp"))
-       :show t :host *clnet*)
-  (success))
-
-(defun make-and-publish-archive ()
+  (run* (format nil "ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S"
+                (tarname (driver-name))
+                (public-path "archives/uiop.tar.gz")
+                (tarname (asdf-defsystem-name))
+                (public-path "archives/asdf-defsystem.tar.gz")
+                (tarname (asdf-git-name))
+                (public-path "archives/asdf.tar.gz")
+                (asdf-lisp-name)
+                (public-path "archives/asdf.lisp"))
+        :show t :host *clnet*))
+
+(deftestcmd make-and-publish-archive ()
   "make and publish tarballs"
   (make-archive)
   (publish-archive)
@@ -153,7 +147,7 @@
 
 
 ;;; Making a debian package
-(defun debian-package (&optional (release "release"))
+(deftestcmd debian-package ((release "release"))
   "build a debian package"
   (let* ((debian-version (debian-version-from-file release))
          (version (version-from-file release)))
@@ -161,23 +155,22 @@
       (error "Debian version ~A doesn't match asdf version ~A" debian-version version))
     (clean)
     (format t "building package version ~A~%" (debian-version-from-file))
-    (run `(git-buildpackage
-           ;; --git-ignore-new ;; for testing purpose
-           (--git-debian-branch= ,release)
-           (--git-upstream-tag="%(version)s")
-           ;;--git-upstream-tree=tag ;; if the changelog says 3.1.2, looks at that tag
-           ;;(--git-upstream-branch= ,version) ;; if the changelog says 3.1.2, looks at that tag
-           --git-tag --git-retag
-           ;; --git-no-pristine-tar
-           --git-force-create
-           --git-ignore-branch)
-         :directory (pn) :show t))
-  (success))
+    (run* `(git-buildpackage
+            ;; --git-ignore-new ;; for testing purpose
+            (--git-debian-branch= ,release)
+            (--git-upstream-tag="%(version)s")
+            ;;--git-upstream-tree=tag ;; if the changelog says 3.1.2, looks at that tag
+            ;;(--git-upstream-branch= ,version) ;; if the changelog says 3.1.2, looks at that tag
+            --git-tag --git-retag
+            ;; --git-no-pristine-tar
+            --git-force-create
+            --git-ignore-branch)
+          :directory (pn) :show t)))
 
 (defun debian-architecture ()
   (run/ss `(dpkg --print-architecture)))
 
-(defun publish-debian-package (&optional release)
+(deftestcmd publish-debian-package (release)
   "publish a debian package"
   (let ((changes (strcat "cl-asdf_" (debian-version-without-epoch (debian-version-from-file release))
                          "_" (debian-architecture) ".changes")))
@@ -214,5 +207,4 @@
        (when releasep
          (log! log t "Don't forget to send a debian mentors request!"))
        (log! log "Don't forget to send announcement to asdf-announce, asdf-devel, etc.")
-       (log! log "Don't forget to move all fixed bugs from Fix Committed -> Fix Released on launchpad"))))
-  (success))
+       (log! log "Don't forget to move all fixed bugs from Fix Committed -> Fix Released on launchpad")))))
diff --git a/tools/test-all.lisp b/tools/test-all.lisp
index adbf2ddd3..7e9c68170 100644
--- a/tools/test-all.lisp
+++ b/tools/test-all.lisp
@@ -1,12 +1,16 @@
 (in-package :asdf-tools)
 
-(defun call-with-all-lisps (thunk &optional (lisps *test-lisps*))
-  (apply 'all-pass
-         (loop :for lisp :in (get-lisps lisps)
-               :collect (funcall thunk lisp))))
+(defun call-with-all-lisps (thunk &key (lisps *test-lisps*) (fail-fast t))
+  (let ((thunks
+          (loop :for lisp :in (get-lisps lisps)
+                :collect (lambda () (with-failure-context ((format nil "using ~(~A~)" lisp))
+                                      (funcall thunk lisp))))))
+    (if fail-fast
+        (progn (map () 'funcall thunks) (success))
+        (apply 'call-without-stopping thunks))))
 
-(defmacro with-all-lisps ((&optional (lisp-var 'lisp) (lisps '*test-lisps*)) &body body)
-  `(call-with-all-lisps (lambda (,lisp-var) ,@body) ,lisps))
+(defmacro with-all-lisps ((lisp-var lisps &key (fail-fast t)) &body body)
+  `(call-with-all-lisps (lambda (,lisp-var) ,@body) :lisps ,lisps :fail-fast ,fail-fast))
 
 (deftestcmd test-all-clean-load (lisps)
   "test-clean-load on all lisps"
@@ -18,7 +22,7 @@
 
 (deftestcmd test-all-no-upgrade ()
   "test-basic, and test-all-script"
-  (all-pass (test-basic) (test-all-scripts)))
+  (test-basic) (test-all-scripts))
 
 (deftestcmd test-all-upgrade (upgrade-lisps)
   "test-upgrade on all lisps"
@@ -26,58 +30,56 @@
 
 (deftestcmd test-all ()
   "all tests"
-  (all-pass (test-all-no-upgrade) (test-all-upgrade)))
+  (test-all-no-upgrade) (test-all-upgrade))
 
 (deftestcmd test-all-scripts-no-stop (lisps)
   "test-scripts on all lisps, no stop"
-  (with-all-lisps (l lisps) (ignore-errors (test-scripts l))))
+  (with-all-lisps (l lisps :fail-fast nil) (test-scripts l)))
 
 (deftestcmd test-all-upgrade-no-stop (upgrade-lisps)
   "test-upgrade on all lisps, no stop"
-  (with-all-lisps (l upgrade-lisps) (ignore-errors (test-upgrade l))))
+  (with-all-lisps (l upgrade-lisps :fail-fast nil) (test-upgrade l)))
 
 (deftestcmd test-all-no-upgrade-no-stop ()
   "all tests but upgrade on all lisps, no stop"
-  (all-pass
-   (doc) (test-load-systems)
-   (test-all-clean-load)
-   (test-all-scripts-no-stop)
-   (check-all-scripts-results)))
+  (without-stopping ()
+    (doc) (test-load-systems)
+    (test-all-clean-load)
+    (test-all-scripts-no-stop)
+    (check-all-scripts-results)))
 
 (deftestcmd test-all-no-stop () ;; TODO: pass arguments!
   "all tests on all lisps, no stop"
-  (all-pass
-   (doc) (test-load-systems)
-   (test-all-clean-load)
-   (test-all-scripts-no-stop)
-   (test-all-upgrade-no-stop)
-   (check-all-results)))
+  (without-stopping ()
+    (doc) (test-load-systems)
+    (test-all-clean-load)
+    (test-all-scripts-no-stop)
+    (test-all-upgrade-no-stop)
+    (check-all-results)))
 
 (deftestcmd check-all-scripts-results ()
   "were there errors in test scripts?"
   (with-asdf-dir ()
-    (let ((a (run/lines
-              `(grep "-L" "[5-9][0-9] passing and 0 failing"
-                     ,(mapcar (lambda (l) (format nil "build/results/~(~A~)-test.text" l))
-                              *test-lisps*)))))
-      (if (null a) (success)
-          (progn
-            (format! *error-output* "Unexpected test failures on these implementations:~%~{~A~%~}" a)
-            nil)))))
+    (let ((bad-lisps
+            (run/lines
+             `(grep "-L" "[5-9][0-9] passing and 0 failing"
+                    ,(mapcar (lambda (l) (format nil "build/results/~(~A~)-test.text" l))
+                             *test-lisps*)))))
+    (failure-if bad-lisps
+                "Unexpected test failures on these implementations:~%~{~A~%~}" bad-lisps))))
 
 (deftestcmd check-all-upgrade-results ()
   "were there upgrade test failures?"
   (with-asdf-dir ()
-    (let ((a (run/lines
-              `(grep "-L" "Upgrade test succeeded for "
-                     ,(mapcar (lambda (l) (format nil "build/results/~(~A~)-upgrade.text" l))
-                              *upgrade-test-lisps*)))))
-      (if (null a) (success)
-          (progn
-            (format t "Unexpected upgrade failures on these implementations:~%~{~A~%~}~%" a)
-            nil)))))
+    (let ((bad-lisps
+            (run/lines
+             `(grep "-L" "Upgrade test succeeded for "
+                    ,(mapcar (lambda (l) (format nil "build/results/~(~A~)-upgrade.text" l))
+                             *upgrade-test-lisps*)))))
+      (failure-if bad-lisps
+                  "Unexpected upgrade failures on these implementations:~%~{~A~%~}~%" bad-lisps))))
 
 (deftestcmd check-all-results ()
   "were there failures in any scripts or upgrade?"
-  (all-pass (check-all-scripts-results) (check-all-upgrade-results)))
-
+  (without-stopping ()
+    (check-all-scripts-results) (check-all-upgrade-results)))
diff --git a/tools/test-basic.lisp b/tools/test-basic.lisp
index be7f69791..aece56eb9 100644
--- a/tools/test-basic.lisp
+++ b/tools/test-basic.lisp
@@ -56,7 +56,7 @@ Use your preferred lisp implementation and check that asdf is loaded without any
 
 (deftestcmd test-basic (lisp systems)
   "basic test: doc, clean-load, load-systems"
-  (all-pass
-   (doc)
-   (test-clean-load lisp)
-   (test-load-systems lisp systems)))
+  (without-stopping ()
+    (doc)
+    (test-clean-load lisp)
+    (test-load-systems lisp systems)))
diff --git a/tools/test-environment.lisp b/tools/test-environment.lisp
index ed866f9db..b11bf7a01 100644
--- a/tools/test-environment.lisp
+++ b/tools/test-environment.lisp
@@ -134,11 +134,10 @@
              (return
                `(defun ,name (&optional ,@largs)
                   ,@decl
-                  ,@inits
-                  ,@body)))))
-
-(defun all-pass (&rest tests)
-  (success (every 'identity tests)))
+                  (with-failure-context (,(command-name name))
+                    ,@inits
+                    ,@body
+                    (success))))))) ;; use return-from ,name to return a value.
 
 (defmacro defalias (name real)
   `(defun ,name (&rest args)
@@ -147,7 +146,7 @@
 
 (deftestcmd interactive-command (lisp)
   (let* ((command (lisp-invocation-arglist :implementation-type lisp :debugger t)))
-    (cons "rlwrap" command)))
+    (return-from interactive-command (cons "rlwrap" command))))
 
 (defparameter *default-test-lisps*
   '(:ccl :clisp :sbcl :ecl :ecl_bytecodes :cmucl :abcl :scl :allegro
@@ -181,7 +180,7 @@
        log (add-pathname-suffix log (strcat "-" (date-string date)))))
     (with-output-file (s log) s) ;; create the file
     ;;(format t "Logging results to ~A" log)
-    log))
+    (return-from newlogfile log)))
 
 (defun log! (log fmt &rest args)
   (let ((msg (apply 'format nil fmt args)))
@@ -199,6 +198,13 @@
 ;; While we're at it, we also avoid spaces and backslashes.
 ;; We haven't tested our new Lisp implementation of the test infrastructure on Windows, though.
 
+(defun run* (cmd &rest keys)
+  (let* ((string (strcat "`" (print-process-spec cmd) "`")))
+    (with-failure-context (string)
+      (apply 'run cmd
+             :on-error (lambda (c) (fail! "process failed with code ~A" (subprocess-error-code c)))
+             keys))))
+
 (defun run-test-lisp (activity forms &key (output t) log lisp debugger)
   ;; Activity is of the form "compiling ASDF", "running this test", etc.
   (format t "~&Now ~A...~@[ (log in ~A)~]~%" activity log)
@@ -209,14 +215,16 @@
          (output (if (eq output t) *standard-output* output))
          (output (if (eq output *stdout*) :interactive output)))
     (log! log "~A" (print-process-spec command nil))
-    (multiple-value-bind (okp out err code)
-        (run* `((>& 2 1) ,@(when interactive '(rlwrap)) ,@command
-                ,@(when log `((>> ,log)))) ;; unhappily, | tee -a log eats error codes :-(
-              :input interactive :output output :error-output (or interactive :output) :on-error nil)
-      (unless interactive
-        (log! log (if okp
-                      "SUCCEEDED at ~A."
-                      "FAILED at ~A.
+    (multiple-value-bind (out err code)
+        (run `((>& 2 1) ,@(when interactive '(rlwrap)) ,@command
+               ,@(when log `((>> ,log)))) ;; unhappily, | tee -a log eats error codes :-(
+             :input interactive :output output :error-output (or interactive :output) :on-error nil)
+      (declare (ignore out err))
+      (let ((okp (eql code 0)))
+        (unless interactive
+          (log! log (if okp
+                        "SUCCEEDED at ~A."
+                        "FAILED at ~A.
 You can retry ~A with:
     ~A
 or more interactively, start with:
@@ -227,4 +235,4 @@ then copy/paste:
               (print-process-spec command nil)
               (print-process-spec (interactive-command) nil)
               (compose-copy-paste-string forms)))
-      (if okp (success) (values nil out err code)))))
+        (success-if okp "failed at ~A" activity)))))
diff --git a/tools/test-scripts.lisp b/tools/test-scripts.lisp
index fbbbe4789..ae48132cf 100644
--- a/tools/test-scripts.lisp
+++ b/tools/test-scripts.lisp
@@ -35,6 +35,7 @@ Use the preferred lisp implementation"
    (let* ((log (newlogfile "test" lisp)))
      (log! log "Running the following ~D ASDF test scripts on ~(~A~):~%~{  ~A~%~}"
            (length test-scripts) lisp test-scripts))
+   (without-stopping ())
    (and
     (run-test-lisp
      "compiling ASDF"
@@ -65,7 +66,7 @@ Use the preferred lisp implementation"
               (incf test-fail)
               (push i failed-list)))
      :finally)
-   (let ((okp (zerop test-fail)))
+   (let ((failp (plusp test-fail)))
      (log! log "~
 -#---------------------------------------
 Using ~A
@@ -74,14 +75,23 @@ Ran ~D tests, ~D passed, ~D failed~
 -#---------------------------------------~%"
            lisp
            n-tests test-pass test-fail (reverse failed-list))
-     (unless okp
+     (when failp
        (log! log "To view full results and failures, try the following command:
      less -p ABORTED ~A" (enough-namestring log (pn))))
-     (return (success okp)))))
+     (failure-if failp "~D test~:*~P failed" test-fail))))
 
-(deftestcmd %test (lisp test-scripts)
+(deftestcmd test (lisp test-scripts)
   "run all normal tests but upgrade tests
 Use the preferred lisp implementation"
-  (all-pass (doc) (test-clean-load lisp) (test-scripts lisp test-scripts)))
+  (without-stopping () (doc) (test-clean-load lisp) (test-scripts lisp test-scripts)))
 
-(defalias %t %test)
+;;(defalias %t test)
+
+(deftestcmd %t ()
+  (with-failure-context ("foo")
+    (without-stopping ()
+      (with-failure-context ("1") (error "bar"))
+      (with-failure-context ("2") (error "baz"))
+      (error "frob")
+      (with-failure-context ("3") (error "quux"))
+      (success))))
diff --git a/tools/test-upgrade.lisp b/tools/test-upgrade.lisp
index 989b8d204..e954e31a7 100644
--- a/tools/test-upgrade.lisp
+++ b/tools/test-upgrade.lisp
@@ -140,18 +140,18 @@ Use the preferred lisp implementation"
        (map () 'delete-file (directory* pattern))))
    (loop :for tag :in upgrade-tags :do
      (loop :for method :in upgrade-methods
+           :for description
+             = (format nil "Testing ASDF upgrade on ~(~A~) from ~A to ~A using method ~(~{~A~^:~}~)"
+                       lisp tag *version* method)
            :when (valid-upgrade-test-p lisp tag method) :do
-             (unless (and
-                      (extract-tagged-asdf tag)
-                      (run-test-lisp
-                       (format nil "Testing ASDF upgrade on ~(~A~) from ~A to ~A using method ~(~{~A~^:~}~)"
-                               lisp tag *version* method)
-                       `((load "test/script-support.lisp")
-                         (asdf-test::test-upgrade ,@method ,tag))
-                       :lisp lisp :log log))
-               (return-from test-upgrade nil)))
-    :finally (log! log "Upgrade test succeeded for ~(~A~)" lisp))
-   (return (success))))
+             (failure-if (and
+                          (extract-tagged-asdf tag)
+                          (run-test-lisp description
+                           `((load "test/script-support.lisp")
+                             (asdf-test::test-upgrade ,@method ,tag))
+                           :lisp lisp :log log))
+                         description))
+    :finally (log! log "Upgrade test succeeded for ~(~A~)" lisp))))
 
 (defalias u test-upgrade)
 
-- 
GitLab