From: Mattias Engdegård Date: Wed, 20 Dec 2023 16:08:41 +0000 (+0100) Subject: ; * lisp/emacs-lisp/cconv.el (cconv-convert): Reindent. X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=25dc93c5c1bc7df82a9e16dd080667ccb4ba4f45;p=emacs.git ; * lisp/emacs-lisp/cconv.el (cconv-convert): Reindent. --- diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 136560f3ef4..1c9b7fc6730 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -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)) - - (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))) + (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))))))) + (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)))) + (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) (_ 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)))))) - - (`(internal-make-closure . ,_) - (byte-compile-report-error - "Internal error in compiler: cconv called twice?")) - - (`(quote . ,_) form) - (`(function . ,_) form) + ; 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))))) + (`(,(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) + (`(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)) - (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 (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))))) + 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 (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))))) (defvar byte-compile-lexical-variables)