X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=6764c3acb5f8043cdd35d964786f955cc7fd3eaa;hb=ace140856e6b3f92bb06597092a59753f1e59142;hp=8ed61a8aa3ff62d303238c685e0524f460ab6667;hpb=0794cd3908a441222f430ba0cf3bb7c3e1a96c63;p=sbcl.git

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 8ed61a8..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))
@@ -624,7 +620,7 @@
 	   ;; there's no need for us to accept ANSI's lameness when
 	   ;; processing our own code, though.
 	   #+sb-xc-host
-	   (compiler-warn "reading an ignored variable: ~S" name)))
+	   (warn "reading an ignored variable: ~S" name)))
        (reference-leaf start next result var))
       (cons
        (aver (eq (car var) 'MACRO))
@@ -743,8 +739,8 @@
                                 (muffle-warning-or-die)))
 		     #-(and cmu sb-xc-host)
 		     (warning (lambda (c)
-				(compiler-warn "~@<~A~:@_~A~@:_~A~:>"
-					       (wherestring) hint c)
+				(warn "~@<~A~:@_~A~@:_~A~:>"
+				      (wherestring) hint c)
 				(muffle-warning-or-die)))
                      (error (lambda (c)
                               (compiler-error "~@<~A~:@_~A~@:_~A~:>"
@@ -922,28 +918,38 @@
     (collect ((restr nil cons)
              (new-vars nil cons))
       (dolist (var-name (rest decl))
+	(when (boundp var-name)
+          (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)
 			(find-free-var var-name))))
 	  (etypecase var
 	    (leaf
-             (flet ((process-var (var bound-var)
-                      (let* ((old-type (or (lexenv-find var type-restrictions)
-                                           (leaf-type var)))
-                             (int (if (or (fun-type-p type)
-                                          (fun-type-p old-type))
-                                      type
-                                      (type-approx-intersection2 old-type type))))
-                        (cond ((eq int *empty-type*)
-                               (unless (policy *lexenv* (= inhibit-warnings 3))
-                                 (compiler-warn
-                                  "The type declarations ~S and ~S for ~S conflict."
-                                  (type-specifier old-type) (type-specifier type)
-                                  var-name)))
-                              (bound-var (setf (leaf-type bound-var) int))
-                              (t
-                               (restr (cons var int)))))))
+             (flet 
+		 ((process-var (var bound-var)
+		    (let* ((old-type (or (lexenv-find var type-restrictions)
+					 (leaf-type var)))
+			   (int (if (or (fun-type-p type)
+					(fun-type-p old-type))
+				    type
+				    (type-approx-intersection2 
+				     old-type type))))
+		      (cond ((eq int *empty-type*)
+			     (unless (policy *lexenv* (= inhibit-warnings 3))
+			       (warn
+				'type-warning
+				:format-control
+				"The type declarations ~S and ~S for ~S conflict."
+				:format-arguments
+				(list
+				 (type-specifier old-type) 
+				 (type-specifier type)
+				 var-name))))
+			    (bound-var (setf (leaf-type bound-var) int))
+			    (t
+			     (restr (cons var int)))))))
                (process-var var bound-var)
                (awhen (and (lambda-var-p var)
                            (lambda-var-specvar var))
@@ -975,6 +981,9 @@
   (let ((type (compiler-specifier-type spec)))
     (collect ((res nil cons))
       (dolist (name names)
+	(when (fboundp name)
+	  (compiler-assert-symbol-home-package-unlocked name
+                                                        "declaring the ftype of ~A"))
 	(let ((found (find name fvars
 			   :key #'leaf-source-name
 			   :test #'equal)))
@@ -999,6 +1008,7 @@
   (declare (list spec vars) (type lexenv res))
   (collect ((new-venv nil cons))
     (dolist (name (cdr spec))
+      (compiler-assert-symbol-home-package-unlocked name "declaring ~A special")
       (let ((var (find-in-bindings vars name)))
 	(etypecase var
 	  (cons
@@ -1195,6 +1205,11 @@
        (dynamic-extent
 	(process-dx-decl (cdr spec) vars)
         res)
+       ((disable-package-locks enable-package-locks)
+        (make-lexenv
+         :default res
+         :disabled-package-locks (process-package-lock-decl 
+                                  spec (lexenv-disabled-package-locks res))))
        (t
         (unless (info :declaration :recognized (first spec))
           (compiler-warn "unrecognized declaration ~S" raw-spec))