Skip to content
Snippets Groups Projects
Commit 30600409 authored by ram's avatar ram
Browse files

Changed :STRICT-RESULT conditionalization to see whether the policy

is unsafe before punting.
Fixed ASSERT-DEFINITION-TYPE to propagate the new type information to
any refs, and also to not set the type when the argument has sets.
parent 6ce8aec6
No related branches found
No related tags found
No related merge requests found
...@@ -85,9 +85,9 @@ ...@@ -85,9 +85,9 @@
;;; used to determine whether the result type matches the specified result. ;;; used to determine whether the result type matches the specified result.
;;; ;;;
;;; Unlike the argument test, the result test may be called on values or ;;; Unlike the argument test, the result test may be called on values or
;;; function types. If Strict-Result is true, then the Node-Derived-Type is ;;; function types. If Strict-Result is true and safety is non-zero, then the
;;; always used. If Strict-Result is false and Cont's Type-Check is true, then ;;; Node-Derived-Type is always used. Otherwise, if Cont's Type-Check is true,
;;; the Node-Derived-Type is intersected with the Cont's Asserted-Type. ;;; then the Node-Derived-Type is intersected with the Cont's Asserted-Type.
;;; ;;;
;;; The error and warning functions are functions that are called to explain ;;; The error and warning functions are functions that are called to explain
;;; the result. We bind *compiler-error-context* to the combination node so ;;; the result. We bind *compiler-error-context* to the combination node so
...@@ -142,7 +142,8 @@ ...@@ -142,7 +142,8 @@
(return-type (function-type-returns type)) (return-type (function-type-returns type))
(cont (node-cont call)) (cont (node-cont call))
(out-type (out-type
(if (or strict-result (not (continuation-type-check cont))) (if (or (not (continuation-type-check cont))
(and strict-result (policy call (/= safety 0))))
dtype dtype
(values-type-intersection (continuation-asserted-type cont) (values-type-intersection (continuation-asserted-type cont)
dtype)))) dtype))))
...@@ -760,13 +761,16 @@ ...@@ -760,13 +761,16 @@
(note-lossage (note-lossage
"The result type from ~A:~% ~S~@ "The result type from ~A:~% ~S~@
conflicts with the definition's result type assertion:~% ~S" conflicts with the definition's result type assertion:~% ~S"
where (type-specifier type-returns) (type-specifier atype))) where (type-specifier type-returns) (type-specifier atype))
nil)
(*lossage-detected* nil) (*lossage-detected* nil)
((not really-assert) t) ((not really-assert) t)
(t (t
(when atype (when atype
(assert-continuation-type (return-result return) atype)) (assert-continuation-type (return-result return) atype))
(mapc #'(lambda (var type) (loop for var in vars and type in types do
(setf (leaf-type var) type)) (unless (basic-var-sets var)
vars types) (setf (leaf-type var) type)
(dolist (ref (leaf-refs var))
(derive-node-type ref type))))
t)))))) t))))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment