feature/native-comp 2435c10 8/8: * Nativecomp testsuite rework for derived return type specifiers

[Andrea Corallo]

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

    * Nativecomp testsuite rework for derived return type specifiers
    
    As we have derived return type specifiers as some test for them.  Also
    rewrite some propagation related test using return type specifiers too
    as it's way more convenient.
    
        * test/src/comp-tests.el (fw-prop-1): Nit rename.
        (comp-tests-check-ret-type-spec): New function.
        (comp-tests-type-spec-tests): New variable.
        (comp-tests-cond-rw-0-var) Remove variable.
        (cond-rw-0, cond-rw-1, cond-rw-2, cond-rw-3, cond-rw-4, cond-rw-5)
        Remove tests as now covered by `comp-tests-check-ret-type-spec'.
---
 test/src/comp-tests.el | 167 +++++++++++++++++++++++++++++++------------------
 1 file changed, 105 insertions(+), 62 deletions(-)

diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index 8bedad5..23c4df8 100644
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -743,7 +743,7 @@ Return a list of results."
        (or (comp-tests-mentioned-p 'concat insn)
            (comp-tests-mentioned-p 'length insn)))))))
 
-(comp-deftest fw-prop ()
+(comp-deftest fw-prop-1 ()
   "Some tests for forward propagation."
   (let ((comp-speed 2)
         (comp-post-pass-hooks '((comp-final comp-tests-fw-prop-checker-1))))
@@ -757,6 +757,110 @@ Return a list of results."
     (should (subr-native-elisp-p (symbol-function #'comp-tests-fw-prop-1-f)))
     (should (= (comp-tests-fw-prop-1-f) 6))))
 
+(defun comp-tests-check-ret-type-spec (func-form type-specifier)
+  (let ((lexical-binding t)
+        (speed 2)
+        (comp-post-pass-hooks
+         `((comp-final
+            ,(lambda (_)
+               (let ((f (gethash (comp-c-func-name (cadr func-form) "F" t)
+                                 (comp-ctxt-funcs-h comp-ctxt))))
+                 (should (equal (comp-func-ret-type-specifier f)
+                                type-specifier))))))))
+    (eval func-form t)
+    (native-compile (cadr func-form))))
+
+(defconst comp-tests-type-spec-tests
+  `(((defun comp-tests-ret-type-spec-0-f (x)
+       x)
+     (t))
+
+    ((defun comp-tests-ret-type-spec-1-f ()
+       1)
+     (integer 1 1))
+
+    ((defun comp-tests-ret-type-spec-2-f (x)
+       (if x 1 3))
+     (or (integer 1 1) (integer 3 3)))
+
+    ((defun comp-tests-ret-type-spec-3-f (x)
+       (let (y)
+         (if x
+             (setf y 1)
+           (setf y 2))
+         y))
+     (integer 1 2))
+
+    ((defun comp-tests-ret-type-spec-4-f (x)
+       (let (y)
+         (if x
+             (setf y 1)
+           (setf y 3))
+         y))
+     (or (integer 1 1) (integer 3 3)))
+
+    ((defun comp-tests-ret-type-spec-5-f (x)
+       (if x
+           (list x)
+         3))
+     (or cons (integer 3 3)))
+
+    ((defun comp-tests-ret-type-spec-6-f (x)
+       (if x
+           'foo
+         3))
+     (or (member foo) (integer 3 3)))
+
+    ((defun comp-tests-ret-type-spec-7-1-f (x)
+       (if (eq x 3)
+           x
+         'foo))
+     (or (member foo) (integer 3 3)))
+
+    ((defun comp-tests-ret-type-spec-7-2-f (x)
+       (if (eq 3 x)
+           x
+         'foo))
+     (or (member foo) (integer 3 3)))
+
+    ((defun comp-tests-ret-type-spec-8-1-f (x)
+       (if (= x 3)
+           x
+         'foo))
+     (or (member foo) (integer 3 3)))
+
+    ((defun comp-tests-ret-type-spec-8-2-f (x)
+       (if (= 3 x)
+           x
+         'foo))
+     (or (member foo) (integer 3 3)))
+
+    ;; FIXME returning ATM (or t (member foo))
+    ;; ((defun comp-tests-ret-type-spec-8-3-f (x)
+    ;;    (if (= x 3)
+    ;;        'foo
+    ;;      x))
+    ;;  (or number (member foo)))
+
+    ((defun comp-tests-ret-type-spec-8-4-f (x y)
+       (if (= x y)
+           x
+         'foo))
+     (or number (member foo)))
+
+    ((defun comp-tests-ret-type-spec-9-1-f (x)
+       (comp-hint-fixnum y))
+     (integer ,most-negative-fixnum ,most-positive-fixnum))
+
+    ((defun comp-tests-ret-type-spec-9-1-f (x)
+       (comp-hint-cons x))
+     (cons))))
+
+(comp-deftest ret-type-spec ()
+  "Some derived return type specifier tests."
+  (cl-loop for (func-form  type-spec) in comp-tests-type-spec-tests
+           do (comp-tests-check-ret-type-spec func-form type-spec)))
+
 (defun comp-tests-pure-checker-1 (_)
   "Check that inside `comp-tests-pure-caller-f' `comp-tests-pure-callee-f' is
  folded."
@@ -826,67 +930,6 @@ Return a list of results."
           (equal (comp-mvar-typeset mvar)
                  comp-tests-cond-rw-expected-type))))))))
 
