procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add support for generators

Browse source 
diff --git a/doc/lispref/ChangeLog b/doc/lispref/ChangeLog
index 78f7e34..e7d79d5 100644
--- a/doc/lispref/ChangeLog
+++ b/doc/lispref/ChangeLog
@@ -1,3 +1,8 @@
+2015-03-02  Daniel Colascione  <dancol@dancol.org>
+
+	* control.texi (Generators): New section
+	* elisp.text: Reference new section.
+
 2015-02-28  Eli Zaretskii  <eliz@gnu.org>

 	* searching.texi (Char Classes): Update the documentation of
diff --git a/doc/misc/ChangeLog b/doc/misc/ChangeLog
index 448c7f2..4e9c119 100644
--- a/doc/misc/ChangeLog
+++ b/doc/misc/ChangeLog
@@ -1,3 +1,7 @@
+2015-03-02  Daniel Colascione  <dancol@dancol.org>
+
+	* cl.texi (Iteration Clauses): Mention iterator support.
+
 2015-02-25  Tassilo Horn  <tsdh@gnu.org>

 	* reftex.texi (Multifile Documents): Document
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 7ce2e81..4ab4406 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,6 +1,8 @@
 2015-03-02  Daniel Colascione  <dancol@dancol.org>

-	* vc/vc.el (vc-responsible-backend): Add autoload cooking for
+	* emacs-lisp/generator.el: New file.
+
+	* vc/vc.el (vc-responsible-backend): Add autoload cookie for
 	`vc-responsible-backend'.

 2015-03-01  Michael Albinus  <michael.albinus@gmx.de>
diff --git a/test/ChangeLog b/test/ChangeLog
index 684e98f..64ad851 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -1,5 +1,7 @@
 2015-03-02  Daniel Colascione  <dancol@dancol.org>

+	* automated/generator-tests.el: New tests
+
 	* automated/finalizer-tests.el (finalizer-basic)
 	(finalizer-circular-reference, finalizer-cross-reference)
 	(finalizer-error): New tests.
This commit is contained in:
Daniel Colascione 2015-03-01 23:57:51 -08:00
parent 9d8d065814
commit f6b5db6c45
10 changed files with 1215 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
doc/lispref/ChangeLog
View file

@ -1,3 +1,8 @@
2015-03-02 Daniel Colascione <dancol@dancol.org>
* control.texi (Generators): New section
* elisp.text: Reference new section.
2015-02-28 Eli Zaretskii <eliz@gnu.org>
* searching.texi (Char Classes): Update the documentation of

116
doc/lispref/control.texi
View file

@ -39,6 +39,7 @@ structure constructs (@pxref{Macros}).
* Conditionals:: @code{if}, @code{cond}, @code{when}, @code{unless}.
* Combining Conditions:: @code{and}, @code{or}, @code{not}.
* Iteration:: @code{while} loops.
* Generators:: Generic sequences and coroutines.
* Nonlocal Exits:: Jumping out of a sequence.
@end menu
@ -620,6 +621,121 @@ Here is an example of using @code{dotimes} to do something 100 times:
@end example
@end defmac
@node Generators
@section Generators
@cindex generators
A @dfn{generator} is a function that produces a potentially-infinite
stream of values. Each time the function produces a value, it
suspends itself and waits for a caller to request the next value.
@defmac iter-defun name args [doc] [declare] [interactive] body@dots{}
@code{iter-defun} defines a generator function. A generator function
has the same signature as a normal function, but works differently.
Instead of executing @var{body} when called, a generator function
returns an iterator object. That iterator runs @var{body} to generate
values, emitting a value and pausing where @code{iter-yield} or
@code{iter-yield-from} appears. When @var{body} returns normally,
@code{iter-next} signals @code{iter-end-of-sequence} with @var{body}'s
result as its condition data.
Any kind of Lisp code is valid inside @var{body}, but
@code{iter-yield} and @code{iter-yield-from} cannot appear inside
@code{unwind-protect} forms.
@end defmac
@defmac iter-lambda args [doc] [interactive] body@dots{}
@code{iter-lambda} produces an unnamed generator function that works
just like a generator function produced with @code{iter-defun}.
@end defmac
@defmac iter-yield value
When it appears inside a generator function, @code{iter-yield}
indicates that the current iterator should pause and return
@var{value} from @code{iter-next}. @code{iter-yield} evaluates to the
@code{value} parameter of next call to @code{iter-next}.
@end defmac
@defmac iter-yield-from iterator
@code{iter-yield-from} yields all the values that @var{iterator}
produces and evaluates to the value that @var{iterator}'s generator
function returns normally. While it has control, @var{iterator}
receives sent to the iterator using @code{iter-next}.
@end defmac
To use a generator function, first call it normally, producing a
@dfn{iterator} object. An iterator is a specific instance of a
generator. Then use @code{iter-next} to retrieve values from this
iterator. When there are no more values to pull from an iterator,
@code{iter-next} raises an @code{iter-end-of-sequence} condition with
the iterator's final value.
It's important to note that generator function bodies only execute
inside calls to @code{iter-next}. A call to a function defined with
@code{iter-defun} produces an iterator; you must ``drive'' this
iterator with @code{iter-next} for anything interesting to happen.
Each call to a generator function produces a @emph{different}
iterator, each with its own state.
@defun iter-next iterator value
Retrieve the next value from @var{iterator}. If there are no more
values to be generated (because @var{iterator}'s generator function
returned), @code{iter-next} signals the @code{iter-end-of-sequence}
condition; the data value associated with this condition is the value
with which @var{iterator}'s generator function returned.
@var{value} is sent into the iterator and becomes the value to which
@code{iter-yield} evaluates. @var{value} is ignored for the first
@code{iter-next} call to a given iterator, since at the start of
@var{iterator}'s generator function, the generator function is not
evaluating any @code{iter-yield} form.
@end defun
@defun iter-close iterator
If @var{iterator} is suspended inside a @code{unwind-protect} and
becomes unreachable, Emacs will eventually run unwind handlers after a
garbage collection pass. To ensure that these handlers are run before
then, use @code{iter-close}.
@end defun
Some convenience functions are provided to make working with
iterators easier:
@defmac iter-do (var iterator) body @dots{}
Run @var{body} with @var{var} bound to each value that
@var{iterator} produces.
@end defmac
The Common Lisp loop facility also contains features for working with
iterators. See @xref{Loop Facility,,,cl,Common Lisp Extensions}.
The following piece of code demonstrates some important principles of
working with iterators.
@example
(iter-defun my-iter (x)
(iter-yield (1+ (iter-yield (1+ x))))
-1 ;; Return normally
)
(let* ((iter (my-iter 5))
(iter2 (my-iter 0)))
;; Prints 6
(print (iter-next iter))
;; Prints 9
(print (iter-next iter 8))
;; Prints 1; iter and iter2 have distinct states
(print (iter-next iter2 nil))
;; We expect the iter sequence to end now
(condition-case x
(iter-next iter)
(iter-end-of-sequence
;; Prints -1, which my-iter returned normally
(print (cdr x)))))
@end example
@node Nonlocal Exits
@section Nonlocal Exits
@cindex nonlocal exits

1
doc/lispref/elisp.texi
View file

@ -464,6 +464,7 @@ Control Structures
* Conditionals:: @code{if}, @code{cond}, @code{when}, @code{unless}.
* Combining Conditions:: @code{and}, @code{or}, @code{not}.
* Iteration:: @code{while} loops.
* Generators:: Generic sequences and coroutines.
* Nonlocal Exits:: Jumping out of a sequence.
Nonlocal Exits

4
doc/misc/ChangeLog
View file

@ -1,3 +1,7 @@
2015-03-02 Daniel Colascione <dancol@dancol.org>
* cl.texi (Iteration Clauses): Mention iterator support.
2015-02-25 Tassilo Horn <tsdh@gnu.org>
* reftex.texi (Multifile Documents): Document

5
doc/misc/cl.texi
View file

@ -2237,6 +2237,11 @@ This clause is like @code{always}, except that the loop returns
This clause stops the loop when the specified form is non-@code{nil};
in this case, it returns that non-@code{nil} value. If all the
values were @code{nil}, the loop returns @code{nil}.
@item iter-by @var{iterator}
This clause iterates over the values from the specified form, an
iterator object. See (@pxref{Generators,,,elisp,GNU Emacs Lisp
Reference Manual}).
@end table
@node Accumulation Clauses

2
etc/NEWS
View file

@ -621,6 +621,8 @@ word syntax, use `\sw' instead.
* Lisp Changes in Emacs 25.1
** Emacs Lisp now supports generators.
** New finalizer facility for running code when objects
become unreachable.

