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 e14ed30..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

@@ -848,8 +807,11 @@
 (defun setq-var (start cont var value)
   (declare (type continuation start cont) (type basic-var var))
   (let ((dest (make-continuation)))
 (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)
     (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)
     (let ((res (make-set :var var :value dest)))
       (setf (continuation-dest dest) res)
       (setf (leaf-ever-used var) t)

@@ -859,7 +821,7 @@
 \f
 ;;;; CATCH, THROW and UNWIND-PROTECT
 
 \f
 ;;;; 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)
 ;;; 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 +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)

@@ -1063,20 +1022,17 @@
 \f
 ;;;; interface to defining macros
 
 \f
 ;;;; interface to defining macros
 

-;;;; FIXME:
-;;;;   classic CMU CL comment:
-;;;;     DEFMACRO and DEFUN expand into calls to %DEFxxx functions
-;;;;     so that we get a chance to see what is going on. We define
-;;;;     IR1 translators for these functions which look at the
-;;;;     definition and then generate a call to the %%DEFxxx function.
-;;;; Alas, this implementation doesn't do the right thing for
-;;;; non-toplevel uses of these forms, so this should probably
-;;;; be changed to use EVAL-WHEN instead.
-
-;;; Return a new source path with any stuff intervening between the
-;;; current path and the first form beginning with NAME stripped off.
-;;; This is used to hide the guts of DEFmumble macros to prevent
-;;; annoying error messages.
+;;; Old CMUCL comment:
+;;;
+;;;   Return a new source path with any stuff intervening between the
+;;;   current path and the first form beginning with NAME stripped
+;;;   off.  This is used to hide the guts of DEFmumble macros to
+;;;   prevent annoying error messages.
+;;;
+;;; Now that we have implementations of DEFmumble macros in terms of
+;;; EVAL-WHEN, this function is no longer used.  However, it might be
+;;; worth figuring out why it was used, and maybe doing analogous
+;;; munging to the functions created in the expanders for the macros.

 (defun revert-source-path (name)
   (do ((path *current-path* (cdr path)))
       ((null path) *current-path*)
 (defun revert-source-path (name)
   (do ((path *current-path* (cdr path)))
       ((null path) *current-path*)

@@ -1084,28 +1040,3 @@
       (when (or (eq first name)
                (eq first 'original-source-start))
        (return path)))))
       (when (or (eq first name)
                (eq first 'original-source-start))
        (return path)))))

-
-(def-ir1-translator %define-compiler-macro ((name def lambda-list doc)
-                                           start cont
-                                           :kind :function)
-  (let ((name (eval name))
-       (def (second def))) ; We don't want to make a function just yet...
-
-    (when (eq (info :function :kind name) :special-form)
-      (compiler-error "attempt to define a compiler-macro for special form ~S"
-                     name))
-
-    (setf (info :function :compiler-macro-function name)
-         (coerce def 'function))
-
-    (let* ((*current-path* (revert-source-path 'define-compiler-macro))
-          (fun (ir1-convert-lambda def
-                                   :debug-name (debug-namify
-                                                "DEFINE-COMPILER-MACRO ~S"
-                                                name))))
-      (setf (functional-arg-documentation fun) (eval lambda-list))
-
-      (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc)))
-
-    (when sb!xc:*compile-print*
-      (compiler-mumble "~&; converted ~S~%" name))))