X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir1tran.lisp;h=6764c3acb5f8043cdd35d964786f955cc7fd3eaa;hb=a163c70e2bef35bf482a785dbfd9c545b4fcd555;hp=22654d10e31714d03fde3d7b4b9e2ae104347159;hpb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;p=sbcl.git

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 22654d1..6764c3a 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -449,23 +449,20 @@
 (declaim (ftype (sfunction (ctran ctran (or lvar null) t) (values))
 		ir1-convert))
 (macrolet (;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws
-	   ;; out of the body and converts a proxy form instead.
-	   (ir1-error-bailout ((start next result
-				form
-				&optional
-				(proxy ``(error 'simple-program-error
-					  :format-control "execution of a form compiled with errors:~% ~S"
-					  :format-arguments (list ',,form))))
-			       &body body)
-			      (with-unique-names (skip)
-				`(block ,skip
-				   (catch 'ir1-error-abort
+	   ;; out of the body and converts a condition signalling form
+	   ;; instead. The source form is converted to a string since it
+	   ;; may contain arbitrary non-externalizable objects.
+	   (ir1-error-bailout ((start next result form) &body body)
+	     (with-unique-names (skip condition)
+	       `(block ,skip
+		 (let ((,condition (catch 'ir1-error-abort
 				     (let ((*compiler-error-bailout*
-					    (lambda ()
-					      (throw 'ir1-error-abort nil))))
+					    (lambda (&optional e)
+					      (throw 'ir1-error-abort e))))
 				       ,@body
-				       (return-from ,skip nil)))
-				   (ir1-convert ,start ,next ,result ,proxy)))))
+				       (return-from ,skip nil)))))
+		   (ir1-convert ,start ,next ,result
+				(make-compiler-error-form ,condition ,form)))))))
 
   ;; Translate FORM into IR1. The code is inserted as the NEXT of the
   ;; CTRAN START. RESULT is the LVAR which receives the value of the
@@ -533,8 +530,7 @@
     (declare (type ctran start next)
              (type (or lvar null) result)
 	     (inline find-constant))
-    (ir1-error-bailout
-     (start next result value '(error "attempt to reference undumpable constant"))
+    (ir1-error-bailout (start next result value)
      (when (producing-fasl-file)
        (maybe-emit-make-load-forms value))
      (let* ((leaf (find-constant value))
@@ -923,8 +919,8 @@
              (new-vars nil cons))
       (dolist (var-name (rest decl))
 	(when (boundp var-name)
-	  (with-single-package-locked-error
-              (:symbol var-name "declaring the type of ~A")))
+          (compiler-assert-symbol-home-package-unlocked var-name
+                                                        "declaring the type of ~A"))
 	(let* ((bound-var (find-in-bindings vars var-name))
 	       (var (or bound-var
 			(lexenv-find var-name vars)
@@ -986,8 +982,8 @@
     (collect ((res nil cons))
       (dolist (name names)
 	(when (fboundp name)
-	  (with-single-package-locked-error
-              (:symbol name "declaring the ftype of ~A")))
+	  (compiler-assert-symbol-home-package-unlocked name
+                                                        "declaring the ftype of ~A"))
 	(let ((found (find name fvars
 			   :key #'leaf-source-name
 			   :test #'equal)))
@@ -1012,8 +1008,7 @@
   (declare (list spec vars) (type lexenv res))
   (collect ((new-venv nil cons))
     (dolist (name (cdr spec))
-      (with-single-package-locked-error
-          (:symbol name "declaring ~A special"))
+      (compiler-assert-symbol-home-package-unlocked name "declaring ~A special")
       (let ((var (find-in-bindings vars name)))
 	(etypecase var
 	  (cons