From 866cba66d7023964eaeee402ec52898fded12be2 Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Wed, 20 Aug 2008 20:47:33 +0000
Subject: [PATCH] Implemented hooks for users to trap compiler conditions,
 based on WITH-COMPILATION-UNIT

---
 src/CHANGELOG       | 17 +++++++++++++++++
 src/cmp/cmpdefs.lsp | 14 ++++++++++++++
 src/cmp/cmputil.lsp | 36 ++++++++++++++++++++++++++++--------
 3 files changed, 59 insertions(+), 8 deletions(-)

diff --git a/src/CHANGELOG b/src/CHANGELOG
index b92953e0d..8c3130f9e 100644
--- a/src/CHANGELOG
+++ b/src/CHANGELOG
@@ -6,6 +6,23 @@ ECL 0.9l-p1:
  - The compiler now signals compiler-error, compiler-warning and compiler-note
    for errors, warnings and notes, respectively.
 
+ - WITH-COMPILATION-UNIT allows the user to set up handlers for different
+   compiler conditions, including errors, warnings and simple notes. The
+   recommended procedure is to use HANDLER-BIND and _NOT_ to transfer control
+   out of the handler, but to defer to the default ones.
+	(use-package :c)
+	(let ((messages nil))
+	  (with-compilation-unit ()
+	    (handler-bind ((compiler-error #'(lambda (c)
+					       (push c messages)
+					       (abort)))
+			   (compiler-message #'(lambda (c) (push c messages))))
+	      (compile-file "foo.lsp")))
+	  (format t "~&;;; Printing messages")
+	  (loop for m in (nreverse messages)
+	     for i from 0
+	     do (format t "~&~@<;;; ~@;Message #~D~%~A~:>" i m)))
+
 * Bugs fixed:
 
  - The optimizer for COERCE might enter an infinite loop for certain
diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp
index 6a71fe18a..8b456f18a 100644
--- a/src/cmp/cmpdefs.lsp
+++ b/src/cmp/cmpdefs.lsp
@@ -28,6 +28,16 @@
            "BUILD-FASL"
 	   "BUILD-STATIC-LIBRARY"
 	   "BUILD-SHARED-LIBRARY"
+	   "COMPILER-WARNING"
+	   "COMPILER-NOTE"
+	   "COMPILER-MESSAGE"
+	   "COMPILER-ERROR"
+	   "COMPILER-FATAL-ERROR"
+	   "COMPILER-INTERNAL-ERROR"
+	   "COMPILER-UNDEFINED-VARIABLE"
+	   "COMPILER-MESSAGE-FILE"
+	   "COMPILER-MESSAGE-FILE-POSITION"
+	   "COMPILER-MESSAGE-FORM"
 	   "*SUPPRESS-COMPILER-WARNINGS*"
 	   "*SUPPRESS-COMPILER-NOTES*")
   (:import-from "SI" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" "MACRO"
@@ -252,6 +262,10 @@
 (defvar *error-p* nil)
 (defconstant *cmperr-tag* (cons nil nil))
 
+(defvar *active-handlers* nil)
+(defvar *active-protection* nil)
+(defvar *pending-actions* nil)
+
 (defvar *compiler-conditions* '()
   "This variable determines whether conditions are printed or just accumulated.")
 
diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp
index 2bd262e4e..7ad4af7f8 100644
--- a/src/cmp/cmputil.lsp
+++ b/src/cmp/cmputil.lsp
@@ -66,18 +66,38 @@
   (print-compiler-message c t)
   (invoke-restart (find-restart-never-fail 'abort-form c)))
 
+(defun do-compilation-unit (closure &key override)
+  (cond (override
+	 (let* ((*active-handlers* nil)
+		(*active-protection* nil))
+	   (do-compilation-unit closure)))
+	((null *active-protection*)
+	 (let* ((*active-protection* t)
+		(*pending-actions* nil))
+	   (unwind-protect (do-compilation-unit closure)
+	     (loop for action in *pending-actions*
+		do (funcall action)))))
+	((null *active-handlers*)
+	 (let ((*active-handlers* t))
+	   (handler-bind ((compiler-note #'handle-note)
+			  (compiler-warning #'handle-warning)
+			  (compiler-error #'handle-error)
+			  (compiler-fatal-error #'handle-fatal-error))
+	     (funcall closure))))
+	(t
+	 (funcall closure))))
+
+(defmacro with-compilation-unit ((&rest options) &body body)
+ `(do-compilation-unit #'(lambda () ,@body) ,@options))
+
 (defmacro with-compiler-env ((error-flag) &body body)
   `(with-lock (+load-compile-lock+)
      (restart-case
-	 (handler-bind ((compiler-note #'handle-note)
-			(compiler-warning #'handle-warning)
-			(compiler-error #'handle-error)
-			(compiler-fatal-error #'handle-fatal-error))
-	   (let ,+init-env-form+
-	     (setf ,error-flag nil)
+	 (let ,+init-env-form+
+	   (setf ,error-flag nil)
+	   (with-compilation-unit ()
 	     ,@body))
-       (abort (c) (setf ,error-flag t))
-       (abort-form (c) (setf ,error-flag t)))))
+       (abort (c) (setf ,error-flag t)))))
 
 (defvar *c1form-level* 0)
 (defun print-c1forms (form)