[Sbcl-commits] CVS: sbcl/src/compiler compiler-error.lisp,1.6,1.7 ir1report.lisp,1.11,1.12

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1:/tmp/cvs-serv4630/src/compiler

Modified Files:
	compiler-error.lisp ir1report.lisp 
Log Message:
0.8alpha.0.28:
	Fix bug 47d (DEFGENERIC must signal PROGRAM-ERROR when 
	attempting to create a generic function with the same name as a 
	special operator).
	... sounds easy, huh?  No.
	... make COMPILER-ERROR not inherit from ERROR any more, so that 
		user handlers don't (wrongly) claim to handle it;
	... establish a handler for COMPILER-ERROR around the evaluator 
		that delegates to the compiler handlers if present, but 
		handles them itself if not...
	... by signalling an error from a new internal restart, to allow 
		user handlers for ERROR and friends a chance to run.


Index: compiler-error.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/compiler-error.lisp,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- compiler-error.lisp	31 Jan 2002 16:38:47 -0000	1.6
+++ compiler-error.lisp	13 May 2003 13:55:30 -0000	1.7
@@ -22,8 +22,7 @@
 
 ;;; a function that is called to unwind out of COMPILER-ERROR
 (declaim (type (function () nil) *compiler-error-bailout*))
-(defvar *compiler-error-bailout*
-  (lambda () (error "COMPILER-ERROR with no bailout")))
+(defvar *compiler-error-bailout*)
 
 ;;; an application programmer's error caught by the compiler
 ;;;
@@ -33,7 +32,51 @@
 ;;; and turned into diagnostic output and a FAILURE-P return value
 ;;; from COMPILE or COMPILE-FILE. Bugs in SBCL itself throw us into
 ;;; the debugger.
-(define-condition compiler-error (simple-error) ())
+;;;
+;;; A further word or two of explanation might be warranted here,
+;;; since I (CSR) have spent the last day or so wandering in a
+;;; confused daze trying to get this to behave nicely before finally
+;;; hitting on the right solution.
+;;;
+;;; These objects obey a slightly involved protocol in order to
+;;; achieve the right dynamic behaviour.  If we signal a
+;;; COMPILER-ERROR from within the compiler, we want that the
+;;; outermost call to COMPILE/COMPILE-FILE cease attempting to compile
+;;; the code in question and instead compile a call to signal a
+;;; PROGRAM-ERROR.  This is achieved by resignalling the condition
+;;; from within the handler, so that the condition travels up the
+;;; handler stack until it finds the outermost handler.  Why the
+;;; outermost?  Well, COMPILE-FILE could call EVAL from an EVAL-WHEN,
+;;; which could recursively call COMPILE, which could then signal an
+;;; error; we want the inner EVAL not to fail so that we can go on
+;;; compiling, so it's the outer COMPILE-FILE that needs to replace
+;;; the erroneous call with a call to ERROR.
+;;;
+;;; This resignalling up the stack means that COMPILER-ERROR should
+;;; not be a generalized instance of ERROR, as otherwise code such as
+;;; (IGNORE-ERRORS (DEFGENERIC IF (X))) will catch and claim to handle
+;;; the COMPILER-ERROR.  So we make COMPILER-ERROR inherit from
+;;; SIMPLE-CONDITION and SERIOUS-CONDITION instead, as of
+;;; sbcl-0.8alpha.0.2x, so that unless the user claims to be able to
+;;; handle SERIOUS-CONDITION (and if he does, he deserves what's going
+;;; to happen :-)
+;;;
+;;; So, what if we're not inside the compiler, then?  Well, in that
+;;; case we're in the evaluator, so we want to convert the
+;;; COMPILER-ERROR into a PROGRAM-ERROR and signal it immediately.  We
+;;; have to signal the PROGRAM-ERROR from the dynamic environment of
+;;; attempting to evaluate the erroneous code, and not from any
+;;; exterior handler, so that user handlers for PROGRAM-ERROR and
+;;; ERROR stand a chance of running, in e.g. (IGNORE-ERRORS
+;;; (DEFGENERIC IF (X))).  So this is where the SIGNAL-PROGRAM-ERROR
+;;; restart comes in; the handler in EVAL-IN-LEXENV chooses this
+;;; restart if it believes that the compiler is not present (which it
+;;; tests using the BOUNDPness of *COMPILER-ERROR-BAILOUT*).  The
+;;; restart executes in the dynamic environment of the original
+;;; COMPILER-ERROR call, and all is well.
+;;;
+;;; CSR, 2003-05-13
+(define-condition compiler-error (simple-condition serious-condition) ())
 
 ;;; Signal the appropriate condition. COMPILER-ERROR calls the bailout
 ;;; function so that it never returns (but compilation continues).
@@ -47,12 +90,18 @@
 	 :format-control format-string
 	 :format-arguments format-args))
 (defun compiler-error (format-string &rest format-args)
-  (cerror "Replace form with call to ERROR."
-	  'compiler-error
-	  :format-control format-string
-	  :format-arguments format-args)
-  (funcall *compiler-error-bailout*)
-  (bug "Control returned from *COMPILER-ERROR-BAILOUT*."))
+  (restart-case
+      (progn
+	(cerror "Replace form with call to ERROR."
+		'compiler-error
+		:format-control format-string
+		:format-arguments format-args)
+	(funcall *compiler-error-bailout*)
+	(bug "Control returned from *COMPILER-ERROR-BAILOUT*."))
+    (signal-program-error ()
+      (error 'simple-program-error
+	     :format-control format-string
+	     :format-arguments format-args))))
 (defun compiler-warn (format-string &rest format-args)
   (apply #'warn format-string format-args)
   (values))

Index: ir1report.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1report.lisp,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -d -r1.11 -r1.12
--- ir1report.lisp	14 Dec 2002 22:10:11 -0000	1.11
+++ ir1report.lisp	13 May 2003 13:55:30 -0000	1.12
@@ -400,7 +400,7 @@
 	(what (etypecase condition
 		(style-warning 'style-warning)
 		(warning 'warning)
-		(error 'error))))
+		((or error compiler-error) 'error))))
     (multiple-value-bind (format-string format-args)
 	(if (typep condition 'simple-condition)
 	    (values (simple-condition-format-control condition)