0.7.8.41:

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

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index c06a99b..14823c9 100644 (file)
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -77,7 +77,7 @@
     (setf (entry-cleanup entry) cleanup)
     (link-node-to-previous-continuation entry start)
     (use-continuation entry dummy)
     (setf (entry-cleanup entry) cleanup)
     (link-node-to-previous-continuation entry start)
     (use-continuation entry dummy)

-    
+

     (let* ((env-entry (list entry cont))
            (*lexenv* (make-lexenv :blocks (list (cons name env-entry))
                                  :cleanup cleanup)))
     (let* ((env-entry (list entry cont))
            (*lexenv* (make-lexenv :blocks (list (cons name env-entry))
                                  :cleanup cleanup)))

@@ -177,7 +177,7 @@
       (starts dummy)
       (dolist (segment (rest segments))
        (let* ((tag-cont (make-continuation))
       (starts dummy)
       (dolist (segment (rest segments))
        (let* ((tag-cont (make-continuation))

-               (tag (list (car segment) entry tag-cont)))          
+               (tag (list (car segment) entry tag-cont)))

          (conts tag-cont)
          (starts tag-cont)
          (continuation-starts-block tag-cont)
          (conts tag-cont)
          (starts tag-cont)
          (continuation-starts-block tag-cont)

@@ -222,7 +222,7 @@
 ;;;   are ignored for non-top-level forms. For non-top-level forms, an
 ;;;   eval-when specifying the :EXECUTE situation is treated as an
 ;;;   implicit PROGN including the forms in the body of the EVAL-WHEN
 ;;;   are ignored for non-top-level forms. For non-top-level forms, an
 ;;;   eval-when specifying the :EXECUTE situation is treated as an
 ;;;   implicit PROGN including the forms in the body of the EVAL-WHEN

-;;;   form; otherwise, the forms in the body are ignored. 
+;;;   form; otherwise, the forms in the body are ignored.

 (def-ir1-translator eval-when ((situations &rest forms) start cont)
   #!+sb-doc
   "EVAL-WHEN (Situation*) Form*
 (def-ir1-translator eval-when ((situations &rest forms) start cont)
   #!+sb-doc
   "EVAL-WHEN (Situation*) Form*

@@ -250,7 +250,7 @@
     (compiler-style-warn "duplicate definitions in ~S" definitions))
   (let* ((processed-definitions (mapcar definitionize-fun definitions))
          (*lexenv* (make-lexenv definitionize-keyword processed-definitions)))
     (compiler-style-warn "duplicate definitions in ~S" definitions))
   (let* ((processed-definitions (mapcar definitionize-fun definitions))
          (*lexenv* (make-lexenv definitionize-keyword processed-definitions)))

-    (funcall fun)))
+    (funcall fun definitionize-keyword processed-definitions)))

 
 ;;; Tweak *LEXENV* to include the DEFINITIONS from a MACROLET, then
 ;;; call FUN (with no arguments).
 
 ;;; Tweak *LEXENV* to include the DEFINITIONS from a MACROLET, then
 ;;; call FUN (with no arguments).

@@ -267,16 +267,20 @@
      (destructuring-bind (name arglist &body body) definition
        (unless (symbolp name)
         (compiler-error "The local macro name ~S is not a symbol." name))
      (destructuring-bind (name arglist &body body) definition
        (unless (symbolp name)
         (compiler-error "The local macro name ~S is not a symbol." name))

+       (unless (listp arglist)
+        (compiler-error "The local macro argument list ~S is not a list." arglist))

        (let ((whole (gensym "WHOLE"))
             (environment (gensym "ENVIRONMENT")))
         (multiple-value-bind (body local-decls)
             (parse-defmacro arglist whole body name 'macrolet
                             :environment environment)
           `(,name macro .
        (let ((whole (gensym "WHOLE"))
             (environment (gensym "ENVIRONMENT")))
         (multiple-value-bind (body local-decls)
             (parse-defmacro arglist whole body name 'macrolet
                             :environment environment)
           `(,name macro .

-                  ,(compile nil
-                            `(lambda (,whole ,environment)
-                               ,@local-decls
-                               (block ,name ,body))))))))
+                  ,(compile-in-lexenv
+                     nil
+                     `(lambda (,whole ,environment)
+                        ,@local-decls
+                        (block ,name ,body))
+                     (make-restricted-lexenv *lexenv*)))))))

    :funs
    definitions
    fun))
    :funs
    definitions
    fun))

