diff options
| -rw-r--r-- | src/compiler/constraint-back.lisp | 35 | ||||
| -rw-r--r-- | tests/constraint.pure.lisp | 7 |
2 files changed, 20 insertions, 22 deletions
diff --git a/src/compiler/constraint-back.lisp b/src/compiler/constraint-back.lisp index a7d8bdb7f..614a49bbf 100644 --- a/src/compiler/constraint-back.lisp +++ b/src/compiler/constraint-back.lisp @@ -17,14 +17,18 @@ :exit-if-null)) (funcall propagate node nth-value kind constraint gen consequent alternative))))) +(defun add-back-constraint (gen kind x y target) + (when x + (let ((var (ok-lvar-lambda-var x gen))) + (if var + (conset-add-constraint-to-eql gen kind var y nil target) + (constraint-propagate-back x kind y gen target nil))))) + (defun numeric-contagion-constraint-back (x y gen constraint consequent &optional complex-p (x-type (lvar-type x)) (y-type (lvar-type y))) (flet ((add (lvar type) - (let ((var (and lvar - (ok-lvar-lambda-var lvar gen)))) - (when var - (conset-add-constraint-to-eql gen 'typep var type nil consequent))))) + (add-back-constraint gen 'typep lvar type consequent))) (let ((real-type (if complex-p ;; complex rationals multiplied by 0 will produce an integer 0. (specifier-type '(and real (not (eql 0)))) (specifier-type 'real)))) @@ -88,9 +92,7 @@ ;; (integerp (+ integer y)) means Y is an integer too. ;; (integerp (+ y-real x-real)) means X and Y are rational. (flet ((add (lvar type) - (let ((var (ok-lvar-lambda-var lvar gen))) - (when var - (conset-add-constraint-to-eql gen 'typep var type nil consequent))))) + (add-back-constraint gen 'typep lvar type consequent))) (cond ((and (csubtypep constraint (specifier-type 'integer)) (let ((x-integerp (csubtypep (lvar-type x) (specifier-type 'integer))) (y-integerp (csubtypep (lvar-type y) (specifier-type 'integer)))) @@ -114,10 +116,7 @@ (case kind (typep (flet ((add (lvar type) - (let ((var (and lvar - (ok-lvar-lambda-var lvar gen)))) - (when var - (conset-add-constraint-to-eql gen 'typep var type nil consequent))))) + (add-back-constraint gen 'typep lvar type consequent))) (cond ((and (csubtypep constraint (specifier-type 'integer)) (let ((x-integerp (csubtypep x-type (specifier-type 'integer))) (y-integerp (csubtypep y-type (specifier-type 'integer)))) @@ -152,9 +151,7 @@ (case kind (typep (flet ((add (lvar type) - (let ((var (ok-lvar-lambda-var lvar gen))) - (when var - (conset-add-constraint-to-eql gen 'typep var type nil consequent))))) + (add-back-constraint gen 'typep lvar type consequent))) (let ((complex-p (or (types-equal-or-intersect (lvar-type x) (specifier-type 'complex)) (types-equal-or-intersect (lvar-type y) (specifier-type 'complex))))) (cond ((and @@ -237,10 +234,7 @@ (let ((range (type-approximate-interval (lvar-type constraint)))) (when (and range (numberp (interval-high range))) - (let ((var (ok-lvar-lambda-var x gen))) - (when var - (conset-add-constraint-to-eql gen 'typep var (specifier-type `(rational (,(- (interval-high range))))) - nil consequent))))))) + (add-back-constraint gen 'typep x (specifier-type `(rational (,(- (interval-high range))))) consequent))))) (typep (-constraint-propagate-back nil x (specifier-type '(eql 0)) (lvar-type x) kind constraint gen consequent)))) @@ -249,10 +243,7 @@ (case kind (typep (flet ((add (lvar type) - (let ((var (and lvar - (ok-lvar-lambda-var lvar gen)))) - (when var - (conset-add-constraint-to-eql gen 'typep var type nil consequent))))) + (add-back-constraint gen 'typep lvar type consequent))) (cond ((csubtypep constraint (specifier-type 'integer)) (let ((int (type-approximate-interval constraint t))) (add x (specifier-type (if (and int diff --git a/tests/constraint.pure.lisp b/tests/constraint.pure.lisp index 350f09d7a..5f3ca3935 100644 --- a/tests/constraint.pure.lisp +++ b/tests/constraint.pure.lisp @@ -1775,3 +1775,10 @@ m)) t)) (eql t))) + +(with-test (:name :multiple-back) + (assert-type + (lambda (m) + (the (integer 0 30) (+ (* m 2) 2)) + m) + (rational -1 14))) |