Add sum/subtraction integer range propagation support

	* lisp/emacs-lisp/comp-cstr.el (comp-range-+, comp-range--): New
	functions.
	(comp-cstr-set-range-for-arithm): New macro.
	(comp-cstr-add-2, comp-cstr-sub-2, comp-cstr-add, comp-cstr-sub):
	New function.
	* lisp/emacs-lisp/comp.el (comp-fwprop-call): Wire-up + - integer
	range propagation.

diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index d41501e680448df881210d15761c23fcceee2298..28cffcf0661abee7e334dc4f2a211d637898835b 100644 (file)
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -280,6 +280,22 @@ Return them as multiple value."
       x
     (1- x)))
 
+(defsubst comp-range-+ (x y)
+  (pcase (cons x y)
+    ((or '(+ . -) '(- . +)) '??)
+    ((or `(- . ,_) `(,_ . -)) '-)
+    ((or `(+ . ,_) `(,_ . +)) '+)
+    (_ (+ x y))))
+
+(defsubst comp-range-- (x y)
+  (pcase (cons x y)
+    ((or '(+ . +) '(- . -)) '??)
+    ('(+ . -) '+)
+    ('(- . +) '-)
+    ((or `(+ . ,_) `(,_ . -)) '+)
+    ((or `(- . ,_) `(,_ . +)) '-)
+    (_ (- x y))))
+
 (defsubst comp-range-< (x y)
   (cond
    ((eq x '+) nil)
@@ -389,6 +405,39 @@ Return them as multiple value."
             (range dst) (range old-dst)
             (neg dst) (neg old-dst)))))
 
+(defmacro comp-cstr-set-range-for-arithm (dst src1 src2 &rest range-body)
+  ;; Prevent some code duplication for `comp-cstr-add-2'
+  ;; `comp-cstr-sub-2'.
+  (declare (debug (range-body))
+           (indent defun))
+  `(with-comp-cstr-accessors
+     (when-let ((r1 (range ,src1))
+                (r2 (range ,src2)))
+       (let* ((l1 (comp-cstr-smallest-in-range r1))
+              (l2 (comp-cstr-smallest-in-range r2))
+              (h1 (comp-cstr-greatest-in-range r1))
+              (h2 (comp-cstr-greatest-in-range r2)))
+         (setf (typeset ,dst) (when (cl-some (lambda (x)
+                                               (comp-subtype-p 'float x))
+                                             (append (typeset src1)
+                                                     (typeset src2)))
+                                '(float))
+               (range ,dst) ,@range-body)))))
+
+(defun comp-cstr-add-2 (dst src1 src2)
+  "Sum SRC1 and SRC2 into DST."
+  (comp-cstr-set-range-for-arithm dst src1 src2
+    `((,(comp-range-+ l1 l2) . ,(comp-range-+ h1 h2)))))
+
+(defun comp-cstr-sub-2 (dst src1 src2)
+  "Subtract SRC1 and SRC2 into DST."
+  (comp-cstr-set-range-for-arithm dst src1 src2
+    (let ((l (comp-range-- l1 h2))
+          (h (comp-range-- h1 l2)))
+      (if (or (eq l '??) (eq h '??))
+          '((- . +))
+        `((,l . ,h))))))
+
 \f
 ;;; Union specific code.
 
@@ -742,6 +791,20 @@ SRC can be either a comp-cstr or an integer."
                `((- . ,low))))))
       (comp-cstr-set-cmp-range dst old-dst ext-range))))
 
+(defun comp-cstr-add (dst srcs)
+  "Sum SRCS into DST."
+  (comp-cstr-add-2 dst (cl-first srcs) (cl-second srcs))
+  (cl-loop
+   for src in (nthcdr 2 srcs)
+   do (comp-cstr-add-2 dst dst src)))
+
+(defun comp-cstr-sub (dst srcs)
+  "Subtract SRCS into DST."
+  (comp-cstr-sub-2 dst (cl-first srcs) (cl-second srcs))
+  (cl-loop
+   for src in (nthcdr 2 srcs)
+   do (comp-cstr-sub-2 dst dst src)))
+
 (defun comp-cstr-union-no-range (dst &rest srcs)
   "Combine SRCS by union set operation setting the result in DST.
 Do not propagate the range component.

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 936e47ff39aadbfb6a98ac6e29b1f1cad7f11047..336ed39145d1510c816cc782aa5204ef887a0453 100644 (file)
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -2648,7 +2648,10 @@ Fold the call in case."
         (setf (comp-mvar-range lval) (comp-cstr-range cstr)
               (comp-mvar-valset lval) (comp-cstr-valset cstr)
               (comp-mvar-typeset lval) (comp-cstr-typeset cstr)
-              (comp-mvar-neg lval) (comp-cstr-neg cstr))))))
+              (comp-mvar-neg lval) (comp-cstr-neg cstr))))
+    (cl-case f
+      (+ (comp-cstr-add lval args))
+      (- (comp-cstr-sub lval args)))))
 
 (defun comp-fwprop-insn (insn)
   "Propagate within INSN."

diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index 446c30666f0d365bd1c8b5bbc2892a4edf561012..154229ec872526535b55502b927e8040294a454f 100644 (file)
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -1036,7 +1036,96 @@ Return a list of results."
       ((defun comp-tests-ret-type-spec-f (x)
               (when (> x 1.0)
                 x))
-       (or null marker number))))
+       (or null marker number))
+
+      ;; 36
+      ;; SBCL: (OR (RATIONAL (5)) (SINGLE-FLOAT 5.0)
+      ;;           (DOUBLE-FLOAT 5.0d0) NULL) !?
+      ((defun comp-tests-ret-type-spec-f (x y)
+         (when (and (> x 3)
+                    (> y 2))
+           (+ x y)))
+       (or null float (integer 7 *)))
+
+      ;; 37
+      ;; SBCL: (OR REAL NULL)
+      ((defun comp-tests-ret-type-spec-f (x y)
+         (when (and (<= x 3)
+                    (<= y 2))
+           (+ x y)))
+       (or null float (integer * 5)))
+
+      ;; 38 SBCL gives: (OR (RATIONAL (2) (10)) (SINGLE-FLOAT 2.0 10.0)
+      ;;                    (DOUBLE-FLOAT 2.0d0 10.0d0) NULL)!?
+      ((defun comp-tests-ret-type-spec-f (x y)
+         (when (and (< 1 x 5)
+                   (< 1 y 5))
+           (+ x y)))
+       (or null float (integer 4 8)))
+
+      ;; 37
+      ;; SBCL gives: (OR REAL NULL)
+      ((defun comp-tests-ret-type-spec-f (x y)
+                   (when (and (<= 1 x 10)
+                              (<= 2 y 3))
+                     (+ x y)))
+       (or null float (integer 3 13)))
+
+      ;; 38
+      ;; SBCL: (OR REAL NULL)
+      ((defun comp-tests-ret-type-spec-f (x y)
+                   (when (and (<= 1 x 10)
+                              (<= 2 y 3))
+                     (- x y)))
+       (or null float (integer -2 8)))
+
+      ;; 39
+      ((defun comp-tests-ret-type-spec-f (x y)
+         (when (and (<= 1 x)
+                    (<= 2 y 3))
+           (- x y)))
+       (or null float (integer -2 *)))
+
+      ;; 40
+      ((defun comp-tests-ret-type-spec-f (x y)
+         (when (and (<= 1 x 10)
+                    (<= 2 y))
+           (- x y)))
+       (or null float (integer * 8)))
+
+      ;; 41
+      ((defun comp-tests-ret-type-spec-f (x y)
+                   (when (and (<= x 10)
+                              (<= 2 y))
+                     (- x y)))
+       (or null float (integer * 8)))
+
+      ;; 42
+      ((defun comp-tests-ret-type-spec-f (x y)
+          (when (and (<= x 10)
+                     (<= y 3))
+            (- x y)))
+       (or null float integer))
+
+      ;; 43
+      ((defun comp-tests-ret-type-spec-f (x y)
+          (when (and (<= 2 x)
+                     (<= 3 y))
+            (- x y)))
+       (or null float integer))
+
+      ;; 44
+      ;; SBCL: (OR (RATIONAL (6) (30)) (SINGLE-FLOAT 6.0 30.0)
+      ;;           (DOUBLE-FLOAT 6.0d0 30.0d0) NULL)
+      ((defun comp-tests-ret-type-spec-f (x y z i j k)
+         (when (and (< 1 x 5)
+                   (< 1 y 5)
+                   (< 1 z 5)
+                   (< 1 i 5)
+                   (< 1 j 5)
+                   (< 1 k 5))
+           (+ x y z i j k)))
+       (or null float (integer 12 24)))))
 
   (defun comp-tests-define-type-spec-test (number x)
     `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) ()