Function: cconv-convert
cconv-convert is a byte-compiled function defined in cconv.el.gz.
Signature
(cconv-convert FORM ENV EXTEND)
Documentation
Return FORM with all its lambdas changed so they are closed.
ENV is a lexical environment mapping variables to the expression
used to get its value. This is used for variables that are copied into
closures, moved into cons cells, ...
ENV is a list where each entry takes the shape either:
(VAR . (car-safe EXP)): VAR has been moved into the car of a cons-cell, and EXP
is an expression that evaluates to this cons-cell.
(VAR . (internal-get-closed-var N)): VAR has been copied into the closure
environment's Nth slot.
(VAR . (apply-partially F ARG1 ARG2 ..)): VAR has been λ-lifted and takes
additional arguments ARGs.
(VAR . nil): VAR is accessed normally. This is the same as VAR
being absent from ENV, but an explicit nil entry is useful
for shadowing VAR for a specific scope.
EXTEND is a list of variables which might need to be accessed even from places
where they are shadowed, because some part of ENV causes them to be used at
places where they originally did not directly appear.
Source Code
;; Defined in /usr/src/emacs/lisp/emacs-lisp/cconv.el.gz
(defun cconv-convert (form env extend)
;; This function actually rewrites the tree.
"Return FORM with all its lambdas changed so they are closed.
ENV is a lexical environment mapping variables to the expression
used to get its value. This is used for variables that are copied into
closures, moved into cons cells, ...
ENV is a list where each entry takes the shape either:
(VAR . (car-safe EXP)): VAR has been moved into the car of a cons-cell, and EXP
is an expression that evaluates to this cons-cell.
(VAR . (internal-get-closed-var N)): VAR has been copied into the closure
environment's Nth slot.
(VAR . (apply-partially F ARG1 ARG2 ..)): VAR has been λ-lifted and takes
additional arguments ARGs.
(VAR . nil): VAR is accessed normally. This is the same as VAR
being absent from ENV, but an explicit nil entry is useful
for shadowing VAR for a specific scope.
EXTEND is a list of variables which might need to be accessed even from places
where they are shadowed, because some part of ENV causes them to be used at
places where they originally did not directly appear."
(cl-assert (not (any (lambda (mapping)
(and (eq (cadr mapping) #'apply-partially)
(cconv--set-diff (cdr (cddr mapping))
extend)))
env)))
;; What's the difference between fvrs and envs?
;; Suppose that we have the code
;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1)))
;; only the first occurrence of fvr should be replaced by
;; (aref env ...).
;; So initially envs and fvrs are the same thing, but when we descend to
;; the 'let, we delete fvr from fvrs. Why we don't delete fvr from envs?
;; Because in envs the order of variables is important. We use this list
;; to find the number of a specific variable in the environment vector,
;; so we never touch it(unless we enter to the other closure).
;;(if (listp form) (print (car form)) form)
(macroexp--with-extended-form-stack form
(pcase form
(`(,(and letsym (or 'let* 'let)) ,binders . ,body)
; let and let* special forms
(let ((binders-new '())
(new-env env)
(new-extend extend))
(dolist (binder binders)
(let* ((value nil)
(var (if (not (consp binder))
(prog1 binder (setq binder (list binder)))
(when (cddr binder)
(byte-compile-warn-x
binder
"Malformed `%S' binding: %S"
letsym binder))
(setq value (cadr binder))
(car binder))))
(cond
;; Ignore bindings without a valid name.
((not (symbolp var))
(byte-compile-warn-x
var "attempt to let-bind nonvariable `%S'" var))
((or (booleanp var) (keywordp var))
(byte-compile-warn-x
var "attempt to let-bind constant `%S'" var))
(t
(let ((new-val
(pcase (cconv--var-classification binder form)
;; Check if var is a candidate for lambda lifting.
((and :lambda-candidate
(guard
(progn
(cl-assert
(and (eq (car value) 'function)
(eq (car (cadr value)) 'lambda)))
(cl-assert (equal (cddr (cadr value))
(caar cconv-freevars-alist)))
;; Peek at the freevars to decide whether
;; to λ-lift.
(let* ((fvs (cdr (car cconv-freevars-alist)))
(fun (cadr value))
(funargs (cadr fun))
(funcvars (append fvs funargs)))
; lambda lifting condition
(and fvs (>= cconv-liftwhen
(length funcvars)))))))
; Lift.
(let* ((fvs (cdr (pop cconv-freevars-alist)))
(fun (cadr value))
(funargs (cadr fun))
(funcvars (append fvs funargs))
(funcbody (cddr fun))
(funcbody-env ()))
(push `(,var . (apply-partially ,var . ,fvs))
new-env)
(dolist (fv fvs)
(cl-pushnew fv new-extend)
(if (and (eq 'car-safe (car-safe
(cdr (assq fv env))))
(not (memq fv funargs)))
(push `(,fv . (car-safe ,fv)) funcbody-env)))
`(function
(lambda ,funcvars
. ,(cconv--convert-funcbody
funargs funcbody funcbody-env value)))))
;; Check if it needs to be turned into a "ref-cell".
(:captured+mutated
;; Declared variable is mutated and captured.
(push `(,var . (car-safe ,var)) new-env)
`(list ,(cconv-convert value env extend)))
;; Check if it needs to be turned into a "ref-cell".
(:unused
;; Declared variable is unused.
(if (assq var new-env)
(push `(,var) new-env)) ;FIXME:Needed?
(let* ((Ignore (if (symbol-with-pos-p var)
(position-symbol 'ignore var)
'ignore))
(newval `(,Ignore
,(cconv-convert value env extend)))
(msg (cconv--warn-unused-msg var "variable")))
(if (null msg) newval
(macroexp--warn-wrap var msg newval 'lexical))))
;; Normal default case.
(_
(if (assq var new-env) (push `(,var) new-env))
(cconv-convert value env extend)))))
(when (and (eq letsym 'let*) (memq var new-extend))
;; One of the lambda-lifted vars is shadowed, so add
;; a reference to the outside binding and arrange to use
;; that reference.
(let ((var-def (cconv--lifted-arg var env))
(closedsym (make-symbol (format "closed-%s" var))))
(setq new-env (cconv--remap-llv new-env var closedsym))
;; FIXME: `closedsym' doesn't need to be added to `extend'
;; but adding it makes it easier to write the assertion at
;; the beginning of this function.
(setq new-extend (cons closedsym (remq var new-extend)))
(push `(,closedsym ,var-def) binders-new)))
;; We push the element after redefined free variables are
;; processed. This is important to avoid the bug when free
;; variable and the function have the same name.
(push (list var new-val) binders-new)
(when (eq letsym 'let*)
(setq env new-env)
(setq extend new-extend))))))
) ; end of dolist over binders
(when (not (eq letsym 'let*))
;; We can't do the cconv--remap-llv at the same place for let and
;; let* because in the case of `let', the shadowing may occur
;; before we know that the var will be in `new-extend' (bug#24171).
(dolist (binder binders-new)
(when (memq (car-safe binder) new-extend)
;; One of the lambda-lifted vars is shadowed.
(let* ((var (car-safe binder))
(var-def (cconv--lifted-arg var env))
(closedsym (make-symbol (format "closed-%s" var))))
(setq new-env (cconv--remap-llv new-env var closedsym))
(setq new-extend (cons closedsym (remq var new-extend)))
(push `(,closedsym ,var-def) binders-new)))))
`(,letsym ,(nreverse binders-new)
. ,(mapcar (lambda (form)
(cconv-convert
form new-env new-extend))
body))))
;end of let let* forms
; first element is lambda expression
(`(,(and `(lambda . ,_) fun) . ,args)
;; FIXME: it's silly to create a closure just to call it.
;; Running byte-optimize-form earlier would resolve this.
`(funcall
,(cconv-convert `(function ,fun) env extend)
,@(mapcar (lambda (form)
(cconv-convert form env extend))
args)))
(`(cond . ,cond-forms) ; cond special form
`(,(car form) . ,(mapcar (lambda (branch)
(mapcar (lambda (form)
(cconv-convert form env extend))
branch))
cond-forms)))
(`(function (lambda ,args . ,body) . ,rest)
(let* ((docstring (if (eq :documentation (car-safe (car body)))
(cconv-convert (cadr (pop body)) env extend)))
(bf (if (stringp (car body)) (cdr body) body))
(if (when (eq 'interactive (car-safe (car bf)))
(gethash form cconv--interactive-form-funs)))
(wrapped (pcase if (`#'(lambda (&rest _cconv--dummy) .,_) t)))
(cif (when if (cconv-convert if env extend)))
(cf nil))
;; TODO: Because we need to non-destructively modify body, this code
;; is particularly ugly. This should ideally be moved to
;; cconv--convert-function.
(pcase cif
('nil (setq bf nil))
(`#',f
(pcase-let ((`((,f1 . (,_ . ,f2)) . ,f3) bf))
(setq bf `((,f1 . (,(if wrapped (nth 2 f) cif) . ,f2)) . ,f3)))
(setq cif nil))
;; The interactive form needs special treatment, so the form
;; inside the `interactive' won't be used any further.
(_ (pcase-let ((`((,f1 . (,_ . ,f2)) . ,f3) bf))
(setq bf `((,f1 . (nil . ,f2)) . ,f3)))))
(when bf
;; If we modified bf, re-build body and form as
;; copies with the modified bits.
(setq body (if (stringp (car body))
(cons (car body) bf)
bf)
form `(function (lambda ,args . ,body) . ,rest))
;; Also, remove the current old entry on the alist, replacing
;; it with the new one.
(let ((entry (pop cconv-freevars-alist)))
(push (cons body (cdr entry)) cconv-freevars-alist)))
(setq cf (cconv--convert-function args body env form docstring))
(if (not cif)
;; Normal case, the interactive form needs no special treatment.
cf
`(cconv--interactive-helper
,cf ,(if wrapped cif `(list 'quote ,cif))))))
(`(internal-make-closure . ,_)
(byte-compile-report-error
"Internal error in compiler: cconv called twice?"))
(`(quote . ,_) form)
(`(function . ,_) form)
;defconst, defvar
(`(,(and sym (or 'defconst 'defvar)) ,definedsymbol . ,forms)
`(,sym ,definedsymbol
. ,(when (consp forms)
(cons (cconv-convert (car forms) env extend)
;; The rest (i.e. docstring, of any) is not evaluated,
;; and may be an invalid expression (e.g. ($# . 678)).
(cdr forms)))))
; condition-case
(`(condition-case ,var ,protected-form . ,handlers)
(let* ((class (and var (cconv--var-classification (list var) form)))
(newenv
(cond ((eq class :captured+mutated)
(cons `(,var . (car-safe ,var)) env))
((assq var env) (cons `(,var) env))
(t env)))
(msg (when (eq class :unused)
(cconv--warn-unused-msg var "variable")))
(newprotform (cconv-convert protected-form env extend)))
`(,(car form) ,var
,(if msg
(macroexp--warn-wrap var msg newprotform 'lexical)
newprotform)
,@(mapcar
(lambda (handler)
`(,(car handler)
,@(let ((body
(mapcar (lambda (form)
(cconv-convert form newenv extend))
(cdr handler))))
(if (not (eq class :captured+mutated))
body
`((let ((,var (list ,var))) ,@body))))))
handlers))))
(`(unwind-protect ,form1 . ,body)
`(,(car form) ,(cconv-convert form1 env extend)
:fun-body ,(cconv--convert-function () body env form1)))
(`(setq ,var ,expr)
(let ((var-new (or (cdr (assq var env)) var))
(value (cconv-convert expr env extend)))
(pcase var-new
((pred symbolp) `(,(car form) ,var-new ,value))
(`(car-safe ,iexp) `(setcar ,iexp ,value))
;; This "should never happen", but for variables which are
;; mutated+captured+unused, we may end up trying to `setq'
;; on a closed-over variable, so just drop the setq.
(_ ;; (byte-compile-report-error
;; (format "Internal error in cconv of (setq %s ..)"
;; sym-new))
value))))
(`(,(and (or 'funcall 'apply) callsym) ,fun . ,args)
;; These are not special forms but we treat them separately for the needs
;; of lambda lifting.
(let ((mapping (cdr (assq fun env))))
(pcase mapping
(`(apply-partially ,_ . ,(and fvs `(,_ . ,_)))
(cl-assert (eq (cadr mapping) fun))
`(,callsym ,fun
,@(mapcar (lambda (fv)
(let ((exp (or (cdr (assq fv env)) fv)))
(pcase exp
(`(car-safe ,iexp . ,_) iexp)
(_ exp))))
fvs)
,@(mapcar (lambda (arg)
(cconv-convert arg env extend))
args)))
(_ `(,callsym ,@(mapcar (lambda (arg)
(cconv-convert arg env extend))
(cons fun args)))))))
;; The form (if any) is converted beforehand as part of the `lambda' case.
(`(interactive . ,_) form)
;; `declare' should now be macro-expanded away (and if they're not, we're
;; in trouble because they *can* contain code nowadays).
;; (`(declare . ,_) form) ;The args don't contain code.
(`(oclosure--fix-type (ignore . ,vars) ,exp)
(dolist (var vars)
(let ((x (assq var env)))
(pcase (cdr x)
(`(car-safe . ,_) (error "Slot %S should not be mutated" var))
(_ (cl-assert (null (cdr x)))))))
(cconv-convert exp env extend))
(`(,func . ,forms)
(if (or (symbolp func) (functionp func))
;; First element is function or whatever function-like forms are:
;; or, and, if, catch, progn, prog1, while, until
(let ((args (mapcar (lambda (form) (cconv-convert form env extend))
forms)))
(unless (symbolp func)
(byte-compile-warn-x
form
"Use `funcall' instead of `%s' in the function position" func))
`(,func . ,args))
(byte-compile-warn-x form "Malformed function `%S'" func)
nil))
(_ (or (cdr (assq form env)) form)))))