0.7.9.7:

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

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index a3a4e1e..09ad701 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,33 +250,46 @@
     (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
+;;; Tweak LEXENV to include the DEFINITIONS from a MACROLET, then

 ;;; call FUN (with no arguments).
 ;;;
 ;;; This is split off from the IR1 convert method so that it can be
 ;;; call FUN (with no arguments).
 ;;;
 ;;; This is split off from the IR1 convert method so that it can be

-;;; shared by the special-case top level MACROLET processing code.
+;;; shared by the special-case top level MACROLET processing code, and
+;;; further split so that the special-case MACROLET processing code in
+;;; EVAL can likewise make use of it.
+(defmacro macrolet-definitionize-fun (context lexenv)
+  (flet ((make-error-form (control &rest args)
+          (ecase context
+            (:compile `(compiler-error ,control ,@args))
+            (:eval `(error 'simple-program-error
+                     :format-control ,control
+                     :format-arguments (list ,@args))))))
+    `(lambda (definition)
+      (unless (list-of-length-at-least-p definition 2)
+       ,(make-error-form "The list ~S is too short to be a legal local macro definition." 'definition))
+      (destructuring-bind (name arglist &body body) definition
+       (unless (symbolp name)
+         ,(make-error-form "The local macro name ~S is not a symbol." 'name))
+       (unless (listp arglist)
+         ,(make-error-form "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 .
+             ,(compile-in-lexenv
+               nil
+               `(lambda (,whole ,environment)
+                 ,@local-decls
+                 (block ,name ,body))
+               ,lexenv))))))))
+

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

-   (lambda (definition)
-     (unless (list-of-length-at-least-p definition 2)
-       (compiler-error
-       "The list ~S is too short to be a legal local macro definition."
-       definition))
-     (destructuring-bind (name arglist &body body) definition
-       (unless (symbolp name)
-        (compiler-error "The local macro name ~S is not a symbol." name))
-       (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))))))))
+   (macrolet-definitionize-fun :compile (make-restricted-lexenv *lexenv*))

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

@@ -288,28 +301,41 @@
   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
-   (lambda (definition)
-     (unless (proper-list-of-length-p definition 2)
-       (compiler-error "malformed symbol/expansion pair: ~S" definition))
+(defmacro symbol-macrolet-definitionize-fun (context)
+  (flet ((make-error-form (control &rest args)
+          (ecase context
+            (:compile `(compiler-error ,control ,@args))
+            (:eval `(error 'simple-program-error
+                     :format-control ,control
+                     :format-arguments (list ,@args))))))
+    `(lambda (definition)
+      (unless (proper-list-of-length-p definition 2)
+       ,(make-error-form "malformed symbol/expansion pair: ~S" 'definition))

      (destructuring-bind (name expansion) definition
        (unless (symbolp name)
      (destructuring-bind (name expansion) definition
        (unless (symbolp name)

-         (compiler-error
-          "The local symbol macro name ~S is not a symbol."
-          name))
+         ,(make-error-form
+          "The local symbol macro name ~S is not a symbol."
+          'name))

        (let ((kind (info :variable :kind name)))
         (when (member kind '(:special :constant))
        (let ((kind (info :variable :kind name)))
         (when (member kind '(:special :constant))

-          (compiler-error "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" kind name)))
-       `(,name . (MACRO . ,expansion))))
+          ,(make-error-form
+            "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S"
+            'kind 'name)))
+       `(,name . (MACRO . ,expansion))))))1
+
+(defun funcall-in-symbol-macrolet-lexenv (definitions fun)
+  (%funcall-in-foomacrolet-lexenv
+   (symbol-macrolet-definitionize-fun :compile)

    :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 +343,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 +481,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
 

@@ -575,10 +603,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))
   (multiple-value-bind (forms decls) (parse-body body nil)
   (declare (type list body) (type continuation start cont))
   (multiple-value-bind (forms decls) (parse-body body nil)

-    (let ((*lexenv* (process-decls decls nil nil cont)))
+    (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)

@@ -720,7 +748,7 @@
 ;;; many branches there are going to be.
 (defun ir1ize-the-or-values (type cont lexenv place)
   (declare (type continuation cont) (type lexenv lexenv))
 ;;; many branches there are going to be.
 (defun ir1ize-the-or-values (type cont lexenv place)
   (declare (type continuation cont) (type lexenv lexenv))

-  (let* ((ctype (if (typep type 'ctype) type (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))

@@ -747,7 +775,7 @@
 ;;; 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)

-  (with-continuation-type-assertion (cont (values-specifier-type type)
+  (with-continuation-type-assertion (cont (compiler-values-specifier-type type)

                                           "in THE declaration")
     (ir1-convert start cont value)))
 
                                           "in THE declaration")
     (ir1-convert start cont value)))
 

@@ -762,7 +790,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)

@@ -1049,79 +1077,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)

@@ -1136,7 +1091,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))))