Function: cps-generate-evaluator

cps-generate-evaluator is a byte-compiled function defined in generator.el.gz.

Signature

(cps-generate-evaluator BODY)

Source Code

;; Defined in /usr/src/emacs/lisp/emacs-lisp/generator.el.gz
(defun cps-generate-evaluator (body)
  (let* (cps--states
         cps--bindings
         cps--cleanup-function
         (cps--value-symbol (cps--gensym "cps-current-value-"))
         (cps--state-symbol (cps--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
                          `(cl-macrolet
                               ((iter-yield (value)
                                  `(cps-internal-yield ,value)))
                             ,@body)
                          macroexpand-all-environment)
                         terminal-state))
         (finalizer-symbol
          (when cps--cleanup-table-symbol
            (when cps--cleanup-table-symbol
              (cps--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))))