From 840f5a3fa4c9142fd0d63dea8e8b76bce49aaf67 Mon Sep 17 00:00:00 2001
From: "Tobias C. Rittweiler" <trittweiler@users.sourceforge.net>
Date: Wed, 16 Dec 2009 09:58:54 +0000
Subject: [PATCH] 1.0.33.13: Catch errors during compile-time-too processing.

  * Errors signaled within an (EVAL-WHEN (:COMPILE-TOPLEVEL) ...),
    i.e. during ``compile-time-too' processing, are now caught and
    reported just like errors at macroexpansion time.

    Previously, we landed in the debugger from within the compiler and
    thus provided pretty much no information about the actual source
    context to the user.

    Now, we won't land in the debugger, and the appropriate source
    context is reported along the error.

  * Some slight generalization in the test suite.

  * So we can add tests for errors in EVAL-WHEN and during
    macroexpansion.
---
 NEWS                   |    2 ++
 src/compiler/main.lisp |    5 ++++-
 tests/compiler.test.sh |   22 +++++++++++++++++-----
 tests/expect.sh        |   22 +++++++++++-----------
 version.lisp-expr      |    2 +-
 5 files changed, 35 insertions(+), 18 deletions(-)

diff --git a/NEWS b/NEWS
index 3d11b7d..bb01da4 100644
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,8 @@
 changes relative to sbcl-1.0.33:
   * enhancement: SB-INTROSPECT:DEFTYPE-LAMBDA-LIST now also works on most
     builtin types.
+  * enhancement: Errors during compile-time-too processing (i.e. EVAL-WHEN)
+    are now caught and reported just like errors during macroexpansion.
   * bug fix: #p"\\\\" can now be read without error on Win32.  (reported by
     Willem Broekema; launchpad bug lp#489698).
   * bug fix: some minor code rearrangements to reenable warning-free building
diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index df17921..49078b9 100644
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -1206,7 +1206,10 @@
 ;;; compilation. Normally just evaluate in the appropriate
 ;;; environment, but also compile if outputting a CFASL.
 (defun eval-compile-toplevel (body path)
-  (eval-in-lexenv `(progn ,@body) *lexenv*)
+  (handler-case (eval-in-lexenv `(progn ,@body) *lexenv*)
+    (error (condition)
+      (compiler-error "(during compile-time-too processing)~%~A"
+                      condition)))
   (when *compile-toplevel-object*
     (let ((*compile-object* *compile-toplevel-object*))
       (convert-and-maybe-compile `(progn ,@body) path))))
diff --git a/tests/compiler.test.sh b/tests/compiler.test.sh
index 57a37a4..bac5690 100644
--- a/tests/compiler.test.sh
+++ b/tests/compiler.test.sh
@@ -156,7 +156,7 @@ cat > $tmpfilename <<EOF
     (defun foo (x)
       (error x))
 EOF
-fail_on_compiler_note $tmpfilename
+fail_on_condition_during_compile sb-ext:compiler-note $tmpfilename
 
 # test case from Rudi for some CLOS WARNINGness that shouldn't have
 # been there
@@ -213,7 +213,7 @@ cat > $tmpfilename <<EOF
       (declare (muffle-conditions code-deletion-note))
       (if t (foo) (foo)))
 EOF
-fail_on_compiler_note $tmpfilename
+fail_on_condition_during_compile sb-ext:compiler-note $tmpfilename
 
 cat > $tmpfilename <<EOF
     (defun foo (x y)
@@ -221,7 +221,7 @@ cat > $tmpfilename <<EOF
       (declare (optimize speed))
       (+ x y))
 EOF
-fail_on_compiler_note $tmpfilename
+fail_on_condition_during_compile sb-ext:compiler-note $tmpfilename
 
 cat > $tmpfilename <<EOF
     (declaim (muffle-conditions compiler-note))
@@ -229,7 +229,7 @@ cat > $tmpfilename <<EOF
       (declare (optimize speed))
       (+ x y))
 EOF
-fail_on_compiler_note $tmpfilename
+fail_on_condition_during_compile sb-ext:compiler-note $tmpfilename
 
 cat > $tmpfilename <<EOF
     (declaim (muffle-conditions compiler-note))
@@ -238,7 +238,7 @@ cat > $tmpfilename <<EOF
       (declare (optimize speed))
       (+ x y))
 EOF
-expect_compiler_note $tmpfilename
+expect_condition_during_compile sb-ext:compiler-note $tmpfilename
 
 # undefined variable causes a WARNING
 cat > $tmpfilename <<EOF
@@ -441,5 +441,17 @@ cat > $tmpfilename <<EOF
 EOF
 expect_clean_cload $tmpfilename
 
+cat > $tmpfilename <<EOF
+(in-package :cl-user)
+(defmacro foo () (error "ERROR at macroexpansion time."))
+(defun bar () (foo))
+EOF
+expect_condition_during_compile sb-c:compiler-error $tmpfilename
+
+cat > $tmpfilename <<EOF
+(eval-when (:compile-toplevel)
+  (error "ERROR within EVAL-WHEN."))
+EOF
+expect_condition_during_compile sb-c:compiler-error $tmpfilename
 # success
 exit $EXIT_TEST_WIN
diff --git a/tests/expect.sh b/tests/expect.sh
index 60cbdc8..84617f0 100644
--- a/tests/expect.sh
+++ b/tests/expect.sh
@@ -99,24 +99,24 @@ EOF
     check_status_maybe_lose abort-compile $?
 }
 
-fail_on_compiler_note ()
+fail_on_condition_during_compile ()
 {
     run_sbcl <<EOF
-        (handler-bind ((sb-ext:compiler-note #'error))
-          (compile-file "$1")
+        (handler-bind (($1 #'error))
+          (compile-file "$2")
           (sb-ext:quit :unix-status $EXIT_LISP_WIN))
 EOF
-    check_status_maybe_lose fail-on-compiler-note $?
+    check_status_maybe_lose "fail-on-condition_$1" $?
 }
 
-expect_compiler_note ()
+expect_condition_during_compile ()
 {
     run_sbcl <<EOF
-        (handler-bind ((sb-ext:compiler-note (lambda (c)
-                                               (declare (ignore c))
-                                               (sb-ext:quit :unix-status
-                                                            $EXIT_LISP_WIN))))
-          (compile-file "$1"))
+        (handler-bind (($1 (lambda (c)
+                             (declare (ignore c))
+                             (sb-ext:quit :unix-status $EXIT_LISP_WIN))))
+          (compile-file "$2"))
 EOF
-    check_status_maybe_lose expect-compiler-note $?
+    check_status_maybe_lose "expect-condition_$1" $?
 }
+
diff --git a/version.lisp-expr b/version.lisp-expr
index b4cca35..23d8ec3 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.33.12"
+"1.0.33.13"
-- 
1.7.10.4