--- /dev/null
+;;; 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
--- /dev/null
+;;; 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))))
projects / emacs.git / commitdiff