X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=14823c990497cb39229548b0ab8e3030a850bccc;hb=25070981025894faaef260a38b83fd0bbcfdc80d;hp=c06a99b4f99b06027aedeb13da36232bd012b170;hpb=f399a6fcad06989b7cb70c00fc7a4a4850a22ab8;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index c06a99b..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 @@ -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." - (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)) @@ -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." - (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))))) @@ -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) (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) @@ -608,7 +616,7 @@ (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) @@ -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." - (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) @@ -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." - (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 @@ -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. -(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)) - (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)) - (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) + ;; 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 - "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) - name + place (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) - (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 @@ -761,7 +770,7 @@ (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) @@ -1009,7 +1018,10 @@ (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) @@ -1045,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) @@ -1132,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))))