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
#
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.
(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)))
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))
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)
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.
;; 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."
;; 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))))
'(&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))
,@(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
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)
(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
(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)
(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
(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))))
(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))))
\f
;; Redefined in byte-opt.el.
;; This was undocumented and unused for decades.
(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) ""))
(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)
(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)))
(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)
(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
(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.
;; 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)
(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 ()))
((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)))))
\f
;;;###autoload
(defun byte-compile (form)
(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.
"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."
(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
(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)
;; 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
(gethash (cadr compiled)
byte-to-native-lambdas-h))
out))
- out))))
+ out)))))
(defvar byte-compile-reserved-constants 0)
(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)
(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)))))
(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:
;; 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.
',(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."
;; 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.
;; 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))
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)
(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 ())
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:
(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
; 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)
(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)))))
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))
;; 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
(`(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))
(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))
(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))
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.
(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.
(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))
;; 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"))
(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))'
(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))))))
(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.
(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
;; 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).
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)
`(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
;; 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
(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)
(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
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
nargs))
(if found
`(function
- (lambda ,(nreverse nargs)
+ (lambda
+ ,@(if def `(,def)) ,(nreverse nargs)
. ,(mapcar (lambda (exp)
(macroexpand-all exp env))
body)))
(cdr clause))))
clauses))))
(_ exp))))
+(eval-when-compile (setq pcase-max-duplicates save-p-m-d))
;;;###autoload
(defmacro cl-symbol-macrolet (bindings &rest body)
(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)
(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.")
(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.
(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."
: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")))
(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))))
(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))
(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))
(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)
(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.
;; 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)
(comp-log "\n\f\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.
;;; 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'.
(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'.
: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
`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
(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'.
(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)
;; 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))
(`(,(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)))
(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)
(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))
(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)))))))
;; 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)))
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))
;; 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
,@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
(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)))
(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
(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
(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.
(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)
((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)
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.
#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");
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;
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;
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);
}
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);
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. */
}
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);
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);
}
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;
}
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. */)
}
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);
}
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);
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);
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))
* (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. */
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. */
eval ? eval_sub (initvalue) : initvalue);
}
}
- return sym;
+ return unbind_to (count, sym);
}
DEFUN ("defvar", Fdefvar, Sdefvar, 1, UNEVALLED, 0,
(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))))
{
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,
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);
val = call_debugger (list2 (Qexit, val));
specpdl_ptr--;
- return val;
+ return unbind_to (count, val);
}
\f
DEFUN ("apply", Fapply, Sapply, 1, MANY, 0,
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
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
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. */
char *native_c_name;
Lisp_Object lambda_list;
Lisp_Object type;
+ Lisp_Object defining_symbol;
#endif
} GCALIGNED_STRUCT;
union Aligned_Lisp_Subr
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.
#ifdef HAVE_NATIVE_COMP
eassert (NILP (Vcomp_abi_hash));
Vcomp_subr_list = Fpurecopy (Fcons (tem, Vcomp_subr_list));
+ sname->defining_symbol = sym;
#endif
}
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
(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)")))))
(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.
;; 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)))))))
'#'(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))))))))
'#'(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))))))))
(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)
(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))
(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))))))))
(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))))))))
projects / emacs.git / commitdiff