diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/byte-opt.el | 6 | ||||
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 10 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cconv.el | 582 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 2 | ||||
| -rw-r--r-- | lisp/emacs-lisp/debug.el | 62 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eldoc.el | 4 | ||||
| -rw-r--r-- | lisp/emacs-lisp/ert-font-lock.el | 2 | ||||
| -rw-r--r-- | lisp/emacs-lisp/gv.el | 2 | ||||
| -rw-r--r-- | lisp/emacs-lisp/macroexp.el | 12 | ||||
| -rw-r--r-- | lisp/emacs-lisp/package-vc.el | 2 | ||||
| -rw-r--r-- | lisp/emacs-lisp/trace.el | 10 |
11 files changed, 358 insertions, 336 deletions
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 7a61a8fce7e..5a72011c609 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -440,7 +440,7 @@ There can be multiple entries for the same NAME if it has several aliases.") (`(unwind-protect ,protected-expr :fun-body ,unwind-fun) ;; FIXME: The return value of UNWIND-FUN is never used so we - ;; could potentially optimise it for-effect, but we don't do + ;; could potentially optimize it for-effect, but we don't do ;; that right no. `(,fn ,(byte-optimize-form protected-expr for-effect) :fun-body ,(byte-optimize-form unwind-fun))) @@ -973,7 +973,7 @@ There can be multiple entries for the same NAME if it has several aliases.") (list (car form) (nth 2 form) (nth 1 form))))) (defun byte-opt--nary-comparison (form) - "Optimise n-ary comparisons such as `=', `<' etc." + "Optimize n-ary comparisons such as `=', `<' etc." (let ((nargs (length (cdr form)))) (cond ((= nargs 1) @@ -988,7 +988,7 @@ There can be multiple entries for the same NAME if it has several aliases.") (if (memq nil (mapcar #'macroexp-copyable-p (cddr form))) ;; At least one arg beyond the first is non-constant non-variable: ;; create temporaries for all args to guard against side-effects. - ;; The optimiser will eliminate trivial bindings later. + ;; The optimizer will eliminate trivial bindings later. (let ((i 1)) (dolist (arg (cdr form)) (let ((var (make-symbol (format "arg%d" i)))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 64fd4f6b3f3..950ae77803c 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3566,7 +3566,7 @@ lambda-expression." (cond ((and sef (or (eq sef 'error-free) byte-compile-delete-errors)) - ;; This transform is normally done in the Lisp optimiser, + ;; This transform is normally done in the Lisp optimizer, ;; so maybe we don't need to bother about it here? (setq form (cons 'progn (cdr form))) (setq handler #'byte-compile-progn)) @@ -3603,7 +3603,7 @@ lambda-expression." (let ((important-return-value-fns '( ;; These functions are side-effect-free except for the - ;; behaviour of functions passed as argument. + ;; behavior of functions passed as argument. mapcar mapcan mapconcat assoc plist-get plist-member @@ -4148,7 +4148,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-compile-two-args (if (macroexp-const-p (nth 1 form)) ;; First argument is constant: flip it so that the constant - ;; is last, which may allow more lapcode optimisations. + ;; is last, which may allow more lapcode optimizations. (let* ((op (car form)) (flipped-op (cdr (assq op '((< . >) (<= . >=) (> . <) (>= . <=) (= . =)))))) @@ -4312,7 +4312,7 @@ This function is never called when `lexical-binding' is nil." (arg2 (nth 2 form))) (when (and (memq (car form) '(+ *)) (macroexp-const-p arg1)) - ;; Put constant argument last for better LAP optimisation. + ;; Put constant argument last for better LAP optimization. (cl-rotatef arg1 arg2)) (byte-compile-form arg1) (byte-compile-form arg2) @@ -5326,7 +5326,7 @@ FORM is used to provide location, `bytecomp--cus-function' and "Warn about common mistakes in the `defcustom' type TYPE." (let ((invalid-types '( - ;; Lisp type predicates, often confused with customisation types: + ;; Lisp type predicates, often confused with customization types: functionp numberp integerp fixnump natnump floatp booleanp characterp listp stringp consp vectorp symbolp keywordp hash-table-p facep diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index e65c39e3998..1c9b7fc6730 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -123,7 +123,8 @@ using dynamic scoping. Returns a form where all lambdas don't have any free variables." (let ((cconv--dynbound-variables dynbound-vars) (cconv-freevars-alist '()) - (cconv-var-classification '())) + (cconv-var-classification '()) + (byte-compile-form-stack byte-compile-form-stack)) ;; Analyze form - fill these variables with new information. (cconv-analyze-form form '()) (setq cconv-freevars-alist (nreverse cconv-freevars-alist)) @@ -328,304 +329,309 @@ places where they originally did not directly appear." ;; 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) - (pcase form - (`(,(and letsym (or 'let* 'let)) ,binders . ,body) + (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))) + (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)) - (macroexp--warn-wrap form (format-message "Malformed function `%S'" - (car form)) - nil 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) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 2431e658368..7b69404cfac 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3739,7 +3739,7 @@ macro that returns its `&whole' argument." (mapc (lambda (x) (function-put x 'important-return-value t)) '( ;; Functions that are side-effect-free except for the - ;; behaviour of functions passed as argument. + ;; behavior of functions passed as argument. cl-mapcar cl-mapcan cl-maplist cl-map cl-mapcon cl-reduce cl-assoc cl-assoc-if cl-assoc-if-not diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 5411088189d..e0b6ca31b9e 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -237,12 +237,11 @@ the debugger will not be entered." (unwind-protect (save-excursion (when (eq (car debugger-args) 'debug) - ;; Skip the frames for backtrace-debug, byte-code, - ;; debug--implement-debug-on-entry and the advice's `apply'. - (backtrace-debug 4 t) - ;; Place an extra debug-on-exit for macro's. - (when (eq 'lambda (car-safe (cadr (backtrace-frame 4)))) - (backtrace-debug 5 t))) + (let ((base (debugger--backtrace-base))) + (backtrace-debug 1 t base) ;FIXME! + ;; Place an extra debug-on-exit for macro's. + (when (eq 'lambda (car-safe (cadr (backtrace-frame 1 base)))) + (backtrace-debug 2 t base)))) (with-current-buffer debugger-buffer (unless (derived-mode-p 'debugger-mode) (debugger-mode)) @@ -343,11 +342,10 @@ Make functions into cross-reference buttons if DO-XREFS is non-nil." (defun debugger-setup-buffer (args) "Initialize the `*Backtrace*' buffer for entry to the debugger. That buffer should be current already and in `debugger-mode'." - (setq backtrace-frames (nthcdr - ;; Remove debug--implement-debug-on-entry and the - ;; advice's `apply' frame. - (if (eq (car args) 'debug) 3 1) - (backtrace-get-frames 'debug))) + (setq backtrace-frames + ;; The `base' frame is the one that gets index 0 and it is the entry to + ;; the debugger, so drop it with `cdr'. + (cdr (backtrace-get-frames (debugger--backtrace-base)))) (when (eq (car-safe args) 'exit) (setq debugger-value (nth 1 args)) (setf (cl-getf (backtrace-frame-flags (car backtrace-frames)) @@ -477,26 +475,29 @@ removes itself from that hook." (setq debugger-jumping-flag nil) (remove-hook 'post-command-hook 'debugger-reenable)) -(defun debugger-frame-number (&optional skip-base) +(defun debugger-frame-number () "Return number of frames in backtrace before the one point points at." - (let ((index (backtrace-get-index)) - (count 0)) + (let ((index (backtrace-get-index))) (unless index (error "This line is not a function call")) - (unless skip-base - (while (not (eq (cadr (backtrace-frame count)) 'debug)) - (setq count (1+ count))) - ;; Skip debug--implement-debug-on-entry frame. - (when (eq 'debug--implement-debug-on-entry - (cadr (backtrace-frame (1+ count)))) - (setq count (+ 2 count)))) - (+ count index))) + ;; We have 3 representations of the backtrace: the real in C in `specpdl', + ;; the one stored in `backtrace-frames' and the textual version in + ;; the buffer. Check here that the one from `backtrace-frames' is in sync + ;; with the one from `specpdl'. + (cl-assert (equal (backtrace-frame-fun (nth index backtrace-frames)) + (nth 1 (backtrace-frame (1+ index) + (debugger--backtrace-base))))) + ;; The `base' frame is the one that gets index 0 and it is the entry to + ;; the debugger, so the first non-debugger frame is 1. + ;; This `+1' skips the same frame as the `cdr' in + ;; `debugger-setup-buffer'. + (1+ index))) (defun debugger-frame () "Request entry to debugger when this frame exits. Applies to the frame whose line point is on in the backtrace." (interactive) - (backtrace-debug (debugger-frame-number) t) + (backtrace-debug (debugger-frame-number) t (debugger--backtrace-base)) (setf (cl-getf (backtrace-frame-flags (nth (backtrace-get-index) backtrace-frames)) :debug-on-exit) @@ -507,7 +508,7 @@ Applies to the frame whose line point is on in the backtrace." "Do not enter debugger when this frame exits. Applies to the frame whose line point is on in the backtrace." (interactive) - (backtrace-debug (debugger-frame-number) nil) + (backtrace-debug (debugger-frame-number) nil (debugger--backtrace-base)) (setf (cl-getf (backtrace-frame-flags (nth (backtrace-get-index) backtrace-frames)) :debug-on-exit) @@ -526,10 +527,8 @@ Applies to the frame whose line point is on in the backtrace." (defun debugger--backtrace-base () "Return the function name that marks the top of the backtrace. See `backtrace-frame'." - (cond ((eq 'debug--implement-debug-on-entry - (cadr (backtrace-frame 1 'debug))) - 'debug--implement-debug-on-entry) - (t 'debug))) + (or (cadr (memq :backtrace-base debugger-args)) + #'debug)) (defun debugger-eval-expression (exp &optional nframe) "Eval an expression, in an environment like that outside the debugger. @@ -537,7 +536,7 @@ The environment used is the one when entering the activation frame at point." (interactive (list (read--expression "Eval in stack frame: "))) (let ((nframe (or nframe - (condition-case nil (1+ (debugger-frame-number 'skip-base)) + (condition-case nil (debugger-frame-number) (error 0)))) ;; If on first line. (base (debugger--backtrace-base))) (debugger-env-macro @@ -670,7 +669,10 @@ functions to break on entry." (if (or inhibit-debug-on-entry debugger-jumping-flag) nil (let ((inhibit-debug-on-entry t)) - (funcall debugger 'debug)))) + (funcall debugger 'debug :backtrace-base + ;; An offset of 1 because we need to skip the advice + ;; OClosure that called us. + '(1 . debug--implement-debug-on-entry))))) ;;;###autoload (defun debug-on-entry (function) diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index e28d73c3555..4ee825136c9 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -607,7 +607,7 @@ known to be truncated." (defun eldoc-display-in-echo-area (docs interactive) "Display DOCS in echo area. -INTERACTIVE is non-nil if user explictly invoked ElDoc. Honor +INTERACTIVE is non-nil if user explicitly invoked ElDoc. Honor `eldoc-echo-area-use-multiline-p' and `eldoc-echo-area-prefer-doc-buffer'." (cond @@ -933,7 +933,7 @@ the docstrings eventually produced, using (let* ((eldoc--make-callback #'make-callback) (res (funcall eldoc-documentation-strategy))) ;; Observe the old and the new protocol: - (cond (;; Old protocol: got string, e-d-strategy is iself the + (cond (;; Old protocol: got string, e-d-strategy is itself the ;; origin function, and we output immediately; (stringp res) (register-doc 0 res nil eldoc-documentation-strategy) diff --git a/lisp/emacs-lisp/ert-font-lock.el b/lisp/emacs-lisp/ert-font-lock.el index 6a02cf7acc4..8bde83bf278 100644 --- a/lisp/emacs-lisp/ert-font-lock.el +++ b/lisp/emacs-lisp/ert-font-lock.el @@ -28,7 +28,7 @@ ;; ;; ert-font-lock entry points are functions ;; `ert-font-lock-test-string' and `ert-font-lock-test-file' and -;; covenience macros: `ert-font-lock-deftest' and +;; convenience macros: `ert-font-lock-deftest' and ;; `ert-font-lock-deftest-file'. ;; ;; See unit tests in ert-font-lock-tests.el for usage examples. diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 5d31253fe2d..9f40c1f3c93 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -638,7 +638,7 @@ REF must have been previously obtained with `gv-ref'." ;;; Generalized variables. -;; You'd think noone would write `(setf (error ...) ..)' but it +;; You'd think no one would write `(setf (error ...) ..)' but it ;; appears naturally as the result of macroexpansion of things like ;; (setf (pcase-exhaustive ...)). ;; We could generalize this to `throw' and `signal', but it seems diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 615a6622ce6..2a646be9725 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -39,6 +39,18 @@ of `byte-compile-form', etc., and manually popped off at its end. This is to preserve the data in it in the event of a condition-case handling a signaled error.") +(defmacro macroexp--with-extended-form-stack (expr &rest body) + "Evaluate BODY with EXPR pushed onto `byte-compile-form-stack'." + (declare (indent 1)) + ;; FIXME: We really should just be using a simple dynamic let-binding here, + ;; but these explicit push and pop make the extended stack value visible + ;; to error handlers. Remove that need for that! + `(progn + (push ,expr byte-compile-form-stack) + (prog1 + (progn ,@body) + (pop byte-compile-form-stack)))) + ;; Bound by the top-level `macroexpand-all', and modified to include any ;; macros defined by `defmacro'. (defvar macroexpand-all-environment nil) diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index bc36762cb2d..bef498f997c 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -863,7 +863,7 @@ package uses `file-name-base' on the URL to obtain the package name, otherwise NAME is the package name as a symbol. PACKAGE can also be a cons cell (PNAME . SPEC) where PNAME is the -package name as a symbol, and SPEC is a plist that specifes how +package name as a symbol, and SPEC is a plist that specifies how to fetch and build the package. For possible values, see the subsection \"Specifying Package Sources\" in the Info node `(emacs)Fetching Package Sources'. diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index d802648d8ab..3881fe66eb4 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -128,6 +128,8 @@ ;;; Code: +(require 'cl-print) + (defgroup trace nil "Tracing facility for Emacs Lisp functions." :prefix "trace-" @@ -168,13 +170,13 @@ and CONTEXT is a string describing the dynamic context (e.g. values of some global variables)." (let ((print-circle t) (print-escape-newlines t)) - (format "%s%s%d -> %S%s\n" + (format "%s%s%d -> %s%s\n" (mapconcat #'char-to-string (make-string (max 0 (1- level)) ?|) " ") (if (> level 1) " " "") level ;; FIXME: Make it so we can click the function name to jump to its ;; definition and/or untrace it. - (cons function args) + (cl-prin1-to-string (cons function args)) context))) (defun trace-exit-message (function level value context) @@ -184,13 +186,13 @@ and CONTEXT is a string describing the dynamic context (e.g. values of some global variables)." (let ((print-circle t) (print-escape-newlines t)) - (format "%s%s%d <- %s: %S%s\n" + (format "%s%s%d <- %s: %s%s\n" (mapconcat 'char-to-string (make-string (1- level) ?|) " ") (if (> level 1) " " "") level function ;; Do this so we'll see strings: - value + (cl-prin1-to-string value) context))) (defvar trace--timer nil) |