X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=14823c990497cb39229548b0ab8e3030a850bccc;hb=25070981025894faaef260a38b83fd0bbcfdc80d;hp=8c11111fc10fb935a8ca1161facfc8529330a770;hpb=dea9bd5c1afe23d9e061c60db654b88187ba9a5e;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 8c11111..14823c9 100644 --- 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) - + (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)) - (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) @@ -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 -;;; 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* @@ -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))) - (funcall fun))) + (funcall fun definitionize-keyword processed-definitions))) ;;; 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)) + (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 . - ,(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)) @@ -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." - (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 @@ -309,7 +315,7 @@ :vars definitions fun)) - + (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 - (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) @@ -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) - (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)) ;;;; FUNCALL @@ -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. -(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) - (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) @@ -1049,79 +1057,6 @@ (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) @@ -1136,7 +1071,7 @@ (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))))