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