Function: cps--transform-1
cps--transform-1 is a byte-compiled function defined in
generator.el.gz.
Signature
(cps--transform-1 FORM NEXT-STATE)
Source Code
;; Defined in /usr/src/emacs/lisp/emacs-lisp/generator.el.gz
(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 `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 (cps--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
(cps--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
(cps--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.
(_ (cps--make-atomic-state form next-state))))