X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=8c11111fc10fb935a8ca1161facfc8529330a770;hb=96b310113978665980a8d65ad5dd83deab05c28b;hp=305306949503c8e5bb5d78dbcd00118a35d8001d;hpb=c713eb2b521b048ff2c927ec52b861787d289f85;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 3053069..8c11111 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -12,7 +12,7 @@ (in-package "SB!C") -;;;; control special forms +;;;; special forms for control (def-ir1-translator progn ((&rest forms) start cont) #!+sb-doc @@ -84,7 +84,6 @@ (push env-entry (continuation-lexenv-uses cont)) (ir1-convert-progn-body dummy cont forms)))) - (def-ir1-translator return-from ((name &optional value) start cont) #!+sb-doc "Return-From Block-Name Value-Form @@ -303,6 +302,9 @@ (compiler-error "The local symbol macro name ~S is not a symbol." name)) + (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)))) :vars definitions @@ -466,7 +468,7 @@ ;;; FUNCALL is implemented on %FUNCALL, which can only call functions ;;; (not symbols). %FUNCALL is used directly in some places where the ;;; call should always be open-coded even if FUNCALL is :NOTINLINE. -(deftransform funcall ((function &rest args) * * :when :both) +(deftransform funcall ((function &rest args) * *) (let ((arg-names (make-gensym-list (length args)))) `(lambda (function ,@arg-names) (%funcall ,(if (csubtypep (continuation-type function) @@ -491,7 +493,6 @@ (values nil t))) (deftransform %coerce-callable-to-fun ((thing) (function) * - :when :both :important t) "optimize away possible call to FDEFINITION at runtime" 'thing) @@ -546,7 +547,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)) @@ -562,7 +563,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))))) @@ -576,7 +577,7 @@ ;;; forms before we hit the IR1 transform level. (defun ir1-translate-locally (body start cont) (declare (type list body) (type continuation start cont)) - (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) + (multiple-value-bind (forms decls) (parse-body body nil) (let ((*lexenv* (process-decls decls nil nil cont))) (ir1-convert-aux-bindings start cont forms nil nil)))) @@ -607,7 +608,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) @@ -621,7 +622,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) @@ -641,7 +642,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 @@ -717,24 +718,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))) @@ -746,7 +747,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 @@ -760,7 +762,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) @@ -1008,7 +1010,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)