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;;; Code:
34
35(defun generator-list-subrs ()
36  (cl-loop for x being the symbols
37        when (and (fboundp x)
38                  (cps--special-form-p (symbol-function x)))
39        collect x))
40
41(defmacro cps-testcase (name &rest body)
42  "Perform a simple test of the continuation-transforming code.
43
44`cps-testcase' defines an ERT testcase called NAME that evaluates
45BODY twice: once using ordinary `eval' and once using
46lambda-generators.  The test ensures that the two forms produce
47identical output."
48  (declare (indent 1))
49  `(progn
50     (ert-deftest ,name ()
51       (should
52        (equal
53         (funcall (lambda () ,@body))
54         (iter-next
55          (funcall
56           (iter-lambda () (iter-yield (progn ,@body))))))))
57     (ert-deftest ,(intern (format "%s-noopt" name)) ()
58       (should
59        (equal
60         (funcall (lambda () ,@body))
61         (iter-next
62          (funcall
63           (let ((cps-inhibit-atomic-optimization t))
64             (iter-lambda () (iter-yield (progn ,@body)))))))))))
65
66(defvar *cps-test-i* nil)
67(defun cps-get-test-i ()
68  *cps-test-i*)
69
70(cps-testcase cps-simple-1 (progn 1 2 3))
71(cps-testcase cps-empty-progn (progn))
72(cps-testcase cps-inline-not-progn (inline 1 2 3))
73(cps-testcase cps-prog1-a (prog1 1 2 3))
74(cps-testcase cps-prog1-b (prog1 1))
75(cps-testcase cps-prog1-c (prog2 1 2 3))
76(cps-testcase cps-quote (progn 'hello))
77(cps-testcase cps-function (progn #'message))
78
79(cps-testcase cps-and-fail (and 1 nil 2))
80(cps-testcase cps-and-succeed (and 1 2 3))
81(cps-testcase cps-and-empty (and))
82
83(cps-testcase cps-or-fallthrough (or nil 1 2))
84(cps-testcase cps-or-alltrue (or 1 2 3))
85(cps-testcase cps-or-empty (or))
86
87(cps-testcase cps-let* (let* ((i 10)) i))
88(cps-testcase cps-let*-shadow-empty (let* ((i 10)) i (let ((i nil)) i)))
89(cps-testcase cps-let (let ((i 10)) i))
90(cps-testcase cps-let-shadow-empty (let ((i 10)) i (let ((i nil)) i)))
91(cps-testcase cps-let-novars (let nil 42))
92(cps-testcase cps-let*-novars (let* nil 42))
93
94(cps-testcase cps-let-parallel
95  (let ((a 5) (b 6)) (let ((a b) (b a)) (list a b))))
96
97(cps-testcase cps-let*-parallel
98  (let* ((a 5) (b 6)) a (let* ((a b) (b a)) (list a b))))
99
100(cps-testcase cps-while-dynamic
101  (setq *cps-test-i* 0)
102  (while (< *cps-test-i* 10)
103    (setf *cps-test-i* (+ *cps-test-i* 1)))
104  *cps-test-i*)
105
106(cps-testcase cps-while-lexical
107 (let* ((i 0) (j 10))
108   (while (< i 10)
109     (setf i (+ i 1))
110     (setf j (+ j (* i 10))))
111   j))
112
113(cps-testcase cps-while-incf
114 (let* ((i 0) (j 10))
115   (while (< i 10)
116     (cl-incf i)
117     (setf j (+ j (* i 10))))
118   j))
119
120(cps-testcase cps-dynbind
121 (setf *cps-test-i* 0)
122 (let* ((*cps-test-i* 5))
123   (cps-get-test-i)))
124
125(cps-testcase cps-nested-application
126 (+ (+ 3 5) 1))
127
128(cps-testcase cps-unwind-protect
129 (setf *cps-test-i* 0)
130 (unwind-protect
131     (setf *cps-test-i* 1)
132   (setf *cps-test-i* 2))
133 *cps-test-i*)
134
135(cps-testcase cps-catch-unused
136 (catch 'mytag 42))
137
138(cps-testcase cps-catch-thrown
139 (1+ (catch 'mytag
140       (throw 'mytag (+ 2 2)))))
141
142(cps-testcase cps-loop
143 (cl-loop for x from 1 to 10 collect x))
144
145(cps-testcase cps-loop-backquote
146 `(a b ,(cl-loop for x from 1 to 10 collect x) -1))
147
148(cps-testcase cps-if-branch-a
149 (if t 'abc))
150
151(cps-testcase cps-if-branch-b
152 (if t 'abc 'def))
153
154(cps-testcase cps-if-condition-fail
155 (if nil 'abc 'def))
156
157(cps-testcase cps-cond-empty
158 (cond))
159
160(cps-testcase cps-cond-atomi
161 (cond (42)))
162
163(cps-testcase cps-cond-complex
164 (cond (nil 22) ((1+ 1) 42) (t 'bad)))
165
166(put 'cps-test-error 'error-conditions '(cps-test-condition))
167
168(cps-testcase cps-condition-case
169  (condition-case
170      condvar
171      (signal 'cps-test-error 'test-data)
172    (cps-test-condition condvar)))
173
174(cps-testcase cps-condition-case-no-error
175  (condition-case
176      condvar
177      42
178    (cps-test-condition condvar)))
179
180(ert-deftest cps-generator-basic ()
181  (let* ((gen (iter-lambda ()
182                (iter-yield 1)
183                (iter-yield 2)
184                (iter-yield 3)
185                4))
186         (gen-inst (funcall gen)))
187    (should (eql (iter-next gen-inst) 1))
188    (should (eql (iter-next gen-inst) 2))
189    (should (eql (iter-next gen-inst) 3))
190
191    ;; should-error doesn't catch the generator-end condition (which
192    ;; isn't an error), so we write our own.
193    (let (errored)
194      (condition-case x
195          (iter-next gen-inst)
196        (iter-end-of-sequence
197         (setf errored (cdr x))))
198      (should (eql errored 4)))))
199
200(iter-defun mygenerator (i)
201  (iter-yield 1)
202  (iter-yield i)
203  (iter-yield 2))
204
205(ert-deftest cps-test-iter-do ()
206  (let (mylist)
207    (iter-do (x (mygenerator 4))
208      (push x mylist))
209    (should (equal mylist '(2 4 1)))))
210
211(iter-defun gen-using-yield-value ()
212  (let (f)
213    (setf f (iter-yield 42))
214    (iter-yield f)
215    -8))
216
217(ert-deftest cps-yield-value ()
218  (let ((it (gen-using-yield-value)))
219    (should (eql (iter-next it -1) 42))
220    (should (eql (iter-next it -1) -1))))
221
222(ert-deftest cps-loop-2 ()
223  (should
224   (equal (cl-loop for x iter-by (mygenerator 42)
225             collect x)
226          '(1 42 2))))
227
228(iter-defun gen-using-yield-from ()
229  (let ((sub-iter (gen-using-yield-value)))
230    (iter-yield (1+ (iter-yield-from sub-iter)))))
231
232(ert-deftest cps-test-yield-from-works ()
233  (let ((it (gen-using-yield-from)))
234    (should (eql (iter-next it -1) 42))
235    (should (eql (iter-next it -1) -1))
236    (should (eql (iter-next it -1) -7))))
237
238(defvar cps-test-closed-flag nil)
239
240(ert-deftest cps-test-iter-close ()
241  (garbage-collect)
242  (let ((cps-test-closed-flag nil))
243    (let ((iter (funcall
244                 (iter-lambda ()
245                   (unwind-protect (iter-yield 1)
246                     (setf cps-test-closed-flag t))))))
247      (should (equal (iter-next iter) 1))
248      (should (not cps-test-closed-flag))
249      (iter-close iter)
250      (should cps-test-closed-flag))))
251
252(ert-deftest cps-test-iter-close-idempotent ()
253  (garbage-collect)
254  (let ((cps-test-closed-flag nil))
255    (let ((iter (funcall
256                 (iter-lambda ()
257                   (unwind-protect (iter-yield 1)
258                     (setf cps-test-closed-flag t))))))
259      (should (equal (iter-next iter) 1))
260      (should (not cps-test-closed-flag))
261      (iter-close iter)
262      (should cps-test-closed-flag)
263      (setf cps-test-closed-flag nil)
264      (iter-close iter)
265      (should (not cps-test-closed-flag)))))
266
267(ert-deftest cps-test-iter-cleanup-once-only ()
268  (let* ((nr-unwound 0)
269         (iter
270          (funcall (iter-lambda ()
271                     (unwind-protect
272                          (progn
273                            (iter-yield 1)
274                            (error "Test")
275                            (iter-yield 2))
276                       (cl-incf nr-unwound))))))
277    (should (equal (iter-next iter) 1))
278    (should-error (iter-next iter))
279    (should (equal nr-unwound 1))))
280
281(iter-defun generator-with-docstring ()
282  "Documentation!"
283  (declare (indent 5))
284  nil)
285
286(ert-deftest cps-test-declarations-preserved ()
287  (should (equal (documentation 'generator-with-docstring) "Documentation!"))
288  (should (equal (get 'generator-with-docstring 'lisp-indent-function) 5)))
289
290(ert-deftest cps-iter-lambda-with-dynamic-binding ()
291  "`iter-lambda' with dynamic binding produces correct result (bug#25965)."
292  (should (= 1
293             (iter-next
294              (funcall (iter-lambda ()
295                         (let* ((fill-column 10) ;;any special variable will do
296                                (i 0)
297                                (j (setq i (1+ i))))
298                           (iter-yield i))))))))
299
300(ert-deftest iter-lambda-variable-shadowing ()
301  "`iter-lambda' forms which have local variable shadowing (Bug#26073)."
302  (should (equal (iter-next
303                  (funcall (iter-lambda ()
304                             (let ((it 1))
305                               (iter-yield (funcall
306                                            (lambda (it) (- it))
307                                            (1+ it)))))))
308                 -2)))
309
310(defun generator-tests-edebug ()) ; silence byte-compiler
311(ert-deftest generator-tests-edebug ()
312  "Check that Bug#40434 is fixed."
313  (with-temp-buffer
314    (prin1 '(iter-defun generator-tests-edebug ()
315              (iter-yield 123))
316           (current-buffer))
317    (edebug-defun))
318  (should (eql (iter-next (generator-tests-edebug)) 123)))
319
320;;; generator-tests.el ends here
321