feature/native-comp 5074447 1/3: Fix type inference for bug#45635

[Andrea Corallo]

branch: feature/native-comp
commit 5074447ef4980e2eb613e908e346fd3471f52139
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>

    Fix type inference for bug#45635
    
        * lisp/emacs-lisp/comp-cstr.el (comp-cstr-union-1-no-mem): Fix
        missing mixed pos neg handling.
        * test/lisp/emacs-lisp/comp-cstr-tests.el
        (comp-cstr-typespec-tests-alist): Add a test.
        * test/src/comp-tests.el (45635): New testcase.
        * test/src/comp-test-funcs.el (comp-test-45635-f): New function.
---
 lisp/emacs-lisp/comp-cstr.el            | 16 ++++++++++++++++
 test/lisp/emacs-lisp/comp-cstr-tests.el |  4 +++-
 test/src/comp-test-funcs.el             | 15 +++++++++++++++
 test/src/comp-tests.el                  |  5 +++++
 4 files changed, 39 insertions(+), 1 deletion(-)

diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index e63afa1..651c7b7 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -558,6 +558,22 @@ DST is returned."
               ;; "simple" for now.
               (give-up))
 
+            ;; When every neg type is a subtype of some pos one.
+            ;; In case return pos.
+            (when (and (typeset neg)
+                       (cl-every (lambda (x)
+                                   (cl-some (lambda (y)
+                                              (comp-subtype-p x y))
+                                            (append (typeset pos)
+                                                    (when (range pos)
+                                                      '(integer)))))
+                                 (typeset neg)))
+              (setf (typeset dst) (typeset pos)
+                    (valset dst) (valset pos)
+                    (range dst) (range pos)
+                    (neg dst) nil)
+              (cl-return-from comp-cstr-union-1-no-mem dst))
+
             ;; Verify disjoint condition between positive types and
             ;; negative types coming from values, in case give-up.
             (let ((neg-value-types (nconc (mapcar #'type-of (valset neg))
diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el 
b/test/lisp/emacs-lisp/comp-cstr-tests.el
index 1e1376b..149afaf 100644
--- a/test/lisp/emacs-lisp/comp-cstr-tests.el
+++ b/test/lisp/emacs-lisp/comp-cstr-tests.el
@@ -207,7 +207,9 @@
       ;; 83
       ((not t) . nil)
       ;; 84
-      ((not nil) . t))
+      ((not nil) . t)
+      ;; 85
+      ((or (not string) t) . t))
     "Alist type specifier -> expected type specifier."))
 
 (defmacro comp-cstr-synthesize-tests ()
diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el
index d0ec636..694d9d4 100644
--- a/test/src/comp-test-funcs.el
+++ b/test/src/comp-test-funcs.el
@@ -463,6 +463,21 @@
                         eshell-term eshell-unix))
        sym)))
 
+(defun comp-test-45635-f (&rest args)
+  ;; Reduced from `set-face-attribute'.
+  (let ((spec args)
+       family)
+    (while spec
+      (cond ((eq (car spec) :family)
+            (setq family (cadr spec))))
+      (setq spec (cddr spec)))
+    (when (and (stringp family)
+              (string-match "\\([^-]*\\)-\\([^-]*\\)" family))
+      (setq family (match-string 2 family)))
+    (when (or (stringp family)
+             (eq family 'unspecified))
+      family)))
+
 
 ;;;;;;;;;;;;;;;;;;;;
 ;; Tromey's tests ;;
diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index faaa2f4..23a1087 100644
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -487,6 +487,11 @@ 
https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html.";
 <https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-01/msg00029.html>."
   (should (eq (comp-test-45576-f) 'eval)))
 
+(comp-deftest 45635-1 ()
+  "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-01/msg00158.html>."
+  (should (string= (comp-test-45635-f :height 180 :family "PragmataPro Liga")
+                   "PragmataPro Liga")))
+
 
 ;;;;;;;;;;;;;;;;;;;;;
 ;; Tromey's tests. ;;