; * lisp/emacs-lisp/cconv.el (cconv-convert): Reindent.
This commit is contained in:
Mattias Engdegård
parent
57fd0f47f6
commit
25dc93c5c1
1 changed files with 270 additions and 265 deletions
|
|
@ -330,303 +330,308 @@ places where they originally did not directly appear."
|
|||
;; 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)
|
||||
(pcase form
|
||||
(`(,(and letsym (or 'let* 'let)) ,binders . ,body)
|
||||
|
||||
; let and let* special forms
|
||||
(let ((binders-new '())
|
||||
(new-env env)
|
||||
(new-extend extend))
|
||||
(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)))
|
||||
(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)))))))
|
||||
(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)))))
|
||||
(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".
|
||||
(: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))))
|
||||
;; 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)))))
|
||||
;; 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)))
|
||||
(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)
|
||||
;; 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 (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)))))
|
||||
(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))))
|
||||
`(,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)))
|
||||
; 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)))
|
||||
(`(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) (_ nil)))
|
||||
(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))))))
|
||||
(`(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?"))
|
||||
(`(internal-make-closure . ,_)
|
||||
(byte-compile-report-error
|
||||
"Internal error in compiler: cconv called twice?"))
|
||||
|
||||
(`(quote . ,_) form)
|
||||
(`(function . ,_) form)
|
||||
(`(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)))))
|
||||
(`(,(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))))
|
||||
(`(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)))
|
||||
(`(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))))
|
||||
(`(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)
|
||||
(`(,(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))
|
||||
(cons fun args)))))))
|
||||
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)
|
||||
;; 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.
|
||||
;; `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))
|
||||
(`(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 (symbolp func)
|
||||
;; First element is function or whatever function-like forms are:
|
||||
;; or, and, if, catch, progn, prog1, while, until
|
||||
`(,func . ,(mapcar (lambda (form)
|
||||
(cconv-convert form env extend))
|
||||
forms))
|
||||
(byte-compile-warn-x form "Malformed function `%S'" func)
|
||||
nil))
|
||||
(`(,func . ,forms)
|
||||
(if (symbolp func)
|
||||
;; First element is function or whatever function-like forms are:
|
||||
;; or, and, if, catch, progn, prog1, while, until
|
||||
`(,func . ,(mapcar (lambda (form)
|
||||
(cconv-convert form env extend))
|
||||
forms))
|
||||
(byte-compile-warn-x form "Malformed function `%S'" func)
|
||||
nil))
|
||||
|
||||
(_ (or (cdr (assq form env)) form)))))
|
||||
(_ (or (cdr (assq form env)) form)))))
|
||||
|
||||
(defvar byte-compile-lexical-variables)
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue