X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=47b4c92e4f64a0135f2abe4b623a7f7c2d4c08e6;hb=e73a30c901ab234291aefc9f1e73507650628892;hp=67ac1239581e530bc8be3bd955cc07f0d074028a;hpb=084168e1524a6493bc0f9d1697753d31239b158d;p=sbcl.git

diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index 67ac123..47b4c92 100644
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -612,13 +612,7 @@
     (setq *tn-id* 0)
     (clrhash *label-ids*)
     (clrhash *id-labels*)
-    (setq *label-id* 0)
-
-    ;; Clear some PACK data structures (for GC purposes only).
-    (aver (not *in-pack*))
-    (dolist (sb *backend-sb-list*)
-      (when (finite-sb-p sb)
-	(fill (finite-sb-live-tns sb) nil))))
+    (setq *label-id* 0))
 
   ;; (Note: The CMU CL code used to set CL::*GENSYM-COUNTER* to zero here.
   ;; Superficially, this seemed harmful -- the user could reasonably be
@@ -811,7 +805,8 @@
 ;;; *TOPLEVEL-LAMBDAS* instead.
 (defun convert-and-maybe-compile (form path)
   (declare (list path))
-  (let* ((*lexenv* (make-lexenv :policy *policy*))
+  (let* ((*lexenv* (make-lexenv :policy *policy*
+				:handled-conditions *handled-conditions*))
 	 (tll (ir1-toplevel form path nil)))
     (cond ((eq *block-compile* t) (push tll *toplevel-lambdas*))
 	  (t (compile-toplevel (list tll) nil)))))
@@ -856,7 +851,9 @@
 	   ;; FIXME: Ideally, something should be done so that DECLAIM
 	   ;; inside LOCALLY works OK. Failing that, at least we could
 	   ;; issue a warning instead of silently screwing up.
-	   (*policy* (lexenv-policy *lexenv*)))
+	   (*policy* (lexenv-policy *lexenv*))
+	   ;; This is probably also a hack
+	   (*handled-conditions* (lexenv-handled-conditions *lexenv*)))
       (process-toplevel-progn forms path compile-time-too))))
 
 ;;; Parse an EVAL-WHEN situations list, returning three flags,
@@ -915,8 +912,8 @@
     (setf (component-kind component) :initial)
     (let* ((locall-fun (ir1-convert-lambdalike
                         definition
-                        :debug-name (debug-namify "top level local call ~S"
-                                                  name)
+                        :debug-name (debug-namify "top level local call "
+						  name)
 			;; KLUDGE: we do this so that we get to have
 			;; nice debug returnness in functions defined
 			;; from the REPL
@@ -954,7 +951,8 @@
 		  '(original-source-start 0 0)))
   (when name
     (legal-fun-name-or-type-error name))
-  (let* ((*lexenv* (make-lexenv :policy *policy*))
+  (let* ((*lexenv* (make-lexenv :policy *policy*
+				:handled-conditions *handled-conditions*))
          (fun (make-functional-from-toplevel-lambda lambda-expression
 						    :name name
 						    :path path)))
@@ -1344,6 +1342,45 @@
     (setq *block-compile* nil)
     (setq *entry-points* nil)))
 
+(defun handle-condition-p (condition)
+  (let ((lexenv
+	 (etypecase *compiler-error-context*
+	   (node
+	    (node-lexenv *compiler-error-context*))
+	   (compiler-error-context
+	    (let ((lexenv (compiler-error-context-lexenv
+			   *compiler-error-context*)))
+	      (aver lexenv)
+	      lexenv))
+	   (null *lexenv*))))
+    (let ((muffles (lexenv-handled-conditions lexenv)))
+      (if (null muffles) ; common case
+	  nil
+	  (dolist (muffle muffles nil)
+	    (destructuring-bind (typespec . restart-name) muffle
+	      (when (and (typep condition typespec)
+			 (find-restart restart-name condition))
+		(return t))))))))
+
+(defun handle-condition-handler (condition)
+  (let ((lexenv
+	 (etypecase *compiler-error-context*
+	   (node
+	    (node-lexenv *compiler-error-context*))
+	   (compiler-error-context
+	    (let ((lexenv (compiler-error-context-lexenv
+			   *compiler-error-context*)))
+	      (aver lexenv)
+	      lexenv))
+	   (null *lexenv*))))
+    (let ((muffles (lexenv-handled-conditions lexenv)))
+      (aver muffles)
+      (dolist (muffle muffles (bug "fell through"))
+	(destructuring-bind (typespec . restart-name) muffle
+	  (when (typep condition typespec)
+	    (awhen (find-restart restart-name condition)
+	      (invoke-restart it))))))))
+
 ;;; Read all forms from INFO and compile them, with output to OBJECT.
 ;;; Return (VALUES NIL WARNINGS-P FAILURE-P).
 (defun sub-compile-file (info)
@@ -1354,6 +1391,7 @@
         (sb!xc:*compile-file-truename* nil) ; SUB-SUB-COMPILE-FILE
 
         (*policy* *policy*)
+	(*handled-conditions* *handled-conditions*)
         (*lexenv* (make-null-lexenv))
         (*block-compile* *block-compile-arg*)
         (*source-info* info)
@@ -1378,19 +1416,20 @@
         (*info-environment* *info-environment*)
         (*gensym-counter* 0))
     (handler-case
-	(with-compilation-values
-	 (sb!xc:with-compilation-unit ()
-	   (clear-stuff)
-
-	   (sub-sub-compile-file info)
-
-	   (finish-block-compilation)
-	   (let ((object *compile-object*))
-	     (etypecase object
-	       (fasl-output (fasl-dump-source-info info object))
-	       (core-object (fix-core-source-info info object))
-	       (null)))
-	   nil))
+	(handler-bind (((satisfies handle-condition-p) #'handle-condition-handler))
+	  (with-compilation-values
+	      (sb!xc:with-compilation-unit ()
+		(clear-stuff)
+		
+		(sub-sub-compile-file info)
+		
+		(finish-block-compilation)
+		(let ((object *compile-object*))
+		  (etypecase object
+		    (fasl-output (fasl-dump-source-info info object))
+		    (core-object (fix-core-source-info info object))
+		    (null)))
+		nil)))
       ;; Some errors are sufficiently bewildering that we just fail
       ;; immediately, without trying to recover and compile more of
       ;; the input file.