X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=307d76224d37b334e6ab3e26e27a0f5956793abe;hb=204f2fa9771ad9e55718dc76205afec7d11b3011;hp=5752d6e8ff470d648e11122ede160aa050892042;hpb=54a2e62234dc9a399ae12e56fe212d2137b43556;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 5752d6e..307d762 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -829,7 +829,7 @@ type (type-approx-intersection2 old-type type)))) (cond ((eq int *empty-type*) - (unless (policy nil (= inhibit-warnings 3)) + (unless (policy *lexenv* (= inhibit-warnings 3)) (compiler-warning "The type declarations ~S and ~S for ~S conflict." (type-specifier old-type) (type-specifier type) @@ -937,7 +937,7 @@ name "in an inline or notinline declaration"))) (etypecase found (functional - (when (policy nil (>= speed inhibit-warnings)) + (when (policy *lexenv* (>= speed inhibit-warnings)) (compiler-note "ignoring ~A declaration not at ~ definition of local function:~% ~S" sense name))) @@ -1018,12 +1018,6 @@ (make-lexenv :default res :policy (process-optimize-decl spec (lexenv-policy res)))) - (optimize-interface - (make-lexenv - :default res - :interface-policy (process-optimize-decl - spec - (lexenv-interface-policy res)))) (type (process-type-decl (cdr spec) res vars)) (values @@ -1035,7 +1029,7 @@ `(values ,@types)) cont res 'values)))) (dynamic-extent - (when (policy nil (> speed inhibit-warnings)) + (when (policy *lexenv* (> speed inhibit-warnings)) (compiler-note "compiler limitation:~ ~% There's no special support for DYNAMIC-EXTENT (so it's ignored).")) @@ -1274,26 +1268,18 @@ ;;; sequentially bind each AUX-VAR to the corresponding AUX-VAL before ;;; converting the body. If there are no bindings, just convert the ;;; body, otherwise do one binding and recurse on the rest. -;;; -;;; If INTERFACE is true, then we convert bindings with the interface -;;; policy. For real &AUX bindings, and for implicit aux bindings -;;; introduced by keyword bindings, this is always true. It is only -;;; false when LET* directly calls this function. -(defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals interface) +(defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals) (declare (type continuation start cont) (list body aux-vars aux-vals)) (if (null aux-vars) (ir1-convert-progn-body start cont body) (let ((fun-cont (make-continuation)) - (fun (ir1-convert-lambda-body body (list (first aux-vars)) - (rest aux-vars) (rest aux-vals) - interface))) + (fun (ir1-convert-lambda-body body + (list (first aux-vars)) + :aux-vars (rest aux-vars) + :aux-vals (rest aux-vals)))) (reference-leaf start fun-cont fun) - (let ((*lexenv* (if interface - (make-lexenv - :policy (make-interface-policy *lexenv*)) - *lexenv*))) - (ir1-convert-combination-args fun-cont cont - (list (first aux-vals)))))) + (ir1-convert-combination-args fun-cont cont + (list (first aux-vals))))) (values)) ;;; This is similar to IR1-CONVERT-PROGN-BODY except that code to bind @@ -1307,13 +1293,12 @@ ;;; will end up being the innermost one. We force CONT to start a ;;; block outside of this cleanup, causing cleanup code to be emitted ;;; when the scope is exited. -(defun ir1-convert-special-bindings (start cont body aux-vars aux-vals - interface svars) +(defun ir1-convert-special-bindings (start cont body aux-vars aux-vals svars) (declare (type continuation start cont) (list body aux-vars aux-vals svars)) (cond ((null svars) - (ir1-convert-aux-bindings start cont body aux-vars aux-vals interface)) + (ir1-convert-aux-bindings start cont body aux-vars aux-vals)) (t (continuation-starts-block cont) (let ((cleanup (make-cleanup :kind :special-bind)) @@ -1326,7 +1311,7 @@ (let ((*lexenv* (make-lexenv :cleanup cleanup))) (ir1-convert next-cont nnext-cont '(%cleanup-point)) (ir1-convert-special-bindings nnext-cont cont body aux-vars aux-vals - interface (rest svars)))))) + (rest svars)))))) (values)) ;;; Create a lambda node out of some code, returning the result. The @@ -1345,11 +1330,8 @@ ;;; ;;; AUX-VARS is a list of VAR structures for variables that are to be ;;; sequentially bound. Each AUX-VAL is a form that is to be evaluated -;;; to get the initial value for the corresponding AUX-VAR. Interface -;;; is a flag as T when there are real aux values (see LET* and -;;; IR1-CONVERT-AUX-BINDINGS.) -(defun ir1-convert-lambda-body (body vars &optional aux-vars aux-vals - interface result) +;;; to get the initial value for the corresponding AUX-VAR. +(defun ir1-convert-lambda-body (body vars &key aux-vars aux-vals result) (declare (list body vars aux-vars aux-vals) (type (or continuation null) result)) (let* ((bind (make-bind)) @@ -1381,7 +1363,7 @@ (prev-link bind cont1) (use-continuation bind cont2) (ir1-convert-special-bindings cont2 result body aux-vars aux-vals - interface (svars))) + (svars))) (let ((block (continuation-block result))) (when block @@ -1409,8 +1391,6 @@ ;;; then we mark the corresponding var as EVER-USED to inhibit ;;; "defined but not read" warnings for arguments that are only used ;;; by default forms. -;;; -;;; We bind *LEXENV* to change the policy to the interface policy. (defun convert-optional-entry (fun vars vals defaults) (declare (type clambda fun) (list vars vals defaults)) (let* ((fvars (reverse vars)) @@ -1423,14 +1403,14 @@ :where-from (leaf-where-from var) :specvar (lambda-var-specvar var))) fvars)) - (*lexenv* (make-lexenv :policy (make-interface-policy *lexenv*))) (fun - (ir1-convert-lambda-body - `((%funcall ,fun ,@(reverse vals) ,@defaults)) - arg-vars))) - (mapc #'(lambda (var arg-var) - (when (cdr (leaf-refs arg-var)) - (setf (leaf-ever-used var) t))) + (ir1-convert-lambda-body `((%funcall ,fun + ,@(reverse vals) + ,@defaults)) + arg-vars))) + (mapc (lambda (var arg-var) + (when (cdr (leaf-refs arg-var)) + (setf (leaf-ever-used var) t))) fvars arg-vars) fun)) @@ -1497,10 +1477,6 @@ ;;; ;;; We deal with :ALLOW-OTHER-KEYS by delaying unknown keyword errors ;;; until we have scanned all the keywords. -;;; -;;; When converting the function, we bind *LEXENV* to change the -;;; compilation policy over to the interface policy, so that keyword -;;; args will be checked even when type checking isn't on in general. (defun convert-more-entry (res entry-vars entry-vals rest morep keys) (declare (type optional-dispatch res) (list entry-vars entry-vals keys)) (collect ((arg-vars) @@ -1517,8 +1493,7 @@ (context-temp (make-lambda-var :name n-context)) (n-count (gensym "N-COUNT-")) (count-temp (make-lambda-var :name n-count - :type (specifier-type 'index))) - (*lexenv* (make-lexenv :policy (make-interface-policy *lexenv*)))) + :type (specifier-type 'index)))) (arg-vars context-temp count-temp) @@ -1535,7 +1510,7 @@ (n-allowp (gensym "N-ALLOWP-")) (n-losep (gensym "N-LOSEP-")) (allowp (or (optional-dispatch-allowp res) - (policy nil (zerop safety))))) + (policy *lexenv* (zerop safety))))) (temps `(,n-index (1- ,n-count)) n-key n-value-temp) (body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp))) @@ -1596,7 +1571,7 @@ (values)) -;;; This is called by IR1-Convert-Hairy-Args when we run into a &REST +;;; This is called by IR1-CONVERT-HAIRY-ARGS when we run into a &REST ;;; or &KEY arg. The arguments are similar to that function, but we ;;; split off any &REST arg and pass it in separately. REST is the ;;; &REST arg var, or NIL if there is no &REST arg. KEYS is a list of @@ -1670,11 +1645,11 @@ (main-vals (arg-info-default info)) (bind-vals n-val))))) - (let* ((main-entry (ir1-convert-lambda-body body (main-vars) - (append (bind-vars) aux-vars) - (append (bind-vals) aux-vals) - t - cont)) + (let* ((main-entry (ir1-convert-lambda-body + body (main-vars) + :aux-vars (append (bind-vars) aux-vars) + :aux-vals (append (bind-vals) aux-vals) + :result cont)) (last-entry (convert-optional-entry main-entry default-vars (main-vals) ()))) (setf (optional-dispatch-main-entry res) main-entry) @@ -1691,29 +1666,30 @@ ;;; arguments, analyzing the arglist on the way down and generating entry ;;; points on the way up. ;;; -;;; Default-Vars is a reversed list of all the argument vars processed so -;;; far, including supplied-p vars. Default-Vals is a list of the names of the -;;; Default-Vars. +;;; Default-Vars is a reversed list of all the argument vars processed +;;; so far, including supplied-p vars. Default-Vals is a list of the +;;; names of the Default-Vars. ;;; -;;; Entry-Vars is a reversed list of processed argument vars, excluding -;;; supplied-p vars. Entry-Vals is a list things that can be evaluated to get -;;; the values for all the vars from the Entry-Vars. It has the var name for -;;; each required or optional arg, and has T for each supplied-p arg. +;;; Entry-Vars is a reversed list of processed argument vars, +;;; excluding supplied-p vars. Entry-Vals is a list things that can be +;;; evaluated to get the values for all the vars from the Entry-Vars. +;;; It has the var name for each required or optional arg, and has T +;;; for each supplied-p arg. ;;; -;;; Vars is a list of the Lambda-Var structures for arguments that haven't -;;; been processed yet. Supplied-p-p is true if a supplied-p argument has -;;; already been processed; only in this case are the Default-XXX and Entry-XXX -;;; different. +;;; Vars is a list of the Lambda-Var structures for arguments that +;;; haven't been processed yet. Supplied-p-p is true if a supplied-p +;;; argument has already been processed; only in this case are the +;;; Default-XXX and Entry-XXX different. ;;; -;;; The result at each point is a lambda which should be called by the above -;;; level to default the remaining arguments and evaluate the body. We cause -;;; the body to be evaluated by converting it and returning it as the result -;;; when the recursion bottoms out. +;;; The result at each point is a lambda which should be called by the +;;; above level to default the remaining arguments and evaluate the +;;; body. We cause the body to be evaluated by converting it and +;;; returning it as the result when the recursion bottoms out. ;;; -;;; Each level in the recursion also adds its entry point function to the -;;; result Optional-Dispatch. For most arguments, the defaulting function and -;;; the entry point function will be the same, but when supplied-p args are -;;; present they may be different. +;;; Each level in the recursion also adds its entry point function to +;;; the result Optional-Dispatch. For most arguments, the defaulting +;;; function and the entry point function will be the same, but when +;;; supplied-p args are present they may be different. ;;; ;;; When we run into a &REST or &KEY arg, we punt out to ;;; IR1-CONVERT-MORE, which finishes for us in this case. @@ -1733,7 +1709,9 @@ nil nil nil vars supplied-p-p body aux-vars aux-vals cont) (let ((fun (ir1-convert-lambda-body body (reverse default-vars) - aux-vars aux-vals t cont))) + :aux-vars aux-vars + :aux-vals aux-vals + :result cont))) (setf (optional-dispatch-main-entry res) fun) (push (if supplied-p-p (convert-optional-entry fun entry-vars entry-vals ()) @@ -1779,9 +1757,9 @@ aux-vals cont))))))) ;;; This function deals with the case where we have to make an -;;; Optional-Dispatch to represent a lambda. We cons up the result and call -;;; IR1-Convert-Hairy-Args to do the work. When it is done, we figure out the -;;; min-args and max-args. +;;; Optional-Dispatch to represent a lambda. We cons up the result and +;;; call IR1-CONVERT-HAIRY-ARGS to do the work. When it is done, we +;;; figure out the min-args and max-args. (defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals cont) (declare (list body vars aux-vars aux-vals) (type continuation cont)) (let ((res (make-optional-dispatch :arglist vars @@ -1833,8 +1811,10 @@ (ir1-convert-hairy-lambda forms vars keyp allow-other-keys aux-vars aux-vals cont) - (ir1-convert-lambda-body forms vars aux-vars aux-vals - t cont)))) + (ir1-convert-lambda-body forms vars + :aux-vars aux-vars + :aux-vals aux-vals + :result cont)))) (setf (functional-inline-expansion res) form) (setf (functional-arg-documentation res) (cadr form)) (setf (leaf-name res) name) @@ -2452,7 +2432,7 @@ (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) (multiple-value-bind (vars values) (extract-let-variables bindings 'let*) (let ((*lexenv* (process-decls decls vars nil cont))) - (ir1-convert-aux-bindings start cont forms vars values nil))))) + (ir1-convert-aux-bindings start cont forms vars values))))) ;;; This is a lot like a LET* with no bindings. Unlike LET*, LOCALLY ;;; has to preserves top-level-formness, but we don't need to worry @@ -2468,7 +2448,7 @@ the Forms are also processed as top-level forms." (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) (let ((*lexenv* (process-decls decls nil nil cont))) - (ir1-convert-aux-bindings start cont forms nil nil nil)))) + (ir1-convert-aux-bindings start cont forms nil nil)))) ;;;; FLET and LABELS @@ -2586,13 +2566,14 @@ (let* ((ctype (values-specifier-type type)) (old-type (or (lexenv-find cont type-restrictions) *wild-type*)) - (intersects (values-types-intersect old-type ctype)) + (intersects (values-types-equal-or-intersect old-type ctype)) (int (values-type-intersection old-type ctype)) (new (if intersects int old-type))) (when (null (find-uses cont)) (setf (continuation-asserted-type cont) new)) (when (and (not intersects) - (not (policy nil (= inhibit-warnings 3)))) ;FIXME: really OK to suppress? + (not (policy *lexenv* + (= inhibit-warnings 3)))) ;FIXME: really OK to suppress? (compiler-warning "The type ~S in ~S declaration conflicts with an enclosing assertion:~% ~S" (type-specifier ctype) @@ -3018,8 +2999,7 @@ `(,(car x) . (macro . ,(coerce (cdr x) 'function)))) macros) - :policy (lexenv-policy *lexenv*) - :interface-policy (lexenv-interface-policy *lexenv*)))) + :policy (lexenv-policy *lexenv*)))) (ir1-convert-lambda `(lambda ,@body) name)))) ;;; Return a lambda that has been "closed" with respect to ENV, @@ -3115,9 +3095,6 @@ ;; 3.2.2.3 of the spec) but at least as of sbcl-0.6.11, we don't ;; keep track of whether the mismatched data came from the same ;; compilation unit, so we can't do that. -- WHN 2001-02-11 - ;; - ;; FIXME: Actually, I think we could issue a full WARNING if the - ;; new definition contradicts a DECLAIM FTYPE. :error-function #'compiler-style-warning :warning-function (cond (info #'compiler-style-warning) (for-real #'compiler-note)