@@ -288,9 +292,11 @@
   defined. Name is the local macro name, Lambda-List is the DEFMACRO style
   destructuring lambda list, and the Forms evaluate to the expansion. The
   Forms are evaluated in the null environment."
   defined. Name is the local macro name, Lambda-List is the DEFMACRO style
   destructuring lambda list, and the Forms evaluate to the expansion. The
   Forms are evaluated in the null environment."

-  (funcall-in-macrolet-lexenv definitions
-                             (lambda ()
-                               (ir1-translate-locally body start cont))))
+  (funcall-in-macrolet-lexenv
+   definitions
+   (lambda (&key funs)
+     (declare (ignore funs))
+     (ir1-translate-locally body start cont))))

 
 (defun funcall-in-symbol-macrolet-lexenv (definitions fun)
   (%funcall-in-foomacrolet-lexenv
 
 (defun funcall-in-symbol-macrolet-lexenv (definitions fun)
   (%funcall-in-foomacrolet-lexenv

@@ -309,7 +315,7 @@
    :vars
    definitions
    fun))
    :vars
    definitions
    fun))

-  
+

 (def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont)
   #!+sb-doc
   "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form*
 (def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont)
   #!+sb-doc
   "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form*

@@ -317,8 +323,8 @@
   body, references to a Name will effectively be replaced with the Expansion."
   (funcall-in-symbol-macrolet-lexenv
    macrobindings
   body, references to a Name will effectively be replaced with the Expansion."
   (funcall-in-symbol-macrolet-lexenv
    macrobindings

-   (lambda ()
-     (ir1-translate-locally body start cont))))
+   (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)
 
 ;;; not really a special form, but..
 (def-ir1-translator declare ((&rest stuff) start cont)

@@ -455,13 +461,15 @@
 ;;; for the function used to implement
 ;;;   (DEFMETHOD PRINT-OBJECT :AROUND ((SS STARSHIP) STREAM) ...).
 (def-ir1-translator named-lambda ((name &rest rest) start cont)
 ;;; for the function used to implement
 ;;;   (DEFMETHOD PRINT-OBJECT :AROUND ((SS STARSHIP) STREAM) ...).
 (def-ir1-translator named-lambda ((name &rest rest) start cont)

-  (reference-leaf start
-                 cont
-                 (if (legal-fun-name-p name)
-                     (ir1-convert-lambda `(lambda ,@rest)
-                                         :source-name name)
-                     (ir1-convert-lambda `(lambda ,@rest)
-                                         :debug-name name))))
+  (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
 

@@ -547,7 +555,7 @@
   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) (sb!sys:parse-body body nil)
+  (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))
     (multiple-value-bind (vars values) (extract-let-vars bindings 'let)
       (let ((fun-cont (make-continuation)))
         (let* ((*lexenv* (process-decls decls vars nil cont))

@@ -563,7 +571,7 @@
   "LET* ({(Var [Value]) | Var}*) Declaration* Form*
   Similar to LET, but the variables are bound sequentially, allowing each Value
   form to reference any of the previous Vars."
   "LET* ({(Var [Value]) | Var}*) Declaration* Form*
   Similar to LET, but the variables are bound sequentially, allowing each Value
   form to reference any of the previous Vars."

-  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+  (multiple-value-bind (forms decls) (parse-body body nil)

     (multiple-value-bind (vars values) (extract-let-vars bindings 'let*)
       (let ((*lexenv* (process-decls decls vars nil cont)))
        (ir1-convert-aux-bindings start cont forms vars values)))))
     (multiple-value-bind (vars values) (extract-let-vars bindings 'let*)
       (let ((*lexenv* (process-decls decls vars nil cont)))
        (ir1-convert-aux-bindings start cont forms vars values)))))

@@ -575,10 +583,10 @@
 ;;; but we don't need to worry about that within an IR1 translator,
 ;;; since toplevel-formness is picked off by PROCESS-TOPLEVEL-FOO
 ;;; forms before we hit the IR1 transform level.
 ;;; but we don't need to worry about that within an IR1 translator,
 ;;; since toplevel-formness is picked off by PROCESS-TOPLEVEL-FOO
 ;;; forms before we hit the IR1 transform level.

-(defun ir1-translate-locally (body start cont)
+(defun ir1-translate-locally (body start cont &key vars funs)

   (declare (type list body) (type continuation start cont))
   (declare (type list body) (type continuation start cont))

-  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
-    (let ((*lexenv* (process-decls decls nil nil cont)))
+  (multiple-value-bind (forms decls) (parse-body body nil)
+    (let ((*lexenv* (process-decls decls vars funs cont)))

       (ir1-convert-aux-bindings start cont forms nil nil))))
 
 (def-ir1-translator locally ((&body body) start cont)
       (ir1-convert-aux-bindings start cont forms nil nil))))
 
 (def-ir1-translator locally ((&body body) start cont)

@@ -608,7 +616,7 @@
       (let ((name (first def)))
        (check-fun-name name)
        (names name)
       (let ((name (first def)))
        (check-fun-name name)
        (names name)

-       (multiple-value-bind (forms decls) (sb!sys:parse-body (cddr def))
+       (multiple-value-bind (forms decls) (parse-body (cddr def))

          (defs `(lambda ,(second def)
                   ,@decls
                   (block ,(fun-name-block-name name)
          (defs `(lambda ,(second def)
                   ,@decls
                   (block ,(fun-name-block-name name)

@@ -622,7 +630,7 @@
   Evaluate the Body-Forms with some local function definitions. The bindings
   do not enclose the definitions; any use of Name in the Forms will refer to
   the lexically apparent function definition in the enclosing environment."
   Evaluate the Body-Forms with some local function definitions. The bindings
   do not enclose the definitions; any use of Name in the Forms will refer to
   the lexically apparent function definition in the enclosing environment."

-  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+  (multiple-value-bind (forms decls) (parse-body body nil)

     (multiple-value-bind (names defs)
        (extract-flet-vars definitions 'flet)
       (let* ((fvars (mapcar (lambda (n d)
     (multiple-value-bind (names defs)
        (extract-flet-vars definitions 'flet)
       (let* ((fvars (mapcar (lambda (n d)

@@ -642,7 +650,7 @@
   Evaluate the Body-Forms with some local function definitions. The bindings
   enclose the new definitions, so the defined functions can call themselves or
   each other."
   Evaluate the Body-Forms with some local function definitions. The bindings
   enclose the new definitions, so the defined functions can call themselves or
   each other."

-  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+  (multiple-value-bind (forms decls) (parse-body body nil)

     (multiple-value-bind (names defs)
        (extract-flet-vars definitions 'labels)
       (let* (;; dummy LABELS functions, to be used as placeholders
     (multiple-value-bind (names defs)
        (extract-flet-vars definitions 'labels)
       (let* (;; dummy LABELS functions, to be used as placeholders

@@ -718,24 +726,24 @@
 ;;; We make this work by getting USE-CONTINUATION to do the unioning
 ;;; across COND branches. We can't do it here, since we don't know how
 ;;; many branches there are going to be.
 ;;; We make this work by getting USE-CONTINUATION to do the unioning
 ;;; across COND branches. We can't do it here, since we don't know how
 ;;; many branches there are going to be.

-(defun ir1ize-the-or-values (type cont lexenv name)
+(defun ir1ize-the-or-values (type cont lexenv place)

   (declare (type continuation cont) (type lexenv lexenv))
   (declare (type continuation cont) (type lexenv lexenv))

-  (let* ((ctype (values-specifier-type type))
+  (let* ((ctype (if (typep type 'ctype) type (compiler-values-specifier-type type)))

         (old-type (or (lexenv-find cont type-restrictions)
                       *wild-type*))
         (intersects (values-types-equal-or-intersect old-type ctype))
         (old-type (or (lexenv-find cont type-restrictions)
                       *wild-type*))
         (intersects (values-types-equal-or-intersect old-type ctype))

-        (int (values-type-intersection old-type ctype))
-        (new (if intersects int old-type)))
+        (new (values-type-intersection old-type ctype)))

     (when (null (find-uses cont))
       (setf (continuation-asserted-type cont) new))
     (when (and (not intersects)
     (when (null (find-uses cont))
       (setf (continuation-asserted-type cont) new))
     (when (and (not intersects)

+              ;; FIXME: Is it really right to look at *LEXENV* here,
+              ;; instead of looking at the LEXENV argument? Why?

               (not (policy *lexenv*
                            (= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
       (compiler-warn
               (not (policy *lexenv*
                            (= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
       (compiler-warn

-       "The type ~S in ~S declaration conflicts with an ~
-        enclosing assertion:~%   ~S"
+       "The type ~S ~A conflicts with an enclosing assertion:~%   ~S"

        (type-specifier ctype)
        (type-specifier ctype)

-       name
+       place

        (type-specifier old-type)))
     (make-lexenv :type-restrictions `((,cont . ,new))
                 :default lexenv)))
        (type-specifier old-type)))
     (make-lexenv :type-restrictions `((,cont . ,new))
                 :default lexenv)))

@@ -747,7 +755,8 @@
 ;;; this didn't seem to expand into an assertion, at least for ALIEN
 ;;; values. Check that SBCL doesn't have this problem.
 (def-ir1-translator the ((type value) start cont)
 ;;; this didn't seem to expand into an assertion, at least for ALIEN
 ;;; values. Check that SBCL doesn't have this problem.
 (def-ir1-translator the ((type value) start cont)

-  (let ((*lexenv* (ir1ize-the-or-values type cont *lexenv* 'the)))
+  (with-continuation-type-assertion (cont (compiler-values-specifier-type type)
+                                          "in THE declaration")

     (ir1-convert start cont value)))
 
 ;;; This is like the THE special form, except that it believes
     (ir1-convert start cont value)))
 
 ;;; This is like the THE special form, except that it believes

@@ -761,7 +770,7 @@
 (def-ir1-translator truly-the ((type value) start cont)
   #!+sb-doc
   (declare (inline member))
 (def-ir1-translator truly-the ((type value) start cont)
   #!+sb-doc
   (declare (inline member))

-  (let ((type (values-specifier-type type))
+  (let ((type (compiler-values-specifier-type type))

        (old (find-uses cont)))
     (ir1-convert start cont value)
     (do-uses (use cont)
        (old (find-uses cont)))
     (ir1-convert start cont value)
     (do-uses (use cont)

@@ -1009,7 +1018,10 @@
     (continuation-starts-block dummy-start)
     (ir1-convert start dummy-start result)
 
     (continuation-starts-block dummy-start)
     (ir1-convert start dummy-start result)
 

-    (substitute-continuation-uses cont dummy-start)
+    (with-continuation-type-assertion
+        (cont (continuation-asserted-type dummy-start)
+              "of the first form")
+      (substitute-continuation-uses cont dummy-start))

 
     (continuation-starts-block dummy-result)
     (ir1-convert-progn-body dummy-start dummy-result forms)
 
     (continuation-starts-block dummy-result)
     (ir1-convert-progn-body dummy-start dummy-result forms)

@@ -1045,79 +1057,6 @@
                (eq first 'original-source-start))
        (return path)))))
 
                (eq first 'original-source-start))
        (return path)))))
 

-;;; Warn about incompatible or illegal definitions and add the macro
-;;; to the compiler environment.
-;;;
-;;; Someday we could check for macro arguments being incompatibly
-;;; redefined. Doing this right will involve finding the old macro
-;;; lambda-list and comparing it with the new one.
-(def-ir1-translator %defmacro ((qname qdef lambda-list doc) start cont
-                              :kind :function)
-  (let (;; QNAME is typically a quoted name. I think the idea is to
-       ;; let %DEFMACRO work as an ordinary function when
-       ;; interpreting. Whatever the reason the quote is there, we
-       ;; don't want it any more. -- WHN 19990603
-       (name (eval qname))
-       ;; QDEF should be a sharp-quoted definition. We don't want to
-       ;; make a function of it just yet, so we just drop the
-       ;; sharp-quote.
-       (def (progn
-              (aver (eq 'function (first qdef)))
-              (aver (proper-list-of-length-p qdef 2))
-              (second qdef))))
-
-    (/show "doing IR1 translator for %DEFMACRO" name)
-
-    (unless (symbolp name)
-      (compiler-error "The macro name ~S is not a symbol." name))
-
-    (ecase (info :function :kind name)
-      ((nil))
-      (:function
-       (remhash name *free-funs*)
-       (undefine-fun-name name)
-       (compiler-warn
-       "~S is being redefined as a macro when it was ~
-         previously ~(~A~) to be a function."
-       name
-       (info :function :where-from name)))
-      (:macro)
-      (:special-form
-       (compiler-error "The special form ~S can't be redefined as a macro."
-                      name)))
-
-    (setf (info :function :kind name) :macro
-         (info :function :where-from name) :defined
-         (info :function :macro-function name) (coerce def 'function))
-
-    (let* ((*current-path* (revert-source-path 'defmacro))
-          (fun (ir1-convert-lambda def 
-                                   :debug-name (debug-namify "DEFMACRO ~S"
-                                                             name))))
-      (setf (functional-arg-documentation fun) (eval lambda-list))
-
-      (ir1-convert start cont `(%%defmacro ',name ,fun ,doc)))
-
-    (when sb!xc:*compile-print*
-      ;; FIXME: It would be nice to convert this, and the other places
-      ;; which create compiler diagnostic output prefixed by
-      ;; semicolons, to use some common utility which automatically
-      ;; prefixes all its output with semicolons. (The addition of
-      ;; semicolon prefixes was introduced ca. sbcl-0.6.8.10 as the
-      ;; "MNA compiler message patch", and implemented by modifying a
-      ;; bunch of output statements on a case-by-case basis, which
-      ;; seems unnecessarily error-prone and unclear, scattering
-      ;; implicit information about output style throughout the
-      ;; system.) Starting by rewriting COMPILER-MUMBLE to add
-      ;; semicolon prefixes would be a good start, and perhaps also:
-      ;;   * Add semicolon prefixes for "FOO assembled" messages emitted 
-      ;;     when e.g. src/assembly/x86/assem-rtns.lisp is processed.
-      ;;   * At least some debugger output messages deserve semicolon
-      ;;     prefixes too:
-      ;;     ** restarts table
-      ;;     ** "Within the debugger, you can type HELP for help."
-      (compiler-mumble "~&; converted ~S~%" name))))
-

 (def-ir1-translator %define-compiler-macro ((name def lambda-list doc)
                                            start cont
                                            :kind :function)
 (def-ir1-translator %define-compiler-macro ((name def lambda-list doc)
                                            start cont
                                            :kind :function)

@@ -1132,7 +1071,7 @@
          (coerce def 'function))
 
     (let* ((*current-path* (revert-source-path 'define-compiler-macro))
          (coerce def 'function))
 
     (let* ((*current-path* (revert-source-path 'define-compiler-macro))

-          (fun (ir1-convert-lambda def 
+          (fun (ir1-convert-lambda def

                                    :debug-name (debug-namify
                                                 "DEFINE-COMPILER-MACRO ~S"
                                                 name))))
                                    :debug-name (debug-namify
                                                 "DEFINE-COMPILER-MACRO ~S"
                                                 name))))