test/automated/generator-tests.el

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