[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/named-lambdas 603ac9505d5: Add "defining symbols" to backtrace l
|
From: |
Alan Mackenzie |
|
Subject: |
feature/named-lambdas 603ac9505d5: Add "defining symbols" to backtrace lines with lambdas. |
|
Date: |
Mon, 17 Jul 2023 05:58:53 -0400 (EDT) |
branch: feature/named-lambdas
commit 603ac9505d5d0eebf27798620d1826788739fad8
Author: Alan Mackenzie <acm@muc.de>
Commit: Alan Mackenzie <acm@muc.de>
Add "defining symbols" to backtrace lines with lambdas.
This is achieved by enhancing the structures of the
interpreted, byte compiled, and native compiled functions to
include the defining symbol in them. It is intended that the
older forms of such functions will still run OK in the current
Emacs.
* lisp/emacs-lisp/byte-run.el (byte-run--strip-list)
(byte-run--strip-vector/record)
(byte-run-strip-symbol-positions, function-put)
(byte-run--set-advertised-calling-convention)
(byte-run--set-obsolete, byte-run--set-interactive-only)
(byte-run--set-pure, byte-run--set-side-effect-free)
(byte-run--set-compiler-macro, byte-run--set-doc-string)
(byte-run--set-indent, byte-run--set-speed)
(byte-run--set-completion, byte-run--set-modes)
(byte-run--set-interactive-args, byte-run--set-debug)
(byte-run--set-no-font-lock-keyword, byte-run--parse-body)
(byte-run--parse-declarations, defmacro)
* lisp/emacs-lisp/debug-early.el (debug-early-backtrace)
(debug-early): Add in the defining symbol to the source of all
these explicit defalias's.
* lisp/emacs-lisp/byte-run.el (defmacro, defun): Insert the
NAME parameter as defining symbol into the resulting form.
(lambda-arglist, lambda-body): New macros.
* lisp/emacs-lisp/byte-opt.el (byte-optimize--rename-var)
* lisp/emacs-lisp/bytecomp.el
(byte-compile-docstring-style-warn)
(byte-compile--reify-function, byte-compile-lambda)
(byte-compile-out-toplevel, byte-compile-make-closure)
(byte-compile-file-form-defalias)
* lisp/emacs-lisp/cconv.el (cconv--convert-function)
(cconv-convert, cconv-analyze-form)
(cconv-make-interpreted-closure)
* lisp/emacs-lisp/cl-generic.el (cl-generic-define)
(cl--generic-lambda, cl-generic-define-method)
* lisp/emacs-lisp/cl-macs.el (cl-labels)
(cl--sm-macroexpand-1)
* lisp/emacs-lisp/loaddefs-gen.el
(loaddefs-generate--make-autoload)
* lisp/emacs-lisp/macroexp.el (macroexp--expand-all)
* lisp/emacs-lisp/oclosure.el (oclosure--fix-type)
* lisp/help.el (help-function-arglist)
* lisp/progmodes/elisp-mode.el (elisp--local-variables-1)
(elisp--eval-defun-1)
* lisp/simple.el (function-documentation): Amend to handle
possible or actual defining symbols in forms.
* lisp/emacs-lisp/bytecomp.el (byte-compile-from-buffer): Bind
defining-symbol to t. Call byte-compile-flush-pending after
each top-level form to ensure the defining-symbol mechanism
works.
(byte-compile-file-form-defvar, byte-compile-defvar): bind
defining-symbol to the variable being defined for the benefit
of any forms in the value.
(byte-compile-file-form-defmumble): New parameter defsym. Add
the defining symbol to the form passed to byte-compile-lambda.
(byte-compile, byte-compile-sexp, byte-compile-top-level): Bind
defining-symbol to t.
(byte-compile-lambda, byte-compile-make-closure): Amend the
arguments to make-byte-code.
* lisp/emacs-lisp/cconv.el (cconv--convert-function): New
parameter defsym.
(cconv-fv, cconv-make-interpreted-closure): Use lambda-body.
* lisp/emacs-lisp/cl-generic.el (cl--generic-lambda): New
parameter defsym.
(cl-defmethod): Insert defining symbol into generated code.
(cl--generic-get-dispatcher): New parameter `name'. Add this
symbol as the defining symbol in generated code.
(cl--generic-make-function, cl--generic-make-next-function):
New parameter `name'.
* lisp/emacs-lisp/cl-macs.el (cl--sm-macroexpand-1): bind
pcase-max-duplicate to nil around this function to prevent the
creation of pcase-n functions which lead to infinite recursion.
* lisp/emacs-lisp/cl-print.el (cl-print-object/cons): For a
lambda function, print the defining symbol in braces. This is
the main point of these changes.
(cl-print-compiled): Add extra value, `full', meaning print out
a (byte-compiled) function in full.
(cl-print-object/compiled-function): Print the defining symbol
in the pertinent function. Add in code for (eq
cl-print-compiled 'full).
* lisp/emacs-lisp/comp.el (comp-func): New field
defining-symbol.
(comp-spill-lap-function/symbol)
(comp-spill-lap-function/lambda): Fill in the new field
defining-symbol of func. Use lambda-arglist in the lambda
version.
(comp-spill-lap) Add a mention of lambda form to the doc
string.
(comp-emit-for-top-level/form)
(comp-emit-for-top-level/lambda): Emit the defining symbol as
the last element of the subr being created.
(comp-limplify-top-level): Add one of the two rigid
possibilities for the defining symbol into the func structure.
(comp-native-compile): Remove the condition-case to ease
debugging the compiler.
* lisp/emacs-lisp/ert.el (ert-batch-backtrace-right-margin):
Change from 70 to nil.
(ert-batch-print-length): Change from 10 to nil.
(ert-batch-print-level): Change from 5 to nil.
All these changes were to get half-usable backtraces.
* lisp/emacs-lisp/macroexp.el (macroexp--unfold-lambda): Use
lambda-arglist and lambda-body.
(macroexp--expand-all): Add in a pcase handler for defalias,
which binds defining-symbol during the expansion of the form's
contents. Likewise add a pcase handler for defvar and
defconst, which does the same.
* lisp/emacs-lisp/nadvice.el (advice--equal): New function.
This function is, as yet, incomplete, needing code for both
interpreted functions and subrs.
(advice--member-p, advice--remove-function): Use advice--equal
rather than equal to avoid unnecessarily failing to match when
defining-symbols are not the same.
* lisp/emacs-lisp/pcase.el (pcase-max-duplicates): New
variable, replaces a constant 2
(pcase--expand): Compare `count' with the new variable rather
than the constant 2.
* lisp/progmodes/compile.el (compilation-directory-properties)
(compilation-error-properties): Check a position is not
(point-min) before testing a text-property on the position
before.
* lisp/subr.el (lambda): Ensure there is a defining symbol
(usually the variable defining-symbol) in the resultant form.
* src/bytecode.c (Fbyte_code): Add an extra (as yet unused)
parameter defsym.
(exec_byte_code): Replace a call to error with one to xsignal1.
* src/comp.c (make_subr): New parameter defining_symbol. Set
the new field in "struct subr" to this value.
(Fcomp__register_lambda, Fcomp__register_subr)
(Fcomp__late_register_subr): New parameter defining_symbol,
passed to one of the above functions.
* src/data.c (Fsubr_native_defining_symbol): New DEFUN.
(Finteractive_form, Fcommand_modes): Amend to handle the
possible presence of a defining_symbol field.
* src/eval.c (Ffunction, Fcommandp, funcall_lambda)
(lambda_arity): Handle the possible presence of a defining
symbol.
(defvar, defconst): Bind defining_symbol to the sym parameter.
* src/lisp.h (struct Lisp_Subr): New field defining_symbol.
(enum Lisp_Compiled): Amend COMPILED_INTERACTIVE, introduce
COMPILED_DEFINIG_SYM.
* src/lread.c (defsubr): Set subr's defining_symbol field.
* test/Makefile.in (check-doit): Set
ert-batch-backtrace-right-margin to zero.
* test/lisp/emacs-lisp/bytecomp-tests.el
(bytecomp-function-attributes): Amend for the extra field in
the bytecomp structure.
* test/lisp/emacs-lisp/cconv-tests.el
(cconv-convert-lambda-lifted)
(cconv-closure-convert-remap-var): Amend the expected
structure of macro-expanded lambda expressions.
# Please enter the commit message for your changes. Lines starting
# with '#' will be ignored, and an empty message aborts the commit.
#
# On branch feature/named-lambdas
# Changes to be committed:
# modified: lisp/Makefile.in
# modified: lisp/emacs-lisp/byte-opt.el
# modified: lisp/emacs-lisp/byte-run.el
# modified: lisp/emacs-lisp/bytecomp.el
# modified: lisp/emacs-lisp/cconv.el
# modified: lisp/emacs-lisp/cl-generic.el
# modified: lisp/emacs-lisp/cl-macs.el
# modified: lisp/emacs-lisp/cl-print.el
# modified: lisp/emacs-lisp/comp.el
# modified: lisp/emacs-lisp/debug-early.el
# modified: lisp/emacs-lisp/ert.el
# modified: lisp/emacs-lisp/loaddefs-gen.el
# modified: lisp/emacs-lisp/macroexp.el
# modified: lisp/emacs-lisp/nadvice.el
# modified: lisp/emacs-lisp/oclosure.el
# modified: lisp/emacs-lisp/pcase.el
# modified: lisp/help.el
# modified: lisp/progmodes/compile.el
# modified: lisp/progmodes/elisp-mode.el
# modified: lisp/simple.el
# modified: lisp/subr.el
# modified: src/bytecode.c
# modified: src/comp.c
# modified: src/data.c
# modified: src/eval.c
# modified: src/lisp.h
# modified: src/lread.c
# modified: test/Makefile.in
# modified: test/lisp/emacs-lisp/bytecomp-tests.el
# modified: test/lisp/emacs-lisp/cconv-tests.el
#
# Untracked files:
# .gitignore.acm
# .gitignore.backup
# .timestamps.txt
# 20230315.outerr
# 20230317.parallel.out
# 20230320.outerr
# 20230322.parallel.out
# bytecomp.20230407.el.diff
# diff.20230228.diff
# diff.20230313b.diff
# diff.20230408.diff
# diff.20230608.diff
# diff.20230608b.diff
# diff.20230705.diff
# diff.20230706.diff
# diff.20230715.diff
# diff.20230716.diff
# diff.20230716b.diff
# doc/lispref/files.20201010.techsi
# find-quoted-lambdas.el
# lisp/diff.20230314.diff
# lisp/emacs-lisp/bo-primitives.el
# lisp/emacs-lisp/bytecomp.20230406.eeel
# lisp/emacs-lisp/bytecomp.20230407.eeel
# lisp/emacs-lisp/bytecomp.20230608.eeel
# lisp/emacs-lisp/bytecomp.20230608.no-b-c.eeel
# lisp/emacs-lisp/cconv.20230608.eeelsee
# lisp/emacs-lisp/cl-generic.20230716.eeelsee
# outerr.20230716.txt
# scratch.20230715.el
# src/diff.20230314.diff
# src/eval.20230518.see
# src/eval.20230716.see
# src/fingerprint.c
# src/syntax.20201010.see
# stderr.20230712.txt
# stdout.20230712.txt
#
---
lisp/Makefile.in | 2 +-
lisp/emacs-lisp/byte-opt.el | 12 ++-
lisp/emacs-lisp/byte-run.el | 127 ++++++++++++++++++-----
lisp/emacs-lisp/bytecomp.el | 181 +++++++++++++++++++++++----------
lisp/emacs-lisp/cconv.el | 70 +++++++++----
lisp/emacs-lisp/cl-generic.el | 54 +++++-----
lisp/emacs-lisp/cl-macs.el | 18 +++-
lisp/emacs-lisp/cl-print.el | 98 +++++++++++-------
lisp/emacs-lisp/comp.el | 90 ++++++++--------
lisp/emacs-lisp/debug-early.el | 4 +-
lisp/emacs-lisp/ert.el | 6 +-
lisp/emacs-lisp/loaddefs-gen.el | 4 +-
lisp/emacs-lisp/macroexp.el | 33 ++++--
lisp/emacs-lisp/nadvice.el | 53 ++++++++--
lisp/emacs-lisp/oclosure.el | 6 +-
lisp/emacs-lisp/pcase.el | 22 ++--
lisp/help.el | 10 +-
lisp/progmodes/compile.el | 10 +-
lisp/progmodes/elisp-mode.el | 14 ++-
lisp/simple.el | 6 +-
lisp/subr.el | 6 +-
src/bytecode.c | 11 +-
src/comp.c | 23 +++--
src/data.c | 35 ++++++-
src/eval.c | 53 ++++++++--
src/lisp.h | 4 +-
src/lread.c | 1 +
test/Makefile.in | 3 +-
test/lisp/emacs-lisp/bytecomp-tests.el | 2 +-
test/lisp/emacs-lisp/cconv-tests.el | 32 +++---
30 files changed, 692 insertions(+), 298 deletions(-)
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index 5af2168a827..011383ed358 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -60,7 +60,7 @@ EMACS = ../src/emacs${EXEEXT}
EMACSOPT = -batch --no-site-file --no-site-lisp
# Extra flags to pass to the byte compiler
-BYTE_COMPILE_EXTRA_FLAGS =
+BYTE_COMPILE_EXTRA_FLAGS = --eval "(setq debug-on-some-signals t
cl-print-compiled 'full)"
# For example to not display the undefined function warnings you can use this:
# BYTE_COMPILE_EXTRA_FLAGS = --eval '(setq byte-compile-warnings (quote (not
unresolved)))'
# The example above is just for developers, it should not be used by default.
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 26a1dc4a103..74e4a83c4a5 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -558,9 +558,17 @@ for speeding up processing.")
(cons (car h)
(byte-optimize--rename-var-body var new-var
(cdr h))))
handlers)))
- (`(internal-make-closure ,vars ,env . ,rest)
+ ((or `(internal-make-closure ,vars ,env
+ ,(and (pred (lambda (e) (and e (symbolp
e))))
+ def)
+ . ,rest)
+ (and
+ `(internal-make-closure ,vars ,env . ,rest)
+ (let def nil)))
`(,fn
- ,vars ,(byte-optimize--rename-var-body var new-var env) . ,rest))
+ ,vars ,(byte-optimize--rename-var-body var new-var env)
+ ,@(if def `(,def))
+ . ,rest))
(`(defvar ,name . ,rest)
;; NAME is not renamed here; we only care about lexical variables.
`(,fn ,name . ,(byte-optimize--rename-var-body var new-var rest)))
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index a377ec395e1..9c865613399 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -37,7 +37,9 @@ 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.")
(defalias 'byte-run--strip-list
- #'(lambda (arg)
+ #'(lambda
+ byte-run--strip-list
+ (arg)
"Strip the positions from symbols with position in the list ARG.
This is done by destructively modifying ARG. Return ARG."
(let ((a arg))
@@ -63,7 +65,9 @@ This is done by destructively modifying ARG. Return ARG."
arg)))
(defalias 'byte-run--strip-vector/record
- #'(lambda (arg)
+ #'(lambda
+ byte-run--strip-vector/record
+ (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)
@@ -84,7 +88,9 @@ This is done by destructively modifying ARG. Return ARG."
arg))
(defalias 'byte-run-strip-symbol-positions
- #'(lambda (arg)
+ #'(lambda
+ byte-run-strip-symbol-positions
+ (arg)
"Strip all positions from symbols in ARG.
This modifies destructively then returns ARG.
@@ -104,7 +110,9 @@ record, containing symbols with position."
;; 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
;; no such remapping, so we just call `put'.
- #'(lambda (function prop value)
+ #'(lambda
+ function-put
+ (function prop value)
"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."
@@ -121,27 +129,37 @@ So far, FUNCTION can only be a symbol, not a lambda
expression."
;; loaded before backquote.el.
(defalias 'byte-run--set-advertised-calling-convention
- #'(lambda (f _args arglist when)
+ #'(lambda
+ byte-run--set-advertised-calling-convention
+ (f _args arglist when)
(list 'set-advertised-calling-convention
(list 'quote f) (list 'quote arglist) (list 'quote when))))
(defalias 'byte-run--set-obsolete
- #'(lambda (f _args new-name when)
+ #'(lambda
+ byte-run--set-obsolete
+ (f _args new-name when)
(list 'make-obsolete
(list 'quote f) (list 'quote new-name) when)))
(defalias 'byte-run--set-interactive-only
- #'(lambda (f _args instead)
+ #'(lambda
+ byte-run--set-interactive-only
+ (f _args instead)
(list 'function-put (list 'quote f)
''interactive-only (list 'quote instead))))
(defalias 'byte-run--set-pure
- #'(lambda (f _args val)
+ #'(lambda
+ byte-run--set-pure
+ (f _args val)
(list 'function-put (list 'quote f)
''pure (list 'quote val))))
(defalias 'byte-run--set-side-effect-free
- #'(lambda (f _args val)
+ #'(lambda
+ byte-run--set-side-effect-free
+ (f _args val)
(list 'function-put (list 'quote f)
''side-effect-free (list 'quote val))))
@@ -154,7 +172,9 @@ So far, FUNCTION can only be a symbol, not a lambda
expression."
'(&or symbolp ("lambda" &define lambda-list lambda-doc def-body)))
(defalias 'byte-run--set-compiler-macro
- #'(lambda (f args compiler-function)
+ #'(lambda
+ byte-run--set-compiler-macro
+ (f args compiler-function)
(if (not (eq (car-safe compiler-function) 'lambda))
`(eval-and-compile
(function-put ',f 'compiler-macro #',compiler-function))
@@ -175,36 +195,48 @@ So far, FUNCTION can only be a symbol, not a lambda
expression."
,@(cdr data))))))))
(defalias 'byte-run--set-doc-string
- #'(lambda (f _args pos)
+ #'(lambda
+ byte-run--set-doc-string
+ (f _args pos)
(list 'function-put (list 'quote f)
''doc-string-elt (if (numberp pos)
pos
(list 'quote pos)))))
(defalias 'byte-run--set-indent
- #'(lambda (f _args val)
+ #'(lambda
+ byte-run--set-indent
+ (f _args val)
(list 'function-put (list 'quote f)
''lisp-indent-function (if (numberp val)
val
(list 'quote val)))))
(defalias 'byte-run--set-speed
- #'(lambda (f _args val)
+ #'(lambda
+ byte-run--set-speed
+ (f _args val)
(list 'function-put (list 'quote f)
''speed (list 'quote val))))
(defalias 'byte-run--set-completion
- #'(lambda (f _args val)
+ #'(lambda
+ byte-run--set-completion
+ (f _args val)
(list 'function-put (list 'quote f)
''completion-predicate (list 'function val))))
(defalias 'byte-run--set-modes
- #'(lambda (f _args &rest val)
+ #'(lambda
+ byte-run--set-modes
+ (f _args &rest val)
(list 'function-put (list 'quote f)
''command-modes (list 'quote val))))
(defalias 'byte-run--set-interactive-args
- #'(lambda (f args &rest val)
+ #'(lambda
+ byte-run--set-interactive-args
+ (f args &rest val)
(setq args (remove '&optional (remove '&rest args)))
(list 'function-put (list 'quote f)
''interactive-args
@@ -250,18 +282,24 @@ to set this property.
This is used by `declare'.")
(defalias 'byte-run--set-debug
- #'(lambda (name _args spec)
+ #'(lambda
+ byte-run--set-debug
+ (name _args spec)
(list 'progn :autoload-end
(list 'put (list 'quote name)
''edebug-form-spec (list 'quote spec)))))
(defalias 'byte-run--set-no-font-lock-keyword
- #'(lambda (name _args val)
+ #'(lambda
+ byte-run--set-no-font-lock-keyword
+ (name _args val)
(list 'function-put (list 'quote name)
''no-font-lock-keyword (list 'quote val))))
(defalias 'byte-run--parse-body
- #'(lambda (body allow-interactive)
+ #'(lambda
+ byte-run--parse-body
+ (body allow-interactive)
"Decompose BODY into (DOCSTRING DECLARE INTERACTIVE BODY-REST WARNINGS)."
(let* ((top body)
(docstring nil)
@@ -308,7 +346,9 @@ This is used by `declare'.")
(list docstring declare-form interactive-form body warnings))))
(defalias 'byte-run--parse-declarations
- #'(lambda (name arglist clauses construct declarations-alist)
+ #'(lambda
+ byte-run--parse-declarations
+ (name arglist clauses construct declarations-alist)
(let* ((cl-decls nil)
(actions
(mapcar
@@ -318,7 +358,7 @@ This is used by `declare'.")
(f (apply (car f) name arglist (cdr x)))
;; Yuck!!
((and (featurep 'cl)
- (memq (car x) ;C.f. cl--do-proclaim.
+ (memq (car x) ;C.f. cl--do-proclaim.
'(special inline notinline optimize warn)))
(push (list 'declare x) cl-decls)
nil)
@@ -347,7 +387,9 @@ This is used by `declare'.")
(defalias 'defmacro
(cons
'macro
- #'(lambda (name arglist &rest body)
+ #'(lambda
+ defmacro
+ (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
@@ -374,7 +416,10 @@ The return value is undefined.
(setq body (cons docstring body)))
(if (null body)
(setq body '(nil)))
- (let* ((fun (list 'function (cons 'lambda (cons arglist body))))
+ (let* ((fun (list 'function (cons 'lambda
+ (cons
+ (bare-symbol name)
+ (cons arglist body)))))
(def (list 'defalias
(list 'quote name)
(list 'cons ''macro fun))))
@@ -421,11 +466,37 @@ The return value is undefined.
(list 'quote name)
(list 'function
(cons 'lambda
- (cons arglist body))))))
- (if declarations
- (cons 'prog1 (cons def (car declarations)))
- def))))
-
+ (cons
+ (bare-symbol name)
+ (cons arglist body)
+ ))))))
+ (if declarations
+ (cons 'prog1 (cons def (car declarations)))
+ def))))
+
+(defmacro lambda-arglist (l)
+ "Given a lambda form L, return its arglist.
+Note that this takes into account the possible presence of a
+defining symbol field."
+ ;; `(if (and (cadr ,l) (symbolp (cadr ,l)))
+ ;; (caddr ,l)
+ ;; (cadr ,l))
+ (list 'if (list 'and (list 'car (list 'cdr l))
+ (list 'symbolp (list 'car (list 'cdr l))))
+ (list 'car (list 'cdr (list 'cdr l)))
+ (list 'car (list 'cdr l))))
+
+(defmacro lambda-body (l)
+ "Given a lambda form L, return its body.
+Note that this takes into account the possible presence of a
+defining symbol field."
+ ;; `(if (and (cadr ,l) (symbolp (cadr ,l)))
+ ;; (cdddr ,l)
+ ;; (cddr ,l))
+ (list 'if (list 'and (list 'car (list 'cdr l))
+ (list 'symbolp (list 'car (list 'cdr l))))
+ (list 'cdr (list 'cdr (list 'cdr l)))
+ (list 'cdr (list 'cdr l))))
;; Redefined in byte-opt.el.
;; This was undocumented and unused for decades.
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 489a9724fc4..e3210438a1b 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -1800,8 +1800,10 @@ It is too wide if it has any lines longer than the
largest of
(setq docs (nth 3 form)))
('lambda
(setq kind "") ; can't be "function", unfortunately
- (setq docs (and (stringp (nth 2 form))
- (nth 2 form)))))
+ (let* ((definer (and (cadr form) (symbolp (cadr form))))
+ (docstring (nth (if definer 3 2) form)))
+ (setq docs (and (stringp docstring)
+ docstring)))))
(when (and (consp name) (eq (car name) 'quote))
(setq name (cadr name)))
(setq name (if name (format " `%s' " name) ""))
@@ -2366,6 +2368,7 @@ With argument ARG, insert value in current buffer after
the form."
(byte-compile-tag-number 0)
(byte-compile-depth 0)
(byte-compile-maxdepth 0)
+ (defining-symbol t)
(byte-compile-output nil)
;; #### This is bound in b-c-close-variables.
;; (byte-compile-warnings byte-compile-warnings)
@@ -2429,7 +2432,10 @@ With argument ARG, insert value in current buffer after
the form."
(form (read-positioning-symbols inbuffer))
(warning (byte-run--unescaped-character-literals-warning)))
(when warning (byte-compile-warn-x form "%s" warning))
- (byte-compile-toplevel-file-form form)))
+ (byte-compile-toplevel-file-form form)
+ (when byte-compile-output
+ (byte-compile-flush-pending)))) ; To ensure pending
byte-code's get
+ ; the correct `defining-symbol'.
;; Compile pending forms at end of file.
(byte-compile-flush-pending)
(byte-compile-warn-about-unresolved-functions)))
@@ -2721,16 +2727,17 @@ list that represents a doc string reference.
(let ((sym (nth 1 form)))
(byte-compile--declare-var sym)
(if (eq (car form) 'defconst)
- (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)
- (setq form (copy-sequence form))
- (when (consp (nth 2 form))
- (setcar (cdr (cdr form))
- (byte-compile-top-level (nth 2 form) nil 'file)))
- form))
+ (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)
+ (setq form (copy-sequence form))
+ (when (consp (nth 2 form))
+ (setcar (cdr (cdr form))
+ (let ((defining-symbol sym))
+ (byte-compile-top-level (nth 2 form) nil 'file))))
+ form)))
(put 'define-abbrev-table 'byte-hunk-handler
'byte-compile-file-form-defvar-function)
@@ -2812,11 +2819,12 @@ list that represents a doc string reference.
(apply 'make-obsolete
(mapcar 'eval (cdr form)))))
-(defun byte-compile-file-form-defmumble (name macro arglist body rest)
+(defun byte-compile-file-form-defmumble (name macro arglist body defsym rest)
"Process a `defalias' for NAME.
If MACRO is non-nil, the definition is known to be a macro.
ARGLIST is the list of arguments, if it was recognized or t otherwise.
-BODY of the definition, or t if not recognized.
+BODY of the definition, or t if not recognized. DEFSYM is the defining
+symbol for the lambda, usually the same as NAME.
Return non-nil if everything went as planned, or nil to imply that it decided
not to take responsibility for the actual compilation of the code."
(let* ((this-kind (if macro 'byte-compile-macro-environment
@@ -2827,7 +2835,7 @@ not to take responsibility for the actual compilation of
the code."
(that-one (assq name (symbol-value that-kind)))
(bare-name (bare-symbol name))
(byte-compile-current-form name)) ; For warnings.
-
+ (setq defining-symbol (or defsym t))
(push bare-name byte-compile-new-defuns)
;; When a function or macro is defined, add it to the call tree so that
;; we can tell when functions are not used.
@@ -2900,7 +2908,9 @@ not to take responsibility for the actual compilation of
the code."
;; Tell the caller that we didn't compile it yet.
nil)
- (let* ((code (byte-compile-lambda (cons arglist body) t)))
+ (let* ((code (byte-compile-lambda (cons defining-symbol
+ (cons arglist body))
+ t)))
(if this-one
;; A definition in b-c-initial-m-e should always take precedence
;; during compilation, so don't let it be redefined. (Bug#8647)
@@ -2985,8 +2995,18 @@ If QUOTED is non-nil, print with quoting; otherwise,
print without quoting."
(defun byte-compile--reify-function (fun)
"Return an expression which will evaluate to a function value FUN.
FUN should be either a `lambda' value or a `closure' value."
- (pcase-let* (((or (and `(lambda ,args . ,body) (let env nil))
- `(closure ,env ,args . ,body))
+ (pcase-let* (((or (and
+ (or `(lambda ,(and
+ (pred (lambda (e) (and e (symbolp e))))
+ def)
+ ,args . ,body)
+ (and `(lambda ,args . ,body) (let def nil)))
+ (let env nil))
+ `(closure ,env ,(and
+ (pred (lambda (e) (and e (symbolp e))))
+ def)
+ ,args . ,body)
+ (and `(closure ,env ,args . ,body) (let def nil)))
fun)
(preamble nil)
(renv ()))
@@ -3004,8 +3024,11 @@ FUN should be either a `lambda' value or a `closure'
value."
((eq binding t))
(t (push `(defvar ,binding) body))))
(if (null renv)
- `(lambda ,args ,@preamble ,@body)
- `(let ,renv (lambda ,args ,@preamble ,@body)))))
+ `(lambda ,@(if def `(,def))
+ ,args ,@preamble ,@body)
+ `(let ,renv (lambda
+ ,@(if def `(,def))
+ ,args ,@preamble ,@body)))))
;;;###autoload
(defun byte-compile (form)
@@ -3031,7 +3054,8 @@ 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 ((defining-symbol t)
+ final-eval)
(when (or (symbolp form) (eq (car-safe fun) 'closure))
;; `fun' is a function *value*, so try to recover its
corresponding
;; source code.
@@ -3057,7 +3081,8 @@ If FORM is a lambda or a macro, byte-compile it as a
function."
"Compile and return SEXP."
(displaying-byte-compile-warnings
(byte-compile-close-variables
- (byte-compile-top-level (byte-compile-preprocess sexp)))))
+ (let ((defining-symbol t))
+ (byte-compile-top-level (byte-compile-preprocess sexp))))))
(defun byte-compile-check-lambda-list (list)
"Check lambda-list LIST for errors."
@@ -3150,15 +3175,20 @@ lambda-expression."
(setq fun (cons 'lambda fun))
(unless (eq 'lambda (car-safe fun))
(error "Not a lambda list: %S" fun)))
- (byte-compile-docstring-style-warn fun)
- (byte-compile-check-lambda-list (nth 1 fun))
- (let* ((arglist (nth 1 fun))
+ (let ((definer (and (car-safe (cdr-safe fun))
+ (symbolp (cadr fun))
+ (cadr fun))))
+ (byte-compile-docstring-style-warn fun)
+ (byte-compile-check-lambda-list (nth (if definer 2 1) fun))
+ (let* (
+ (fun1 (if definer (cdr fun) fun))
+ (arglist (nth 1 fun1))
(arglistvars (byte-run-strip-symbol-positions
(byte-compile-arglist-vars arglist)))
(byte-compile-bound-variables
(append (if (not lexical-binding) arglistvars)
byte-compile-bound-variables))
- (body (cdr (cdr fun)))
+ (body (cdr (cdr fun1)))
(doc (if (stringp (car body))
(prog1 (car body)
;; Discard the doc string
@@ -3167,6 +3197,10 @@ lambda-expression."
(setq body (cdr body))))))
(int (assq 'interactive body))
command-modes)
+ (setq defining-symbol (or (and (not (eq definer t))
+ definer)
+ defining-symbol
+ t))
(when lexical-binding
(dolist (var arglistvars)
(when (assq var byte-compile--known-dynamic-vars)
@@ -3231,8 +3265,9 @@ lambda-expression."
;; byte-compile-make-args-desc lost the args's
names,
;; so preserve them in the docstring.
(list (help-add-fundoc-usage doc bare-arglist)))
- ((or doc int)
- (list doc)))
+ (t (list doc)))
+ ;; The defining symbol.
+ `(,defining-symbol)
;; optionally, the interactive spec (and the modes the
;; command applies to).
(cond
@@ -3248,7 +3283,7 @@ lambda-expression."
(gethash (cadr compiled)
byte-to-native-lambdas-h))
out))
- out))))
+ out)))))
(defvar byte-compile-reserved-constants 0)
@@ -3301,6 +3336,7 @@ lambda-expression."
(byte-compile-tag-number 0)
(byte-compile-depth 0)
(byte-compile-maxdepth 0)
+ (defining-symbol t)
(byte-compile--lexical-environment lexenv)
(byte-compile-reserved-constants (or reserved-csts 0))
(byte-compile-output nil)
@@ -3400,9 +3436,16 @@ lambda-expression."
(not (delq nil (mapcar 'consp (cdr (car body))))))))
(setq rest (cdr rest)))
rest))
- (let ((byte-compile-vector (byte-compile-constants-vector)))
- (list 'byte-code (byte-compile-lapcode byte-compile-output)
- byte-compile-vector byte-compile-maxdepth)))
+ (let ((byte-compile-vector (byte-compile-constants-vector))
+ (definer-suffix
+ (and (eq output-type 'file)
+ defining-symbol
+ (not (eq defining-symbol t))
+ (symbolp defining-symbol)
+ `(',defining-symbol))))
+ (nconc (list 'byte-code (byte-compile-lapcode byte-compile-output)
+ byte-compile-vector byte-compile-maxdepth)
+ definer-suffix)))
;; it's a trivial function
((cdr body) (cons 'progn (nreverse body)))
((car body)))))
@@ -4212,13 +4255,21 @@ This function is never called when `lexical-binding' is
nil."
(if byte-compile--for-effect (setq byte-compile--for-effect nil)
(let* ((vars (nth 1 form))
(env (nth 2 form))
- (docstring-exp (nth 3 form))
- (body (nthcdr 4 form))
+ (def (and (symbolp (nth 3 form)) (nth 3 form)))
+ (docstring-exp (nth (if def 4 3) form))
+ (body (nthcdr (if def 5 4) form))
(fun
- (byte-compile-lambda `(lambda ,vars . ,body) nil (length env))))
+ (byte-compile-lambda `(lambda
+ ,defining-symbol
+ ,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))
+ (setq defining-symbol (or (and (not (eq def t))
+ def)
+ defining-symbol
+ t))
(byte-compile-form
(if (macroexp-const-p docstring-exp)
;; Use symbols V0, V1 ... as placeholders for closure variables:
@@ -4237,15 +4288,22 @@ This function is never called when `lexical-binding' is
nil."
;; to get the indices right when disassembling.
(vconcat dummy-vars (aref fun 2))
(aref fun 3) ; Stack depth of function
- (if docstring-exp
- (cons
- (eval (byte-run-strip-symbol-positions
- docstring-exp)
- t)
- (cdr opt-args)) ; The interactive spec will
- ; have been stripped in
- ; `byte-compile-lambda'.
- opt-args))))
+ (cond
+ (defining-symbol
+ (cons (if docstring-exp
+ (eval (byte-run-strip-symbol-positions
+ docstring-exp)
+ t)
+ (car opt-args))
+ (cons defining-symbol
+ (nthcdr 2 opt-args))))
+ (docstring-exp
+ (cons
+ (eval (byte-run-strip-symbol-positions
+ docstring-exp)
+ t)
+ (cdr opt-args)))
+ (t opt-args)))))
`(make-closure ,proto-fun ,@env))
;; Nontrivial doc string expression: create a bytecode object
;; from small pieces at run time.
@@ -4254,12 +4312,17 @@ This function is never called when `lexical-binding' is
nil."
',(aref fun 1) ; The byte-code.
(vconcat (vector . ,env) ',(aref fun 2)) ; constant vector.
,@(let ((rest (nthcdr 3 (mapcar (lambda (x) `',x) fun))))
- (if docstring-exp
- `(,(car rest)
- ,(byte-run-strip-symbol-positions docstring-exp)
- ,@(cddr rest))
- rest))))
- ))))
+ (cond
+ (defining-symbol
+ `(,(car rest)
+ ,(byte-run-strip-symbol-positions docstring-exp)
+ ',defining-symbol
+ ,@(nthcdr 3 rest)))
+ (docstring-exp
+ `(,(car rest)
+ ,(byte-run-strip-symbol-positions docstring-exp)
+ ,@(cddr rest)))
+ (t rest)))))))))
(defun byte-compile-get-closed-var (form)
"Byte-compile the special `internal-get-closed-var' form."
@@ -5190,6 +5253,7 @@ binding slots have been popped."
;; Delegate the actual work to the function version of the
;; special form, named with a "-1" suffix.
(byte-compile-form-do-effect
+ (let ((defining-symbol var))
(cond
((eq fun 'defconst) `(defconst-1 ',var ,@(nthcdr 2 form)))
((not (cddr form)) `',var) ; A simple (defvar foo) just returns foo.
@@ -5197,7 +5261,7 @@ binding slots have been popped."
;; Don't eval `value' if `defvar' wouldn't eval it either.
,(if (macroexp-const-p value) value
`(if (boundp ',var) nil ,value))
- ,@(nthcdr 3 form)))))))
+ ,@(nthcdr 3 form))))))))
(defun byte-compile-autoload (form)
(and (macroexp-const-p (nth 1 form))
@@ -5252,13 +5316,18 @@ binding slots have been popped."
fun)
;; `arglist' is the list of arguments (or t if not recognized).
;; `body' is the body of `lam' (or t if not recognized).
- ((or `(lambda ,arglist . ,body)
+ ((or `(lambda ,(and (pred (lambda (e)
+ (and e (symbolp e))))
+ def)
+ ,arglist . ,body)
+ (and `(lambda ,arglist . ,body) (let def nil))
;; `(closure ,_ ,arglist . ,body)
- (and `(internal-make-closure ,arglist . ,_) (let body t))
- (and (let arglist t) (let body t)))
+ (and `(internal-make-closure ,arglist . ,_) (let body t)
+ (let def nil))
+ (and (let arglist t) (let body t) (let def nil)))
lam))
(unless (byte-compile-file-form-defmumble
- name macro arglist body rest)
+ name macro arglist body def rest)
(when macro
(if (null fun)
(message "Macro %s unrecognized, won't work in file" name)
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 3e75020a013..95aefba8b66 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -167,8 +167,9 @@ 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)
- (cl-assert (equal body (caar cconv-freevars-alist)))
+(defun cconv--convert-function (args body env
+ defsym parentform &optional docstring)
+ ;; (cl-assert (equal body (caar cconv-freevars-alist))) ; STOUGH, 2023-02-21.
(let* ((fvs (cdr (pop cconv-freevars-alist)))
(body-new '())
(envector ())
@@ -198,10 +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 (lambda ,@(if defsym `(,defsym)) ,args . ,body-new)))
(t
`(internal-make-closure
- ,args ,envector ,docstring . ,body-new)))))
+ ,args ,envector
+ ,@(if defsym `(,defsym))
+ ,docstring . ,body-new)))))
(defun cconv--remap-llv (new-env var closedsym)
;; In a case such as:
@@ -362,13 +365,13 @@ places where they originally did not directly appear."
(progn
(cl-assert (and (eq (car value) 'function)
(eq (car (cadr value))
'lambda)))
- (cl-assert (equal (cddr (cadr value))
+ (cl-assert (equal (lambda-body (cadr value))
(caar cconv-freevars-alist)))
;; Peek at the freevars to decide whether
;; to λ-lift.
(let* ((fvs (cdr (car cconv-freevars-alist)))
(fun (cadr value))
- (funargs (cadr fun))
+ (funargs (lambda-arglist fun))
(funcvars (append fvs funargs)))
; lambda lifting condition
(and fvs (>= cconv-liftwhen
@@ -376,9 +379,12 @@ places where they originally did not directly appear."
; Lift.
(let* ((fvs (cdr (pop cconv-freevars-alist)))
(fun (cadr value))
- (funargs (cadr fun))
+ (func-defsym (or (and (symbolp (cadr fun))
+ (cadr fun))
+ t))
+ (funargs (lambda-arglist fun))
(funcvars (append fvs funargs))
- (funcbody (cddr fun))
+ (funcbody (lambda-body fun))
(funcbody-env ()))
(push `(,var . (apply-partially ,var . ,fvs)) new-env)
(dolist (fv fvs)
@@ -387,7 +393,7 @@ places where they originally did not directly appear."
(cdr (assq fv env))))
(not (memq fv funargs)))
(push `(,fv . (car-safe ,fv)) funcbody-env)))
- `(function (lambda ,funcvars .
+ `(function (lambda ,func-defsym ,funcvars .
,(cconv--convert-funcbody
funargs funcbody funcbody-env
value)))))
@@ -477,7 +483,11 @@ places where they originally did not directly appear."
branch))
cond-forms)))
- (`(function (lambda ,args . ,body) . ,rest)
+ (`(function
+ ,(or `(lambda ,(and (pred (lambda (e) (and e (symbolp e)))) def)
+ ,args . ,body)
+ (and `(lambda ,args . ,body) (let def nil)))
+ . ,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))
@@ -510,7 +520,7 @@ places where they originally did not directly appear."
;; 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 def form docstring))
(if (not cif)
;; Normal case, the interactive form needs no special treatment.
cf
@@ -562,7 +572,9 @@ places where they originally did not directly appear."
(`(unwind-protect ,form1 . ,body)
`(,(car form) ,(cconv-convert form1 env extend)
- :fun-body ,(cconv--convert-function () body env form1)))
+ :fun-body ,(cconv--convert-function () body env
+ (or defining-symbol t)
+ form1)))
(`(setq ,var ,expr)
(let ((var-new (or (cdr (assq var env)) var))
@@ -751,6 +763,20 @@ This function does not return anything but instead fills
the
(dolist (vardata newvars)
(cconv--analyze-use vardata form "variable"))))
+ (`(function (lambda ,(pred (lambda (e) (and e (symbolp e))))
+ ,vrs . ,body-forms))
+ (when (eq :documentation (car-safe (car body-forms)))
+ (cconv-analyze-form (cadr (pop body-forms)) env))
+ (let ((bf (if (stringp (car body-forms)) (cdr body-forms) body-forms)))
+ (when (eq 'interactive (car-safe (car bf)))
+ (let ((if (cadr (car bf))))
+ (unless (macroexp-const-p if) ;Optimize this common case.
+ (let ((f (if (eq 'function (car-safe if)) if
+ `#'(lambda (&rest _cconv--dummy) ,if))))
+ (setf (gethash form cconv--interactive-form-funs) f)
+ (cconv-analyze-form f env))))))
+ (cconv--analyze-function vrs body-forms env form))
+
(`(function (lambda ,vrs . ,body-forms))
(when (eq :documentation (car-safe (car body-forms)))
(cconv-analyze-form (cadr (pop body-forms)) env))
@@ -872,7 +898,7 @@ lexically and dynamically bound symbols actually used by
FORM."
(cconv--dynbindings nil)
(cconv-freevars-alist '())
(cconv-var-classification '()))
- (let* ((body (cddr (cadr fun))))
+ (let* ((body (lambda-body (cadr fun))))
;; Analyze form - fill these variables with new information.
(cconv-analyze-form fun analysis-env)
(setq cconv-freevars-alist (nreverse cconv-freevars-alist))
@@ -899,21 +925,29 @@ i.e. a list whose elements can be either plain symbols
(which indicate
that this symbol should use dynamic scoping) or pairs (SYMBOL . VALUE)
for the lexical bindings."
(cl-assert (eq (car-safe fun) 'lambda))
- (let ((lexvars (delq nil (mapcar #'car-safe env))))
+ (let ((lexvars (delq nil (mapcar #'car-safe env)))
+ (defsym (and (car-safe (cdr-safe fun))
+ (symbolp (cadr fun))
+ (cadr fun))))
(if (or (null lexvars)
;; Functions with a `:closure-dont-trim-context' marker
;; should keep their whole context untrimmed (bug#59213).
- (and (eq :closure-dont-trim-context (nth 2 fun))
+ (and (eq :closure-dont-trim-context
+ (car (lambda-body fun)))
;; Check the function doesn't just return the magic keyword.
- (nthcdr 3 fun)))
+ (cdr (lambda-body fun))))
;; The lexical environment is empty, or needs to be preserved,
;; so there's no need to look for free variables.
;; Attempting to replace ,(cdr fun) by a macroexpanded version
;; causes bootstrap to fail.
- `(closure ,env . ,(cdr fun))
+ `(closure ,env
+ ,(or defsym defining-symbol t)
+ ,(lambda-arglist fun) . ,(lambda-body fun))
;; We could try and cache the result of the macroexpansion and
;; `cconv-fv' analysis. Not sure it's worth the trouble.
- (let* ((form `#',fun)
+ (let* ((form `#'(lambda ,(or defsym defining-symbol t)
+ ,(lambda-arglist fun)
+ . ,(lambda-body fun)))
(expanded-form
(let ((lexical-binding t) ;; Tell macros which dialect is in use.
;; Make the macro aware of any defvar declarations in scope.
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index b062c280a41..5ff1bcfa471 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -337,7 +337,7 @@ DEFAULT-BODY, if present, is used as the body of a default
method.
(setf (cl--generic-dispatches generic)
(cons dispatch (delq dispatch dispatches)))))))
(setf (cl--generic-options generic) options)
- (cl--generic-make-function generic)))
+ (cl--generic-make-function generic name)))
(defmacro cl-generic-current-method-specializers ()
"List of (VAR . TYPE) where TYPE is var's specializer.
@@ -387,7 +387,7 @@ the specializer used will be the one returned by BODY."
(cons (nreverse specializers)
(nreverse (delq nil plain-args)))))
- (defun cl--generic-lambda (args body)
+ (defun cl--generic-lambda (defsym args body)
"Make the lambda expression for a method with ARGS and BODY."
(pcase-let* ((`(,spec-args . ,plain-args)
(cl--generic-split-args args))
@@ -402,7 +402,9 @@ the specializer used will be the one returned by BODY."
;; First macroexpand away the cl-function stuff (e.g. &key and
;; destructuring args, `declare' and whatnot).
(pcase (macroexpand fun macroenv)
- (`#'(lambda ,args . ,body)
+ ((or `#'(lambda ,(and (pred (lambda (e) (and e (symbolp e)))) def)
+ ,args . ,body)
+ (and `#'(lambda ,args . ,body) (let def nil)))
(let* ((parsed-body (macroexp-parse-body body))
(nm (make-symbol "cl--nm"))
(arglist (make-symbol "cl--args"))
@@ -423,12 +425,12 @@ the specializer used will be the one returned by BODY."
(cond
((not uses-cnm)
(cons nil
- `#'(lambda (,@args)
+ `#'(lambda ,defsym (,@args)
,@(car parsed-body)
,nbody)))
(lexical-binding
(cons 'curried
- `#'(lambda (,nm) ;Called when constructing the effective
method.
+ `#'(lambda ,defsym (,nm) ;Called when constructing the
effective method.
(let ((,nmp (if (cl--generic-isnot-nnm-p ,nm)
#'always #'ignore)))
;; This `(λ (&rest x) .. (apply (λ (args) ..) x))'
@@ -464,17 +466,16 @@ the specializer used will be the one returned by BODY."
(apply (lambda (,@λ-lift ,@args) ,nbody)
,@λ-lift ,arglist)))))))
(t
- (cons t
- `#'(lambda (,cnm ,@args)
- ,@(car parsed-body)
- ,(macroexp-warn-and-return
- "cl-defmethod used without lexical-binding"
- (if (not (assq nmp uses-cnm))
- nbody
- `(let ((,nmp (lambda ()
- (cl--generic-isnot-nnm-p ,cnm))))
- ,nbody))
- 'lexical t)))))
+ (cons t `#'(lambda ,defsym (,cnm ,@args)
+ ,@(car parsed-body)
+ ,(macroexp-warn-and-return
+ "cl-defmethod used without lexical-binding"
+ (if (not (assq nmp uses-cnm))
+ nbody
+ `(let ((,nmp (lambda ()
+ (cl--generic-isnot-nnm-p ,cnm))))
+ ,nbody))
+ 'lexical t)))))
))
(f (error "Unexpected macroexpansion result: %S" f))))))
@@ -572,7 +573,9 @@ The set of acceptable TYPEs (also called \"specializers\")
is defined
(require 'gv)
(declare-function gv-setter "gv" (name))
(setq name (gv-setter (cadr name))))
- (pcase-let* ((`(,call-con . ,fun) (cl--generic-lambda args body)))
+ (pcase-let* ((`(,call-con . ,fun) (cl--generic-lambda
+ (bare-symbol name)
+ args body)))
`(progn
;; You could argue that `defmethod' modifies rather than defines the
;; function, so warnings like "not known to be defined" are fair game.
@@ -643,7 +646,7 @@ The set of acceptable TYPEs (also called \"specializers\")
is defined
(let ((sym (cl--generic-name generic)) ; Actual name (for aliases).
;; FIXME: Try to avoid re-constructing a new function if the old one
;; is still valid (e.g. still empty method cache)?
- (gfun (cl--generic-make-function generic)))
+ (gfun (cl--generic-make-function generic name)))
(unless (symbol-function sym)
(defalias sym 'dummy)) ;Record definition into load-history.
(cl-pushnew `(cl-defmethod . ,(cl--generic-load-hist-format
@@ -681,7 +684,7 @@ The set of acceptable TYPEs (also called \"specializers\")
is defined
;; see `cl--generic-prefill-dispatchers'.
#'byte-compile))
-(defun cl--generic-get-dispatcher (dispatch)
+(defun cl--generic-get-dispatcher (dispatch &optional name)
(with-memoization
;; We need `copy-sequence` here because this `dispatch' object might be
;; modified by side-effect in `cl-generic-define-method' (bug#46722).
@@ -745,7 +748,9 @@ You might need to add: %S"
cl--generic-compiler
`(lambda (generic dispatches-left methods)
(let ((method-cache (make-hash-table :test #'eql)))
- (lambda (,@fixedargs &rest args)
+ (lambda
+ ,(or name 'cl--generic-get-dispatcher)
+ (,@fixedargs &rest args)
(let ,bindings
(apply (with-memoization
(gethash ,tag-exp method-cache)
@@ -755,12 +760,13 @@ You might need to add: %S"
`(append ,@typescodes) (car typescodes))))
,@fixedargs args)))))))))
-(defun cl--generic-make-function (generic)
+(defun cl--generic-make-function (generic &optional name)
(cl--generic-make-next-function generic
(cl--generic-dispatches generic)
- (cl--generic-method-table generic)))
+ (cl--generic-method-table generic)
+ name))
-(defun cl--generic-make-next-function (generic dispatches methods)
+(defun cl--generic-make-next-function (generic dispatches methods &optional
name)
(let* ((dispatch
(progn
(while (and dispatches
@@ -774,7 +780,7 @@ You might need to add: %S"
;; further arguments.
methods))
(cl--generic-build-combined-method generic methods)
- (let ((dispatcher (cl--generic-get-dispatcher dispatch)))
+ (let ((dispatcher (cl--generic-get-dispatcher dispatch name)))
(funcall dispatcher generic dispatches methods)))))
(defvar cl--generic-combined-method-memoization
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 0a3181561bd..23ca692a131 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2255,7 +2255,9 @@ details.
(lambda (bind)
(pcase-let*
((`(,var ,sargs . ,sbody) bind)
- (`(function (lambda ,fargs . ,ebody))
+ (`(function ,(or `(lambda ,(pred (lambda (e) (and e
(symbolp e))))
+ ,fargs . ,ebody)
+ `(lambda ,fargs . ,ebody)))
(macroexpand-all `(cl-function (lambda ,sargs .
,sbody))
newenv))
(`(,ofargs . ,obody)
@@ -2314,6 +2316,11 @@ This is like `cl-flet', but for macros instead of
functions.
(while (not (eq exp (setq exp (macroexpand-1 exp env)))))
exp)
+;; pcase-n functions must not be created in `cl--sm-macroexpand-1',
+;; because of infinite recursion.
+(eval-when-compile (defvar save-p-m-d pcase-max-duplicates)
+ (setq save-p-m-d pcase-max-duplicates)
+ (setq pcase-max-duplicates nil))
(defun cl--sm-macroexpand-1 (orig-fun exp &optional env)
"Special macro expander advice used inside `cl-symbol-macrolet'.
This function extends `macroexpand-1' during macro expansion
@@ -2399,7 +2406,10 @@ of `cl-symbol-macrolet' to additionally expand symbol
macros."
exp)))
;; Do the same as for `let' but for variables introduced
;; via other means, such as `lambda' and `condition-case'.
- (`(function (lambda ,args . ,body))
+ (`(function
+ ,(or `(lambda ,(and (pred (lambda (e) (and e (symbolp e)))) def)
+ ,args . ,body)
+ (and `(lambda ,args . ,body) (let def nil))))
(let ((nargs ()) (found nil))
(dolist (var args)
(push (cond
@@ -2414,7 +2424,8 @@ of `cl-symbol-macrolet' to additionally expand symbol
macros."
nargs))
(if found
`(function
- (lambda ,(nreverse nargs)
+ (lambda
+ ,@(if def `(,def)) ,(nreverse nargs)
. ,(mapcar (lambda (exp)
(macroexpand-all exp env))
body)))
@@ -2433,6 +2444,7 @@ of `cl-symbol-macrolet' to additionally expand symbol
macros."
(cdr clause))))
clauses))))
(_ exp))))
+(eval-when-compile (setq pcase-max-duplicates save-p-m-d))
;;;###autoload
(defmacro cl-symbol-macrolet (bindings &rest body)
diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 71929caabb8..06c4f092d15 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -69,7 +69,17 @@ Print the contents hidden by the ellipsis to STREAM."
(if (and cl-print--depth (natnump print-level)
(> cl-print--depth print-level))
(cl-print-insert-ellipsis object nil stream)
- (let ((car (pop object)))
+ (let ((car (pop object))
+ defsym)
+ (cond
+ ((eq car 'lambda)
+ (setq defsym (car-safe object)))
+ ((eq car 'closure)
+ (setq defsym (car-safe (cdr-safe object)))))
+ (when (and defsym (not (eq defsym t)) (symbolp defsym))
+ (princ "{" stream)
+ (prin1 defsym stream)
+ (princ "} " stream))
(if (and print-quoted
(memq car '(\, quote function \` \,@ \,.))
(consp object)
@@ -165,6 +175,7 @@ Print the contents hidden by the ellipsis to STREAM."
(defvar cl-print-compiled nil
"Control how to print byte-compiled functions.
Acceptable values include:
+- `full' to print out the full contents of the function using `prin1'.
- `static' to print the vector of constants.
- `disassemble' to print the disassembly of the code.
- nil to skip printing any details about the code.")
@@ -181,48 +192,63 @@ into a button whose action shows the function's
disassembly.")
(cl-defmethod cl-print-object ((object compiled-function) stream)
(unless stream (setq stream standard-output))
+ (let ((defsym
+ (cond
+ ((subrp object)
+ (subr-native-defining-symbol object))
+ ((> (length object) 5)
+ (aref object 5)))))
+ (when (and defsym (not (eq defsym t)) (symbolp defsym))
+ (princ "{" stream)
+ (;; cl-
+ prin1 defsym stream)
+ (princ "} " stream)))
;; We use "#f(...)" rather than "#<...>" so that pp.el gives better results.
(princ "#f(compiled-function " stream)
(let ((args (help-function-arglist object 'preserve-names)))
(if args
(prin1 args stream)
(princ "()" stream)))
- (pcase (help-split-fundoc (documentation object 'raw) object)
- ;; Drop args which `help-function-arglist' already printed.
- (`(,_usage . ,(and doc (guard (stringp doc))))
- (princ " " stream)
- (prin1 doc stream)))
- (let ((inter (interactive-form object)))
- (when inter
- (princ " " stream)
- (cl-print-object
- (if (eq 'byte-code (car-safe (cadr inter)))
- `(interactive ,(make-byte-code nil (nth 1 (cadr inter))
- (nth 2 (cadr inter))
- (nth 3 (cadr inter))))
- inter)
- stream)))
- (if (eq cl-print-compiled 'disassemble)
- (princ
- (with-temp-buffer
- (insert "\n")
- (disassemble-1 object 0)
- (buffer-string))
- stream)
- (princ " " stream)
- (let ((button-start (and cl-print-compiled-button
- (bufferp stream)
- (with-current-buffer stream (point)))))
- (princ (format "#<bytecode %#x>" (sxhash object)) stream)
- (when (eq cl-print-compiled 'static)
+ (if (eq cl-print-compiled 'full)
+ (progn
+ (princ " " stream)
+ (prin1 object stream))
+ (pcase (help-split-fundoc (documentation object 'raw) object)
+ ;; Drop args which `help-function-arglist' already printed.
+ (`(,_usage . ,(and doc (guard (stringp doc))))
+ (princ " " stream)
+ (prin1 doc stream)))
+ (let ((inter (interactive-form object)))
+ (when inter
(princ " " stream)
- (cl-print-object (aref object 2) stream))
- (when button-start
- (with-current-buffer stream
- (make-text-button button-start (point)
- :type 'help-byte-code
- 'byte-code-function object)))))
- (princ ")" stream))
+ (cl-print-object
+ (if (eq 'byte-code (car-safe (cadr inter)))
+ `(interactive ,(make-byte-code nil (nth 1 (cadr inter))
+ (nth 2 (cadr inter))
+ (nth 3 (cadr inter))))
+ inter)
+ stream)))
+ (if (eq cl-print-compiled 'disassemble)
+ (princ
+ (with-temp-buffer
+ (insert "\n")
+ (disassemble-1 object 0)
+ (buffer-string))
+ stream)
+ (princ " " stream)
+ (let ((button-start (and cl-print-compiled-button
+ (bufferp stream)
+ (with-current-buffer stream (point)))))
+ (princ (format "#<bytecode %#x>" (sxhash object)) stream)
+ (when (eq cl-print-compiled 'static)
+ (princ " " stream)
+ (cl-print-object (aref object 2) stream))
+ (when button-start
+ (with-current-buffer stream
+ (make-text-button button-start (point)
+ :type 'help-byte-code
+ 'byte-code-function object)))))
+ (princ ")" stream)))
;; This belongs in oclosure.el, of course, but some load-ordering issues make
it
;; complicated.
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 4892733d456..f228523d801 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -983,7 +983,10 @@ CFG is mutated by a pass.")
(pure nil :type boolean
:documentation "t if pure nil otherwise.")
(type nil :type (or null comp-mvar)
- :documentation "Mvar holding the derived return type."))
+ :documentation "Mvar holding the derived return type.")
+ (defining-symbol nil :type symbol
+ :documentation "The symbol (usually of a defun) where the
+function was defined."))
(cl-defstruct (comp-func-l (:include comp-func))
"Lexically-scoped function."
@@ -1309,7 +1312,8 @@ clashes."
:command-modes (command-modes f)
:speed (comp-spill-speed function-name)
:pure (comp-spill-decl-spec function-name
- 'pure))))
+ 'pure)
+ :defining-symbol function-name)))
(when (byte-code-function-p f)
(signal 'native-compiler-error
'("can't native compile an already byte-compiled function")))
@@ -1342,17 +1346,21 @@ clashes."
(make-temp-file "comp-lambda-" nil ".eln")))
(let* ((byte-code (byte-compile form))
(c-name (comp-c-func-name "anonymous-lambda" "F"))
+ (defsym (and (> (length byte-code) 5)
+ (aref byte-code 5)))
(func (if (comp-lex-byte-func-p byte-code)
(make-comp-func-l :c-name c-name
:doc (documentation form t)
:int-spec (interactive-form form)
:command-modes (command-modes form)
- :speed (comp-ctxt-speed comp-ctxt))
+ :speed (comp-ctxt-speed comp-ctxt)
+ :defining-symbol defsym)
(make-comp-func-d :c-name c-name
:doc (documentation form t)
:int-spec (interactive-form form)
:command-modes (command-modes form)
- :speed (comp-ctxt-speed comp-ctxt)))))
+ :speed (comp-ctxt-speed comp-ctxt)
+ :defining-symbol defsym))))
(let ((lap (byte-to-native-lambda-lap
(gethash (aref byte-code 1)
byte-to-native-lambdas-h))))
@@ -1361,7 +1369,7 @@ clashes."
(if (comp-func-l-p func)
(setf (comp-func-l-args func)
(comp-decrypt-arg-list (aref byte-code 0) byte-code))
- (setf (comp-func-d-lambda-list func) (cadr form)))
+ (setf (comp-func-d-lambda-list func) (lambda-arglist form)))
(setf (comp-func-lap func) lap
(comp-func-frame-size func) (comp-byte-frame-size
byte-code))
@@ -1453,6 +1461,7 @@ clashes."
(defun comp-spill-lap (input)
"Byte-compile and spill the LAP representation for INPUT.
If INPUT is a symbol, it is the function-name to be compiled.
+If INPUT is a lambda form, it is compiled as such.
If INPUT is a string, it is the filename to be compiled."
(let* ((byte-native-compiling t)
(byte-to-native-lambdas-h (make-hash-table :test #'eq))
@@ -2161,7 +2170,8 @@ and the annotation emission."
(comp-func-command-modes f)))
;; This is the compilation unit it-self passed as
;; parameter.
- (make-comp-mvar :slot 0))))))
+ (make-comp-mvar :slot 0)
+ (make-comp-mvar :constant name))))))
(cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)
for-late-load)
@@ -2205,7 +2215,9 @@ These are stored in the reloc data array."
(comp-func-command-modes func)))
;; This is the compilation unit it-self passed as
;; parameter.
- (make-comp-mvar :slot 0)))))
+ (make-comp-mvar :slot 0)
+ (make-comp-mvar :constant
+ (comp-func-defining-symbol func))))))
(defun comp-limplify-top-level (for-late-load)
"Create a Limple function to modify the global environment at load.
@@ -2233,7 +2245,10 @@ into the C code forwarding the compilation unit."
;; the last function being
;; registered.
:frame-size 2
- :speed (comp-ctxt-speed comp-ctxt)))
+ :speed (comp-ctxt-speed comp-ctxt)
+ :defining-symbol (if for-late-load
+ 'late_top_level_run
+ 'top_level_run)))
(comp-func func)
(comp-pass (make-comp-limplify
:curr-block (make--comp-block-lap -1 0 'top-level)
@@ -4156,45 +4171,26 @@ the deferred compilation mechanism."
(comp-log "\n \n" 1)
(unwind-protect
(progn
- (condition-case err
- (cl-loop
- with report = nil
- for t0 = (current-time)
- for pass in comp-passes
- unless (memq pass comp-disabled-passes)
- do
- (comp-log (format "(%s) Running pass %s:\n"
- function-or-file pass)
- 2)
- (setf data (funcall pass data))
- (push (cons pass (float-time (time-since t0))) report)
- (cl-loop for f in (alist-get pass comp-post-pass-hooks)
- do (funcall f data))
- finally
- (when comp-log-time-report
- (comp-log (format "Done compiling %s" data) 0)
- (cl-loop for (pass . time) in (reverse report)
- do (comp-log (format "Pass %s took: %fs."
- pass time) 0))))
- (native-compiler-skip)
- (t
- (let ((err-val (cdr err)))
- ;; If we are doing an async native compilation print the
- ;; error in the correct format so is parsable and abort.
- (if (and comp-async-compilation
- (not (eq (car err) 'native-compiler-error)))
- (progn
- (message (if err-val
- "%s: Error: %s %s"
- "%s: Error %s")
- function-or-file
- (get (car err) 'error-message)
- (car-safe err-val))
- (kill-emacs -1))
- ;; Otherwise re-signal it adding the compilation input.
- (signal (car err) (if (consp err-val)
- (cons function-or-file err-val)
- (list function-or-file err-val)))))))
+ (cl-loop
+ with report = nil
+ for t0 = (current-time)
+ for pass in comp-passes
+ unless (memq pass comp-disabled-passes)
+ do
+ (comp-log (format "(%s) Running pass %s:\n"
+ function-or-file pass)
+ 2)
+ (setf data (funcall pass data))
+ (push (cons pass (float-time (time-since t0))) report)
+ (cl-loop for f in (alist-get pass comp-post-pass-hooks)
+ do (funcall f data))
+ finally
+ (when comp-log-time-report
+ (comp-log (format "Done compiling %s" data) 0)
+ (cl-loop for (pass . time) in (reverse report)
+ do (comp-log (format "Pass %s took: %fs."
+ pass time)
+ 0))))
(if (stringp function-or-file)
data
;; So we return the compiled function.
diff --git a/lisp/emacs-lisp/debug-early.el b/lisp/emacs-lisp/debug-early.el
index e393daee879..55fd55f1a39 100644
--- a/lisp/emacs-lisp/debug-early.el
+++ b/lisp/emacs-lisp/debug-early.el
@@ -34,7 +34,7 @@
;;; Code:
(defalias 'debug-early-backtrace
- #'(lambda ()
+ #'(lambda debug-early-backtrace ()
"Print a trace of Lisp function calls currently active.
The output stream used is the value of `standard-output'.
@@ -71,7 +71,7 @@ of the build process."
(princ ")\n")))))))
(defalias 'debug-early
- #'(lambda (&rest args)
+ #'(lambda debug-early (&rest args)
"Print an error message with a backtrace of active Lisp function calls.
The output stream used is the value of `standard-output'.
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index be9f013ebcf..96b7fe3b400 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -70,12 +70,12 @@
:prefix "ert-"
:group 'lisp)
-(defcustom ert-batch-backtrace-right-margin 70
+(defcustom ert-batch-backtrace-right-margin nil ; 70 STOUGH, 2023-06-09
"Maximum length of lines in ERT backtraces in batch mode.
Use nil for no limit (caution: backtrace lines can be very long)."
:type '(choice (const :tag "No truncation" nil) integer))
-(defvar ert-batch-print-length 10
+(defvar ert-batch-print-length nil ; 10 STOUGH, 2023-06-09
"`print-length' setting used in `ert-run-tests-batch'.
When formatting lists in test conditions, `print-length' will be
@@ -83,7 +83,7 @@ temporarily set to this value. See also
`ert-batch-backtrace-line-length' for its effect on stack
traces.")
-(defvar ert-batch-print-level 5
+(defvar ert-batch-print-level nil ; 5 STOUGH, 2023-06-09
"`print-level' setting used in `ert-run-tests-batch'.
When formatting lists in test conditions, `print-level' will be
diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el
index 5db9af21508..fa3436bfd1e 100644
--- a/lisp/emacs-lisp/loaddefs-gen.el
+++ b/lisp/emacs-lisp/loaddefs-gen.el
@@ -162,7 +162,9 @@ expression, in which case we want to handle forms
differently."
(lam (if (memq (car-safe fun) '(quote function)) (cadr fun)))
;; `args' is the list of arguments (or t if not recognized).
;; `body' is the body of `lam' (or t if not recognized).
- ((or `(lambda ,args . ,body)
+ ((or `(lambda ,(pred (lambda (e) (and e (symbolp e))))
+ ,args . ,body)
+ `(lambda ,args . ,body)
(and (let args t) (let body t)))
lam)
;; Get the `doc' from `body' or `rest'.
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 290bf1c933a..4f23fd379e5 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -247,8 +247,8 @@ It should normally be a symbol with position and it
defaults to FORM."
(or name (setq name "anonymous lambda"))
(pcase form
((or `(funcall (function ,lambda) . ,actuals) `(,lambda . ,actuals))
- (let* ((formals (nth 1 lambda))
- (body (cdr (macroexp-parse-body (cddr lambda))))
+ (let* ((formals (lambda-arglist lambda))
+ (body (cdr (macroexp-parse-body (lambda-body lambda))))
optionalp restp
(dynboundarg nil)
bindings)
@@ -332,6 +332,16 @@ Assumes the caller has bound
`macroexpand-all-environment'."
;; I tried it, it broke the bootstrap :-(
(let ((fn (car-safe form)))
(pcase form
+ (`(defalias ,(and `(quote ,def)
+ (pred (lambda (e) (and e (symbolp e)))))
+ . ,_rest)
+ (let ((defining-symbol def))
+ (macroexp--all-forms form 2)))
+ (`(,(or `defvar `defconst)
+ ,(and def (pred (lambda (e) (and e (symbolp e)))))
+ . ,(and _rest (pred (not null))))
+ (let ((defining-symbol def))
+ (macroexp--all-forms form 2)))
(`(cond . ,clauses)
(macroexp--cons fn (macroexp--all-clauses clauses) form))
(`(condition-case . ,(or `(,err ,body . ,handlers)
pcase--dontcare))
@@ -351,10 +361,15 @@ Assumes the caller has bound
`macroexpand-all-environment'."
(`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_)
(push name macroexp--dynvars)
(macroexp--all-forms form 2))
- (`(function ,(and f `(lambda . ,_)))
- (let ((macroexp--dynvars macroexp--dynvars))
+ (`(function ,(and f (or `(lambda
+ ,(and def
+ (pred (lambda (e) (and e (symbolp
e)))))
+ . ,_)
+ (and `(lambda . ,_) (let def nil)))))
+ (let ((defining-symbol def)
+ (macroexp--dynvars macroexp--dynvars))
(macroexp--cons fn
- (macroexp--cons (macroexp--all-forms f 2)
+ (macroexp--cons (macroexp--all-forms f (if def
3 2))
nil
(cdr form))
form)))
@@ -432,8 +447,12 @@ Assumes the caller has bound
`macroexpand-all-environment'."
(push assignment assignments))
(setq args (cddr args)))
(cons 'progn (nreverse assignments))))))
- (`(,(and fun `(lambda . ,_)) . ,args)
- (macroexp--cons (macroexp--all-forms fun 2)
+ (`(,(and fun `(lambda . ,_))
+ (or `(lambda ,(and (pred (lambda (e) (and e (symbolp e)))) def)
+ . ,_)
+ (and `(lambda . ,_) (let def nil)))
+ . ,args)
+ (macroexp--cons (macroexp--all-forms fun (if def 3 2))
(macroexp--all-forms args)
form))
(`(funcall ,exp . ,args)
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el
index cd80df2c41d..7700927bd67 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -257,16 +257,54 @@ 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.
+ (equal (aref function 4) (aref adv 4)) ; Doc string.
+ (or (< (length function) 6)
+ (< (length adv) 6)
+ (symbolp (aref function 5)) ; Is element 5 the defining-symbol...
+ (symbolp (aref adv 5)) ; ...(or absent)?
+ (equal (aref function 5) (aref adv 5))) ; It's an interactive
spec.
+ (or (< (length function) 7)
+ (< (length adv) 7)
+ (equal (aref function 6) (aref adv 6))) ; Interactive spec (new
format).
+ adv))
+ ((and (consp function)
+ (consp adv)) ; Interpreted functions.
+ (and (equal function adv) ; FIXME!!! Flesh this out!
+ 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))
+ ;; (message "advice--member-p: function: %S" function)
(while (and (not found) (advice--p definition))
+ ;; (message "advice--member-p: elt: %S" (advice--car 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,7 +326,8 @@ 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)
+ ((or (advice--equal
+ function first)
(equal function (cdr (assq 'name props))))
(list (advice--remove-function rest function)))))))
diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index 40f1f54eed0..29b69b0cd8c 100644
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -442,8 +442,10 @@ This has 2 uses:
;; stuff it into the environment part of the closure with a special
;; marker so we can distinguish this entry from actual variables.
(cl-assert (eq 'closure (car-safe oclosure)))
- (let ((typename (nth 3 oclosure))) ;; The "docstring".
- (cl-assert (stringp typename))
+ (let ((typename (if (and (nth 2 oclosure) (symbolp (nth 2 oclosure)))
+ (nth 4 oclosure)
+ (nth 3 oclosure)))) ;; The "docstring".
+ (cl-assert (stringp typename) t)
(push (cons :type (intern typename))
(cadr oclosure))
oclosure)))
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 1c5ce5169ab..00cda84ab40 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -438,6 +438,10 @@ how many time this CODEGEN is called."
main nil nil (car case)))))
main)))
+(defvar pcase-max-duplicates 1
+ "The max number of pattern uses before pcase creates an internal function
for it.
+This can be nil, meaning never create such a function.")
+
(defun pcase--expand (exp cases)
;; (message "pid=%S (pcase--expand %S ...hash=%S)"
;; (emacs-pid) exp (sxhash cases))
@@ -460,7 +464,9 @@ how many time this CODEGEN is called."
;; code explosion, we need to keep track of how many
;; times we've used each leaf and move it
;; to a separate function if that number is too high.
- (if (or (< count 2) (pcase--small-branch-p code))
+ (if (or (null pcase-max-duplicates)
+ (<= count pcase-max-duplicates)
+ (pcase--small-branch-p code))
`(let ,(mapcar (lambda (vv) (list (car vv) (cadr vv)))
varvals)
;; Try and silence some of the most common
@@ -469,13 +475,13 @@ how many time this CODEGEN is called."
,@code)
;; Several occurrence of this non-small branch in
;; the output.
- (unless bsym
- (setq bsym (make-symbol
- (format "pcase-%d" (length defs))))
- (push `(,bsym (lambda ,(mapcar #'car varvals)
- ,@ignores ,@code))
- defs))
- `(funcall ,bsym ,@(mapcar #'cadr varvals)))))))))
+ (unless bsym
+ (setq bsym (make-symbol
+ (format "pcase-%d" (length defs))))
+ (push `(,bsym (lambda ,(mapcar #'car varvals)
+ ,@ignores ,@code))
+ defs))
+ `(funcall ,bsym ,@(mapcar #'cadr varvals)))))))))
(main
(pcase-compile-patterns
exp
diff --git a/lisp/help.el b/lisp/help.el
index 6f55136049b..11e1d5e509b 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -2275,8 +2275,14 @@ the same names as used in the original source code, when
possible."
(if (eq (car-safe def) 'macro) (setq def (cdr def)))
(cond
((and (byte-code-function-p def) (listp (aref def 0))) (aref def 0))
- ((eq (car-safe def) 'lambda) (nth 1 def))
- ((eq (car-safe def) 'closure) (nth 2 def))
+ ((eq (car-safe def) 'lambda)
+ (if (and (nth 1 def) (symbolp (nth 1 def)))
+ (nth 2 def)
+ (nth 1 def)))
+ ((eq (car-safe def) 'closure)
+ (if (and (nth 2 def) (symbolp (nth 2 def)))
+ (nth 3 def)
+ (nth 2 def)))
((and (featurep 'native-compile)
(subrp def)
(listp (subr-native-lambda-list def)))
diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el
index 6d151db8a83..a68f76608d9 100644
--- a/lisp/progmodes/compile.el
+++ b/lisp/progmodes/compile.el
@@ -1214,7 +1214,9 @@ POS and RES.")
(if leave (setq leave (match-end leave)))
;; find previous stack, and push onto it, or if `leave' pop it
(let ((dir (compilation--previous-directory (match-beginning 0))))
- (setq dir (if dir (or (get-text-property (1- dir) 'compilation-directory)
+ (setq dir (if dir (or
+ (and (> dir 1)
+ (get-text-property (1- dir)
'compilation-directory))
(get-text-property dir 'compilation-directory))))
`(font-lock-face ,(if leave
compilation-leave-directory-face
@@ -1302,8 +1304,10 @@ POS and RES.")
(let ((pos (compilation--previous-directory
(match-beginning 0))))
(when pos
- (or (get-text-property (1- pos) 'compilation-directory)
- (get-text-property pos 'compilation-directory)))))))
+ (or
+ (and (> pos 1)
+ (get-text-property (1- pos)
'compilation-directory))
+ (get-text-property pos 'compilation-directory)))))))
(setq file (cons file (car dir)))))
;; This message didn't mention one, get it from previous
(let ((prev-pos
diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el
index 955b708aee9..4963785e56f 100644
--- a/lisp/progmodes/elisp-mode.el
+++ b/lisp/progmodes/elisp-mode.el
@@ -388,10 +388,15 @@ be used instead.
(dolist (binding bindings)
(push (or (car-safe binding) binding) vars))
(elisp--local-variables-1 vars (car (last body)))))
- (`(lambda ,_args)
+ ((or
+ `(lambda ,(pred (lambda (e) (and e (symbolp e)))) ,_args)
+ `(lambda ,_args))
;; FIXME: Look for the witness inside `args'.
(setq sexp nil))
- (`(lambda ,args . ,body)
+ ((or
+ `(lambda ,(pred (lambda (e) (and e (symbolp e))))
+ ,args . ,body)
+ `(lambda ,args . ,body))
(elisp--local-variables-1
(let ((args (if (listp args) args)))
;; FIXME: Exit the loop if witness is in args.
@@ -1614,8 +1619,9 @@ Reinitialize the face according to the `defface'
specification."
(cdr-safe (cdr-safe form))
(boundp (cadr form)))
;; Force variable to be re-set.
- `(progn (defvar ,(nth 1 form) nil ,@(nthcdr 3 form))
- (setq-default ,(nth 1 form) ,(nth 2 form))))
+ `(let ((defining-symbol ,(nth 1 form)))
+ (defvar ,(nth 1 form) nil ,@(nthcdr 3 form))
+ (setq-default ,(nth 1 form) ,(nth 2 form))))
;; `defcustom' is now macroexpanded to
;; `custom-declare-variable' with a quoted value arg.
((and (eq (car form) 'custom-declare-variable)
diff --git a/lisp/simple.el b/lisp/simple.el
index 54e71e1b040..d0fbc68d47e 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -2715,7 +2715,11 @@ function as needed."
((or (pred stringp) (pred vectorp)) "Keyboard macro.")
(`(keymap . ,_)
"Prefix command (definition is a keymap associating keystrokes with
commands).")
- ((or `(lambda ,_args . ,body) `(closure ,_env ,_args . ,body)
+ ((or `(lambda ,(pred (lambda (e) (and e (symbolp e))))
+ ,_args . ,body)
+ `(closure ,_env ,(pred (lambda (e) (and e (symbolp e))))
+ ,_args . ,body)
+ `(lambda ,_args . ,body) `(closure ,_env ,_args . ,body)
`(autoload ,_file . ,body))
(let ((doc (car body)))
(when (funcall docstring-p doc)
diff --git a/lisp/subr.el b/lisp/subr.el
index 2e2caf9fe27..db709cb600a 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -132,7 +132,11 @@ BODY should be a list of Lisp expressions.
def-body)))
;; Note that this definition should not use backquotes; subr.el should not
;; depend on backquote.el.
- (list 'function (cons 'lambda cdr)))
+ (if (and (car cdr) (symbolp (car cdr)))
+ (list 'function (cons 'lambda cdr))
+ (list 'function
+ (cons 'lambda
+ (cons (or defining-symbol t) cdr)))))
(defmacro prog2 (form1 form2 &rest body)
"Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
diff --git a/src/bytecode.c b/src/bytecode.c
index 2eb53b0428a..f3ff19269d0 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -305,13 +305,16 @@ enum byte_code_op
#define TOP (*top)
-DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
+DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 4, 0,
doc: /* Function used internally in byte-compiled code.
The first argument, BYTESTR, is a string of byte code;
the second, VECTOR, a vector of constants;
-the third, MAXDEPTH, the maximum stack depth used in this function.
+the third, MAXDEPTH, the maximum stack depth used in this function;
+the fourth DEFSYM, if non-nil, the symbol which defined the byte code -
+this is used in diagnostics.
If the third argument is incorrect, Emacs may crash. */)
- (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth)
+ (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
+ Lisp_Object defsym)
{
if (! (STRINGP (bytestr) && VECTORP (vector) && FIXNATP (maxdepth)))
error ("Invalid byte-code");
@@ -776,7 +779,7 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
if (max_lisp_eval_depth < 100)
max_lisp_eval_depth = 100;
if (lisp_eval_depth > max_lisp_eval_depth)
- error ("Lisp nesting exceeds `max-lisp-eval-depth'");
+ xsignal1 (Qexcessive_lisp_nesting, make_fixnum
(max_lisp_eval_depth));
}
ptrdiff_t call_nargs = op;
diff --git a/src/comp.c b/src/comp.c
index 1bde4ae5821..7cd69a6c0b1 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -5475,7 +5475,8 @@ native_function_doc (Lisp_Object function)
static Lisp_Object
make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg,
Lisp_Object c_name, Lisp_Object type, Lisp_Object doc_idx,
- Lisp_Object intspec, Lisp_Object command_modes, Lisp_Object comp_u)
+ Lisp_Object intspec, Lisp_Object command_modes, Lisp_Object comp_u,
+ Lisp_Object defining_symbol)
{
struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u);
dynlib_handle_ptr handle = cu->handle;
@@ -5515,6 +5516,7 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg,
Lisp_Object maxarg,
x->s.native_comp_u = comp_u;
x->s.native_c_name = xstrdup (SSDATA (c_name));
x->s.type = type;
+ x->s.defining_symbol = defining_symbol;
#endif
Lisp_Object tem;
XSETSUBR (tem, &x->s);
@@ -5523,12 +5525,12 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg,
Lisp_Object maxarg,
}
DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda,
- 7, 7, 0,
+ 8, 8, 0,
doc: /* Register anonymous lambda.
This gets called by top_level_run during the load phase. */)
(Lisp_Object reloc_idx, Lisp_Object c_name, Lisp_Object minarg,
Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest,
- Lisp_Object comp_u)
+ Lisp_Object comp_u, Lisp_Object defining_symbol)
{
Lisp_Object doc_idx = FIRST (rest);
Lisp_Object intspec = SECOND (rest);
@@ -5540,7 +5542,7 @@ This gets called by top_level_run during the load phase.
*/)
Lisp_Object tem =
make_subr (c_name, minarg, maxarg, c_name, type, doc_idx, intspec,
- command_modes, comp_u);
+ command_modes, comp_u, defining_symbol);
/* We must protect it against GC because the function is not
reachable through symbols. */
@@ -5556,12 +5558,12 @@ This gets called by top_level_run during the load
phase. */)
}
DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr,
- 7, 7, 0,
+ 8, 8, 0,
doc: /* Register exported subr.
This gets called by top_level_run during the load phase. */)
(Lisp_Object name, Lisp_Object c_name, Lisp_Object minarg,
Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest,
- Lisp_Object comp_u)
+ Lisp_Object comp_u, Lisp_Object defining_symbol)
{
Lisp_Object doc_idx = FIRST (rest);
Lisp_Object intspec = SECOND (rest);
@@ -5569,7 +5571,7 @@ This gets called by top_level_run during the load phase.
*/)
Lisp_Object tem =
make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, type, doc_idx,
- intspec, command_modes, comp_u);
+ intspec, command_modes, comp_u, defining_symbol);
defalias (name, tem);
@@ -5577,16 +5579,17 @@ This gets called by top_level_run during the load
phase. */)
}
DEFUN ("comp--late-register-subr", Fcomp__late_register_subr,
- Scomp__late_register_subr, 7, 7, 0,
+ Scomp__late_register_subr, 8, 8, 0,
doc: /* Register exported subr.
This gets called by late_top_level_run during the load phase. */)
(Lisp_Object name, Lisp_Object c_name, Lisp_Object minarg,
Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest,
- Lisp_Object comp_u)
+ Lisp_Object comp_u, Lisp_Object defining_symbol)
{
if (!NILP (Fequal (Fsymbol_function (name),
Fgethash (name, Vcomp_deferred_pending_h, Qnil))))
- Fcomp__register_subr (name, c_name, minarg, maxarg, type, rest, comp_u);
+ Fcomp__register_subr (name, c_name, minarg, maxarg, type, rest, comp_u,
+ defining_symbol);
Fremhash (name, Vcomp_deferred_pending_h);
return Qnil;
}
diff --git a/src/data.c b/src/data.c
index 108ed97d1f6..a56efa7fcc4 100644
--- a/src/data.c
+++ b/src/data.c
@@ -1039,6 +1039,20 @@ function or t otherwise. */)
return Qt;
}
+DEFUN ("subr-native-defining-symbol", Fsubr_native_defining_symbol,
+ Ssubr_native_defining_symbol, 1, 1, 0,
+ doc: /* Return the symbol (usually of a defun) where the native compiled
+function was defined, or nil if this information is missing. */)
+ (Lisp_Object subr)
+{
+ CHECK_SUBR (subr);
+
+#ifdef HAVE_NATIVE_COMP
+ return XSUBR (subr)->defining_symbol;
+#endif
+ return Qnil;
+}
+
DEFUN ("subr-type", Fsubr_type,
Ssubr_type, 1, 1, 0,
doc: /* Return the type of SUBR. */)
@@ -1121,14 +1135,23 @@ Value, if non-nil, is a list (interactive SPEC). */)
}
else if (COMPILEDP (fun))
{
+ Lisp_Object form;
if (PVSIZE (fun) > COMPILED_INTERACTIVE)
{
- Lisp_Object form = AREF (fun, COMPILED_INTERACTIVE);
+ /* Lisp_Object */ form = AREF (fun, COMPILED_INTERACTIVE);
/* The vector form is the new form, where the first
element is the interactive spec, and the second is the
command modes. */
return list2 (Qinteractive, VECTORP (form) ? AREF (form, 0) : form);
}
+ else if (PVSIZE (fun) > COMPILED_DEFINING_SYM
+ && (NILP (form = AREF (fun, COMPILED_DEFINING_SYM))
+ || !SYMBOLP (form)))
+ {
+ /* We have a FUN from before the defining symbol was included. */
+ form = AREF (fun, COMPILED_DEFINING_SYM);
+ return list2 (Qinteractive, VECTORP (form) ? AREF (form, 0) : form);
+ }
else if (PVSIZE (fun) > COMPILED_DOC_STRING)
{
Lisp_Object doc = AREF (fun, COMPILED_DOC_STRING);
@@ -1203,9 +1226,14 @@ The value, if non-nil, is a list of mode name symbols.
*/)
}
else if (COMPILEDP (fun))
{
- if (PVSIZE (fun) <= COMPILED_INTERACTIVE)
+ Lisp_Object form;
+
+ if (PVSIZE (fun) <= COMPILED_DEFINING_SYM)
return Qnil;
- Lisp_Object form = AREF (fun, COMPILED_INTERACTIVE);
+ if (PVSIZE (fun) == COMPILED_INTERACTIVE)
+ form = AREF (fun, COMPILED_DEFINING_SYM);
+ else
+ form = AREF (fun, COMPILED_INTERACTIVE);
if (VECTORP (form))
/* New form -- the second element is the command modes. */
return AREF (form, 1);
@@ -4347,6 +4375,7 @@ syms_of_data (void)
defsubr (&Ssubr_name);
defsubr (&Ssubr_native_elisp_p);
defsubr (&Ssubr_native_lambda_list);
+ defsubr (&Ssubr_native_defining_symbol);
defsubr (&Ssubr_type);
#ifdef HAVE_NATIVE_COMP
defsubr (&Ssubr_native_comp_unit);
diff --git a/src/eval.c b/src/eval.c
index 3f4e77cd3b1..83877008d8f 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -536,6 +536,12 @@ usage: (function ARG) */)
return an interpreted closure instead of a simple lambda. */
Lisp_Object cdr = XCDR (quoted);
Lisp_Object tmp = cdr;
+ bool with_definer = false;
+ if (!NILP (XCAR (tmp)) && SYMBOLP (XCAR (tmp))) /* Defining symbol */
+ {
+ tmp = XCDR (tmp);
+ with_definer = true;
+ }
if (CONSP (tmp)
&& (tmp = XCDR (tmp), CONSP (tmp))
&& (tmp = XCAR (tmp), CONSP (tmp))
@@ -548,14 +554,19 @@ usage: (function ARG) */)
* (the OClosure's type). */
docstring = Fsymbol_name (docstring);
CHECK_STRING (docstring);
- cdr = Fcons (XCAR (cdr), Fcons (docstring, XCDR (XCDR (cdr))));
+ if (with_definer)
+ cdr = Fcons (XCAR (cdr), Fcons (XCAR (XCDR (cdr)),
+ Fcons (docstring,
+ XCDR (XCDR (XCDR (cdr))))));
+ else
+ cdr = Fcons (XCAR (cdr), Fcons (docstring, XCDR (XCDR (cdr))));
}
if (NILP (Vinternal_make_interpreted_closure_function))
return Fcons (Qclosure, Fcons (Vinternal_interpreter_environment,
cdr));
else
- return call2 (Vinternal_make_interpreted_closure_function,
+ return call2 (Vinternal_make_interpreted_closure_function,
Fcons (Qlambda, cdr),
- Vinternal_interpreter_environment);
+ Vinternal_interpreter_environment);
}
else
/* Simply quote the argument. */
@@ -764,9 +775,13 @@ static Lisp_Object
defvar (Lisp_Object sym, Lisp_Object initvalue, Lisp_Object docstring, bool
eval)
{
Lisp_Object tem;
+ specpdl_ref count = SPECPDL_INDEX ();
CHECK_SYMBOL (sym);
+ /* Bind `defining-symbol' in case `initvalue' defines a lambda function. */
+ specbind (Qdefining_symbol, sym);
+
tem = Fdefault_boundp (sym);
/* Do it before evaluating the initial value, for self-references. */
@@ -784,7 +799,7 @@ defvar (Lisp_Object sym, Lisp_Object initvalue, Lisp_Object
docstring, bool eval
eval ? eval_sub (initvalue) : initvalue);
}
}
- return sym;
+ return unbind_to (count, sym);
}
DEFUN ("defvar", Fdefvar, Sdefvar, 1, UNEVALLED, 0,
@@ -874,9 +889,11 @@ usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
(Lisp_Object args)
{
Lisp_Object sym, tem;
+ specpdl_ref count = SPECPDL_INDEX ();
sym = XCAR (args);
CHECK_SYMBOL (sym);
+ specbind (Qdefining_symbol, sym); /* In case INITVALUE defines a function.
*/
Lisp_Object docstring = Qnil;
if (!NILP (XCDR (XCDR (args))))
{
@@ -885,7 +902,7 @@ usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
docstring = XCAR (XCDR (XCDR (args)));
}
tem = eval_sub (XCAR (XCDR (args)));
- return Fdefconst_1 (sym, tem, docstring);
+ return unbind_to (count, Fdefconst_1 (sym, tem, docstring));
}
DEFUN ("defconst-1", Fdefconst_1, Sdefconst_1, 2, 3, 0,
@@ -2144,8 +2161,14 @@ then strings and vectors are not accepted. */)
where the interactive spec is stored. */
else if (COMPILEDP (fun))
{
+ Lisp_Object obj;
if (PVSIZE (fun) > COMPILED_INTERACTIVE)
return Qt;
+ else if (PVSIZE (fun) > COMPILED_DEFINING_SYM
+ && (NILP (obj = AREF (fun, COMPILED_DEFINING_SYM))
+ || !SYMBOLP (obj)))
+ /* An old function where the interactive spec is still here. */
+ return Qt;
else if (PVSIZE (fun) > COMPILED_DOC_STRING)
{
Lisp_Object doc = AREF (fun, COMPILED_DOC_STRING);
@@ -2608,7 +2631,7 @@ eval_sub (Lisp_Object form)
val = call_debugger (list2 (Qexit, val));
specpdl_ptr--;
- return val;
+ return unbind_to (count, val);
}
DEFUN ("apply", Fapply, Sapply, 1, MANY, 0,
@@ -3151,6 +3174,13 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
else
lexenv = Qnil;
syms_left = XCDR (fun);
+ if (CONSP (syms_left)
+ && !NILP (XCAR (syms_left))
+ && SYMBOLP (XCAR (syms_left))) /* Defining symbol. */
+ {
+ syms_left = XCDR (syms_left);
+ fun = XCDR (fun);
+ }
if (CONSP (syms_left))
syms_left = XCAR (syms_left);
else
@@ -3330,6 +3360,9 @@ lambda_arity (Lisp_Object fun)
CHECK_CONS (fun);
}
syms_left = XCDR (fun);
+ if (CONSP (syms_left) && !NILP (XCAR (syms_left))
+ && SYMBOLP (XCAR (syms_left)))
+ syms_left = XCDR (syms_left);
if (CONSP (syms_left))
syms_left = XCAR (syms_left);
else
@@ -4259,6 +4292,14 @@ before making `inhibit-quit' nil. */);
DEFSYM (Qautoload, "autoload");
DEFSYM (Qinhibit_debugger, "inhibit-debugger");
DEFSYM (Qmacro, "macro");
+ DEFSYM (Qdefining_symbol, "defining-symbol");
+ DEFVAR_LISP ("defining-symbol", Vdefining_symbol,
+ doc: /* The symbol being defined by `defun' or `defmacro', etc..
+We use this to include in the structure of closures/lambdas defined inside
+the function or macro. A value of nil means the variable is not in use.
+A value of t means, e.g. the byte compiler is active, but there is not yet
+a current defining symbol. */);
+ Vdefining_symbol = Qnil;
/* Note that the process handling also uses Qexit, but we don't want
to staticpro it twice, so we just do it here. */
diff --git a/src/lisp.h b/src/lisp.h
index 3fc78cd1919..ab91341603f 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -2173,6 +2173,7 @@ struct Lisp_Subr
char *native_c_name;
Lisp_Object lambda_list;
Lisp_Object type;
+ Lisp_Object defining_symbol;
#endif
} GCALIGNED_STRUCT;
union Aligned_Lisp_Subr
@@ -2966,7 +2967,8 @@ enum Lisp_Compiled
COMPILED_CONSTANTS = 2,
COMPILED_STACK_DEPTH = 3,
COMPILED_DOC_STRING = 4,
- COMPILED_INTERACTIVE = 5
+ COMPILED_DEFINING_SYM = 5,
+ COMPILED_INTERACTIVE = 6
};
/* Flag bits in a character. These also get used in termhooks.h.
diff --git a/src/lread.c b/src/lread.c
index 6792ef27206..e6dba3bb8c1 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -5091,6 +5091,7 @@ defsubr (union Aligned_Lisp_Subr *aname)
#ifdef HAVE_NATIVE_COMP
eassert (NILP (Vcomp_abi_hash));
Vcomp_subr_list = Fpurecopy (Fcons (tem, Vcomp_subr_list));
+ sname->defining_symbol = sym;
#endif
}
diff --git a/test/Makefile.in b/test/Makefile.in
index e2a14c4dd92..50835325373 100644
--- a/test/Makefile.in
+++ b/test/Makefile.in
@@ -339,7 +339,8 @@ ifeq ($(TEST_INTERACTIVE), yes)
else
-@${MAKE} -k ${LOGFILES}
@$(emacs) --batch -l ert --eval \
- "(ert-summarize-tests-batch-and-exit ${SUMMARIZE_TESTS})" ${LOGFILES}
+ "(setq ert-batch-backtrace-right-margin 0)" \
+ --eval "(ert-summarize-tests-batch-and-exit ${SUMMARIZE_TESTS})"
${LOGFILES}
endif
.PHONY: mostlyclean clean bootstrap-clean distclean maintainer-clean
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el
b/test/lisp/emacs-lisp/bytecomp-tests.el
index 9813e9459c8..34d03c5446d 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -1826,7 +1826,7 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode
python-mode)) \
(let ((bc (byte-compile fname)))
(should (byte-code-function-p bc))
(should (equal (funcall bc 'titi) '(toto titi)))
- (should (equal (aref bc 5) "P"))
+ (should (equal (aref bc 6) "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)")))))
diff --git a/test/lisp/emacs-lisp/cconv-tests.el
b/test/lisp/emacs-lisp/cconv-tests.el
index 6facd3452ea..7b7c671b1cb 100644
--- a/test/lisp/emacs-lisp/cconv-tests.el
+++ b/test/lisp/emacs-lisp/cconv-tests.el
@@ -178,7 +178,7 @@
(should (equal (cconv-closure-convert
'#'(lambda (x) (let ((f #'(lambda () (+ x 1))))
(funcall f))))
- '#'(lambda (x) (let ((f #'(lambda (x) (+ x 1))))
+ '#'(lambda (x) (let ((f #'(lambda t (x) (+ x 1))))
(funcall f x)))))
;; Bug#30872.
@@ -223,23 +223,23 @@
;; Basic case:
(should (equal (cconv-tests--intern-all
(cconv-closure-convert
- '#'(lambda (x)
- (let ((f #'(lambda () x)))
+ '#'(lambda t (x)
+ (let ((f #'(lambda t () x)))
(let ((x 'b))
(list x (funcall f)))))))
- '#'(lambda (x)
- (let ((f #'(lambda (x) x)))
+ '#'(lambda t (x)
+ (let ((f #'(lambda t (x) x)))
(let ((x 'b)
(closed-x x))
(list x (funcall f closed-x)))))))
(should (equal (cconv-tests--intern-all
(cconv-closure-convert
- '#'(lambda (x)
+ '#'(lambda t (x)
(let ((f #'(lambda () x)))
(let* ((x 'b))
(list x (funcall f)))))))
- '#'(lambda (x)
- (let ((f #'(lambda (x) x)))
+ '#'(lambda t (x)
+ (let ((f #'(lambda t (x) x)))
(let* ((closed-x x)
(x 'b))
(list x (funcall f closed-x)))))))
@@ -256,7 +256,7 @@
'#'(lambda (x)
(internal-make-closure
nil (x) nil
- (let ((f #'(lambda (x) x)))
+ (let ((f #'(lambda t (x) x)))
(let ((x 'a)
(closed-x (internal-get-closed-var 0)))
(list x (funcall f closed-x))))))))
@@ -271,7 +271,7 @@
'#'(lambda (x)
(internal-make-closure
nil (x) nil
- (let ((f #'(lambda (x) x)))
+ (let ((f #'(lambda t (x) x)))
(let* ((closed-x (internal-get-closed-var 0))
(x 'a))
(list x (funcall f closed-x))))))))
@@ -289,7 +289,7 @@
(let ((x (list x)))
(internal-make-closure
nil (x) nil
- (let ((f #'(lambda (x) (car-safe x))))
+ (let ((f #'(lambda t (x) (car-safe x))))
(setcar (internal-get-closed-var 0)
(car-safe (internal-get-closed-var 0)))
(let ((x 'a)
@@ -308,7 +308,7 @@
(let ((x (list x)))
(internal-make-closure
nil (x) nil
- (let ((f #'(lambda (x) (car-safe x))))
+ (let ((f #'(lambda t (x) (car-safe x))))
(setcar (internal-get-closed-var 0)
(car-safe (internal-get-closed-var 0)))
(let* ((closed-x (internal-get-closed-var 0))
@@ -325,8 +325,8 @@
(list x (funcall g) (funcall h)))))))
'#'(lambda (x)
(let ((x (list x)))
- (let ((g #'(lambda (x) (car-safe x)))
- (h #'(lambda (x) (setcar x (car-safe x)))))
+ (let ((g #'(lambda t (x) (car-safe x)))
+ (h #'(lambda t (x) (setcar x (car-safe x)))))
(let ((x 'b)
(closed-x x))
(list x (funcall g closed-x) (funcall h closed-x))))))))
@@ -340,8 +340,8 @@
(list x (funcall g) (funcall h)))))))
'#'(lambda (x)
(let ((x (list x)))
- (let ((g #'(lambda (x) (car-safe x)))
- (h #'(lambda (x) (setcar x (car-safe x)))))
+ (let ((g #'(lambda t (x) (car-safe x)))
+ (h #'(lambda t (x) (setcar x (car-safe x)))))
(let* ((closed-x x)
(x 'b))
(list x (funcall g closed-x) (funcall h closed-x))))))))