[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/native-comp 8c7228e: Fix = propagation semantic for constrained
From: |
Andrea Corallo |
Subject: |
feature/native-comp 8c7228e: Fix = propagation semantic for constrained inputs |
Date: |
Tue, 2 Mar 2021 08:45:33 -0500 (EST) |
branch: feature/native-comp
commit 8c7228e8cde9a33f8128933f991f6432e58cfde3
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>
Fix = propagation semantic for constrained inputs
* lisp/emacs-lisp/comp-cstr.el (comp-cstr): Synthesize
`comp-cstr-shallow-copy'.
(comp-cstr-=): Relax inputs before intersecting them.
* test/src/comp-tests.el (comp-tests-type-spec-tests): Add three
tests.
---
lisp/emacs-lisp/comp-cstr.el | 41 ++++++++++++++++++++++++++++++-----------
test/src/comp-tests.el | 29 ++++++++++++++++++++++++++++-
2 files changed, 58 insertions(+), 12 deletions(-)
diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index d98ef68..996502b 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -71,7 +71,7 @@
(irange &aux
(range (list irange))
(typeset ())))
- (:copier nil))
+ (:copier comp-cstr-shallow-copy))
"Internal representation of a type/value constraint."
(typeset '(t) :type list
:documentation "List of possible types the mvar can assume.
@@ -859,17 +859,36 @@ Non memoized version of `comp-cstr-intersection-no-mem'."
(null (neg cstr))
(equal (typeset cstr) '(cons)))))
-(defun comp-cstr-= (dst old-dst src)
- "Constraint DST being = SRC."
+(defun comp-cstr-= (dst op1 op2)
+ "Constraint OP1 being = OP2 setting the result into DST."
(with-comp-cstr-accessors
- (comp-cstr-intersection dst old-dst src)
- (cl-loop for v in (valset dst)
- when (and (floatp v)
- (= v (truncate v)))
- do (push (cons (truncate v) (truncate v)) (range dst)))
- (cl-loop for (l . h) in (range dst)
- when (eql l h)
- do (push (float l) (valset dst)))))
+ (cl-flet ((relax-cstr (cstr)
+ (setf cstr (comp-cstr-shallow-copy cstr))
+ ;; If can be any float extend it to all integers.
+ (when (memq 'float (typeset cstr))
+ (setf (range cstr) '((- . +))))
+ ;; For each float value that can be represented
+ ;; precisely as an integer add the integer as well.
+ (cl-loop
+ for v in (valset cstr)
+ when (and (floatp v)
+ (= v (truncate v)))
+ do (push (cons (truncate v) (truncate v)) (range cstr)))
+ (cl-loop
+ with vals-to-add
+ for (l . h) in (range cstr)
+ ;; If an integer range reduces to single value add
+ ;; its float value too.
+ if (eql l h)
+ do (push (float l) vals-to-add)
+ ;; Otherwise can be any float.
+ else
+ do (cl-pushnew 'float (typeset cstr))
+ (cl-return cstr)
+ finally (setf (valset cstr)
+ (append vals-to-add (valset cstr))))
+ cstr))
+ (comp-cstr-intersection dst (relax-cstr op1) (relax-cstr op2)))))
(defun comp-cstr-> (dst old-dst src)
"Constraint DST being > than SRC.
diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index 651df33..3f007d2 100644
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -1293,7 +1293,34 @@ Return a list of results."
(if (equal x '(1 2 3))
x
(error "")))
- cons)))
+ cons)
+
+ ;; 69
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (and (floatp x)
+ (= x 0))
+ x
+ (error "")))
+ ;; Conservative (see cstr relax in `comp-cstr-=').
+ (or (member 0.0) (integer 0 0)))
+
+ ;; 70
+ ((defun comp-tests-ret-type-spec-f (x)
+ (if (and (integer x)
+ (= x 0))
+ x
+ (error "")))
+ ;; Conservative (see cstr relax in `comp-cstr-=').
+ (or (member 0.0) (integer 0 0)))
+
+ ;; 71
+ ((defun comp-tests-ret-type-spec-f (x y)
+ (if (and (floatp x)
+ (integerp y)
+ (= x y))
+ x
+ (error "")))
+ (or float integer))))
(defun comp-tests-define-type-spec-test (number x)
`(comp-deftest ,(intern (format "ret-type-spec-%d" number)) ()
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- feature/native-comp 8c7228e: Fix = propagation semantic for constrained inputs,
Andrea Corallo <=