From a0889b188cadcbb5c5fde6807662ea299e6c134d Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Sat, 17 Nov 2007 16:34:00 +0000
Subject: [PATCH] 1.0.11.25: don't leave incomplete fasls around after
 compilation

* CLHS says the first return value of COMPILE-FILE is
  NIL if "file could not be created" -- interpret this
  to mean "fasl could not be created" and don't count
  incomplete fasls as fasls.
---
 NEWS                   |  2 ++
 src/compiler/main.lisp | 35 +++++++++++++++++++----------------
 tests/compiler.test.sh |  8 +++++++-
 tests/expect.sh        | 19 +++++++++++++++++++
 version.lisp-expr      |  2 +-
 5 files changed, 48 insertions(+), 18 deletions(-)

diff --git a/NEWS b/NEWS
index 2d649b169..371216d98 100644
--- a/NEWS
+++ b/NEWS
@@ -5,6 +5,8 @@ changes in sbcl-1.0.12 relative to sbcl-1.0.11:
     concurrent accesses (but not iteration.) See also:
     SB-EXT:WITH-LOCKED-HASH-TABLE, and
     SB-EXT:HASH-TABLE-SYNCHRONIZED-P.
+  * bug fix: if file compilation is aborted, the partial fasl is now
+    deleted, and COMPILE-FILE returns NIL as the primary value.
   * bug fix: number of thread safety issues relating to SBCL's internal
     hash-table usage have been fixed.
   * bug fix: SB-SYS:WITH-PINNED-OBJECTS could cause garbage values to
diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index f99f24eda..7b671c479 100644
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -1482,7 +1482,7 @@
               (invoke-restart it))))))))
 
 ;;; Read all forms from INFO and compile them, with output to OBJECT.
-;;; Return (VALUES NIL WARNINGS-P FAILURE-P).
+;;; Return (VALUES ABORT-P WARNINGS-P FAILURE-P).
 (defun sub-compile-file (info)
   (declare (type source-info info))
   (let ((*package* (sane-package))
@@ -1503,7 +1503,7 @@
         (*compiler-error-bailout*
          (lambda ()
            (compiler-mumble "~2&; fatal error, aborting compilation~%")
-           (return-from sub-compile-file (values nil t t))))
+           (return-from sub-compile-file (values t t t))))
         (*current-path* nil)
         (*last-source-context* nil)
         (*last-original-source* nil)
@@ -1557,7 +1557,7 @@
                  "~@<compilation aborted because of fatal error: ~2I~_~A~:>"
                  condition))
        (finish-output *error-output*)
-       (values nil t t)))))
+       (values t t t)))))
 
 ;;; Return a pathname for the named file. The file must exist.
 (defun verify-source-file (pathname-designator)
@@ -1666,7 +1666,7 @@ SPEED and COMPILATION-SPEED optimization values, and the
 |#
   (let* ((fasl-output nil)
          (output-file-name nil)
-         (compile-won nil)
+         (abort-p nil)
          (warnings-p nil)
          (failure-p t) ; T in case error keeps this from being set later
          (input-pathname (verify-source-file input-file))
@@ -1697,31 +1697,34 @@ SPEED and COMPILATION-SPEED optimization values, and the
 
           (when sb!xc:*compile-verbose*
             (print-compile-start-note source-info))
-          (let ((*compile-object* fasl-output)
-                dummy)
-            (multiple-value-setq (dummy warnings-p failure-p)
-              (sub-compile-file source-info)))
-          (setq compile-won t))
+
+          (let ((*compile-object* fasl-output))
+            (setf (values abort-p warnings-p failure-p)
+                  (sub-compile-file source-info))))
 
       (close-source-info source-info)
 
       (when fasl-output
-        (close-fasl-output fasl-output (not compile-won))
+        (close-fasl-output fasl-output abort-p)
         (setq output-file-name
               (pathname (fasl-output-stream fasl-output)))
-        (when (and compile-won sb!xc:*compile-verbose*)
+        (when (and (not abort-p) sb!xc:*compile-verbose*)
           (compiler-mumble "~2&; ~A written~%" (namestring output-file-name))))
 
       (when sb!xc:*compile-verbose*
-        (print-compile-end-note source-info compile-won))
+        (print-compile-end-note source-info (not abort-p)))
 
       (when *compiler-trace-output*
         (close *compiler-trace-output*)))
 
-    (values (if output-file
-                ;; Hack around filesystem race condition...
-                (or (probe-file output-file-name) output-file-name)
-                nil)
+    ;; CLHS says that the first value is NIL if the "file could not
+    ;; be created". We interpret this to mean "a valid fasl could not
+    ;; be created" -- which can happen if the compilation is aborted
+    ;; before the whole file has been processed, due to eg. a reader
+    ;; error.
+    (values (when (and (not abort-p) output-file)
+              ;; Hack around filesystem race condition...
+              (or (probe-file output-file-name) output-file-name))
             warnings-p
             failure-p)))
 
diff --git a/tests/compiler.test.sh b/tests/compiler.test.sh
index 5b891d29c..ce1566f57 100644
--- a/tests/compiler.test.sh
+++ b/tests/compiler.test.sh
@@ -372,8 +372,14 @@ cat > $tmpfilename <<EOF
 EOF
 expect_clean_compile $tmpfilename
 
+cat > $tmpfilename <<EOF
+(defun something (x) x)
+...
+(defun something-more (x) x)
+EOF
+expect_aborted_compile $tmpfilename
+
 rm $tmpfilename
-rm $compiled_tmpfilename
 
 # success
 exit 104
diff --git a/tests/expect.sh b/tests/expect.sh
index 49e848933..9976e298e 100644
--- a/tests/expect.sh
+++ b/tests/expect.sh
@@ -83,6 +83,25 @@ EOF
     fi
 }
 
+expect_aborted_compile ()
+{
+    $SBCL <<EOF
+        (let* ((lisp "$1")
+               (fasl (compile-file-pathname lisp)))
+          (multiple-value-bind (pathname warnings-p failure-p)
+              (compile-file "$1" :print t)
+            (assert (not pathname))
+            (assert failure-p)
+            (assert warnings-p)
+            (assert (not (probe-file fasl))))
+          (sb-ext:quit :unix-status 52))
+EOF
+    if [ $? != 52 ]; then
+        echo abort-compile $1 test failed: $?
+        exit 1
+    fi
+}
+
 fail_on_compiler_note ()
 {
     $SBCL <<EOF
diff --git a/version.lisp-expr b/version.lisp-expr
index 98d52c7ae..5a0cae677 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.11.24"
+"1.0.11.25"
-- 
2.11.4.GIT