(defvar cps--cleanup-table-symbol nil)
(defvar cps--cleanup-function nil)
+(defmacro cps--gensym (fmt &rest args)
+ ;; Change this function to use `cl-gensym' if you want the generated
+ ;; code to be easier to read and debug.
+ ;; (cl-gensym (apply #'format fmt args))
+ `(make-symbol ,fmt))
+
(defvar cps--dynamic-wrappers '(identity)
"List of transformer functions to apply to atomic forms we
evaluate in CPS context.")
(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))))
+ (let* ((state (cps--gensym "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))
+ (car (push (cps--gensym (format "cps-binding-%s-" original-name))
cps--bindings)))
(defun cps--find-special-form-handler (form)
(handler (intern-soft handler-name)))
(and (fboundp handler) handler)))
-(defvar cps-disable-atomic-optimization nil
+(defvar cps-inhibit-atomic-optimization nil
"When t, always rewrite forms into cps even when they
don't yield.")
(defun cps--atomic-p (form)
"Return whether the given form never yields."
- (and (not cps-disable-atomic-optimization)
+ (and (not cps-inhibit-atomic-optimization)
(let* ((cps--yield-seen))
(ignore (macroexpand-all
`(cl-macrolet ((cps-internal-yield
(_val)
(setf cps--yield-seen t)))
- ,form)))
+ ,form)
+ macroexpand-all-environment))
(not cps--yield-seen))))
(defun cps--make-atomic-state (form next-state)
;; 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-")))
+ (setf cps--cleanup-table-symbol (cps--gensym "cps-cleanup-table-")))
(let* ((unwind-state
(cps--add-state
"unwind"
;; need our states to be self-referential. (That's what makes the
;; state a loop.)
(let* ((loop-state
- (cl-gensym "cps-state-while-"))
+ (cps--gensym "cps-state-while-"))
(eval-loop-condition-state
(cps--transform-1 test loop-state))
(loop-state-body
(cl-loop for argument in arguments
collect (if (atom argument)
argument
- (cl-gensym "cps-argument-")))))
+ (cps--gensym "cps-argument-")))))
(cps--transform-1
`(let* ,(cl-loop for argument in arguments
(defun cps--make-catch-wrapper (tag-binding next-state)
(lambda (form)
(let ((normal-exit-symbol
- (cl-gensym "cps-normal-exit-from-catch-")))
+ (cps--gensym "cps-normal-exit-from-catch-")))
`(let (,normal-exit-symbol)
(prog1
(catch ,tag-binding
;; encounter the given error.
(let* ((error-symbol (cps--add-binding "condition-case-error"))
- (lexical-error-symbol (cl-gensym "cps-lexical-error-"))
+ (lexical-error-symbol (cps--gensym "cps-lexical-error-"))
(processed-handlers
(cl-loop for (condition . body) in handlers
collect (cons condition
This routine does not modify FORM. Instead, it returns a
modified copy."
(macroexpand-all
- `(cl-symbol-macrolet ((,var ,new-var)) ,form)))
+ `(cl-symbol-macrolet ((,var ,new-var)) ,form)
+ macroexpand-all-environment))
(defun cps--make-unwind-wrapper (unwind-forms)
(cl-assert lexical-binding)
(lambda (form)
(let ((normal-exit-symbol
- (cl-gensym "cps-normal-exit-from-unwind-")))
+ (cps--gensym "cps-normal-exit-from-unwind-")))
`(let (,normal-exit-symbol)
(unwind-protect
(prog1
`(setf ,cps--state-symbol ,terminal-state
,cps--value-symbol nil)))
-(defun cps-generate-evaluator (form)
+(defun cps-generate-evaluator (body)
(let* (cps--states
cps--bindings
cps--cleanup-function
- (cps--value-symbol (cl-gensym "cps-current-value-"))
- (cps--state-symbol (cl-gensym "cps-current-state-"))
+ (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)
`(signal 'iter-end-of-sequence
,cps--value-symbol)))
(initial-state (cps--transform-1
- (macroexpand-all form)
+ (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
- (cl-gensym "cps-iterator-finalizer-")))))
+ (cps--gensym "cps-iterator-finalizer-")))))
`(let ,(append (list cps--state-symbol cps--value-symbol)
(when cps--cleanup-table-symbol
(list cps--cleanup-table-symbol))
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 ((errsym (cps--gensym "yield-from-result"))
+ (valsym (cps--gensym "yield-from-value")))
`(let ((,valsym ,value))
(unwind-protect
(condition-case ,errsym
(push (pop body) preamble))
`(defun ,name ,arglist
,@(nreverse preamble)
- ,(cps-generate-evaluator
- `(cl-macrolet ((iter-yield (value) `(cps-internal-yield ,value)))
- ,@body)))))
+ ,(cps-generate-evaluator body))))
(defmacro iter-lambda (arglist &rest body)
"Return a lambda generator.
(declare (indent defun))
(cl-assert lexical-binding)
`(lambda ,arglist
- ,(cps-generate-evaluator
- `(cl-macrolet ((iter-yield (value) `(cps-internal-yield ,value)))
- ,@body))))
+ ,(cps-generate-evaluator body)))
(defun iter-next (iterator &optional yield-result)
"Extract a value 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 ((done-symbol (cps--gensym "iter-do-iterator-done"))
+ (condition-symbol (cps--gensym "iter-do-condition"))
+ (it-symbol (cps--gensym "iter-do-iterator"))
+ (result-symbol (cps--gensym "iter-do-result")))
`(let (,var
,result-symbol
(,done-symbol nil)
(defmacro cps--initialize-for (iterator)
;; See cps--handle-loop-for
- (let ((cs (cl-gensym "cps--loop-temp")))
+ (let ((cs (cps--gensym "cps--loop-temp")))
`(let ((,cs (cons nil ,iterator)))
(cps--advance-for ,cs))))
'(("(\\(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\\)\\_>"
+ ("(\\(iter-\\(?:next\\|lambda\\|yield\\|yield-from\\)\\)\\_>"
(1 font-lock-keyword-face nil t))))))
(provide 'generator)
projects / emacs.git / commitdiff