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

Fixed GENERATE-TYPE-CHECKS to always give a warning when any use of

the continuation is incorrect, instead of only warning when the first
use happened to be incorrect.
parent c5c8ff2c
No related branches found
No related tags found
No related merge requests found
...@@ -399,46 +399,47 @@ ...@@ -399,46 +399,47 @@
(do-blocks (block component) (do-blocks (block component)
(when (block-type-check block) (when (block-type-check block)
(do-nodes (node cont block) (do-nodes (node cont block)
(when (eq (continuation-type-check cont) t) (let ((type-check (continuation-type-check cont)))
(unless (member type-check '(nil :error))
(let ((dtype (node-derived-type node))
(atype (continuation-asserted-type cont)))
(unless (values-types-intersect dtype atype)
(setf (continuation-%type-check cont) :error)
(let ((dest (continuation-dest cont)))
(when (and (combination-p dest)
(function-info-p (basic-combination-kind dest)))
(setf (basic-combination-kind dest) :full)))
(unless (policy node (= brevity 3))
(let ((*compiler-error-context* node))
(if (and (ref-p node) (constant-p (ref-leaf node)))
(compiler-warning "This is not a ~S:~% ~S"
(type-specifier atype)
(constant-value (ref-leaf node)))
(compiler-warning "Result is a ~S, not a ~S."
(type-specifier dtype)
(type-specifier atype))))))))
(let ((dtype (node-derived-type node)) (when (eq type-check t)
(atype (continuation-asserted-type cont))) (let ((check-p (probable-type-check-p cont)))
(unless (values-types-intersect dtype atype) (multiple-value-bind (check types)
(setf (continuation-%type-check cont) :error) (continuation-check-types cont)
(let ((dest (continuation-dest cont))) (ecase check
(when (and (combination-p dest) (:simple
(function-info-p (basic-combination-kind dest))) (unless check-p
(setf (basic-combination-kind dest) :full)))
(unless (policy node (= brevity 3))
(let ((*compiler-error-context* node))
(if (and (ref-p node) (constant-p (ref-leaf node)))
(compiler-warning "This is not a ~S:~% ~S"
(type-specifier atype)
(constant-value (ref-leaf node)))
(compiler-warning "Result is a ~S, not a ~S."
(type-specifier dtype)
(type-specifier atype)))))))
(let ((check-p (probable-type-check-p cont)))
(multiple-value-bind (check types)
(continuation-check-types cont)
(ecase check
(:simple
(unless check-p
(setf (continuation-%type-check cont) :no-check)))
(:hairy
(if check-p
(convert-type-check cont types)
(setf (continuation-%type-check cont) :no-check))) (setf (continuation-%type-check cont) :no-check)))
(:too-hairy (:hairy
(let* ((context (continuation-dest cont)) (if check-p
(*compiler-error-context* context)) (convert-type-check cont types)
(when (policy context (>= safety brevity)) (setf (continuation-%type-check cont) :no-check)))
(compiler-note (:too-hairy
"Type assertion too complex to check:~% ~S." (let* ((context (continuation-dest cont))
(type-specifier (continuation-asserted-type cont))))) (*compiler-error-context* context))
(setf (continuation-%type-check cont) :deleted))))))) (when (policy context (>= safety brevity))
(compiler-note
"Type assertion too complex to check:~% ~S."
(type-specifier (continuation-asserted-type cont)))))
(setf (continuation-%type-check cont) :deleted))))))))
(setf (block-type-check block) nil))) (setf (block-type-check block) nil)))
(undefined-value)) (undefined-value))
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