[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/positioned-lambdas 1bd7bee1d6b 1/3: Set ; POS... position struct
|
From: |
Alan Mackenzie |
|
Subject: |
feature/positioned-lambdas 1bd7bee1d6b 1/3: Set ; POS... position structures on entities in interpreted code |
|
Date: |
Mon, 4 Mar 2024 10:06:29 -0500 (EST) |
branch: feature/positioned-lambdas
commit 1bd7bee1d6b1d47b9a14de7029b614a3545cd0e8
Author: Alan Mackenzie <acm@muc.de>
Commit: Alan Mackenzie <acm@muc.de>
Set ;POS... position structures on entities in interpreted code
This is part of bug#67455. defvars and defconsts together with
methods generated by cl-defmethod currently don't get these
position structures. Also, many debugging artefacts remain in
this repository, to be removed later.
doc/lispref/functions.texi (Declare Form): Enhance to
document the new declare clause, defining-symbol.
lisp/emacs-lisp/backquote.el (backquote-process): Add a new
clause to attach byte-run-posify-lambda-form to lambda forms.
lisp/emacs-lisp/byte-run.el (byte-run--strip-hash-table): New
function.
(byte-run--strip-list, byte-run--strip-vector/record)
(byte-run-strip-symbol-positions): Call the above new function.
(byte-run--report-hash-table, byte-run--report-vector/record)
(byte-run--report-list, byte-run-report-symbol-positions): New
diagnostic functions.
(byte-run--posify-hash-table, byte-run--posify-vector/record)
(byte-run--posify-list, byte-run-posify-all-lambdas): New,
probably redundant functions.
(byte-run--strip-lambda-doc-list)
(byte-run--strip-lambda-doc-vector/record)
(byte-run--strip-lambda-doc-hash-table)
(byte-run-strip-lambda-doc): New auxiliary functions, probably
redundant.
(byte-run-posify-doc-string): Amend to take a position rather
than a lambda-token as argument. Also change the introductory
token to use \001 rather than \000, since the latter acted as
null terminators in some interprocess communication. Attempt
to handle (:documentation ...) doc string forms.
(byte-run-posify-lambda-form): New function.
(byte-run--set-defining-symbol): Removed.
(byte-run--extract-sym-from-form, byte-run--doc-n): New
functions.
(byte-run--posify-defining-form): New function.
(byte-run--parse-body): Amend the detection of duplicated doc
strings also to handle bare ;POS... structures.
(byte-run--parse-declarations): Rename `pre-form' to
`byte-run-pre-form'. Allow a handler to return code both to be
run after a declaration, and to be prefixed onto a
macro/function.
(defmacro): New code to posify an existing doc string or insert
a new ;POS... structure. Also to strip the position from a
symbol with position. Give defmacro a byte-run-defined-form so
that the reader will position symbols it defines.
(defun): Remove "the return value is undefined" from the doc
string.
(byte-run--fun-doc-pos/macro, byte-run--fun-get-string)
(byte-run--fun-put-new-string, byte-run--fun-get-lambda-pos)
(byte-run-strip-pos-info)
(byte-run-posify-existing-defaliases-1)
(byte-run-posify-existing-defaliases)
(byte-run-posify-existing-lambdas): New functions, some of
which may be redundant.
(defsubst): Strip the new symbol of its position.
lisp/emacs-lisp/bytecomp.el (byte-compile-file): Use the name
of the file for the temporary buffer: this gets a good name
into the ;POS... structures created at compilation.
(compile-defun): Bind byte-compile-in-progress.
lisp/emacs-lisp/cconv.el (cconv-convert)
(cconv-make-interpreted-closure): Handle any doc string in a
lambda form.
lisp/emacs-lisp/cl-defgeneric.el (cl-defgeneric): Amend the
defining-symbol declare clause.
(cl-defgeneric): Remove the defining-symbol declare clause,
which can't work due to the non-constant position of the doc
string.
lisp/emacs-lisp/debug-early.el (debug-early-frame): New
function extracted from debug-early-backtrace to avoid the use
of a lambda function, which is troublesome so early in the
bootstrap.
lisp/emacs-lisp/debug.el (top level) don't set debug to be the
default debugger in batch mode.
lisp/emacs-lisp/edebug.el (edebug-install-read-eval-functions):
Amend the advising of load-read-function, since that function
can now be let bound in Fload.
lisp/emacs-lisp/macroexp.el (macroexpand-1): Refactor. Also
add handling for lambda forms which was previously in the macro
lambda in subr.el. Handle also defalias forms from early
bootstrapping.
(macroexp--expand-all): Enhance the handling of #'(lambda ...),
posifying the lambda form, and stripping its position. Strip
the positions from symbols in (setq ...) forms. Add a guard
pcase clause to strip the position from a symbol.
(macroexpand-1, macroexpand-all, macroexpand-all-toplevel):
Bind symbols-with-pos-enabled to t.
lisp/emacs-lisp/pcase.el (\`): Add a clause to strip the
position from a symbol with position.
lisp/help-mode.el (top level): Require easymenu.
lisp/help.el (help-strip-pos-info, help-add-fundoc-usage):
Recognize the new token in ;POS structures using \001 rather
than \000.
lisp/international/mule.el (load-with-code-conversion): Use the
file name for the buffer name rather than " *load*".
lisp/jsonrpc.el (jsonrpc-connection): Give
-events-buffer-scrollback-size an initform.
lisp/loadup.el (top-level): Set symbols-with-pos-enabled to t
during the loading of the first ?16 files. Call
byte-run-posify-existing-defaliases and
byte-run-posify-existing-lambdas to posify functions loaded
from the first few files. Load the first ?16 files a second
time, so as to handle posification properly on these early
files. Clear out their function history between the two
loadings to prevent symbols with position getting into the
pdump process. Also use a variant of defvar during this period
to ensure that these variables are set to their new values.
lisp/<various>: Update approximately 37 defining-symbol declare
clauses to the new way of defining them by giving argument
names rather than positions in the arglist.
src/alloc.c (Fmake_record): Strip any position from the type
field.
src/data.c (Fdefalias): Record the first few symbol defined in
the bootstrap for later posification.
src/doc.c (Fdocumentation): Strip ;POS... position information
from doc strings unless RAW is set to `also-pos'.
src/eval.c (defvar): Add an extra parameter, forced_init, to
force the initialization of variables, even when they already
have a value.
(Fdefvar_bootstrap): New function, a variant of Fdefvar which
always reinitializes the variable's value.
(Fmacroexpand): bind symbols-with-pos-enabled to t and
cur-evalled-macro-form to the form being expanded.
(eval_sub): Bind symbols-with-pos-enabled to t. Eagerly expand
macros encountered by calling macroexpand-all, when this has
been loaded.
(syms_of_eval): New Lisp variable cur-evalled-macro-form.
src/fns.c (Fgethash, Fputhash): Strip any positions from the
supplied keys.
src/lread.c (char_count): New variable recording the position
in the buffer currently being loaded.
(readchar, unreadchar): Handle char_count correctly.
(unbind_char_count): New function.
(Fload): Bind char_count to 1 at the start of loading a file.
Bind load-read-function to `read' at the start of each load.
(readevalloop_early_eval): New function.
(readevalloop_eager_expand_eval): In early bootstrap, detect
defalias calls and not defining-symbol for them. Strip symbol
positions before calling eval_sub.
(readevalloop): Use new boolean variable is_elc. Refactor the
function somewhat. Call readevalloop_early_eval in the early
part of bootstrap, before macro expansion is fully available.
(read-positioning-symbols): Refactor somewhat.
(read-positioning-defined-symbol): New function.
(get_read_stream): New function.
(read_stack_entry): New fields old_locate_syms, target_obj,
current_obj.
(ADJUST_LOCATE_SYMS): New macro.
(read0): Enhance to boolean locate_syms to an integer with 5
meaningful values, implementing a state machine with them. Use
this state machine for positioning only symbols defined by
"defining-symbol" macros, and `lambda' immediately following an
open parenthesis.
test/lisp/emacs-lisp/cconv-tests.el (several tests): Use
byte-run-strip-lambda-doc to enable easy comparison of actual
results with expected ones.
test/lisp/emacs-lisp/ert-tests.el
test/lisp/emacs-lisp/ert-x-tests.el
lisp/lisp/erc/erc-tests.el: Minor amendments to handle the
presence of ;POS... forms.
test/lisp/jsonrpc-tests.el
(jsonrpc--call-with-emacsrpc-fixture): Add in a missing :name
keyword.
test/lisp/use-package/use-package-tests.el (3 tests): Add
edebug specs.
(match-expansion): Use byte-run-strip-lambda-doc.
---
doc/lispref/functions.texi | 14 +-
exec/config.guess | 35 +-
exec/config.sub | 50 +-
lisp/Makefile.in | 3 +-
lisp/cedet/mode-local.el | 6 +-
lisp/cedet/semantic/idle.el | 2 +-
lisp/cedet/semantic/lex-spp.el | 6 +-
lisp/cedet/semantic/lex.el | 10 +-
lisp/cedet/semantic/wisent.el | 2 +-
lisp/emacs-lisp/backquote.el | 24 +
lisp/emacs-lisp/backtrace.el | 3 +-
lisp/emacs-lisp/bindat.el | 2 +-
lisp/emacs-lisp/byte-run.el | 866 ++++++++++++++++++++++++++---
lisp/emacs-lisp/bytecomp.el | 35 +-
lisp/emacs-lisp/cconv.el | 14 +-
lisp/emacs-lisp/cl-generic.el | 27 +-
lisp/emacs-lisp/cl-macs.el | 10 +-
lisp/emacs-lisp/comp.el | 40 +-
lisp/emacs-lisp/debug-early.el | 64 ++-
lisp/emacs-lisp/debug.el | 4 +-
lisp/emacs-lisp/derived.el | 2 +-
lisp/emacs-lisp/easy-mmode.el | 2 +-
lisp/emacs-lisp/edebug.el | 65 ++-
lisp/emacs-lisp/ert.el | 8 +-
lisp/emacs-lisp/generator.el | 2 +-
lisp/emacs-lisp/gv.el | 2 +-
lisp/emacs-lisp/macroexp.el | 166 +++---
lisp/emacs-lisp/pcase.el | 1 +
lisp/erc/erc-backend.el | 7 +-
lisp/gnus/nnoo.el | 2 +-
lisp/help.el | 4 +-
lisp/international/mule.el | 3 +-
lisp/jsonrpc.el | 1 +
lisp/ldefs-boot.el | 4 +-
lisp/loadup.el | 92 +++
lisp/mh-e/mh-acros.el | 4 +-
lisp/obsolete/cl.el | 8 +-
lisp/obsolete/eieio-compat.el | 1 -
lisp/progmodes/cc-defs.el | 2 +-
lisp/progmodes/cc-langs.el | 5 +-
lisp/skeleton.el | 2 +-
lisp/subr.el | 6 +-
lisp/transient.el | 6 +-
lisp/vc/pcvs.el | 3 +-
lisp/window.el | 15 +-
src/alloc.c | 3 +
src/data.c | 6 +
src/doc.c | 5 +-
src/editfns.c | 3 +-
src/eval.c | 83 ++-
src/fns.c | 6 +
src/lisp.h | 12 +-
src/lread.c | 454 ++++++++++++---
test/Makefile.in | 2 +-
test/lisp/emacs-lisp/cconv-tests.el | 41 +-
test/lisp/emacs-lisp/ert-tests.el | 2 +-
test/lisp/emacs-lisp/ert-x-tests.el | 1 +
test/lisp/erc/erc-tests.el | 26 +-
test/lisp/jsonrpc-tests.el | 1 +
test/lisp/use-package/use-package-tests.el | 7 +-
60 files changed, 1826 insertions(+), 456 deletions(-)
diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi
index ba0d919549b..2687b112c92 100644
--- a/doc/lispref/functions.texi
+++ b/doc/lispref/functions.texi
@@ -2667,8 +2667,20 @@ instead of native code for the function.
This is valid for macros only. Macros with this declaration are
highlighted by font-lock (@pxref{Font Lock Mode}) as normal functions,
not specially as macros.
-@end table
+@c NEW STOUGH, 2024-02-29
+@item (defining-symbol @var{val})
+This is valid for macros only. It denotes a macro is a @dfn{defining
+macro}, that is, a macro which itself creates functions or macros. As
+an example, @code{defun} is annotated with @code{defining-symbol}.
+This declaration causes the generation of code for certain boilerplate
+functions to be attached to the macro. @var{val} contains
+specifications of where to find the name and doc string in the macro's
+arglist. For details of @var{val}, see the doc string of
+@code{byte-run--posify-defining-form} in
+@file{lisp/emacs-lisp/byte-run.el}.
+@c END OF NEW STOUGH
+@end table
@end defmac
@node Declaring Functions
diff --git a/exec/config.guess b/exec/config.guess
index e7a6fe3e6d1..b187213930f 100755
--- a/exec/config.guess
+++ b/exec/config.guess
@@ -1,10 +1,10 @@
-#!/usr/bin/sh
+#! /bin/sh
# Attempt to guess a canonical system name.
# Copyright 1992-2023 Free Software Foundation, Inc.
# shellcheck disable=SC2006,SC2268 # see below for rationale
-timestamp='2023-06-23'
+timestamp='2023-07-20'
# This file is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
@@ -976,7 +976,27 @@ EOF
GUESS=$UNAME_MACHINE-unknown-minix
;;
aarch64:Linux:*:*)
- GUESS=$UNAME_MACHINE-unknown-linux-$LIBC
+ set_cc_for_build
+ CPU=$UNAME_MACHINE
+ LIBCABI=$LIBC
+ if test "$CC_FOR_BUILD" != no_compiler_found; then
+ ABI=64
+ sed 's/^ //' << EOF > "$dummy.c"
+ #ifdef __ARM_EABI__
+ #ifdef __ARM_PCS_VFP
+ ABI=eabihf
+ #else
+ ABI=eabi
+ #endif
+ #endif
+EOF
+ cc_set_abi=`$CC_FOR_BUILD -E "$dummy.c" 2>/dev/null | grep '^ABI' |
sed 's, ,,g'`
+ eval "$cc_set_abi"
+ case $ABI in
+ eabi | eabihf) CPU=armv8l; LIBCABI=$LIBC$ABI ;;
+ esac
+ fi
+ GUESS=$CPU-unknown-linux-$LIBCABI
;;
aarch64_be:Linux:*:*)
UNAME_MACHINE=aarch64_be
@@ -1042,6 +1062,15 @@ EOF
k1om:Linux:*:*)
GUESS=$UNAME_MACHINE-unknown-linux-$LIBC
;;
+ kvx:Linux:*:*)
+ GUESS=$UNAME_MACHINE-unknown-linux-$LIBC
+ ;;
+ kvx:cos:*:*)
+ GUESS=$UNAME_MACHINE-unknown-cos
+ ;;
+ kvx:mbr:*:*)
+ GUESS=$UNAME_MACHINE-unknown-mbr
+ ;;
loongarch32:Linux:*:* | loongarch64:Linux:*:*)
GUESS=$UNAME_MACHINE-unknown-linux-$LIBC
;;
diff --git a/exec/config.sub b/exec/config.sub
index a6d99a0f15f..6ae25027537 100755
--- a/exec/config.sub
+++ b/exec/config.sub
@@ -1,10 +1,10 @@
-#!/usr/bin/sh
+#! /bin/sh
# Configuration validation subroutine script.
# Copyright 1992-2023 Free Software Foundation, Inc.
# shellcheck disable=SC2006,SC2268 # see below for rationale
-timestamp='2023-06-23'
+timestamp='2023-07-31'
# This file is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
@@ -145,7 +145,8 @@ case $1 in
nto-qnx* | linux-* | uclinux-uclibc* \
| uclinux-gnu* | kfreebsd*-gnu* | knetbsd*-gnu* |
netbsd*-gnu* \
| netbsd*-eabi* | kopensolaris*-gnu* | cloudabi*-eabi* \
- | storm-chaos* | os2-emx* | rtmk-nova* | managarm-*)
+ | storm-chaos* | os2-emx* | rtmk-nova* | managarm-* \
+ | windows-* )
basic_machine=$field1
basic_os=$maybe_os
;;
@@ -1205,6 +1206,7 @@ case $cpu-$vendor in
| i370 | i*86 | i860 | i960 | ia16 | ia64 \
| ip2k | iq2000 \
| k1om \
+ | kvx \
| le32 | le64 \
| lm32 \
| loongarch32 | loongarch64 \
@@ -1213,31 +1215,7 @@ case $cpu-$vendor in
| m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x \
| m88110 | m88k | maxq | mb | mcore | mep | metag \
| microblaze | microblazeel \
- | mips | mipsbe | mipseb | mipsel | mipsle \
- | mips16 \
- | mips64 | mips64eb | mips64el \
- | mips64octeon | mips64octeonel \
- | mips64orion | mips64orionel \
- | mips64r5900 | mips64r5900el \
- | mips64vr | mips64vrel \
- | mips64vr4100 | mips64vr4100el \
- | mips64vr4300 | mips64vr4300el \
- | mips64vr5000 | mips64vr5000el \
- | mips64vr5900 | mips64vr5900el \
- | mipsisa32 | mipsisa32el \
- | mipsisa32r2 | mipsisa32r2el \
- | mipsisa32r3 | mipsisa32r3el \
- | mipsisa32r5 | mipsisa32r5el \
- | mipsisa32r6 | mipsisa32r6el \
- | mipsisa64 | mipsisa64el \
- | mipsisa64r2 | mipsisa64r2el \
- | mipsisa64r3 | mipsisa64r3el \
- | mipsisa64r5 | mipsisa64r5el \
- | mipsisa64r6 | mipsisa64r6el \
- | mipsisa64sb1 | mipsisa64sb1el \
- | mipsisa64sr71k | mipsisa64sr71kel \
- | mipsr5900 | mipsr5900el \
- | mipstx39 | mipstx39el \
+ | mips* \
| mmix \
| mn10200 | mn10300 \
| moxie \
@@ -1732,7 +1710,7 @@ case $os in
| hpux* | unos* | osf* | luna* | dgux* | auroraux* | solaris* \
| sym* | plan9* | psp* | sim* | xray* | os68k* | v88r* \
| hiux* | abug | nacl* | netware* | windows* \
- | os9* | macos* | osx* | ios* \
+ | os9* | macos* | osx* | ios* | tvos* | watchos* \
| mpw* | magic* | mmixware* | mon960* | lnews* \
| amigaos* | amigados* | msdos* | newsos* | unicos* | aof* \
| aos* | aros* | cloudabi* | sortix* | twizzler* \
@@ -1758,7 +1736,7 @@ case $os in
| onefs* | tirtos* | phoenix* | fuchsia* | redox* | bme* \
| midnightbsd* | amdhsa* | unleashed* | emscripten* | wasi* \
| nsk* | powerunix* | genode* | zvmoe* | qnx* | emx* | zephyr* \
- | fiwix* | mlibc* )
+ | fiwix* | mlibc* | cos* | mbr* )
;;
# This one is extra strict with allowed versions
sco3.2v2 | sco3.2v[4-9]* | sco5v6*)
@@ -1766,7 +1744,7 @@ case $os in
;;
none)
;;
- kernel* )
+ kernel* | msvc* )
# Restricted further below
;;
*)
@@ -1785,6 +1763,8 @@ case $kernel-$os in
;;
managarm-mlibc* | managarm-kernel* )
;;
+ windows*-gnu* | windows*-msvc*)
+ ;;
-dietlibc* | -newlib* | -musl* | -relibc* | -uclibc* | -mlibc* )
# These are just libc implementations, not actual OSes, and thus
# require a kernel.
@@ -1799,6 +1779,10 @@ case $kernel-$os in
echo "Invalid configuration '$1': '$kernel' does not support
'$os'." 1>&2
exit 1
;;
+ *-msvc* )
+ echo "Invalid configuration '$1': '$os' needs 'windows'." 1>&2
+ exit 1
+ ;;
kfreebsd*-gnu* | kopensolaris*-gnu*)
;;
vxworks-simlinux | vxworks-simwindows | vxworks-spe)
@@ -1809,6 +1793,10 @@ case $kernel-$os in
;;
*-eabi* | *-gnueabi*)
;;
+ none-coff* | none-elf*)
+ # None (no kernel, i.e. freestanding / bare metal),
+ # can be paired with an output format "OS"
+ ;;
-*)
# Blank kernel with real OS is always fine.
;;
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index 0059305cc80..d47997ef688 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -60,7 +60,8 @@ 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 =
+BYTE_COMPILE_EXTRA_FLAGS = --eval "(setq debug-on-error t text-quoting-style
'grave byte-compile-debug t)"
# 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/cedet/mode-local.el b/lisp/cedet/mode-local.el
index 978dedfea8d..62b51d8ee8b 100644
--- a/lisp/cedet/mode-local.el
+++ b/lisp/cedet/mode-local.el
@@ -417,7 +417,7 @@ Return the value of the last VAL."
"Define MODE local variable SYM with value VAL.
DOCSTRING is optional."
(declare (indent defun)
- (defining-symbol 2)
+ (defining-symbol sym docstring)
(debug (&define symbolp name def-form [ &optional stringp ] )))
`(progn
(setq-mode-local ,mode ,sym ,val)
@@ -549,7 +549,7 @@ OVERARGS is a list of arguments passed to the override and
`NAME-default' function, in place of those deduced from ARGS."
(declare (doc-string 3)
(indent defun)
- (defining-symbol 1)
+ (defining-symbol name docstring)
(debug (&define name lambda-list stringp def-body)))
`(eval-and-compile
(defun ,name ,args
@@ -579,7 +579,7 @@ BODY is the implementation of this function."
;; FIXME: Make this obsolete and use cl-defmethod with &context instead.
(declare (doc-string 4)
(indent defun)
- (defining-symbol 1)
+ (defining-symbol name docstring)
(debug (&define name symbolp lambda-list stringp def-body)))
(let ((newname (intern (format "%s-%s" name mode))))
`(progn
diff --git a/lisp/cedet/semantic/idle.el b/lisp/cedet/semantic/idle.el
index 80a0adb9d6a..416dbd340d5 100644
--- a/lisp/cedet/semantic/idle.el
+++ b/lisp/cedet/semantic/idle.el
@@ -566,7 +566,7 @@ DOC will be a documentation string describing FORMS.
FORMS will be called during idle time after the current buffer's
semantic tag information has been updated.
This routine creates the following functions and variables:"
- (declare (indent 1) (defining-symbol 1)
+ (declare (indent 1) (defining-symbol name doc)
(debug (&define name stringp def-body)))
(let ((global (intern (concat "global-" (symbol-name name) "-mode")))
(mode (intern (concat (symbol-name name) "-mode")))
diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el
index 04680ee2cd4..59a52c35e9f 100644
--- a/lisp/cedet/semantic/lex-spp.el
+++ b/lisp/cedet/semantic/lex-spp.el
@@ -1163,7 +1163,7 @@ of type `spp-macro-def' is to be created.
VALFORM are forms that return the value to be saved for this macro, or nil.
When implementing a macro, you can use `semantic-lex-spp-stream-for-macro'
to convert text into a lexical stream for storage in the macro."
- (declare (defining-symbol 1)
+ (declare (defining-symbol name doc)
(debug (&define name stringp stringp form def-body))
(indent 1))
(let ((start (make-symbol "start"))
@@ -1199,7 +1199,7 @@ REGEXP is a regular expression for the analyzer to match.
See `define-lex-regex-analyzer' for more on regexp.
TOKIDX is an index into REGEXP for which a new lexical token
of type `spp-macro-undef' is to be created."
- (declare (defining-symbol 1)
+ (declare (defining-symbol name doc) ; Is this valid? 2024-01-20 NO!
2024-02-08 YES!
(debug (&define name stringp stringp form))
(indent 1))
(let ((start (make-symbol "start"))
@@ -1262,7 +1262,7 @@ type of include. The return value should be of the form:
(NAME . TYPE)
where NAME is the name of the include, and TYPE is the type of the include,
where a valid symbol is `system', or nil."
- (declare (defining-symbol 1)
+ (declare (defining-symbol name doc)
(debug (&define name stringp stringp form def-body))
(indent 1))
(let ((start (make-symbol "start"))
diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el
index dd00dfc7138..e2bcf6417ed 100644
--- a/lisp/cedet/semantic/lex.el
+++ b/lisp/cedet/semantic/lex.el
@@ -757,7 +757,7 @@ If two analyzers can match the same text, it is important
to order the
analyzers so that the one you want to match first occurs first. For
example, it is good to put a number analyzer in front of a symbol
analyzer which might mistake a number for a symbol."
- (declare (defining-symbol 1)
+ (declare (defining-symbol name doc)
(debug (&define name stringp (&rest symbolp))) (indent 1))
`(defun ,name (start end &optional depth length)
,(concat doc "\nSee `semantic-lex' for more information.")
@@ -1094,7 +1094,7 @@ Proper action in FORMS is to move the value of
`semantic-lex-end-point' to
after the location of the analyzed entry, and to add any discovered tokens
at the beginning of `semantic-lex-token-stream'.
This can be done by using `semantic-lex-push-token'."
- (declare (defining-symbol 1)
+ (declare (defining-symbol name doc)
(debug (&define name stringp form def-body)) (indent 1))
`(eval-and-compile
;; This is the real info used by `define-lex' (via
semantic-lex-one-token).
@@ -1117,7 +1117,7 @@ This can be done by using `semantic-lex-push-token'."
"Create a lexical analyzer with NAME and DOC that will match REGEXP.
FORMS are evaluated upon a successful match.
See `define-lex-analyzer' for more about analyzers."
- (declare (defining-symbol 1)
+ (declare (defining-symbol name doc)
(debug (&define name stringp form def-body)) (indent 1))
`(define-lex-analyzer ,name
,doc
@@ -1136,7 +1136,7 @@ expression.
FORMS are evaluated upon a successful match BEFORE the new token is
created. It is valid to ignore FORMS.
See `define-lex-analyzer' for more about analyzers."
- (declare (defining-symbol 1)
+ (declare (defining-symbol name doc)
(debug
(&define name stringp form symbolp [ &optional form ] def-body))
(indent 1))
@@ -1164,7 +1164,7 @@ where BLOCK-SYM is the symbol returned in a block token.
OPEN-DELIM
and CLOSE-DELIM are respectively the open and close delimiters
identifying a block. OPEN-SYM and CLOSE-SYM are respectively the
symbols returned in open and close tokens."
- (declare (defining-symbol 1)
+ (declare (defining-symbol name doc)
(debug (&define name stringp form (&rest form)))
(indent 1))
(let ((specs (cons spec1 specs))
diff --git a/lisp/cedet/semantic/wisent.el b/lisp/cedet/semantic/wisent.el
index 5378aba4fba..23da3ac5df5 100644
--- a/lisp/cedet/semantic/wisent.el
+++ b/lisp/cedet/semantic/wisent.el
@@ -66,7 +66,7 @@ Returned tokens must have the form:
(TOKSYM VALUE START . END)
where VALUE is the buffer substring between START and END positions."
- (declare (defining-symbol 1)
+ (declare (defining-symbol name doc)
(debug (&define name stringp def-body)) (indent 1))
`(defun
,name () ,doc
diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el
index 84527234207..0be984f1492 100644
--- a/lisp/emacs-lisp/backquote.el
+++ b/lisp/emacs-lisp/backquote.el
@@ -172,6 +172,30 @@ LEVEL is only used internally and indicates the nesting
level:
(backquote-delay-process s (1- level))))
((eq (car s) backquote-backquote-symbol)
(backquote-delay-process s (1+ level)))
+ ;; Process a (lambda ...) form specially, since otherwise the
+ ;; lambda symbol would get separated from its introductory (,
+ ;; preventing this processing from being done elsewhere in macro
+ ;; expansion.
+ ((and (eq (car s) 'lambda)
+ (symbol-with-pos-p (car s))
+ (listp (car-safe (cdr s))))
+ (let ((kdr (backquote-process (cdr s) level))
+ (lambda-pos (symbol-with-pos-pos (car s)))
+ )
+ (if (null byte-compile-in-progress)
+ (setcar s 'lambda)) ; Strip the position.
+ (cond
+ ((= (car kdr) 0)
+ (cons (car kdr)
+ (list 'quote
+ (byte-run-posify-lambda-form
+ (cons (car s) (car (cdr (cdr kdr)))) ; Two cdr's to strip
'quote.
+ lambda-pos))))
+ (t
+ (cons 1
+ (list 'byte-run-posify-lambda-form
+ (list 'cons (list 'quote (car s)) (cdr kdr))
+ lambda-pos))))))
(t
(let ((rest s)
item firstlist list lists expression)
diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el
index 1beeb523f08..74462899efc 100644
--- a/lisp/emacs-lisp/backtrace.el
+++ b/lisp/emacs-lisp/backtrace.el
@@ -902,7 +902,8 @@ function calls currently active."
(backtrace-mode)
(setq backtrace-view '(:show-flags t)
backtrace-frames frames
- backtrace-print-function #'cl-prin1)
+ backtrace-print-function #'prin1;; #'cl-prin1 STOUGH, 2024-02-12
+ )
(backtrace-print)
(filter-buffer-substring (point-min) (point-max)))))
diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el
index 7e495536207..98a3bcbb360 100644
--- a/lisp/emacs-lisp/bindat.el
+++ b/lisp/emacs-lisp/bindat.el
@@ -906,7 +906,7 @@ a bindat type expression."
(defmacro bindat-defmacro (name args &rest body)
"Define a new Bindat type as a macro."
(declare (indent 2) (doc-string 3) (debug (&define name sexp def-body))
- (defining-symbol 1))
+ (defining-symbol name))
(let ((leaders ()))
(while (and (cdr body)
(or (stringp (car body))
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index dd286ffee81..24fbddb9d71 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -43,7 +43,7 @@ This is done by destructively modifying ARG. Return ARG."
(let ((a arg))
(while
(and
- (not (gethash a byte-run--ssp-seen))
+ (null (gethash a byte-run--ssp-seen))
(progn
(puthash a t byte-run--ssp-seen)
(cond
@@ -52,7 +52,9 @@ This is done by destructively modifying ARG. Return ARG."
((consp (car a))
(byte-run--strip-list (car a)))
((or (vectorp (car a)) (recordp (car a)))
- (byte-run--strip-vector/record (car a))))
+ (byte-run--strip-vector/record (car a)))
+ ((hash-table-p (car a))
+ (byte-run--strip-hash-table (car a))))
(consp (cdr a))))
(setq a (cdr a)))
(cond
@@ -66,7 +68,7 @@ This is done by destructively modifying ARG. Return ARG."
#'(lambda (arg)
"Strip the positions from symbols with position in the vector/record ARG.
This is done by destructively modifying ARG. Return ARG."
- (unless (gethash arg byte-run--ssp-seen)
+ (if (null (gethash arg byte-run--ssp-seen))
(let ((len (length arg))
(i 0)
elt)
@@ -75,14 +77,40 @@ This is done by destructively modifying ARG. Return ARG."
(setq elt (aref arg i))
(cond
((symbol-with-pos-p elt)
- (aset arg i elt))
+ (aset arg i (bare-symbol elt)))
((consp elt)
(byte-run--strip-list elt))
((or (vectorp elt) (recordp elt))
- (byte-run--strip-vector/record elt)))
+ (byte-run--strip-vector/record elt))
+ ((hash-table-p elt)
+ (byte-run--strip-hash-table elt)))
(setq i (1+ i)))))
arg))
+(defalias 'byte-run--strip-hash-table
+ #'(lambda (arg)
+ "Strip the positions from symbols with position in the hash table ARG.
+This is done by destructively modifying ARG. Return ARG."
+ (maphash
+ (lambda (key value)
+ (when (symbol-with-pos-p key)
+ (let ((symbols-with-pos-enabled t))
+ (remhash key arg))
+ (setq key (bare-symbol key)))
+ (puthash key
+ (cond
+ ((symbol-with-pos-p value)
+ (bare-symbol value))
+ ((consp value)
+ (byte-run--strip-list value))
+ ((or (vectorp value) (recordp value))
+ (byte-run--strip-vector/record value))
+ ((hash-table-p value)
+ (byte-run--strip-hash-table value))
+ (t value))
+ arg))
+ arg)))
+
(defalias 'byte-run-strip-symbol-positions
#'(lambda (arg)
"Strip all positions from symbols in ARG.
@@ -98,16 +126,352 @@ record, containing symbols with position."
(byte-run--strip-list arg))
((or (vectorp arg) (recordp arg))
(byte-run--strip-vector/record arg))
+ ((hash-table-p arg)
+ (byte-run--strip-hash-table arg))
+ (t arg))))
+
+(defalias 'byte-run--report-hash-table
+ #'(lambda (name arg)
+ "Report the positions from symbols with position in the hash table ARG.
+This is done by destructively modifying ARG. Return ARG."
+ (maphash
+ (lambda (key value)
+ (when (symbol-with-pos-p key)
+ (message "SWP key %S in %S, name %S" key arg name))
+ (cond
+ ((symbol-with-pos-p value)
+ (message "SWP in %S, key %S, value %S, name %S"
+ arg key value name))
+ ((consp value)
+ (byte-run--report-list name value))
+ ((or (vectorp value) (recordp value))
+ (byte-run--report-vector/record name value))
+ ((hash-table-p value)
+ (byte-run--report-hash-table name value))
+ (t value)))
+ arg)
+ arg))
+
+(defalias 'byte-run--report-vector/record
+ #'(lambda (name arg)
+ "Report the positions from symbols with position in the vector/record
ARG.
+This is done by destructively modifying ARG. Return ARG."
+ (if (null (gethash arg byte-run--ssp-seen))
+ (let ((len (length arg))
+ (i 0)
+ elt)
+ (puthash arg t byte-run--ssp-seen)
+ (while (< i len)
+ (setq elt (aref arg i))
+ (cond
+ ((symbol-with-pos-p elt)
+ (message "SWP in %S, elt %S, %S, name %S"
+ arg i elt name))
+ ((consp elt)
+ (byte-run--report-list name elt))
+ ((or (vectorp elt) (recordp elt))
+ (byte-run--report-vector/record name elt))
+ ((hash-table-p elt)
+ (byte-run--report-hash-table name elt)))
+ (setq i (1+ i)))))
+ arg))
+
+(defalias 'byte-run--report-list
+ #'(lambda (name arg)
+ "Report positions in symbols with position in the list ARG.
+This is done by destructively modifying ARG. Return ARG."
+ (let ((a arg))
+ (while
+ (and
+ (null (gethash a byte-run--ssp-seen))
+ (progn
+ (puthash a t byte-run--ssp-seen)
+ (cond
+ ((symbol-with-pos-p (car a))
+ (message "SWP in %S, %S" name (car a)))
+ ((consp (car a))
+ (byte-run--report-list name (car a)))
+ ((or (vectorp (car a)) (recordp (car a)))
+ (byte-run--report-vector/record name (car a)))
+ ((hash-table-p (car a))
+ (byte-run--report-hash-table name (car a))))
+ (consp (cdr a))))
+ (setq a (cdr a)))
+ (cond
+ ((symbol-with-pos-p (cdr a))
+ (message "SWP in %S, %S" name (cdr a)))
+ ;; ((or (vectorp (cdr a)) (recordp (cdr a)))
+ ;; (byte-run--strip-vector/record (cdr a)))
+ )
+ arg)))
+
+(defalias 'byte-run-report-symbol-positions
+ #'(lambda (name arg)
+ "Report NAME for any symbols with position in ARG.
+
+ARG is any Lisp object, but is usually a list or a vector or a
+record, containing symbols with position."
+ (setq byte-run--ssp-seen (make-hash-table :test 'eq))
+ (cond
+ ((symbol-with-pos-p arg)
+ (message "SWP in %S, %S" name arg))
+ ((consp arg)
+ (byte-run--report-list name arg))
+ ((or (vectorp arg) (recordp arg))
+ (byte-run--report-vector/record name arg))
+ ((hash-table-p arg)
+ (byte-run--report-hash-table name arg))
(t arg))))
+
+(defalias 'byte-run--posify-hash-table
+ #'(lambda (form)
+ "Posify any lambda forms still unposified in the hash table FORM.
+The original FORM is not changed. Return a changed copy of FORM or FORM."
+ (if (null (gethash form byte-run--ssp-seen))
+ (let ((new (copy-hash-table form))
+ changed)
+ (progn
+ (puthash form t byte-run--ssp-seen)
+ (maphash
+ (lambda (key value)
+ (if (null (eq value
+ (setq value
+ (cond
+ ((consp value)
+ (byte-run--posify-list value))
+ ((or (vectorp value) (recordp value))
+ (byte-run--posify-vector/record value))
+ ((hash-table-p value)
+ (byte-run--posify-hash-table value))
+ (t value)))))
+ (setq changed t))
+ (puthash key value new))
+ form)
+ (if changed new form)))
+ form)))
+
+(defalias 'byte-run--posify-vector/record
+ #'(lambda (form)
+ "Posify any lambda forms still unposified in the vector/record FORM.
+The original FORM is not changed. Return a changed copy of FORM, or FORM."
+ (if (null (gethash form byte-run--ssp-seen))
+ (let* ((len (length form))
+ (new (if (vectorp form)
+ (make-vector len nil)
+ (make-record (aref form 0) (1- len) nil)))
+ (i 0)
+ changed elt)
+ (puthash form t byte-run--ssp-seen)
+ (while (< i len)
+ (setq elt (aref form i))
+ (if (null (eq elt
+ (setq elt
+ (cond
+ ((consp elt)
+ (byte-run--posify-list elt))
+ ((or (vectorp elt) (recordp elt))
+ (byte-run--posify-vector/record elt))
+ ((hash-table-p elt)
+ (byte-run--posify-hash-table elt))
+ (t elt)))))
+ (setq changed t))
+ (aset new i elt)
+ (setq i (1+ i)))
+ (if changed new form))
+ form)))
+
+(defalias 'byte-run--posify-list
+ #'(lambda (form)
+ "Posify any lambda forms still unposified in the the list FORM.
+This original FORM is not changed. Return a changed copy of FORM or FORM."
+ (let ((a form) changed elt new)
+ (while (and (null (gethash a byte-run--ssp-seen))
+ (consp a)
+ (null (and (symbol-with-pos-p (car a))
+ (eq (bare-symbol (car a)) 'lambda))))
+ (progn
+ (puthash a t byte-run--ssp-seen)
+ (setq elt (car a))
+ (if (null
+ (eq elt
+ (setq elt
+ (cond
+ ((consp elt)
+ (byte-run--posify-list elt))
+ ((or (vectorp elt) (recordp elt))
+ (byte-run--posify-vector/record elt))
+ ((hash-table-p elt)
+ (byte-run--posify-hash-table elt))
+ (t elt)))))
+ (setq changed t))
+ (setq new (cons elt new))
+ (setq a (cdr a))))
+
+ (cond
+ ((gethash a byte-run--ssp-seen)
+ (if changed (nconc (nreverse new) a) form))
+ ((null a)
+ (if changed (nreverse new) form))
+ ((or (vectorp a) (recordp a))
+ (if (or (null (eq a (setq a (byte-run--posify-vector/record a))))
+ changed)
+ (cons (nreverse new) a)
+ form))
+ ((hash-table-p a)
+ (if (or (null (eq a (setq a (byte-run--posify-hash-table a))))
+ changed)
+ (cons (nreverse new) a)
+ form))
+ ((and (symbol-with-pos-p (car-safe a))
+ (eq (bare-symbol (car a)) 'lambda))
+ (nconc (nreverse new)
+ (let ((stripped (byte-run-posify-lambda-form
+ a (symbol-with-pos-pos (car a)))))
+ (setcar stripped 'lambda) ; Strip the position.
+ (byte-run--posify-list stripped))))
+ (t (if changed (cons (nreverse new) a) form))))))
+
+(defalias 'byte-run-posify-all-lambdas
+ #'(lambda (form)
+ "Posify any lambda forms still unposified in FORM.
+
+FORM is any Lisp object, but is usually a list or a vector or a
+record, containing symbols with position. Return FORM, possibly
+destructively modified."
+ (setq byte-run--ssp-seen (make-hash-table :test 'eq))
+ (cond
+ ((consp form)
+ (byte-run--posify-list form))
+ ((or (vectorp form) (recordp form))
+ (byte-run--posify-vector/record form))
+ ((hash-table-p form)
+ (byte-run--posify-hash-table form))
+ (t form))))
+
+
+(defalias 'byte-run--strip-lambda-doc-list
+ #'(lambda (form)
+ "Strip any doc string from all lambdas in the cons FORM, and return it."
+ (let ((a form))
+ (while
+ (and
+ (null (gethash a byte-run--ssp-seen))
+ (progn
+ (puthash a t byte-run--ssp-seen)
+ (cond
+ ((and (eq (car a) 'lambda)
+ (listp (car-safe (cdr a)))
+ (stringp (car-safe (cdr-safe (cdr a)))))
+ (setcdr (cdr a) (cdr (cdr (cdr a)))))
+ ((consp (car a))
+ (byte-run--strip-lambda-doc-list (car a)))
+ ((or (vectorp (car a)) (recordp (car a)))
+ (byte-run--strip-lambda-doc-vector/record (car a)))
+ ((hash-table-p (car a))
+ (byte-run--strip-lambda-doc-hash-table (car a))))
+ (consp (cdr a))))
+ (setq a (cdr a)))
+ (cond
+ ((or (vectorp (cdr a)) (recordp (cdr a)))
+ (byte-run--strip-lambda-doc-vector/record (cdr a)))
+ ((hash-table-p (cdr a))
+ (byte-run--strip-lambda-doc-hash-table (cdr a))))
+ form)))
+
+(defalias 'byte-run--strip-lambda-doc-vector/record
+ #'(lambda (form)
+ "Strip any doc string from all lambdas in the vector/record FORM.
+Return the possibly changed FORM."
+ (if (null (gethash form byte-run--ssp-seen))
+ (let ((len (length form))
+ (i 0)
+ elt)
+ (puthash form t byte-run--ssp-seen)
+ (while (< i len)
+ (setq elt (aref form i))
+ (cond
+ ((consp elt)
+ (byte-run--strip-lambda-doc-list elt))
+ ((or (vectorp elt) (recordp elt))
+ (byte-run--strip-lambda-doc-vector/record elt))
+ ((hash-table-p elt)
+ (byte-run--strip-lambda-doc-hash-table elt)))
+ (setq i (1+ i)))))
+ form))
+
+(defalias 'byte-run--strip-lambda-doc-hash-table
+ #'(lambda (form)
+ "Strip any doc string from all lambdas in the hash table FORM.
+Return the possibly changed FORM."
+ (if (null (gethash form byte-run--ssp-seen))
+ (puthash form t byte-run--ssp-seen)
+ (maphash
+ (lambda (_key value)
+ ;; Disregard the possibility of lambdas in `key's.
+ (cond
+ ((consp value)
+ (byte-run--strip-lambda-doc-list value))
+ ((or (vectorp value) (recordp value))
+ (byte-run--strip-lambda-doc-vector/record value))
+ ((hash-table-p value)
+ (byte-run--strip-lambda-doc-hash-table value))))
+ form))
+ form))
+
+(defalias 'byte-run-strip-lambda-doc
+ #'(lambda (form)
+ "Strip any doc string from all lambdas forms contained in FORM.
+FORM can be any Lisp object. A lambda form is something like
+\(lambda (args) \"Optional doc string\" ...). The change is done
+destructively to the original FORM. Return the possibly altered
+FORM."
+ (setq byte-run--ssp-seen (make-hash-table :test 'eq))
+ (let ((symbols-with-pos-enabled t))
+ (cond
+ ((symbolp form) form)
+ ((consp form)
+ (byte-run--strip-lambda-doc-list form))
+ ((or (vectorp form) (recordp form))
+ (byte-run--strip-lambda-doc-vector/record form))
+ ((hash-table-p form)
+ (byte-run--strip-lambda-doc-hash-table form))
+ (t form)))))
+
+(defalias 'byte-run-valid-doc-string
+ #'(lambda (str)
+ "Return non-nil if STR is a valid doc string.
+Otherwise return nil.
+If STR is a string, or of the form (:documentation \"...\"), the return
+value is t. If STR is a doc string (:documentation ...) generated at
+run time, return the symbol `var'."
+ (if (stringp str)
+ t
+ (if (eq (car-safe str) ':documentation)
+ (if (stringp (car-safe (cdr str)))
+ t
+ 'var)
+ nil))))
(defalias 'byte-run-posify-doc-string
- #'(lambda (doc-string &optional lambda-token)
+ #'(lambda (doc-string &optional lambda-pos)
"Prefix a doc string with defining position information.
DOC-STRING is the existing doc string, or if nil, the new doc
-string is created from scratch.
-LAMBDA-TOKEN when non-nil is the symbol `lambda' for which the new
-doc string is being created. It should be a symbol with position."
- (let ((pos-string
+string is created from scratch. If DOC-STRING is a
+cons, (:documentation ....), the new structure will be `concat'ed
+onto it. LAMBDA-POS when non-nil is the position of the symbol
+`lambda' for which the new doc string is being created. It
+should be a fixnum. Return the new (or unaltered) doc string.
+If DOC-STRING already has position information, return the string
+unchanged."
+ (if (cond
+ ((stringp doc-string)
+ (string-match "\\`;POS\036\001\001\001" doc-string))
+ ((and (consp doc-string)
+ (eq (car-safe doc-string) ':documentation)
+ (stringp (car-safe (cdr doc-string))))
+ (string-match "\\`;POS\036\001\001\001" (car (cdr doc-string)))))
+ doc-string
+ (let ((pos-string
(concat
";POS"
;; (let ((version ; See comments in `byte-compile-insert-header'.
@@ -117,38 +481,87 @@ doc string is being created. It should be a symbol with
position."
"\036" ; Hard coded version 30, for now. FIXME!!!
;; (cl-assert (and (> version 13) (< version 128)))
;; (string version))
- "\000\000\000 ["
+ "\001\001\001 ["
(if defining-symbol
(symbol-name (bare-symbol defining-symbol))
"nil")
" "
- (let* ((cur-buf
- (or (and (boundp 'byte-compile-current-buffer)
- byte-compile-current-buffer)
- (current-buffer)))
- (cur-file-name
- (or (and (boundp 'byte-compile-current-file)
- (if (bufferp byte-compile-current-file)
- (buffer-name byte-compile-current-file)
- byte-compile-current-file))
- (buffer-file-name (current-buffer)))))
- (cond
- (cur-file-name)
- (cur-buf (buffer-name cur-buf))
- (t ; ?minibuffer
- "nil")))
+ (cond
+ ((bufferp read-stream)
+ (let ((name (format "%s" (buffer-name read-stream))))
+ (string-replace " " "\\ " name)))
+ ;; What about reading from Fload, when we don't have a
+ ;; buffer as such? FIXME!!! STOUGH, 2023-12-15.
+ ((stringp read-stream) ; A file name
+ read-stream)
+ (t ; ?minibuffer
+ "nil")) ;; )
" "
(if (symbol-with-pos-p defining-symbol)
(format "%d" (symbol-with-pos-pos defining-symbol))
"nil")
" "
- (if (symbol-with-pos-p lambda-token)
- (format "%d" (symbol-with-pos-pos lambda-token))
+ (if (numberp lambda-pos)
+ (format "%d" lambda-pos)
"nil")
"]\n")))
- (if doc-string
- (concat pos-string doc-string)
- pos-string))))
+ (cond
+ ((null doc-string) pos-string)
+ ((stringp doc-string) (concat pos-string doc-string))
+ ((and (consp doc-string) (eq (car doc-string) ':documentation))
+ (list (car doc-string)
+ (cond ((stringp (car (cdr doc-string)))
+ (concat pos-string (car (cdr doc-string))))
+ ((consp (car (cdr doc-string)))
+ (list 'concat pos-string
+ (car (cdr doc-string))))
+ (t (list 'concat pos-string
+ (car (cdr doc-string)))))))
+ (t ; Oclosure type info in the doc string position. Deal with this
+ ; sometime (2024-02-26).
+ doc-string
+ ))))))
+
+(defalias 'byte-run-posify-lambda-form
+ #'(lambda (form position)
+ "Put position structure on the lambda form FORM.
+POSITION is one position that will be used, the other coming from
+`defining-symbol'.
+
+The modification of FORM will be done by creating a new list
+form."
+ (let* ((bare-ds (bare-symbol defining-symbol))
+ (cand-doc-string (nth 2 form))
+ (doc-string
+ (and (byte-run-valid-doc-string cand-doc-string)
+ cand-doc-string))
+ (already-posified
+ (and doc-string
+ (cond
+ ((stringp doc-string)
+ (string-match "^;POS\036\001\001\001" doc-string))
+ ((stringp (car-safe (cdr-safe doc-string)))
+ (string-match "^;POS\036\001\001\001"
+ (car (cdr doc-string))))
+;;;; STOUGH TO AMEND WHEN APPROPRIATE, 2023-12-17
+ (t t) ; For (:documentation 'symbol), in oclosures.
+;;;; END OF STOUGH
+ )))
+ (empty-body-allowed
+ (and bare-ds (get bare-ds 'empty-body-allowed)))
+ (insert (or (null doc-string)
+ (and (null empty-body-allowed)
+ (null (nthcdr 3 form))))))
+
+ (if (and (null already-posified)
+ (>= (length form) 2))
+ (let ((new-doc-string (byte-run-posify-doc-string
+ doc-string
+ position)))
+ (nconc (take 2 form)
+ (list new-doc-string)
+ (nthcdr (if insert 2 3) form)))
+ form))))
(defalias 'function-put
;; We don't want people to just use `put' because we can't conveniently
@@ -205,7 +618,7 @@ So far, FUNCTION can only be a symbol, not a lambda
expression."
(defalias 'byte-run--set-compiler-macro
#'(lambda (f args compiler-function)
- (if (not (eq (car-safe compiler-function) 'lambda))
+ (if (null (eq (car-safe compiler-function) 'lambda))
`(eval-and-compile
(function-put ',f 'compiler-macro #',compiler-function))
(let ((cfname (intern (concat (symbol-name f) "--anon-cmacro")))
@@ -267,14 +680,190 @@ So far, FUNCTION can only be a symbol, not a lambda
expression."
(cadr elem)))
val)))))
-(defalias 'byte-run--set-defining-symbol
- #'(lambda (_name args &rest def-sym-poses)
- (list 'if '(null defining-symbol)
- (list 'setq 'defining-symbol
- (if (numberp (car def-sym-poses))
- (nth (1- (car def-sym-poses)) args)
- (car def-sym-poses))))))
-(put 'byte-run--set-defining-symbol 'pre-form t)
+(defalias 'byte-run--extract-sym-from-form
+ #'(lambda (form args)
+ "Return the \"first\" arg in ARGS which occurs in list FORM.
+ARGS has the shape of an arglist from a lambda form, FORM is a list
+which is capable of being evaluated. If an arg isn't found, return
+nil."
+ (cond
+ ((symbolp form) (car (memq form args)))
+ ((consp form)
+ (let ((tail (cdr form)) sym
+ )
+ (while (and tail
+ (null
+ (setq sym
+ (byte-run--extract-sym-from-form
+ (car tail) args))))
+ (setq tail (cdr tail)))
+ sym)))))
+
+(defalias 'byte-run--doc-n
+ #'(lambda (doc-spec args)
+ "Return the \"index\" of DOC-SPEC in a member of ARGS.
+This index is the number of cdr's in DOC-SPEC which is of the form
+(car (cdr (cdr ..... arg))), where arg is a member of the list ARGS.
+(nth index arg) would give the same result as DOC-SPEC. If
+DOC-SPEC is not of the above form, return nil."
+ (let ((n 0))
+ (and (eq (car-safe doc-spec) 'car)
+ (progn
+ (while
+ (progn
+ (setq doc-spec (car-safe (cdr doc-spec)))
+ (eq (car-safe doc-spec) 'cdr))
+ (setq n (1+ n)))
+ (memq doc-spec args))
+ n))))
+
+(defalias 'byte-run--posify-defining-form
+ #'(lambda (f args &rest bit-specs)
+ "Create code to posify an invocation of F with arglist ARGS.
+
+This handler makes the invoking macro a defining macro. The
+`defining-symbol' declare clause which invokes this function specifies
+which symbol the macro will be defining, where to find its doc string,
+and whether to insert a new doc string if the macro invocation
+would result in an empty body. It is used to make macros such as `defun'
+and `cl-defstruct' defining macros.
+
+It returns a list of two Lisp forms: (i) to set the `byte-run-defined-form'
+property on the macro being defined; (ii) to cause the defining macro to
+posify the forms it defines.
+
+BIT-SPECS, the cdr of the `defining-symbol' declare clause consists of three
+elements: (i) A Lisp form, usually a symbol, which specifies how to get what
+the macro will use as the new name being defined; (ii) The location of the
+doc string in ARGS. This is either a symbol (an element of ARGS) or of the
form
+(car (cdr (cdr ..... arg))), with zero or more `cdr's. These may not be
+abbreviated to (cadr arg), etc. This element is optional when there is a
+&rest (or &body) form in ARGS. In this case the doc string is assumed to be
+the first &rest element; (iii) An optional `t' element. If present, it means
+that if the form being defined by the macro would have an empty body, NOT to
+assume that a doc string is also the value of the form. See `cl-defstruct' for
+an example of its use."
+ (let* ((def-spec (car bit-specs))
+ (rest-stuff
+ (or (memq '&rest args)
+ (memq '&body args))) ; YUCK!
+ (body-spec (and (eq (length rest-stuff) 2)
+ (car (cdr rest-stuff))))
+ (doc-spec
+ (cond ((and body-spec
+ (memq (car (cdr bit-specs)) '(nil t)))
+ (list 'car body-spec)) ; Default
+ ((symbolp (car (cdr bit-specs)))
+ (car (cdr bit-specs)))
+ ((byte-run--doc-n (car (cdr bit-specs)) args)
+ (car (cdr bit-specs)))
+ (t (error "Invalid arguments to defining-form declare
clause in %s" f))))
+ ;; We want to insert a new doc string if `doc-spec' is an
+ ;; &optional parameter just before the &rest arg, and its
+ ;; run time value isn't a string (e.g. a keyword in
+ ;; `define-derived-mode' signifying a missing doc string).
+ (can-insert-doc-before-rest
+ (and rest-stuff
+ (symbolp doc-spec)
+ (memq doc-spec (memq '&optional args))
+ (eq (cdr (memq doc-spec args)) rest-stuff)))
+ (empty-body-flag (and (memq t bit-specs) ; Empty body allowed?
+ (eq (length (memq t bit-specs)) 1)))
+ (def-arg-sym (byte-run--extract-sym-from-form def-spec args))
+ (doc-arg-sym
+ (byte-run--extract-sym-from-form doc-spec args))
+ (doc-n (and (consp doc-spec)
+ (byte-run--doc-n doc-spec args)))
+ (after-doc-spec (and doc-n
+ (list 'nthcdr (1+ doc-n) doc-arg-sym)))
+ (def-index
+ (let ((i 1) (rest-args args))
+ (while (and rest-args (null (eq (car rest-args) def-arg-sym)))
+ (progn (setq rest-args (cdr rest-args)) (setq i (1+ i))))
+ (and rest-args i))))
+
+ (if (null (and def-index doc-arg-sym))
+ (error "Invalid arguments to defining-form declare clause in %s"
+ f))
+
+ (cons
+ (list 'function-put (list 'quote f)
+ ''byte-run-defined-form
+ def-index)
+ (list
+ 'progn
+ (list 'or 'defining-symbol
+ (list 'setq 'defining-symbol def-spec))
+
+ (list 'let*
+ (list
+ (list 'old-ds
+ (list 'and (list 'byte-run-valid-doc-string doc-spec)
+ doc-spec))
+ (list 'new-ds (list 'byte-run-posify-doc-string 'old-ds)))
+ ;; Strip the symbol position from the name being defined.
+ (list 'if '(null byte-compile-in-progress)
+ (list 'setq def-arg-sym
+ (list 'byte-run-strip-symbol-positions
+ def-arg-sym)))
+ ;; Strip the symbol position from the name in the
+ ;; original form.
+ (list 'if (list 'and 'cur-evalled-macro-form
+ (list 'null 'byte-compile-in-progress))
+ (list
+ 'let
+ (list
+ (list 'stripped-arg
+ (list 'byte-run-strip-symbol-positions
+ (list 'nth def-index
+ 'cur-evalled-macro-form))))
+ (list 'setcar (list 'nthcdr def-index
+ 'cur-evalled-macro-form)
+ 'stripped-arg)))
+ (if empty-body-flag
+ (list 'put def-spec ''empty-body-allowed t)
+ (list 'progn))
+ ;; Replace the old doc string with the new, or
+ ;; insert the new.
+ (cond
+ (can-insert-doc-before-rest
+ (list 'if (list 'byte-run-valid-doc-string 'old-ds)
+ (list 'setq doc-spec 'new-ds)
+ ;; If `doc-spec' isn't a string, it's part of the body.
+ (list 'setq body-spec
+ (list 'cons doc-spec body-spec))
+ (list 'setq doc-spec 'new-ds)))
+ ((symbolp doc-spec)
+ (list 'setq doc-spec 'new-ds))
+ (t
+ (list
+ 'setq doc-arg-sym
+ (list
+ 'nconc
+ (list 'take doc-n doc-arg-sym)
+ (list
+ 'cond
+ ;; doc-string present and a non-nil (cdr body):
+ (list (list 'and (list 'byte-run-valid-doc-string
+ doc-spec)
+ after-doc-spec)
+ (list 'list 'new-ds))
+ ;; Single string, both doc string and return value:
+ (list (list 'byte-run-valid-doc-string doc-spec)
+ (if empty-body-flag
+ (list 'list 'new-ds)
+ (list 'list 'new-ds 'old-ds)))
+ ;; Neither doc string nor return value:
+ (list (list 'null (list 'nthcdr doc-n doc-arg-sym))
+ (if empty-body-flag
+ (list 'list 'new-ds)
+ (list 'list 'new-ds ''nil)))
+ ;; No doc string, but a non-nil body, not a string.
+ (list t
+ (list 'list 'new-ds doc-spec)))
+ after-doc-spec))))))))))
+
+(put 'byte-run--posify-defining-form 'byte-run-pre-form t)
;; Add any new entries to info node `(elisp)Declare Form'.
(defvar defun-declarations-alist
@@ -327,6 +916,7 @@ This is used by `declare'.")
(declare-form nil)
(interactive-form nil)
(warnings nil)
+ (non-bare-doc nil)
(warn #'(lambda (msg form)
(push (macroexp-warn-and-return
(format-message msg) nil nil t form)
@@ -336,20 +926,31 @@ This is used by `declare'.")
(let* ((form (car body))
(head (car-safe form)))
(cond
- ((and (stringp form) (null (cdr body)))
+ ((and (null docstring)
+ (stringp form) (null (cdr body)))
;; The doc string is also the defun's return value.
(setq docstring form)
nil) ; Don't remove the doc string from BODY.
((or (and (stringp form) (cdr body))
(eq head :documentation))
(cond
- (docstring (funcall warn "More than one doc string" top))
+ (non-bare-doc
+ (funcall warn "More than one doc string" top))
(declare-form
(funcall warn "Doc string after `declare'"
declare-form))
(interactive-form
(funcall warn "Doc string after `interactive'"
interactive-form))
- (t (setq docstring form)))
+ ((string-match "\\`;POS\36\1\1\1 \\[[^]]+]\n\\'"
+ (cond
+ ((stringp form)
+ form)
+ ((stringp (car (cdr form)))
+ (car (cdr form)))
+ (t "")))
+ (setq docstring form))
+ (t (setq docstring form)
+ (setq non-bare-doc t)))
t)
((eq head 'declare)
(cond
@@ -361,7 +962,7 @@ This is used by `declare'.")
t)
((eq head 'interactive)
(cond
- ((not allow-interactive)
+ ((null allow-interactive)
(funcall warn "No `interactive' form allowed here"
form))
(interactive-form
(funcall warn "More than one `interactive' form" form))
@@ -378,11 +979,11 @@ This is used by `declare'.")
#'(lambda (x)
(let ((f (cdr (assq (car x) declarations-alist))))
(cond
- ((and f (symbolp (car f)) (get (car f) 'pre-form))
- (setq cl-decls
- (cons (apply (car f) name arglist (cdr x))
- cl-decls))
- nil)
+ ((and f (symbolp (car f))
+ (get (car f) 'byte-run-pre-form))
+ (let ((res (apply (car f) name arglist (cdr x))))
+ (setq cl-decls (cons (cdr res) cl-decls))
+ (car res)))
(f (apply (car f) name arglist (cdr x)))
;; Yuck!!
((and (featurep 'cl)
@@ -400,7 +1001,7 @@ This is used by `declare'.")
(defvar macro-declarations-alist
(cons
- (list 'defining-symbol #'byte-run--set-defining-symbol)
+ (list 'defining-symbol #'byte-run--posify-defining-form)
(cons
(list 'debug #'byte-run--set-debug)
(cons
@@ -426,16 +1027,27 @@ and the result should be a form to be evaluated instead
of the original.
DECL is a declaration, optional, of the form (declare DECLS...) where
DECLS is a list of elements of the form (PROP . VALUES). These are
interpreted according to `macro-declarations-alist'.
-The return value is undefined.
\(fn NAME ARGLIST [DOCSTRING] [DECL] BODY...)"
(if (null defining-symbol) ; For, e.g., components of cl-defstruct's;
(setq defining-symbol name)) ; they must get the original symbol.
+ (let*
+ ((old-ds
+ (or (and (stringp (car body)) (car body))
+ (and (eq (car-safe (car body)) ':documentation)
+ (car body))))
+ (new-ds (byte-run-posify-doc-string old-ds)))
+ ;; Replace the old doc string with the new, or insert the new.
+ (setq body
+ (cond
+ ((and (stringp (car body)) (cdr body))
+ (cons new-ds (cdr body)))
+ ((stringp (car body)) (list new-ds old-ds))
+ ((null (car body)) (list new-ds 'nil))
+ (t (cons new-ds body)))))
(let* ((parse (byte-run--parse-body body nil))
(docstring
- (if (or (stringp (nth 0 parse)) (null (nth 0 parse)))
- (byte-run-posify-doc-string (nth 0 parse))
- (nth 0 parse)))
+ (nth 0 parse))
(declare-form (nth 1 parse))
(body (or (nth 3 parse)
'(nil)))
@@ -445,6 +1057,9 @@ The return value is undefined.
name arglist (cdr declare-form) 'macro
macro-declarations-alist))))
(setq body (nconc warnings body))
+ (if (and (null byte-compile-in-progress)
+ (symbol-with-pos-p name))
+ (setq name (bare-symbol name)))
(setq body (nconc (cdr declarations) body))
(if docstring
(setq body (cons docstring body)))
@@ -457,6 +1072,7 @@ The return value is undefined.
(if declarations
(cons 'prog1 (cons def (car declarations)))
def))))))
+(function-put 'defmacro 'byte-run-defined-form 1)
;; Now that we defined defmacro we can use it!
(defmacro defun (name arglist &rest body)
@@ -466,11 +1082,10 @@ DECL is a declaration, optional, of the form (declare
DECLS...) where
DECLS is a list of elements of the form (PROP . VALUES). These are
interpreted according to `defun-declarations-alist'.
INTERACTIVE is an optional `interactive' specification.
-The return value is undefined.
\(fn NAME ARGLIST [DOCSTRING] [DECL] [INTERACTIVE] BODY...)"
(declare (doc-string 3) (indent 2)
- (defining-symbol 1))
+ (defining-symbol name))
(or name (error "Cannot define '%s' as a function" name))
(if (null
(and (listp arglist)
@@ -478,9 +1093,7 @@ The return value is undefined.
(error "Malformed arglist: %s" arglist))
(let* ((parse (byte-run--parse-body body t))
(docstring
- (if (or (stringp (nth 0 parse)) (null (nth 0 parse)))
- (byte-run-posify-doc-string (nth 0 parse))
- (nth 0 parse)))
+ (nth 0 parse))
(declare-form (nth 1 parse))
(interactive-form (nth 2 parse))
(body
@@ -507,8 +1120,129 @@ The return value is undefined.
(if declarations
(cons 'prog1 (cons def (car declarations)))
def))))
-
+
+(defun byte-run--fun-doc-pos/macro (fun)
+ "FUN should be a function form. Is it a lambda, a closure, a macro?
+Return a cons of (DOC-POS . MAC), where DOC-POS is the position
+in FUN of the doc string (if any), depending on what FUN is,
+and MAC is `macro' if additionally FUN is a macro, else nil.
+
+If it's something else, return nil."
+ (if (consp fun)
+ (let ((mac (and (eq (car-safe fun) 'macro) 'macro)))
+ (if (eq mac 'macro)
+ (setq fun (cdr fun)))
+ (if (consp fun)
+ (let ((doc-pos (cond ((eq (car fun) 'lambda) 2)
+ ((eq (car fun) 'closure) 3)
+ (t nil))))
+ (and doc-pos (cons doc-pos mac)))))))
+
+(defun byte-run--fun-get-string (fun doc-pos/m)
+ "Get the doc string (or nil) from function form FUN.
+DOC-POS/M is a cons of FUN's doc string position and whether it's
+a macro.
+
+Return the doc sring."
+ (if (cdr doc-pos/m)
+ (setq fun (cdr fun)))
+ (and (stringp (nth (car doc-pos/m) fun))
+ (nth (car doc-pos/m) fun)))
+
+(defun byte-run--fun-put-new-string (fun doc-string doc-pos/m)
+ "Put a new doc string into FUN.
+FUN is an interpreted function form, DOC-STRING is the new doc
+string, including any position information on DOC-POS/M is a cons
+of FUN's DOC-POS and whether it's a macro.
+
+Create and return a new form rather than altering the old one."
+ (if (cdr doc-pos/m)
+ (setq fun (cdr fun)))
+ (let* ((doc-pos (car doc-pos/m))
+ (insert (null (stringp (nth doc-pos fun)))))
+ (nconc (take doc-pos fun)
+ (list doc-string)
+ (nthcdr (if insert doc-pos (1+ doc-pos)) fun))))
+
+(defun byte-run--fun-get-lambda-pos (fun doc-pos/m)
+ "Get the position (if any) of the lambda symbol from FUN.
+FUN is a function form, DOC-POS/M is a cons of FUN's DOC-POS and
+whether it's a macro.
+
+Return the position of the lambda or closure symbol from FUN."
+ (if (cdr doc-pos/m)
+ (setq fun (cdr fun)))
+ (and (symbol-with-pos-p (car fun))
+ (symbol-with-pos-pos (car fun))))
+
+(defun byte-run-strip-pos-info (string)
+ "Remove the POS info, if any, from STRING, returning what's left.
+STRING may be nil.
+
+If no changes are made, return the original STRING. If there are
+no characters other than the POS info, return nil instead."
+ (if string
+ (let (start index)
+ (while
+ (and (setq index (string-match ";POS.\001\001\001 " string start))
+ (string-match "\n" string index))
+ (setq start (match-end 0)))
+ (cond
+ ((and start (< start (length string)))
+ (substring string start))
+ ((and start (eq start (length string)))
+ nil)
+ ((null index) string)))))
+
+(defun byte-run-posify-existing-defaliases-1 (sym)
+ "Sub function of `byte-run-posify-existing-defaliases'."
+ (let ((defining-symbol (get sym 'byte-run--early-defalias))) ; Symbol with
pos.
+ (if defining-symbol
+ (let* ((fun (symbol-function sym))
+ (doc-pos/m (byte-run--fun-doc-pos/macro fun)))
+ (if doc-pos/m
+ (let*
+ ((lambda-pos (byte-run--fun-get-lambda-pos fun doc-pos/m))
+ (old-doc-string (byte-run--fun-get-string fun doc-pos/m))
+ (bare-doc-string (byte-run-strip-pos-info old-doc-string))
+ (new-doc-string (byte-run-posify-doc-string bare-doc-string
+ lambda-pos)))
+ (byte-run--fun-put-new-string fun new-doc-string
doc-pos/m)))))))
+
+(defun byte-run-posify-existing-defaliases ()
+ "Create the position structure in the doc strings of existing functions.
+At the same time, strip the positions from the defining symbol and the
+lambda."
+ ;; This function should be run with `symbols-with-pos-enabled'
+ ;; non-nil. We can't use a lambda form here, since it would have a
+ ;; position on the lambda symbol.
+ (mapatoms #'byte-run-posify-existing-defaliases-1))
+
+(defun byte-run-posify-existing-lambdas ()
+ "Create the position structure in the doc strings of existing lambdas.
+At the same time, strip the positions from the defining symbol and
+the lambda."
+ (let ((tail early-lambda-lists))
+ (while tail
+ (let* ((elt (car tail)) ; (((lambda (..) ...) #<symbol lambda at N>
+ ; #<symbol foo at M>))
+ (pointer (car elt)) ; ((lambda (..) ...))
+ (form-elt (car (cdr elt))) ; #<symbol lambda at N>
+ (defining-symbol (car (cdr (cdr elt)))))
+ (setcar (car pointer) form-elt)
+ (if (null defining-symbol)
+ (message "byte-run-posify-existing-lambdas: null defining-symbol")
+ (let ((form1 (byte-run-posify-lambda-form
+ (car pointer) ;; form
+ (and (symbol-with-pos-p (car pointer))
+ (symbol-with-pos-pos (car pointer))))))
+ (setcar pointer
+ form1)
+ (if (null byte-compile-in-progress)
+ (setcar (car pointer) 'lambda))))) ; Strip any position.
+ (setq tail (cdr tail)))))
+
;; Redefined in byte-opt.el.
;; This was undocumented and unused for decades.
(defalias 'inline 'progn
@@ -548,8 +1282,11 @@ You don't need this. (See bytecomp.el commentary for
more details.)
"Define an inline function. The syntax is just like that of `defun'.
\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)"
- (declare (debug defun) (doc-string 3) (indent 2))
- (or (memq (get name 'byte-optimizer)
+ (declare (debug defun) (doc-string 3) (indent 2)
+ (defining-symbol name))
+ (let ((bare-name (bare-symbol name)))
+ (or (memq (get bare-name
+ 'byte-optimizer)
'(nil byte-compile-inline-expand))
(error "`%s' is a primitive" name))
`(prog1
@@ -559,7 +1296,8 @@ You don't need this. (See bytecomp.el commentary for more
details.)
;; definition in `byte-compile-unfold-bcf' to perform the
;; inlining (Bug#42664, Bug#43280, Bug#44209).
,(byte-run--set-speed name nil -1)
- (put ',name 'byte-optimizer 'byte-compile-inline-expand))))
+ (put ',bare-name
+ 'byte-optimizer 'byte-compile-inline-expand)))))
(defvar advertised-signature-table (make-hash-table :test 'eq :weakness 'key))
@@ -751,7 +1489,7 @@ types. The types that can be suppressed with this macro
are
;; Note: during compilation, this definition is overridden by the one in
;; byte-compile-initial-macro-environment.
(declare (debug (sexp body)) (indent 1))
- (if (not (and (featurep 'macroexp)
+ (if (null (and (featurep 'macroexp)
(boundp 'byte-compile--suppressed-warnings)))
;; If `macroexp' is not yet loaded, we're in the middle of
;; bootstrapping, so better risk emitting too many warnings
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index f2356899cc0..82811a52a0a 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -487,6 +487,10 @@ Filled in `cconv-analyze-form' but initialized and
consulted here.")
(defvar byte-compiler-error-flag)
+;; This variable is declared in src/lread.c for convenience in reading
+;; symbols.
+(defvar byte-compile-in-progress)
+
(defun byte-compile-recurse-toplevel (form non-toplevel-case)
"Implement `eval-when-compile' and `eval-and-compile'.
Return the compile-time value of FORM."
@@ -1892,20 +1896,22 @@ It is too wide if it has any lines longer than the
largest of
(setq tem (byte-compile-log-file))
(unless warning-series-started
(setq warning-series (or tem 'byte-compile-warning-series)))
- (if byte-compile-debug
+ ;; (if byte-compile-debug STOUGH, 2024-02-13
(funcall --displaying-byte-compile-warnings-fn)
- (condition-case error-info
- (funcall --displaying-byte-compile-warnings-fn)
- (error (byte-compile-report-error error-info)))))
+ ;; (condition-case error-info STOUGH, 2024-02-13
+ ;; (funcall --displaying-byte-compile-warnings-fn)
+ ;; (error (byte-compile-report-error error-info))))
+ )
;; warning-series does not come from compilation, so bind it.
(let ((warning-series
;; Log the file name. Record position of that text.
(or (byte-compile-log-file) 'byte-compile-warning-series)))
- (if byte-compile-debug
+ ;; (if byte-compile-debug STOUGH, 2024-02-13
(funcall --displaying-byte-compile-warnings-fn)
- (condition-case error-info
- (funcall --displaying-byte-compile-warnings-fn)
- (error (byte-compile-report-error error-info))))))))
+ ;; (condition-case error-info STOUGH, 2024-02-13
+ ;; (funcall --displaying-byte-compile-warnings-fn)
+ ;; (error (byte-compile-report-error error-info))))
+ ))))
;;;###autoload
(defun byte-force-recompile (directory)
@@ -2166,10 +2172,9 @@ See also `emacs-lisp-byte-compile-and-load'."
;; It would be cleaner to use a temp buffer, but if there was
;; an error, we leave this buffer around for diagnostics.
;; Its name is documented in the lispref.
- (setq input-buffer (get-buffer-create
- (concat " *Compiler Input*"
- (if (zerop byte-compile-level) ""
- (format "-%s" byte-compile-level)))))
+ (setq input-buffer (generate-new-buffer
+ (file-name-nondirectory filename)))
+ (setq buffer-undo-list t)
(erase-buffer)
(setq buffer-file-coding-system nil)
;; Always compile an Emacs Lisp file as multibyte
@@ -2309,7 +2314,8 @@ With argument ARG, insert value in current buffer after
the form."
(save-excursion
(end-of-defun)
(beginning-of-defun)
- (let* ((print-symbols-bare t) ; For the final `message'.
+ (let* ((byte-compile-in-progress t)
+ (print-symbols-bare t) ; For the final `message'.
(byte-compile-current-file (current-buffer))
(byte-compile-current-buffer (current-buffer))
(start-read-position (point))
@@ -2332,7 +2338,8 @@ With argument ARG, insert value in current buffer after
the form."
((message "%s" (prin1-to-string value)))))))
(defun byte-compile-from-buffer (inbuffer)
- (let ((byte-compile-current-buffer inbuffer)
+ (let ((byte-compile-in-progress t)
+ (byte-compile-current-buffer inbuffer)
;; Prevent truncation of flonums and lists as we read and print them
(float-output-format nil)
(case-fold-search nil)
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 39a2a3eb201..12847c1d46a 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -497,7 +497,13 @@ places where they originally did not directly appear."
('nil (setq bf nil))
(`#',f
(pcase-let ((`((,f1 . (,_ . ,f2)) . ,f3) bf))
- (setq bf `((,f1 . (,(if wrapped (nth 2 f) cif) . ,f2)) . ,f3)))
+ (setq bf `((,f1 . (,(if wrapped
+ (if (stringp (nth 2 f))
+ (nth 3 f)
+ (nth 2 f))
+ cif)
+ . ,f2))
+ . ,f3)))
(setq cif nil))
;; The interactive form needs special treatment, so the form
;; inside the `interactive' won't be used any further.
@@ -914,7 +920,11 @@ for the lexical bindings."
;; should keep their whole context untrimmed (bug#59213).
(and (eq :closure-dont-trim-context (nth 2 fun))
;; Check the function doesn't just return the magic keyword.
- (nthcdr 3 fun)))
+ (nthcdr 3 fun))
+ (and (stringp (nth 2 fun))
+ (eq :closure-dont-trim-context (nth 3 fun))
+ ;; Ditto with a doc string.
+ (nthcdr 4 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
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index d014df79767..3d1be7daf3c 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -244,11 +244,9 @@ DEFAULT-BODY, if present, is used as the body of a default
method.
(declare (indent 2) (doc-string 3)
(defining-symbol
(if (eq (car-safe name) 'setf)
- (progn
- (require 'gv)
- (declare-function gv-setter "gv" (name))
- (gv-setter (cadr name)))
- name))
+ (car (cdr name))
+ name)
+ t)
(debug
(&define
&interpose
@@ -296,7 +294,10 @@ DEFAULT-BODY, if present, is used as the body of a default
method.
(_ (push (pop options-and-methods) options))))
(when options-and-methods
;; Anything remaining is assumed to be a default method body.
- (push `(,args ,@options-and-methods) methods))
+ ;; A kludge to avoid a single string which is the return value
+ ;; of the method getting later sucked into the doc string.
+ (let ((default-doc (byte-run-posify-doc-string nil)))
+ (push `(,args ,default-doc ,@options-and-methods) methods)))
(when (eq 'setf (car-safe name))
(require 'gv)
(declare-function gv-setter "gv" (name))
@@ -355,7 +356,7 @@ This macro can only be used within the lexical scope of a
cl-generic method."
"Define a special kind of context named NAME.
Whenever a context specializer of the form (NAME . ARGS) appears,
the specializer used will be the one returned by BODY."
- (declare (defining-symbol 1)
+ (declare (defining-symbol name)
(debug (&define name lambda-list def-body)) (indent defun))
`(eval-and-compile
(put ',name 'cl-generic--context-rewriter
@@ -528,7 +529,7 @@ of specific types of arguments.
ARGS is a list of dispatch arguments (see `cl-defun'), but where
each variable element is either just a single variable name VAR,
-or a list on the form (VAR TYPE).
+or a list of the form (VAR TYPE).
For instance:
@@ -564,13 +565,9 @@ The set of acceptable TYPEs (also called \"specializers\")
is defined
\(fn NAME [EXTRA] [QUALIFIER] ARGS &rest [DOCSTRING] BODY)"
(declare (doc-string cl--defmethod-doc-pos) (indent defun)
- (defining-symbol
- (if (eq (car-safe name) 'setf)
- (progn
- (require 'gv)
- (declare-function gv-setter "gv" (name))
- (gv-setter (cadr name)))
- name))
+ ;; Because there are a variable number of parameters preceding
+ ;; any doc string, it is currently not possible to code a
+ ;; defining-symbol clause. ACM, 2024-03-02.
(debug
(&define ; this means we are defining something
[&name [sexp ;Allow (setf ...) additionally to symbols.
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 6cb6f3a80b4..9618dd0578d 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -390,7 +390,7 @@ written simply `VAR'. See the Info node `(cl)Argument
Lists' for
more details.
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
- (declare (defining-symbol 1)
+ (declare (defining-symbol name)
(debug
;; Same as defun but use cl-lambda-list.
(&define [&name symbolp]
@@ -409,7 +409,7 @@ Like normal `iter-defun', except ARGLIST allows full Common
Lisp conventions,
and BODY is implicitly surrounded by (cl-block NAME ...).
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
- (declare (defining-symbol 1)
+ (declare (defining-symbol name)
(debug
;; Same as iter-defun but use cl-lambda-list.
(&define [&name sexp] ;Allow (setf ...) additionally to symbols.
@@ -474,7 +474,7 @@ written simply `VAR'. See the Info node `(cl)Argument
Lists' for
more details.
\(fn NAME ARGLIST [DOCSTRING] BODY...)"
- (declare (defining-symbol 1)
+ (declare (defining-symbol name)
(debug
(&define name cl-macro-list cl-declarations-or-string def-body))
(doc-string 3)
@@ -3003,7 +3003,7 @@ To see the documentation for a defined struct type, use
\(fn NAME &optional DOCSTRING &rest SLOTS)"
(declare (doc-string 2) (indent 1)
(defining-symbol
- (if (consp struct) (car struct) struct))
+ (if (consp struct) (car struct) struct) t)
(debug
(&define ;Makes top-level form not be wrapped.
[&or symbolp
@@ -3621,7 +3621,7 @@ possible. Unlike regular macros, BODY can decide to
\"punt\" and leave the
original function call alone by declaring an initial `&whole foo' parameter
and then returning foo."
;; Like `cl-defmacro', but with the `&whole' special case.
- (declare (defining-symbol 1)
+ (declare (defining-symbol func)
(debug (&define [&name symbolp "@cl-compiler-macro"]
cl-macro-list
cl-declarations-or-string def-body))
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 73764eb1d79..acd9615aaee 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -3356,7 +3356,7 @@ the deferred compilation mechanism."
(comp-log "\n \n" 1)
(unwind-protect
(progn
- (condition-case-unless-debug err
+ ;; (condition-case-unless-debug err
(cl-loop
with report = nil
for t0 = (current-time)
@@ -3377,25 +3377,25 @@ the deferred compilation mechanism."
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)))))))
+ ;; (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)))))))
(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..4425d13feef 100644
--- a/lisp/emacs-lisp/debug-early.el
+++ b/lisp/emacs-lisp/debug-early.el
@@ -33,6 +33,33 @@
;;; Code:
+;; The following function is a separate function so that the early
+;; bootstrap mechanism for stripping lambda symbols of their positions
+;; can work.
+
+(defvar prin1 nil
+ "Variable to hold the current `prin1' like function for debug-early.")
+
+(defalias 'debug-early-frame
+ #'(lambda (evald func args _flags)
+ "Print one frame of the currently active backtrace.
+For details, see `debug-early-backtrace'."
+ (let ((args args))
+ (if evald
+ (progn
+ (princ " ")
+ (funcall prin1 func)
+ (princ "("))
+ (progn
+ (princ " (")
+ (setq args (cons func args))))
+ (if args
+ (while (progn
+ (funcall prin1 (car args))
+ (setq args (cdr args)))
+ (princ " ")))
+ (princ ")\n"))))
+
(defalias 'debug-early-backtrace
#'(lambda ()
"Print a trace of Lisp function calls currently active.
@@ -45,30 +72,21 @@ of the build process."
(let ((print-escape-newlines t)
(print-escape-control-characters t)
(print-escape-nonascii t)
- (prin1 (if (and (fboundp 'cl-prin1)
- (fboundp 'cl-defmethod) ;Used by `cl-print'.
- (condition-case nil
- (require 'cl-print)
- (error nil)))
- #'cl-prin1
- #'prin1)))
+ (prin1
+;;;; TEMP OLD STOUGH, 2024-01-15
+ ;; (if (and (fboundp 'cl-prin1)
+ ;; (fboundp 'cl-defmethod) ;Used by `cl-print'.
+ ;; (condition-case nil
+ ;; (require 'cl-print)
+ ;; (error nil)))
+ ;; #'cl-prin1
+ ;; #'prin1)
+;;;; TEMP NEW STOUGH, 2024-01-15
+ #'prin1
+;;;; END OF TEMP STOUGH
+ ))
(mapbacktrace
- #'(lambda (evald func args _flags)
- (let ((args args))
- (if evald
- (progn
- (princ " ")
- (funcall prin1 func)
- (princ "("))
- (progn
- (princ " (")
- (setq args (cons func args))))
- (if args
- (while (progn
- (funcall prin1 (car args))
- (setq args (cdr args)))
- (princ " ")))
- (princ ")\n")))))))
+ #'debug-early-frame))))
(defalias 'debug-early
#'(lambda (&rest args)
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el
index 5411088189d..d6f08649ce9 100644
--- a/lisp/emacs-lisp/debug.el
+++ b/lisp/emacs-lisp/debug.el
@@ -154,7 +154,9 @@ where CAUSE can be:
(goto-char (debugger--buffer-state-pos state)))
;;;###autoload
-(setq debugger 'debug)
+(if (null noninteractive)
+ (setq debugger 'debug))
+
;;;###autoload
(defun debug (&rest args)
"Enter debugger. \\<debugger-mode-map>`\\[debugger-continue]' returns from
the debugger.
diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el
index d0b4329596c..5f7e9fbfe37 100644
--- a/lisp/emacs-lisp/derived.el
+++ b/lisp/emacs-lisp/derived.el
@@ -171,7 +171,7 @@ the hook will be named `foo-mode-hook'.
See Info node `(elisp)Derived Modes' for more details.
\(fn CHILD PARENT NAME [DOCSTRING] [KEYWORD-ARGS...] &rest BODY)"
- (declare (defining-symbol 1)
+ (declare (defining-symbol child docstring)
(debug (&define name symbolp sexp [&optional stringp]
[&rest keywordp sexp] def-body))
(doc-string 4)
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el
index 41eff43a67c..5c4354616dc 100644
--- a/lisp/emacs-lisp/easy-mmode.el
+++ b/lisp/emacs-lisp/easy-mmode.el
@@ -217,7 +217,7 @@ INIT-VALUE LIGHTER KEYMAP.
\(fn MODE DOC [KEYWORD VAL ... &rest BODY])"
(declare (doc-string 2)
(indent defun)
- (defining-symbol 1)
+ (defining-symbol mode doc)
(debug (&define name string-or-null-p
[&optional [¬ keywordp] sexp
&optional [¬ keywordp] sexp
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index aa68978f6d6..0a1076e5bc6 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -549,7 +549,12 @@ already is one.)"
(defun edebug-install-read-eval-functions ()
(interactive)
- (add-function :around load-read-function #'edebug--read)
+ ;; `load-read-function' might be dynamically bound by `load'. We
+ ;; need to advise its default binding, not the current let binding
+ ;; in `load'.
+ (let ((load-read-function (default-toplevel-value 'load-read-function)))
+ (add-function :around (var load-read-function) #'edebug--read)
+ (set-default-toplevel-value 'load-read-function load-read-function))
(advice-add 'eval-defun :around #'edebug--eval-defun))
(defun edebug-uninstall-read-eval-functions ()
@@ -1149,35 +1154,35 @@ purpose by adding an entry to this alist, and setting
;; entering Edebug during the actual function's definition:
;; we only want to enter Edebug later when the thing is called.
(defining-form-p
- (if (or edebug-all-defs edebug-all-forms)
- ;; If it is a defining form and we are edebugging defs,
- ;; then let edebug-list-form start it.
- (let ((cursor (edebug-new-cursor
- (list (edebug-read-storing-offsets
(current-buffer)))
- (list edebug-offsets))))
- (car
- (edebug-make-form-wrapper
- cursor
- (edebug-before-offset cursor)
- (1- (edebug-after-offset cursor))
- (list (cons (symbol-name def-kind) (cdr spec))))))
-
- ;; Not edebugging this form, so reset the symbol's edebug
- ;; property to be just a marker at the definition's source
code.
- ;; This only works for defs with simple names.
-
- ;; Preserve the `edebug' property in case there's
- ;; debugging still under way.
- (let ((ghost (get def-name 'edebug)))
- (if (consp ghost)
- (put def-name 'ghost-edebug ghost)))
- (put def-name 'edebug (point-marker))
- ;; Also nil out dependent defs.
- '(mapcar (function
- (lambda (def)
- (put def-name 'edebug nil)))
- (get def-name 'edebug-dependents))
- (edebug-read-sexp)))
+ (if (or edebug-all-defs edebug-all-forms)
+ ;; If it is a defining form and we are edebugging defs,
+ ;; then let edebug-list-form start it.
+ (let ((cursor (edebug-new-cursor
+ (list (edebug-read-storing-offsets
(current-buffer)))
+ (list edebug-offsets))))
+ (car
+ (edebug-make-form-wrapper
+ cursor
+ (edebug-before-offset cursor)
+ (1- (edebug-after-offset cursor))
+ (list (cons (symbol-name def-kind) (cdr spec))))))
+
+ ;; Not edebugging this form, so reset the symbol's edebug
+ ;; property to be just a marker at the definition's source code.
+ ;; This only works for defs with simple names.
+
+ ;; Preserve the `edebug' property in case there's
+ ;; debugging still under way.
+ (let ((ghost (get def-name 'edebug)))
+ (if (consp ghost)
+ (put def-name 'ghost-edebug ghost)))
+ (put def-name 'edebug (point-marker))
+ ;; Also nil out dependent defs.
+ '(mapcar (function
+ (lambda (def)
+ (put def-name 'edebug nil)))
+ (get def-name 'edebug-dependents))
+ (edebug-read-sexp)))
;; If all forms are being edebugged, explicitly wrap it.
(edebug-all-forms
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 59b4504c6ef..f101c5c1fa6 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -71,12 +71,12 @@
:prefix "ert-"
:group 'lisp)
-(defcustom ert-batch-backtrace-right-margin 70
+(defcustom ert-batch-backtrace-right-margin nil ;; 70
"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
"`print-length' setting used in `ert-run-tests-batch'.
When formatting lists in test conditions, `print-length' will be
@@ -84,7 +84,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
"`print-level' setting used in `ert-run-tests-batch'.
When formatting lists in test conditions, `print-level' will be
@@ -213,7 +213,7 @@ in batch mode, an error is signaled.
\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \
[:tags \\='(TAG...)] BODY...)"
- (declare (defining-symbol 1)
+ (declare (defining-symbol name (car (cdr docstring-keys-and-body)))
(debug (&define [&name "test@" symbolp]
sexp [&optional stringp]
[&rest keywordp sexp] def-body))
diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el
index eb00f1adc86..82cc954e887 100644
--- a/lisp/emacs-lisp/generator.el
+++ b/lisp/emacs-lisp/generator.el
@@ -674,7 +674,7 @@ When called as a function, NAME returns an iterator value
that
encapsulates the state of a computation that produces a sequence
of values. Callers can retrieve each value using `iter-next'."
(declare (indent defun)
- (defining-symbol 1)
+ (defining-symbol name)
(debug (&define name lambda-list lambda-doc &rest sexp))
(doc-string 3))
(cl-assert lexical-binding)
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index 72ec3033fc7..97060f0474e 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -251,7 +251,7 @@ which can do arbitrary things, whereas the other arguments
are all guaranteed
to be pure and copyable. Example use:
(gv-define-setter aref (v a i) \\=`(aset ,a ,i ,v))"
(declare (indent 2)
- (defining-symbol 1)
+ (defining-symbol name)
(debug (&define [&name symbolp "@gv-setter"] sexp def-body)))
`(gv-define-expander ,name
(lambda (do &rest args)
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index b4fd7bdc658..63800891efd 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -114,12 +114,14 @@ Unless `macroexp-inhibit-compiler-macros' is non-nil, in
which
case return FORM unchanged."
(if macroexp-inhibit-compiler-macros
form
- (condition-case-unless-debug err
+ ;; (condition-case-unless-debug err
(apply handler form (cdr form))
- (error
- (message "Warning: Optimization failure for %S: Handler: %S\n%S"
- (car form) handler err)
- form))))
+ ;; (error
+ ;; (message "Warning: Optimization failure for %S: Handler: %S\n%S"
+ ;; (car form) handler err)
+ ;; form)
+ ;; )
+ ))
(defun macroexp--funcall-if-compiled (_form)
"Pseudo function used internally by macroexp to delay warnings.
@@ -209,58 +211,46 @@ It should normally be a symbol with position and it
defaults to FORM."
(defun macroexpand-1 (form &optional environment)
"Perform (at most) one step of macroexpansion."
- (cond
- ((consp form)
- (let* ((head (car form))
- (env-expander (assq head environment)))
- ;; Special handling for `lambda', preserving any symbol position
- ;; in it, and amending/creating its doc string for position
- ;; information.
- (if (eq head 'lambda)
- (let* ((ds (and (stringp (nth 2 form))
- ;; (nthcdr 3 form)
- ; Ensure we don't have
- ; (lambda () "str").
- (nth 2 form)))
- (new-ds (byte-run-posify-doc-string ds head))
- new-link)
- (setq form
- (cond
- ;; Overwrite the existing doc string with the new one
- (;;ds ;; (setcar (nthcdr 2 form) new-ds)
- (and (stringp (nth 2 form))
- (nthcdr 3 form))
- (nconc (list (car form) (cadr form) new-ds)
- (nthcdr 3 form))
- )
- ((and (consp (nth 2 form))
- (eq (car (nth 2 form)) ':documentation))
- form
- ;; How should we deal with a dynamic doc string?
- )
- ;; Insert the new doc string into the structure.
- (t (setq new-link (cons new-ds (nthcdr 2 form)))
- ;; (setcdr (cdr form) new-link)
- (nconc (list (car form) (cadr form)) new-link)
- )))
- (list 'function form))
- (if env-expander
- (if (cdr env-expander)
- (apply (cdr env-expander) (cdr form))
+ (let ((symbols-with-pos-enabled t))
+ (if (consp form)
+ (let* ((head (car form))
+ (env-expander (assq head environment))
+ (cur-evalled-macro-form form))
+ (cond
+ ;; Deal with `(defalias 'foo ...)' in the source code.
+ ;; Make sure `foo' gets regarded as the function name.
+ ((and (null defining-symbol)
+ (symbol-with-pos-p head)
+ (eq (bare-symbol head) 'defalias)
+ (consp (car-safe (cdr form)))
+ (consp (cdr (cadr form)))
+ (symbolp (cadr (cadr form))))
+ (setq defining-symbol (cadr (cadr form)))
form)
- (if (not (and (symbolp head) (fboundp head)))
- form
- (let ((def (autoload-do-load (symbol-function head) head 'macro)))
- (cond
- ;; Follow alias, but only for macros, otherwise we may end up
- ;; skipping an important compiler-macro (e.g. cl--block-wrapper).
- ((and (symbolp def) (macrop def)) (cons def (cdr form)))
- ((not (consp def)) form)
- (t
- (if (eq 'macro (car def))
- (apply (cdr def) (cdr form))
- form)))))))))
- (t form)))
+ ;; Special handling for `lambda', wrapping it in (function
+ ;; ...), and preserving any symbol position in it.
+ ((and (or (symbolp head) (symbol-with-pos-p head))
+ (eq (bare-symbol head) 'lambda))
+ (setq form (list 'function form)))
+ (env-expander
+ (if (cdr env-expander)
+ (apply (cdr env-expander) (cdr form))
+ form))
+ ((and (symbolp head)
+ (fboundp head))
+ (let ((def
+ (autoload-do-load (symbol-function head) head 'macro)))
+ (cond
+ ;; Follow alias, but only for macros, otherwise we may end up
+ ;; skipping an important compiler-macro (e.g.
cl--block-wrapper).
+ ((and (symbolp def) (macrop def))
+ (cons def (cdr form)))
+ ((not (consp def)) form)
+ ((eq 'macro (car def))
+ (apply (cdr def) (cdr form)))
+ (t form))))
+ (t form)))
+ form)))
(defun macroexp-macroexpand (form env)
"Like `macroexpand' but checking obsolescence."
@@ -385,7 +375,7 @@ Assumes the caller has bound `macroexpand-all-environment'."
(t t))
;; This is unquestionably a default clause.
(setq default-tail (cdr rest))
- (setq clauses (take (1+ n) clauses)) ; trim the tail
+ (setq clauses (take (1+ n) clauses)) ; trim the tail
(setq rest nil)))
(setq n (1+ n))
(setq rest (cdr rest)))
@@ -414,13 +404,21 @@ 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))
- (macroexp--cons fn
- (macroexp--cons (macroexp--all-forms f 2)
- nil
- (cdr form))
- form)))
+ (`(function ,(and f `(lambda ,_ . ,_)))
+ (progn
+ (let ((macroexp--dynvars macroexp--dynvars))
+ (setq f (macroexp--all-forms f 2))
+ (setq f (byte-run-posify-lambda-form
+ f (and (symbol-with-pos-p (car f))
+ (symbol-with-pos-pos (car f)))))
+ (if (null byte-compile-in-progress)
+ ;; Strip any position from lambda. This can be
+ ;; needed for source in loaddefs.el.
+ (setq f (cons 'lambda (cdr f))))
+ (macroexp--cons fn
+ (macroexp--cons f nil (cdr form))
+ form))))
+
(`(,(or 'function 'quote) . ,_) form)
(`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body)
pcase--dontcare))
@@ -467,7 +465,10 @@ Assumes the caller has bound
`macroexpand-all-environment'."
nil 'compile-only fn)
(let ((assignments nil))
(while (consp (cdr-safe args))
- (let* ((var (car args))
+ (let* ((var (if (and (not byte-compile-in-progress)
+ (symbol-with-pos-p (car args)))
+ (bare-symbol (car args))
+ (car args)))
(expr (cadr args))
(new-expr (macroexp--expand-all expr))
(assignment
@@ -539,6 +540,9 @@ Assumes the caller has bound `macroexpand-all-environment'."
newform
(macroexp--expand-all form)))
(macroexp--expand-all newform))))))
+ ((guard (and (not byte-compile-in-progress)
+ (symbol-with-pos-p form)))
+ (bare-symbol form))
(_ form))))
(pop byte-compile-form-stack)))
@@ -548,7 +552,8 @@ Assumes the caller has bound `macroexpand-all-environment'."
If no macros are expanded, FORM is returned unchanged.
The second optional arg ENVIRONMENT specifies an environment of macro
definitions to shadow the loaded ones for use in file byte-compilation."
- (let ((macroexpand-all-environment environment)
+ (let ((symbols-with-pos-enabled t)
+ (macroexpand-all-environment environment)
(macroexp--dynvars macroexp--dynvars))
(macroexp--expand-all form)))
@@ -556,7 +561,8 @@ definitions to shadow the loaded ones for use in file
byte-compilation."
;; forms. It does not dynbind `macroexp--dynvars' because we want
;; top-level `defvar' declarations to be recorded in that variable.
(defun macroexpand--all-toplevel (form &optional environment)
- (let ((macroexpand-all-environment environment))
+ (let ((macroexpand-all-environment environment)
+ (symbols-with-pos-enabled t))
(macroexp--expand-all form)))
;;; Handy functions to use in macros.
@@ -851,18 +857,20 @@ test of free variables in the following ways:
(push 'skip macroexp--pending-eager-loads)
form))
(t
- (condition-case err
- (let ((macroexp--pending-eager-loads
- (cons load-file-name macroexp--pending-eager-loads)))
- (if full-p
- (macroexpand--all-toplevel form)
- (macroexpand form)))
- ((debug error)
- ;; Hopefully this shouldn't happen thanks to the cycle detection,
- ;; but in case it does happen, let's catch the error and give the
- ;; code a chance to macro-expand later.
- (error "Eager macro-expansion failure: %S" err)
- form)))))
+ ;; (condition-case err
+ (let ((macroexp--pending-eager-loads
+ (cons load-file-name macroexp--pending-eager-loads)))
+ (if full-p
+ (macroexpand--all-toplevel form)
+ (macroexpand form)))
+ ;; ((debug error)
+ ;; ;; Hopefully this shouldn't happen thanks to the cycle detection,
+ ;; ;; but in case it does happen, let's catch the error and give the
+ ;; ;; code a chance to macro-expand later.
+ ;; (error "Eager macro-expansion failure: %S" err)
+ ;; form)
+ ;; )
+ )))
;; ¡¡¡ Big Ugly Hack !!!
;; src/bootstrap-emacs is mostly used to compile .el files, so it needs
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index d5f7249e527..a089b9c11a6 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -1086,6 +1086,7 @@ The predicate is the logical-AND of:
`(and (pred consp)
(app car-safe ,(list '\` (car qpat)))
(app cdr-safe ,(list '\` (cdr qpat)))))
+ ((symbol-with-pos-p qpat) `',(bare-symbol qpat))
((or (stringp qpat) (numberp qpat) (symbolp qpat)) `',qpat)
;; In all other cases just raise an error so we can't break
;; backward compatibility when adding \` support for other
diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el
index 7ff55de0d0c..56e34f06966 100644
--- a/lisp/erc/erc-backend.el
+++ b/lisp/erc/erc-backend.el
@@ -1630,7 +1630,12 @@ Would expand to:
See also `erc-server-311'.\"))
\(fn (NAME &rest ALIASES) &optional EXTRA-FN-DOC EXTRA-VAR-DOC &rest FN-BODY)"
- (declare (debug (&define [&name "erc-response-handler@"
+ (declare
+;;;; NEW STOUGH, 2023-12-24
+ ;; (defining-symbol name) ; Not too sure about this. (ACM,
+ ;; 2023-12-24) Commented out, 2024-01-20, because it didn't work.
+;;;; END OF NEW STOUGH
+ (debug (&define [&name "erc-response-handler@"
;; No `def-edebug-elem-spec' in 27.
([&or integerp symbolp]
&rest [&or integerp symbolp])]
diff --git a/lisp/gnus/nnoo.el b/lisp/gnus/nnoo.el
index c24cfb94b19..81ac2b65ff3 100644
--- a/lisp/gnus/nnoo.el
+++ b/lisp/gnus/nnoo.el
@@ -46,7 +46,7 @@
"The same as `defun', only register FUNC."
(declare (indent 2)
(doc-string 3)
- (defining-symbol 1)
+ (defining-symbol func)
(debug (&define name lambda-list def-body)))
`(prog1
(defun ,func ,args ,@forms)
diff --git a/lisp/help.el b/lisp/help.el
index 5667b511b6e..889ecac94f3 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -1323,7 +1323,7 @@ no characters other than the POS info, return nil
instead."
(when string
(let (start index)
(while
- (and (setq index (string-match ";POS.\000\000\000 " string start))
+ (and (setq index (string-match ";POS.\001\001\001 " string start))
(string-match "\n" string index))
(setq start (match-end 0)))
(cond
@@ -2322,7 +2322,7 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1
ARG2 ...)\"."
(concat docstring
(cond
((progn (string-match
- "\\(?:;POS.\000\000\000 \\[[^]]+]\n\\)?\\(\n*\\)\\'"
+ "\\(?:;POS.\001\001\001 \\[[^]]+]\n\\)?\\(\n*\\)\\'"
docstring)
(zerop (- (match-end 1) (match-beginning 1))))
"\n\n")
diff --git a/lisp/international/mule.el b/lisp/international/mule.el
index 2b44a2e0645..b934485deeb 100644
--- a/lisp/international/mule.el
+++ b/lisp/international/mule.el
@@ -318,7 +318,7 @@ Return t if file exists."
(and (null noerror)
(signal 'file-error (list "Cannot open load file" file)))
;; Read file with code conversion, and then eval.
- (let ((buffer (generate-new-buffer " *load*"))
+ (let ((buffer (generate-new-buffer (file-name-nondirectory file)))
(load-in-progress t)
(source (string-suffix-p ".el" fullname)))
(unless nomessage
@@ -334,6 +334,7 @@ Return t if file exists."
(inhibit-file-name-operation nil)
shorthands)
(with-current-buffer buffer
+ (setq buffer-undo-list t)
;; So that we don't get completely screwed if the
;; file is encoded in some complicated character set,
;; read it with real decoding, as a multibyte buffer.
diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el
index 849a8d8eaee..7caa8a6612c 100644
--- a/lisp/jsonrpc.el
+++ b/lisp/jsonrpc.el
@@ -77,6 +77,7 @@
:documentation "A buffer pretty-printing the JSONRPC events")
(-events-buffer-scrollback-size
:initarg :events-buffer-scrollback-size
+ :initform nil
:accessor jsonrpc--events-buffer-scrollback-size
:documentation "Max size of events buffer. 0 disables, nil means
infinite.")
(-deferred-actions
diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el
index f062f3bf8de..83ef1f844b0 100644
--- a/lisp/ldefs-boot.el
+++ b/lisp/ldefs-boot.el
@@ -6629,7 +6629,9 @@ There is some minimal font-lock support (see vars
;;; Generated autoloads from emacs-lisp/debug.el
-(setq debugger 'debug)
+(if (null noninteractive)
+ (setq debugger 'debug))
+
(autoload 'debug "debug" "\
Enter debugger. \\<debugger-mode-map>`\\[debugger-continue]' returns from the
debugger.
Arguments are mainly for use when this is called from the internals
diff --git a/lisp/loadup.el b/lisp/loadup.el
index 07895228d0d..4d3fafb8140 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -51,6 +51,7 @@
;; successfully loading charprop.el, which defines the Unicode tables
;; bidi.c needs for its job.
(setq redisplay--inhibit-bidi t)
+(setq text-quoting-style 'grave)
(message "Dump mode: %s" dump-mode)
@@ -123,8 +124,16 @@
(set-buffer "*scratch*")
(setq buffer-undo-list t)
+(defvar real-defvar (symbol-function 'defvar))
+(setq symbols-with-pos-enabled t)
+(fset 'defvar (symbol-function 'defvar-bootstrap))
(load "emacs-lisp/debug-early")
(load "emacs-lisp/byte-run")
+(byte-run-posify-existing-defaliases)
+(byte-run-posify-existing-lambdas)
+;; (makunbound 'early-lambda-lists)
+(setq early-lambda-lists nil) ; We don't want its symbols with
+ ; position in the dumped image.
(load "emacs-lisp/backquote")
(load "subr")
(load "keymap")
@@ -163,6 +172,75 @@
;; Re-load macroexp so as to eagerly macro-expand its uses of pcase.
(let ((max-lisp-eval-depth (* 2 max-lisp-eval-depth)))
(load "emacs-lisp/macroexp")))
+(setq base-loaded t)
+
+(load "emacs-lisp/debug-early")
+(load "emacs-lisp/byte-run")
+(message "loadup.el, just after second load of byte-run.el.")
+(message "loadup.el. base-loaded %S bound."
+ (if (boundp 'base-loaded) "is" "isn't"))
+(message "loadup.el. base-loaded %S a SWP. symbols-with-pos-enabled is %S"
+ (symbol-with-pos-p 'base-loaded) symbols-with-pos-enabled)
+(message "loadup.el, just after setting base-loaded to t")
+(unintern 'base-loaded nil) ; So that it can't be messed with from Lisp.
+(load "emacs-lisp/backquote")
+;; Second loading of these files to clear out symbols with positions from
+;; lambda symbols. This absolutely requires macroexp.el.
+;; In the second loading, we make `internal-macroexpand-for-load' unbound so
+;; as to inhibit eager macro expansion in early loaded files that aren't ready
+;; for it.
+(load "subr")
+(load "keymap")
+
+;; Do it after subr, since both after-load-functions and add-hook are
+;; implemented in subr.el.
+(add-hook 'after-load-functions (lambda (_) (garbage-collect)))
+
+(load "version")
+
+(load "widget")
+(load "custom")
+(load "emacs-lisp/map-ynp")
+(load "international/mule")
+(load "international/mule-conf")
+(load "env")
+(load "format")
+(load "bindings")
+(load "window") ; Needed here for `replace-buffer-in-windows'.
+;; We are now capable of resizing the mini-windows, so give the
+;; variable its advertised default value (it starts as nil, see
+;; xdisp.c).
+(setq resize-mini-windows 'grow-only)
+(setq load-source-file-function #'load-with-code-conversion)
+(load "files")
+
+;; Load-time macro-expansion can only take effect after setting
+;; load-source-file-function because of where it is called in lread.c.
+(load "emacs-lisp/macroexp")
+(if (compiled-function-p (symbol-function 'macroexpand-all))
+ nil
+ ;; Since loaddefs is not yet loaded, macroexp's uses of pcase will simply
+ ;; fail until pcase is explicitly loaded. This also means that we have to
+ ;; disable eager macro-expansion while loading pcase.
+ (let ((macroexp--pending-eager-loads '(skip))) (load "emacs-lisp/pcase"))
+ ;; Re-load macroexp so as to eagerly macro-expand its uses of pcase.
+ (let ((max-lisp-eval-depth (* 2 max-lisp-eval-depth)))
+ (load "emacs-lisp/macroexp")))
+;; Clear out all the function-history from the functions we've loaded
+;; twice, since otherwise the stored old versions would contain
+;; symbols with properties which would thwart the portable dumper.
+(mapatoms (lambda (elt)
+ (let* ((plist (symbol-plist elt))
+ (tail (memq 'function-history plist)))
+ (if tail
+ (progn
+ (setq plist (delq (car (cdr tail)) plist))
+ (setq plist (delq 'function-history plist))
+ (setplist elt plist))))))
+(fset 'defvar real-defvar)
+(message "Just after (fset defvar real-defvar)")
+(setq symbols-with-pos-enabled nil)
+(message "Just after setting symbols-with-pos-enabled back to nil")
(load "cus-face")
(load "faces") ; after here, `defface' may be used.
@@ -604,6 +682,20 @@ directory got moved. This is set to be a pair in the form
of:
;; Continue with loadup.
nil)
(error nil))))))
+;;;; TEMP STOUGH, 2024-01-06
+ (message "\nRemaining buffers: %S\n" (buffer-list))
+ (message "\nScanning obarray for SWPs")
+ (message "byte-compile-in-progress: %S" byte-compile-in-progress)
+ (mapatoms (lambda (elt)
+ (if (symbol-with-pos-p elt)
+ (message "%S is a symbol with position" elt))
+ (if (boundp elt)
+ (byte-run-report-symbol-positions elt (symbol-value elt)))
+ (if (fboundp elt)
+ (byte-run-report-symbol-positions elt (symbol-function
elt)))
+ (if (symbol-plist elt)
+ (byte-run-report-symbol-positions elt (symbol-plist elt)))))
+;;;; END OF TEMP STOUGH
(if dump-mode
(let ((output (cond ((equal dump-mode "pdump") "emacs.pdmp")
((equal dump-mode "dump") "emacs")
diff --git a/lisp/mh-e/mh-acros.el b/lisp/mh-e/mh-acros.el
index 1b4b42ebde6..a8730b4bc42 100644
--- a/lisp/mh-e/mh-acros.el
+++ b/lisp/mh-e/mh-acros.el
@@ -75,7 +75,7 @@ If FUNCTION exists, then NAME becomes an alias for FUNCTION.
Otherwise, create function NAME with ARG-LIST and BODY."
(declare (obsolete defun "29.1")
(indent defun) (doc-string 4)
- (defining-symbol 1)
+ (defining-symbol name)
(debug (&define name symbolp sexp def-body)))
`(defalias ',name
(if (fboundp ',function)
@@ -89,7 +89,7 @@ If MACRO exists, then NAME becomes an alias for MACRO.
Otherwise, create macro NAME with ARG-LIST and BODY."
(declare (obsolete defmacro "29.1")
(indent defun) (doc-string 4)
- (defining-symbol 1)
+ (defining-symbol name)
(debug (&define name symbolp sexp def-body)))
(let ((defined-p (fboundp macro)))
(if defined-p
diff --git a/lisp/obsolete/cl.el b/lisp/obsolete/cl.el
index ff1dc70d0c0..2d4de825910 100644
--- a/lisp/obsolete/cl.el
+++ b/lisp/obsolete/cl.el
@@ -512,7 +512,7 @@ a temporary-variables list, a value-forms list, a
store-variables list
See `gv-define-expander', and `gv-define-setter' for better and
simpler ways to define setf-methods."
- (declare (defining-symbol 1)
+ (declare (defining-symbol name)
(debug
(&define name cl-lambda-list cl-declarations-or-string def-body))
(indent defun))
@@ -552,8 +552,7 @@ For example:
You can replace this form with `gv-define-setter'.
\(fn NAME [FUNC | ARGLIST (STORE) BODY...])"
- (declare (defining-symbol 1)
- (debug
+ (declare (debug
(&define name
[&or [symbolp &optional stringp]
[cl-lambda-list (symbolp)]]
@@ -617,8 +616,7 @@ arguments from ARGLIST using FUNC. For example:
(define-modify-macro incf (&optional (n 1)) +)
You can replace this macro with `gv-letplace'."
- (declare (defining-symbol 1)
- (debug
+ (declare (debug
(&define name cl-lambda-list ;; should exclude &key
symbolp &optional stringp))
(indent defun))
diff --git a/lisp/obsolete/eieio-compat.el b/lisp/obsolete/eieio-compat.el
index 959c715cb02..bb3d5ccb49c 100644
--- a/lisp/obsolete/eieio-compat.el
+++ b/lisp/obsolete/eieio-compat.el
@@ -106,7 +106,6 @@ Summary:
body)"
(declare (doc-string 3) (obsolete cl-defmethod "25.1")
(indent defun)
- (defining-symbol 1)
(debug
(&define ; this means we are defining something
[&name sexp] ;Allow (setf ...) additionally to symbols.
diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el
index b6d664be571..6c1816f2879 100644
--- a/lisp/progmodes/cc-defs.el
+++ b/lisp/progmodes/cc-defs.el
@@ -2508,7 +2508,7 @@ already is one it will be completely replaced; the value
in the
earlier definition will not affect `c-lang-const' on the same
constant. A file is identified by its base name."
(declare (indent 1)
- (defining-symbol 1)
+ (defining-symbol name)
(debug (&define name [&optional stringp] [&rest sexp def-form])))
(let* ((sym (intern (symbol-name name) c-lang-constants))
;; Make `c-lang-const' expand to a straightforward call to
diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el
index 15b08888b9d..4b5fa1756d3 100644
--- a/lisp/progmodes/cc-langs.el
+++ b/lisp/progmodes/cc-langs.el
@@ -160,7 +160,7 @@ the macro `c-init-language-vars' is evaluated.
language being initialized, and such calls will be macro expanded to
the evaluated constant value at compile time."
(declare (indent defun)
- (defining-symbol 1)
+ (defining-symbol var doc)
(debug (&define name def-form
&optional &or ("quote" symbolp) stringp)))
(when (and (not doc)
@@ -194,8 +194,7 @@ Emacs variable like `comment-start'.
`c-lang-const' is typically used in VAL to get the right value for the
language being initialized, and such calls will be macro expanded to
the evaluated constant value at compile time."
- (declare (defining-symbol 1)
- (debug (&define name def-form)))
+ (declare (debug (&define name def-form)))
(let ((elem (assq var (cdr c-emacs-variable-inits))))
(if elem
(setcdr elem (list val)) ; Maybe remove "list", sometime. 2006-07-19
diff --git a/lisp/skeleton.el b/lisp/skeleton.el
index c9e77f1cbe9..dbb8fd0a763 100644
--- a/lisp/skeleton.el
+++ b/lisp/skeleton.el
@@ -115,7 +115,7 @@ are integer buffer positions in the reverse order of the
insertion order.")
"Define a user-configurable COMMAND that enters a statement skeleton.
DOCUMENTATION is that of the command.
SKELETON is as defined under `skeleton-insert'."
- (declare (doc-string 2) (defining-symbol 1)
+ (declare (doc-string 2) (defining-symbol command documentation)
(debug (&define name stringp skeleton-edebug-spec))
(indent defun))
(if skeleton-debug
diff --git a/lisp/subr.el b/lisp/subr.el
index 7f2dcdc4d90..eb7383207bb 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -3731,7 +3731,7 @@ There is no need to explicitly add `help-char' to CHARS;
;; We have a string (with one character), so return the first
one.
(elt result 0)
;; The default value is RET.
- (when history (push "\r" (symbol-value history)))
+ (when history (set history (cons "\r" (symbol-value history))))
?\r)))
;; Display the question with the answer.
(message "%s%s" prompt (char-to-string char))
@@ -6516,9 +6516,9 @@ To test whether a function can be called interactively,
use
(unless (memq keymap map)
(unless (memq 'add-keymap-witness (symbol-value symbol))
(setq map (make-composed-keymap nil (symbol-value symbol)))
- (push 'add-keymap-witness (cdr map))
+ (setcdr map (cons 'add-keymap-witness (cdr map)))
(set symbol map))
- (push keymap (cdr map)))))
+ (setcdr map (cons keymap (cdr map))))))
(defun internal-pop-keymap (keymap symbol)
(let ((map (symbol-value symbol)))
diff --git a/lisp/transient.el b/lisp/transient.el
index da1a4b11f5c..455e18bbf26 100644
--- a/lisp/transient.el
+++ b/lisp/transient.el
@@ -856,7 +856,7 @@ to the setup function:
(transient-setup \\='NAME nil nil :scope SCOPE)
\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]... GROUP... [BODY...])"
- (declare (defining-symbol 1)
+ (declare (defining-symbol name)
(debug ( &define name lambda-list
[&optional lambda-doc]
[&rest keywordp sexp]
@@ -898,7 +898,7 @@ ARGLIST. The infix arguments are usually accessed by using
`transient-args' inside `interactive'.
\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]... BODY...)"
- (declare (defining-symbol 1)
+ (declare (defining-symbol name)
(debug ( &define name lambda-list
[&optional lambda-doc]
[&rest keywordp sexp]
@@ -950,7 +950,7 @@ the infix command and use t as the value of the `:transient'
keyword.
\(fn NAME ARGLIST [DOCSTRING] [KEYWORD VALUE]...)"
- (declare (defining-symbol 1)
+ (declare (defining-symbol name)
(debug ( &define name lambda-list
[&optional lambda-doc]
[&rest keywordp sexp]))
diff --git a/lisp/vc/pcvs.el b/lisp/vc/pcvs.el
index 5bb2647da13..03426d47c5f 100644
--- a/lisp/vc/pcvs.el
+++ b/lisp/vc/pcvs.el
@@ -897,7 +897,8 @@ clear what alternative to use.
- `NOARGS' will get all the arguments from the *cvs* buffer and will
always behave as if called interactively.
- `DOUBLE' is the generic case."
- (declare (defining-symbol (if (symbolp fun) fun (car fun)))
+ (declare (defining-symbol (if (symbolp fun) fun (car fun))
+ docstring)
(debug (&define sexp lambda-list stringp
("interactive" interactive) def-body))
(indent defun)
diff --git a/lisp/window.el b/lisp/window.el
index fbdcd611068..4a11d5f13b7 100644
--- a/lisp/window.el
+++ b/lisp/window.el
@@ -8061,13 +8061,13 @@ indirectly called by the latter."
(when (and mode?
(not (and inhibit-same-window-p
(eq window curwin))))
- (push window (if (eq curframe (window-frame window))
+ (if (eq curframe (window-frame window))
(if (eq mode? 'same)
- same-mode-same-frame
- derived-mode-same-frame)
+ (push window same-mode-same-frame)
+ (push window derived-mode-same-frame))
(if (eq mode? 'same)
- same-mode-other-frame
- derived-mode-other-frame))))))
+ (push window same-mode-other-frame)
+ (push window derived-mode-other-frame))))))
(let ((window (car (nconc same-mode-same-frame
same-mode-other-frame
derived-mode-same-frame
@@ -9185,7 +9185,8 @@ to deactivate this overriding action."
(when echofun
(add-hook 'prefix-command-echo-keystrokes-functions echofun))
(setq switch-to-buffer-obey-display-actions t)
- (push action (car display-buffer-overriding-action))
+ (setcar display-buffer-overriding-action
+ (cons action display-buffer-overriding-action))
exitfun))
@@ -10738,7 +10739,7 @@ displaying that processes's buffer."
;; Add this window to the list of windows
;; displaying process.
(if procwin
- (push window (cdr procwin))
+ (setcdr procwin (cons window (cdr procwin)))
(push (list process window) process-windows))
;; We found our process for this window, so
;; stop iterating over the process list.
diff --git a/src/alloc.c b/src/alloc.c
index cda8ba1ad46..5b106bf2690 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3734,6 +3734,9 @@ each initialized to INIT. */)
CHECK_FIXNAT (slots);
EMACS_INT size = XFIXNAT (slots) + 1;
struct Lisp_Vector *p = allocate_record (size);
+ if (symbols_with_pos_enabled
+ && !NILP (Fsymbol_with_pos_p (type)))
+ type = Fbare_symbol (type);
p->contents[0] = type;
for (ptrdiff_t i = 1; i < size; i++)
p->contents[i] = init;
diff --git a/src/data.c b/src/data.c
index afb0b14c576..b2b58fe9594 100644
--- a/src/data.c
+++ b/src/data.c
@@ -970,6 +970,11 @@ The return value is undefined. */)
maybe_defer_native_compilation (symbol, definition);
+ /* For the first few symbols from early-debug.el and byte-run.el, note the
+ symbol for later creation of position information in the doc string. */
+ if (NILP (Ffboundp (Qdefun)))
+ Fput (symbol, Qbyte_run__early_defalias, symbol);
+
if (!NILP (docstring))
Fput (symbol, Qfunction_documentation, docstring);
/* We used to return `definition', but now that `defun' and `defmacro' expand
@@ -4240,6 +4245,7 @@ syms_of_data (void)
DEFSYM (Qtreesit_compiled_query, "treesit-compiled-query");
DEFSYM (Qdefun, "defun");
+ DEFSYM (Qbyte_run__early_defalias, "byte-run--early-defalias");
DEFSYM (Qinteractive_form, "interactive-form");
DEFSYM (Qdefalias_fset_function, "defalias-fset-function");
diff --git a/src/doc.c b/src/doc.c
index 134d7414906..a731e856f0d 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -413,7 +413,8 @@ string is passed through `substitute-command-keys'. */)
doc = call1 (Qsubstitute_command_keys, doc);
}
else
- doc = call1 (Qhelp_strip_pos_info, doc);
+ if (!(EQ (raw, Qalso_pos)))
+ doc = call1 (Qhelp_strip_pos_info, doc);
return doc;
}
@@ -748,7 +749,7 @@ syms_of_doc (void)
DEFSYM (Qgrave, "grave");
DEFSYM (Qstraight, "straight");
DEFSYM (Qcurve, "curve");
-
+ DEFSYM (Qalso_pos, "also-pos");
DEFVAR_LISP ("internal-doc-file-name", Vdoc_file_name,
doc: /* Name of file containing documentation strings of
built-in symbols. */);
Vdoc_file_name = Qnil;
diff --git a/src/editfns.c b/src/editfns.c
index 49d552c4a75..686dd73e529 100644
--- a/src/editfns.c
+++ b/src/editfns.c
@@ -3623,7 +3623,8 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool
message)
format = num_end;
if (format == end)
- error ("Format string ends in middle of format specifier");
+ signal_error ("Format string ends in middle of format specifier",
+ args[0]);
char conversion = *format++;
memset (&discarded[format0 - format_start], 1,
diff --git a/src/eval.c b/src/eval.c
index 29fa5fb645a..8ecfeb426bf 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -551,7 +551,7 @@ usage: (function ARG) */)
cdr = Fcons (XCAR (cdr), Fcons (docstring, XCDR (XCDR (cdr))));
}
if (NILP (Vinternal_make_interpreted_closure_function))
- return Fcons (Qclosure, Fcons (Vinternal_interpreter_environment,
cdr));
+ return Fcons (Qclosure, Fcons (Vinternal_interpreter_environment, cdr));
else
return call2 (Vinternal_make_interpreted_closure_function,
Fcons (Qlambda, cdr),
@@ -761,7 +761,8 @@ value. */)
}
static Lisp_Object
-defvar (Lisp_Object sym, Lisp_Object initvalue, Lisp_Object docstring, bool
eval)
+defvar (Lisp_Object sym, Lisp_Object initvalue, Lisp_Object docstring,
+ bool eval, bool forced_init)
{
Lisp_Object tem;
@@ -778,11 +779,15 @@ defvar (Lisp_Object sym, Lisp_Object initvalue,
Lisp_Object docstring, bool eval
{ /* Check if there is really a global binding rather than just a let
binding that shadows the global unboundness of the var. */
union specbinding *binding = default_toplevel_binding (sym);
+ Lisp_Object val;
+
+ if ((binding && BASE_EQ (specpdl_old_value (binding), Qunbound))
+ || forced_init)
+ val = eval ? eval_sub (initvalue) : initvalue;
+ if (forced_init)
+ Fset_default (sym, val);
if (binding && BASE_EQ (specpdl_old_value (binding), Qunbound))
- {
- set_specpdl_old_value (binding,
- eval ? eval_sub (initvalue) : initvalue);
- }
+ set_specpdl_old_value (binding, val);
}
return sym;
}
@@ -828,7 +833,50 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
error ("Too many arguments");
Lisp_Object exp = XCAR (tail);
tail = XCDR (tail);
- return defvar (sym, exp, CAR (tail), true);
+ return defvar (sym, exp, CAR (tail), true, false);
+ }
+ else if (!NILP (Vinternal_interpreter_environment)
+ && (SYMBOLP (sym) && !XSYMBOL (sym)->u.s.declared_special))
+ /* A simple (defvar foo) with lexical scoping does "nothing" except
+ declare that var to be dynamically scoped *locally* (i.e. within
+ the current file or let-block). */
+ Vinternal_interpreter_environment
+ = Fcons (sym, Vinternal_interpreter_environment);
+ else
+ {
+ /* Simple (defvar <var>) should not count as a definition at all.
+ It could get in the way of other definitions, and unloading this
+ package could try to make the variable unbound. */
+ }
+
+ return sym;
+}
+
+DEFUN ("defvar-bootstrap", Fdefvar_bootstrap, Sdefvar_bootstrap, 1, UNEVALLED,
0,
+ doc: /* Define SYMBOL as a variable, and return SYMBOL.
+This is like `defvar', except that if an INITVALUE is supplied, the
+variable is always initialized to it, regardless of whether or not
+it already has a value.
+
+This is only for use during bootstrapping.
+
+usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
+ (Lisp_Object args)
+{
+ Lisp_Object sym, tail;
+
+ sym = XCAR (args);
+ tail = XCDR (args);
+
+ CHECK_SYMBOL (sym);
+
+ if (!NILP (tail))
+ {
+ if (!NILP (XCDR (tail)) && !NILP (XCDR (XCDR (tail))))
+ error ("Too many arguments");
+ Lisp_Object exp = XCAR (tail);
+ tail = XCDR (tail);
+ return defvar (sym, exp, CAR (tail), true, true);
}
else if (!NILP (Vinternal_interpreter_environment)
&& (SYMBOLP (sym) && !XSYMBOL (sym)->u.s.declared_special))
@@ -852,7 +900,7 @@ DEFUN ("defvar-1", Fdefvar_1, Sdefvar_1, 2, 3, 0,
More specifically behaves like (defvar SYM 'INITVALUE DOCSTRING). */)
(Lisp_Object sym, Lisp_Object initvalue, Lisp_Object docstring)
{
- return defvar (sym, initvalue, docstring, false);
+ return defvar (sym, initvalue, docstring, false, false);
}
DEFUN ("defconst", Fdefconst, Sdefconst, 2, UNEVALLED, 0,
@@ -1115,6 +1163,10 @@ definitions to shadow the loaded ones for use in file
byte-compilation. */)
{
/* With cleanups from Hallvard Furuseth. */
register Lisp_Object expander, sym, def, tem;
+ specpdl_ref count = SPECPDL_INDEX ();
+
+ specbind (Qcur_evalled_macro_form, Qnil);
+ specbind (Qsymbols_with_pos_enabled, Qt);
while (1)
{
@@ -1168,6 +1220,7 @@ definitions to shadow the loaded ones for use in file
byte-compilation. */)
break;
}
{
+ Vcur_evalled_macro_form = form;
Lisp_Object newform = apply1 (expander, XCDR (form));
if (EQ (form, newform))
break;
@@ -1175,7 +1228,7 @@ definitions to shadow the loaded ones for use in file
byte-compilation. */)
form = newform;
}
}
- return form;
+ return unbind_to (count, form);
}
DEFUN ("catch", Fcatch, Scatch, 1, UNEVALLED, 0,
@@ -2594,6 +2647,7 @@ eval_sub (Lisp_Object form)
interpreted using lexical-binding or not. */
specbind (Qlexical_binding,
NILP (Vinternal_interpreter_environment) ? Qnil : Qt);
+ specbind (Qsymbols_with_pos_enabled, Qt);
/* Make the macro aware of any defvar declarations in scope. */
Lisp_Object dynvars = Vmacroexp__dynvars;
@@ -2607,7 +2661,11 @@ eval_sub (Lisp_Object form)
if (!EQ (dynvars, Vmacroexp__dynvars))
specbind (Qmacroexp__dynvars, dynvars);
+ specbind (Qcur_evalled_macro_form, form);
+
exp = apply1 (Fcdr (fun), original_args);
+ if (base_loaded)
+ exp = call2 (Qmacroexpand_all, exp, Qnil);
exp = unbind_to (count1, exp);
val = eval_sub (exp);
}
@@ -4274,6 +4332,7 @@ before making `inhibit-quit' nil. */);
DEFSYM (Qautoload, "autoload");
DEFSYM (Qinhibit_debugger, "inhibit-debugger");
DEFSYM (Qmacro, "macro");
+ DEFSYM (Qmacroexpand_all, "macroexpand-all");
/* Note that the process handling also uses Qexit, but we don't want
to staticpro it twice, so we just do it here. */
@@ -4410,6 +4469,11 @@ alist of active lexical bindings. */);
doc: /* Function to filter the env when constructing a closure.
*/);
Vinternal_make_interpreted_closure_function = Qnil;
+ DEFSYM (Qcur_evalled_macro_form, "cur-evalled-macro-form");
+ DEFVAR_LISP ("cur-evalled-macro-form", Vcur_evalled_macro_form,
+ doc: /* The macro form currerntly being evaluated. */);
+ Vcur_evalled_macro_form = Qnil;
+
Vrun_hooks = intern_c_string ("run-hooks");
staticpro (&Vrun_hooks);
@@ -4440,6 +4504,7 @@ alist of active lexical bindings. */);
defsubr (&Sdefault_toplevel_value);
defsubr (&Sset_default_toplevel_value);
defsubr (&Sdefvar);
+ defsubr (&Sdefvar_bootstrap);
defsubr (&Sdefvar_1);
defsubr (&Sdefvaralias);
DEFSYM (Qdefvaralias, "defvaralias");
diff --git a/src/fns.c b/src/fns.c
index 84aa86d9eb6..8729663c1f9 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -5488,6 +5488,9 @@ If KEY is not found, return DFLT which defaults to nil.
*/)
(Lisp_Object key, Lisp_Object table, Lisp_Object dflt)
{
struct Lisp_Hash_Table *h = check_hash_table (table);
+ if (symbols_with_pos_enabled
+ && Fsymbol_with_pos_p (key))
+ key = Fbare_symbol (key);
ptrdiff_t i = hash_lookup (h, key, NULL);
return i >= 0 ? HASH_VALUE (h, i) : dflt;
}
@@ -5502,6 +5505,9 @@ VALUE. In any case, return VALUE. */)
struct Lisp_Hash_Table *h = check_hash_table (table);
check_mutable_hash_table (table, h);
+ if (symbols_with_pos_enabled
+ && Fsymbol_with_pos_p (key))
+ key = Fbare_symbol (key);
Lisp_Object hash;
ptrdiff_t i = hash_lookup (h, key, &hash);
if (i >= 0)
diff --git a/src/lisp.h b/src/lisp.h
index df6cf1df544..60034ddd4cd 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3782,12 +3782,6 @@ set_symbol_function (Lisp_Object sym, Lisp_Object
function)
XSYMBOL (sym)->u.s.function = function;
}
-INLINE void
-set_symbol_plist (Lisp_Object sym, Lisp_Object plist)
-{
- XSYMBOL (sym)->u.s.plist = plist;
-}
-
INLINE void
set_symbol_next (Lisp_Object sym, struct Lisp_Symbol *next)
{
@@ -4536,6 +4530,12 @@ intern (const char *str)
return intern_1 (str, strlen (str));
}
+INLINE void
+set_symbol_plist (Lisp_Object sym, Lisp_Object plist)
+{
+ XSYMBOL (sym)->u.s.plist = plist;
+}
+
INLINE Lisp_Object
intern_c_string (const char *str)
{
diff --git a/src/lread.c b/src/lread.c
index c81318f80cf..1a3b7308021 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -119,7 +119,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
static struct android_fd_or_asset invalid_file_stream =
{
-1,
- NULL,
+ NULL
};
#define file_stream struct android_fd_or_asset
@@ -226,6 +226,12 @@ static ptrdiff_t read_from_string_limit;
/* Position in object from which characters are being read by `readchar'. */
static EMACS_INT readchar_offset;
+/* The position in the "notional buffer" of the next character to be
+ read. This simulates a buffer's point. It is pushed to and popped
+ from the Lisp stack by Fload. It is used only for readcharfun,
+ Qget_file_char, or Qget_emacs_mule_file_char. */
+static EMACS_INT char_count = 1;
+
struct saved_string {
char *string; /* string in allocated buffer */
ptrdiff_t size; /* allocated size of buffer */
@@ -255,6 +261,7 @@ static Lisp_Object oblookup_considering_shorthand
(Lisp_Object, const char *,
char **, ptrdiff_t *,
ptrdiff_t *);
+static Lisp_Object get_read_stream (Lisp_Object);
/* Functions that read one byte from the current source READCHARFUN
or unreads one byte. If the integer argument C is -1, it returns
@@ -433,6 +440,10 @@ readchar (Lisp_Object readcharfun, bool *multibyte)
{
c = unread_char;
unread_char = -1;
+ if (char_count > 0
+ && (EQ (readcharfun, Qget_file_char)
+ || EQ (readcharfun, Qget_emacs_mule_file_char)))
+ char_count++;
return c;
}
c = (*readbyte) (-1, readcharfun);
@@ -441,9 +452,23 @@ readchar (Lisp_Object readcharfun, bool *multibyte)
if (multibyte)
*multibyte = 1;
if (ASCII_CHAR_P (c))
- return c;
+ {
+ if (char_count > 0
+ && (EQ (readcharfun, Qget_file_char)
+ || EQ (readcharfun, Qget_emacs_mule_file_char)))
+ char_count++;
+ return c;
+ }
if (emacs_mule_encoding)
- return read_emacs_mule_char (c, readbyte, readcharfun);
+ {
+ if ((c = read_emacs_mule_char (c, readbyte, readcharfun))
+ != -1)
+ if (char_count > 0
+ && (EQ (readcharfun, Qget_file_char)
+ || EQ (readcharfun, Qget_emacs_mule_file_char)))
+ char_count++;
+ return c;
+ }
i = 0;
buf[i++] = c;
len = BYTES_BY_CHAR_HEAD (c);
@@ -456,6 +481,10 @@ readchar (Lisp_Object readcharfun, bool *multibyte)
(*readbyte) (buf[i], readcharfun);
return BYTE8_TO_CHAR (buf[0]);
}
+ if (char_count > 0
+ && (EQ (readcharfun, Qget_file_char)
+ || EQ (readcharfun, Qget_emacs_mule_file_char)))
+ char_count++;
}
return STRING_CHAR (buf);
}
@@ -555,6 +584,7 @@ unreadchar (Lisp_Object readcharfun, int c)
}
else if (FROM_FILE_P (readcharfun))
{
+ char_count--;
unread_char = c;
}
else
@@ -770,8 +800,8 @@ struct subst
};
static Lisp_Object read_internal_start (Lisp_Object, Lisp_Object,
- Lisp_Object, bool);
-static Lisp_Object read0 (Lisp_Object, bool);
+ Lisp_Object, ptrdiff_t);
+static Lisp_Object read0 (Lisp_Object, ptrdiff_t);
static Lisp_Object substitute_object_recurse (struct subst *, Lisp_Object);
static void substitute_in_interval (INTERVAL, void *);
@@ -1336,6 +1366,11 @@ close_file_unwind_android_fd (void *ptr)
#endif
+static void unbind_char_count (int old_char_count)
+{
+ char_count = old_char_count;
+}
+
DEFUN ("load", Fload, Sload, 1, 5, 0,
doc: /* Execute a file of Lisp code named FILE.
First try FILE with `.elc' appended, then try with `.el', then try
@@ -1716,6 +1751,9 @@ Return t if the file exists and loads successfully. */)
might be accessed by the unbind_to call below. */
struct infile input;
+ record_unwind_protect_int (&unbind_char_count, char_count);
+ char_count = 1;
+
if (is_module || is_native_elisp)
{
/* `module-load' uses the file name, so we can close the stream
@@ -1785,6 +1823,9 @@ Return t if the file exists and loads successfully. */)
}
else
{
+ Vread_stream = file;
+ if (is_elc)
+ specbind (Qload_read_function, Qread);
if (lisp_file_lexically_bound_p (Qget_file_char))
Fset (Qlexical_binding, Qt);
@@ -2391,9 +2432,88 @@ end_of_file_error (void)
xsignal0 (Qend_of_file);
}
+/* readevalloop_early_eval evaluates Lisp forms in early bootstrap
+ before full macro expansion is available. If that form is a
+ defining `defalias', the function arranges for the defined symbol
+ to be later posified. (`defmacro' and `defun' contain code to
+ posify the macros and functions they create.) */
+
+static Lisp_Object
+readevalloop_early_eval (Lisp_Object val)
+{
+ Lisp_Object quote_foo, def_sym, function_form, lambda_form, lambda_pointer;
+ bool macro = false;
+
+ /* Have we got a (defalias 'foo ...) form? */
+ if (EQ (CAR_SAFE (val), Qdefalias)
+ && CONSP (Fcdr (val))
+ && CONSP (quote_foo = Fcar (Fcdr (val)))
+ && EQ (Fcar (quote_foo), Qquote)
+ && CONSP (Fcdr (quote_foo))
+ && SYMBOLP (def_sym = Fcar (Fcdr (quote_foo)))
+ && !NILP (def_sym))
+ {
+ Vdefining_symbol = def_sym;
+ /* Strip the position from the symbol. */
+ Fsetcar (Fcdr (quote_foo), Fbare_symbol (def_sym));
+ /* Have we got, additionally, (defalias 'foo #'(lambda ...))?
+ Aka (defalias 'foo (function (lambda ...)))?
+ Or, (defalias 'foo (cons 'macro (function (lambda ...))))) */
+ if (CONSP (Fcdr (Fcdr (val)))
+ && CONSP (function_form = Fcar (Fcdr (Fcdr (val)))))
+ {
+ if (EQ (Fcar (function_form), Qcons)
+ && CONSP (Fcdr (function_form))
+ && CONSP (Fcar (Fcdr (function_form))) /* 'macro */
+ && EQ (Fcar (Fcar (Fcdr (function_form))), Qquote)
+ && CONSP (Fcdr (Fcar (Fcdr (function_form))))
+ && EQ (Fcar (Fcdr (Fcar (Fcdr (function_form)))), Qmacro))
+ {
+ macro = true;
+ function_form = Fcdr (Fcdr (function_form));
+ printf ("ref_early_eval: macro detected\n");
+ }
+ if (CONSP (lambda_pointer = (Fcdr (function_form)))
+ && CONSP (lambda_form = Fcar (Fcdr (function_form))) /* (lambda
...) */
+ && EQ (Fcar (lambda_form), Qlambda))
+ {
+ if (!NILP (Ffboundp (Qbyte_run_posify_lambda_form)))
+ {
+ lambda_form = call2 (Qbyte_run_posify_lambda_form,
+ lambda_form,
+ byte_compile_in_progress ? Qt : Qnil);
+
+ if (macro)
+ val = CALLN (Fnconc, Ftake (make_fixnum (2), val),
+ Fcons (list2 (Qcons, list2 (Qquote, Qmacro)),
+ list1 (list2 (Fcar (function_form),
+ lambda_form))));
+ else
+ val = CALLN (Fnconc, Ftake (make_fixnum (2), val),
+ list1 (list2 (Fcar (function_form),
lambda_form)));
+ }
+ else
+ {
+ Vearly_lambda_lists
+ = Fcons (list3 (lambda_pointer, Fcar (lambda_form),
+ Vdefining_symbol),
+ Vearly_lambda_lists);
+ Fsetcar (lambda_form, Fbare_symbol (Fcar (lambda_form)));
+ }
+ }
+ }
+ }
+ val = Fmacroexpand (val, Qnil);
+ return eval_sub (val);
+}
+
+/* readevalloop_eager_expand_eval evaluates a Lisp form VAL, eagerly
+ expanding its macros using the function MACROEXPAND. */
+
static Lisp_Object
readevalloop_eager_expand_eval (Lisp_Object val, Lisp_Object macroexpand)
{
+ Lisp_Object def_sym, quote_foo;
/* If we macroexpand the toplevel form non-recursively and it ends
up being a `progn' (or if it was a progn to start), treat each
form in the progn as a top-level form. This way, if one form in
@@ -2402,6 +2522,18 @@ readevalloop_eager_expand_eval (Lisp_Object val,
Lisp_Object macroexpand)
specpdl_ref count = SPECPDL_INDEX ();
specbind (Qdefining_symbol, Qnil); /* This gets setq'd in macros. */
+
+ if (!base_loaded /* Still in mid-bootstrapping */
+ /* Have we got a (defalias 'foo ...) form? */
+ && EQ (CAR_SAFE (val), Qdefalias)
+ && CONSP (Fcdr (val))
+ && CONSP (quote_foo = Fcar (Fcdr (val)))
+ && EQ (Fcar (quote_foo), Qquote)
+ && CONSP (Fcdr (quote_foo))
+ && SYMBOLP (def_sym = Fcar (Fcdr (quote_foo)))
+ && !NILP (def_sym))
+ Vdefining_symbol = def_sym;
+
val = call2 (macroexpand, val, Qnil);
if (EQ (CAR_SAFE (val), Qprogn))
{
@@ -2411,7 +2543,12 @@ readevalloop_eager_expand_eval (Lisp_Object val,
Lisp_Object macroexpand)
val = readevalloop_eager_expand_eval (XCAR (subforms), macroexpand);
}
else
- val = eval_sub (call2 (macroexpand, val, Qt));
+ {
+ val = call2 (macroexpand, val, Qt);
+ if (Ffboundp (Qbyte_run_strip_symbol_positions))
+ val = call1 (Qbyte_run_strip_symbol_positions, val);
+ val = eval_sub (val);
+ }
return unbind_to (count, val);
}
@@ -2441,17 +2578,11 @@ readevalloop (Lisp_Object readcharfun,
/* True on the first time around. */
bool first_sexp = 1;
Lisp_Object macroexpand = intern ("internal-macroexpand-for-load");
+ bool is_elc = (STRINGP (sourcename) && suffix_p (sourcename, ".elc"));
if (!NILP (sourcename))
CHECK_STRING (sourcename);
- if (NILP (Ffboundp (macroexpand))
- || (STRINGP (sourcename) && suffix_p (sourcename, ".elc")))
- /* Don't macroexpand before the corresponding function is defined
- and don't bother macroexpanding in .elc files, since it should have
- been done already. */
- macroexpand = Qnil;
-
if (MARKERP (readcharfun))
{
if (NILP (start))
@@ -2557,7 +2688,7 @@ readevalloop (Lisp_Object readcharfun,
DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD,
Qnil, false);
if (!NILP (Vpurify_flag) && c == '(')
- val = read0 (readcharfun, false);
+ val = read0 (readcharfun, 0);
else
{
if (!NILP (readfun))
@@ -2577,7 +2708,7 @@ readevalloop (Lisp_Object readcharfun,
else if (! NILP (Vload_read_function))
val = call1 (Vload_read_function, readcharfun);
else
- val = read_internal_start (readcharfun, Qnil, Qnil, false);
+ val = read_internal_start (readcharfun, Qnil, Qnil, -1);
}
/* Empty hashes can be reused; otherwise, reset on next call. */
if (HASH_TABLE_P (read_objects_map)
@@ -2594,15 +2725,20 @@ readevalloop (Lisp_Object readcharfun,
unbind_to (count1, Qnil);
/* Now eval what we just read. */
- if (!NILP (macroexpand))
- val = readevalloop_eager_expand_eval (val, macroexpand);
- else
+ if (!is_elc
+ && !NILP (Ffboundp (macroexpand))
+ && (base_loaded
+ || (Ffeaturep (Qpcase, Qnil)))) /* macroexp.el fully loaded? */
+ val = readevalloop_eager_expand_eval (val, macroexpand);
+ else if (!is_elc)
{
specpdl_ref count2 = SPECPDL_INDEX ();
specbind (Qdefining_symbol, Qnil);
- val = unbind_to (count2, eval_sub (val));
+ val = unbind_to (count2, readevalloop_early_eval (val));
}
+ else
+ val = eval_sub (val);
if (printflag)
{
@@ -2667,6 +2803,8 @@ This function preserves the position of point. */)
if (NILP (filename))
filename = BVAR (XBUFFER (buf), filename);
+ Vread_stream = get_read_stream (buf);
+
specbind (Qeval_buffer_list, Fcons (buf, Veval_buffer_list));
specbind (Qstandard_output, tem);
record_unwind_protect_excursion ();
@@ -2699,6 +2837,8 @@ This function does not move point. */)
cbuf = Fcurrent_buffer ();
+ Vread_stream = get_read_stream (cbuf);
+
if (NILP (printflag))
tem = Qsymbolp;
else
@@ -2728,6 +2868,8 @@ STREAM or the value of `standard-input' may be:
standard input in batch mode). */)
(Lisp_Object stream)
{
+ Vread_stream = get_read_stream (stream);
+
if (NILP (stream))
stream = Vstandard_input;
if (EQ (stream, Qt))
@@ -2740,7 +2882,7 @@ STREAM or the value of `standard-input' may be:
return call1 (intern ("read-minibuffer"),
build_string ("Lisp expression: "));
- return read_internal_start (stream, Qnil, Qnil, false);
+ return read_internal_start (stream, Qnil, Qnil, 0);
}
DEFUN ("read-positioning-symbols", Fread_positioning_symbols,
@@ -2759,6 +2901,38 @@ STREAM or the value of `standard-input' may be:
standard input in batch mode). */)
(Lisp_Object stream)
{
+ Vread_stream = get_read_stream (stream);
+
+ if (NILP (stream))
+ stream = Vstandard_input;
+ if (EQ (stream, Qt))
+ stream = Qread_char;
+ if (EQ (stream, Qread_char))
+ /* FIXME: ?! When is this used !? */
+ return call1 (intern ("read-minibuffer"),
+ build_string ("Lisp expression: "));
+ return read_internal_start (stream, Qnil, Qnil, 1);
+}
+
+DEFUN ("read-positioning-defined-symbols", Fread_positioning_defined_symbols,
+ Sread_positioning_defined_symbols, 0, 1, 0,
+ doc: /* Read one Lisp expression as text from STREAM, return as Lisp
object.
+
+Convert each occurrence of a defined symbol (e.g. from `defun') or
+`lambda' into a "symbol with pos" object.
+
+If STREAM is nil, use the value of `standard-input' (which see).
+STREAM or the value of `standard-input' may be:
+ a buffer (read from point and advance it)
+ a marker (read from where it points and advance it)
+ a function (call it with no arguments for each character,
+ call it with a char as argument to push a char back)
+ a string (takes text from string, starting at the beginning)
+ t (read text line using minibuffer and use it, or read from
+ standard input in batch mode). */)
+ (Lisp_Object stream)
+{
+ Vread_stream = get_read_stream (stream);
if (NILP (stream))
stream = Vstandard_input;
if (EQ (stream, Qt))
@@ -2768,7 +2942,7 @@ STREAM or the value of `standard-input' may be:
return call1 (intern ("read-minibuffer"),
build_string ("Lisp expression: "));
- return read_internal_start (stream, Qnil, Qnil, true);
+ return read_internal_start (stream, Qnil, Qnil, -1);
}
DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0,
@@ -2781,24 +2955,60 @@ a substring of STRING from which to read; they default
to 0 and
the end of STRING. */)
(Lisp_Object string, Lisp_Object start, Lisp_Object end)
{
+ Vread_stream = get_read_stream (string);
Lisp_Object ret;
CHECK_STRING (string);
/* `read_internal_start' sets `read_from_string_index'. */
- ret = read_internal_start (string, start, end, false);
+ ret = read_internal_start (string, start, end, 0);
return Fcons (ret, make_fixnum (read_from_string_index));
}
+/* Determine the new value of the variable `read-stream' based on
+ READCHARFUN. Return this value. */
+static Lisp_Object
+get_read_stream (Lisp_Object readcharfun)
+{
+ Lisp_Object temp;
+
+ if (STRINGP (readcharfun))
+ temp = Qnil;
+ else if (BUFFERP (readcharfun)
+ || EQ (readcharfun, Qt))
+ {
+ /* message3_nolog (Fbuffer_name (readcharfun)); */
+ if (Fequal (Fbuffer_name (readcharfun),
+ make_string (" *Compiler Input*", 17)))
+ temp = Fsymbol_value (Qbyte_compile_current_buffer);
+ else
+ temp = readcharfun;
+ }
+ else if (MARKERP (readcharfun))
+ XSETBUFFER (temp, XMARKER (readcharfun)->buffer);
+ else if (EQ (readcharfun, Qget_file_char)
+ || EQ (readcharfun, Qget_emacs_mule_file_char))
+ temp = Qload_file_name;
+ else
+ temp = Qnil;
+ return temp;
+}
+
/* Function to set up the global context we need in toplevel read
- calls. START and END only used when STREAM is a string.
- LOCATE_SYMS true means read symbol occurrences as symbols with
- position. */
+ calls. START and END only used when STREAM is a string. LOC_SYMS
+ 1 means read symbol occurrences as symbols with position; -1 means
+ read only defined symbols and `lambda' with position; 0 means no
+ symbols with position. */
static Lisp_Object
read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end,
- bool locate_syms)
+ ptrdiff_t loc_syms)
{
Lisp_Object retval;
- readchar_offset = BUFFERP (stream) ? XBUFFER (stream)->pt : 0;
+ readchar_offset =
+ BUFFERP (stream) ? XBUFFER (stream)->pt
+ : (char_count > 0
+ && (EQ (stream, Qget_file_char)
+ || EQ (stream, Qget_emacs_mule_file_char))) ? char_count
+ : 0;
/* We can get called from readevalloop which may have set these
already. */
if (! HASH_TABLE_P (read_objects_map)
@@ -2831,7 +3041,7 @@ read_internal_start (Lisp_Object stream, Lisp_Object
start, Lisp_Object end,
read_from_string_limit = endval;
}
- retval = read0 (stream, locate_syms);
+ retval = read0 (stream, loc_syms);
if (HASH_TABLE_P (read_objects_map)
&& XHASH_TABLE (read_objects_map)->count > 0)
read_objects_map = Qnil;
@@ -3842,19 +4052,23 @@ enum read_entry_type
struct read_stack_entry
{
+ ptrdiff_t old_locate_syms;
enum read_entry_type type;
union {
/* RE_list, RE_list_dot */
struct {
Lisp_Object head; /* first cons of list */
Lisp_Object tail; /* last cons of list */
+ /* The following two fields are useful only when locate_syms is -1. */
+ ptrdiff_t target_obj; /* Index of object we want to position. */
+ ptrdiff_t current_obj; /* Index of object about to be read. */
} list;
/* RE_vector, RE_record, RE_char_table, RE_sub_char_table,
RE_byte_code, RE_string_props */
struct {
Lisp_Object elems; /* list of elements in reverse order */
- bool old_locate_syms; /* old value of locate_syms */
+ ptrdiff_t old_locate_syms; /* old value of locate_syms */
} vector;
/* RE_special */
@@ -3958,10 +4172,20 @@ read_stack_reset (intmax_t sp)
rdstack.sp = sp;
}
+#define ADJUST_LOCATE_SYMS() \
+ do { \
+ if (locate_syms == -2) \
+ locate_syms = -1; \
+ else if (locate_syms == 2) \
+ locate_syms = 1; \
+ } while (0);
+
/* Read a Lisp object.
- If LOCATE_SYMS is true, symbols are read with position. */
+ If LOC_SYMS is 1, symbols are read with position; if it's -1,
+ defined symbols and `lambda' are read with position; if it's 0, no
+ symbols are read with position. */
static Lisp_Object
-read0 (Lisp_Object readcharfun, bool locate_syms)
+read0 (Lisp_Object readcharfun, ptrdiff_t loc_syms)
{
char stackbuf[64];
char *read_buffer = stackbuf;
@@ -3977,6 +4201,21 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
bool uninterned_symbol;
bool skip_shorthand;
+ Lisp_Object defined_form = Qnil;
+ /* locate_syms can take any of the following values:
+ -2: As -1, but position a `lambda' if it immediately follows.
+ -1: Defined symbols and `lambda' following an open paren will be
+ positioned.
+ 0: No symbol will be positioned.
+ 1: All symbols, except for nil, will be positioned.
+ 2: Just the next form is to be positioned.
+ Here a "defined symbol" is the `foo' in the likes of (defun foo ...).
+ */
+ ptrdiff_t locate_syms = loc_syms;
+
+ /* Record readcharfun (often a buffer) for the use of Lisp programs. */
+ /* Vread_stream = readcharfun; */
+
/* Read an object into `obj'. */
read_obj: ;
Lisp_Object obj;
@@ -3988,7 +4227,14 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
switch (c)
{
case '(':
- read_stack_push ((struct read_stack_entry) {.type = RE_list_start});
+ read_stack_push ((struct read_stack_entry) {.type = RE_list_start,
+ .old_locate_syms =
locate_syms,
+ .u.list.target_obj = -1,
+ .u.list.current_obj = -1});
+ if (locate_syms == -1)
+ locate_syms = -2; /* Position a lambda right after ( */
+ if (locate_syms == 2)
+ locate_syms = 1;
goto read_obj;
case ')':
@@ -3997,15 +4243,17 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
switch (read_stack_top ()->type)
{
case RE_list_start:
+ locate_syms = read_stack_top ()->old_locate_syms;
read_stack_pop ();
obj = Qnil;
break;
case RE_list:
+ locate_syms = read_stack_top ()->old_locate_syms;
obj = read_stack_pop ()->u.list.head;
break;
case RE_record:
{
- locate_syms = read_stack_top ()->u.vector.old_locate_syms;
+ locate_syms = read_stack_top ()->old_locate_syms;
Lisp_Object elems = Fnreverse (read_stack_pop ()->u.vector.elems);
if (NILP (elems))
invalid_syntax ("#s", readcharfun);
@@ -4017,7 +4265,7 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
break;
}
case RE_string_props:
- locate_syms = read_stack_top ()->u.vector.old_locate_syms;
+ locate_syms = read_stack_top ()->old_locate_syms;
obj = string_props_from_rev_list (read_stack_pop () ->u.vector.elems,
readcharfun);
break;
@@ -4028,11 +4276,12 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
case '[':
read_stack_push ((struct read_stack_entry) {
+ .old_locate_syms = locate_syms,
.type = RE_vector,
- .u.vector.elems = Qnil,
- .u.vector.old_locate_syms = locate_syms,
+ .u.vector.elems = Qnil
});
- /* FIXME: should vectors be read with locate_syms=false? */
+ ADJUST_LOCATE_SYMS ();
+ /* FIXME: should vectors be read with locate_syms zero? */
goto read_obj;
case ']':
@@ -4041,21 +4290,21 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
switch (read_stack_top ()->type)
{
case RE_vector:
- locate_syms = read_stack_top ()->u.vector.old_locate_syms;
+ locate_syms = read_stack_top ()->old_locate_syms;
obj = vector_from_rev_list (read_stack_pop ()->u.vector.elems);
break;
case RE_byte_code:
- locate_syms = read_stack_top ()->u.vector.old_locate_syms;
+ locate_syms = read_stack_top ()->old_locate_syms;
obj = bytecode_from_rev_list (read_stack_pop ()->u.vector.elems,
readcharfun);
break;
case RE_char_table:
- locate_syms = read_stack_top ()->u.vector.old_locate_syms;
+ locate_syms = read_stack_top ()->old_locate_syms;
obj = char_table_from_rev_list (read_stack_pop ()->u.vector.elems,
readcharfun);
break;
case RE_sub_char_table:
- locate_syms = read_stack_top ()->u.vector.old_locate_syms;
+ locate_syms = read_stack_top ()->old_locate_syms;
obj = sub_char_table_from_rev_list (read_stack_pop ()->u.vector.elems,
readcharfun);
break;
@@ -4073,9 +4322,12 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
case '\'':
/* #'X -- special syntax for (function X) */
read_stack_push ((struct read_stack_entry) {
+ .old_locate_syms = locate_syms,
.type = RE_special,
- .u.special.symbol = Qfunction,
+ .u.special.symbol = Qfunction
});
+ if (locate_syms == 2)
+ locate_syms = 1;
goto read_obj;
case '#':
@@ -4092,11 +4344,11 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
invalid_syntax ("#s", readcharfun);
}
read_stack_push ((struct read_stack_entry) {
+ .old_locate_syms = locate_syms,
.type = RE_record,
- .u.vector.elems = Qnil,
- .u.vector.old_locate_syms = locate_syms,
+ .u.vector.elems = Qnil
});
- locate_syms = false;
+ locate_syms = 0;
goto read_obj;
case '^':
@@ -4109,11 +4361,11 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
if (ch == '[')
{
read_stack_push ((struct read_stack_entry) {
+ .old_locate_syms = locate_syms,
.type = RE_sub_char_table,
- .u.vector.elems = Qnil,
- .u.vector.old_locate_syms = locate_syms,
+ .u.vector.elems = Qnil
});
- locate_syms = false;
+ locate_syms = 0;
goto read_obj;
}
else
@@ -4125,11 +4377,11 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
else if (ch == '[')
{
read_stack_push ((struct read_stack_entry) {
+ .old_locate_syms = locate_syms,
.type = RE_char_table,
- .u.vector.elems = Qnil,
- .u.vector.old_locate_syms = locate_syms,
+ .u.vector.elems = Qnil
});
- locate_syms = false;
+ locate_syms = 0;
goto read_obj;
}
else
@@ -4141,21 +4393,21 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
case '(':
/* #(...) -- string with properties */
read_stack_push ((struct read_stack_entry) {
+ .old_locate_syms = locate_syms,
.type = RE_string_props,
- .u.vector.elems = Qnil,
- .u.vector.old_locate_syms = locate_syms,
+ .u.vector.elems = Qnil
});
- locate_syms = false;
+ locate_syms = 0;
goto read_obj;
case '[':
/* #[...] -- byte-code */
read_stack_push ((struct read_stack_entry) {
+ .old_locate_syms = locate_syms,
.type = RE_byte_code,
.u.vector.elems = Qnil,
- .u.vector.old_locate_syms = locate_syms,
});
- locate_syms = false;
+ locate_syms = 0;
goto read_obj;
case '&':
@@ -4278,10 +4530,12 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
else
hash_put (h, number, placeholder, hash);
read_stack_push ((struct read_stack_entry) {
+ .old_locate_syms = locate_syms,
.type = RE_numbered,
.u.numbered.number = number,
- .u.numbered.placeholder = placeholder,
+ .u.numbered.placeholder = placeholder
});
+ ADJUST_LOCATE_SYMS ();
goto read_obj;
}
else if (c == '#')
@@ -4317,16 +4571,20 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
case '\'':
read_stack_push ((struct read_stack_entry) {
+ .old_locate_syms = locate_syms,
.type = RE_special,
- .u.special.symbol = Qquote,
+ .u.special.symbol = Qquote
});
+ ADJUST_LOCATE_SYMS ();
goto read_obj;
case '`':
read_stack_push ((struct read_stack_entry) {
+ .old_locate_syms = locate_syms,
.type = RE_special,
- .u.special.symbol = Qbackquote,
+ .u.special.symbol = Qbackquote
});
+ ADJUST_LOCATE_SYMS ();
goto read_obj;
case ',':
@@ -4342,9 +4600,11 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
sym = Qcomma;
}
read_stack_push ((struct read_stack_entry) {
+ .old_locate_syms = locate_syms,
.type = RE_special,
- .u.special.symbol = sym,
+ .u.special.symbol = sym
});
+ ADJUST_LOCATE_SYMS ();
goto read_obj;
}
@@ -4502,10 +4762,12 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
result = intern_driver (name, obarray, found);
}
}
- if (locate_syms && !NILP (result))
+ if (!NILP (result)
+ && (locate_syms > 0
+ || (locate_syms == -2
+ && EQ (result, Qlambda))))
result = build_symbol_with_pos (result,
make_fixnum (start_position));
-
obj = result;
break;
}
@@ -4519,6 +4781,18 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
switch (e->type)
{
case RE_list_start:
+ if (locate_syms == -2)
+ locate_syms = -1; /* Don't position lambdas unless right after a (.
*/
+ if (locate_syms < 0
+ && (SYMBOLP (obj))
+ && (FIXNUMP (defined_form
+ = (Fget (obj, Qbyte_run_defined_form)))))
+ {
+ e->u.list.target_obj = XFIXNUM (defined_form);
+ e->u.list.current_obj = 1;
+ if (e->u.list.current_obj == e->u.list.target_obj)
+ locate_syms = 2;
+ }
e->type = RE_list;
e->u.list.head = e->u.list.tail = Fcons (obj, Qnil);
goto read_obj;
@@ -4528,6 +4802,13 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
Lisp_Object tl = Fcons (obj, Qnil);
XSETCDR (e->u.list.tail, tl);
e->u.list.tail = tl;
+ if (locate_syms < 0 || locate_syms == 2)
+ e->u.list.current_obj++;
+ if (locate_syms < 0
+ && (e->u.list.current_obj == e->u.list.target_obj))
+ locate_syms = 2; /* Meaning "position just the next form". */
+ else if (locate_syms == 2)
+ locate_syms = -1;
goto read_obj;
}
@@ -4538,6 +4819,7 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
if (ch != ')')
invalid_syntax ("expected )", readcharfun);
XSETCDR (e->u.list.tail, obj);
+ locate_syms = read_stack_top ()->old_locate_syms;
read_stack_pop ();
obj = e->u.list.head;
@@ -4562,12 +4844,14 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
goto read_obj;
case RE_special:
+ locate_syms = read_stack_top ()->old_locate_syms;
read_stack_pop ();
obj = list2 (e->u.special.symbol, obj);
break;
case RE_numbered:
{
+ locate_syms = read_stack_top ()->old_locate_syms;
read_stack_pop ();
Lisp_Object placeholder = e->u.numbered.placeholder;
if (CONSP (obj))
@@ -5681,6 +5965,7 @@ syms_of_lread (void)
{
defsubr (&Sread);
defsubr (&Sread_positioning_symbols);
+ defsubr (&Sread_positioning_defined_symbols);
defsubr (&Sread_from_string);
defsubr (&Slread__substitute_object_in_subtree);
defsubr (&Sintern);
@@ -5783,6 +6068,13 @@ customize `jka-compr-load-suffixes' rather than the
present variable. */);
doc: /* Non-nil if inside of `load'. */);
DEFSYM (Qload_in_progress, "load-in-progress");
+ DEFSYM (Qbyte_compile_in_progress, "byte-compile-in-progress");
+ DEFVAR_BOOL ("byte-compile-in-progress", byte_compile_in_progress,
+ doc: /* Non-nil when byte compilation is in progress.
+This variable is used to decide whether or not to read all symbols with
+positions. */);
+ byte_compile_in_progress = false;
+
DEFVAR_LISP ("after-load-alist", Vafter_load_alist,
doc: /* An alist of functions to be evalled when particular
files are loaded.
Each element looks like (REGEXP-OR-FEATURE FUNCS...).
@@ -5843,6 +6135,7 @@ of the file, regardless of whether or not it has the
`.elc' extension. */);
doc: /* Used for internal purposes by `load'. */);
Vcurrent_load_list = Qnil;
+ DEFSYM (Qload_read_function, "load-read-function");
DEFVAR_LISP ("load-read-function", Vload_read_function,
doc: /* Function used for reading expressions.
It is used by `load' and `eval-region'.
@@ -5850,7 +6143,10 @@ It is used by `load' and `eval-region'.
Called with a single argument (the stream from which to read).
The default is to use the function `read'. */);
DEFSYM (Qread, "read");
- Vload_read_function = Qread;
+ DEFSYM (Qread_positioning_symbols, "read-positioning-symbols");
+ DEFSYM (Qread_positioning_defined_symbols,
+ "read-positioning-defined-symbols");
+ Vload_read_function = Qread_positioning_defined_symbols;
DEFVAR_LISP ("load-source-file-function", Vload_source_file_function,
doc: /* Function called in `load' to load an Emacs Lisp source
file.
@@ -5931,6 +6227,20 @@ This variable is bound in the read-eval-print loop and
certain
high-level functions in the byte compiler. It is set to a value by
functions and macros such as `defun', `defmacro', and `defvar'. */);
+ DEFSYM (Qread_stream, "read-stream");
+ DEFVAR_LISP ("read-stream", Vread_stream,
+ doc: /* The stream of the current or previous read operation.
+This is often a buffer, but may alternatively be a string or a function.
+When it is a string, this is the file name being loaded from.
+When it is nil, we are reading from a string. */);
+ Vread_stream = Qnil;
+
+ /* The following is a symbol property applied to defining macros such as
+ `defun' and `cl-defstruct'. It's value is an integer designating which
+ argument in an invocation is the new symbol being defined. The first
+ argument following the macro symbol is 1, not 0. */
+ DEFSYM (Qbyte_run_defined_form, "byte-run-defined-form");
+
DEFVAR_LISP ("eval-buffer-list", Veval_buffer_list,
doc: /* List of buffers being read from by calls to
`eval-buffer' and `eval-region'. */);
Veval_buffer_list = Qnil;
@@ -5949,6 +6259,22 @@ For internal use only. */);
DEFSYM (Qbyte_run_strip_symbol_positions,
"byte-run-strip-symbol-positions");
+ DEFSYM (Qbyte_run_posify_lambda_form, "byte-run-posify-lambda-form");
+
+ DEFSYM (Qearly_lambda_lists, "early-lambda-lists");
+ DEFVAR_LISP ("early-lambda-lists", Vearly_lambda_lists,
+ doc: /* List of details about early lambda forms.
+Each element is a triple, (FORM, LAMBDA, DEFINING-SYMBOL) where the latter two
+are (usually) symbols with position, with which the lambda a FORM will be
+later positioned. */);
+ Vearly_lambda_lists = Qnil;
+
+ DEFSYM (Qdefalias, "defalias");
+ DEFVAR_BOOL ("base-loaded", base_loaded,
+ doc: /* A value of t means the first few .el files in the
bootstrap
+have been fully loaded. Don't change this value at any time. */);
+ base_loaded = false;
+
DEFVAR_BOOL ("load-prefer-newer", load_prefer_newer,
doc: /* Non-nil means `load' prefers the newest version of a
file.
This applies when a filename suffix is not explicitly specified and
@@ -6018,6 +6344,8 @@ that are loaded before your customizations are read! */);
DEFSYM (Qrehash_threshold, "rehash-threshold");
DEFSYM (Qchar_from_name, "char-from-name");
+ DEFSYM (Qbyte_compile_current_buffer, "byte-compile-current-buffer");
+ DEFSYM (Qpcase, "pcase");
DEFVAR_LISP ("read-symbol-shorthands", Vread_symbol_shorthands,
doc: /* Alist of known symbol-name shorthands.
diff --git a/test/Makefile.in b/test/Makefile.in
index 4e53efeb9a8..226fb2f20bc 100644
--- a/test/Makefile.in
+++ b/test/Makefile.in
@@ -80,7 +80,7 @@ TEST_INTERACTIVE ?= no
ifeq ($(TEST_INTERACTIVE),yes)
TEST_RUN_ERT = --eval '(ert (quote ${SELECTOR_ACTUAL}))'
else
-TEST_RUN_ERT = --batch --eval '(ert-run-tests-batch-and-exit (quote
${SELECTOR_ACTUAL}))' ${WRITE_LOG}
+TEST_RUN_ERT = --batch --eval "(setq backtrace-print-function 'prin1)" --eval
'(ert-run-tests-batch-and-exit (quote ${SELECTOR_ACTUAL}))' ${WRITE_LOG}
endif
# Whether to run tests from .el files in preference to .elc, we do
diff --git a/test/lisp/emacs-lisp/cconv-tests.el
b/test/lisp/emacs-lisp/cconv-tests.el
index 6facd3452ea..6da2e90c4ac 100644
--- a/test/lisp/emacs-lisp/cconv-tests.el
+++ b/test/lisp/emacs-lisp/cconv-tests.el
@@ -175,9 +175,10 @@
(ert-deftest cconv-convert-lambda-lifted ()
;; Verify that lambda-lifting is actually performed at all.
- (should (equal (cconv-closure-convert
+ (should (equal (byte-run-strip-lambda-doc
+ (cconv-closure-convert
'#'(lambda (x) (let ((f #'(lambda () (+ x 1))))
- (funcall f))))
+ (funcall f)))))
'#'(lambda (x) (let ((f #'(lambda (x) (+ x 1))))
(funcall f x)))))
@@ -211,33 +212,33 @@
;; distinct symbols having the same name.
;; Sanity check: captured variable, no lambda-lifting or shadowing:
- (should (equal (cconv-tests--intern-all
+ (should (equal (byte-run-strip-lambda-doc (cconv-tests--intern-all
(cconv-closure-convert
'#'(lambda (x)
- #'(lambda () x))))
+ #'(lambda () x)))))
'#'(lambda (x)
(internal-make-closure
nil (x) nil
(internal-get-closed-var 0)))))
;; Basic case:
- (should (equal (cconv-tests--intern-all
+ (should (equal (byte-run-strip-lambda-doc (cconv-tests--intern-all
(cconv-closure-convert
'#'(lambda (x)
(let ((f #'(lambda () x)))
(let ((x 'b))
- (list x (funcall f)))))))
+ (list x (funcall f))))))))
'#'(lambda (x)
(let ((f #'(lambda (x) x)))
(let ((x 'b)
(closed-x x))
(list x (funcall f closed-x)))))))
- (should (equal (cconv-tests--intern-all
+ (should (equal (byte-run-strip-lambda-doc (cconv-tests--intern-all
(cconv-closure-convert
'#'(lambda (x)
(let ((f #'(lambda () x)))
(let* ((x 'b))
- (list x (funcall f)))))))
+ (list x (funcall f))))))))
'#'(lambda (x)
(let ((f #'(lambda (x) x)))
(let* ((closed-x x)
@@ -245,14 +246,14 @@
(list x (funcall f closed-x)))))))
;; With the lambda-lifted shadowed variable also being captured:
- (should (equal
+ (should (equal (byte-run-strip-lambda-doc
(cconv-tests--intern-all
(cconv-closure-convert
'#'(lambda (x)
#'(lambda ()
(let ((f #'(lambda () x)))
(let ((x 'a))
- (list x (funcall f))))))))
+ (list x (funcall f)))))))))
'#'(lambda (x)
(internal-make-closure
nil (x) nil
@@ -260,14 +261,14 @@
(let ((x 'a)
(closed-x (internal-get-closed-var 0)))
(list x (funcall f closed-x))))))))
- (should (equal
+ (should (equal (byte-run-strip-lambda-doc
(cconv-tests--intern-all
(cconv-closure-convert
'#'(lambda (x)
#'(lambda ()
(let ((f #'(lambda () x)))
(let* ((x 'a))
- (list x (funcall f))))))))
+ (list x (funcall f)))))))))
'#'(lambda (x)
(internal-make-closure
nil (x) nil
@@ -276,7 +277,7 @@
(x 'a))
(list x (funcall f closed-x))))))))
;; With lambda-lifted shadowed variable also being mutably captured:
- (should (equal
+ (should (equal (byte-run-strip-lambda-doc
(cconv-tests--intern-all
(cconv-closure-convert
'#'(lambda (x)
@@ -284,7 +285,7 @@
(let ((f #'(lambda () x)))
(setq x x)
(let ((x 'a))
- (list x (funcall f))))))))
+ (list x (funcall f)))))))))
'#'(lambda (x)
(let ((x (list x)))
(internal-make-closure
@@ -295,7 +296,7 @@
(let ((x 'a)
(closed-x (internal-get-closed-var 0)))
(list x (funcall f closed-x)))))))))
- (should (equal
+ (should (equal (byte-run-strip-lambda-doc
(cconv-tests--intern-all
(cconv-closure-convert
'#'(lambda (x)
@@ -303,7 +304,7 @@
(let ((f #'(lambda () x)))
(setq x x)
(let* ((x 'a))
- (list x (funcall f))))))))
+ (list x (funcall f)))))))))
'#'(lambda (x)
(let ((x (list x)))
(internal-make-closure
@@ -315,14 +316,14 @@
(x 'a))
(list x (funcall f closed-x)))))))))
;; Lambda-lifted variable that isn't actually captured where it is shadowed:
- (should (equal
+ (should (equal (byte-run-strip-lambda-doc
(cconv-tests--intern-all
(cconv-closure-convert
'#'(lambda (x)
(let ((g #'(lambda () x))
(h #'(lambda () (setq x x))))
(let ((x 'b))
- (list x (funcall g) (funcall h)))))))
+ (list x (funcall g) (funcall h))))))))
'#'(lambda (x)
(let ((x (list x)))
(let ((g #'(lambda (x) (car-safe x)))
@@ -330,14 +331,14 @@
(let ((x 'b)
(closed-x x))
(list x (funcall g closed-x) (funcall h closed-x))))))))
- (should (equal
+ (should (equal (byte-run-strip-lambda-doc
(cconv-tests--intern-all
(cconv-closure-convert
'#'(lambda (x)
(let ((g #'(lambda () x))
(h #'(lambda () (setq x x))))
(let* ((x 'b))
- (list x (funcall g) (funcall h)))))))
+ (list x (funcall g) (funcall h))))))))
'#'(lambda (x)
(let ((x (list x)))
(let ((g #'(lambda (x) (car-safe x)))
diff --git a/test/lisp/emacs-lisp/ert-tests.el
b/test/lisp/emacs-lisp/ert-tests.el
index bb3de111e3e..1379d40330e 100644
--- a/test/lisp/emacs-lisp/ert-tests.el
+++ b/test/lisp/emacs-lisp/ert-tests.el
@@ -375,7 +375,7 @@ This macro is used to test if macroexpansion in `should'
works."
(ert-deftest ert-test-abc () "foo" :tags '(bar))
(let ((abc (ert-get-test 'ert-test-abc)))
(should (equal (ert-test-tags abc) '(bar)))
- (should (equal (ert-test-documentation abc) "foo")))
+ (should (string-suffix-p "foo" (ert-test-documentation abc))))
(should (equal (symbol-file 'ert-test-deftest 'ert--test)
(symbol-file 'ert-test--which-file 'defun)))
diff --git a/test/lisp/emacs-lisp/ert-x-tests.el
b/test/lisp/emacs-lisp/ert-x-tests.el
index 6be2ca18ff1..66fc14ceb86 100644
--- a/test/lisp/emacs-lisp/ert-x-tests.el
+++ b/test/lisp/emacs-lisp/ert-x-tests.el
@@ -250,6 +250,7 @@
"\\`ert-test-describe-test is a test"
" defined in"
" ['`‘]ert-x-tests.elc?['’]\\.\n\n"
+ ";POS.... \\[[^]]*]\n"
"Tests ['`‘]ert-describe-test['’]\\.\n\\'")
(buffer-string))))))))
diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el
index 912a85ad5e0..477aac6c098 100644
--- a/test/lisp/erc/erc-tests.el
+++ b/test/lisp/erc/erc-tests.el
@@ -134,13 +134,25 @@
(advice-remove 'buffer-local-value 'erc-with-server-buffer)))
(ert-deftest erc--with-dependent-type-match ()
- (should (equal (macroexpand-1
- '(erc--with-dependent-type-match (repeat face) erc-match))
- '(backquote-list*
- 'repeat :match (lambda (w v)
- (require 'erc-match)
- (widget-editable-list-match w v))
- '(face)))))
+;; '(backquote-list*
+;; 'repeat :match (lambda (w v)
+;; ";POS\36\1\1\1 [nil nil nil 21249]\n"
+;; (require 'erc-match)
+;; (widget-editable-list-match w v))
+;; '(face))
+ (let ((res (macroexpand-1
+ '(erc--with-dependent-type-match (repeat face) erc-match))))
+ (should (eq (car res) 'backquote-list*))
+ (should (equal (cadr res) ''repeat))
+ (should (eq (nth 2 res) ':match))
+ (let ((form (nth 3 res)))
+ (should (eq (car form) 'lambda))
+ (should (equal (cadr form) '(w v)))
+ (should (string-match ";POS\36\1\1\1 \\[nil nil nil [0-9]+]\n"
+ (nth 2 form)))
+ (should (equal (nth 3 form) '(require 'erc-match)))
+ (should (equal (nth 4 form) '(widget-editable-list-match w v))))
+ (should (equal (nth 4 res) ''(face)))))
(defun erc-tests--send-prep ()
;; Caller should probably shadow `erc-insert-modify-hook' or
diff --git a/test/lisp/jsonrpc-tests.el b/test/lisp/jsonrpc-tests.el
index 85ac96a931c..d8795ad8586 100644
--- a/test/lisp/jsonrpc-tests.el
+++ b/test/lisp/jsonrpc-tests.el
@@ -76,6 +76,7 @@
(setq endpoint
(make-instance
'jsonrpc--test-client
+ :name
"Emacs RPC client"
:process
(open-network-stream "JSONRPC test tcp endpoint"
diff --git a/test/lisp/use-package/use-package-tests.el
b/test/lisp/use-package/use-package-tests.el
index 9181a8171a7..ddf1f2e450d 100644
--- a/test/lisp/use-package/use-package-tests.el
+++ b/test/lisp/use-package/use-package-tests.el
@@ -57,17 +57,22 @@
(t form))))
(defmacro expand-minimally (form)
+ (declare (debug (sexp)))
`(let ((use-package-verbose 'errors)
(use-package-expand-minimally t))
(macroexpand-1 ',form)))
(defmacro expand-maximally (form)
+ (declare (debug (sexp)))
`(let ((use-package-verbose 'debug)
(use-package-expand-minimally nil))
(macroexpand-1 ',form)))
(defmacro match-expansion (form &rest value)
- `(should (pcase (expand-minimally ,form)
+ ;; (declare (debug (sexp form)))
+ `(should (pcase
+ (byte-run-strip-lambda-doc
+ (expand-minimally ,form))
,@(mapcar #'(lambda (x) (list x t)) value))))
(defun fix-expansion ()