From 2435c103a4da85ae8b6bc48f3f964014d1cb6341 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 11 Nov 2020 17:59:46 +0100 Subject: [PATCH] * 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 8bedad5db73..23c4df88201 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. ;; -- 2.39.5