From 9c56f356c14d51cfbc7e852c01fbf519b64a36ae Mon Sep 17 00:00:00 2001
From: Sean Whitton <spwhitton@spwhitton.name>
Date: Sat, 5 Jun 2021 16:54:02 -0700
Subject: :SBCL connection: propagate :NO-CHANGE

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
---
 src/connection/fork.lisp | 6 +-----
 src/connection/sbcl.lisp | 8 ++++----
 src/data.lisp            | 8 +++++++-
 src/package.lisp         | 1 +
 src/util.lisp            | 8 ++++++++
 5 files changed, 21 insertions(+), 10 deletions(-)

diff --git a/src/connection/fork.lisp b/src/connection/fork.lisp
index 1d96501..ae25bca 100644
--- a/src/connection/fork.lisp
+++ b/src/connection/fork.lisp
@@ -66,11 +66,7 @@ for example, such that we don't see it."
         (-1
          (error "fork(2) failed"))
         (0
-         (handler-bind ((serious-condition
-                          (lambda (c)
-                            (trivial-backtrace:print-backtrace
-                             c :output *error-output*)
-                            (uiop:quit 2))))
+         (with-backtrace-and-exit-code-two
            ;; Capture child stdout in case *STANDARD-OUTPUT* has been rebound
            ;; to somewhere else in the parent, e.g. by APPLY-AND-PRINT.  The
            ;; parent can then send the contents of the file named by OUTPUT to
diff --git a/src/connection/sbcl.lisp b/src/connection/sbcl.lisp
index 770d408..820f82e 100644
--- a/src/connection/sbcl.lisp
+++ b/src/connection/sbcl.lisp
@@ -46,13 +46,13 @@ recommended."))
     (multiple-value-bind (program forms)
         (continue-deploy*-program remaining requirements)
       (multiple-value-bind (out err exit) (run :may-fail :input program *sbcl*)
-        (inform t (if (zerop exit) "done." "failed.") :fresh-line nil)
+        (inform t (if (< exit 2) "done." "failed.") :fresh-line nil)
         (when-let ((lines (lines out)))
           (inform t "  Output was:" :fresh-line nil)
           (with-indented-inform (inform t lines)))
-        (unless (zerop exit)
+        (unless (< exit 2)
           ;; print FORMS not PROGRAM because latter might contain sudo passwords
           (failed-change
 	   "~&Remote Lisp failed; stderr was:~%~%~A~&~%Program we sent:~%~%~S"
-           err forms)))))
-  nil)
+           err forms))
+        (values nil (if (zerop exit) :no-change nil))))))
diff --git a/src/data.lisp b/src/data.lisp
index eccf283..b0397c5 100644
--- a/src/data.lisp
+++ b/src/data.lisp
@@ -716,7 +716,13 @@ Preprocessing must occur in the root Lisp."))
                          else do (ignore-errors (delete-file (cdr cell)))
                          finally (setq record accum)))
                  ;; Continue the deployment.
-                 ,(wrap `(%consfigure ',remaining-connections ,*host*)))))
+                 ,(wrap
+                   `(with-backtrace-and-exit-code-two
+                      (uiop:quit
+                       (if (eql :no-change
+                                (%consfigure ',remaining-connections ,*host*))
+                           0
+                           1)))))))
         (handler-case
             (with-standard-io-syntax
               (let ((*allow-printing-passphrases* t))
diff --git a/src/package.lisp b/src/package.lisp
index 665cbf5..cf8d06d 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -100,6 +100,7 @@
 
            #:unwind-protect-in-parent
            #:cancel-unwind-protect-in-parent-cleanup
+           #:with-backtrace-and-exit-code-two
 
            ;; connection.lisp
            #:establish-connection
diff --git a/src/util.lisp b/src/util.lisp
index d1bfcab..fb11fec 100644
--- a/src/util.lisp
+++ b/src/util.lisp
@@ -387,6 +387,14 @@ of this macro."
 Should be called soon after fork(2) in child processes."
   (signal 'in-child-process))
 
+(defmacro with-backtrace-and-exit-code-two (&body forms)
+  `(handler-bind
+       ((serious-condition
+          (lambda (c)
+            (trivial-backtrace:print-backtrace c :output *error-output*)
+            (uiop:quit 2))))
+     ,@forms))
+
 
 ;;;; Lisp data files
 
-- 
cgit v1.2.3