From f6b5db6c45b773f86e203368aee9153ec8527205 Mon Sep 17 00:00:00 2001 From: Daniel Colascione Date: Sun, 1 Mar 2015 23:57:51 -0800 Subject: [PATCH] Add support for generators 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 + + * control.texi (Generators): New section + * elisp.text: Reference new section. + 2015-02-28 Eli Zaretskii * 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 + + * cl.texi (Iteration Clauses): Mention iterator support. + 2015-02-25 Tassilo Horn * 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 - * 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 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 + * automated/generator-tests.el: New tests + * automated/finalizer-tests.el (finalizer-basic) (finalizer-circular-reference, finalizer-cross-reference) (finalizer-error): New tests. --- doc/lispref/ChangeLog | 5 + doc/lispref/control.texi | 116 +++++ doc/lispref/elisp.texi | 1 + doc/misc/ChangeLog | 4 + doc/misc/cl.texi | 5 + etc/NEWS | 2 + lisp/ChangeLog | 4 +- lisp/emacs-lisp/generator.el | 789 ++++++++++++++++++++++++++++++ test/ChangeLog | 2 + test/automated/generator-tests.el | 288 +++++++++++ 10 files changed, 1215 insertions(+), 1 deletion(-) create mode 100644 lisp/emacs-lisp/generator.el create mode 100644 test/automated/generator-tests.el diff --git a/doc/lispref/ChangeLog b/doc/lispref/ChangeLog index 78f7e34ca01..e7d79d55c7e 100644 --- a/doc/lispref/ChangeLog +++ b/doc/lispref/ChangeLog @@ -1,3 +1,8 @@ +2015-03-02 Daniel Colascione + + * control.texi (Generators): New section + * elisp.text: Reference new section. + 2015-02-28 Eli Zaretskii * searching.texi (Char Classes): Update the documentation of diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index d21292348a4..bec2bc92ac4 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -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 diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index cdc443f07d5..3802e49ec3d 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -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 diff --git a/doc/misc/ChangeLog b/doc/misc/ChangeLog index 448c7f26c1a..4e9c119379d 100644 --- a/doc/misc/ChangeLog +++ b/doc/misc/ChangeLog @@ -1,3 +1,7 @@ +2015-03-02 Daniel Colascione + + * cl.texi (Iteration Clauses): Mention iterator support. + 2015-02-25 Tassilo Horn * reftex.texi (Multifile Documents): Document diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi index 66776029353..052ca6bd786 100644 --- a/doc/misc/cl.texi +++ b/doc/misc/cl.texi @@ -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 diff --git a/etc/NEWS b/etc/NEWS index 6c94a587ad5..ad8b6f27812 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -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. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 7ce2e816d45..4ab4406dba1 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,6 +1,8 @@ 2015-03-02 Daniel Colascione - * 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 diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el new file mode 100644 index 00000000000..4e21e792406 --- /dev/null +++ b/lisp/emacs-lisp/generator.el @@ -0,0 +1,789 @@ +;;; generator.el --- generators -*- lexical-binding: t -*- + +;;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Daniel Colascione +;; 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 . + +;;; 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 diff --git a/test/ChangeLog b/test/ChangeLog index 684e98f880e..64ad85198af 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,5 +1,7 @@ 2015-03-02 Daniel Colascione + * automated/generator-tests.el: New tests + * automated/finalizer-tests.el (finalizer-basic) (finalizer-circular-reference, finalizer-cross-reference) (finalizer-error): New tests. diff --git a/test/automated/generator-tests.el b/test/automated/generator-tests.el new file mode 100644 index 00000000000..2c5de31b40b --- /dev/null +++ b/test/automated/generator-tests.el @@ -0,0 +1,288 @@ +;;; generator-tests.el --- Testing generators -*- lexical-binding: t -*- + +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Daniel Colascione +;; 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 . + +;;; 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)))) -- 2.39.2