X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=7177de5533a9d95478b01d9a71fca2ad45ead29a;hb=aebbc5aad31f7e55930c996a8c54f0a135e00894;hp=398e692250cca4d3818e037c4fb868788fd46c43;hpb=dc84ceb894fdbe315f82dd8336f3ba894435a669;p=sbcl.git

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index 398e692..7177de5 100644
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -35,6 +35,8 @@
 	 (node (make-if :test pred
 			:consequent then-block
 			:alternative else-block)))
+    ;; IR1-CONVERT-MAYBE-PREDICATE requires DEST to be CIF, so the
+    ;; order of the following two forms is important
     (setf (continuation-dest pred) node)
     (ir1-convert start pred test)
     (link-node-to-previous-continuation node pred)
@@ -344,15 +346,6 @@
    macrobindings
    (lambda (&key vars)
      (ir1-translate-locally body start cont :vars vars))))
-
-;;; not really a special form, but..
-(def-ir1-translator declare ((&rest stuff) start cont)
-  (declare (ignore stuff))
-  ;; We ignore START and CONT too, but we can't use DECLARE IGNORE to
-  ;; tell the compiler about it here, because the DEF-IR1-TRANSLATOR
-  ;; macro would put the DECLARE in the wrong place, so..
-  start cont
-  (compiler-error "misplaced declaration"))
 
 ;;;; %PRIMITIVE
 ;;;;
@@ -435,60 +428,22 @@
   be a lambda expression."
   (if (consp thing)
       (case (car thing)
-	((lambda)
+	((lambda named-lambda instance-lambda lambda-with-lexenv)
 	 (reference-leaf start
 			 cont
-			 (ir1-convert-lambda thing
-					     :debug-name (debug-namify
-							  "#'~S" thing))))
-	((setf)
+			 (ir1-convert-lambdalike
+			  thing
+			  :debug-name (debug-namify "#'~S" thing)
+			  :allow-debug-catch-tag t)))
+	((setf sb!pcl::class-predicate sb!pcl::slot-accessor)
 	 (let ((var (find-lexically-apparent-fun
 		     thing "as the argument to FUNCTION")))
 	   (reference-leaf start cont var)))
-	((instance-lambda)
-	 (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing))
-					:debug-name (debug-namify "#'~S"
-								  thing))))
-	   (setf (getf (functional-plist res) :fin-function) t)
-	   (reference-leaf start cont res)))
 	(t
 	 (compiler-error "~S is not a legal function name." thing)))
       (let ((var (find-lexically-apparent-fun
 		  thing "as the argument to FUNCTION")))
 	(reference-leaf start cont var))))
-
-;;; `(NAMED-LAMBDA ,NAME ,@REST) is like `(FUNCTION (LAMBDA ,@REST)),
-;;; except that the value of NAME is passed to the compiler for use in
-;;; creation of debug information for the resulting function.
-;;;
-;;; NAME can be a legal function name or some arbitrary other thing.
-;;;
-;;; If NAME is a legal function name, then the caller should be
-;;; planning to set (FDEFINITION NAME) to the created function.
-;;; (Otherwise the debug names will be inconsistent and thus
-;;; unnecessarily confusing.)
-;;;
-;;; Arbitrary other things are appropriate for naming things which are
-;;; not the FDEFINITION of NAME. E.g.
-;;;   NAME = (:FLET FOO BAR)
-;;; for the FLET function in
-;;;   (DEFUN BAR (X)
-;;;     (FLET ((FOO (Y) (+ X Y)))
-;;;       FOO))
-;;; or
-;;;   NAME = (:METHOD PRINT-OBJECT :AROUND (STARSHIP T))
-;;; for the function used to implement
-;;;   (DEFMETHOD PRINT-OBJECT :AROUND ((SS STARSHIP) STREAM) ...).
-(def-ir1-translator named-lambda ((name &rest rest) start cont)
-  (let* ((fun (if (legal-fun-name-p name)
-                  (ir1-convert-lambda `(lambda ,@rest)
-                                      :source-name name)
-                  (ir1-convert-lambda `(lambda ,@rest)
-                                      :debug-name name)))
-         (leaf (reference-leaf start cont fun)))
-    (when (legal-fun-name-p name)
-      (assert-global-function-definition-type name fun))
-    leaf))
 
 ;;;; FUNCALL
 
@@ -657,7 +612,8 @@
   			      (ir1-convert-lambda d
 						  :source-name n
 						  :debug-name (debug-namify
-							       "FLET ~S" n)))
+							       "FLET ~S" n)
+						  :allow-debug-catch-tag t))
 			    names defs))
 	     (*lexenv* (make-lexenv
 			:default (process-decls decls nil fvars cont)
@@ -692,7 +648,8 @@
 			  (ir1-convert-lambda def
 					      :source-name name
 					      :debug-name (debug-namify
-							   "LABELS ~S" name)))
+							   "LABELS ~S" name)
+					      :allow-debug-catch-tag t))
 			names defs))))
 
         ;; Modify all the references to the dummy function leaves so
@@ -848,8 +805,11 @@
 (defun setq-var (start cont var value)
   (declare (type continuation start cont) (type basic-var var))
   (let ((dest (make-continuation)))
-    (assert-continuation-type dest (leaf-type var) (lexenv-policy *lexenv*))
     (ir1-convert start dest value)
+    (assert-continuation-type dest
+                              (or (lexenv-find var type-restrictions)
+                                  (leaf-type var))
+                              (lexenv-policy *lexenv*))
     (let ((res (make-set :var var :value dest)))
       (setf (continuation-dest dest) res)
       (setf (leaf-ever-used var) t)
@@ -859,7 +819,7 @@
 
 ;;;; CATCH, THROW and UNWIND-PROTECT
 
-;;; We turn THROW into a multiple-value-call of a magical function,
+;;; We turn THROW into a MULTIPLE-VALUE-CALL of a magical function,
 ;;; since as as far as IR1 is concerned, it has no interesting
 ;;; properties other than receiving multiple-values.
 (def-ir1-translator throw ((tag result) start cont)
@@ -994,9 +954,6 @@
 		     fun
 		     `(%coerce-callable-to-fun ,fun)))
     (setf (continuation-dest fun-cont) node)
-    (assert-continuation-type fun-cont
-			      (specifier-type '(or function symbol))
-                              (lexenv-policy *lexenv*))
     (collect ((arg-conts))
       (let ((this-start fun-cont))
 	(dolist (arg args)