From eb89a6c44565ec67379c399eaae4ba8d33a06430 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Tue, 11 Jun 2024 09:38:53 +0000 Subject: [PATCH] Load backquote.el before byte-run.el. This is to allow the many functions with "hand expanded backquotes" to use actual backquotes. Also make a few miscellaneous amendments, particularly to the test suite. * lisp/emacs-lisp/backquote.el (backquote-list*-function) (backquote-list*-macro, backquote, backquote-delay-process) (backquote-process, backquote-listify): Replace the declaring `defun's and `defmacros' with defalias. (Random places in the file): Replace `not' with `null', `push' with `setq' and `cons', and `unless' with `if' and `null'. * lisp/emacs-lisp/backtrace.el (backtrace--to-string): Use cl-prin1 rather than prin1. * lisp/emacs-lisp/byte-run.el (byte-run--posify-def-form): Remove. (byte-run--posify-list): No longer posify defining forms. (byte-run-posify-all-lambdas-etc) Rename by removing the "-etc" and no longer posify defining-forms. (byte-run--set-advertised-calling-convention) (byte-run--set-obsolete, byte-run--set-interactive-only) (byte-run--set-pure, byte-run--set-side-effect-free) (byte-run--set-important-return-value) (byte-run--set-doc-string, byte-run--set-indent) (byte-run--set-speed, byte-run--set-safety) (byte-run--set-completion, byte-run--set-modes) (byte-run--set-interactive-args) (byte-run--posify-defining-form, byte-run--set-function-type) (byte-run--set-debug, byte-run--set-no-font-lock-keyword) (defmacro, defun, dont-compile, eval-when-compile) (eval-and-compile): Recode using the backquote macro. * lisp/emacs-lisp/cl-generic.el (cl-defmethod): Remove the obtrusive car of the function which is the cdr of the return value from the byte-run-defined-form property value of this function. * lisp/emacs-lisp/macroexp.el (macroexp--expand-all): In the handling of quoted forms, no longer test byte-compile-in-progress. * lisp/loadup.el (top level) load backquote.el before byte-run.el. * test/lisp/emacs-lisp/backtrace-tests.el (backtrace-tests--forward-frame) * test/lisp/emacs-lisp/cconv-tests.el (cconv-convert-lambda-lifted, cconv-closure-convert-remap-var) (cconv-tests-interactive-form-modify-bug60974) * test/lisp/erc/erc-tests.el (erc--with-dependent-type-match): Use byte-run-strip-lambda-doc to prevent mismatches in comparisons caused by the presence of position information in doc strings. --- lisp/emacs-lisp/backquote.el | 55 ++-- lisp/emacs-lisp/backtrace.el | 2 +- lisp/emacs-lisp/byte-run.el | 404 +++++++++--------------- lisp/emacs-lisp/cl-generic.el | 2 +- lisp/emacs-lisp/macroexp.el | 7 +- lisp/loadup.el | 4 +- test/lisp/emacs-lisp/backtrace-tests.el | 14 +- test/lisp/emacs-lisp/cconv-tests.el | 144 +++++---- test/lisp/erc/erc-tests.el | 11 +- 9 files changed, 275 insertions(+), 368 deletions(-) diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el index 6917128d70a..8db1f94132f 100644 --- a/lisp/emacs-lisp/backquote.el +++ b/lisp/emacs-lisp/backquote.el @@ -40,7 +40,8 @@ ;; function and macro versions of backquote-list* -(defun backquote-list*-function (first &rest list) +(defalias 'backquote-list*-function + #'(lambda (first &rest list) "Like `list' but the last argument is the tail of the new list. For example (backquote-list* \\='a \\='b \\='c) => (a b . c)" @@ -55,9 +56,11 @@ For example (backquote-list* \\='a \\='b \\='c) => (a b . c)" rest (cdr rest))) (setcdr last (car rest)) newlist) - first)) + first))) -(defmacro backquote-list*-macro (first &rest list) +(defalias 'backquote-list*-macro + (cons 'macro + #'(lambda (first &rest list) "Like `list' but the last argument is the tail of the new list. For example (backquote-list* \\='a \\='b \\='c) => (a b . c)" @@ -75,7 +78,7 @@ For example (backquote-list* \\='a \\='b \\='c) => (a b . c)" (setq newlist (list 'cons (car rest) newlist) rest (cdr rest))) newlist) - first)) + first)))) (defalias 'backquote-list* (symbol-function 'backquote-list*-macro)) @@ -90,8 +93,10 @@ For example (backquote-list* \\='a \\='b \\='c) => (a b . c)" (defconst backquote-splice-symbol '\,@ "Symbol used to represent a splice inside a backquote.") -(defmacro backquote (structure) - "Argument STRUCTURE describes a template to build. +(defalias 'backquote + (cons 'macro + #'(lambda (structure) + "Argument STRUCTURE describes a template to build. The whole structure acts as if it were quoted except for certain places where expressions are evaluated and inserted or spliced in. @@ -107,7 +112,7 @@ Vectors work just like lists. Nested backquotes are permitted. Note that some macros, such as `pcase', use this symbol for other purposes." - (cdr (backquote-process structure))) + (cdr (backquote-process structure))))) ;; GNU Emacs has no reader macros @@ -118,29 +123,31 @@ purposes." ;; constant, 1 => to be unquoted, 2 => to be spliced in. ;; The top-level backquote macro just discards the tag. -(defun backquote-delay-process (s level) +(defalias 'backquote-delay-process + #'(lambda (s level) "Process a (un|back|splice)quote inside a backquote. This simply recurses through the body." (let ((exp (backquote-listify (list (cons 0 (list 'quote (car s)))) (backquote-process (cdr s) level)))) - (cons (if (eq (car-safe exp) 'quote) 0 1) exp))) + (cons (if (eq (car-safe exp) 'quote) 0 1) exp)))) -(defun backquote-process (s &optional level) - "Process the body of a backquote. +(defalias 'backquote-process + #'(lambda (s &optional level) + "Process the body of a backquote. S is the body. Returns a cons cell whose cdr is piece of code which is the macro-expansion of S, and whose car is a small integer whose value can either indicate that the code is constant (0), or not (1), or returns a list which should be spliced into its environment (2). LEVEL is only used internally and indicates the nesting level: 0 (the default) is for the toplevel nested inside a single backquote." - (unless level (setq level 0)) + (if (null level) (setq level 0)) (cond ((vectorp s) (let ((n (backquote-process (append s ()) level))) (if (= (car n) 0) (cons 0 s) (cons 1 (cond - ((not (listp (cdr n))) + ((null (listp (cdr n))) (list 'vconcat (cdr n))) ((eq (nth 1 n) 'list) (cons 'vector (nthcdr 2 n))) @@ -150,7 +157,7 @@ LEVEL is only used internally and indicates the nesting level: (list 'apply '(function vector) (cdr n)))))))) ((atom s) ;; FIXME: Use macroexp-quote! - (cons 0 (if (or (null s) (eq s t) (not (symbolp s))) + (cons 0 (if (or (null s) (eq s t) (null (symbolp s))) s (list 'quote s)))) ((eq (car s) backquote-unquote-symbol) @@ -187,8 +194,8 @@ LEVEL is only used internally and indicates the nesting level: ;; Stop if the cdr is an expression inside a backquote or ;; unquote since this needs to go recursively through ;; backquote-process. - (not (or (eq (car rest) backquote-unquote-symbol) - (eq (car rest) backquote-backquote-symbol)))) + (null (or (eq (car rest) backquote-unquote-symbol) + (eq (car rest) backquote-backquote-symbol)))) (setq item (backquote-process (car rest) level)) (cond ((= (car item) 2) @@ -199,8 +206,8 @@ LEVEL is only used internally and indicates the nesting level: list nil)) ;; Otherwise, put any preceding nonspliced items into LISTS. (if list - (push (backquote-listify list '(0 . nil)) lists)) - (push (cdr item) lists) + (setq lists (cons (backquote-listify list '(0 . nil)) lists))) + (setq lists (cons (cdr item) lists)) (setq list nil)) (t (setq list (cons item list)))) @@ -208,8 +215,9 @@ LEVEL is only used internally and indicates the nesting level: ;; Handle nonsplicing final elements, and the tail of the list ;; (which remains in REST). (if (or rest list) - (push (backquote-listify list (backquote-process rest level)) - lists)) + (setq lists + (cons (backquote-listify list (backquote-process rest level)) + lists))) ;; Turn LISTS into a form that produces the combined list. (setq expression (if (or (cdr lists) @@ -219,13 +227,14 @@ LEVEL is only used internally and indicates the nesting level: ;; Tack on any initial elements. (if firstlist (setq expression (backquote-listify firstlist (cons 1 expression)))) - (cons (if (eq (car-safe expression) 'quote) 0 1) expression))))) + (cons (if (eq (car-safe expression) 'quote) 0 1) expression)))))) ;; backquote-listify takes (tag . structure) pairs from backquote-process ;; and decides between append, list, backquote-list*, and cons depending ;; on which tags are in the list. -(defun backquote-listify (list old-tail) +(defalias 'backquote-listify + #'(lambda (list old-tail) (let ((heads nil) (tail (cdr old-tail)) (list-tail list) (item nil)) (if (= (car old-tail) 0) (setq tail (eval tail) @@ -248,7 +257,7 @@ LEVEL is only used internally and indicates the nesting level: (cons (if use-list* 'backquote-list* 'cons) (append heads (list tail)))) tail)) - (t (cons 'list heads))))) + (t (cons 'list heads)))))) ;; Give `,' and `,@' documentation strings which can be examined by C-h f. diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index 04b64e7916b..065869c9b87 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -908,7 +908,7 @@ function calls currently active." (backtrace-mode) (setq backtrace-view '(:show-flags t) backtrace-frames frames - backtrace-print-function #'prin1;; #'cl-prin1 STOUGH, 2024-02-12 + backtrace-print-function #'cl-prin1 ) (backtrace-print) (filter-buffer-substring (point-min) (point-max))))) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index a98bb7e22af..a7bf067e9d3 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -293,67 +293,9 @@ The original FORM is not changed. Return a changed copy of FORM, or FORM." (if changed new form)) form))) -(defalias 'byte-run--posify-def-form - #'(lambda (form) - "Posify FORM, a defining form. -A defining form is one whose function has a `byte-run-defined-form' -property. Examples are `defun', `cl-defmethod'." - (let* ((df (get (car form) 'byte-run-defined-form)) - (mth (car df)) - (nth (and (integerp mth) (if (> mth 0) mth (- mth)))) - (posifier (cdr df)) - defining-symbol ; Bound for `byte-run-posify-doc-string'. - old-ds new-ds new-obj - (obj - (and nth - (condition-case nil - (nth nth form) - (wrong-type-argument nil) - (t nil))))) - (if obj - (progn - (setq new-obj - (if (> mth 0) - (if (symbol-with-pos-p obj) - (progn (setq defining-symbol obj) - (bare-symbol obj)) - obj) - (if (and (eq (car-safe obj) 'quote) - (symbol-with-pos-p (car-safe (cdr obj)))) - (progn (setq defining-symbol (car (cdr obj))) - (list 'quote (bare-symbol (car (cdr obj))))) - obj))) - (if (let (symbols-with-pos-enabled) - (null (eq new-obj obj))) - (progn - (if (functionp posifier) - (progn - (setq posifier (funcall posifier form)))) - (let ((flat-posifier - (if (integerp posifier) - posifier - ;; At this stage the &rest arguments won't have been - ;; gathered into a single list, hence we must treat - ;; them as individual arguments. - (+ (car posifier) (cdr posifier))))) - (setq old-ds (nth flat-posifier form)) - (setq new-ds - (byte-run-posify-doc-string (and (stringp old-ds) old-ds))) - (append (take nth form) - (list new-obj) - (take (- flat-posifier (1+ nth)) - (nthcdr (1+ nth) form)) - (list new-ds) - (nthcdr (if (stringp old-ds) - (1+ flat-posifier) - flat-posifier) - form)))) - form)) - form)))) - (defalias 'byte-run--posify-list #'(lambda (form) - "Posify any lambda or defining forms still unposified in the list FORM. + "Posify any lambda forms still unposified in the list FORM. This original FORM is not changed. Return a changed copy of FORM or FORM." (let ((a form) changed elt new) @@ -367,7 +309,7 @@ This original FORM is not changed. Return a changed copy of FORM or FORM." (eq (bare-symbol (car a)) 'lambda)) (if (and (cdr-safe a) - (listp (car-safe (cdr a)))) ; valid param list. + (consp (car-safe (cdr a)))) ; valid param list. (let ((stripped (byte-run-posify-lambda-form a (symbol-with-pos-pos (car a)) @@ -377,21 +319,14 @@ This original FORM is not changed. Return a changed copy of FORM or FORM." a (cdr a)) (setq new (cons (car a) new) ; param list. a (cdr a)) - (setq new (cons (car a) new) ; doc string. - a (cdr a)) + ;; Leave the doc string as the car of A to be accumulated + ;; into NEW below. + ;; (setq new (cons (car a) new) ; doc string. + ;; a (cdr a)) (setq changed t)) - (byte-run-pull-lambda-source (car a)) - (setq new (cons 'lambda new) - a (cdr a)))) - - ;; Do we need to posify a defining form? - (if (and (symbolp (car a)) - (get (car a) 'byte-run-defined-form)) - (let ((stripped (byte-run--posify-def-form a))) - (if (null (eq stripped a)) - (progn - (setq a stripped) - (setq changed t))))) + (byte-run-pull-lambda-source (car a)) + (setq a (cons 'lambda (cdr a)) + changed t))) ;; Accumulate an element. (if (consp a) @@ -431,14 +366,13 @@ This original FORM is not changed. Return a changed copy of FORM or FORM." rev) form)))) -(defalias 'byte-run-posify-all-lambdas-etc +(defalias 'byte-run-posify-all-lambdas #'(lambda (form) "Posify any lambda forms still unposified in FORM. -Also strip the positions of any `lambda' which doesn't open a form. -FORM is any Lisp object, but is usually a list or a vector or a -record, containing symbols with position. Return FORM, possibly -destructively modified." +FORM is any Lisp object, but is usually a list or a vector or a record, +containing symbols with position. Return a modified copy of FORM, or +FORM." (setq byte-run--ssp-seen (make-hash-table :test 'eq)) (cond ((consp form) @@ -682,47 +616,52 @@ read-stream (typically as a symbol) where FORM occurred or nil. The modification of FORM will be done by creating a new list form." - (let* ((bare-ds (bare-symbol defining-symbol)) - (cand-doc-string (nth 2 form)) - (doc-string - (and (byte-run-valid-doc-string cand-doc-string) - cand-doc-string)) - (already-posified - (and doc-string - (cond - ((stringp doc-string) - (string-match "^;POS\036\001\001\001" doc-string)) - ((stringp (car-safe (cdr-safe doc-string))) - (string-match "^;POS\036\001\001\001" - (car (cdr doc-string)))) + ;; We need a proper list with at least the arglist present. + (if (and (proper-list-p form) + (cdr-safe form)) + (let* ((bare-ds (bare-symbol defining-symbol)) + (cand-doc-string (nth 2 form)) + (doc-string + (and (byte-run-valid-doc-string cand-doc-string) + cand-doc-string)) + (already-posified + (and doc-string + (cond + ((stringp doc-string) + (string-match "^;POS\036\001\001\001" doc-string)) + ((stringp (car-safe (cdr-safe doc-string))) + (string-match "^;POS\036\001\001\001" + (car (cdr doc-string)))) ;;;; STOUGH TO AMEND WHEN APPROPRIATE, 2023-12-17 - (t t) ; For (:documentation 'symbol), in oclosures. + (t t) ; For (:documentation 'symbol), in oclosures. ;;;; END OF STOUGH - ))) - (empty-body-allowed - (and bare-ds (get bare-ds 'empty-body-allowed))) - (insert (or (null doc-string) - (and (null empty-body-allowed) - (null (nthcdr 3 form)))))) + ))) + (empty-body-allowed + (and bare-ds (get bare-ds 'empty-body-allowed))) + (insert (or (null doc-string) + (and (null empty-body-allowed) + (null (nthcdr 3 form)))))) - (cond - ((and (null already-posified) - (>= (length form) 2)) - (let ((new-doc-string (byte-run-posify-doc-string - doc-string - position - lambda-read-stream))) - (append - (if byte-compile-in-progress - (take 1 form) - (list 'lambda)) ; Strip the lambda of its position. - (take 1 (cdr form)) - (list new-doc-string) - (nthcdr (if insert 2 3) form)))) - ((and (null byte-compile-in-progress) - (symbol-with-pos-p (car form))) - (cons 'lambda (cdr form))) - (t form))))) + (cond + ((and (null already-posified) + (>= (length form) 2)) + (let ((new-doc-string (byte-run-posify-doc-string + doc-string + position + lambda-read-stream))) + (append + (if byte-compile-in-progress + (take 1 form) + (list 'lambda)) ; Strip the lambda of its position. + (take 1 (cdr form)) + (list new-doc-string) + (nthcdr (if insert 2 3) form)))) + ((and (null byte-compile-in-progress) + (symbol-with-pos-p (car form))) + (cons 'lambda (cdr form))) + (t form))) + ;; We've got an invalid lambda form. Just return it. + form))) (defalias 'function-put ;; We don't want people to just use `put' because we can't conveniently @@ -740,39 +679,32 @@ So far, FUNCTION can only be a symbol, not a lambda expression." ;; handle declarations in macro definitions and this is the first file ;; loaded by loadup.el that uses declarations in macros. We specify ;; the values as named aliases so that `describe-variable' prints -;; something useful; cf. Bug#40491. We can only use backquotes inside -;; the lambdas and not for those properties that are used by functions -;; loaded before backquote.el. +;; something useful; cf. Bug#40491. Backquotes can be used freely in +;; this file since 2024-06. (defalias 'byte-run--set-advertised-calling-convention #'(lambda (f _args arglist when) - (list 'set-advertised-calling-convention - (list 'quote f) (list 'quote arglist) (list 'quote when)))) + `(set-advertised-calling-convention ',f ',arglist ',when))) (defalias 'byte-run--set-obsolete #'(lambda (f _args new-name when) - (list 'make-obsolete - (list 'quote f) (list 'quote new-name) when))) + `(make-obsolete ',f ',new-name ,when))) (defalias 'byte-run--set-interactive-only #'(lambda (f _args instead) - (list 'function-put (list 'quote f) - ''interactive-only (list 'quote instead)))) + `(function-put ',f 'interactive-only ',instead))) (defalias 'byte-run--set-pure #'(lambda (f _args val) - (list 'function-put (list 'quote f) - ''pure (list 'quote val)))) + `(function-put ',f 'pure ',val))) (defalias 'byte-run--set-side-effect-free #'(lambda (f _args val) - (list 'function-put (list 'quote f) - ''side-effect-free (list 'quote val)))) + `(function-put ',f 'side-effect-free ',val))) (defalias 'byte-run--set-important-return-value #'(lambda (f _args val) - (list 'function-put (list 'quote f) - ''important-return-value (list 'quote val)))) + `(function-put ',f 'important-return-value ',val))) (put 'compiler-macro 'edebug-declaration-spec '(&or symbolp ("lambda" &define lambda-list lambda-doc def-body))) @@ -801,51 +733,39 @@ So far, FUNCTION can only be a symbol, not a lambda expression." (defalias 'byte-run--set-doc-string #'(lambda (f _args pos) - (list 'function-put (list 'quote f) - ''doc-string-elt (if (numberp pos) - pos - (list 'quote pos))))) + `(function-put ',f 'doc-string-elt + ,(if (numberp pos) pos `',pos)))) (defalias 'byte-run--set-indent #'(lambda (f _args val) - (list 'function-put (list 'quote f) - ''lisp-indent-function (if (numberp val) - val - (list 'quote val))))) + `(function-put ',f 'lisp-indent-function + ,(if (numberp val) val `',val)))) (defalias 'byte-run--set-speed #'(lambda (f _args val) - (list 'function-put (list 'quote f) - ''speed (list 'quote val)))) + `(function-put ',f 'speed ',val))) (defalias 'byte-run--set-safety #'(lambda (f _args val) - (list 'function-put (list 'quote f) - ''safety (list 'quote val)))) + `(function-put ',f 'safety ',val))) (defalias 'byte-run--set-completion #'(lambda (f _args val) - (list 'function-put (list 'quote f) - ''completion-predicate (list 'function val)))) + `(function-put ',f 'completion-predicate #',val))) (defalias 'byte-run--set-modes #'(lambda (f _args &rest val) - (list 'function-put (list 'quote f) - ''command-modes (list 'quote val)))) + `(function-put ',f 'command-modes ',val))) (defalias 'byte-run--set-interactive-args #'(lambda (f args &rest val) (setq args (remove '&optional (remove '&rest args))) - (list 'function-put (list 'quote f) - ''interactive-args - (list - 'quote - (mapcar - (lambda (elem) - (cons - (seq-position args (car elem)) - (cadr elem))) - val))))) + `(function-put ',f 'interactive-args + ',(mapcar (lambda (elem) + (cons + (seq-position args (car elem)) + (cadr elem))) + val)))) (defalias 'byte-run--extract-sym-from-form #'(lambda (form args) @@ -961,93 +881,70 @@ an example of its use." f def-index)) (cons - (list 'function-put (list 'quote f) - ''byte-run-defined-form - (list 'quote (cons def-index (if doc-n - (cons doc-index doc-n) - doc-index)))) - (list - 'progn - (list 'or 'defining-symbol - (list 'setq 'defining-symbol def-spec)) - - (list 'let* - (list - (list 'old-ds - (list 'and (list 'byte-run-valid-doc-string doc-spec) - doc-spec)) - (list 'new-ds (list 'byte-run-posify-doc-string 'old-ds))) - ;; Strip the symbol position from the name being defined. - (list 'if '(null byte-compile-in-progress) - (list 'setq def-arg-sym - (list 'byte-run-strip-symbol-positions - def-arg-sym))) - ;; Strip the symbol position from the name in the - ;; original form. - (list 'if (list 'and 'cur-evalled-macro-form - (list 'null 'byte-compile-in-progress)) - (list - 'let - (list - (list 'stripped-arg - (list 'byte-run-strip-symbol-positions - (list 'nth def-index - 'cur-evalled-macro-form)))) - (list 'setcar (list 'nthcdr def-index - 'cur-evalled-macro-form) - 'stripped-arg))) - (if empty-body-flag - (list 'put def-spec ''empty-body-allowed t) - (list 'progn)) - ;; Replace the old doc string with the new, or - ;; insert the new. - (cond - (can-insert-doc-before-rest - (list 'if (list 'byte-run-valid-doc-string 'old-ds) - (list 'setq doc-spec 'new-ds) - ;; If `doc-spec' isn't a string, it's part of the body. - (list 'setq body-spec - (list 'cons doc-spec body-spec)) - (list 'setq doc-spec 'new-ds))) - ((symbolp doc-spec) - (list 'setq doc-spec 'new-ds)) - (t - (list - 'setq doc-arg-sym - (list - 'append - (list 'take doc-n doc-arg-sym) - (list - 'cond - ;; doc-string present and a non-nil (cdr body): - (list (list 'and (list 'byte-run-valid-doc-string - doc-spec) - after-doc-spec) - (list 'list 'new-ds)) - ;; Single string, both doc string and return value: - (list (list 'byte-run-valid-doc-string doc-spec) - (if empty-body-flag - (list 'list 'new-ds) - (list 'list 'new-ds 'old-ds))) - ;; Neither doc string nor return value: - (list (list 'null (list 'nthcdr doc-n doc-arg-sym)) - (if empty-body-flag - (list 'list 'new-ds) - (list 'list 'new-ds ''nil))) - ;; No doc string, but a non-nil body, not a string. - (list t - (list 'list 'new-ds doc-spec))) - after-doc-spec)))))))))) - + `(function-put ',f 'byte-run-defined-form + '(,def-index ,@(if doc-n (cons doc-index doc-n) + doc-index))) + `(progn + (or defining-symbol (setq defining-symbol ,def-spec)) + (let* ((old-ds (and (byte-run-valid-doc-string ,doc-spec) + ,doc-spec)) + (new-ds (byte-run-posify-doc-string old-ds))) + ;; Strip the symbol position from the name being defined. + (if (null byte-compile-in-progress) + (setq ,def-arg-sym + (byte-run-strip-symbol-positions ,def-arg-sym))) + ;; Strip the symbol position from the name in the + ;; original form. + (if (and cur-evalled-macro-form + (null byte-compile-in-progress)) + (let ((stripped-arg + (byte-run-strip-symbol-positions + (nth ,def-index cur-evalled-macro-form)))) + (setcar (nthcdr ,def-index cur-evalled-macro-form) + stripped-arg))) + ,@(if empty-body-flag + `((put ,def-spec 'empty-body-allowed t))) + ;; Replace the old doc string with the new, or + ;; insert the new. + ,(cond + (can-insert-doc-before-rest + `(if (byte-run-valid-doc-string old-ds) + (setq ,doc-spec new-ds) + ;; if `doc-spec' isn't a string, it's part of the body. + (setq ,body-spec (cons ,doc-spec ,body-spec)) + (setq ,doc-spec new-ds))) + ((symbolp doc-spec) + `(setq ,doc-spec new-ds)) + (t `(setq ,doc-arg-sym + (append + (take ,doc-n ,doc-arg-sym) + (cond + ;; doc-string present and a non-nil (cdr body): + ((and (byte-run-valid-doc-string ,doc-spec) + ,after-doc-spec) + (list new-ds)) + ;; Single string, both doc string and return value + ((byte-run-valid-doc-string ,doc-spec) + ,(if empty-body-flag + `(list new-ds) + `(list new-ds old-ds))) + ;; Neither doc string nor return value: + ((null (nthcdr ,doc-n ,doc-arg-sym)) + ,(if empty-body-flag + `(list new-ds) + `(list new-ds 'nil))) + ;; No doc string, but a non-nil, non-string body. + (t (list new-ds ,doc-spec))) + ,after-doc-spec)))))))))) (put 'byte-run--posify-defining-form 'byte-run-pre-form t) + (defalias 'byte-run--set-function-type #'(lambda (f _args val &optional f2) (when (and f2 (not (eq f2 f))) (error "`%s' does not match top level function `%s' inside function type \ declaration" f2 f)) - (list 'function-put (list 'quote f) - ''function-type (list 'quote val)))) + `(function-put ',f 'function-type ',val))) ;; Add any new entries to info node `(elisp)Declare Form'. (defvar defun-declarations-alist @@ -1085,14 +982,12 @@ This is used by `declare'.") (defalias 'byte-run--set-debug #'(lambda (name _args spec) - (list 'progn :autoload-end - (list 'put (list 'quote name) - ''edebug-form-spec (list 'quote spec))))) + `(progn :autoload-end + (put ',name 'edebug-form-spec ',spec)))) (defalias 'byte-run--set-no-font-lock-keyword #'(lambda (name _args val) - (list 'function-put (list 'quote name) - ''no-font-lock-keyword (list 'quote val)))) + `(function-put ',name 'no-font-lock-keyword ',val))) (defalias 'byte-run--parse-body #'(lambda (body allow-interactive) @@ -1251,10 +1146,8 @@ interpreted according to `macro-declarations-alist'. (setq body (cons docstring body))) (if (null body) (setq body '(nil))) - (let* ((fun (list 'function (cons 'lambda (cons arglist body)))) - (def (list 'defalias - (list 'quote name) - (list 'cons ''macro fun)))) + (let* ((fun `(function (lambda ,arglist ,@body))) + (def `(defalias ',name (cons 'macro ,fun)))) (if declarations (cons 'prog1 (cons def (car declarations))) def)))))) @@ -1279,8 +1172,7 @@ INTERACTIVE is an optional `interactive' specification. (null (delq t (mapcar #'symbolp arglist))))) (error "Malformed arglist: %s" arglist)) (let* ((parse (byte-run--parse-body body t)) - (docstring - (nth 0 parse)) + (docstring (nth 0 parse)) (declare-form (nth 1 parse)) (interactive-form (nth 2 parse)) (body @@ -1299,11 +1191,7 @@ INTERACTIVE is an optional `interactive' specification. (setq body (cons docstring body))) (if (null body) (setq body '(nil))) - (let ((def (list 'defalias - (list 'quote name) - (list 'function - (cons 'lambda - (cons arglist body)))))) + (let ((def `(defalias ',name (function (lambda ,arglist ,@body))))) (if declarations (cons 'prog1 (cons def (car declarations))) def)))) @@ -1649,7 +1537,7 @@ obsolete, for example a date or a release number." "Like `progn', but the body always runs interpreted (not compiled). If you think you need this, you're probably making a mistake somewhere." (declare (debug t) (indent 0) (obsolete nil "24.4")) - (list 'eval (list 'quote (if (cdr body) (cons 'progn body) (car body))))) + `(eval ',(if (cdr body) `(progn ,@body) (car body)))) ;; interface to evaluating things at compile time and/or load time @@ -1665,8 +1553,7 @@ constant. In interpreted code, this is entirely equivalent to not necessarily) computed at load time if eager macro expansion is enabled." (declare (debug (&rest def-form)) (indent 0)) - (list 'quote (eval (cons 'progn (byte-run-posify-all-lambdas-etc body)) - lexical-binding))) + `',(eval `(progn ,@(byte-run-posify-all-lambdas body)) lexical-binding)) (defmacro eval-and-compile (&rest body) "Like `progn', but evaluates the body at compile time and at load time. @@ -1678,8 +1565,7 @@ enabled." ;; When the byte-compiler expands code, this macro is not used, so we're ;; either about to run `body' (plain interpretation) or we're doing eager ;; macroexpansion. - (list 'quote (eval (cons 'progn (byte-run-posify-all-lambdas-etc body)) - lexical-binding))) + `',(eval `(progn ,@(byte-run-posify-all-lambdas body)) lexical-binding)) (defun with-no-warnings (&rest body) "Like `progn', but prevents compiler warnings in the body." diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 6bb8b9c027c..4891df63148 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -632,7 +632,7 @@ See `byte-run--posify-def-form' in byte-run.el." (cl-generic--method-qualifier-p (car ptr))) (setq ptr (cdr ptr)) (setq i (1+ i))) - `(1 . (3 . ,i)))))) + `(3 . ,i))))) (defun cl--generic-member-method (specializers qualifiers methods) (while diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index ebd69aa631d..9d26dcb5583 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -384,8 +384,8 @@ Assumes the caller has bound `macroexpand-all-environment'." ;; `eval-when-compile' and `eval-and-compile' need their args expanded ;; first, in case there are any backquote constructs in them which - ;; would otherwise confuse the `byte-run-posify-all-lambdas-etc' calls - ;; in those macros. + ;; would otherwise confuse the `byte-run-posify-all-lambdas' calls in + ;; those macros. (macroexpand (macroexp--all-forms form 1) macroexpand-all-environment)) @@ -473,8 +473,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (`(function . ,_) form) (`(quote ,_arg) - (if (null byte-compile-in-progress) - (setq form (byte-run-posify-all-lambdas-etc form))) + (setq form (byte-run-posify-all-lambdas form)) form) (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) pcase--dontcare)) diff --git a/lisp/loadup.el b/lisp/loadup.el index 05722dd0611..f18a70899b8 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -129,6 +129,7 @@ (defvar real-defvar (symbol-function 'defvar)) (fset 'defvar (symbol-function 'defvar-bootstrap)) (load "emacs-lisp/debug-early") +(load "emacs-lisp/backquote") (load "emacs-lisp/byte-run") (byte-run-posify-existing-defaliases) (byte-run-posify-existing-lambdas) @@ -136,7 +137,6 @@ ;; (makunbound 'early-lambda-lists) (setq early-lambda-lists nil) ; We don't want its symbols with ; position in the dumped image. -(load "emacs-lisp/backquote") (load "subr") (load "keymap") @@ -180,11 +180,11 @@ ;;;; END OF NEW STOUGH (load "emacs-lisp/debug-early") +(load "emacs-lisp/backquote") (load "emacs-lisp/byte-run") (message "loadup.el, just after second load of byte-run.el.") (message "loadup.el, just after setting base-loaded to t") (unintern 'base-loaded nil) ; So that it can't be messed with from Lisp. -(load "emacs-lisp/backquote") ;; Second loading of these files to clear out symbols with positions from ;; lambda symbols. This absolutely requires macroexp.el. ;; In the second loading, we make `internal-macroexpand-for-load' unbound so diff --git a/test/lisp/emacs-lisp/backtrace-tests.el b/test/lisp/emacs-lisp/backtrace-tests.el index 3248403078f..17c6b8592c9 100644 --- a/test/lisp/emacs-lisp/backtrace-tests.el +++ b/test/lisp/emacs-lisp/backtrace-tests.el @@ -225,12 +225,14 @@ (ert-deftest backtrace-tests--single-and-multi-line () "Forms in backtrace frames can be on a single line or on multiple lines." (ert-with-test-buffer (:name "single-multi-line") - (let* ((arg '(lambda (x) ; Quote this so it isn't made into a closure. - ;; Make the form long enough so `number' should not - ;; appear on the first line once pretty-printed. - (interactive (region-beginning)) - (let ((number (1+ x))) - (+ x number)))) + (let* ((arg + (byte-run-strip-lambda-doc + '(lambda (x) ; Quote this so it isn't made into a closure. + ;; Make the form long enough so `number' should not + ;; appear on the first line once pretty-printed. + (interactive (region-beginning)) + (let ((number (1+ x))) + (+ x number))))) (header-string "Test header: ") (header (format "%s%s\n" header-string arg)) (insert-header-function (lambda () diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el index 5bbade0ae6e..11fe7b0ab32 100644 --- a/test/lisp/emacs-lisp/cconv-tests.el +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -179,8 +179,9 @@ (cconv-closure-convert '#'(lambda (x) (let ((f #'(lambda () (+ x 1)))) (funcall f))))) + (byte-run-strip-lambda-doc '#'(lambda (x) (let ((f #'(lambda (x) (+ x 1)))) - (funcall f x))))) + (funcall f x)))))) ;; Bug#30872. (should @@ -216,10 +217,11 @@ (cconv-closure-convert '#'(lambda (x) #'(lambda () x))))) - '#'(lambda (x) - (internal-make-closure - nil (x) nil - (internal-get-closed-var 0))))) + (byte-run-strip-lambda-doc + '#'(lambda (x) + (internal-make-closure + nil (x) nil + (internal-get-closed-var 0)))))) ;; Basic case: (should (equal (byte-run-strip-lambda-doc (cconv-tests--intern-all @@ -228,22 +230,24 @@ (let ((f #'(lambda () x))) (let ((x 'b)) (list x (funcall f)))))))) - '#'(lambda (x) - (let ((f #'(lambda (x) x))) - (let ((x 'b) - (closed-x x)) - (list x (funcall f closed-x))))))) + (byte-run-strip-lambda-doc + '#'(lambda (x) + (let ((f #'(lambda (x) x))) + (let ((x 'b) + (closed-x x)) + (list x (funcall f closed-x)))))))) (should (equal (byte-run-strip-lambda-doc (cconv-tests--intern-all (cconv-closure-convert '#'(lambda (x) (let ((f #'(lambda () x))) (let* ((x 'b)) (list x (funcall f)))))))) - '#'(lambda (x) - (let ((f #'(lambda (x) x))) - (let* ((closed-x x) - (x 'b)) - (list x (funcall f closed-x))))))) + (byte-run-strip-lambda-doc + '#'(lambda (x) + (let ((f #'(lambda (x) x))) + (let* ((closed-x x) + (x 'b)) + (list x (funcall f closed-x)))))))) ;; With the lambda-lifted shadowed variable also being captured: (should (equal (byte-run-strip-lambda-doc @@ -254,13 +258,14 @@ (let ((f #'(lambda () x))) (let ((x 'a)) (list x (funcall f))))))))) - '#'(lambda (x) - (internal-make-closure - nil (x) nil - (let ((f #'(lambda (x) x))) - (let ((x 'a) - (closed-x (internal-get-closed-var 0))) - (list x (funcall f closed-x)))))))) + (byte-run-strip-lambda-doc + '#'(lambda (x) + (internal-make-closure + nil (x) nil + (let ((f #'(lambda (x) x))) + (let ((x 'a) + (closed-x (internal-get-closed-var 0))) + (list x (funcall f closed-x))))))))) (should (equal (byte-run-strip-lambda-doc (cconv-tests--intern-all (cconv-closure-convert @@ -269,13 +274,14 @@ (let ((f #'(lambda () x))) (let* ((x 'a)) (list x (funcall f))))))))) - '#'(lambda (x) - (internal-make-closure - nil (x) nil - (let ((f #'(lambda (x) x))) - (let* ((closed-x (internal-get-closed-var 0)) - (x 'a)) - (list x (funcall f closed-x)))))))) + (byte-run-strip-lambda-doc + '#'(lambda (x) + (internal-make-closure + nil (x) nil + (let ((f #'(lambda (x) x))) + (let* ((closed-x (internal-get-closed-var 0)) + (x 'a)) + (list x (funcall f closed-x))))))))) ;; With lambda-lifted shadowed variable also being mutably captured: (should (equal (byte-run-strip-lambda-doc (cconv-tests--intern-all @@ -286,16 +292,17 @@ (setq x x) (let ((x 'a)) (list x (funcall f))))))))) - '#'(lambda (x) - (let ((x (list x))) - (internal-make-closure - nil (x) nil - (let ((f #'(lambda (x) (car-safe x)))) - (setcar (internal-get-closed-var 0) - (car-safe (internal-get-closed-var 0))) - (let ((x 'a) - (closed-x (internal-get-closed-var 0))) - (list x (funcall f closed-x))))))))) + (byte-run-strip-lambda-doc + '#'(lambda (x) + (let ((x (list x))) + (internal-make-closure + nil (x) nil + (let ((f #'(lambda (x) (car-safe x)))) + (setcar (internal-get-closed-var 0) + (car-safe (internal-get-closed-var 0))) + (let ((x 'a) + (closed-x (internal-get-closed-var 0))) + (list x (funcall f closed-x)))))))))) (should (equal (byte-run-strip-lambda-doc (cconv-tests--intern-all (cconv-closure-convert @@ -305,16 +312,17 @@ (setq x x) (let* ((x 'a)) (list x (funcall f))))))))) - '#'(lambda (x) - (let ((x (list x))) - (internal-make-closure - nil (x) nil - (let ((f #'(lambda (x) (car-safe x)))) - (setcar (internal-get-closed-var 0) - (car-safe (internal-get-closed-var 0))) - (let* ((closed-x (internal-get-closed-var 0)) - (x 'a)) - (list x (funcall f closed-x))))))))) + (byte-run-strip-lambda-doc + '#'(lambda (x) + (let ((x (list x))) + (internal-make-closure + nil (x) nil + (let ((f #'(lambda (x) (car-safe x)))) + (setcar (internal-get-closed-var 0) + (car-safe (internal-get-closed-var 0))) + (let* ((closed-x (internal-get-closed-var 0)) + (x 'a)) + (list x (funcall f closed-x)))))))))) ;; Lambda-lifted variable that isn't actually captured where it is shadowed: (should (equal (byte-run-strip-lambda-doc (cconv-tests--intern-all @@ -324,13 +332,14 @@ (h #'(lambda () (setq x x)))) (let ((x 'b)) (list x (funcall g) (funcall h)))))))) - '#'(lambda (x) - (let ((x (list x))) - (let ((g #'(lambda (x) (car-safe x))) - (h #'(lambda (x) (setcar x (car-safe x))))) - (let ((x 'b) - (closed-x x)) - (list x (funcall g closed-x) (funcall h closed-x)))))))) + (byte-run-strip-lambda-doc + '#'(lambda (x) + (let ((x (list x))) + (let ((g #'(lambda (x) (car-safe x))) + (h #'(lambda (x) (setcar x (car-safe x))))) + (let ((x 'b) + (closed-x x)) + (list x (funcall g closed-x) (funcall h closed-x))))))))) (should (equal (byte-run-strip-lambda-doc (cconv-tests--intern-all (cconv-closure-convert @@ -339,14 +348,14 @@ (h #'(lambda () (setq x x)))) (let* ((x 'b)) (list x (funcall g) (funcall h)))))))) - '#'(lambda (x) - (let ((x (list x))) - (let ((g #'(lambda (x) (car-safe x))) - (h #'(lambda (x) (setcar x (car-safe x))))) - (let* ((closed-x x) - (x 'b)) - (list x (funcall g closed-x) (funcall h closed-x)))))))) - ) + (byte-run-strip-lambda-doc + '#'(lambda (x) + (let ((x (list x))) + (let ((g #'(lambda (x) (car-safe x))) + (h #'(lambda (x) (setcar x (car-safe x))))) + (let* ((closed-x x) + (x 'b)) + (list x (funcall g closed-x) (funcall h closed-x)))))))))) (ert-deftest cconv-tests-interactive-closure-bug51695 () (let ((f (let ((d 51695)) @@ -384,10 +393,11 @@ (prefix-numeric-value current-prefix-arg) 'toggle))) (ignore arg)))) - (if (cadr (nth 2 (cadr f)))) + (f2 (byte-run-strip-lambda-doc f)) + (if (cadr (nth 2 (cadr f2)))) (if2)) - (cconv-closure-convert f) - (setq if2 (cadr (nth 2 (cadr f)))) + (cconv-closure-convert f2) + (setq if2 (cadr (nth 2 (cadr f2)))) (should (eq if if2)))) (provide 'cconv-tests) diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 561e4577d8b..a2a5bcc831c 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -169,11 +169,12 @@ (byte-run-strip-lambda-doc (macroexpand-1 '(erc--with-dependent-type-match (repeat face) erc-match))) - '(backquote-list* - 'repeat :match (lambda (w v) - (require 'erc-match) - (widget-editable-list-match w v)) - '(face))))) + (byte-run-strip-lambda-doc + '(backquote-list* + 'repeat :match (lambda (w v) + (require 'erc-match) + (widget-editable-list-match w v)) + '(face)))))) (ert-deftest erc--doarray () (let ((array "abcdefg")