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