From f687e62ac5dff18a81354e2a29f523c16e3446c3 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Sat, 19 Feb 2022 10:38:19 +0000 Subject: Fix symbols with position appearing in the output of `compile-defun' This happened with the tags of a condition-case. Also fix the detection of circular lists while stripping the positions from symbols with position. * lisp/emacs-lisp/byte-run.el (byte-run--circular-list-p): Remove. (byte-run--strip-s-p-1): Write a value of t into a hash table for each cons or vector/record encountered. (This is to prevent loops with circular structures.) This is now done for all arguments, not just those detected as circular lists. * lisp/emacs-lisp/bytecomp.el (byte-compile-file-form-defvar) (byte-compile-form, byte-compile-dynamic-variable-op) (byte-compile-constant, byte-compile-push-constant): Remove redundant calls to `bare-symbol'. (byte-compile-lambda): call `byte-run-strip-symbol-positions' on the arglist. (byte-compile-out): call `byte-run-strip-symbol-positions' on the operand. This is the main call to this function in bytecomp.el. * src/fns.c (hashfn_eq): Strip the position from an argument which is a symbol with position. (hash_lookup): No longer strip a position from a symbol with position. (sxhash_obj): Add handling for symbols with position, substituting their bare symbols when symbols with position are enabled. --- lisp/emacs-lisp/byte-run.el | 77 ++++++++++++++++----------------------------- 1 file changed, 27 insertions(+), 50 deletions(-) (limited to 'lisp/emacs-lisp/byte-run.el') diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 110f7e4abf4..5c59d0ae941 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -37,24 +37,6 @@ the corresponding new element of the same type. The purpose of this is to detect circular structures.") -(defalias 'byte-run--circular-list-p - #'(lambda (l) - "Return non-nil when the list L is a circular list. -Note that this algorithm doesn't check any circularity in the -CARs of list elements." - (let ((hare l) - (tortoise l)) - (condition-case err - (progn - (while (progn - (setq hare (cdr (cdr hare)) - tortoise (cdr tortoise)) - (not (or (eq tortoise hare) - (null hare))))) - (eq tortoise hare)) - (wrong-type-argument nil) - (error (signal (car err) (cdr err))))))) - (defalias 'byte-run--strip-s-p-1 #'(lambda (arg) "Strip all positions from symbols in ARG, modifying ARG. @@ -64,41 +46,36 @@ Return the modified ARG." (bare-symbol arg)) ((consp arg) - (let* ((round (byte-run--circular-list-p arg)) - (hash (and round (gethash arg byte-run--ssp-seen)))) - (or hash - (let ((a arg) new) - (while - (progn - (when round - (puthash a new byte-run--ssp-seen)) - (setq new (byte-run--strip-s-p-1 (car a))) - (when (not (eq new (car a))) ; For read-only things. - (setcar a new)) - (and (consp (cdr a)) - (not - (setq hash - (and round - (gethash (cdr a) byte-run--ssp-seen)))))) - (setq a (cdr a))) - (setq new (byte-run--strip-s-p-1 (cdr a))) - (when (not (eq new (cdr a))) - (setcdr a (or hash new))) - arg)))) + (let* ((hash (gethash arg byte-run--ssp-seen))) + (if hash ; Already processed this node. + arg + (let ((a arg) new) + (while + (progn + (puthash a t byte-run--ssp-seen) + (setq new (byte-run--strip-s-p-1 (car a))) + (setcar a new) + (and (consp (cdr a)) + (not + (setq hash (gethash (cdr a) byte-run--ssp-seen))))) + (setq a (cdr a))) + (setq new (byte-run--strip-s-p-1 (cdr a))) + (setcdr a new) + arg)))) ((or (vectorp arg) (recordp arg)) (let ((hash (gethash arg byte-run--ssp-seen))) - (or hash - (let* ((len (length arg)) - (i 0) - new) - (puthash arg arg byte-run--ssp-seen) - (while (< i len) - (setq new (byte-run--strip-s-p-1 (aref arg i))) - (when (not (eq new (aref arg i))) - (aset arg i new)) - (setq i (1+ i))) - arg)))) + (if hash + arg + (let* ((len (length arg)) + (i 0) + new) + (puthash arg t byte-run--ssp-seen) + (while (< i len) + (setq new (byte-run--strip-s-p-1 (aref arg i))) + (aset arg i new) + (setq i (1+ i))) + arg)))) (t arg)))) -- cgit v1.2.3 From f262a6af3694b41828ffb8e62a800f8a3ed4e4aa Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 19 Feb 2022 14:20:02 -0500 Subject: (macroexp-warn-and-return): Fix bug#53618 * lisp/emacs-lisp/macroexp.el (macroexp-warn-and-return): Reorder arguments to preserve compatibility with that of Emacs-28. (macroexp--unfold-lambda, macroexp--expand-all): * lisp/emacs-lisp/pcase.el (pcase-compile-patterns, pcase--u1): * lisp/emacs-lisp/gv.el (gv-ref): * lisp/emacs-lisp/eieio.el (defclass): * lisp/emacs-lisp/eieio-core.el (eieio-oref, eieio-oref-default) (eieio-oset-default): * lisp/emacs-lisp/easy-mmode.el (define-minor-mode): * lisp/emacs-lisp/cl-macs.el (cl-symbol-macrolet, cl-defstruct): * lisp/emacs-lisp/cl-generic.el (cl-defmethod): * lisp/emacs-lisp/byte-run.el (defmacro, defun): * lisp/emacs-lisp/bindat.el (bindat--type): Adjust accordingly. --- lisp/emacs-lisp/bindat.el | 1 - lisp/emacs-lisp/byte-run.el | 6 ++---- lisp/emacs-lisp/cl-generic.el | 5 ++--- lisp/emacs-lisp/cl-macs.el | 9 +++------ lisp/emacs-lisp/easy-mmode.el | 1 - lisp/emacs-lisp/eieio-core.el | 15 +++++---------- lisp/emacs-lisp/eieio.el | 6 +++--- lisp/emacs-lisp/gv.el | 7 ++----- lisp/emacs-lisp/macroexp.el | 22 +++++++++------------- lisp/emacs-lisp/pcase.el | 6 ++---- 10 files changed, 28 insertions(+), 50 deletions(-) (limited to 'lisp/emacs-lisp/byte-run.el') diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 04c5b9f0808..c6d64975eca 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -804,7 +804,6 @@ is the name of a variable that will hold the value we need to pack.") (if (or (eq label '_) (not (assq label labels))) code (macroexp-warn-and-return - code (format "Duplicate label: %S" label) code)))) (`(,_ ,val) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 5c59d0ae941..c542c550169 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -311,11 +311,10 @@ The return value is undefined. (let ((f (cdr (assq (car x) macro-declarations-alist)))) (if f (apply (car f) name arglist (cdr x)) (macroexp-warn-and-return - (car x) (format-message "Unknown macro property %S in %S" (car x) name) - nil)))) + nil nil nil (car x))))) decls))) ;; Refresh font-lock if this is a new macro, or it is an ;; existing macro whose 'no-font-lock-keyword declaration @@ -385,10 +384,9 @@ The return value is undefined. nil) (t (macroexp-warn-and-return - (car x) (format-message "Unknown defun property `%S' in %S" (car x) name) - nil))))) + nil nil nil (car x)))))) decls)) (def (list 'defalias (list 'quote name) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 5e0e0834fff..b44dda6f9d4 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -499,7 +499,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined lambda-doc ; documentation string def-body))) ; part to be debugged (let ((qualifiers nil) - (org-name name)) + (orig-name name)) (while (cl-generic--method-qualifier-p args) (push args qualifiers) (setq args (pop body))) @@ -514,9 +514,8 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (byte-compile-warning-enabled-p 'obsolete name)) (let* ((obsolete (get name 'byte-obsolete-info))) (macroexp-warn-and-return - org-name (macroexp--obsolete-warning name obsolete "generic function") - nil))) + nil nil nil orig-name))) ;; You could argue that `defmethod' modifies rather than defines the ;; function, so warnings like "not known to be defined" are fair game. ;; But in practice, it's common to use `cl-defmethod' diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 470168177ca..50852172505 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2431,10 +2431,9 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). (if malformed-bindings (let ((rev-malformed-bindings (nreverse malformed-bindings))) (macroexp-warn-and-return - rev-malformed-bindings (format-message "Malformed `cl-symbol-macrolet' binding(s): %S" rev-malformed-bindings) - expansion)) + expansion nil nil rev-malformed-bindings)) expansion))) (unless advised (advice-remove 'macroexpand #'cl--sm-macroexpand))))) @@ -3118,20 +3117,18 @@ To see the documentation for a defined struct type, use (when (cl-oddp (length desc)) (push (macroexp-warn-and-return - (car (last desc)) (format "Missing value for option `%S' of slot `%s' in struct %s!" (car (last desc)) slot name) - 'nil) + nil nil nil (car (last desc))) forms) (when (and (keywordp (car defaults)) (not (keywordp (car desc)))) (let ((kw (car defaults))) (push (macroexp-warn-and-return - kw (format " I'll take `%s' to be an option rather than a default value." kw) - 'nil) + nil nil nil kw) forms) (push kw desc) (setcar defaults nil)))) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 7bcb2f2936d..688c76e0c54 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -230,7 +230,6 @@ INIT-VALUE LIGHTER KEYMAP. (warnwrap (if (or (null body) (keywordp (car body))) #'identity (lambda (exp) (macroexp-warn-and-return - exp "Use keywords rather than deprecated positional arguments to `define-minor-mode'" exp)))) keyw keymap-sym tmp) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 45ded158990..19aa20fa086 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -748,9 +748,8 @@ Argument FN is the function calling this verifier." ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-slot-names)))) (macroexp-warn-and-return - name (format-message "Unknown slot `%S'" name) - exp nil 'compile-only)) + exp nil 'compile-only name)) (_ exp)))) (gv-setter eieio-oset)) (cl-check-type slot symbol) @@ -785,15 +784,13 @@ Fills in CLASS's SLOT with its default value." ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-slot-names)))) (macroexp-warn-and-return - name (format-message "Unknown slot `%S'" name) - exp nil 'compile-only)) + exp nil 'compile-only name)) ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-class-slot-names)))) (macroexp-warn-and-return - name (format-message "Slot `%S' is not class-allocated" name) - exp nil 'compile-only)) + exp nil 'compile-only name)) (_ exp))))) (cl-check-type class (or eieio-object class)) (cl-check-type slot symbol) @@ -849,15 +846,13 @@ Fills in the default value in CLASS' in SLOT with VALUE." ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-slot-names)))) (macroexp-warn-and-return - name (format-message "Unknown slot `%S'" name) - exp nil 'compile-only)) + exp nil 'compile-only name)) ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-class-slot-names)))) (macroexp-warn-and-return - name (format-message "Slot `%S' is not class-allocated" name) - exp nil 'compile-only)) + exp nil 'compile-only name)) (_ exp))))) (setq class (eieio--class-object class)) (cl-check-type class eieio--class) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 6f97c25ca96..1315ca0c627 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -246,7 +246,7 @@ This method is obsolete." `(progn ,@(mapcar (lambda (w) (macroexp-warn-and-return - (car w) (cdr w) `(progn ',(cdr w)) nil 'compile-only)) + (cdr w) `(progn ',(cdr w)) nil 'compile-only (car w))) warnings) ;; This test must be created right away so we can have self- ;; referencing classes. ei, a class whose slot can contain only @@ -296,13 +296,13 @@ This method is obsolete." (if (not (stringp (car slots))) whole (macroexp-warn-and-return - (car slots) (format "Obsolete name arg %S to constructor %S" (car slots) (car whole)) ;; Keep the name arg, for backward compatibility, ;; but hide it so we don't trigger indefinitely. `(,(car whole) (identity ,(car slots)) - ,@(cdr slots))))))) + ,@(cdr slots)) + nil nil (car slots)))))) (apply #'make-instance ',name slots)))))) diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 91538d1f06e..7cfa1f2dadc 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -581,9 +581,7 @@ This is like the `&' operator of the C language. Note: this only works reliably with lexical binding mode, except for very simple PLACEs such as (symbol-function \\='foo) which will also work in dynamic binding mode." - (let ((org-place place) ; It's too difficult to determine by inspection whether - ; the functions modify place. - (code + (let ((code (gv-letplace (getter setter) place `(cons (lambda () ,getter) (lambda (gv--val) ,(funcall setter 'gv--val)))))) @@ -595,9 +593,8 @@ binding mode." (eq (car-safe code) 'cons)) code (macroexp-warn-and-return - org-place "Use of gv-ref probably requires lexical-binding" - code)))) + code nil nil place)))) (defsubst gv-deref (ref) "Dereference REF, returning the referenced value. diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 256092599b2..e91b302af10 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -160,14 +160,14 @@ Other uses risk returning non-nil value that point to the wrong file." (define-obsolete-function-alias 'macroexp--warn-and-return #'macroexp-warn-and-return "28.1") -(defun macroexp-warn-and-return (arg msg form &optional category compile-only) +(defun macroexp-warn-and-return (msg form &optional category compile-only arg) "Return code equivalent to FORM labeled with warning MSG. -ARG is a symbol (or a form) giving the source code position of FORM -for the message. It should normally be a symbol with position. CATEGORY is the category of the warning, like the categories that can appear in `byte-compile-warnings'. COMPILE-ONLY non-nil means no warning should be emitted if the code -is executed without being compiled first." +is executed without being compiled first. +ARG is a symbol (or a form) giving the source code position for the message. +It should normally be a symbol with position and it defaults to FORM." (cond ((null msg) form) ((macroexp-compiling-p) @@ -177,7 +177,7 @@ is executed without being compiled first." ;; macroexpand-all gets right back to macroexpanding `form'. form (puthash form form macroexp--warned) - (macroexp--warn-wrap arg msg form category))) + (macroexp--warn-wrap (or arg form) msg form category))) (t (unless compile-only (message "%sWarning: %s" @@ -233,12 +233,11 @@ is executed without being compiled first." (let* ((fun (car form)) (obsolete (get fun 'byte-obsolete-info))) (macroexp-warn-and-return - fun (macroexp--obsolete-warning fun obsolete (if (symbolp (symbol-function fun)) "alias" "macro")) - new-form (list 'obsolete fun))) + new-form (list 'obsolete fun) nil fun)) new-form))) (defun macroexp--unfold-lambda (form &optional name) @@ -289,12 +288,11 @@ is executed without being compiled first." (setq arglist (cdr arglist))) (if values (macroexp-warn-and-return - arglist (format (if (eq values 'too-few) "attempt to open-code `%s' with too few arguments" "attempt to open-code `%s' with too many arguments") name) - form) + form nil nil arglist) ;; The following leads to infinite recursion when loading a ;; file containing `(defsubst f () (f))', and then trying to @@ -365,9 +363,8 @@ Assumes the caller has bound `macroexpand-all-environment'." (if (null body) (macroexp-unprogn (macroexp-warn-and-return - fun (format "Empty %s body" fun) - nil nil 'compile-only)) + nil nil 'compile-only fun)) (macroexp--all-forms body)) (cdr form)) form))) @@ -405,11 +402,10 @@ Assumes the caller has bound `macroexpand-all-environment'." (eq 'lambda (car-safe (cadr arg)))) (setcar (nthcdr funarg form) (macroexp-warn-and-return - (cadr arg) (format "%S quoted with ' rather than with #'" (let ((f (cadr arg))) (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) - arg))))) + arg nil nil (cadr arg)))))) ;; Macro expand compiler macros. This cannot be delayed to ;; byte-optimize-form because the output of the compiler-macro can ;; use macros. diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index c3dbfe29473..0330a2a0aba 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -433,10 +433,9 @@ how many time this CODEGEN is called." (memq (car case) pcase--dontwarn-upats)) (setq main (macroexp-warn-and-return - (car case) (format "pcase pattern %S shadowed by previous pcase pattern" (car case)) - main)))) + main nil nil (car case))))) main))) (defun pcase--expand (exp cases) @@ -941,9 +940,8 @@ Otherwise, it defers to REST which is a list of branches of the form (let ((code (pcase--u1 matches code vars rest))) (if (eq upat '_) code (macroexp-warn-and-return - upat "Pattern t is deprecated. Use `_' instead" - code)))) + code nil nil upat)))) ((eq upat 'pcase--dontcare) :pcase--dontcare) ((memq (car-safe upat) '(guard pred)) (if (eq (car upat) 'pred) (pcase--mark-used sym)) -- cgit v1.2.3 From 6092ee1c3ff503fbe8087e13b7eae2f904c4af3b Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Thu, 24 Feb 2022 17:30:39 +0000 Subject: Amend byte-run-strip-symbol-positions so that an unexec build builds This fixes bug #54098. * lisp/emacs-lisp/byte-run.el (byte-run--strip-list) (byte-run--strip-vector/record): New functions. These alter a list or vector/record structure only where a symbol with position gets replaced by a bare symbol. (byte-run-strip-symbol-positions): Reformulate to use the two new functions. (function-put): No longer strip positions from the second and third arguments. * lisp/emacs-lisp/bytecomp.el (byte-compile-out): Remove the senseless "stripping" of putative symbol positions from OPERAND, which is nil or a number. --- lisp/emacs-lisp/byte-run.el | 98 ++++++++++++++++++++++++++------------------- lisp/emacs-lisp/bytecomp.el | 3 +- 2 files changed, 57 insertions(+), 44 deletions(-) (limited to 'lisp/emacs-lisp/byte-run.el') diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index c542c550169..d7a2d8cecaf 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -37,53 +37,69 @@ the corresponding new element of the same type. The purpose of this is to detect circular structures.") -(defalias 'byte-run--strip-s-p-1 +(defalias 'byte-run--strip-list #'(lambda (arg) - "Strip all positions from symbols in ARG, modifying ARG. -Return the modified ARG." + "Strip the positions from symbols with position in the list ARG. +This is done by destructively modifying ARG. Return ARG." + (let ((a arg)) + (while + (and + (not (gethash a byte-run--ssp-seen)) + (progn + (puthash a t byte-run--ssp-seen) + (cond + ((symbol-with-pos-p (car a)) + (setcar a (bare-symbol (car a)))) + ((consp (car a)) + (byte-run--strip-list (car a))) + ((or (vectorp (car a)) (recordp (car a))) + (byte-run--strip-vector/record (car a)))) + (consp (cdr a)))) + (setq a (cdr a))) + (cond + ((symbol-with-pos-p (cdr a)) + (setcdr a (bare-symbol (cdr a)))) + ((or (vectorp (cdr a)) (recordp (cdr a))) + (byte-run--strip-vector/record (cdr a)))) + arg))) + +(defalias 'byte-run--strip-vector/record + #'(lambda (arg) + "Strip the positions from symbols with position in the vector/record ARG. +This is done by destructively modifying ARG. Return ARG." + (unless (gethash arg byte-run--ssp-seen) + (let ((len (length arg)) + (i 0) + elt) + (puthash arg t byte-run--ssp-seen) + (while (< i len) + (setq elt (aref arg i)) + (cond + ((symbol-with-pos-p elt) + (aset arg i elt)) + ((consp elt) + (byte-run--strip-list elt)) + ((or (vectorp elt) (recordp elt)) + (byte-run--strip-vector/record elt)))))) + arg)) + +(defalias 'byte-run-strip-symbol-positions + #'(lambda (arg) + "Strip all positions from symbols in ARG. +This modifies destructively then returns ARG. + +ARG is any Lisp object, but is usually a list or a vector or a +record, containing symbols with position." + (setq byte-run--ssp-seen (make-hash-table :test 'eq)) (cond ((symbol-with-pos-p arg) (bare-symbol arg)) - ((consp arg) - (let* ((hash (gethash arg byte-run--ssp-seen))) - (if hash ; Already processed this node. - arg - (let ((a arg) new) - (while - (progn - (puthash a t byte-run--ssp-seen) - (setq new (byte-run--strip-s-p-1 (car a))) - (setcar a new) - (and (consp (cdr a)) - (not - (setq hash (gethash (cdr a) byte-run--ssp-seen))))) - (setq a (cdr a))) - (setq new (byte-run--strip-s-p-1 (cdr a))) - (setcdr a new) - arg)))) - + (byte-run--strip-list arg)) ((or (vectorp arg) (recordp arg)) - (let ((hash (gethash arg byte-run--ssp-seen))) - (if hash - arg - (let* ((len (length arg)) - (i 0) - new) - (puthash arg t byte-run--ssp-seen) - (while (< i len) - (setq new (byte-run--strip-s-p-1 (aref arg i))) - (aset arg i new) - (setq i (1+ i))) - arg)))) - + (byte-run--strip-vector/record arg)) (t arg)))) -(defalias 'byte-run-strip-symbol-positions - #'(lambda (arg) - (setq byte-run--ssp-seen (make-hash-table :test 'eq)) - (byte-run--strip-s-p-1 arg))) - (defalias 'function-put ;; We don't want people to just use `put' because we can't conveniently ;; hook into `put' to remap old properties to new ones. But for now, there's @@ -92,9 +108,7 @@ Return the modified ARG." "Set FUNCTION's property PROP to VALUE. The namespace for PROP is shared with symbols. So far, FUNCTION can only be a symbol, not a lambda expression." - (put (bare-symbol function) - (byte-run-strip-symbol-positions prop) - (byte-run-strip-symbol-positions value)))) + (put (bare-symbol function) prop value))) (function-put 'defmacro 'doc-string-elt 3) (function-put 'defmacro 'lisp-indent-function 2) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index c59bb292f8f..6f83429dd4b 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -5099,7 +5099,7 @@ binding slots have been popped." OP and OPERAND are as passed to `byte-compile-out'." (if (memq op '(byte-call byte-discardN byte-discardN-preserve-tos)) ;; For calls, OPERAND is the number of args, so we pop OPERAND + 1 - ;; elements, and the push the result, for a total of -OPERAND. + ;; elements, and then push the result, for a total of -OPERAND. ;; For discardN*, of course, we just pop OPERAND elements. (- operand) (or (aref byte-stack+-info (symbol-value op)) @@ -5109,7 +5109,6 @@ OP and OPERAND are as passed to `byte-compile-out'." (- 1 operand)))) (defun byte-compile-out (op &optional operand) - (setq operand (byte-run-strip-symbol-positions operand)) (push (cons op operand) byte-compile-output) (if (eq op 'byte-return) ;; This is actually an unnecessary case, because there should be no -- cgit v1.2.3 From 68cdb95019a24024e6000ae75de6aa974d9b4a23 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Sun, 6 Mar 2022 13:37:30 +0000 Subject: Restore call to byte-run-strip-symbol-positions in byte-compile-out Also increment a loop counter. This should fix bug #54248. * lisp/emacs-lisp/byte-run.el (byte-run--strip-vector/record): increment the loop counter 'i' in the main loop. * lisp/emacs-lisp/bytecomp.el (byte-compile-out): call byte-run-strip-symbol-positions on operands which are one-element lists. --- lisp/emacs-lisp/byte-run.el | 3 ++- lisp/emacs-lisp/bytecomp.el | 5 +++++ 2 files changed, 7 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp/byte-run.el') diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index d7a2d8cecaf..384e8cba88f 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -80,7 +80,8 @@ This is done by destructively modifying ARG. Return ARG." ((consp elt) (byte-run--strip-list elt)) ((or (vectorp elt) (recordp elt)) - (byte-run--strip-vector/record elt)))))) + (byte-run--strip-vector/record elt))) + (setq i (1+ i))))) arg)) (defalias 'byte-run-strip-symbol-positions diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 432fd2ad9c5..9be44a8d5af 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -5108,6 +5108,11 @@ OP and OPERAND are as passed to `byte-compile-out'." (- 1 operand)))) (defun byte-compile-out (op &optional operand) + "Push the operation onto `byte-compile-output'. +OP is an opcode, a symbol. OPERAND is either nil or a number or +a one-element list of a lisp form." + (when (and (consp operand) (null (cdr operand))) + (setq operand (byte-run-strip-symbol-positions operand))) (push (cons op operand) byte-compile-output) (if (eq op 'byte-return) ;; This is actually an unnecessary case, because there should be no -- cgit v1.2.3 From 5b23c9942ae057c886e68edb8c4bf09bf7e8eda9 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Fri, 22 Apr 2022 17:16:21 +0000 Subject: Byte compiler: correct output warning message positions (part 2) A supplementary commit to that on 2022-04-18: * lisp/emacs-lisp/bytecomp.el (byte-compile--first-symbol-with-pos): Handle vectors and records correctly. * lisp/emacs-lisp/byte-run.el (byte-run--ssp-seen): Correct the doc string. --- lisp/emacs-lisp/byte-run.el | 3 +-- lisp/emacs-lisp/bytecomp.el | 4 ++-- 2 files changed, 3 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp/byte-run.el') diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 384e8cba88f..0113051c8eb 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -32,8 +32,7 @@ (defvar byte-run--ssp-seen nil "Which conses/vectors/records have been processed in strip-symbol-positions? -The value is a hash table, the key being the old element and the value being -the corresponding new element of the same type. +The value is a hash table, the keys being the elements and the values being t. The purpose of this is to detect circular structures.") diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 8128410916a..f97324f3a8f 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1185,14 +1185,14 @@ Here, \"first\" is by a depth first search." (and (symbolp (setq sym (byte-compile--first-symbol-with-pos (cdr form)))) sym) 0)) - ((and (vectorp form) + ((and (or (vectorp form) (recordp form)) (> (length form) 0)) (let ((i 0) (len (length form)) elt) (catch 'sym (while (< i len) - (when (symbolp + (when (symbol-with-pos-p (setq elt (byte-compile--first-symbol-with-pos (aref form i)))) (throw 'sym elt)) (setq i (1+ i))) -- cgit v1.2.3 From a0524584e93a66278dcf7bb998398f7484f9e8b5 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 22 May 2022 20:06:24 +0200 Subject: Allow suppressing messages about the wrong number of arguments * lisp/emacs-lisp/byte-run.el (with-suppressed-warnings): Add `wrong-args'. * lisp/emacs-lisp/bytecomp.el (byte-compile-emit-callargs-warn) (byte-compile-subr-wrong-args): Allow suppressing wrong number of arguments. --- lisp/emacs-lisp/byte-run.el | 2 +- lisp/emacs-lisp/bytecomp.el | 32 +++++++++++++++++--------------- 2 files changed, 18 insertions(+), 16 deletions(-) (limited to 'lisp/emacs-lisp/byte-run.el') diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 0113051c8eb..2d11f350f0b 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -637,7 +637,7 @@ The warnings that can be suppressed are a subset of the warnings in `byte-compile-warning-types'; see the variable `byte-compile-warnings' for a fuller explanation of the warning types. The types that can be suppressed with this macro are -`free-vars', `callargs', `redefine', `obsolete', +`free-vars', `callargs', `redefine', `obsolete', `wrong-args', `interactive-only', `lexical', `mapcar', `constants' and `suspicious'. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index e72b96af4a9..920cdbe5a6f 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1494,15 +1494,16 @@ when printing the error message." byte-compile-unresolved-functions))))) (defun byte-compile-emit-callargs-warn (name actual-args min-args max-args) - (byte-compile-warn-x - name - "%s called with %d argument%s, but %s %s" - name actual-args - (if (= 1 actual-args) "" "s") - (if (< actual-args min-args) - "requires" - "accepts only") - (byte-compile-arglist-signature-string (cons min-args max-args)))) + (when (byte-compile-warning-enabled-p 'wrong-args name) + (byte-compile-warn-x + name + "`%s' called with %d argument%s, but %s %s" + name actual-args + (if (= 1 actual-args) "" "s") + (if (< actual-args min-args) + "requires" + "accepts only") + (byte-compile-arglist-signature-string (cons min-args max-args))))) (defun byte-compile--check-arity-bytecode (form bytecode) "Check that the call in FORM matches that allowed by BYTECODE." @@ -3838,12 +3839,13 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (defun byte-compile-subr-wrong-args (form n) - (byte-compile-warn-x (car form) - "`%s' called with %d arg%s, but requires %s" - (car form) (length (cdr form)) - (if (= 1 (length (cdr form))) "" "s") n) - ;; Get run-time wrong-number-of-args error. - (byte-compile-normal-call form)) + (when (byte-compile-warning-enabled-p 'wrong-args (car form)) + (byte-compile-warn-x (car form) + "`%s' called with %d arg%s, but requires %s" + (car form) (length (cdr form)) + (if (= 1 (length (cdr form))) "" "s") n) + ;; Get run-time wrong-number-of-args error. + (byte-compile-normal-call form))) (defun byte-compile-no-args (form) (if (not (= (length form) 1)) -- cgit v1.2.3 From f14f6180b78656eec2f4dad5b79eb5da20bd0b70 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 22 May 2022 20:14:03 +0200 Subject: Fix previous warning suppression change * lisp/emacs-lisp/bytecomp.el (byte-compile-emit-callargs-warn) (byte-compile-subr-wrong-args): * lisp/emacs-lisp/byte-run.el (with-suppressed-warnings): * lisp/cedet/semantic/fw.el (semantic-install-function-overrides): The `wrong-args' warning is really called `callargs'. --- lisp/cedet/semantic/fw.el | 2 +- lisp/emacs-lisp/byte-run.el | 2 +- lisp/emacs-lisp/bytecomp.el | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp/byte-run.el') diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el index c60778a34da..d07d8d42a8c 100644 --- a/lisp/cedet/semantic/fw.el +++ b/lisp/cedet/semantic/fw.el @@ -278,7 +278,7 @@ OVERRIDES will be installed globally for this major mode. If MODE is nil, OVERRIDES will be installed locally in the current buffer. This later installation should be done in MODE hook." (declare (obsolete define-mode-local-override "29.1")) - (with-suppressed-warnings ((wrong-args mode-local-bind)) + (with-suppressed-warnings ((callargs mode-local-bind)) (mode-local-bind ;; Add the semantic- prefix to OVERLOAD short names. (mapcar diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 2d11f350f0b..0113051c8eb 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -637,7 +637,7 @@ The warnings that can be suppressed are a subset of the warnings in `byte-compile-warning-types'; see the variable `byte-compile-warnings' for a fuller explanation of the warning types. The types that can be suppressed with this macro are -`free-vars', `callargs', `redefine', `obsolete', `wrong-args', +`free-vars', `callargs', `redefine', `obsolete', `interactive-only', `lexical', `mapcar', `constants' and `suspicious'. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 920cdbe5a6f..61382d6989f 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1494,7 +1494,7 @@ when printing the error message." byte-compile-unresolved-functions))))) (defun byte-compile-emit-callargs-warn (name actual-args min-args max-args) - (when (byte-compile-warning-enabled-p 'wrong-args name) + (when (byte-compile-warning-enabled-p 'callargs name) (byte-compile-warn-x name "`%s' called with %d argument%s, but %s %s" @@ -3839,7 +3839,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (defun byte-compile-subr-wrong-args (form n) - (when (byte-compile-warning-enabled-p 'wrong-args (car form)) + (when (byte-compile-warning-enabled-p 'callargs (car form)) (byte-compile-warn-x (car form) "`%s' called with %d arg%s, but requires %s" (car form) (length (cdr form)) -- cgit v1.2.3 From ed34cbeae7e2246b2a5f7578da3d1ccc6984f7ca Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 24 May 2022 12:36:41 +0200 Subject: Audit symbol quoting in Lisp doc strings * lisp/vc/vc-svn.el (vc-svn-dir-status-files): * lisp/so-long.el (so-long-mode-maintain-preserved-variables): * lisp/help-fns.el (help-fns--most-relevant-active-keymap): * lisp/gnus/nnselect.el (nnselect-get-artlist): (nnselect-store-artlist): * lisp/forms.el (forms-enumerate): * lisp/ffap.el (ffap-string-at-point): * lisp/emacs-lisp/byte-run.el (define-obsolete-variable-alias): Audit symbol quoting in Lisp doc strings. --- lisp/emacs-lisp/byte-run.el | 2 +- lisp/ffap.el | 4 ++-- lisp/forms.el | 2 +- lisp/gnus/nnselect.el | 8 ++++---- lisp/help-fns.el | 4 ++-- lisp/so-long.el | 4 ++-- lisp/vc/vc-svn.el | 2 +- 7 files changed, 13 insertions(+), 13 deletions(-) (limited to 'lisp/emacs-lisp/byte-run.el') diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 0113051c8eb..92c2699c6e3 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -534,7 +534,7 @@ made obsolete, for example a date or a release number. This macro evaluates all its parameters, and both OBSOLETE-NAME and CURRENT-NAME should be symbols, so a typical usage would look like: - (define-obsolete-variable-alias 'foo-thing 'bar-thing \"28.1\") + (define-obsolete-variable-alias \\='foo-thing \\='bar-thing \"28.1\") This macro uses `defvaralias' and `make-obsolete-variable' (which see). See the Info node `(elisp)Variable Aliases' for more details. diff --git a/lisp/ffap.el b/lisp/ffap.el index 30a9577d38f..ae86e554906 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -1229,13 +1229,13 @@ If the region is active, return a string from the region. If the point is in a comment, ensure that the returned string does not contain the comment start characters (especially for major modes that -have '//' as comment start characters). +have \"//\" as comment start characters). Set the variables `ffap-string-at-point' and `ffap-string-at-point-region'. When the region is active and larger than `ffap-max-region-length', -return an empty string, and set `ffap-string-at-point-region' to '(1 1)." +return an empty string, and set `ffap-string-at-point-region' to `(1 1)'." (let* (dir-separator (args (cdr diff --git a/lisp/forms.el b/lisp/forms.el index 8bfeaad1c1a..fdc44b5214f 100644 --- a/lisp/forms.el +++ b/lisp/forms.el @@ -2009,7 +2009,7 @@ It returns the highest number. Usage: (setq forms-number-of-fields (forms-enumerate - '(field1 field2 field2 ...)))" + \\='(field1 field2 field2 ...)))" (let ((the-index 0)) (while the-fields diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index cdbfa0b5910..b081b1c8f9b 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -291,9 +291,9 @@ parameters." (defmacro nnselect-get-artlist (group) "Get the list of articles for GROUP. -If the group parameter 'nnselect-get-artlist-override-function is +If the group parameter `nnselect-get-artlist-override-function' is non-nil call this function with argument GROUP to get the -artlist; if the group parameter 'nnselect-always-regenerate is +artlist; if the group parameter `nnselect-always-regenerate' is non-nil, regenerate the artlist; otherwise retrieve the artlist directly from the group parameters." `(when (gnus-nnselect-group-p ,group) @@ -310,9 +310,9 @@ directly from the group parameters." (defmacro nnselect-store-artlist (group artlist) "Store the ARTLIST for GROUP. -If the group parameter 'nnselect-store-artlist-override-function +If the group parameter `nnselect-store-artlist-override-function' is non-nil call this function on GROUP and ARTLIST; if the group -parameter 'nnselect-always-regenerate is non-nil don't store the +parameter `nnselect-always-regenerate' is non-nil don't store the artlist; otherwise store the ARTLIST in the group parameters." `(let ((override (gnus-group-get-parameter ,group diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 1ff47bcb496..45308e6e9c8 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -1902,8 +1902,8 @@ variable with value KEYMAP." The heuristic to determine which keymap is most likely to be relevant to a user follows this order: -1. 'keymap' text property at point -2. 'local-map' text property at point +1. `keymap' text property at point +2. `local-map' text property at point 3. the `current-local-map' This is used to set the default value for the interactive prompt diff --git a/lisp/so-long.el b/lisp/so-long.el index f4ae71d9058..a2b4282ad61 100644 --- a/lisp/so-long.el +++ b/lisp/so-long.el @@ -1518,14 +1518,14 @@ The variables are set in accordance with what was remembered in `so-long'." (kill-local-variable variable)))) (defun so-long-mode-maintain-preserved-variables () - "Set any 'preserved' variables. + "Set any \"preserved\" variables. The variables are set in accordance with what was remembered in `so-long'." (dolist (var (so-long-original 'so-long-mode-preserved-variables)) (so-long-restore-variable var))) (defun so-long-mode-maintain-preserved-minor-modes () - "Enable or disable 'preserved' minor modes. + "Enable or disable \"preserved\" minor modes. The modes are set in accordance with what was remembered in `so-long'." (dolist (mode (so-long-original 'so-long-mode-preserved-minor-modes)) diff --git a/lisp/vc/vc-svn.el b/lisp/vc/vc-svn.el index 3cf692bfdaa..270877041aa 100644 --- a/lisp/vc/vc-svn.el +++ b/lisp/vc/vc-svn.el @@ -212,7 +212,7 @@ switches." (autoload 'vc-expand-dirs "vc") (defun vc-svn-dir-status-files (_dir files callback) - "Run 'svn status' for DIR and update BUFFER via CALLBACK. + "Run \"svn status\" for DIR and update BUFFER via CALLBACK. CALLBACK is called as (CALLBACK RESULT BUFFER), where RESULT is a list of conses (FILE . STATE) for directory DIR." ;; FIXME shouldn't this rather default to all the files in dir? -- cgit v1.2.3 From 73e75e18d170826e1838324d39ac0698948071f8 Mon Sep 17 00:00:00 2001 From: Mattias Engdegård Date: Fri, 17 Jun 2022 17:06:05 +0200 Subject: Warn about misplaced or duplicated function/macro declarations Doc strings, `declare` and `interactive` forms must appear in that order and at most once each. Complain if they don't, instead of silently ignoring the problem (bug#55905). * lisp/emacs-lisp/byte-run.el (byte-run--parse-body) (byte-run--parse-declarations): New. (defmacro, defun): Check for declaration well-formedness as described above. Clarify doc strings. Refactor some common code. * test/lisp/emacs-lisp/bytecomp-resources/fun-attr-warn.el: * test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-fun-attr-warn): New test. --- lisp/emacs-lisp/byte-run.el | 208 +++++++++------- .../emacs-lisp/bytecomp-resources/fun-attr-warn.el | 266 +++++++++++++++++++++ test/lisp/emacs-lisp/bytecomp-tests.el | 63 +++++ 3 files changed, 446 insertions(+), 91 deletions(-) create mode 100644 test/lisp/emacs-lisp/bytecomp-resources/fun-attr-warn.el (limited to 'lisp/emacs-lisp/byte-run.el') diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 92c2699c6e3..17c15549666 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -272,6 +272,75 @@ This is used by `declare'.") (list 'function-put (list 'quote name) ''no-font-lock-keyword (list 'quote val)))) +(defalias 'byte-run--parse-body + #'(lambda (body allow-interactive) + "Decompose BODY into (DOCSTRING DECLARE INTERACTIVE BODY-REST WARNINGS)." + (let* ((top body) + (docstring nil) + (declare-form nil) + (interactive-form nil) + (warnings nil) + (warn #'(lambda (msg form) + (push (macroexp-warn-and-return msg nil nil t form) + warnings)))) + (while + (and body + (let* ((form (car body)) + (head (car-safe form))) + (cond + ((or (and (stringp form) (cdr body)) + (eq head :documentation)) + (cond + (docstring (funcall warn "More than one doc string" top)) + (declare-form + (funcall warn "Doc string after `declare'" declare-form)) + (interactive-form + (funcall warn "Doc string after `interactive'" + interactive-form)) + (t (setq docstring form))) + t) + ((eq head 'declare) + (cond + (declare-form + (funcall warn "More than one `declare' form" form)) + (interactive-form + (funcall warn "`declare' after `interactive'" form)) + (t (setq declare-form form))) + t) + ((eq head 'interactive) + (cond + ((not allow-interactive) + (funcall warn "No `interactive' form allowed here" form)) + (interactive-form + (funcall warn "More than one `interactive' form" form)) + (t (setq interactive-form form))) + t)))) + (setq body (cdr body))) + (list docstring declare-form interactive-form body warnings)))) + +(defalias 'byte-run--parse-declarations + #'(lambda (name arglist clauses construct declarations-alist) + (let* ((cl-decls nil) + (actions + (mapcar + #'(lambda (x) + (let ((f (cdr (assq (car x) declarations-alist)))) + (cond + (f (apply (car f) name arglist (cdr x))) + ;; Yuck!! + ((and (featurep 'cl) + (memq (car x) ;C.f. cl--do-proclaim. + '(special inline notinline optimize warn))) + (push (list 'declare x) cl-decls) + nil) + (t + (macroexp-warn-and-return + (format-message "Unknown %s property `%S'" + construct (car x)) + nil nil nil (car x)))))) + clauses))) + (cons actions cl-decls)))) + (defvar macro-declarations-alist (cons (list 'debug #'byte-run--set-debug) @@ -289,7 +358,7 @@ This is used by `declare'.") (defalias 'defmacro (cons 'macro - #'(lambda (name arglist &optional docstring &rest body) + #'(lambda (name arglist &rest body) "Define NAME as a macro. When the macro is called, as in (NAME ARGS...), the function (lambda ARGLIST BODY...) is applied to @@ -300,116 +369,73 @@ DECLS is a list of elements of the form (PROP . VALUES). These are interpreted according to `macro-declarations-alist'. The return value is undefined. -\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)" - ;; We can't just have `decl' as an &optional argument, because we need - ;; to distinguish - ;; (defmacro foo (arg) (bar) nil) - ;; from - ;; (defmacro foo (arg) (bar)). - (let ((decls (cond - ((eq (car-safe docstring) 'declare) - (prog1 (cdr docstring) (setq docstring nil))) - ((and (stringp docstring) - (eq (car-safe (car body)) 'declare)) - (prog1 (cdr (car body)) (setq body (cdr body))))))) - (if docstring (setq body (cons docstring body)) - (if (null body) (setq body '(nil)))) - ;; Can't use backquote because it's not defined yet! - (let* ((fun (list 'function (cons 'lambda (cons arglist body)))) - (def (list 'defalias - (list 'quote name) - (list 'cons ''macro fun))) - (declarations - (mapcar - #'(lambda (x) - (let ((f (cdr (assq (car x) macro-declarations-alist)))) - (if f (apply (car f) name arglist (cdr x)) - (macroexp-warn-and-return - (format-message - "Unknown macro property %S in %S" - (car x) name) - nil nil nil (car x))))) - decls))) - ;; Refresh font-lock if this is a new macro, or it is an - ;; existing macro whose 'no-font-lock-keyword declaration - ;; has changed. - (if (and - ;; If lisp-mode hasn't been loaded, there's no reason - ;; to flush. - (fboundp 'lisp--el-font-lock-flush-elisp-buffers) - (or (not (fboundp name)) ;; new macro - (and (fboundp name) ;; existing macro - (member `(function-put ',name 'no-font-lock-keyword - ',(get name 'no-font-lock-keyword)) - declarations)))) - (lisp--el-font-lock-flush-elisp-buffers)) - (if declarations - (cons 'prog1 (cons def declarations)) +\(fn NAME ARGLIST [DOCSTRING] [DECL] BODY...)" + (let* ((parse (byte-run--parse-body body nil)) + (docstring (nth 0 parse)) + (declare-form (nth 1 parse)) + (body (nth 3 parse)) + (warnings (nth 4 parse)) + (declarations + (and declare-form (byte-run--parse-declarations + name arglist (cdr declare-form) 'macro + macro-declarations-alist)))) + (setq body (nconc warnings body)) + (setq body (nconc (cdr declarations) body)) + (if docstring + (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)))) + (if declarations + (cons 'prog1 (cons def (car declarations))) def)))))) ;; Now that we defined defmacro we can use it! -(defmacro defun (name arglist &optional docstring &rest body) +(defmacro defun (name arglist &rest body) "Define NAME as a function. -The definition is (lambda ARGLIST [DOCSTRING] BODY...). -See also the function `interactive'. +The definition is (lambda ARGLIST [DOCSTRING] [INTERACTIVE] BODY...). DECL is a declaration, optional, of the form (declare DECLS...) where DECLS is a list of elements of the form (PROP . VALUES). These are interpreted according to `defun-declarations-alist'. +INTERACTIVE is an optional `interactive' specification. The return value is undefined. -\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)" - ;; We can't just have `decl' as an &optional argument, because we need - ;; to distinguish - ;; (defun foo (arg) (toto) nil) - ;; from - ;; (defun foo (arg) (toto)). +\(fn NAME ARGLIST [DOCSTRING] [DECL] [INTERACTIVE] BODY...)" (declare (doc-string 3) (indent 2)) (or name (error "Cannot define '%s' as a function" name)) (if (null (and (listp arglist) (null (delq t (mapcar #'symbolp arglist))))) (error "Malformed arglist: %s" arglist)) - (let ((decls (cond - ((eq (car-safe docstring) 'declare) - (prog1 (cdr docstring) (setq docstring nil))) - ((and (stringp docstring) - (eq (car-safe (car body)) 'declare)) - (prog1 (cdr (car body)) (setq body (cdr body))))))) - (if docstring (setq body (cons docstring body)) - (if (null body) (setq body '(nil)))) - (let ((declarations - (mapcar - #'(lambda (x) - (let ((f (cdr (assq (car x) defun-declarations-alist)))) - (cond - (f (apply (car f) name arglist (cdr x))) - ;; Yuck!! - ((and (featurep 'cl) - (memq (car x) ;C.f. cl-do-proclaim. - '(special inline notinline optimize warn))) - (push (list 'declare x) - (if (stringp docstring) - (if (eq (car-safe (cadr body)) 'interactive) - (cddr body) - (cdr body)) - (if (eq (car-safe (car body)) 'interactive) - (cdr body) - body))) - nil) - (t - (macroexp-warn-and-return - (format-message "Unknown defun property `%S' in %S" - (car x) name) - nil nil nil (car x)))))) - decls)) - (def (list 'defalias + (let* ((parse (byte-run--parse-body body t)) + (docstring (nth 0 parse)) + (declare-form (nth 1 parse)) + (interactive-form (nth 2 parse)) + (body (nth 3 parse)) + (warnings (nth 4 parse)) + (declarations + (and declare-form (byte-run--parse-declarations + name arglist (cdr declare-form) 'defun + defun-declarations-alist)))) + (setq body (nconc warnings body)) + (setq body (nconc (cdr declarations) body)) + (if interactive-form + (setq body (cons interactive-form body))) + (if docstring + (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)))))) (if declarations - (cons 'prog1 (cons def declarations)) - def)))) + (cons 'prog1 (cons def (car declarations))) + def)))) ;; Redefined in byte-opt.el. diff --git a/test/lisp/emacs-lisp/bytecomp-resources/fun-attr-warn.el b/test/lisp/emacs-lisp/bytecomp-resources/fun-attr-warn.el new file mode 100644 index 00000000000..be907b32f47 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/fun-attr-warn.el @@ -0,0 +1,266 @@ +;;; -*- lexical-binding: t -*- + +;; Correct + +(defun faw-str-decl-code (x) + "something" + (declare (pure t)) + (print x)) + +(defun faw-doc-decl-code (x) + (:documentation "something") + (declare (pure t)) + (print x)) + +(defun faw-str-int-code (x) + "something" + (interactive "P") + (print x)) + +(defun faw-doc-int-code (x) + (:documentation "something") + (interactive "P") + (print x)) + +(defun faw-decl-int-code (x) + (declare (pure t)) + (interactive "P") + (print x)) + +(defun faw-str-decl-int-code (x) + "something" + (declare (pure t)) + (interactive "P") + (print x)) + +(defun faw-doc-decl-int-code (x) + (:documentation "something") + (declare (pure t)) + (interactive "P") + (print x)) + + +;; Correct (last string is return value) + +(defun faw-str () + "something") + +(defun faw-decl-str () + (declare (pure t)) + "something") + +(defun faw-decl-int-str () + (declare (pure t)) + (interactive) + "something") + +(defun faw-str-str () + "something" + "something else") + +(defun faw-doc-str () + (:documentation "something") + "something else") + + +;; Incorrect (bad order) + +(defun faw-int-decl-code (x) + (interactive "P") + (declare (pure t)) + (print x)) + +(defun faw-int-str-code (x) + (interactive "P") + "something" + (print x)) + +(defun faw-int-doc-code (x) + (interactive "P") + (:documentation "something") + (print x)) + +(defun faw-decl-str-code (x) + (declare (pure t)) + "something" + (print x)) + +(defun faw-decl-doc-code (x) + (declare (pure t)) + (:documentation "something") + (print x)) + +(defun faw-str-int-decl-code (x) + "something" + (interactive "P") + (declare (pure t)) + (print x)) + +(defun faw-doc-int-decl-code (x) + (:documentation "something") + (interactive "P") + (declare (pure t)) + (print x)) + +(defun faw-int-str-decl-code (x) + (interactive "P") + "something" + (declare (pure t)) + (print x)) + +(defun faw-int-doc-decl-code (x) + (interactive "P") + (:documentation "something") + (declare (pure t)) + (print x)) + +(defun faw-int-decl-str-code (x) + (interactive "P") + (declare (pure t)) + "something" + (print x)) + +(defun faw-int-decl-doc-code (x) + (interactive "P") + (declare (pure t)) + (:documentation "something") + (print x)) + +(defun faw-decl-int-str-code (x) + (declare (pure t)) + (interactive "P") + "something" + (print x)) + +(defun faw-decl-int-doc-code (x) + (declare (pure t)) + (interactive "P") + (:documentation "something") + (print x)) + +(defun faw-decl-str-int-code (x) + (declare (pure t)) + "something" + (interactive "P") + (print x)) + +(defun faw-decl-doc-int-code (x) + (declare (pure t)) + (:documentation "something") + (interactive "P") + (print x)) + + +;; Incorrect (duplication) + +(defun faw-str-str-decl-int-code (x) + "something" + "something else" + (declare (pure t)) + (interactive "P") + (print x)) + +(defun faw-str-doc-decl-int-code (x) + "something" + (:documentation "something else") + (declare (pure t)) + (interactive "P") + (print x)) + +(defun faw-doc-str-decl-int-code (x) + (:documentation "something") + "something else" + (declare (pure t)) + (interactive "P") + (print x)) + +(defun faw-doc-doc-decl-int-code (x) + (:documentation "something") + (:documentation "something else") + (declare (pure t)) + (interactive "P") + (print x)) + +(defun faw-str-decl-str-int-code (x) + "something" + (declare (pure t)) + "something else" + (interactive "P") + (print x)) + +(defun faw-doc-decl-str-int-code (x) + (:documentation "something") + (declare (pure t)) + "something else" + (interactive "P") + (print x)) + +(defun faw-str-decl-doc-int-code (x) + "something" + (declare (pure t)) + (:documentation "something else") + (interactive "P") + (print x)) + +(defun faw-doc-decl-doc-int-code (x) + (:documentation "something") + (declare (pure t)) + (:documentation "something else") + (interactive "P") + (print x)) + +(defun faw-str-decl-decl-int-code (x) + "something" + (declare (pure t)) + (declare (indent 1)) + (interactive "P") + (print x)) + +(defun faw-doc-decl-decl-int-code (x) + (:documentation "something") + (declare (pure t)) + (declare (indent 1)) + (interactive "P") + (print x)) + +(defun faw-str-decl-int-decl-code (x) + "something" + (declare (pure t)) + (interactive "P") + (declare (indent 1)) + (print x)) + +(defun faw-doc-decl-int-decl-code (x) + (:documentation "something") + (declare (pure t)) + (interactive "P") + (declare (indent 1)) + (print x)) + +(defun faw-str-decl-int-int-code (x) + "something" + (declare (pure t)) + (interactive "P") + (interactive "p") + (print x)) + +(defun faw-doc-decl-int-int-code (x) + (:documentation "something") + (declare (pure t)) + (interactive "P") + (interactive "p") + (print x)) + +(defun faw-str-int-decl-int-code (x) + "something" + (interactive "P") + (declare (pure t)) + (interactive "p") + (print x)) + +(defun faw-doc-int-decl-int-code (x) + (:documentation "something") + (interactive "P") + (declare (pure t)) + (interactive "p") + (print x)) diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 9abc17a1c41..fbc00b30c54 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -1580,6 +1580,69 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \ (should (equal (get fname 'lisp-indent-function) 1)) (should (equal (aref bc 4) "tata\n\n(fn X)"))))) +(ert-deftest bytecomp-fun-attr-warn () + ;; Check that warnings are emitted when doc strings, `declare' and + ;; `interactive' forms don't come in the proper order, or more than once. + (let* ((filename "fun-attr-warn.el") + (el (ert-resource-file filename)) + (elc (concat el "c")) + (text-quoting-style 'grave)) + (with-current-buffer (get-buffer-create "*Compile-Log*") + (let ((inhibit-read-only t)) + (erase-buffer)) + (byte-compile-file el) + (let ((expected + '("70:4: Warning: `declare' after `interactive'" + "74:4: Warning: Doc string after `interactive'" + "79:4: Warning: Doc string after `interactive'" + "84:4: Warning: Doc string after `declare'" + "89:4: Warning: Doc string after `declare'" + "96:4: Warning: `declare' after `interactive'" + "102:4: Warning: `declare' after `interactive'" + "108:4: Warning: `declare' after `interactive'" + "106:4: Warning: Doc string after `interactive'" + "114:4: Warning: `declare' after `interactive'" + "112:4: Warning: Doc string after `interactive'" + "118:4: Warning: Doc string after `interactive'" + "119:4: Warning: `declare' after `interactive'" + "124:4: Warning: Doc string after `interactive'" + "125:4: Warning: `declare' after `interactive'" + "130:4: Warning: Doc string after `declare'" + "136:4: Warning: Doc string after `declare'" + "142:4: Warning: Doc string after `declare'" + "148:4: Warning: Doc string after `declare'" + "159:4: Warning: More than one doc string" + "165:4: Warning: More than one doc string" + "171:4: Warning: More than one doc string" + "178:4: Warning: More than one doc string" + "186:4: Warning: More than one doc string" + "192:4: Warning: More than one doc string" + "200:4: Warning: More than one doc string" + "206:4: Warning: More than one doc string" + "215:4: Warning: More than one `declare' form" + "222:4: Warning: More than one `declare' form" + "230:4: Warning: More than one `declare' form" + "237:4: Warning: More than one `declare' form" + "244:4: Warning: More than one `interactive' form" + "251:4: Warning: More than one `interactive' form" + "258:4: Warning: More than one `interactive' form" + "257:4: Warning: `declare' after `interactive'" + "265:4: Warning: More than one `interactive' form" + "264:4: Warning: `declare' after `interactive'"))) + (goto-char (point-min)) + (let ((actual nil)) + (while (re-search-forward + (rx bol (* (not ":")) ":" + (group (+ digit) ":" (+ digit) ": Warning: " + (or "More than one " (+ nonl) " form" + (: (+ nonl) " after " (+ nonl)))) + eol) + nil t) + (push (match-string 1) actual)) + (setq actual (nreverse actual)) + (should (equal actual expected))))))) + + ;; Local Variables: ;; no-byte-compile: t ;; End: -- cgit v1.2.3 From a53c34d76a09cd6519d2d176b76d4b820bc26a51 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 17 Jun 2022 18:12:38 +0200 Subject: Don't quote the `when' form in obsoletions * lisp/emacs-lisp/byte-run.el (byte-run--set-obsolete): The `when' is a string (or nil), so don't quote it (bug#48145). * lisp/emacs-lisp/loaddefs-gen.el (loaddefs-generate--print-form): Adjust folding. --- lisp/emacs-lisp/byte-run.el | 2 +- lisp/emacs-lisp/loaddefs-gen.el | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp/byte-run.el') diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 17c15549666..498435c58d0 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -166,7 +166,7 @@ The return value of this function is not used." (defalias 'byte-run--set-obsolete #'(lambda (f _args new-name when) (list 'make-obsolete - (list 'quote f) (list 'quote new-name) (list 'quote when)))) + (list 'quote f) (list 'quote new-name) when))) (defalias 'byte-run--set-interactive-only #'(lambda (f _args instead) diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index 86c776e3013..a686de406ab 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -633,6 +633,7 @@ If GENERATE-FULL, don't update, but regenerate all the loaddefs files." "Print DEF in the way make-docfile.c expects it." (if (or (not (consp def)) (not (symbolp (car def))) + (eq (car def) 'make-obsolete) (not (stringp (nth 3 def)))) (prin1 def (current-buffer) t) ;; The salient point here is that we have to have the doc string -- cgit v1.2.3 From f515d658e5e5382bfbcf835dee4a32099c9815e6 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 17 Jun 2022 19:10:44 +0200 Subject: Don't quote numbers in byte-run--set-* * lisp/emacs-lisp/byte-run.el (byte-run--set-doc-string) (byte-run--set-indent): Don't quote numbers (bug#48145). --- lisp/emacs-lisp/byte-run.el | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp/byte-run.el') diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 498435c58d0..dd90bcf4d82 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -210,12 +210,16 @@ The return value of this function is not used." (defalias 'byte-run--set-doc-string #'(lambda (f _args pos) (list 'function-put (list 'quote f) - ''doc-string-elt (list 'quote pos)))) + ''doc-string-elt (if (numberp pos) + pos + (list 'quote pos))))) (defalias 'byte-run--set-indent #'(lambda (f _args val) (list 'function-put (list 'quote f) - ''lisp-indent-function (list 'quote val)))) + ''lisp-indent-function (if (numberp val) + val + (list 'quote val))))) (defalias 'byte-run--set-speed #'(lambda (f _args val) -- cgit v1.2.3 From 96926fa6eb0f71f47586d50ac5532b57bff1ab54 Mon Sep 17 00:00:00 2001 From: Mattias Engdegård Date: Sat, 23 Jul 2022 18:42:11 +0200 Subject: Fix `lsh` warning shortcomings (bug#56641) Reported by Basil Contovounesios. * etc/NEWS: Mention how to suppress the warning. * lisp/emacs-lisp/byte-run.el (with-suppressed-warnings): Amend doc string. * lisp/subr.el: Use `macroexp-warn-and-return` to delay the warning until codegen time (which makes it suppressible) and to prevent repeated warnings. * test/lisp/international/ccl-tests.el (shift): * test/src/data-tests.el (data-tests-ash-lsh): Suppress warning in tests of `lsh` itself. --- etc/NEWS | 4 +++- lisp/emacs-lisp/byte-run.el | 2 +- lisp/subr.el | 5 ++--- test/lisp/international/ccl-tests.el | 36 +++++++++++++++++++----------------- test/src/data-tests.el | 13 +++++++------ 5 files changed, 32 insertions(+), 28 deletions(-) (limited to 'lisp/emacs-lisp/byte-run.el') diff --git a/etc/NEWS b/etc/NEWS index 412a93bbf99..27046894ad4 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2336,7 +2336,9 @@ It's been obsolete since Emacs-22.1, actually. ** Calling 'lsh' now elicits a byte-compiler warning. 'lsh' behaves in somewhat surprising and platform-dependent ways for negative arguments, and is generally slower than 'ash', which should be -used instead. +used instead. This warning can be suppressed by surrounding calls to +'lsh' with the construct '(with-suppressed-warnings ((suspicious lsh)) ...)', +but switching to `ash` is generally much preferable. --- ** Some functions and variables obsolete since Emacs 24 have been removed: diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index dd90bcf4d82..9370bd3a097 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -672,7 +672,7 @@ types. The types that can be suppressed with this macro are `suspicious'. For the `mapcar' case, only the `mapcar' function can be used in -the symbol list. For `suspicious', only `set-buffer' can be used." +the symbol list. For `suspicious', only `set-buffer' and `lsh' can be used." ;; Note: during compilation, this definition is overridden by the one in ;; byte-compile-initial-macro-environment. (declare (debug (sexp body)) (indent 1)) diff --git a/lisp/subr.el b/lisp/subr.el index 06da5e28730..a0ad967533d 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -530,9 +530,8 @@ This function is provided for compatibility. In new code, use `ash' instead." (declare (compiler-macro (lambda (form) - (when (byte-compile-warning-enabled-p 'suspicious 'lsh) - (byte-compile-warn-x form "avoid `lsh'; use `ash' instead")) - form))) + (macroexp-warn-and-return "avoid `lsh'; use `ash' instead" + form '(suspicious lsh) t form)))) (when (and (< value 0) (< count 0)) (when (< value most-negative-fixnum) (signal 'args-out-of-range (list value count))) diff --git a/test/lisp/international/ccl-tests.el b/test/lisp/international/ccl-tests.el index 57ac74639b1..cf472415c7a 100644 --- a/test/lisp/international/ccl-tests.el +++ b/test/lisp/international/ccl-tests.el @@ -25,23 +25,25 @@ (ert-deftest shift () - ;; shift left +ve 5628 #x00000000000015fc - (should (= (ash 5628 8) 1440768)) ; #x000000000015fc00 - (should (= (lsh 5628 8) 1440768)) ; #x000000000015fc00 - - ;; shift left -ve -5628 #x3fffffffffffea04 - (should (= (ash -5628 8) -1440768)) ; #x3fffffffffea0400 - (should (= (lsh -5628 8) -1440768)) ; #x3fffffffffea0400 - - ;; shift right +ve 5628 #x00000000000015fc - (should (= (ash 5628 -8) 21)) ; #x0000000000000015 - (should (= (lsh 5628 -8) 21)) ; #x0000000000000015 - - ;; shift right -ve -5628 #x3fffffffffffea04 - (should (= (ash -5628 -8) -22)) ; #x3fffffffffffffea - (should (= (lsh -5628 -8) - (ash (- -5628 (ash most-negative-fixnum 1)) -8) - (ash (logand (ash -5628 -1) most-positive-fixnum) -7)))) + (with-suppressed-warnings ((suspicious lsh)) + + ;; shift left +ve 5628 #x00000000000015fc + (should (= (ash 5628 8) 1440768)) ; #x000000000015fc00 + (should (= (lsh 5628 8) 1440768)) ; #x000000000015fc00 + + ;; shift left -ve -5628 #x3fffffffffffea04 + (should (= (ash -5628 8) -1440768)) ; #x3fffffffffea0400 + (should (= (lsh -5628 8) -1440768)) ; #x3fffffffffea0400 + + ;; shift right +ve 5628 #x00000000000015fc + (should (= (ash 5628 -8) 21)) ; #x0000000000000015 + (should (= (lsh 5628 -8) 21)) ; #x0000000000000015 + + ;; shift right -ve -5628 #x3fffffffffffea04 + (should (= (ash -5628 -8) -22)) ; #x3fffffffffffffea + (should (= (lsh -5628 -8) + (ash (- -5628 (ash most-negative-fixnum 1)) -8) + (ash (logand (ash -5628 -1) most-positive-fixnum) -7))))) ;; CCl program from `pgg-parse-crc24' in lisp/obsolete/pgg-parse.el (defconst prog-pgg-source diff --git a/test/src/data-tests.el b/test/src/data-tests.el index 7ce2995e562..0f84b2fb776 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -741,14 +741,15 @@ comparing the subr with a much slower Lisp implementation." (should (= (ash 1000 (* 2 most-negative-fixnum)) 0)) (should (= (ash -1000 (* 2 most-negative-fixnum)) -1)) (should (= (ash (* 2 most-negative-fixnum) (* 2 most-negative-fixnum)) -1)) - (should (= (lsh most-negative-fixnum 1) - (* most-negative-fixnum 2))) (should (= (ash (* 2 most-negative-fixnum) -1) most-negative-fixnum)) - (should (= (lsh most-positive-fixnum -1) (/ most-positive-fixnum 2))) - (should (= (lsh most-negative-fixnum -1) (lsh (- most-negative-fixnum) -1))) - (should (= (lsh -1 -1) most-positive-fixnum)) - (should-error (lsh (1- most-negative-fixnum) -1))) + (with-suppressed-warnings ((suspicious lsh)) + (should (= (lsh most-negative-fixnum 1) + (* most-negative-fixnum 2))) + (should (= (lsh most-positive-fixnum -1) (/ most-positive-fixnum 2))) + (should (= (lsh most-negative-fixnum -1) (lsh (- most-negative-fixnum) -1))) + (should (= (lsh -1 -1) most-positive-fixnum)) + (should-error (lsh (1- most-negative-fixnum) -1)))) (ert-deftest data-tests-make-local-forwarded-var () ;bug#34318 ;; Boy, this bug is tricky to trigger. You need to: -- cgit v1.2.3