-(defvar comp-tests-cond-rw-0-var)
-(comp-deftest cond-rw-0 ()
-  "Check we do not miscompile some simple functions."
-  (let ((lexical-binding t))
-    (let ((f (native-compile '(lambda (l)
-                                (when (eq (car l) 'x)
-                                  (cdr l))))))
-      (should (subr-native-elisp-p f))
-      (should (eq (funcall f '(x . y)) 'y))
-      (should (null (funcall f '(z . y)))))
-
-    (should
-     (subr-native-elisp-p
-      (native-compile '(lambda () (if (eq comp-tests-cond-rw-0-var 123) 5 
10)))))))
-
-(comp-deftest cond-rw-1 ()
-  "Test cond-rw pass allow us to propagate type+val under `eq' tests."
-  (let ((lexical-binding t)
-        (comp-tests-cond-rw-expected-type '(integer))
-        (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type
-                                            comp-tests-cond-rw-checker-val))))
-    (subr-native-elisp-p (native-compile '(lambda (x) (if (eq x 123) x t))))
-    (subr-native-elisp-p (native-compile '(lambda (x) (if (eq 123 x) x t))))))
-
-(comp-deftest cond-rw-2 ()
-  "Test cond-rw pass allow us to propagate type+val under `=' tests."
-  (let ((lexical-binding t)
-        (comp-tests-cond-rw-expected-type '(integer))
-        (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type
-                                            comp-tests-cond-rw-checker-val))))
-    (subr-native-elisp-p (native-compile '(lambda (x) (if (= x 123) x t))))))
-
-(comp-deftest cond-rw-3 ()
-  "Test cond-rw pass allow us to propagate type+val under `eql' tests."
-  (let ((lexical-binding t)
-        (comp-tests-cond-rw-expected-type '(integer))
-        (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type
-                                            comp-tests-cond-rw-checker-val))))
-    (subr-native-elisp-p (native-compile '(lambda (x) (if (eql 123 x) x t))))))
-
-(comp-deftest cond-rw-4 ()
-  "Test cond-rw pass allow us to propagate type under `=' tests."
-  (let ((lexical-binding t)
-        (comp-tests-cond-rw-expected-type '(number))
-        (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type))))
-    (subr-native-elisp-p (native-compile '(lambda (x y) (if (= x y) x t))))))
-
-(comp-deftest cond-rw-5 ()
-  "Test cond-rw pass allow us to propagate type under `=' tests."
-  (let ((comp-tests-cond-rw-checked-function #'comp-tests-cond-rw-4-f)
-        (comp-tests-cond-rw-expected-type '(integer))
-        (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type))))
-    (eval '(defun comp-tests-cond-rw-4-f (x y)
-             (declare (speed 3))
-             (if (= x (comp-hint-fixnum y))
-                 x
-               t))
-          t)
-    (native-compile #'comp-tests-cond-rw-4-f)
-    (should (subr-native-elisp-p (symbol-function #'comp-tests-cond-rw-4-f)))))
-
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Range propagation tests. ;;