4
lisp/ChangeLog
View file

@ -1,6 +1,8 @@
2015-03-02 Daniel Colascione <dancol@dancol.org>
* vc/vc.el (vc-responsible-backend): Add autoload cooking for
* emacs-lisp/generator.el: New file.
* vc/vc.el (vc-responsible-backend): Add autoload cookie for
`vc-responsible-backend'.
2015-03-01 Michael Albinus <michael.albinus@gmx.de>

789
lisp/emacs-lisp/generator.el Normal file
View file

@ -0,0 +1,789 @@
;;; generator.el --- generators -*- lexical-binding: t -*-
;;; Copyright (C) 2015 Free Software Foundation, Inc.
;; Author: Daniel Colascione <dancol@dancol.org>
;; Keywords: extensions, elisp
;; Package: emacs
;; Copyright (C) Daniel Colascione
;; 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 <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This package implements generators for Emacs Lisp through a
;; continuation-passing transformation. It provides essentially the
;; same generator API and iterator facilties that Python and
;; JavaScript ES6 provide.
;;
;; `iter-lambda' and `iter-defun' work like `lambda' and `defun',
;; except that they evaluate to or define, respectively, generator
;; functions. These functions, when called, return an iterator.
;; An iterator is an opaque object that generates a sequence of
;; values. Callers use `iter-next' to retrieve the next value from
;; the sequence; when the sequence is exhausted, `iter-next' will
;; raise the `iter-end-of-sequence' condition.
;;
;; Generator functions are written like normal functions, except that
;; they can invoke `iter-yield' to suspend themselves and return a
;; value to callers; this value becomes the return value of
;; `iter-next'. On the next call to `iter-next', execution of the
;; generator function resumes where it left off. When a generator
;; function returns normally, the `iter-next' raises
;; `iter-end-of-sequence' with the value the function returned.
;;
;; `iter-yield-from' yields all the values from another iterator; it
;; then evaluates to the value the sub-iterator returned normally.
;; This facility is useful for functional composition of generators
;; and for implementing coroutines.
;;
;; `iter-yield' is illegal inside the UNWINDFORMS of an
;; `unwind-protect' for various sordid internal reasons documented in
;; the code.
;;
;; N.B. Each call to a generator function generates a *new* iterator,
;; and each iterator maintains its own internal state.
;;
;; This raw form of iteration is general, but a bit awkward to use, so
;; this library also provides soem convenience functions:
;;
;; `iter-do' is like `cl-do', except that instead of walking a list,
;; it walks an iterator. `cl-loop' is also extended with a new
;; keyword, `iter-by', that iterates over an iterator.
;;
;;; Implementation:
;;
;; The internal cps transformation code uses the cps- namespace.
;; Iteration functions use the `iter-' namespace. Generator functions
;; are somewhat less efficient than conventional elisp routines,
;; although we try to avoid CPS transformation on forms that do not
;; invoke `iter-yield'.
;;
;;; Code:
(require 'cl-lib)
(require 'pcase)
(defvar *cps-bindings* nil)
(defvar *cps-states* nil)
(defvar *cps-value-symbol* nil)
(defvar *cps-state-symbol* nil)
(defvar *cps-cleanup-table-symbol* nil)
(defvar *cps-cleanup-function* nil)
(defvar *cps-dynamic-wrappers* '(identity)
"List of transformer functions to apply to atomic forms we
evaluate in CPS context.")
(defconst cps-standard-special-forms
'(setq setq-default throw interactive)
"List of special forms that we treat just like ordinary
function applications." )
(defun cps--trace-funcall (func &rest args)
(message "%S: args=%S" func args)
(let ((result (apply func args)))
(message "%S: result=%S" func result)
result))
(defun cps--trace (fmt &rest args)
(princ (apply #'format (concat fmt "\n") args)))
(defun cps--special-form-p (definition)
"Non-nil if and only if DEFINITION is a special form."
;; Copied from ad-special-form-p
(if (and (symbolp definition) (fboundp definition))
(setf definition (indirect-function definition)))
(and (subrp definition) (eq (cdr (subr-arity definition)) 'unevalled)))
(defmacro cps--define-unsupported (function)
`(defun ,(intern (format "cps--transform-%s" function))
(error "%s not supported in generators" ,function)))
(defmacro cps--with-value-wrapper (wrapper &rest body)
"Continue generating CPS code with an atomic-form wrapper
to the current stack of such wrappers. WRAPPER is a function that
takes a form and returns a wrapped form.
Whenever we generate an atomic form (i.e., a form that can't
iter-yield), we first (before actually inserting that form in our
generated code) pass that form through all the transformer
functions. We use this facility to wrap forms that can transfer
control flow non-locally in goo that diverts this control flow to
the CPS state machinery.
"
(declare (indent 1))
`(let ((*cps-dynamic-wrappers*
(cons
,wrapper
*cps-dynamic-wrappers*)))
,@body))
(defun cps--make-dynamic-binding-wrapper (dynamic-var static-var)
(cl-assert lexical-binding)
(lambda (form)
`(let ((,dynamic-var ,static-var))
(unwind-protect ; Update the static shadow after evaluation is done
,form
(setf ,static-var ,dynamic-var))
,form)))
(defmacro cps--with-dynamic-binding (dynamic-var static-var &rest body)
"Evaluate BODY such that generated atomic evaluations run with
DYNAMIC-VAR bound to STATIC-VAR."
(declare (indent 2))
`(cps--with-value-wrapper
(cps--make-dynamic-binding-wrapper ,dynamic-var ,static-var)
,@body))
(defun cps--add-state (kind body)
"Create a new CPS state with body BODY and return the state's name."
(declare (indent 1))
(let* ((state (cl-gensym (format "cps-state-%s-" kind))))
(push (list state body *cps-cleanup-function*) *cps-states*)
(push state *cps-bindings*)
state))
(defun cps--add-binding (original-name)
(car (push (cl-gensym (format "cps-binding-%s-" original-name))
*cps-bindings*)))
(defun cps--find-special-form-handler (form)
(let* ((handler-name (format "cps--transform-%s" (car-safe form)))
(handler (intern-soft handler-name)))
(and (fboundp handler) handler)))
(defvar cps-disable-atomic-optimization nil
"When t, always rewrite forms into cps even when they
don't yield.")
(defvar cps--yield-seen)
(defun cps--atomic-p (form)
"Return whether the given form never yields."
(and (not cps-disable-atomic-optimization)
(let* ((cps--yield-seen))
(ignore (macroexpand-all
`(cl-macrolet ((cps-internal-yield
(_val)
(setf cps--yield-seen t)))
,form)))
(not cps--yield-seen))))
(defun cps--make-atomic-state (form next-state)
(let ((tform `(prog1 ,form (setf ,*cps-state-symbol* ,next-state))))
(cl-loop for wrapper in *cps-dynamic-wrappers*
do (setf tform (funcall wrapper tform)))
;; Bind *cps-cleanup-function* to nil here because the wrapper
;; function mechanism is responsible for cleanup here, not the
;; generic cleanup mechanism. If we didn't make this binding,
;; we'd run cleanup handlers twice on anything that made it out
;; to toplevel.
(let ((*cps-cleanup-function* nil))
(cps--add-state "atom"
`(setf ,*cps-value-symbol* ,tform)))))
(defun cps--transform-1 (form next-state)
(pcase form
;; If we're looking at an "atomic" form (i.e., one that does not
;; iter-yield), just evaluate the form as a whole instead of rewriting
;; it into CPS.
((guard (cps--atomic-p form))
(cps--make-atomic-state form next-state))
;; Process `and'.
(`(and) ; (and) -> t
(cps--transform-1 t next-state))
(`(and ,condition) ; (and CONDITION) -> CONDITION
(cps--transform-1 condition next-state))
(`(and ,condition . ,rest)
;; Evaluate CONDITION; if it's true, go on to evaluate the rest
;; of the `and'.
(cps--transform-1
condition
(cps--add-state "and"
`(setf ,*cps-state-symbol*
(if ,*cps-value-symbol*
,(cps--transform-1 `(and ,@rest)
next-state)
,next-state)))))
;; Process `catch'.
(`(catch ,tag . ,body)
(let ((tag-binding (cps--add-binding "catch-tag")))
(cps--transform-1 tag
(cps--add-state "cps-update-tag"
`(setf ,tag-binding ,*cps-value-symbol*
,*cps-state-symbol*
,(cps--with-value-wrapper
(cps--make-catch-wrapper
tag-binding next-state)
(cps--transform-1 `(progn ,@body)
next-state)))))))
;; Process `cond': transform into `if' or `or' depending on the
;; precise kind of the condition we're looking at.
(`(cond) ; (cond) -> nil
(cps--transform-1 nil next-state))
(`(cond (,condition) . ,rest)
(cps--transform-1 `(or ,condition (cond ,@rest))
next-state))
(`(cond (,condition . ,body) . ,rest)
(cps--transform-1 `(if ,condition
(progn ,@body)
(cond ,@rest))
next-state))
;; Process `condition-case': do the heavy lifting in a helper
;; function.
(`(condition-case ,var ,bodyform . ,handlers)
(cps--with-value-wrapper
(cps--make-condition-wrapper var next-state handlers)
(cps--transform-1 bodyform
next-state)))
;; Process `if'.
(`(if ,cond ,then . ,else)
(cps--transform-1 cond
(cps--add-state "if"
`(setf ,*cps-state-symbol*
(if ,*cps-value-symbol*
,(cps--transform-1 then
next-state)
,(cps--transform-1 `(progn ,@else)
next-state))))))
;; Process `progn' and `inline': they are identical except for the
;; name, which has some significance to the byte compiler.
(`(inline) (cps--transform-1 nil next-state))
(`(inline ,form) (cps--transform-1 form next-state))
(`(inline ,form . ,rest)
(cps--transform-1 form
(cps--transform-1 `(inline ,@rest)
next-state)))
(`(progn) (cps--transform-1 nil next-state))
(`(progn ,form) (cps--transform-1 form next-state))
(`(progn ,form . ,rest)
(cps--transform-1 form
(cps--transform-1 `(progn ,@rest)
next-state)))
;; Process `let' in a helper function that transforms it into a
;; let* with temporaries.
(`(let ,bindings . ,body)
(let* ((bindings (cl-loop for binding in bindings
collect (if (symbolp binding)
(list binding nil)
binding)))
(temps (cl-loop for (var value-form) in bindings
collect (cps--add-binding var))))
(cps--transform-1
`(let* ,(append
(cl-loop for (var value-form) in bindings
for temp in temps
collect (list temp value-form))
(cl-loop for (var binding) in bindings
for temp in temps
collect (list var temp)))
,@body)
next-state)))
;; Process `let*' binding: process one binding at a time. Flatten
;; lexical bindings.
(`(let* () . ,body)
(cps--transform-1 `(progn ,@body) next-state))
(`(let* (,binding . ,more-bindings) . ,body)
(let* ((var (if (symbolp binding) binding (car binding)))
(value-form (car (cdr-safe binding)))
(new-var (cps--add-binding var)))
(cps--transform-1
value-form
(cps--add-state "let*"
`(setf ,new-var ,*cps-value-symbol*
,*cps-state-symbol*
,(if (or (not lexical-binding) (special-variable-p var))
(cps--with-dynamic-binding var new-var
(cps--transform-1
`(let* ,more-bindings ,@body)
next-state))
(cps--transform-1
(cps--replace-variable-references
var new-var
`(let* ,more-bindings ,@body))
next-state)))))))
;; Process `or'.
(`(or) (cps--transform-1 nil next-state))
(`(or ,condition) (cps--transform-1 condition next-state))
(`(or ,condition . ,rest)
(cps--transform-1
condition
(cps--add-state "or"
`(setf ,*cps-state-symbol*
(if ,*cps-value-symbol*
,next-state
,(cps--transform-1
`(or ,@rest) next-state))))))
;; Process `prog1'.
(`(prog1 ,first) (cps--transform-1 first next-state))
(`(prog1 ,first . ,body)
(cps--transform-1
first
(let ((temp-var-symbol (cps--add-binding "prog1-temp")))
(cps--add-state "prog1"
`(setf ,temp-var-symbol
,*cps-value-symbol*
,*cps-state-symbol*
,(cps--transform-1
`(progn ,@body)
(cps--add-state "prog1inner"
`(setf ,*cps-value-symbol* ,temp-var-symbol
,*cps-state-symbol* ,next-state))))))))
;; Process `prog2'.
(`(prog2 ,form1 ,form2 . ,body)
(cps--transform-1
`(progn ,form1 (prog1 ,form2 ,@body))
next-state))
;; Process `unwind-protect': If we're inside an unwind-protect, we
;; have a block of code UNWINDFORMS which we would like to run
;; whenever control flows away from the main piece of code,
;; BODYFORM. We deal with the local control flow case by
;; generating BODYFORM such that it yields to a continuation that
;; executes UNWINDFORMS, which then yields to NEXT-STATE.
;;
;; Non-local control flow is trickier: we need to ensure that we
;; execute UNWINDFORMS even when control bypasses our normal
;; continuation. To make this guarantee, we wrap every external
;; application (i.e., every piece of elisp that can transfer
;; control non-locally) in an unwind-protect that runs UNWINDFORMS
;; before allowing the non-local control transfer to proceed.
;;
;; Unfortunately, because elisp lacks a mechanism for generically
;; capturing the reason for an arbitrary non-local control
;; transfer and restarting the transfer at a later point, we
;; cannot reify non-local transfers and cannot allow
;; continuation-passing code inside UNWINDFORMS.
(`(unwind-protect ,bodyform . ,unwindforms)
;; Signal the evaluator-generator that it needs to generate code
;; to handle cleanup forms.
(unless *cps-cleanup-table-symbol*
(setf *cps-cleanup-table-symbol* (cl-gensym "cps-cleanup-table-")))
(let* ((unwind-state
(cps--add-state
"unwind"
;; N.B. It's safe to just substitute unwindforms by
;; sexp-splicing: we've already replaced all variable
;; references inside it with lifted equivalents.
`(progn
,@unwindforms
(setf ,*cps-state-symbol* ,next-state))))
(old-cleanup *cps-cleanup-function*)
(*cps-cleanup-function*
(let ((*cps-cleanup-function* nil))
(cps--add-state "cleanup"
`(progn
,(when old-cleanup `(funcall ,old-cleanup))
,@unwindforms)))))
(cps--with-value-wrapper
(cps--make-unwind-wrapper unwindforms)
(cps--transform-1 bodyform unwind-state))))
;; Process `while'.
(`(while ,test . ,body)
;; Open-code state addition instead of using cps--add-state: we
;; need our states to be self-referential. (That's what makes the
;; state a loop.)
(let* ((loop-state
(cl-gensym "cps-state-while-"))
(eval-loop-condition-state
(cps--transform-1 test loop-state))
(loop-state-body
`(progn
(setf ,*cps-state-symbol*
(if ,*cps-value-symbol*
,(cps--transform-1
`(progn ,@body)
eval-loop-condition-state)
,next-state)))))
(push (list loop-state loop-state-body *cps-cleanup-function*)
*cps-states*)
(push loop-state *cps-bindings*)
eval-loop-condition-state))
;; Process various kinds of `quote'.
(`(quote ,arg) (cps--add-state "quote"
`(setf ,*cps-value-symbol* (quote ,arg)
,*cps-state-symbol* ,next-state)))
(`(function ,arg) (cps--add-state "function"
`(setf ,*cps-value-symbol* (function ,arg)
,*cps-state-symbol* ,next-state)))
;; Deal with `iter-yield'.
(`(cps-internal-yield ,value)
(cps--transform-1
value
(cps--add-state "iter-yield"
`(progn
(setf ,*cps-state-symbol*
,(if *cps-cleanup-function*
(cps--add-state "after-yield"
`(setf ,*cps-state-symbol* ,next-state))
next-state))
(throw 'cps--yield ,*cps-value-symbol*)))))
;; Catch any unhandled special forms.
((and `(,name . ,_)
(guard (cps--special-form-p name))
(guard (not (memq name cps-standard-special-forms))))
name ; Shut up byte compiler
(error "special form %S incorrect or not supported" form))
;; Process regular function applications with nontrivial
;; parameters, converting them to applications of trivial
;; let-bound parameters.
((and `(,function . ,arguments)
(guard (not (cl-loop for argument in arguments
always (atom argument)))))
(let ((argument-symbols
(cl-loop for argument in arguments
collect (if (atom argument)
argument
(cl-gensym "cps-argument-")))))
(cps--transform-1
`(let* ,(cl-loop for argument in arguments
for argument-symbol in argument-symbols
unless (eq argument argument-symbol)
collect (list argument-symbol argument))
,(cons function argument-symbols))
next-state)))
;; Process everything else by just evaluating the form normally.
(t (cps--make-atomic-state form next-state))))
(defun cps--make-catch-wrapper (tag-binding next-state)
(lambda (form)
(let ((normal-exit-symbol
(cl-gensym "cps-normal-exit-from-catch-")))
`(let (,normal-exit-symbol)
(prog1
(catch ,tag-binding
(prog1
,form
(setf ,normal-exit-symbol t)))
(unless ,normal-exit-symbol
(setf ,*cps-state-symbol* ,next-state)))))))
(defun cps--make-condition-wrapper (var next-state handlers)
;; Each handler is both one of the transformers with which we wrap
;; evaluated atomic forms and a state to which we jump when we
;; encounter the given error.
(let* ((error-symbol (cps--add-binding "condition-case-error"))
(lexical-error-symbol (cl-gensym "cps-lexical-error-"))
(processed-handlers
(cl-loop for (condition . body) in handlers
collect (cons condition
(cps--transform-1
(cps--replace-variable-references
var error-symbol
`(progn ,@body))
next-state)))))
(lambda (form)
`(condition-case
,lexical-error-symbol
,form
,@(cl-loop
for (condition . error-state) in processed-handlers
collect
`(,condition
(setf ,error-symbol
,lexical-error-symbol
,*cps-state-symbol*
,error-state)))))))
(defun cps--replace-variable-references (var new-var form)
"Replace all non-shadowed references to VAR with NEW-VAR in FORM.
This routine does not modify FORM. Instead, it returns a
modified copy."
(macroexpand-all
`(cl-symbol-macrolet ((,var ,new-var)) ,form)))
(defun cps--make-unwind-wrapper (unwind-forms)
(cl-assert lexical-binding)
(lambda (form)
(let ((normal-exit-symbol
(cl-gensym "cps-normal-exit-from-unwind-")))
`(let (,normal-exit-symbol)
(unwind-protect
(prog1
,form
(setf ,normal-exit-symbol t))
(unless ,normal-exit-symbol
,@unwind-forms))))))
(put 'iter-end-of-sequence 'error-conditions '(iter-end-of-sequence))
(put 'iter-end-of-sequence 'error-message "iteration terminated")
(defun cps--make-close-iterator-form (terminal-state)
(if *cps-cleanup-table-symbol*
`(let ((cleanup (cdr (assq ,*cps-state-symbol* ,*cps-cleanup-table-symbol*))))
(setf ,*cps-state-symbol* ,terminal-state
,*cps-value-symbol* nil)
(when cleanup (funcall cleanup)))
`(setf ,*cps-state-symbol* ,terminal-state
,*cps-value-symbol* nil)))
(defun cps-generate-evaluator (form)
(let* (*cps-states*
*cps-bindings*
*cps-cleanup-function*
(*cps-value-symbol* (cl-gensym "cps-current-value-"))
(*cps-state-symbol* (cl-gensym "cps-current-state-"))
;; We make *cps-cleanup-table-symbol** non-nil when we notice
;; that we have cleanup processing to perform.
(*cps-cleanup-table-symbol* nil)
(terminal-state (cps--add-state "terminal"
`(signal 'iter-end-of-sequence
,*cps-value-symbol*)))
(initial-state (cps--transform-1
(macroexpand-all form)
terminal-state))
(finalizer-symbol
(when *cps-cleanup-table-symbol*
(when *cps-cleanup-table-symbol*
(cl-gensym "cps-iterator-finalizer-")))))
`(let ,(append (list *cps-state-symbol* *cps-value-symbol*)
(when *cps-cleanup-table-symbol*
(list *cps-cleanup-table-symbol*))
(when finalizer-symbol
(list finalizer-symbol))
(nreverse *cps-bindings*))
;; Order state list so that cleanup states are always defined
;; before they're referenced.
,@(cl-loop for (state body cleanup) in (nreverse *cps-states*)
collect `(setf ,state (lambda () ,body))
when cleanup
do (cl-assert *cps-cleanup-table-symbol*)
and collect `(push (cons ,state ,cleanup) ,*cps-cleanup-table-symbol*))
(setf ,*cps-state-symbol* ,initial-state)
(let ((iterator
(lambda (op value)
(cond
,@(when finalizer-symbol
`(((eq op :stash-finalizer)
(setf ,finalizer-symbol value))
((eq op :get-finalizer)
,finalizer-symbol)))
((eq op :close)
,(cps--make-close-iterator-form terminal-state))
((eq op :next)
(setf ,*cps-value-symbol* value)
(let ((yielded nil))
(unwind-protect
(prog1
(catch 'cps--yield
(while t
(funcall ,*cps-state-symbol*)))
(setf yielded t))
(unless yielded
;; If we're exiting non-locally (error, quit,
;; etc.) close the iterator.
,(cps--make-close-iterator-form terminal-state)))))
(t (error "unknown iterator operation %S" op))))))
,(when finalizer-symbol
`(funcall iterator
:stash-finalizer
(make-finalizer
(lambda ()
(iter-close iterator)))))
iterator))))
(defun iter-yield (value)
"When used inside a generator, yield control to caller.
The caller of `iter-next' receives VALUE, and the next call to
`iter-next' resumes execution at the previous
`iter-yield' point."
(identity value)
(error "`iter-yield' used outside a generator"))
(defmacro iter-yield-from (value)
"When used inside a generator function, delegate to a sub-iterator.
The values that the sub-iterator yields are passed directly to
the caller, and values supplied to `iter-next' are sent to the
sub-iterator. `iter-yield-from' evaluates to the value that the
sub-iterator function returns via `iter-end-of-sequence'."
(let ((errsym (cl-gensym "yield-from-result"))
(valsym (cl-gensym "yield-from-value")))
`(let ((,valsym ,value))
(unwind-protect
(condition-case ,errsym
(let ((vs nil))
(while t
(setf vs (iter-yield (iter-next ,valsym vs)))))
(iter-end-of-sequence (cdr ,errsym)))
(iter-close ,valsym)))))
(defmacro iter-defun (name arglist &rest body)
"Creates a generator NAME.
When called as a function, NAME returns an iterator value that
encapsulates the state of a computation that produces a sequence
of values. Callers can retrieve each value using `iter-next'."
(declare (indent defun))
(cl-assert lexical-binding)
`(defun ,name ,arglist
,(cps-generate-evaluator
`(cl-macrolet ((iter-yield (value) `(cps-internal-yield ,value)))
,@body))))
(defmacro iter-lambda (arglist &rest body)
"Return a lambda generator.
`iter-lambda' is to `iter-defun' as `lambda' is to `defun'."
(declare (indent defun))
(cl-assert lexical-binding)
`(lambda ,arglist
,(cps-generate-evaluator
`(cl-macrolet ((iter-yield (value) `(cps-internal-yield ,value)))
,@body))))
(defun iter-next (iterator &optional yield-result)
"Extract a value from an iterator.
YIELD-RESULT becomes the return value of `iter-yield` in the
context of the generator.
This routine raises the `iter-end-of-sequence' condition if the
iterator cannot supply more values."
(funcall iterator :next yield-result))
(defun iter-close (iterator)
"Terminate an iterator early.
Run any unwind-protect handlers in scope at the point ITERATOR
is blocked."
(funcall iterator :close nil))
(cl-defmacro iter-do ((var iterator) &rest body)
"Loop over values from an iterator.
Evaluate BODY with VAR bound to each value from ITERATOR.
Return the value with which ITERATOR finished iteration."
(declare (indent 1))
(let ((done-symbol (cl-gensym "iter-do-iterator-done"))
(condition-symbol (cl-gensym "iter-do-condition"))
(it-symbol (cl-gensym "iter-do-iterator"))
(result-symbol (cl-gensym "iter-do-result")))
`(let (,var
,result-symbol
(,done-symbol nil)
(,it-symbol ,iterator))
(while (not ,done-symbol)
(condition-case ,condition-symbol
(setf ,var (iter-next ,it-symbol))
(iter-end-of-sequence
(setf ,result-symbol (cdr ,condition-symbol))
(setf ,done-symbol t)))
(unless ,done-symbol ,@body))
,result-symbol)))
(defvar cl--loop-args)
(defmacro cps--advance-for (conscell)
;; See cps--handle-loop-for
`(condition-case nil
(progn
(setcar ,conscell (iter-next (cdr ,conscell)))
,conscell)
(iter-end-of-sequence
nil)))
(defmacro cps--initialize-for (iterator)
;; See cps--handle-loop-for
(let ((cs (cl-gensym "cps--loop-temp")))
`(let ((,cs (cons nil ,iterator)))
(cps--advance-for ,cs))))
(defun cps--handle-loop-for (var)
"Support `iter-by' in `loop'. "
;; N.B. While the cl-loop-for-handler is a documented interface,
;; there's no documented way for cl-loop-for-handler callbacks to do
;; anything useful! Additionally, cl-loop currently lexbinds useful
;; internal variables, so our only option is to modify
;; cl--loop-args. If we substitute a general-purpose for-clause for
;; our iterating clause, however, we can't preserve the
;; parallel-versus-sequential `loop' semantics for for clauses ---
;; we need a terminating condition as well, which requires us to use
;; while, and inserting a while would break and-sequencing.
;;
;; To work around this problem, we actually use the "for var in LIST
;; by FUNCTION" syntax, creating a new fake list each time through
;; the loop, this "list" being a cons cell (val . it).
(let ((it-form (pop cl--loop-args)))
(setf cl--loop-args
(append
`(for ,var
in (cps--initialize-for ,it-form)
by 'cps--advance-for)
cl--loop-args))))
(put 'iter-by 'cl-loop-for-handler 'cps--handle-loop-for)
(eval-after-load 'elisp-mode
(lambda ()
(font-lock-add-keywords
'emacs-lisp-mode
'(("(\\(iter-defun\\)\\_>\\s *\\(\\(?:\\sw\\|\\s_\\)+\\)?"
(1 font-lock-keyword-face nil t)
(2 font-lock-function-name-face nil t))
("(\\(iter-next\\)\\_>"
(1 font-lock-keyword-face nil t))
("(\\(iter-lambda\\)\\_>"
(1 font-lock-keyword-face nil t))
("(\\(iter-yield\\)\\_>"
(1 font-lock-keyword-face nil t))
("(\\(iter-yield-from\\)\\_>"
(1 font-lock-keyword-face nil t))))))
(provide 'generator)
;;; generator.el ends here

2
test/ChangeLog
View file

@ -1,5 +1,7 @@
2015-03-02 Daniel Colascione <dancol@dancol.org>
* automated/generator-tests.el: New tests
* automated/finalizer-tests.el (finalizer-basic)
(finalizer-circular-reference, finalizer-cross-reference)
(finalizer-error): New tests.

288
test/automated/generator-tests.el Normal file
View file

@ -0,0 +1,288 @@
;;; generator-tests.el --- Testing generators -*- lexical-binding: t -*-
;; Copyright (C) 2015 Free Software Foundation, Inc.
;; Author: Daniel Colascione <dancol@dancol.org>
;; Keywords:
;; This program 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.
;; This program 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 this program. If not, see <http://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-disable-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)
(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))
(assert (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-close-finalizer ()
(skip-unless gc-precise-p)
(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))
(setf iter nil)
(garbage-collect)
(should 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))
(incf nr-unwound))))))
(should (equal (iter-next iter) 1))
(should-error (iter-next iter))
(should (equal nr-unwound 1))))