0.pre8.92:

[sbcl.git] / src / compiler / ir1-translators.lisp

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index 8eb3b48..ab89de1 100644 (file)
--- 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)))
         (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)
     (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))))
    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"))

 \f
 ;;;; %PRIMITIVE
 ;;;;
 \f
 ;;;; %PRIMITIVE
 ;;;;

@@ -435,60 +428,22 @@
   be a lambda expression."
   (if (consp thing)
       (case (car thing)
   be a lambda expression."
   (if (consp thing)
       (case (car thing)

-       ((lambda)
+       ((lambda named-lambda instance-lambda lambda-with-lexenv)

         (reference-leaf start
                         cont
         (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)))
         (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))))
        (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))

 \f
 ;;;; FUNCALL
 
 \f
 ;;;; FUNCALL
 

@@ -575,15 +530,17 @@
   During evaluation of the Forms, bind the Vars to the result of evaluating the
   Value forms. The variables are bound in parallel after all of the Values are
   evaluated."
   During evaluation of the Forms, bind the Vars to the result of evaluating the
   Value forms. The variables are bound in parallel after all of the Values are
   evaluated."

-  (multiple-value-bind (forms decls) (parse-body body nil)
-    (multiple-value-bind (vars values) (extract-let-vars bindings 'let)
-      (let ((fun-cont (make-continuation)))
-        (let* ((*lexenv* (process-decls decls vars nil cont))
-               (fun (ir1-convert-lambda-body
-                     forms vars
-                     :debug-name (debug-namify "LET ~S" bindings))))
-          (reference-leaf start fun-cont fun))
-        (ir1-convert-combination-args fun-cont cont values)))))
+  (if (null bindings)
+      (ir1-translate-locally  body start cont)
+      (multiple-value-bind (forms decls) (parse-body body nil)
+        (multiple-value-bind (vars values) (extract-let-vars bindings 'let)
+          (let ((fun-cont (make-continuation)))
+            (let* ((*lexenv* (process-decls decls vars nil cont))
+                   (fun (ir1-convert-lambda-body
+                         forms vars
+                         :debug-name (debug-namify "LET ~S" bindings))))
+              (reference-leaf start fun-cont fun))
+            (ir1-convert-combination-args fun-cont cont values))))))

 
 (def-ir1-translator let* ((bindings &body body)
                          start cont)
 
 (def-ir1-translator let* ((bindings &body body)
                          start cont)

@@ -657,7 +614,8 @@
                              (ir1-convert-lambda d
                                                  :source-name n
                                                  :debug-name (debug-namify
                              (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)
                            names defs))
             (*lexenv* (make-lexenv
                        :default (process-decls decls nil fvars cont)

@@ -692,7 +650,8 @@
                          (ir1-convert-lambda def
                                              :source-name name
                                              :debug-name (debug-namify
                          (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
                        names defs))))
 
         ;; Modify all the references to the dummy function leaves so

@@ -849,7 +808,10 @@
   (declare (type continuation start cont) (type basic-var var))
   (let ((dest (make-continuation)))
     (ir1-convert start dest value)
   (declare (type continuation start cont) (type basic-var var))
   (let ((dest (make-continuation)))
     (ir1-convert start dest value)

-    (assert-continuation-type dest (leaf-type var) (lexenv-policy *lexenv*))
+    (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)
     (let ((res (make-set :var var :value dest)))
       (setf (continuation-dest dest) res)
       (setf (leaf-ever-used var) t)

@@ -994,9 +956,6 @@
                     fun
                     `(%coerce-callable-to-fun ,fun)))
     (setf (continuation-dest fun-cont) node)
                     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)
     (collect ((arg-conts))
       (let ((this-start fun-cont))
        (dolist (arg args)