[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/positioned-lambdas a8b497cf987: Initial commit to branch feature
|
From: |
Alan Mackenzie |
|
Subject: |
feature/positioned-lambdas a8b497cf987: Initial commit to branch feature/positioned-lambdas |
|
Date: |
Mon, 4 Dec 2023 12:17:47 -0500 (EST) |
branch: feature/positioned-lambdas
commit a8b497cf98721775e45d8e35434d88f8636768f0
Author: Alan Mackenzie <acm@muc.de>
Commit: Alan Mackenzie <acm@muc.de>
Initial commit to branch feature/positioned-lambdas
This is the first step in implementing bug#67455.
The new code records in the doc string the "defining symbol" of
each function/lambda/variable/etc., and its source file name
and its position within that file. For lambda forms, it also
records the position of the lambda. This mechanism does not
yet work for interpreted functions, only compiled ones.
* lisp/emacs-lisp/byte-opt.el (byte-optimize-one-form): Push
FORM onto byte-compile-form-stack to improve diagnostics.
* lisp/emacs-lisp/byte-run.el (byte-run-posify-doc-string): New
function.
(byte-run--set-defining-symbol): New function.
(byte-run--parse-body): When there is just a string in a
defun/lambda, treat it as both the doc string and return value.
(byte-run--parse-declarations): For defining-symbol and other
declare symbols with the pre-form symbol property, push the
code onto the front of the function not the rear.
(macro-declarations-alist): Add defining-symbol to this alist.
(defmacro): Add code to set defining-symbol to the macro name
being defined. Add this name's details to the doc string.
Ensure there cannot be an empty body - use '(nil) in this case.
(defun): Add a defining-symbol declare form. Add the new
name's details to the doc string. Ensure there cannot be an
empty body - use '(nil) in this case.
* lisp/emacs-lisp/bytecomp.el (byte-compile-recurse-toplevel)
(compile-defun, byte-compile-from-buffer, byte-compile)
(byte-compile-file-form-defvar): Bind defining-symbol around
the compiling code.
(byte-compile-docstring-style-warn): Strip the new position
information from a doc string before using it.
(byte-compile-file-form-defvar): Add position information to
the new variable.
(byte-compile-make-closure): Preserve the symbol position in
internal-make-closure by moving it to the newly created lambda
symbol.
* lisp/emacs-lisp/cconv.el (cconv--convert-function): Add a new
&optional parameter lambda-token which will carry a symbol
position from the caller. Use this position in the output
lambda or internal-make-closure form.
(cconv-convert): Use the (positioned) lambda token in the
created body form, and pass it to cconv--convert-function.
* lisp/emacs-lisp/cl-generic.el (cl-defgeneric)
(cl-generic-define-context-rewriter, cl-defmethod): Add
defining-symbol declare forms.
(cl--generic-method-info): Remove position information from doc
strings before using them.
* lisp/emacs-lisp/macroexp.el (macroexpand-1): Add special
handling for the symbol lambda, so that its "expansion"
preserves the symbol's position.
* lisp/emacs-lisp/nadvice.el (advice--equal): New function.
(advice--member-p, advice--remove-function): Use advice--equal
rather than equal to compare two functions.
* lisp/help.el (help-strip-pos-info): New function.
(help-split-fundoc): Remove any position info before further
processing.
(help-add-fundoc-usage): Handle the presence of position info.
* lisp/progmodes/elisp-mode.el (elisp--xref-find-definitions):
Remove any position information before testing a doc string for
being empty.
(elisp--eval-last-sexp): Bind defining-symbol to nil around the
evaluation in preparation for the next stage of the bug's
implementation.
* lisp/cedet/mode-local.el (defvar-mode-local)
(define-overloadable-function, define-mode-local-override)
lisp/cedet/semantic/idle.el (define-semantic-idle-service)
lisp/cedet/semantic/lex-spp.el
(define-lex-spp-macro-declaration-analyzer)
(define-lex-spp-macro-undeclaration-analyzer)
(define-lex-spp-include-analyzer)
lisp/cedet/semantic/lex.el (define-lex, define-lex-analyzer)
(define-lex-regex-analyzer, define-lex-simple-regex-analyzer)
(define-lex-block-analyzer)
lisp/cedet/semantic/wisent.el (define-wisent-lexer)
lisp/emacs-lisp/advice.el (defadvice)
lisp/emacs-lisp/bindat.el (bindat-defmacro)
lisp/emacs-lisp/cl-macs.el (cl-defun, cl-iter-defun)
(cl-defmacro, cl-defstruct, cl-define-compiler-macro)
lisp/emacs-lisp/derived.el (define-derived-mode)
lisp/emacs-lisp/easy-mmode.el (define-minor-mode)
lisp/emacs-lisp/ert.el (ert-deftest)
lisp/emacs-lisp/generator.el (iter-defun)
lisp/emacs-lisp/gv.el (gv-define-setter)
lisp/gnus/nnoo.el (deffoo)
lisp/mh-e/mh-acros.el (defun-mh, defmacro-mh)
lisp/obsolete/cl.el (define-setf-expander, defsetf)
(define-modify-macro)
lisp/obsolete/eieio-compat.el (defmethod)
lisp/progmodes/cc-defs.el (c-lang-defconst)
lisp/progmodes/cc-langs.el (c-lang-defvar, c-lang-setvar)
lisp/skeleton.el (define-skeleton)
lisp/transient.el (transient-define-prefix)
(transient-define-suffix, transient-define-infix)
lisp/vc/pcvs.el (defun-cvs-mode): Add defining-symbol declare
forms.
* test/lisp/emacs-lisp/bytecomp-tests.el
(bytecomp-function-attributes)
test/lisp/emacs-lisp/cl-lib-tests.el
(cl-lib-struct-constructors): Strip position info before the
meat of the tests.
* src/doc.c (Fdocumentation): Strip position information before
returning the result.
* src/eval.c (Fmacroexpand): Add special handling for the
symbol lambda, so that its "expansion" preserves the symbol's
position.
* src/lread.c (readevalloop_eager_expand_eval)
(readevalloop): Bind defining-symbol to nil around processing
which might have a defun, etc.
(Qdefining_symbol): New symbol and variable.
---
lisp/cedet/mode-local.el | 3 ++
lisp/cedet/semantic/idle.el | 3 +-
lisp/cedet/semantic/lex-spp.el | 9 ++--
lisp/cedet/semantic/lex.el | 15 ++++--
lisp/cedet/semantic/wisent.el | 3 +-
lisp/emacs-lisp/advice.el | 1 +
lisp/emacs-lisp/bindat.el | 3 +-
lisp/emacs-lisp/byte-opt.el | 2 +
lisp/emacs-lisp/byte-run.el | 98 +++++++++++++++++++++++++++++++---
lisp/emacs-lisp/bytecomp.el | 50 ++++++++++-------
lisp/emacs-lisp/cconv.el | 17 +++---
lisp/emacs-lisp/cl-generic.el | 25 +++++++--
lisp/emacs-lisp/cl-macs.el | 14 +++--
lisp/emacs-lisp/derived.el | 3 +-
lisp/emacs-lisp/easy-mmode.el | 1 +
lisp/emacs-lisp/ert.el | 3 +-
lisp/emacs-lisp/generator.el | 1 +
lisp/emacs-lisp/gv.el | 1 +
lisp/emacs-lisp/macroexp.el | 33 +++++++++++-
lisp/emacs-lisp/nadvice.el | 69 +++++++++++++++++++++---
lisp/gnus/nnoo.el | 1 +
lisp/help.el | 33 ++++++++++--
lisp/mh-e/mh-acros.el | 2 +
lisp/obsolete/cl.el | 9 ++--
lisp/obsolete/eieio-compat.el | 1 +
lisp/progmodes/cc-defs.el | 1 +
lisp/progmodes/cc-langs.el | 4 +-
lisp/progmodes/elisp-mode.el | 7 ++-
lisp/skeleton.el | 3 +-
lisp/transient.el | 9 ++--
lisp/vc/pcvs.el | 3 +-
src/doc.c | 8 ++-
src/eval.c | 11 +++-
src/lread.c | 21 +++++++-
test/lisp/emacs-lisp/bytecomp-tests.el | 2 +-
test/lisp/emacs-lisp/cl-lib-tests.el | 3 +-
36 files changed, 388 insertions(+), 84 deletions(-)
diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el
index 4fb4460d4c6..978dedfea8d 100644
--- a/lisp/cedet/mode-local.el
+++ b/lisp/cedet/mode-local.el
@@ -417,6 +417,7 @@ Return the value of the last VAL."
"Define MODE local variable SYM with value VAL.
DOCSTRING is optional."
(declare (indent defun)
+ (defining-symbol 2)
(debug (&define symbolp name def-form [ &optional stringp ] )))
`(progn
(setq-mode-local ,mode ,sym ,val)
@@ -548,6 +549,7 @@ OVERARGS is a list of arguments passed to the override and
`NAME-default' function, in place of those deduced from ARGS."
(declare (doc-string 3)
(indent defun)
+ (defining-symbol 1)
(debug (&define name lambda-list stringp def-body)))
`(eval-and-compile
(defun ,name ,args
@@ -577,6 +579,7 @@ BODY is the implementation of this function."
;; FIXME: Make this obsolete and use cl-defmethod with &context instead.
(declare (doc-string 4)
(indent defun)
+ (defining-symbol 1)
(debug (&define name symbolp lambda-list stringp def-body)))
(let ((newname (intern (format "%s-%s" name mode))))
`(progn
diff --git a/lisp/cedet/semantic/idle.el b/lisp/cedet/semantic/idle.el
index 58f162e67f7..80a0adb9d6a 100644
--- a/lisp/cedet/semantic/idle.el
+++ b/lisp/cedet/semantic/idle.el
@@ -566,7 +566,8 @@ DOC will be a documentation string describing FORMS.
FORMS will be called during idle time after the current buffer's
semantic tag information has been updated.
This routine creates the following functions and variables:"
- (declare (indent 1) (debug (&define name stringp def-body)))
+ (declare (indent 1) (defining-symbol 1)
+ (debug (&define name stringp def-body)))
(let ((global (intern (concat "global-" (symbol-name name) "-mode")))
(mode (intern (concat (symbol-name name) "-mode")))
(hook (intern (concat (symbol-name name) "-mode-hook")))
diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el
index 35f09e7a784..04680ee2cd4 100644
--- a/lisp/cedet/semantic/lex-spp.el
+++ b/lisp/cedet/semantic/lex-spp.el
@@ -1163,7 +1163,8 @@ of type `spp-macro-def' is to be created.
VALFORM are forms that return the value to be saved for this macro, or nil.
When implementing a macro, you can use `semantic-lex-spp-stream-for-macro'
to convert text into a lexical stream for storage in the macro."
- (declare (debug (&define name stringp stringp form def-body))
+ (declare (defining-symbol 1)
+ (debug (&define name stringp stringp form def-body))
(indent 1))
(let ((start (make-symbol "start"))
(end (make-symbol "end"))
@@ -1198,7 +1199,8 @@ REGEXP is a regular expression for the analyzer to match.
See `define-lex-regex-analyzer' for more on regexp.
TOKIDX is an index into REGEXP for which a new lexical token
of type `spp-macro-undef' is to be created."
- (declare (debug (&define name stringp stringp form))
+ (declare (defining-symbol 1)
+ (debug (&define name stringp stringp form))
(indent 1))
(let ((start (make-symbol "start"))
(end (make-symbol "end")))
@@ -1260,7 +1262,8 @@ type of include. The return value should be of the form:
(NAME . TYPE)
where NAME is the name of the include, and TYPE is the type of the include,
where a valid symbol is `system', or nil."
- (declare (debug (&define name stringp stringp form def-body))
+ (declare (defining-symbol 1)
+ (debug (&define name stringp stringp form def-body))
(indent 1))
(let ((start (make-symbol "start"))
(end (make-symbol "end"))
diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el
index 5fd1fd45400..dd00dfc7138 100644
--- a/lisp/cedet/semantic/lex.el
+++ b/lisp/cedet/semantic/lex.el
@@ -757,7 +757,8 @@ If two analyzers can match the same text, it is important
to order the
analyzers so that the one you want to match first occurs first. For
example, it is good to put a number analyzer in front of a symbol
analyzer which might mistake a number for a symbol."
- (declare (debug (&define name stringp (&rest symbolp))) (indent 1))
+ (declare (defining-symbol 1)
+ (debug (&define name stringp (&rest symbolp))) (indent 1))
`(defun ,name (start end &optional depth length)
,(concat doc "\nSee `semantic-lex' for more information.")
;; Make sure the state of block parsing starts over.
@@ -1093,7 +1094,8 @@ Proper action in FORMS is to move the value of
`semantic-lex-end-point' to
after the location of the analyzed entry, and to add any discovered tokens
at the beginning of `semantic-lex-token-stream'.
This can be done by using `semantic-lex-push-token'."
- (declare (debug (&define name stringp form def-body)) (indent 1))
+ (declare (defining-symbol 1)
+ (debug (&define name stringp form def-body)) (indent 1))
`(eval-and-compile
;; This is the real info used by `define-lex' (via
semantic-lex-one-token).
(defconst ,name '(,condition ,@forms) ,doc)
@@ -1115,7 +1117,8 @@ This can be done by using `semantic-lex-push-token'."
"Create a lexical analyzer with NAME and DOC that will match REGEXP.
FORMS are evaluated upon a successful match.
See `define-lex-analyzer' for more about analyzers."
- (declare (debug (&define name stringp form def-body)) (indent 1))
+ (declare (defining-symbol 1)
+ (debug (&define name stringp form def-body)) (indent 1))
`(define-lex-analyzer ,name
,doc
(looking-at ,regexp)
@@ -1133,7 +1136,8 @@ expression.
FORMS are evaluated upon a successful match BEFORE the new token is
created. It is valid to ignore FORMS.
See `define-lex-analyzer' for more about analyzers."
- (declare (debug
+ (declare (defining-symbol 1)
+ (debug
(&define name stringp form symbolp [ &optional form ] def-body))
(indent 1))
`(define-lex-analyzer ,name
@@ -1160,7 +1164,8 @@ where BLOCK-SYM is the symbol returned in a block token.
OPEN-DELIM
and CLOSE-DELIM are respectively the open and close delimiters
identifying a block. OPEN-SYM and CLOSE-SYM are respectively the
symbols returned in open and close tokens."
- (declare (debug (&define name stringp form (&rest form)))
+ (declare (defining-symbol 1)
+ (debug (&define name stringp form (&rest form)))
(indent 1))
(let ((specs (cons spec1 specs))
spec open olist clist)
diff --git a/lisp/cedet/semantic/wisent.el b/lisp/cedet/semantic/wisent.el
index d135adf4d3b..5378aba4fba 100644
--- a/lisp/cedet/semantic/wisent.el
+++ b/lisp/cedet/semantic/wisent.el
@@ -66,7 +66,8 @@ Returned tokens must have the form:
(TOKSYM VALUE START . END)
where VALUE is the buffer substring between START and END positions."
- (declare (debug (&define name stringp def-body)) (indent 1))
+ (declare (defining-symbol 1)
+ (debug (&define name stringp def-body)) (indent 1))
`(defun
,name () ,doc
(cond
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el
index a6974e07cb2..78e0151542f 100644
--- a/lisp/emacs-lisp/advice.el
+++ b/lisp/emacs-lisp/advice.el
@@ -3129,6 +3129,7 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION]
[ARGLIST] FLAG...)
BODY...)"
(declare (doc-string 3) (indent 2)
(obsolete "use `advice-add' or `define-advice'" "30.1")
+ (defining-symbol (cadr args))
(debug (&define name ;; thing being advised.
(name ;; class is [&or "before" "around" "after"
;; "activation" "deactivation"]
diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el
index 6f2af7f975b..7e495536207 100644
--- a/lisp/emacs-lisp/bindat.el
+++ b/lisp/emacs-lisp/bindat.el
@@ -905,7 +905,8 @@ a bindat type expression."
(defmacro bindat-defmacro (name args &rest body)
"Define a new Bindat type as a macro."
- (declare (indent 2) (doc-string 3) (debug (&define name sexp def-body)))
+ (declare (indent 2) (doc-string 3) (debug (&define name sexp def-body))
+ (defining-symbol 1))
(let ((leaders ()))
(while (and (cdr body)
(or (stringp (car body))
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 7a61a8fce7e..ea818328000 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -510,6 +510,7 @@ There can be multiple entries for the same NAME if it has
several aliases.")
(byte-optimize-form form for-effect)))
(defun byte-optimize-form (form &optional for-effect)
+ (push form byte-compile-form-stack)
(while
(progn
;; First, optimize all sub-forms of this one.
@@ -526,6 +527,7 @@ There can be multiple entries for the same NAME if it has
several aliases.")
(byte-compile-log " %s\t==>\t%s" old new)
(setq form new)
(not (eq new old))))))))
+ (pop byte-compile-form-stack)
form)
(defun byte-optimize--rename-var-body (var new-var body)
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 3e4e4d12cc8..dd286ffee81 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -100,6 +100,56 @@ record, containing symbols with position."
(byte-run--strip-vector/record arg))
(t arg))))
+(defalias 'byte-run-posify-doc-string
+ #'(lambda (doc-string &optional lambda-token)
+ "Prefix a doc string with defining position information.
+DOC-STRING is the existing doc string, or if nil, the new doc
+string is created from scratch.
+LAMBDA-TOKEN when non-nil is the symbol `lambda' for which the new
+doc string is being created. It should be a symbol with position."
+ (let ((pos-string
+ (concat
+ ";POS"
+ ;; (let ((version ; See comments in `byte-compile-insert-header'.
+ ;; (if (zerop emacs-minor-version)
+ ;; (1- emacs-major-version)
+ ;; emacs-major-version));)
+ "\036" ; Hard coded version 30, for now. FIXME!!!
+ ;; (cl-assert (and (> version 13) (< version 128)))
+ ;; (string version))
+ "\000\000\000 ["
+ (if defining-symbol
+ (symbol-name (bare-symbol defining-symbol))
+ "nil")
+ " "
+ (let* ((cur-buf
+ (or (and (boundp 'byte-compile-current-buffer)
+ byte-compile-current-buffer)
+ (current-buffer)))
+ (cur-file-name
+ (or (and (boundp 'byte-compile-current-file)
+ (if (bufferp byte-compile-current-file)
+ (buffer-name byte-compile-current-file)
+ byte-compile-current-file))
+ (buffer-file-name (current-buffer)))))
+ (cond
+ (cur-file-name)
+ (cur-buf (buffer-name cur-buf))
+ (t ; ?minibuffer
+ "nil")))
+ " "
+ (if (symbol-with-pos-p defining-symbol)
+ (format "%d" (symbol-with-pos-pos defining-symbol))
+ "nil")
+ " "
+ (if (symbol-with-pos-p lambda-token)
+ (format "%d" (symbol-with-pos-pos lambda-token))
+ "nil")
+ "]\n")))
+ (if doc-string
+ (concat pos-string doc-string)
+ pos-string))))
+
(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
@@ -217,6 +267,15 @@ So far, FUNCTION can only be a symbol, not a lambda
expression."
(cadr elem)))
val)))))
+(defalias 'byte-run--set-defining-symbol
+ #'(lambda (_name args &rest def-sym-poses)
+ (list 'if '(null defining-symbol)
+ (list 'setq 'defining-symbol
+ (if (numberp (car def-sym-poses))
+ (nth (1- (car def-sym-poses)) args)
+ (car def-sym-poses))))))
+(put 'byte-run--set-defining-symbol 'pre-form t)
+
;; Add any new entries to info node `(elisp)Declare Form'.
(defvar defun-declarations-alist
(list
@@ -277,6 +336,10 @@ This is used by `declare'.")
(let* ((form (car body))
(head (car-safe form)))
(cond
+ ((and (stringp form) (null (cdr body)))
+ ;; The doc string is also the defun's return value.
+ (setq docstring form)
+ nil) ; Don't remove the doc string from BODY.
((or (and (stringp form) (cdr body))
(eq head :documentation))
(cond
@@ -315,6 +378,11 @@ This is used by `declare'.")
#'(lambda (x)
(let ((f (cdr (assq (car x) declarations-alist))))
(cond
+ ((and f (symbolp (car f)) (get (car f) 'pre-form))
+ (setq cl-decls
+ (cons (apply (car f) name arglist (cdr x))
+ cl-decls))
+ nil)
(f (apply (car f) name arglist (cdr x)))
;; Yuck!!
((and (featurep 'cl)
@@ -332,10 +400,12 @@ This is used by `declare'.")
(defvar macro-declarations-alist
(cons
- (list 'debug #'byte-run--set-debug)
+ (list 'defining-symbol #'byte-run--set-defining-symbol)
(cons
- (list 'no-font-lock-keyword #'byte-run--set-no-font-lock-keyword)
- defun-declarations-alist))
+ (list 'debug #'byte-run--set-debug)
+ (cons
+ (list 'no-font-lock-keyword #'byte-run--set-no-font-lock-keyword)
+ defun-declarations-alist)))
"List associating properties of macros to their macro expansion.
Each element of the list takes the form (PROP FUN) where FUN is a function.
For each (PROP . VALUES) in a macro's declaration, the FUN corresponding
@@ -359,10 +429,16 @@ interpreted according to `macro-declarations-alist'.
The return value is undefined.
\(fn NAME ARGLIST [DOCSTRING] [DECL] BODY...)"
+ (if (null defining-symbol) ; For, e.g., components of cl-defstruct's;
+ (setq defining-symbol name)) ; they must get the original symbol.
(let* ((parse (byte-run--parse-body body nil))
- (docstring (nth 0 parse))
+ (docstring
+ (if (or (stringp (nth 0 parse)) (null (nth 0 parse)))
+ (byte-run-posify-doc-string (nth 0 parse))
+ (nth 0 parse)))
(declare-form (nth 1 parse))
- (body (nth 3 parse))
+ (body (or (nth 3 parse)
+ '(nil)))
(warnings (nth 4 parse))
(declarations
(and declare-form (byte-run--parse-declarations
@@ -393,17 +469,23 @@ INTERACTIVE is an optional `interactive' specification.
The return value is undefined.
\(fn NAME ARGLIST [DOCSTRING] [DECL] [INTERACTIVE] BODY...)"
- (declare (doc-string 3) (indent 2))
+ (declare (doc-string 3) (indent 2)
+ (defining-symbol 1))
(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* ((parse (byte-run--parse-body body t))
- (docstring (nth 0 parse))
+ (docstring
+ (if (or (stringp (nth 0 parse)) (null (nth 0 parse)))
+ (byte-run-posify-doc-string (nth 0 parse))
+ (nth 0 parse)))
(declare-form (nth 1 parse))
(interactive-form (nth 2 parse))
- (body (nth 3 parse))
+ (body
+ (or (nth 3 parse)
+ '(nil)))
(warnings (nth 4 parse))
(declarations
(and declare-form (byte-run--parse-declarations
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 64fd4f6b3f3..f2356899cc0 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -495,15 +495,15 @@ Return the compile-time value of FORM."
;; 3.2.3.1, "Processing of Top Level Forms". The semantics are very
;; subtle: see test/lisp/emacs-lisp/bytecomp-tests.el for interesting
;; cases.
- (setf form (macroexp-macroexpand form byte-compile-macro-environment))
- (if (eq (car-safe form) 'progn)
- (cons (car form)
- (mapcar (lambda (subform)
- (byte-compile-recurse-toplevel
- subform non-toplevel-case))
- (cdr form)))
- (funcall non-toplevel-case form)))
-
+ (let ((defining-symbol defining-symbol))
+ (setf form (macroexp-macroexpand form byte-compile-macro-environment))
+ (if (eq (car-safe form) 'progn)
+ (cons (car form)
+ (mapcar (lambda (subform)
+ (byte-compile-recurse-toplevel
+ subform non-toplevel-case))
+ (cdr form)))
+ (funcall non-toplevel-case form))))
(defvar bytecomp--copy-tree-seen)
@@ -1781,7 +1781,8 @@ It is too wide if it has any lines longer than the
largest of
('lambda
(setq kind "") ; can't be "function", unfortunately
(setq docs (nth 2 form))))
- (when (and kind docs (stringp docs))
+ (when (and kind docs (stringp docs)
+ (setq docs (help-strip-pos-info docs)))
(let ((col (max byte-compile-docstring-max-column fill-column)))
(when (and (byte-compile-warning-enabled-p 'docstrings-wide)
(byte-compile--wide-docstring-p docs col))
@@ -2314,6 +2315,7 @@ With argument ARG, insert value in current buffer after
the form."
(start-read-position (point))
(byte-compile-last-warned-form 'nothing)
(symbols-with-pos-enabled t)
+ (defining-symbol nil)
(value (eval
(displaying-byte-compile-warnings
(byte-compile-sexp
@@ -2409,7 +2411,8 @@ With argument ARG, insert value in current buffer after
the form."
;; at a lower level must not get symbols with
;; position.
(form (read-positioning-symbols inbuffer))
- (warning (byte-run--unescaped-character-literals-warning)))
+ (warning (byte-run--unescaped-character-literals-warning))
+ defining-symbol)
(when warning (byte-compile-warn-x form "%s" warning))
(byte-compile-toplevel-file-form form)))
;; Compile pending forms at end of file.
@@ -2748,11 +2751,12 @@ list that represents a doc string reference.
(push sym byte-compile--seen-defvars))
(defun byte-compile-file-form-defvar (form)
- (let ((sym (nth 1 form)))
+ (let* ((sym (nth 1 form))
+ (defining-symbol sym))
(byte-compile--declare-var sym)
(if (eq (car form) 'defconst)
- (push sym byte-compile-const-variables)))
- (if (and (null (cddr form)) ;No `value' provided.
+ (push sym byte-compile-const-variables))
+ (if (and (null (cddr form)) ;No `value' provided.
(eq (car form) 'defvar)) ;Just a declaration.
nil
(byte-compile-docstring-style-warn form)
@@ -2760,7 +2764,13 @@ list that represents a doc string reference.
(when (consp (nth 2 form))
(setcar (cdr (cdr form))
(byte-compile-top-level (nth 2 form) nil 'file)))
- form))
+ (let ((posified-doc-string
+ (byte-run-posify-doc-string
+ (and (nth 3 form) (stringp (nth 3 form)) (nth 3 form)))))
+ (if (nthcdr 3 form)
+ (setcar (nthcdr 3 form) posified-doc-string)
+ (nconc form (list posified-doc-string))))
+ form)))
(put 'define-abbrev-table 'byte-hunk-handler
'byte-compile-file-form-defvar-function)
@@ -2964,7 +2974,7 @@ not to take responsibility for the actual compilation of
the code."
"\n(defalias '" ")"
bare-name
(if macro '(" '(macro . #[" "])") '(" #[" "]"))
- (append code nil) ; Turn byte-code-function-p into list.
+ (append code nil) ; Turn byte-code-function-p into list.
2 4
(and (atom code) byte-compile-dynamic 1)
nil)
@@ -3060,7 +3070,7 @@ If FORM is a lambda or a macro, byte-compile it as a
function."
(if (symbolp form) form "provided"))
fun)
(t
- (let (final-eval)
+ (let (final-eval defining-symbol)
(when (or (symbolp form) (eq (car-safe fun) 'closure))
;; `fun' is a function *value*, so try to recover its
corresponding
;; source code.
@@ -4240,7 +4250,11 @@ This function is never called when `lexical-binding' is
nil."
(docstring-exp (nth 3 form))
(body (nthcdr 4 form))
(fun
- (byte-compile-lambda `(lambda ,vars . ,body) nil (length env))))
+ (byte-compile-lambda `(,(if (symbol-with-pos-p (car form))
+ (position-symbol 'lambda (car form))
+ 'lambda)
+ ,vars . ,body)
+ nil (length env))))
(cl-assert (or (> (length env) 0)
docstring-exp)) ;Otherwise, we don't need a closure.
(cl-assert (byte-code-function-p fun))
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index e65c39e3998..39a2a3eb201 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -167,7 +167,8 @@ Returns a form where all lambdas don't have any free
variables."
(unless (memq (car b) s) (push b res)))
(nreverse res)))
-(defun cconv--convert-function (args body env parentform &optional docstring)
+(defun cconv--convert-function (args body env parentform
+ &optional lambda-token docstring)
(cl-assert (equal body (caar cconv-freevars-alist)))
(let* ((fvs (cdr (pop cconv-freevars-alist)))
(body-new '())
@@ -198,9 +199,12 @@ Returns a form where all lambdas don't have any free
variables."
args body new-env parentform))
(cond
((not (or envector docstring)) ;If no freevars - do nothing.
- `(function (lambda ,args . ,body-new)))
+ `(function (,(or lambda-token 'lambda)
+ ,args . ,body-new)))
(t
- `(internal-make-closure
+ `(,(if (symbol-with-pos-p lambda-token)
+ (position-symbol 'internal-make-closure lambda-token)
+ 'internal-make-closure)
,args ,envector ,docstring . ,body-new)))))
(defun cconv--remap-llv (new-env var closedsym)
@@ -477,7 +481,7 @@ places where they originally did not directly appear."
branch))
cond-forms)))
- (`(function (lambda ,args . ,body) . ,rest)
+ (`(function (,(and 'lambda lambda-token) ,args . ,body) . ,rest)
(let* ((docstring (if (eq :documentation (car-safe (car body)))
(cconv-convert (cadr (pop body)) env extend)))
(bf (if (stringp (car body)) (cdr body) body))
@@ -505,12 +509,13 @@ places where they originally did not directly appear."
(setq body (if (stringp (car body))
(cons (car body) bf)
bf)
- form `(function (lambda ,args . ,body) . ,rest))
+ form `(function (,lambda-token ,args . ,body) . ,rest))
;; Also, remove the current old entry on the alist, replacing
;; it with the new one.
(let ((entry (pop cconv-freevars-alist)))
(push (cons body (cdr entry)) cconv-freevars-alist)))
- (setq cf (cconv--convert-function args body env form docstring))
+ (setq cf (cconv--convert-function args body env form
+ lambda-token docstring))
(if (not cif)
;; Normal case, the interactive form needs no special treatment.
cf
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 0ef0d1e192a..d014df79767 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -242,6 +242,13 @@ DEFAULT-BODY, if present, is used as the body of a default
method.
\(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest DEFAULT-BODY)"
(declare (indent 2) (doc-string 3)
+ (defining-symbol
+ (if (eq (car-safe name) 'setf)
+ (progn
+ (require 'gv)
+ (declare-function gv-setter "gv" (name))
+ (gv-setter (cadr name)))
+ name))
(debug
(&define
&interpose
@@ -348,7 +355,8 @@ This macro can only be used within the lexical scope of a
cl-generic method."
"Define a special kind of context named NAME.
Whenever a context specializer of the form (NAME . ARGS) appears,
the specializer used will be the one returned by BODY."
- (declare (debug (&define name lambda-list def-body)) (indent defun))
+ (declare (defining-symbol 1)
+ (debug (&define name lambda-list def-body)) (indent defun))
`(eval-and-compile
(put ',name 'cl-generic--context-rewriter
(lambda ,args ,@body))))
@@ -556,6 +564,13 @@ The set of acceptable TYPEs (also called \"specializers\")
is defined
\(fn NAME [EXTRA] [QUALIFIER] ARGS &rest [DOCSTRING] BODY)"
(declare (doc-string cl--defmethod-doc-pos) (indent defun)
+ (defining-symbol
+ (if (eq (car-safe name) 'setf)
+ (progn
+ (require 'gv)
+ (declare-function gv-setter "gv" (name))
+ (gv-setter (cadr name)))
+ name))
(debug
(&define ; this means we are defining something
[&name [sexp ;Allow (setf ...) additionally to symbols.
@@ -1111,9 +1126,11 @@ MET-NAME is as returned by
`cl--generic-load-hist-format'."
(cl-assert (consp qualifiers))
(let ((s (prin1-to-string qualifiers)))
(concat (substring s 1 -1) " "))))
- (doconly (if docstring
- (let ((split (help-split-fundoc docstring nil)))
- (if split (cdr split) docstring))))
+ (doconly
+ (help-strip-pos-info
+ (if docstring
+ (let ((split (help-split-fundoc docstring nil)))
+ (if split (cdr split) docstring)))))
(combined-args ()))
(if (eq t call-con) (setq args (cdr args)))
(dolist (specializer specializers)
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 2431e658368..6cb6f3a80b4 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -390,7 +390,8 @@ written simply `VAR'. See the Info node `(cl)Argument
Lists' for
more details.
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
- (declare (debug
+ (declare (defining-symbol 1)
+ (debug
;; Same as defun but use cl-lambda-list.
(&define [&name symbolp]
cl-lambda-list
@@ -408,7 +409,8 @@ Like normal `iter-defun', except ARGLIST allows full Common
Lisp conventions,
and BODY is implicitly surrounded by (cl-block NAME ...).
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
- (declare (debug
+ (declare (defining-symbol 1)
+ (debug
;; Same as iter-defun but use cl-lambda-list.
(&define [&name sexp] ;Allow (setf ...) additionally to symbols.
cl-lambda-list
@@ -472,7 +474,8 @@ written simply `VAR'. See the Info node `(cl)Argument
Lists' for
more details.
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
- (declare (debug
+ (declare (defining-symbol 1)
+ (debug
(&define name cl-macro-list cl-declarations-or-string def-body))
(doc-string 3)
(indent 2))
@@ -2999,6 +3002,8 @@ To see the documentation for a defined struct type, use
\(fn NAME &optional DOCSTRING &rest SLOTS)"
(declare (doc-string 2) (indent 1)
+ (defining-symbol
+ (if (consp struct) (car struct) struct))
(debug
(&define ;Makes top-level form not be wrapped.
[&or symbolp
@@ -3616,7 +3621,8 @@ possible. Unlike regular macros, BODY can decide to
\"punt\" and leave the
original function call alone by declaring an initial `&whole foo' parameter
and then returning foo."
;; Like `cl-defmacro', but with the `&whole' special case.
- (declare (debug (&define [&name symbolp "@cl-compiler-macro"]
+ (declare (defining-symbol 1)
+ (debug (&define [&name symbolp "@cl-compiler-macro"]
cl-macro-list
cl-declarations-or-string def-body))
(indent 2))
diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el
index dec5883767d..d0b4329596c 100644
--- a/lisp/emacs-lisp/derived.el
+++ b/lisp/emacs-lisp/derived.el
@@ -171,7 +171,8 @@ the hook will be named `foo-mode-hook'.
See Info node `(elisp)Derived Modes' for more details.
\(fn CHILD PARENT NAME [DOCSTRING] [KEYWORD-ARGS...] &rest BODY)"
- (declare (debug (&define name symbolp sexp [&optional stringp]
+ (declare (defining-symbol 1)
+ (debug (&define name symbolp sexp [&optional stringp]
[&rest keywordp sexp] def-body))
(doc-string 4)
(indent defun))
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el
index c9e7b3a4dfe..41eff43a67c 100644
--- a/lisp/emacs-lisp/easy-mmode.el
+++ b/lisp/emacs-lisp/easy-mmode.el
@@ -217,6 +217,7 @@ INIT-VALUE LIGHTER KEYMAP.
\(fn MODE DOC [KEYWORD VAL ... &rest BODY])"
(declare (doc-string 2)
(indent defun)
+ (defining-symbol 1)
(debug (&define name string-or-null-p
[&optional [¬ keywordp] sexp
&optional [¬ keywordp] sexp
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 61d8341bdad..59b4504c6ef 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -213,7 +213,8 @@ in batch mode, an error is signaled.
\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \
[:tags \\='(TAG...)] BODY...)"
- (declare (debug (&define [&name "test@" symbolp]
+ (declare (defining-symbol 1)
+ (debug (&define [&name "test@" symbolp]
sexp [&optional stringp]
[&rest keywordp sexp] def-body))
(doc-string 3)
diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el
index 9b0e5ad6352..eb00f1adc86 100644
--- a/lisp/emacs-lisp/generator.el
+++ b/lisp/emacs-lisp/generator.el
@@ -674,6 +674,7 @@ When called as a function, NAME returns an iterator value
that
encapsulates the state of a computation that produces a sequence
of values. Callers can retrieve each value using `iter-next'."
(declare (indent defun)
+ (defining-symbol 1)
(debug (&define name lambda-list lambda-doc &rest sexp))
(doc-string 3))
(cl-assert lexical-binding)
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index 5d31253fe2d..72ec3033fc7 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -251,6 +251,7 @@ which can do arbitrary things, whereas the other arguments
are all guaranteed
to be pure and copyable. Example use:
(gv-define-setter aref (v a i) \\=`(aset ,a ,i ,v))"
(declare (indent 2)
+ (defining-symbol 1)
(debug (&define [&name symbolp "@gv-setter"] sexp def-body)))
`(gv-define-expander ,name
(lambda (do &rest args)
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 615a6622ce6..b4fd7bdc658 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -213,6 +213,37 @@ It should normally be a symbol with position and it
defaults to FORM."
((consp form)
(let* ((head (car form))
(env-expander (assq head environment)))
+ ;; Special handling for `lambda', preserving any symbol position
+ ;; in it, and amending/creating its doc string for position
+ ;; information.
+ (if (eq head 'lambda)
+ (let* ((ds (and (stringp (nth 2 form))
+ ;; (nthcdr 3 form)
+ ; Ensure we don't have
+ ; (lambda () "str").
+ (nth 2 form)))
+ (new-ds (byte-run-posify-doc-string ds head))
+ new-link)
+ (setq form
+ (cond
+ ;; Overwrite the existing doc string with the new one
+ (;;ds ;; (setcar (nthcdr 2 form) new-ds)
+ (and (stringp (nth 2 form))
+ (nthcdr 3 form))
+ (nconc (list (car form) (cadr form) new-ds)
+ (nthcdr 3 form))
+ )
+ ((and (consp (nth 2 form))
+ (eq (car (nth 2 form)) ':documentation))
+ form
+ ;; How should we deal with a dynamic doc string?
+ )
+ ;; Insert the new doc string into the structure.
+ (t (setq new-link (cons new-ds (nthcdr 2 form)))
+ ;; (setcdr (cdr form) new-link)
+ (nconc (list (car form) (cadr form)) new-link)
+ )))
+ (list 'function form))
(if env-expander
(if (cdr env-expander)
(apply (cdr env-expander) (cdr form))
@@ -228,7 +259,7 @@ It should normally be a symbol with position and it
defaults to FORM."
(t
(if (eq 'macro (car def))
(apply (cdr def) (cdr form))
- form))))))))
+ form)))))))))
(t form)))
(defun macroexp-macroexpand (form env)
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el
index 42027c01491..e8aad839c8c 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -257,16 +257,67 @@ HOW is a symbol to select an entry in
`advice--how-alist'."
(advice--copy (cadr proto)
function main how props)))))
+(defun advice--equal (function adv)
+ "Return non-nil when FUNCTION is essentially the same as ADV.
+FUNCTION and ADV are both functions. They are considered
+essentially the same when all components apart, possibly, from
+the \"defining-symbol\" are `equal'.
+
+On such sameness, ADV is returned, otherwise nil."
+ (cond
+ ((and (byte-code-function-p function)
+ (byte-code-function-p adv))
+ (and (equal (aref function 0) (aref adv 0)) ; parameter spec.
+ (equal (aref function 1) (aref adv 1)) ; byte code.
+ (equal (aref function 2) (aref adv 2)) ; constant vector.
+ (equal (aref function 3) (aref adv 3)) ; Stack usage.
+ ;; `documentation' currently (2023-12-01) strips the position
+ ;; information from the doc strings.
+ (equal (documentation function t) (documentation adv t))
+ (or (and (< (length function) 6) (< (length adv) 6))
+ (equal (aref function 5) (aref adv 5))) ; interactive spec.
+ adv))
+ ((and (consp function)
+ (consp adv)) ; Interpreted functions.
+ (let* ((doc-pos (cond ((eq (car function) 'lambda) 2)
+ ((eq (car function) 'closure) 3)
+ (t (error "advice--equal: Unknown function type: %s"
+ (car function)))))
+ (f-doc-cdr (nthcdr doc-pos function))
+ (a-doc-cdr (nthcdr doc-pos adv))
+ (f-doc (car f-doc-cdr))
+ (a-doc (car a-doc-cdr))
+ )
+ ;; Mask out the ;POS info in the doc strings, and compare everything.
+ (if (and f-doc-cdr a-doc-cdr)
+ (unwind-protect
+ (progn
+ (when (stringp f-doc)
+ (setcar f-doc-cdr (help-strip-pos-info f-doc)))
+ (when (stringp a-doc)
+ (setcar a-doc-cdr (help-strip-pos-info a-doc)))
+ (equal function adv))
+ (setcar f-doc-cdr f-doc)
+ (setcar a-doc-cdr a-doc))
+ (equal function adv))))
+ ;; Insert an arm for native-compiled functions here. FIXME!!!
+ (t (and (equal function adv)
+ adv))
+ ))
+
(defun advice--member-p (function use-name definition)
(let ((found nil))
(while (and (not found) (advice--p definition))
(if (if (eq use-name :use-both)
- (or (equal function
- (cdr (assq 'name (advice--props definition))))
- (equal function (advice--car definition)))
- (equal function (if use-name
- (cdr (assq 'name (advice--props definition)))
- (advice--car definition))))
+ (or (advice--equal
+ function
+ (cdr (assq 'name (advice--props definition))))
+ (advice--equal
+ function (advice--car definition)))
+ (advice--equal
+ function (if use-name
+ (cdr (assq 'name (advice--props definition)))
+ (advice--car definition))))
(setq found definition)
(setq definition (advice--cdr definition))))
found))
@@ -288,8 +339,10 @@ HOW is a symbol to select an entry in `advice--how-alist'."
(advice--tweak flist
(lambda (first rest props)
(cond ((not first) rest)
- ((or (equal function first)
- (equal function (cdr (assq 'name props))))
+ ((or (advice--equal
+ function first)
+ (advice--equal
+ function (cdr (assq 'name props))))
(list (advice--remove-function rest function)))))))
(oclosure-define (advice--forward
diff --git a/lisp/gnus/nnoo.el b/lisp/gnus/nnoo.el
index 4392a464f7b..c24cfb94b19 100644
--- a/lisp/gnus/nnoo.el
+++ b/lisp/gnus/nnoo.el
@@ -46,6 +46,7 @@
"The same as `defun', only register FUNC."
(declare (indent 2)
(doc-string 3)
+ (defining-symbol 1)
(debug (&define name lambda-list def-body)))
`(prog1
(defun ,func ,args ,@forms)
diff --git a/lisp/help.el b/lisp/help.el
index 41c43c356a4..5667b511b6e 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -1314,6 +1314,25 @@ mode lighter was clicked."
result))
+(defun help-strip-pos-info (string)
+ "Remove the POS info, if any, from STRING, returning the result.
+STRING may be nil.
+
+If no changes are made, return the original STRING. If there are
+no characters other than the POS info, return nil instead."
+ (when string
+ (let (start index)
+ (while
+ (and (setq index (string-match ";POS.\000\000\000 " string start))
+ (string-match "\n" string index))
+ (setq start (match-end 0)))
+ (cond
+ ((and start (< start (length string)))
+ (substring string start))
+ ((and start (eq start (length string)))
+ nil)
+ ((null index) string)))))
+
(defcustom help-link-key-to-documentation t
"Non-nil means link keys to their command in *Help* buffers.
This affects \\\\=\\[command] substitutions in documentation
@@ -2268,7 +2287,8 @@ When SECTION is \\='usage or \\='doc, return only that
part."
;; In cases where `function' has been fset to a subr we can't search for
;; function's name in the doc string so we use `fn' as the anonymous
;; function name instead.
- (let* ((found (and docstring
+ (let* ((docstring (help-strip-pos-info docstring))
+ (found (and docstring
(string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring)))
(doc (if found
(and (memq section '(t nil doc))
@@ -2300,9 +2320,14 @@ ARGLIST can also be t or a string of the form \"(FUN
ARG1 ARG2 ...)\"."
(eq arglist t))
docstring
(concat docstring
- (if (string-match "\n?\n\\'" docstring)
- (if (< (- (match-end 0) (match-beginning 0)) 2) "\n" "")
- "\n\n")
+ (cond
+ ((progn (string-match
+ "\\(?:;POS.\000\000\000 \\[[^]]+]\n\\)?\\(\n*\\)\\'"
+ docstring)
+ (zerop (- (match-end 1) (match-beginning 1))))
+ "\n\n")
+ ((< (- (match-end 1) (match-beginning 1)) 2) "\n")
+ (t ""))
(if (stringp arglist)
(if (string-match "\\`[^ ]+\\(.*\\))\\'" arglist)
(concat "(fn" (match-string 1 arglist) ")")
diff --git a/lisp/mh-e/mh-acros.el b/lisp/mh-e/mh-acros.el
index 3981bb7f709..1b4b42ebde6 100644
--- a/lisp/mh-e/mh-acros.el
+++ b/lisp/mh-e/mh-acros.el
@@ -75,6 +75,7 @@ If FUNCTION exists, then NAME becomes an alias for FUNCTION.
Otherwise, create function NAME with ARG-LIST and BODY."
(declare (obsolete defun "29.1")
(indent defun) (doc-string 4)
+ (defining-symbol 1)
(debug (&define name symbolp sexp def-body)))
`(defalias ',name
(if (fboundp ',function)
@@ -88,6 +89,7 @@ If MACRO exists, then NAME becomes an alias for MACRO.
Otherwise, create macro NAME with ARG-LIST and BODY."
(declare (obsolete defmacro "29.1")
(indent defun) (doc-string 4)
+ (defining-symbol 1)
(debug (&define name symbolp sexp def-body)))
(let ((defined-p (fboundp macro)))
(if defined-p
diff --git a/lisp/obsolete/cl.el b/lisp/obsolete/cl.el
index 1b86ed259f7..ff1dc70d0c0 100644
--- a/lisp/obsolete/cl.el
+++ b/lisp/obsolete/cl.el
@@ -512,7 +512,8 @@ a temporary-variables list, a value-forms list, a
store-variables list
See `gv-define-expander', and `gv-define-setter' for better and
simpler ways to define setf-methods."
- (declare (debug
+ (declare (defining-symbol 1)
+ (debug
(&define name cl-lambda-list cl-declarations-or-string def-body))
(indent defun))
`(progn
@@ -551,7 +552,8 @@ For example:
You can replace this form with `gv-define-setter'.
\(fn NAME [FUNC | ARGLIST (STORE) BODY...])"
- (declare (debug
+ (declare (defining-symbol 1)
+ (debug
(&define name
[&or [symbolp &optional stringp]
[cl-lambda-list (symbolp)]]
@@ -615,7 +617,8 @@ arguments from ARGLIST using FUNC. For example:
(define-modify-macro incf (&optional (n 1)) +)
You can replace this macro with `gv-letplace'."
- (declare (debug
+ (declare (defining-symbol 1)
+ (debug
(&define name cl-lambda-list ;; should exclude &key
symbolp &optional stringp))
(indent defun))
diff --git a/lisp/obsolete/eieio-compat.el b/lisp/obsolete/eieio-compat.el
index bb3d5ccb49c..959c715cb02 100644
--- a/lisp/obsolete/eieio-compat.el
+++ b/lisp/obsolete/eieio-compat.el
@@ -106,6 +106,7 @@ Summary:
body)"
(declare (doc-string 3) (obsolete cl-defmethod "25.1")
(indent defun)
+ (defining-symbol 1)
(debug
(&define ; this means we are defining something
[&name sexp] ;Allow (setf ...) additionally to symbols.
diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el
index e15ce54da7f..b6d664be571 100644
--- a/lisp/progmodes/cc-defs.el
+++ b/lisp/progmodes/cc-defs.el
@@ -2508,6 +2508,7 @@ already is one it will be completely replaced; the value
in the
earlier definition will not affect `c-lang-const' on the same
constant. A file is identified by its base name."
(declare (indent 1)
+ (defining-symbol 1)
(debug (&define name [&optional stringp] [&rest sexp def-form])))
(let* ((sym (intern (symbol-name name) c-lang-constants))
;; Make `c-lang-const' expand to a straightforward call to
diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el
index ef7f27dc435..15b08888b9d 100644
--- a/lisp/progmodes/cc-langs.el
+++ b/lisp/progmodes/cc-langs.el
@@ -160,6 +160,7 @@ the macro `c-init-language-vars' is evaluated.
language being initialized, and such calls will be macro expanded to
the evaluated constant value at compile time."
(declare (indent defun)
+ (defining-symbol 1)
(debug (&define name def-form
&optional &or ("quote" symbolp) stringp)))
(when (and (not doc)
@@ -193,7 +194,8 @@ Emacs variable like `comment-start'.
`c-lang-const' is typically used in VAL to get the right value for the
language being initialized, and such calls will be macro expanded to
the evaluated constant value at compile time."
- (declare (debug (&define name def-form)))
+ (declare (defining-symbol 1)
+ (debug (&define name def-form)))
(let ((elem (assq var (cdr c-emacs-variable-inits))))
(if elem
(setcdr elem (list val)) ; Maybe remove "list", sometime. 2006-07-19
diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el
index 63198a660be..4745b28a38e 100644
--- a/lisp/progmodes/elisp-mode.el
+++ b/lisp/progmodes/elisp-mode.el
@@ -1163,7 +1163,9 @@ namespace but with lower confidence."
(when (and file
(or non-default
- (nth 2 info))) ;; assuming only co-located
default has null doc string
+ (and
+ (nth 2 info)
+ (help-split-fundoc (nth 2 info) nil 'doc))))
;; assuming only co-located default has null doc string
(if specializers
(let ((summary (format elisp--xref-format-extra
'cl-defmethod symbol (nth 1 info))))
(push (elisp--xref-make-xref 'cl-defmethod met-name
file summary) xrefs))
@@ -1539,7 +1541,8 @@ output with no limit on the length and level of lists, and
include additional formats for integers \(octal, hexadecimal, and
character)."
(pcase-let*
- ((`(,insert-value ,no-truncate ,char-print-limit)
+ ((defining-symbol nil)
+ (`(,insert-value ,no-truncate ,char-print-limit)
(eval-expression-get-print-arguments eval-last-sexp-arg-internal)))
;; Setup the lexical environment if lexical-binding is enabled.
(elisp--eval-last-sexp-print-value
diff --git a/lisp/skeleton.el b/lisp/skeleton.el
index b633490ecca..c9e77f1cbe9 100644
--- a/lisp/skeleton.el
+++ b/lisp/skeleton.el
@@ -115,7 +115,8 @@ are integer buffer positions in the reverse order of the
insertion order.")
"Define a user-configurable COMMAND that enters a statement skeleton.
DOCUMENTATION is that of the command.
SKELETON is as defined under `skeleton-insert'."
- (declare (doc-string 2) (debug (&define name stringp skeleton-edebug-spec))
+ (declare (doc-string 2) (defining-symbol 1)
+ (debug (&define name stringp skeleton-edebug-spec))
(indent defun))
(if skeleton-debug
(set command skeleton))
diff --git a/lisp/transient.el b/lisp/transient.el
index dd2b4e0db0b..da1a4b11f5c 100644
--- a/lisp/transient.el
+++ b/lisp/transient.el
@@ -856,7 +856,8 @@ to the setup function:
(transient-setup \\='NAME nil nil :scope SCOPE)
\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]... GROUP... [BODY...])"
- (declare (debug ( &define name lambda-list
+ (declare (defining-symbol 1)
+ (debug ( &define name lambda-list
[&optional lambda-doc]
[&rest keywordp sexp]
[&rest vectorp]
@@ -897,7 +898,8 @@ ARGLIST. The infix arguments are usually accessed by using
`transient-args' inside `interactive'.
\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]... BODY...)"
- (declare (debug ( &define name lambda-list
+ (declare (defining-symbol 1)
+ (debug ( &define name lambda-list
[&optional lambda-doc]
[&rest keywordp sexp]
("interactive" interactive)
@@ -948,7 +950,8 @@ the infix command and use t as the value of the `:transient'
keyword.
\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]...)"
- (declare (debug ( &define name lambda-list
+ (declare (defining-symbol 1)
+ (debug ( &define name lambda-list
[&optional lambda-doc]
[&rest keywordp sexp]))
(indent defun)
diff --git a/lisp/vc/pcvs.el b/lisp/vc/pcvs.el
index c90b9f6bdf1..5bb2647da13 100644
--- a/lisp/vc/pcvs.el
+++ b/lisp/vc/pcvs.el
@@ -897,7 +897,8 @@ clear what alternative to use.
- `NOARGS' will get all the arguments from the *cvs* buffer and will
always behave as if called interactively.
- `DOUBLE' is the generic case."
- (declare (debug (&define sexp lambda-list stringp
+ (declare (defining-symbol (if (symbolp fun) fun (car fun)))
+ (debug (&define sexp lambda-list stringp
("interactive" interactive) def-body))
(indent defun)
(doc-string 3))
diff --git a/src/doc.c b/src/doc.c
index 37e04262681..134d7414906 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -408,7 +408,12 @@ string is passed through `substitute-command-keys'. */)
}
if (NILP (raw))
- doc = call1 (Qsubstitute_command_keys, doc);
+ {
+ doc = call1 (Qhelp_strip_pos_info, doc);
+ doc = call1 (Qsubstitute_command_keys, doc);
+ }
+ else
+ doc = call1 (Qhelp_strip_pos_info, doc);
return doc;
}
@@ -738,6 +743,7 @@ syms_of_doc (void)
{
DEFSYM (Qlisp_directory, "lisp-directory");
DEFSYM (Qsubstitute_command_keys, "substitute-command-keys");
+ DEFSYM (Qhelp_strip_pos_info, "help-strip-pos-info");
DEFSYM (Qfunction_documentation, "function-documentation");
DEFSYM (Qgrave, "grave");
DEFSYM (Qstraight, "straight");
diff --git a/src/eval.c b/src/eval.c
index 12e811ce264..29fa5fb645a 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1144,8 +1144,15 @@ definitions to shadow the loaded ones for use in file
byte-compilation. */)
and if TEM is nil then DEF is SYM's function definition. */
if (NILP (tem))
{
- /* SYM is not mentioned in ENVIRONMENT.
- Look at its function definition. */
+ /* SYM is not mentioned in ENVIRONMENT. */
+ /* We handle `lambda' specially, to preserve any symbol
+ position which may be attached to it. */
+ if (EQ (sym, Qlambda))
+ {
+ form = list2 (Qfunction, form);
+ break;
+ }
+ /* Look at its function definition. */
def = Fautoload_do_load (def, sym, Qmacro);
if (!CONSP (def))
/* Not defined or definition not suitable. */
diff --git a/src/lread.c b/src/lread.c
index 255b6e914d9..c81318f80cf 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -2399,6 +2399,9 @@ readevalloop_eager_expand_eval (Lisp_Object val,
Lisp_Object macroexpand)
form in the progn as a top-level form. This way, if one form in
the progn defines a macro, that macro is in effect when we expand
the remaining forms. See similar code in bytecomp.el. */
+ specpdl_ref count = SPECPDL_INDEX ();
+
+ specbind (Qdefining_symbol, Qnil); /* This gets setq'd in macros. */
val = call2 (macroexpand, val, Qnil);
if (EQ (CAR_SAFE (val), Qprogn))
{
@@ -2409,7 +2412,7 @@ readevalloop_eager_expand_eval (Lisp_Object val,
Lisp_Object macroexpand)
}
else
val = eval_sub (call2 (macroexpand, val, Qt));
- return val;
+ return unbind_to (count, val);
}
/* UNIBYTE specifies how to set load_convert_to_unibyte
@@ -2594,7 +2597,12 @@ readevalloop (Lisp_Object readcharfun,
if (!NILP (macroexpand))
val = readevalloop_eager_expand_eval (val, macroexpand);
else
- val = eval_sub (val);
+ {
+ specpdl_ref count2 = SPECPDL_INDEX ();
+
+ specbind (Qdefining_symbol, Qnil);
+ val = unbind_to (count2, eval_sub (val));
+ }
if (printflag)
{
@@ -5916,6 +5924,13 @@ variables, this must be set in the first line of a file.
*/);
Vlexical_binding = Qnil;
Fmake_variable_buffer_local (Qlexical_binding);
+ DEFSYM (Qdefining_symbol, "defining-symbol");
+ DEFVAR_LISP ("defining-symbol", Vdefining_symbol,
+ doc: /* The symbol currently being defined by a defining form.
+This variable is bound in the read-eval-print loop and certain
+high-level functions in the byte compiler. It is set to a value by
+functions and macros such as `defun', `defmacro', and `defvar'. */);
+
DEFVAR_LISP ("eval-buffer-list", Veval_buffer_list,
doc: /* List of buffers being read from by calls to
`eval-buffer' and `eval-region'. */);
Veval_buffer_list = Qnil;
@@ -5931,6 +5946,8 @@ For internal use only. */);
/* Defined in lisp/emacs-lisp/byte-run.el. */
DEFSYM (Qbyte_run_unescaped_character_literals_warning,
"byte-run--unescaped-character-literals-warning");
+ DEFSYM (Qbyte_run_strip_symbol_positions,
+ "byte-run-strip-symbol-positions");
DEFVAR_BOOL ("load-prefer-newer", load_prefer_newer,
doc: /* Non-nil means `load' prefers the newest version of a
file.
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el
b/test/lisp/emacs-lisp/bytecomp-tests.el
index 27056c99a50..6330bd7f5e3 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -1983,7 +1983,7 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode
python-mode)) \
(should (equal (aref bc 5) "P"))
(should (equal (get fname 'pure) t))
(should (equal (get fname 'lisp-indent-function) 1))
- (should (equal (aref bc 4) "tata\n\n(fn X)")))))
+ (should (equal (help-strip-pos-info (aref bc 4)) "tata\n\n(fn X)")))))
(ert-deftest bytecomp-fun-attr-warn ()
;; Check that warnings are emitted when doc strings, `declare' and
diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el
b/test/lisp/emacs-lisp/cl-lib-tests.el
index 0995e71db4e..2954d5418fb 100644
--- a/test/lisp/emacs-lisp/cl-lib-tests.el
+++ b/test/lisp/emacs-lisp/cl-lib-tests.el
@@ -224,7 +224,8 @@
t)))))
(ert-deftest cl-lib-struct-constructors ()
(should (string-match "\\`Constructor docstring."
- (documentation 'cl-lib--con-2 t)))
+ (help-strip-pos-info
+ (documentation 'cl-lib--con-2 t))))
(should (mystruct-p (cl-lib--con-1)))
(should (mystruct-p (cl-lib--con-2))))