diff options
Diffstat (limited to 'test/src/comp-tests.el')
| -rw-r--r-- | test/src/comp-tests.el | 117 |
1 files changed, 108 insertions, 9 deletions
diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 810aae0739b..b2fd2f68826 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -28,12 +28,14 @@ (require 'ert) (require 'ert-x) (require 'cl-lib) +(require 'cl-seq) (require 'comp) (require 'comp-cstr) (eval-and-compile (defconst comp-test-src (ert-resource-file "comp-test-funcs.el")) - (defconst comp-test-dyn-src (ert-resource-file "comp-test-funcs-dyn.el"))) + (defconst comp-test-dyn-src (ert-resource-file "comp-test-funcs-dyn.el")) + (defconst comp-test-dyn-src2 (ert-resource-file "comp-test-funcs-dyn2.el"))) (when (native-comp-available-p) (message "Compiling tests...") @@ -44,6 +46,7 @@ ;; names used in this file. (require 'comp-test-funcs comp-test-src) (require 'comp-test-dyn-funcs comp-test-dyn-src) ;Non-standard feature name! +(require 'comp-test-funcs-dyn2 comp-test-dyn-src2) (defmacro comp-deftest (name args &rest docstring-and-body) "Define a test for the native compiler tagging it as :nativecomp." @@ -308,7 +311,8 @@ Check that the resulting binaries do not differ." (lambda () (throw 'foo 3))) 3)) (should (= (catch 'foo - (comp-tests-throw-f 3))))) + (comp-tests-throw-f 3)) + 3))) (comp-deftest gc () "Try to do some longer computation to let the GC kick in." @@ -324,6 +328,14 @@ Check that the resulting binaries do not differ." (should (subr-native-elisp-p f)) (should (= (funcall f 3) 4)))) +(comp-deftest lambda-return2 () + "Check a nested lambda function gets native compiled." + (let ((f (comp-tests-lambda-return-f2))) + (should (subr-native-elisp-p f)) + (let ((f2 (funcall f))) + (should (subr-native-elisp-p f2)) + (should (= (funcall f2 3) 4))))) + (comp-deftest recursive () (should (= (comp-tests-fib-f 10) 55))) @@ -385,7 +397,27 @@ Check that the resulting binaries do not differ." "Some doc.")) (should (commandp #'comp-tests-free-fun-f)) (should (equal (interactive-form #'comp-tests-free-fun-f) - '(interactive)))) + '(interactive nil)))) + +(declare-function comp-tests-free-fun-f2 nil) + +(comp-deftest free-fun2 () + "Check compiling a symbol's function compiles contained lambdas." + (eval '(defun comp-tests-free-fun-f2 () + (lambda (x) + "Some doc." + (interactive) + x))) + (native-compile #'comp-tests-free-fun-f2) + + (let* ((f (symbol-function 'comp-tests-free-fun-f2)) + (f2 (funcall f))) + (should (subr-native-elisp-p f)) + (should (subr-native-elisp-p f2)) + (should (string= (documentation f2) "Some doc.")) + (should (commandp f2)) + (should (equal (interactive-form f2) '(interactive nil))) + (should (= (funcall f2 3) 3)))) (declare-function comp-tests/free\fun-f nil) @@ -539,7 +571,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." "Verify we can compile calls to redefined primitives with dedicated byte-op code." (let (x - (f (lambda (fn &rest args) + (f (lambda (_fn &rest args) (setq comp-test-primitive-redefine-args args)))) (advice-add #'delete-region :around f) (unwind-protect @@ -551,6 +583,10 @@ dedicated byte-op code." (advice-remove #'delete-region f) (should (equal comp-test-primitive-redefine-args '(1 2)))))) +(comp-deftest 67239-1 () + "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2023-11/msg00925.html>" + (should-not (comp-test-67239-1-f))) + ;;;;;;;;;;;;;;;;;;;;; ;; Tromey's tests. ;; @@ -868,16 +904,37 @@ 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--type-lists-equal (l1 l2) + (and (= (length l1) (length l2)) + (cl-every #'comp-tests--types-equal l1 l2))) + +(defun comp-tests--types-equal (t1 t2) + "Whether the types T1 and T2 are equal." + (or (equal t1 t2) ; for atoms, and optimization for the common case + (and (consp t1) (consp t2) + (eq (car t1) (car t2)) + (cond ((memq (car t1) '(and or member)) + ;; Order or duplicates don't matter. + (null (cl-set-exclusive-or (cdr t1) (cdr t2) + :test #'comp-tests--types-equal))) + ((eq (car t1) 'function) + (and (comp-tests--type-lists-equal (nth 1 t1) (nth 1 t2)) + (comp-tests--types-equal (nth 2 t1) (nth 2 t2)))) + (t (comp-tests--type-lists-equal (cdr t1) (cdr t2))))))) + (defun comp-tests-check-ret-type-spec (func-form ret-type) (let ((lexical-binding t) (native-comp-speed 2) (f-name (cl-second func-form))) (eval func-form t) (native-compile f-name) - (should (equal (cl-third (subr-type (symbol-function f-name))) - ret-type)))) + (should (comp-tests--types-equal + (cl-third (subr-type (symbol-function f-name))) + ret-type)))) (cl-eval-when (compile eval load) + (cl-defstruct comp-foo a b) + (cl-defstruct (comp-bar (:include comp-foo)) c) (defconst comp-tests-type-spec-tests ;; Why we quote everything here, you ask? So that values of ;; `most-positive-fixnum' and `most-negative-fixnum', which can be @@ -972,7 +1029,7 @@ Return a list of results." (if (= x y) x 'foo)) - '(or (member foo) marker number)) + '(or (member foo) number-or-marker)) ;; 14 ((defun comp-tests-ret-type-spec-f (x) @@ -1112,7 +1169,7 @@ Return a list of results." ((defun comp-tests-ret-type-spec-f (x) (when (> x 1.0) x)) - '(or null marker number)) + '(or null number-or-marker)) ;; 36 ((defun comp-tests-ret-type-spec-f (x y) @@ -1407,7 +1464,46 @@ Return a list of results." (if (eq x 0) (error "") (1+ x))) - 'number))) + 'number) + + ;; 75 + ((defun comp-tests-ret-type-spec-f () + (make-comp-foo)) + 'comp-foo) + + ;; 76 + ((defun comp-tests-ret-type-spec-f () + (make-comp-bar)) + 'comp-bar) + + ;; 77 + ((defun comp-tests-ret-type-spec-f (x) + (setf (comp-foo-a x) 2) + x) + 'comp-foo) + + ;; 78 + ((defun comp-tests-ret-type-spec-f (x) + (if x + (if (> x 11) + x + (make-comp-foo)) + (make-comp-bar))) + '(or comp-foo float (integer 12 *))) + + ;; 79 + ((defun comp-tests-ret-type-spec-f (x) + (if (comp-foo-p x) + x + (error ""))) + 'comp-foo) + + ;; 80 + ((defun comp-tests-ret-type-spec-f (x) + (if (functionp x) + (error "") + x)) + '(not function)))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () @@ -1496,4 +1592,7 @@ folded." (equal (comp-mvar-typeset mvar) comp-tests-cond-rw-expected-type)))))))) +(comp-deftest comp-tests-result-lambda () + (native-compile 'comp-tests-result-lambda) + (should (eq (funcall (comp-tests-result-lambda) '(a . b)) 'a))) ;;; comp-tests.el ends here |