1;;; generator-tests.el --- Testing generators -*- lexical-binding: t -*-
2
3;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
4
5;; Author: Daniel Colascione <dancol@dancol.org>
6;; Keywords:
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
22
23;;; Commentary:
24
25;; Unit tests for generator.el.
26
27;;; Code:
28
29(require 'generator)
30(require 'ert)
31(require 'cl-lib)
32
33(defun generator-list-subrs ()
34  (cl-loop for x being the symbols
35        when (and (fboundp x)
36                  (cps--special-form-p (symbol-function x)))
37        collect x))
38
39(defmacro cps-testcase (name &rest body)
40  "Perform a simple test of the continuation-transforming code.
41
42`cps-testcase' defines an ERT testcase called NAME that evaluates
43BODY twice: once using ordinary `eval' and once using
44lambda-generators.  The test ensures that the two forms produce
45identical output."
46  `(progn
47     (ert-deftest ,name ()
48       (should
49        (equal
50         (funcall (lambda () ,@body))
51         (iter-next
52          (funcall
53           (iter-lambda () (iter-yield (progn ,@body))))))))
54     (ert-deftest ,(intern (format "%s-noopt" name)) ()
55       (should
56        (equal
57         (funcall (lambda () ,@body))
58         (iter-next
59          (funcall
60           (let ((cps-inhibit-atomic-optimization t))
61             (iter-lambda () (iter-yield (progn ,@body)))))))))))
62
63(put 'cps-testcase 'lisp-indent-function 1)
64
65(defvar *cps-test-i* nil)
66(defun cps-get-test-i ()
67  *cps-test-i*)
68
69(cps-testcase cps-simple-1 (progn 1 2 3))
70(cps-testcase cps-empty-progn (progn))
71(cps-testcase cps-inline-not-progn (inline 1 2 3))
72(cps-testcase cps-prog1-a (prog1 1 2 3))
73(cps-testcase cps-prog1-b (prog1 1))
74(cps-testcase cps-prog1-c (prog2 1 2 3))
75(cps-testcase cps-quote (progn 'hello))
76(cps-testcase cps-function (progn #'hello))
77
78(cps-testcase cps-and-fail (and 1 nil 2))
79(cps-testcase cps-and-succeed (and 1 2 3))
80(cps-testcase cps-and-empty (and))
81
82(cps-testcase cps-or-fallthrough (or nil 1 2))
83(cps-testcase cps-or-alltrue (or 1 2 3))
84(cps-testcase cps-or-empty (or))
85
86(cps-testcase cps-let* (let* ((i 10)) i))
87(cps-testcase cps-let*-shadow-empty (let* ((i 10)) (let (i) i)))
88(cps-testcase cps-let (let ((i 10)) i))
89(cps-testcase cps-let-shadow-empty (let ((i 10)) (let (i) i)))
90(cps-testcase cps-let-novars (let nil 42))
91(cps-testcase cps-let*-novars (let* nil 42))
92
93(cps-testcase cps-let-parallel
94  (let ((a 5) (b 6)) (let ((a b) (b a)) (list a b))))
95
96(cps-testcase cps-let*-parallel
97  (let* ((a 5) (b 6)) (let* ((a b) (b a)) (list a b))))
98
99(cps-testcase cps-while-dynamic
100  (setq *cps-test-i* 0)
101  (while (< *cps-test-i* 10)
102    (setf *cps-test-i* (+ *cps-test-i* 1)))
103  *cps-test-i*)
104
105(cps-testcase cps-while-lexical
106 (let* ((i 0) (j 10))
107   (while (< i 10)
108     (setf i (+ i 1))
109     (setf j (+ j (* i 10))))
110   j))
111
112(cps-testcase cps-while-incf
113 (let* ((i 0) (j 10))
114   (while (< i 10)
115     (cl-incf i)
116     (setf j (+ j (* i 10))))
117   j))
118
119(cps-testcase cps-dynbind
120 (setf *cps-test-i* 0)
121 (let* ((*cps-test-i* 5))
122   (cps-get-test-i)))
123
124(cps-testcase cps-nested-application
125 (+ (+ 3 5) 1))
126
127(cps-testcase cps-unwind-protect
128 (setf *cps-test-i* 0)
129 (unwind-protect
130     (setf *cps-test-i* 1)
131   (setf *cps-test-i* 2))
132 *cps-test-i*)
133
134(cps-testcase cps-catch-unused
135 (catch 'mytag 42))
136
137(cps-testcase cps-catch-thrown
138 (1+ (catch 'mytag
139       (throw 'mytag (+ 2 2)))))
140
141(cps-testcase cps-loop
142 (cl-loop for x from 1 to 10 collect x))
143
144(cps-testcase cps-loop-backquote
145 `(a b ,(cl-loop for x from 1 to 10 collect x) -1))
146
147(cps-testcase cps-if-branch-a
148 (if t 'abc))
149
150(cps-testcase cps-if-branch-b
151 (if t 'abc 'def))
152
153(cps-testcase cps-if-condition-fail
154 (if nil 'abc 'def))
155
156(cps-testcase cps-cond-empty
157 (cond))
158
159(cps-testcase cps-cond-atomi
160 (cond (42)))
161
162(cps-testcase cps-cond-complex
163 (cond (nil 22) ((1+ 1) 42) (t 'bad)))
164
165(put 'cps-test-error 'error-conditions '(cps-test-condition))
166
167(cps-testcase cps-condition-case
168  (condition-case
169      condvar
170      (signal 'cps-test-error 'test-data)
171    (cps-test-condition condvar)))
172
173(cps-testcase cps-condition-case-no-error
174  (condition-case
175      condvar
176      42
177    (cps-test-condition condvar)))
178
179(ert-deftest cps-generator-basic ()
180  (let* ((gen (iter-lambda ()
181                (iter-yield 1)
182                (iter-yield 2)
183                (iter-yield 3)
184                4))
185         (gen-inst (funcall gen)))
186    (should (eql (iter-next gen-inst) 1))
187    (should (eql (iter-next gen-inst) 2))
188    (should (eql (iter-next gen-inst) 3))
189
190    ;; should-error doesn't catch the generator-end condition (which
191    ;; isn't an error), so we write our own.
192    (let (errored)
193      (condition-case x
194          (iter-next gen-inst)
195        (iter-end-of-sequence
196         (setf errored (cdr x))))
197      (should (eql errored 4)))))
198
199(iter-defun mygenerator (i)
200  (iter-yield 1)
201  (iter-yield i)
202  (iter-yield 2))
203
204(ert-deftest cps-test-iter-do ()
205  (let (mylist)
206    (iter-do (x (mygenerator 4))
207      (push x mylist))
208    (should (equal mylist '(2 4 1)))))
209
210(iter-defun gen-using-yield-value ()
211  (let (f)
212    (setf f (iter-yield 42))
213    (iter-yield f)
214    -8))
215
216(ert-deftest cps-yield-value ()
217  (let ((it (gen-using-yield-value)))
218    (should (eql (iter-next it -1) 42))
219    (should (eql (iter-next it -1) -1))))
220
221(ert-deftest cps-loop ()
222  (should
223   (equal (cl-loop for x iter-by (mygenerator 42)
224             collect x)
225          '(1 42 2))))
226
227(iter-defun gen-using-yield-from ()
228  (let ((sub-iter (gen-using-yield-value)))
229    (iter-yield (1+ (iter-yield-from sub-iter)))))
230
231(ert-deftest cps-test-yield-from-works ()
232  (let ((it (gen-using-yield-from)))
233    (should (eql (iter-next it -1) 42))
234    (should (eql (iter-next it -1) -1))
235    (should (eql (iter-next it -1) -7))))
236
237(defvar cps-test-closed-flag nil)
238
239(ert-deftest cps-test-iter-close ()
240  (garbage-collect)
241  (let ((cps-test-closed-flag nil))
242    (let ((iter (funcall
243                 (iter-lambda ()
244                   (unwind-protect (iter-yield 1)
245                     (setf cps-test-closed-flag t))))))
246      (should (equal (iter-next iter) 1))
247      (should (not cps-test-closed-flag))
248      (iter-close iter)
249      (should cps-test-closed-flag))))
250
251(ert-deftest cps-test-iter-close-idempotent ()
252  (garbage-collect)
253  (let ((cps-test-closed-flag nil))
254    (let ((iter (funcall
255                 (iter-lambda ()
256                   (unwind-protect (iter-yield 1)
257                     (setf cps-test-closed-flag t))))))
258      (should (equal (iter-next iter) 1))
259      (should (not cps-test-closed-flag))
260      (iter-close iter)
261      (should cps-test-closed-flag)
262      (setf cps-test-closed-flag nil)
263      (iter-close iter)
264      (should (not cps-test-closed-flag)))))
265
266(ert-deftest cps-test-iter-cleanup-once-only ()
267  (let* ((nr-unwound 0)
268         (iter
269          (funcall (iter-lambda ()
270                     (unwind-protect
271                          (progn
272                            (iter-yield 1)
273                            (error "test")
274                            (iter-yield 2))
275                       (cl-incf nr-unwound))))))
276    (should (equal (iter-next iter) 1))
277    (should-error (iter-next iter))
278    (should (equal nr-unwound 1))))
279
280(iter-defun generator-with-docstring ()
281  "Documentation!"
282  (declare (indent 5))
283  nil)
284
285(ert-deftest cps-test-declarations-preserved ()
286  (should (equal (documentation 'generator-with-docstring) "Documentation!"))
287  (should (equal (get 'generator-with-docstring 'lisp-indent-function) 5)))
288
289(ert-deftest cps-iter-lambda-with-dynamic-binding ()
290  "`iter-lambda' with dynamic binding produces correct result (bug#25965)."
291  (should (= 1
292             (iter-next
293              (funcall (iter-lambda ()
294                         (let* ((fill-column 10) ;;any special variable will do
295                                (i 0)
296                                (j (setq i (1+ i))))
297                           (iter-yield i))))))))
298
299(ert-deftest iter-lambda-variable-shadowing ()
300  "`iter-lambda' forms which have local variable shadowing (Bug#26073)."
301  (should (equal (iter-next
302                  (funcall (iter-lambda ()
303                             (let ((it 1))
304                               (iter-yield (funcall
305                                            (lambda (it) (- it))
306                                            (1+ it)))))))
307                 -2)))
308
309;;; generator-tests.el ends here
310