mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-06 14:30:50 -08:00
bc511a64f6
Most of this change is to boilerplate commentary such as license URLs. This change was prompted by ftp://ftp.gnu.org's going-away party, planned for November. Change these FTP URLs to https://ftp.gnu.org instead. Make similar changes for URLs to other organizations moving away from FTP. Also, change HTTP to HTTPS for URLs to gnu.org and fsf.org when this works, as this will further help defend against man-in-the-middle attacks (for this part I omitted the MS-DOS and MS-Windows sources and the test tarballs to keep the workload down). HTTPS is not fully working to lists.gnu.org so I left those URLs alone for now.
284 lines
7.8 KiB
EmacsLisp
284 lines
7.8 KiB
EmacsLisp
;;; generator-tests.el --- Testing generators -*- lexical-binding: t -*-
|
|
|
|
;; Copyright (C) 2015-2017 Free Software Foundation, Inc.
|
|
|
|
;; Author: Daniel Colascione <dancol@dancol.org>
|
|
;; Keywords:
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
;; GNU Emacs is free software: you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
(require 'generator)
|
|
(require 'ert)
|
|
(require 'cl-lib)
|
|
|
|
(defun generator-list-subrs ()
|
|
(cl-loop for x being the symbols
|
|
when (and (fboundp x)
|
|
(cps--special-form-p (symbol-function x)))
|
|
collect x))
|
|
|
|
(defmacro cps-testcase (name &rest body)
|
|
"Perform a simple test of the continuation-transforming code.
|
|
|
|
`cps-testcase' defines an ERT testcase called NAME that evaluates
|
|
BODY twice: once using ordinary `eval' and once using
|
|
lambda-generators. The test ensures that the two forms produce
|
|
identical output.
|
|
"
|
|
`(progn
|
|
(ert-deftest ,name ()
|
|
(should
|
|
(equal
|
|
(funcall (lambda () ,@body))
|
|
(iter-next
|
|
(funcall
|
|
(iter-lambda () (iter-yield (progn ,@body))))))))
|
|
(ert-deftest ,(intern (format "%s-noopt" name)) ()
|
|
(should
|
|
(equal
|
|
(funcall (lambda () ,@body))
|
|
(iter-next
|
|
(funcall
|
|
(let ((cps-inhibit-atomic-optimization t))
|
|
(iter-lambda () (iter-yield (progn ,@body)))))))))))
|
|
|
|
(put 'cps-testcase 'lisp-indent-function 1)
|
|
|
|
(defvar *cps-test-i* nil)
|
|
(defun cps-get-test-i ()
|
|
*cps-test-i*)
|
|
|
|
(cps-testcase cps-simple-1 (progn 1 2 3))
|
|
(cps-testcase cps-empty-progn (progn))
|
|
(cps-testcase cps-inline-not-progn (inline 1 2 3))
|
|
(cps-testcase cps-prog1-a (prog1 1 2 3))
|
|
(cps-testcase cps-prog1-b (prog1 1))
|
|
(cps-testcase cps-prog1-c (prog2 1 2 3))
|
|
(cps-testcase cps-quote (progn 'hello))
|
|
(cps-testcase cps-function (progn #'hello))
|
|
|
|
(cps-testcase cps-and-fail (and 1 nil 2))
|
|
(cps-testcase cps-and-succeed (and 1 2 3))
|
|
(cps-testcase cps-and-empty (and))
|
|
|
|
(cps-testcase cps-or-fallthrough (or nil 1 2))
|
|
(cps-testcase cps-or-alltrue (or 1 2 3))
|
|
(cps-testcase cps-or-empty (or))
|
|
|
|
(cps-testcase cps-let* (let* ((i 10)) i))
|
|
(cps-testcase cps-let*-shadow-empty (let* ((i 10)) (let (i) i)))
|
|
(cps-testcase cps-let (let ((i 10)) i))
|
|
(cps-testcase cps-let-shadow-empty (let ((i 10)) (let (i) i)))
|
|
(cps-testcase cps-let-novars (let nil 42))
|
|
(cps-testcase cps-let*-novars (let* nil 42))
|
|
|
|
(cps-testcase cps-let-parallel
|
|
(let ((a 5) (b 6)) (let ((a b) (b a)) (list a b))))
|
|
|
|
(cps-testcase cps-let*-parallel
|
|
(let* ((a 5) (b 6)) (let* ((a b) (b a)) (list a b))))
|
|
|
|
(cps-testcase cps-while-dynamic
|
|
(setq *cps-test-i* 0)
|
|
(while (< *cps-test-i* 10)
|
|
(setf *cps-test-i* (+ *cps-test-i* 1)))
|
|
*cps-test-i*)
|
|
|
|
(cps-testcase cps-while-lexical
|
|
(let* ((i 0) (j 10))
|
|
(while (< i 10)
|
|
(setf i (+ i 1))
|
|
(setf j (+ j (* i 10))))
|
|
j))
|
|
|
|
(cps-testcase cps-while-incf
|
|
(let* ((i 0) (j 10))
|
|
(while (< i 10)
|
|
(cl-incf i)
|
|
(setf j (+ j (* i 10))))
|
|
j))
|
|
|
|
(cps-testcase cps-dynbind
|
|
(setf *cps-test-i* 0)
|
|
(let* ((*cps-test-i* 5))
|
|
(cps-get-test-i)))
|
|
|
|
(cps-testcase cps-nested-application
|
|
(+ (+ 3 5) 1))
|
|
|
|
(cps-testcase cps-unwind-protect
|
|
(setf *cps-test-i* 0)
|
|
(unwind-protect
|
|
(setf *cps-test-i* 1)
|
|
(setf *cps-test-i* 2))
|
|
*cps-test-i*)
|
|
|
|
(cps-testcase cps-catch-unused
|
|
(catch 'mytag 42))
|
|
|
|
(cps-testcase cps-catch-thrown
|
|
(1+ (catch 'mytag
|
|
(throw 'mytag (+ 2 2)))))
|
|
|
|
(cps-testcase cps-loop
|
|
(cl-loop for x from 1 to 10 collect x))
|
|
|
|
(cps-testcase cps-loop-backquote
|
|
`(a b ,(cl-loop for x from 1 to 10 collect x) -1))
|
|
|
|
(cps-testcase cps-if-branch-a
|
|
(if t 'abc))
|
|
|
|
(cps-testcase cps-if-branch-b
|
|
(if t 'abc 'def))
|
|
|
|
(cps-testcase cps-if-condition-fail
|
|
(if nil 'abc 'def))
|
|
|
|
(cps-testcase cps-cond-empty
|
|
(cond))
|
|
|
|
(cps-testcase cps-cond-atomi
|
|
(cond (42)))
|
|
|
|
(cps-testcase cps-cond-complex
|
|
(cond (nil 22) ((1+ 1) 42) (t 'bad)))
|
|
|
|
(put 'cps-test-error 'error-conditions '(cps-test-condition))
|
|
|
|
(cps-testcase cps-condition-case
|
|
(condition-case
|
|
condvar
|
|
(signal 'cps-test-error 'test-data)
|
|
(cps-test-condition condvar)))
|
|
|
|
(cps-testcase cps-condition-case-no-error
|
|
(condition-case
|
|
condvar
|
|
42
|
|
(cps-test-condition condvar)))
|
|
|
|
(ert-deftest cps-generator-basic ()
|
|
(let* ((gen (iter-lambda ()
|
|
(iter-yield 1)
|
|
(iter-yield 2)
|
|
(iter-yield 3)
|
|
4))
|
|
(gen-inst (funcall gen)))
|
|
(should (eql (iter-next gen-inst) 1))
|
|
(should (eql (iter-next gen-inst) 2))
|
|
(should (eql (iter-next gen-inst) 3))
|
|
|
|
;; should-error doesn't catch the generator-end condition (which
|
|
;; isn't an error), so we write our own.
|
|
(let (errored)
|
|
(condition-case x
|
|
(iter-next gen-inst)
|
|
(iter-end-of-sequence
|
|
(setf errored (cdr x))))
|
|
(should (eql errored 4)))))
|
|
|
|
(iter-defun mygenerator (i)
|
|
(iter-yield 1)
|
|
(iter-yield i)
|
|
(iter-yield 2))
|
|
|
|
(ert-deftest cps-test-iter-do ()
|
|
(let (mylist)
|
|
(iter-do (x (mygenerator 4))
|
|
(push x mylist))
|
|
(should (equal mylist '(2 4 1)))))
|
|
|
|
(iter-defun gen-using-yield-value ()
|
|
(let (f)
|
|
(setf f (iter-yield 42))
|
|
(iter-yield f)
|
|
-8))
|
|
|
|
(ert-deftest cps-yield-value ()
|
|
(let ((it (gen-using-yield-value)))
|
|
(should (eql (iter-next it -1) 42))
|
|
(should (eql (iter-next it -1) -1))))
|
|
|
|
(ert-deftest cps-loop ()
|
|
(should
|
|
(equal (cl-loop for x iter-by (mygenerator 42)
|
|
collect x)
|
|
'(1 42 2))))
|
|
|
|
(iter-defun gen-using-yield-from ()
|
|
(let ((sub-iter (gen-using-yield-value)))
|
|
(iter-yield (1+ (iter-yield-from sub-iter)))))
|
|
|
|
(ert-deftest cps-test-yield-from-works ()
|
|
(let ((it (gen-using-yield-from)))
|
|
(should (eql (iter-next it -1) 42))
|
|
(should (eql (iter-next it -1) -1))
|
|
(should (eql (iter-next it -1) -7))))
|
|
|
|
(defvar cps-test-closed-flag nil)
|
|
|
|
(ert-deftest cps-test-iter-close ()
|
|
(garbage-collect)
|
|
(let ((cps-test-closed-flag nil))
|
|
(let ((iter (funcall
|
|
(iter-lambda ()
|
|
(unwind-protect (iter-yield 1)
|
|
(setf cps-test-closed-flag t))))))
|
|
(should (equal (iter-next iter) 1))
|
|
(should (not cps-test-closed-flag))
|
|
(iter-close iter)
|
|
(should cps-test-closed-flag))))
|
|
|
|
(ert-deftest cps-test-iter-close-idempotent ()
|
|
(garbage-collect)
|
|
(let ((cps-test-closed-flag nil))
|
|
(let ((iter (funcall
|
|
(iter-lambda ()
|
|
(unwind-protect (iter-yield 1)
|
|
(setf cps-test-closed-flag t))))))
|
|
(should (equal (iter-next iter) 1))
|
|
(should (not cps-test-closed-flag))
|
|
(iter-close iter)
|
|
(should cps-test-closed-flag)
|
|
(setf cps-test-closed-flag nil)
|
|
(iter-close iter)
|
|
(should (not cps-test-closed-flag)))))
|
|
|
|
(ert-deftest cps-test-iter-cleanup-once-only ()
|
|
(let* ((nr-unwound 0)
|
|
(iter
|
|
(funcall (iter-lambda ()
|
|
(unwind-protect
|
|
(progn
|
|
(iter-yield 1)
|
|
(error "test")
|
|
(iter-yield 2))
|
|
(cl-incf nr-unwound))))))
|
|
(should (equal (iter-next iter) 1))
|
|
(should-error (iter-next iter))
|
|
(should (equal nr-unwound 1))))
|
|
|
|
(iter-defun generator-with-docstring ()
|
|
"Documentation!"
|
|
(declare (indent 5))
|
|
nil)
|
|
|
|
(ert-deftest cps-test-declarations-preserved ()
|
|
(should (equal (documentation 'generator-with-docstring) "Documentation!"))
|
|
(should (equal (get 'generator-with-docstring 'lisp-indent-function) 5)))
|