[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#53905: 29.0.50; [PATCH] Back out scratch/correct-warning-pos
|
From: |
dick . r . chiang |
|
Subject: |
bug#53905: 29.0.50; [PATCH] Back out scratch/correct-warning-pos |
|
Date: |
Wed, 09 Feb 2022 14:09:22 -0500 |
|
User-agent: |
Gnus/5.14 (Gnus v5.14) Commercial/29.0.50 (gnu/linux) |
>From 6cbe8e1baafda4304ca8905808e1a9a3db10d154 Mon Sep 17 00:00:00 2001
From: dickmao <dick.r.chiang@gmail.com>
Date: Wed, 9 Feb 2022 13:54:35 -0500
Subject: [PATCH] Back out scratch/correct-warning-pos
Prefer giving up some diagnostic precision to avoid vitiating
the lisp implementation.
* doc/lispref/elisp.texi (Top): Back out.
* doc/lispref/streams.texi (Input Functions): Back out.
* doc/lispref/symbols.texi (Symbols): Back out.
* lisp/Makefile.in (cldefs .PHONY): Deal with Bug#30635.
(%.elc): Recompile the world after bytecomp.el changes.
* lisp/cedet/semantic/fw.el (semantic-alias-obsolete): Back out.
(semantic-varalias-obsolete): Back out.
* lisp/emacs-lisp/bindat.el (bindat--type): Back out.
* lisp/emacs-lisp/byte-opt.el (byte-compile-inline-expand): Back out.
(byte-optimize-form-code-walker): Back out.
(byte-optimize-let-form): Back out.
(byte-optimize-while): Back out.
(byte-optimize-apply): Back out.
* lisp/emacs-lisp/byte-run.el (byte-run--ssp-seen): Back out.
(byte-run--circular-list-p): Back out.
(byte-run--strip-s-p-1): Back out.
(byte-run-strip-symbol-positions): Back out.
(function-put): Back out.
(defmacro): Back out.
(defun): Back out.
(defsubst): Back out.
(byte-run--unescaped-character-literals-warning): De-obfuscate.
* lisp/emacs-lisp/bytecomp.el (require): Deal with Bug#30635.
(byte-compiler-base-file-name): De-obfuscate.
(byte-compile-recurse-toplevel): Renamed to maybe-expand.
(byte-compile-maybe-expand): Renamed from recurse-toplevel.
(byte-compile-initial-macro-environment): Accommodate renames.
(byte-defop): Whitespace.
(byte-compile-eval-before-compile): Muse to yourself.
(byte-compile-current-form): Globals make programming easy.
(byte-compile-current-annotations): Globals make programming easy.
(byte-compile-current-charpos): Globals make programming easy.
(byte-compile-log-1): Add docstring.
(byte-compile-last-warned-form): Renamed to func.
(byte-compile-last-warned-func): Renamed from form.
(byte-compile--first-symbol): Back out.
(byte-compile--warning-source-offset): Back out.
(byte-compile-warning-prefix): Abbreviate comment.
(byte-compile-log-file): Accommodate renames.
(byte-compile-log-warning-function): Docstring.
(byte-compile-log-warning): Docstring.
(byte-compile--log-warning-for-byte-compile): Whitespace.
(byte-compile-warn): Whitespace.
(byte-compile-warn-x): Back out.
(byte-compile-warn-obsolete): De Morgan's.
(byte-compile-report-error): Whitespace.
(byte-compile-fdefinition): Docstring.
(byte-compile-fuzzy-charpos): Divine charpos of compiler warning.
(byte-compile-function-warn): Docstring and de-obfuscate.
(byte-compile-emit-callargs-warn): Back out.
(byte-compile-format-warn): Back out.
(byte-compile-nogroup-warn): Back out.
(byte-compile-arglist-warn): Back out.
(byte-compile-docstring-length-warn): Back out.
(byte-compile-warn-about-unresolved-functions): Back out.
(byte-compile--outbuffer): Back out.
(byte-compile-close-variables): Back out.
(displaying-byte-compile-warnings): Back out.
(byte-compile-file): Prefer `when`.
(compile-defun): Back out.
(byte-compile-from-buffer): Back out.
(byte-compile-output-file-form): Back out.
(byte-compile-output-docform): Back out.
(byte-compile-keep-pending): Use `prog1` to emphasize return value.
(byte-compile-flush-pending): Back out.
(byte-compile-preprocess): Back out.
(byte-compile-toplevel-file-form): De-obfuscate.
(byte-compile-file-form): De-obfuscate.
(byte-compile-file-form-autoload): Prefer `when`.
(byte-compile--check-prefixed-var): Back out.
(byte-compile--declare-var): Back out.
(byte-compile-file-form-defvar): Prefer `when`.
(byte-compile-file-form-defvar-function): Prefer `when`.
(byte-compile-file-form-require): De-obfuscate.
(byte-compile-file-form-progn): Use `prog1` to emphasize return value.
(byte-compile-file-form-with-no-warnings): Refactor.
(byte-compile-file-form-with-suppressed-warnings): Refactor.
(byte-compile-file-form-make-obsolete): Function quote.
(byte-compile-file-form-defmumble): Renamed to defalias*.
(byte-compile-file-form-defalias*): Renamed from defmumble.
(byte-compile-output-as-comment): Whitespace.
(byte-compile): Docstring.
(byte-compile-check-lambda-list): Back out.
(byte-compile--warn-lexical-dynamic): Back out.
(byte-compile-lambda): Rename "csts" to "constants".
(byte-compile-top-level): Accommodate renames.
(byte-compile-out-toplevel): Rename to "top-level".
(byte-compile-out-top-level): Rename from "toplevel".
(byte-compile-top-level-body): Delete unused function.
(byte-compile-macroexpand-declare-function): Whitespace.
(byte-compile--decouple-cell): Separate out annotation.
(byte-compile--decouple): Separate out annotations.
(byte-compile-form): Let-bind `byte-compile-current-form`.
(byte-compile-normal-call): Prefer `when`.
(byte-compile-unfold-bcf): Rename to byte-code-function.
(byte-compile-unfold-byte-code-function): Rename from bcf.
(byte-compile-check-variable): Back out.
(byte-compile-dynamic-variable-op): Back out.
(byte-compile-free-vars-warn): Back out.
(byte-compile-variable-ref): Back out.
(byte-compile-variable-set): Back out.
(byte-compile-constant): Remove `inline`.
(byte-compile-push-constant): Back out.
(byte-defop-compiler): Docstring.
(byte-compile-subr-wrong-args): Back out.
(byte-compile-and-folded): Allow cl-lib in bytecomp.el.
(byte-compile-discard): Prefer `not`.
(byte-compile-make-closure): Brevity is clarity.
(byte-compile-get-closed-var): Brevity is clarity.
(byte-compile-char-before): Docstring.
(byte-compile-backward-char): Docstring.
(byte-compile-list): Function quote.
(byte-compile-concat): Function quote.
(byte-compile-fset): Docstring.
(byte-compile-function-form): Docstring.
(byte-compile-insert): Function quote.
(byte-compile-set-default): Back out.
(byte-compile-find-bound-condition): Docstring.
(byte-compile-funcall): Function quote.
(byte-compile-condition-case): Back out.
(byte-compile-save-excursion): Back out.
(byte-compile-defvar): Back out.
(byte-compile-autoload): Back out.
(byte-compile-lambda-form): Docstring.
(byte-compile-file-form-defalias): Docstring.
(byte-compile-make-variable-buffer-local): Back out.
(byte-compile-define-symbol-prop): Remove unused retval.
(byte-compile-out): Brevity is clarity.
(byte-compile-annotate-call-tree): Back out.
(display-call-tree): Back out.
(prog1): Use `prog1` to emphasize return value.
* lisp/emacs-lisp/cconv.el (cconv--warn-unused-msg): Back out.
(cconv--convert-funcbody): Back out.
(cconv-convert): Back out.
(cconv--analyze-use): Back out.
(cconv--analyze-function): Back out.
(cconv-analyze-form): Back out.
* lisp/emacs-lisp/cl-generic.el (cl-defmethod): Back out.
* lisp/emacs-lisp/cl-macs.el (cl-load-time-value):
Accommodate renames.
(cl-symbol-macrolet): Back out.
(cl-defstruct): Back out.
* lisp/emacs-lisp/cldefs.el.in (gv): Allow cl-lib in bytecomp.el.
(cldefs--cl-lib-functions): Allow cl-lib in bytecomp.el.
* lisp/emacs-lisp/comp.el (comp-finalize-relocs): Back out.
(comp--native-compile): Back out.
* lisp/emacs-lisp/easy-mmode.el (define-minor-mode): Back out.
* lisp/emacs-lisp/eieio-core.el (eieio-oref): Back out.
(eieio-oref-default): Back out.
(eieio-oset-default): Back out.
* lisp/emacs-lisp/eieio.el (defclass): Back out.
* lisp/emacs-lisp/gv.el (gv-ref): Back out.
* lisp/emacs-lisp/macroexp.el (byte-compile-form-stack): Back out.
(macroexp--compiler-macro): Back out.
(macroexp--warn-wrap): Back out.
(macroexp-warn-and-return): Back out.
(macroexp-macroexpand): Back out.
(macroexp--unfold-lambda): Back out.
(macroexp--expand-all): Back out.
(macroexpand--all-toplevel): Back out.
(macroexpand--all-top-level): Back out.
(internal-macroexpand-for-load): Back out.
* lisp/emacs-lisp/pcase.el (pcase-compile-patterns): Back out.
(pcase--u1): Back out.
* lisp/help.el (help--make-usage): Back out.
* lisp/keymap.el (define-keymap--compile): Back out.
* lisp/minibuffer.el (read-file-name-completion-ignore-case):
Prefer `when`.
* src/Makefile.in (all): Add cldefs.el target.
(../native-lisp): Add cldefs.el target.
($(lispsource)/emacs-lisp/cldefs.el): Add cldefs.el target.
* src/alloc.c (XPNTR): Back out.
(set_symbol_name): Back out.
(init_symbol): Back out.
(valid_lisp_object_p): Back out.
(purecopy): Back out.
(Fgarbage_collect): Back out.
(mark_char_table): Back out.
(mark_object): Back out.
(survives_gc_p): Back out.
(symbol_uses_obj): Back out.
* src/comp.c (comp_t): Back out.
(helper_link_table): Back out.
(emit_BASE_EQ): Back out.
(emit_EQ): Back out.
(emit_AND): Back out.
(emit_OR): Back out.
(emit_BARE_SYMBOL_P): Back out.
(emit_SYMBOL_WITH_POS_P): Back out.
(emit_SYMBOL_WITH_POS_SYM): Back out.
(emit_NILP): Back out.
(emit_CHECK_SYMBOL_WITH_POS): Back out.
(emit_limple_insn): Back out.
(declare_runtime_imported_funcs): Back out.
(emit_ctxt_code): Back out.
(define_lisp_symbol_with_position): Back out.
(define_GET_SYMBOL_WITH_POSITION): Back out.
(define_SYMBOL_WITH_POS_SYM): Back out.
(Fcomp__init_ctxt): Back out.
(Fcomp__compile_ctxt_to_file): Back out.
(helper_GET_SYMBOL_WITH_POSITION): Back out.
(load_comp_unit): Back out.
(syms_of_comp): Back out.
* src/data.c (Ftype_of): Back out.
(Fbare_symbol_p): Back out.
(Fsymbol_with_pos_p): Back out.
(Fbare_symbol): Back out.
(Fsymbol_with_pos_pos):
(Fremove_pos_from_symbol): Back out.
(Fposition_symbol): Back out.
(syms_of_data): Back out.
* src/fns.c (Fcircular_list_p): Not redundant
with `proper-list-p`.
(internal_equal): Back out.
(hash_lookup): Back out.
(syms_of_fns): Add circular_list_p.
* src/keyboard.c (recursive_edit_1): Back out.
* src/lisp.h (lisp_h_PSEUDOVECTORP): Back out.
(lisp_h_BASE_EQ): Back out.
(lisp_h_EQ): Back out.
(lisp_h_NILP): Back out.
(lisp_h_SYMBOL_WITH_POS_P): Back out.
(lisp_h_SYMBOLP): Back out.
(BARE_SYMBOL_P): Back out.
(BASE_EQ): Back out.
(EQ): Back out.
(SYMBOLP): Back out.
(GCALIGNED_STRUCT): Back out.
(DEFINE_GDB_SYMBOL_BEGIN): Back out.
* src/lread.c (ANNOTATE): Cons charpos with atom.
(readchar): Zero-indexed offset to one-indexed charpos.
(unreadchar): Zero-indexed offset to one-indexed charpos.
(read_filtered_event): Whitespace.
(load_warn_unescaped_character_literals): De-obfuscate.
(Fload): Whitespace.
(maybe_swap_for_eln): Whitespace.
(openp): Whitespace.
(build_load_history): Whitespace.
(readevalloop): Whitespace.
(Feval_buffer): Whitespace.
(Feval_region): Whitespace.
(Fread_annotated): Cons charpos with atom.
(Fread_positioning_symbols): Back out.
(read_internal_start): Cons charpos with atom.
(read0): Cons charpos with atom.
(read1): Cons charpos with atom.
(substitute_object_recurse): Whitespace.
(read_vector): Cons charpos with atom.
(read_list): Cons charpos with atom.
(load_path_check): Whitespace.
(load_path_default): Whitespace.
(syms_of_lread): Cons charpos with atom.
* src/print.c (print_vectorlike): Back out.
(print_object): Back out.
(syms_of_print): Back out.
* test/Makefile.in (%.elc): Recompile the world
if bytecomp.el changes.
* test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-tests--warnings):
Use constants.
(bytecomp--with-warning-test): Use constants.
(bytecomp--buffer-with-warning-test): Test warning line numbers.
(bytecomp-warn-absent-require-cl-lib): Test Bug#30635.
(bytecomp-warn-coordinates): Test warning line numbers.
(bytecomp-warn-present-require-cl-lib): Test Bug#30635.
(bytecomp-read-annotated-equivalence): Test `read-annotated`.
(bytecomp--define-warning-file-test): Use constants.
(bytecomp-tests--test-no-warnings-with-advice): Use constants.
(bytecomp-test-featurep-warnings): Use constants.
(test-suppression): Use constants.
* test/lisp/emacs-lisp/gv-tests.el (gv-tests--in-temp-dir):
Deal with Bug#30635.
(gv-define-expander-out-of-file): Whitespace.
---
.gitignore | 1 +
doc/lispref/elisp.texi | 1 -
doc/lispref/streams.texi | 9 -
doc/lispref/symbols.texi | 69 +-
lisp/Makefile.in | 36 +-
lisp/cedet/semantic/fw.el | 32 +-
lisp/emacs-lisp/bindat.el | 1 -
lisp/emacs-lisp/byte-opt.el | 58 +-
lisp/emacs-lisp/byte-run.el | 108 +-
lisp/emacs-lisp/bytecomp.el | 1799 +++++++++++-------------
lisp/emacs-lisp/cconv.el | 39 +-
lisp/emacs-lisp/cl-generic.el | 6 +-
lisp/emacs-lisp/cl-macs.el | 14 +-
lisp/emacs-lisp/cldefs.el.in | 17 +
lisp/emacs-lisp/comp.el | 15 +-
lisp/emacs-lisp/easy-mmode.el | 1 -
lisp/emacs-lisp/eieio-core.el | 5 -
lisp/emacs-lisp/eieio.el | 4 +-
lisp/emacs-lisp/gv.el | 5 +-
lisp/emacs-lisp/macroexp.el | 327 ++---
lisp/emacs-lisp/multisession.el | 2 +-
lisp/emacs-lisp/pcase.el | 2 -
lisp/help.el | 2 +-
lisp/keymap.el | 11 +-
lisp/minibuffer.el | 4 +-
lisp/sqlite-mode.el | 2 +-
src/Makefile.in | 9 +-
src/alloc.c | 40 +-
src/comp.c | 293 +---
src/data.c | 105 +-
src/fns.c | 28 +-
src/keyboard.c | 2 -
src/lisp.h | 218 +--
src/lread.c | 483 +++----
src/pdumper.c | 4 +-
src/print.c | 33 +-
src/sqlite.c | 2 +-
test/Makefile.in | 4 +-
test/lisp/emacs-lisp/bytecomp-tests.el | 147 +-
test/lisp/emacs-lisp/gv-tests.el | 5 +-
40 files changed, 1560 insertions(+), 2383 deletions(-)
create mode 100644 lisp/emacs-lisp/cldefs.el.in
diff --git a/.gitignore b/.gitignore
index 16f449a446e..2f20ccf0dcd 100644
--- a/.gitignore
+++ b/.gitignore
@@ -82,6 +82,7 @@ src/verbose.mk
# Lisp-level sources built by 'make'.
*cus-load.el
*loaddefs.el
+*cldefs.el
lisp/cedet/semantic/bovine/c-by.el
lisp/cedet/semantic/bovine/make-by.el
lisp/cedet/semantic/bovine/scm-by.el
diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi
index 426bb6d0176..4d75bc116a9 100644
--- a/doc/lispref/elisp.texi
+++ b/doc/lispref/elisp.texi
@@ -450,7 +450,6 @@ Top
for recording miscellaneous information.
* Shorthands:: Properly organize your symbol names but
type less of them.
-* Symbols with Position:: Symbol variants containing integer positions
Symbol Properties
diff --git a/doc/lispref/streams.texi b/doc/lispref/streams.texi
index 8f8562cadc8..bf728ea3e93 100644
--- a/doc/lispref/streams.texi
+++ b/doc/lispref/streams.texi
@@ -327,15 +327,6 @@ Input Functions
@end example
@end defun
-@defun read-positioning-symbols &optional stream
-This function reads one textual expression from @var{stream}, like
-@code{read} does, but additionally positions the read symbols to the
-positions in @var{stream} where they occurred. Only the symbol
-@code{nil} is not positioned, this for efficiency reasons.
-@xref{Symbols with Position}. This function is used by the byte
-compiler.
-@end defun
-
@defvar standard-input
This variable holds the default input stream---the stream that
@code{read} uses when the @var{stream} argument is @code{nil}.
diff --git a/doc/lispref/symbols.texi b/doc/lispref/symbols.texi
index 9e44348b671..18968c1d8b5 100644
--- a/doc/lispref/symbols.texi
+++ b/doc/lispref/symbols.texi
@@ -31,7 +31,7 @@ Symbols
for recording miscellaneous information.
* Shorthands:: Properly organize your symbol names but
type less of them.
-* Symbols with Position:: Symbol variants containing integer positions
+
@end menu
@node Symbol Components
@@ -751,70 +751,3 @@ Shorthands
@item
Symbol forms whose names start with @samp{#_} are not transformed.
@end itemize
-
-@node Symbols with Position
-@section Symbols with Position
-@cindex symbol with position
-
-@cindex bare symbol
-A @dfn{symbol with position} is a symbol, the @dfn{bare symbol},
-together with an unsigned integer called the @dfn{position}. These
-objects are intended for use by the byte compiler, which records in
-them the position of each symbol occurrence and uses those positions
-in warning and error messages.
-
-The printed representation of a symbol with position uses the hash
-notation outlined in @ref{Printed Representation}. It looks like
-@samp{#<symbol foo at 12345>}. It has no read syntax. You can cause
-just the bare symbol to be printed by binding the variable
-@code{print-symbols-bare} to non-@code{nil} around the print
-operation. The byte compiler does this before writing its output to
-the compiled Lisp file.
-
-For most purposes, when the flag variable
-@code{symbols-with-pos-enabled} is non-@code{nil}, symbols with
-positions behave just as bare symbols do. For example, @samp{(eq
-#<symbol foo at 12345> foo)} has a value @code{t} when that variable
-is set (but nil when it isn't set). Most of the time in Emacs this
-variable is @code{nil}, but the byte compiler binds it to @code{t}
-when it runs.
-
-Typically, symbols with position are created by the byte compiler
-calling the reader function @code{read-positioning-symbols}
-(@pxref{Input Functions}). One can also be created with the function
-@code{position-symbol}.
-
-@defvar symbols-with-pos-enabled
-When this variable is non-@code{nil}, symbols with position behave
-like the contained bare symbol. Emacs runs a little more slowly in
-this case.
-@end defvar
-
-@defvar print-symbols-bare
-When bound to non-nil, the Lisp printer prints only the bare symbol of
-a symbol with position, ignoring the position.
-@end defvar
-
-@defun symbol-with-pos-p symbol.
-This function returns @code{t} if @var{symbol} is a symbol with
-position, @code{nil} otherwise.
-@end defun
-
-@defun bare-symbol symbol
-This function returns the bare symbol contained in @var{symbol}, or
-@var{symbol} itself if it is already a bare symbol. For any other
-type of object, it signals an error.
-@end defun
-
-@defun symbol-with-pos-pos symbol
-This function returns the position, a number, from a symbol with
-position. For any other type of object, it signals an error.
-@end defun
-
-@defun position-symbol sym pos
-Make a new symbol with position. @var{sym} is either a bare symbol or
-a symbol with position, and supplies the symbol part of the new
-object. @var{pos} is either an integer which becomes the number part
-of the new object, or a symbol with position whose position is used.
-Emacs signals an error if either argument is invalid.
-@end defun
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index 308407a8bf1..658108c2848 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -72,7 +72,7 @@ LOADDEFS =
loaddefs = $(shell find ${srcdir} -name '*loaddefs.el' ! -name '.*')
# Elisp files auto-generated.
AUTOGENEL = ${loaddefs} ${srcdir}/cus-load.el ${srcdir}/finder-inf.el \
- ${srcdir}/subdirs.el ${srcdir}/eshell/esh-groups.el
+ ${srcdir}/subdirs.el ${srcdir}/eshell/esh-groups.el
${srcdir}/emacs-lisp/cldefs.el
# Set load-prefer-newer for the benefit of the non-bootstrappers.
BYTE_COMPILE_FLAGS = \
@@ -198,6 +198,26 @@ $(lisp)/loaddefs.el:
--eval '(setq generated-autoload-file (expand-file-name
(unmsys--file-name "$@")))' \
-f batch-update-autoloads ${SUBDIRS_ALMOST}
+cldefs .PHONY: $(lisp)/emacs-lisp/cldefs.el
+$(lisp)/emacs-lisp/cldefs.el: $(lisp)/emacs-lisp/cldefs.el.in
+ $(AM_V_GEN)$(emacs) -l pp -l "cldefs.el.in" \
+ --eval "(with-temp-file (expand-file-name (unmsys--file-name
\"$@\")) \
+ (insert \";; Automatically generated from cldefs.el.in.
\" \
+ \"DO NOT EDIT.\n\" \
+ \"(defconst cldefs-cl-lib-functions\n\" \
+ \"(quote \" \
+ (pp-to-string cldefs--cl-lib-functions) \
+ \"))\n\" \
+ \"(provide (quote cldefs))\n\" \
+ \";; Local Variables:\n\" \
+ \";; version-control: never\n\" \
+ \";; no-byte-compile: t\n\" \
+ \";; no-update-autoloads: t\n\" \
+ \";; coding: utf-8-emacs-unix\n\" \
+ \";; End:\n\" \
+ \";;; cldefs.el ends here\n\" \
+ ))"
+
# autoloads only runs when loaddefs.el is nonexistent, although it
# generates a number of different files. Provide a force option to enable
# regeneration of all these files.
@@ -241,7 +261,7 @@ FORCE:
.PHONY: FORCE
tagsfiles = $(shell find ${srcdir} -name '*.el' \
- ! -name '.*' ! -name '*loaddefs.el')
+ ! -name '.*' ! -name '*loaddefs.el' ! -name '*cldefs.el')
tagsfiles := $(filter-out ${srcdir}/ldefs-boot.el,${tagsfiles})
tagsfiles := $(filter-out ${srcdir}/eshell/esh-groups.el,${tagsfiles})
@@ -300,10 +320,6 @@ $(THEFILE)n:
# subdirectories, to make sure require's and load's in the files being
# compiled find the right files.
-.SUFFIXES: .elc .el
-
-# An old-fashioned suffix rule, which, according to the GNU Make manual,
-# cannot have prerequisites.
ifeq ($(HAVE_NATIVE_COMP),yes)
ifeq ($(ANCIENT),yes)
# The first compilation of compile-first, using an interpreted compiler:
@@ -313,17 +329,17 @@ .SUFFIXES:
# using these .elc's. This is faster than just compiling the native code
# directly using the interpreted compile-first files. (Note: 1970-01-01
# fails on some systems.)
-.el.elc:
+%.elc: %.el $(COMPILE_FIRST:.elc=.el) $(top_srcdir)/src/lread.c
$(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \
-l comp -f batch-byte-compile $<
touch -t 197101010000 $@
else
-.el.elc:
+%.elc: %.el $(COMPILE_FIRST:.elc=.el) $(top_srcdir)/src/lread.c
$(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \
-l comp -f batch-byte+native-compile $<
endif
else
-.el.elc:
+%.elc: %.el $(COMPILE_FIRST:.elc=.el) $(top_srcdir)/src/lread.c
$(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $<
endif
@@ -512,7 +528,7 @@ bootstrap-clean:
rm -f $(AUTOGENEL)
distclean:
- -rm -f ./Makefile $(lisp)/loaddefs.el
+ -rm -f ./Makefile $(lisp)/loaddefs.el $(lisp)/emacs-lisp/cldefs.el
maintainer-clean: distclean bootstrap-clean
rm -f TAGS
diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el
index b7c3461a4d7..fd61751cb50 100644
--- a/lisp/cedet/semantic/fw.el
+++ b/lisp/cedet/semantic/fw.el
@@ -191,20 +191,12 @@ semantic-alias-obsolete
(not (string-match "cedet" (macroexp-file-name)))
)
(make-obsolete-overload oldfnalias newfn when)
- (if (fboundp 'byte-compile-warn-x)
- (byte-compile-warn-x
- newfn
- "%s: `%s' obsoletes overload `%s'"
- (macroexp-file-name)
- newfn
- (with-suppressed-warnings ((obsolete
semantic-overload-symbol-from-function))
- (semantic-overload-symbol-from-function oldfnalias)))
- (byte-compile-warn
- "%s: `%s' obsoletes overload `%s'"
- (macroexp-file-name)
- newfn
- (with-suppressed-warnings ((obsolete
semantic-overload-symbol-from-function))
- (semantic-overload-symbol-from-function oldfnalias))))))
+ (byte-compile-warn
+ "%s: `%s' obsoletes overload `%s'"
+ (macroexp-file-name)
+ newfn
+ (with-suppressed-warnings ((obsolete
semantic-overload-symbol-from-function))
+ (semantic-overload-symbol-from-function oldfnalias)))))
(defun semantic-varalias-obsolete (oldvaralias newvar when)
"Make OLDVARALIAS an alias for variable NEWVAR.
@@ -217,14 +209,10 @@ semantic-varalias-obsolete
(error
;; Only throw this warning when byte compiling things.
(when (macroexp-compiling-p)
- (if (fboundp 'byte-compile-warn-x)
- (byte-compile-warn-x
- newvar
- "variable `%s' obsoletes, but isn't alias of `%s'"
- newvar oldvaralias)
- (byte-compile-warn
- "variable `%s' obsoletes, but isn't alias of `%s'"
- newvar oldvaralias))))))
+ (byte-compile-warn
+ "variable `%s' obsoletes, but isn't alias of `%s'"
+ newvar oldvaralias)
+ ))))
;;; Help debugging
;;
diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el
index 04c5b9f0808..c6d64975eca 100644
--- a/lisp/emacs-lisp/bindat.el
+++ b/lisp/emacs-lisp/bindat.el
@@ -804,7 +804,6 @@ bindat--type
(if (or (eq label '_) (not (assq label labels)))
code
(macroexp-warn-and-return
- code
(format "Duplicate label: %S" label)
code))))
(`(,_ ,val)
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 25898285faa..3a5c5b41c80 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -150,29 +150,26 @@ byte-compile-inline-expand
(cdr (assq name byte-compile-function-environment)))))
(pcase fn
('nil
- (byte-compile-warn-x name
- "attempt to inline `%s' before it was defined"
- name)
+ (byte-compile-warn "attempt to inline `%s' before it was defined"
+ name)
form)
(`(autoload . ,_)
(error "File `%s' didn't define `%s'" (nth 1 fn) name))
((and (pred symbolp) (guard (not (eq fn t)))) ;A function alias.
(byte-compile-inline-expand (cons fn (cdr form))))
((pred byte-code-function-p)
- ;; (message "Inlining byte-code for %S!" name)
- ;; The byte-code will be really inlined in byte-compile-unfold-bcf.
(byte-compile--check-arity-bytecode form fn)
`(,fn ,@(cdr form)))
((or `(lambda . ,_) `(closure . ,_))
- ;; While byte-compile-unfold-bcf can inline dynbind byte-code into
- ;; letbind byte-code (or any other combination for that matter), we
- ;; can only inline dynbind source into dynbind source or letbind
- ;; source into letbind source.
- ;; When the function comes from another file, we byte-compile
- ;; the inlined function first, and then inline its byte-code.
- ;; This also has the advantage that the final code does not
- ;; depend on the order of compilation of ELisp files, making
- ;; the build more reproducible.
+ ;; While byte-compile-unfold-byte-code-function can inline
+ ;; dynbind byte-code into letbind byte-code (or any other
+ ;; combination for that matter), we can only inline dynbind
+ ;; source into dynbind source or letbind source into letbind
+ ;; source. When the function comes from another file, we
+ ;; byte-compile the inlined function first, and then inline its
+ ;; byte-code. This also has the advantage that the final code
+ ;; does not depend on the order of compilation of ELisp files,
+ ;; making the build more reproducible.
(if (eq fn localfn)
;; From the same file => same mode.
(macroexp--unfold-lambda `(,fn ,@(cdr form)))
@@ -308,8 +305,8 @@ byte-optimize-form-code-walker
(t form)))
(`(quote . ,v)
(if (or (not v) (cdr v))
- (byte-compile-warn-x form "malformed quote form: `%s'"
- form))
+ (byte-compile-warn "malformed quote form: `%s'"
+ (prin1-to-string form)))
;; Map (quote nil) to nil to simplify optimizer logic.
;; Map quoted constants to nil if for-effect (just because).
(and (car v)
@@ -327,9 +324,8 @@ byte-optimize-form-code-walker
(cons
(byte-optimize-form (car clause) nil)
(byte-optimize-body (cdr clause) for-effect))
- (byte-compile-warn-x
- clause "malformed cond form: `%s'"
- clause)
+ (byte-compile-warn "malformed cond form: `%s'"
+ (prin1-to-string clause))
clause))
clauses)))
(`(progn . ,exps)
@@ -405,7 +401,8 @@ byte-optimize-form-code-walker
`(while ,condition . ,body)))
(`(interactive . ,_)
- (byte-compile-warn-x form "misplaced interactive spec: `%s'" form)
+ (byte-compile-warn "misplaced interactive spec: `%s'"
+ (prin1-to-string form))
nil)
(`(function . ,_)
@@ -473,7 +470,7 @@ byte-optimize-form-code-walker
(while args
(unless (and (consp args)
(symbolp (car args)) (consp (cdr args)))
- (byte-compile-warn-x form "malformed setq form: %S" form))
+ (byte-compile-warn "malformed setq form: %S" form))
(let* ((var (car args))
(expr (cadr args))
(lexvar (assq var byte-optimize--lexvars))
@@ -506,7 +503,8 @@ byte-optimize-form-code-walker
(cons fn (mapcar #'byte-optimize-form exps)))
(`(,(pred (not symbolp)) . ,_)
- (byte-compile-warn-x fn "`%s' is a malformed function" fn)
+ (byte-compile-warn "`%s' is a malformed function"
+ (prin1-to-string fn))
form)
((guard (when for-effect
@@ -514,10 +512,8 @@ byte-optimize-form-code-walker
(or byte-compile-delete-errors
(eq tmp 'error-free)
(progn
- (byte-compile-warn-x
- form
- "value returned from %s is unused"
- form)
+ (byte-compile-warn "value returned from %s is unused"
+ (prin1-to-string form))
nil)))))
(byte-compile-log " %s called for effect; deleted" fn)
;; appending a nil here might not be necessary, but it can't hurt.
@@ -713,8 +709,7 @@ byte-optimize-let-form
(if (symbolp binding)
binding
(when (or (atom binding) (cddr binding))
- (byte-compile-warn-x
- binding "malformed let binding: `%S'" binding))
+ (byte-compile-warn "malformed let binding: `%S'" binding))
(list (car binding)
(byte-optimize-form (nth 1 binding) nil))))
(car form))
@@ -1197,7 +1192,7 @@ byte-optimize-if
(defun byte-optimize-while (form)
(when (< (length form) 2)
- (byte-compile-warn-x form "too few arguments for `while'"))
+ (byte-compile-warn "too few arguments for `while'"))
(if (nth 1 form)
form))
@@ -1235,10 +1230,9 @@ byte-optimize-apply
(let ((butlast (nreverse (cdr (reverse (cdr (cdr form)))))))
(nconc (list 'funcall fn) butlast
(mapcar (lambda (x) (list 'quote x)) (nth 1 last))))
- (byte-compile-warn-x
- last
+ (byte-compile-warn
"last arg to apply can't be a literal atom: `%s'"
- last)
+ (prin1-to-string last))
nil))
form))))
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 110f7e4abf4..e1fc5513091 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -30,83 +30,6 @@
;;; Code:
-(defvar byte-run--ssp-seen nil
- "Which conses/vectors/records have been processed in strip-symbol-positions?
-The value is a hash table, the key being the old element and the value being
-the corresponding new element of the same type.
-
-The purpose of this is to detect circular structures.")
-
-(defalias 'byte-run--circular-list-p
- #'(lambda (l)
- "Return non-nil when the list L is a circular list.
-Note that this algorithm doesn't check any circularity in the
-CARs of list elements."
- (let ((hare l)
- (tortoise l))
- (condition-case err
- (progn
- (while (progn
- (setq hare (cdr (cdr hare))
- tortoise (cdr tortoise))
- (not (or (eq tortoise hare)
- (null hare)))))
- (eq tortoise hare))
- (wrong-type-argument nil)
- (error (signal (car err) (cdr err)))))))
-
-(defalias 'byte-run--strip-s-p-1
- #'(lambda (arg)
- "Strip all positions from symbols in ARG, modifying ARG.
-Return the modified ARG."
- (cond
- ((symbol-with-pos-p arg)
- (bare-symbol arg))
-
- ((consp arg)
- (let* ((round (byte-run--circular-list-p arg))
- (hash (and round (gethash arg byte-run--ssp-seen))))
- (or hash
- (let ((a arg) new)
- (while
- (progn
- (when round
- (puthash a new byte-run--ssp-seen))
- (setq new (byte-run--strip-s-p-1 (car a)))
- (when (not (eq new (car a))) ; For read-only things.
- (setcar a new))
- (and (consp (cdr a))
- (not
- (setq hash
- (and round
- (gethash (cdr a)
byte-run--ssp-seen))))))
- (setq a (cdr a)))
- (setq new (byte-run--strip-s-p-1 (cdr a)))
- (when (not (eq new (cdr a)))
- (setcdr a (or hash new)))
- arg))))
-
- ((or (vectorp arg) (recordp arg))
- (let ((hash (gethash arg byte-run--ssp-seen)))
- (or hash
- (let* ((len (length arg))
- (i 0)
- new)
- (puthash arg arg byte-run--ssp-seen)
- (while (< i len)
- (setq new (byte-run--strip-s-p-1 (aref arg i)))
- (when (not (eq new (aref arg i)))
- (aset arg i new))
- (setq i (1+ i)))
- arg))))
-
- (t arg))))
-
-(defalias 'byte-run-strip-symbol-positions
- #'(lambda (arg)
- (setq byte-run--ssp-seen (make-hash-table :test 'eq))
- (byte-run--strip-s-p-1 arg)))
-
(defalias 'function-put
;; We don't want people to just use `put' because we can't conveniently
;; hook into `put' to remap old properties to new ones. But for now, there's
@@ -115,9 +38,7 @@ 'function-put
"Set FUNCTION's property PROP to VALUE.
The namespace for PROP is shared with symbols.
So far, FUNCTION can only be a symbol, not a lambda expression."
- (put (bare-symbol function)
- (byte-run-strip-symbol-positions prop)
- (byte-run-strip-symbol-positions value))))
+ (put function prop value)))
(function-put 'defmacro 'doc-string-elt 3)
(function-put 'defmacro 'lisp-indent-function 2)
@@ -334,7 +255,6 @@ 'defmacro
(let ((f (cdr (assq (car x) macro-declarations-alist))))
(if f (apply (car f) name arglist (cdr x))
(macroexp-warn-and-return
- (car x)
(format-message
"Unknown macro property %S in %S"
(car x) name)
@@ -408,7 +328,6 @@ defun
nil)
(t
(macroexp-warn-and-return
- (car x)
(format-message "Unknown defun property `%S' in %S"
(car x) name)
nil)))))
@@ -422,7 +341,7 @@ defun
(cons 'prog1 (cons def declarations))
def))))
-
+
;; Redefined in byte-opt.el.
;; This was undocumented and unused for decades.
(defalias 'inline 'progn
@@ -470,8 +389,8 @@ defsubst
(defun ,name ,arglist ,@body)
(eval-and-compile
;; Never native-compile defsubsts as we need the byte
- ;; definition in `byte-compile-unfold-bcf' to perform the
- ;; inlining (Bug#42664, Bug#43280, Bug#44209).
+ ;; definition in `byte-compile-unfold-byte-code-function' 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))))
@@ -595,7 +514,7 @@ dont-compile
(declare (debug t) (indent 0) (obsolete nil "24.4"))
(list 'eval (list 'quote (if (cdr body) (cons 'progn body) (car body)))))
-
+
;; interface to evaluating things at compile time and/or load time
;; these macro must come after any uses of them in this file, as their
;; definition in the file overrides the magic definitions on the
@@ -670,20 +589,20 @@ with-suppressed-warnings
(append warnings byte-compile--suppressed-warnings)))
(macroexpand-all (macroexp-progn body)
macroexpand-all-environment))))
-
+
(defun byte-run--unescaped-character-literals-warning ()
"Return a warning about unescaped character literals.
If there were any unescaped character literals in the last form
read, return an appropriate warning message as a string.
Otherwise, return nil. For internal use only."
;; This is called from lread.c and therefore needs to be preloaded.
- (if lread--unescaped-character-literals
- (let ((sorted (sort lread--unescaped-character-literals #'<)))
- (format-message "unescaped character literals %s detected, %s
expected!"
- (mapconcat (lambda (char) (format "`?%c'" char))
- sorted ", ")
- (mapconcat (lambda (char) (format "`?\\%c'" char))
- sorted ", ")))))
+ (let ((sorted (sort lread--unescaped-character-literals #'<)))
+ (when sorted
+ (format-message "unescaped character literals %s detected, %s expected!"
+ (mapconcat (lambda (char) (format "`?%c'" char))
+ sorted ", ")
+ (mapconcat (lambda (char) (format "`?\\%c'" char))
+ sorted ", ")))))
(defun byte-compile-info (string &optional message type)
"Format STRING in a way that looks pleasing in the compilation output.
@@ -706,7 +625,6 @@ byte-compile-info-message
(declare (obsolete byte-compile-info "28.1"))
(byte-compile-info (apply #'format args) t))
-
;; I nuked this because it's not a good idea for users to think of using it.
;; These options are a matter of installation preference, and have nothing to
;; with particular source files; it's a mistake to suggest to users
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index ff372151e1b..6252786662b 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -121,14 +121,20 @@
;; o byte-compiled files now start with the string `;ELC'.
;; Some versions of `file' can be customized to recognize that.
+(eval-when-compile (require 'compile))
+(eval-when-compile (require 'cl-lib))
+(require 'cldefs nil t) ;; bootstrap-emacs won't have it in time
(require 'backquote)
(require 'macroexp)
(require 'cconv)
-(eval-when-compile (require 'compile))
-;; Refrain from using cl-lib at run-time here, since it otherwise prevents
-;; us from emitting warnings when compiling files which use cl-lib without
-;; requiring it! (bug#30635)
-(eval-when-compile (require 'cl-lib))
+
+(autoload 'cl-every "cl-extra")
+(autoload 'cl-tailp "cl-extra")
+(autoload 'cl-loop "cl-macs")
+(autoload 'cl-some "cl-extra")
+(autoload 'cl-destructuring-bind "cl-macs")
+(autoload 'cl-find-if "cl-seq")
+(autoload 'cl-labels "cl-macs")
;; The feature of compiling in a specific target Emacs version
;; has been turned off because compile time options are a bad idea.
@@ -154,15 +160,15 @@ byte-compile-dest-file-function
:type '(choice (const nil) function)
:version "23.2")
-;; This enables file name handlers such as jka-compr
-;; to remove parts of the file name that should not be copied
-;; through to the output file name.
(defun byte-compiler-base-file-name (filename)
- (let ((handler (find-file-name-handler filename
- 'byte-compiler-base-file-name)))
- (if handler
- (funcall handler 'byte-compiler-base-file-name filename)
- filename)))
+ "This enables file name handlers such as jka-compr
+to remove parts of the file name that should not be copied
+through to the output file name."
+ (if-let ((handler (find-file-name-handler
+ filename
+ 'byte-compiler-base-file-name)))
+ (funcall handler 'byte-compiler-base-file-name filename)
+ filename))
;; Sadly automake relies on this misfeature up to at least version 1.15.1.
(if (fboundp 'byte-compile-dest-file)
@@ -460,61 +466,46 @@ byte-compile-free-assignments
(defvar byte-compiler-error-flag)
-(defun byte-compile-recurse-toplevel (form non-toplevel-case)
- "Implement `eval-when-compile' and `eval-and-compile'.
-Return the compile-time value of FORM."
- ;; Macroexpand (not macroexpand-all!) form at toplevel in case it
- ;; expands into a toplevel-equivalent `progn'. See CLHS section
- ;; 3.2.3.1, "Processing of Top Level Forms". The semantics are very
- ;; subtle: see test/lisp/emacs-lisp/bytecomp-tests.el for interesting
- ;; cases.
- (let ((print-symbols-bare t)) ; Possibly redundant binding.
- (setf form (macroexp-macroexpand form byte-compile-macro-environment)))
- (if (eq (car-safe form) 'progn)
- (cons 'progn
- (mapcar (lambda (subform)
- (byte-compile-recurse-toplevel
- subform non-toplevel-case))
- (cdr form)))
- (funcall non-toplevel-case form)))
+(defun byte-compile-maybe-expand (form func)
+ "Macroexpansion of top-level FORM could yield a progn.
+See CLHS section 3.2.3.1, *Processing of Top Level Forms*, and
+bytecomp-tests.el for interesting cases."
+ (let ((form* (macroexp-macroexpand form byte-compile-macro-environment)))
+ (if (eq (car-safe form*) 'progn)
+ (cons 'progn
+ (mapcar (lambda (sexpr)
+ (byte-compile-maybe-expand sexpr func))
+ (cdr form*)))
+ (funcall func form*))))
(defconst byte-compile-initial-macro-environment
- `(
- ;; (byte-compiler-options . (lambda (&rest forms)
- ;; (apply 'byte-compiler-options-handler forms)))
- (declare-function . byte-compile-macroexpand-declare-function)
+ `((declare-function . byte-compile-macroexpand-declare-function)
(eval-when-compile . ,(lambda (&rest body)
- (let ((result nil))
- (byte-compile-recurse-toplevel
+ (let (result)
+ (byte-compile-maybe-expand
(macroexp-progn body)
(lambda (form)
- ;; Insulate the following variables
- ;; against changes made in the
- ;; subsidiary compilation. This
- ;; prevents spurious warning
- ;; messages: "not defined at runtime"
- ;; etc.
+ ;; Sandbox these defvars to forestall "not
+ ;; defined at runtime" errors
(let ((byte-compile-unresolved-functions
byte-compile-unresolved-functions)
(byte-compile-new-defuns
byte-compile-new-defuns))
(setf result
(byte-compile-eval
- (byte-compile-top-level
- (byte-compile-preprocess
form)))))))
+ (byte-compile-top-level
+ (byte-compile-preprocess form)))))))
(list 'quote result))))
(eval-and-compile . ,(lambda (&rest body)
- (byte-compile-recurse-toplevel
+ (byte-compile-maybe-expand
(macroexp-progn body)
(lambda (form)
- ;; Don't compile here, since we don't know
- ;; whether to compile as byte-compile-form
- ;; or byte-compile-file-form.
- (let* ((print-symbols-bare t) ; Possibly
redundant binding.
- (expanded
- (macroexpand--all-toplevel
- form
- macroexpand-all-environment)))
+ ;; Don't compile since we don't know
+ ;; byte-compile-form or byte-compile-file-form.
+ (let ((expanded
+ (macroexpand--all-top-level
+ form
+ macroexpand-all-environment)))
(eval expanded lexical-binding)
expanded)))))
(with-suppressed-warnings
@@ -592,7 +583,7 @@ byte-compile-maxdepth
;; - `byte-compile-lambda' to obtain arglist doc and interactive spec
;; af any lambda compiled (including anonymous).
;;
-;; - `byte-compile-file-form-defmumble' to obtain the list of
+;; - `byte-compile-file-form-defalias*' to obtain the list of
;; top-level forms as they would be outputted in the .elc file.
;;
@@ -622,7 +613,7 @@ byte-to-native-output-buffer-file
(defvar byte-to-native-plist-environment nil
"To spill `overriding-plist-environment'.")
-
+
;;; The byte codes; this information is duplicated in bytecomp.c
(defvar byte-code-vector nil
@@ -649,7 +640,7 @@ byte-defop
(aset v2 opcode stack-adjust))
(if docstring
(list 'defconst opname opcode (concat "Byte code opcode " docstring "."))
- (list 'defconst opname opcode)))
+ (list 'defconst opname opcode)))
(defmacro byte-extrude-byte-code-vectors ()
(prog1 (list 'setq 'byte-code-vector
@@ -861,7 +852,7 @@ byte-goto-ops
(defconst byte-goto-always-pop-ops '(byte-goto-if-nil byte-goto-if-not-nil))
(byte-extrude-byte-code-vectors)
-
+
;;; lapcode generator
;;
;; the byte-compiler now does source -> lapcode -> bytecode instead of
@@ -1021,7 +1012,7 @@ byte-compile-lapcode
byte-to-native-lambdas-h))
bytecode)))
-
+
;;; compile-time evaluation
(defun byte-compile-eval (form)
@@ -1053,13 +1044,10 @@ byte-compile-eval-before-compile
"Evaluate FORM for `eval-and-compile'."
(let ((hist-nil-orig current-load-list))
(prog1 (eval form lexical-binding)
- ;; (eval-and-compile (require 'cl) turns off warnings for cl functions.
- ;; FIXME Why does it do that - just as a hack?
- ;; There are other ways to do this nowadays.
(let ((tem current-load-list))
(while (not (eq tem hist-nil-orig))
(setq tem (cdr tem)))))))
-
+
;;; byte compiler messages
(defun emacs-lisp-compilation-file-name-or-buffer (str)
@@ -1106,11 +1094,16 @@ emacs-lisp-compilation-recompile
(error "Only files can be recompiled"))
(byte-compile-file emacs-lisp-compilation--current-file))
-(defvar byte-compile-current-form nil)
+;; Single thread makes global variables possible.
+;; Global variables make programming easy.
+(defvar byte-compile-current-func nil)
(defvar byte-compile-dest-file nil)
(defvar byte-compile-current-file nil)
(defvar byte-compile-current-group nil)
(defvar byte-compile-current-buffer nil)
+(defvar byte-compile-current-annotations nil)
+(defvar byte-compile-current-form nil)
+(defvar byte-compile-current-charpos nil)
;; Log something that isn't a warning.
(defmacro byte-compile-log (format-string &rest args)
@@ -1127,8 +1120,8 @@ byte-compile-log
(lambda (x) (if (symbolp x) (list 'prin1-to-string x) x))
args))))))
-;; Log something that isn't a warning.
(defun byte-compile-log-1 (string)
+ "Log something that isn't a warning."
(with-current-buffer byte-compile-log-buffer
(let ((inhibit-read-only t))
(goto-char (point-max))
@@ -1150,55 +1143,16 @@ byte-compile-delete-first
(setcdr list (cddr list)))
total)))
-(defvar byte-compile-last-warned-form nil)
+(defvar byte-compile-last-warned-func nil)
(defvar byte-compile-last-logged-file nil)
(defvar byte-compile-root-dir nil
"Directory relative to which file names in error messages are written.")
-;; FIXME: We should maybe extend abbreviate-file-name with an optional DIR
-;; argument to try and use a relative file-name.
(defun byte-compile-abbreviate-file (file &optional dir)
(let ((f1 (abbreviate-file-name file))
(f2 (file-relative-name file dir)))
(if (< (length f2) (length f1)) f2 f1)))
-(defun byte-compile--first-symbol (form)
- "Return the \"first\" symbol found in form, or 0 if there is none.
-Here, \"first\" is by a depth first search."
- (let (sym)
- (cond
- ((symbolp form) form)
- ((consp form)
- (or (and (symbolp (setq sym (byte-compile--first-symbol (car form))))
- sym)
- (and (symbolp (setq sym (byte-compile--first-symbol (cdr form))))
- sym)
- 0))
- ((and (vectorp form)
- (> (length form) 0))
- (let ((i 0)
- (len (length form))
- elt)
- (catch 'sym
- (while (< i len)
- (when (symbolp
- (setq elt (byte-compile--first-symbol (aref form i))))
- (throw 'sym elt))
- (setq i (1+ i)))
- 0)))
- (t 0))))
-
-(defun byte-compile--warning-source-offset ()
- "Return a source offset from `byte-compile-form-stack'.
-Return nil if such is not found."
- (catch 'offset
- (dolist (form byte-compile-form-stack)
- (let ((s (byte-compile--first-symbol form)))
- (if (symbol-with-pos-p s)
- (throw 'offset (symbol-with-pos-pos s)))))))
-
-;; This is used as warning-prefix for the compiler.
-;; It is always called with the warnings buffer current.
(defun byte-compile-warning-prefix (level entry)
(let* ((inhibit-read-only t)
(dir (or byte-compile-root-dir default-directory))
@@ -1208,36 +1162,36 @@ byte-compile-warning-prefix
((bufferp byte-compile-current-file)
(format "Buffer %s:"
(buffer-name byte-compile-current-file)))
- ;; We might be simply loading a file that
- ;; contains explicit calls to byte-compile functions.
((stringp load-file-name)
+ ;; a file containing explicit calls to compiled functions.
(format "%s:" (byte-compile-abbreviate-file
load-file-name dir)))
(t "")))
- (offset (byte-compile--warning-source-offset))
- (pos (if (and byte-compile-current-file
- (or offset (not symbols-with-pos-enabled)))
- (with-current-buffer byte-compile-current-buffer
- (let (new-l new-c)
- (save-excursion
- (goto-char offset)
- (setq new-l (1+ (count-lines (point-min)
(point-at-bol)))
- new-c (1+ (current-column)))
- (format "%d:%d:" new-l new-c))))
- ""))
- (form (if (eq byte-compile-current-form :end) "end of data"
- (or byte-compile-current-form "toplevel form"))))
+ (annot (if-let ((byte-compile-current-file byte-compile-current-file)
+ (charpos (or byte-compile-current-charpos
+ (byte-compile-fuzzy-charpos))))
+ (with-current-buffer byte-compile-current-buffer
+ (apply #'format "%d:%d:"
+ (save-excursion
+ (goto-char charpos)
+ (list (1+ (count-lines (point-min)
(point-at-bol)))
+ ;; `next-error' uses one-indexed column
+ (1+ (current-column))))))
+ ""))
+ (form (if (eq byte-compile-current-func :end)
+ "end of data"
+ (or byte-compile-current-func "toplevel form"))))
(when (or (and byte-compile-current-file
(not (equal byte-compile-current-file
byte-compile-last-logged-file)))
- (and byte-compile-current-form
- (not (eq byte-compile-current-form
- byte-compile-last-warned-form))))
+ (and byte-compile-current-func
+ (not (eq byte-compile-current-func
+ byte-compile-last-warned-func))))
(insert (format "\nIn %s:\n" form)))
(when level
- (insert (format "%s%s " file pos))))
+ (insert (format "%s%s " file annot))))
(setq byte-compile-last-logged-file byte-compile-current-file
- byte-compile-last-warned-form byte-compile-current-form)
+ byte-compile-last-warned-func byte-compile-current-func)
entry)
;; This no-op function is used as the value of warning-series
@@ -1283,7 +1237,7 @@ byte-compile-log-file
(insert (format-message "Entering directory `%s'\n"
default-directory))))
(setq byte-compile-last-logged-file byte-compile-current-file
- byte-compile-last-warned-form nil)
+ byte-compile-last-warned-func nil)
;; Do this after setting default-directory.
(unless (derived-mode-p 'compilation-mode)
(emacs-lisp-compilation-mode))
@@ -1298,49 +1252,39 @@ byte-compile-log-warning-function
message describing the problem. POSITION is a buffer position
where the problem was detected. FILL is a prefix as in
`warning-fill-prefix'. LEVEL is the level of the
-problem (`:warning' or `:error'). FILL and LEVEL may be nil.")
+problem (`:warning' or `:error'). POSITION, FILL and LEVEL may
+be nil.")
(defun byte-compile-log-warning (string &optional fill level)
"Log a byte-compilation warning.
-STRING, FILL and LEVEL are as described in
-`byte-compile-log-warning-function', which see."
+SYM, STRING, FILL and LEVEL are as described in
+`byte-compile-log-warning-function'."
(funcall byte-compile-log-warning-function
string
- (or (byte-compile--warning-source-offset)
- (point))
+ 'unused
fill
level))
-(defun byte-compile--log-warning-for-byte-compile (string _position
- &optional
- fill
- level)
+(defun byte-compile--log-warning-for-byte-compile
+ (string &optional _position fill level)
"Log a message STRING in `byte-compile-log-buffer'.
Also log the current function and file if not already done. If
FILL is non-nil, set `warning-fill-prefix' to four spaces. LEVEL
is the warning level (`:warning' or `:error'). Do not call this
function directly; use `byte-compile-warn' or
`byte-compile-report-error' instead."
- (let ((warning-prefix-function 'byte-compile-warning-prefix)
- (warning-type-format "")
- (warning-fill-prefix (if fill " ")))
+ (let* ((warning-prefix-function #'byte-compile-warning-prefix)
+ (warning-type-format "")
+ (warning-fill-prefix (when fill " ")))
(display-warning 'bytecomp string level byte-compile-log-buffer)))
(defun byte-compile-warn (format &rest args)
"Issue a byte compiler warning; use (format-message FORMAT ARGS...) for
message."
(setq format (apply #'format-message format args))
(if byte-compile-error-on-warn
- (error "%s" format) ; byte-compile-file catches and logs it
+ (error "%s" format)
(byte-compile-log-warning format t :warning)))
-(defun byte-compile-warn-x (arg format &rest args)
- "Issue a byte compiler warning.
-ARG is the source element (likely a symbol with position) central to
- the warning, intended to supply source position information.
-FORMAT and ARGS are as in `byte-compile-warn'."
- (let ((byte-compile-form-stack (cons arg byte-compile-form-stack)))
- (apply #'byte-compile-warn format args)))
-
(defun byte-compile-warn-obsolete (symbol)
"Warn that SYMBOL (a variable or function) is obsolete."
(when (byte-compile-warning-enabled-p 'obsolete symbol)
@@ -1349,27 +1293,29 @@ byte-compile-warn-obsolete
symbol
(or funcp (get symbol 'byte-obsolete-variable))
(if funcp "function" "variable"))))
- (unless (and funcp (memq symbol byte-compile-not-obsolete-funcs))
- (byte-compile-warn-x symbol "%s" msg)))))
+ (when (or (not funcp)
+ (not (memq symbol byte-compile-not-obsolete-funcs)))
+ (byte-compile-warn "%s" msg)))))
-(defun byte-compile-report-error (error-info &optional fill)
+(defun byte-compile-report-error (err &optional fill)
"Report Lisp error in compilation.
-ERROR-INFO is the error data, in the form of either (ERROR-SYMBOL . DATA)
+ERR is the error data, in the form of either (ERROR-SYMBOL . DATA)
or STRING. If FILL is non-nil, set `warning-fill-prefix' to four spaces
when printing the error message."
(setq byte-compiler-error-flag t)
(byte-compile-log-warning
- (if (stringp error-info) error-info
- (error-message-string error-info))
+ (if (stringp err)
+ err
+ (error-message-string err))
fill :error))
-
+
;;; sanity-checking arglists
(defun byte-compile-fdefinition (name macro-p)
- ;; If a function has an entry saying (FUNCTION . t).
- ;; that means we know it is defined but we don't know how.
- ;; If a function has an entry saying (FUNCTION . nil),
- ;; that means treat it as not defined.
+ "If a function has an entry saying (FUNCTION . t).
+that means we know it is defined but we don't know how.
+If a function has an entry saying (FUNCTION . nil),
+that means treat it as not defined."
(let* ((list (if macro-p
byte-compile-macro-environment
byte-compile-function-environment))
@@ -1452,33 +1398,93 @@ byte-compile-arglist-signature-string
(format "%d" (car signature)))
(t (format "%d-%d" (car signature) (cdr signature)))))
+(defun byte-compile-fuzzy-charpos ()
+ "Hack prevailing globals for prevailing charpos."
+ (let ((memo-count (make-hash-table :test #'equal)))
+ (cl-labels ((recurse-count
+ (form)
+ (with-memoization
+ (gethash form memo-count)
+ (cond ((circular-list-p form) (safe-length form))
+ ((or (atom form)
+ (or (eq 'quote (car form))
+ (eq 'backquote (car form))
+ (eq '\` (car form))
+ (eq 'function (car form))))
+ 1)
+ (t (cl-loop for element in form
+ collect (recurse-count element) into
result
+ finally return (apply #'+ result)))))))
+ (let ((match-count (recurse-count byte-compile-current-form)))
+ (cl-labels ((recurse
+ (form)
+ (cl-loop for element in form
+ for count = (recurse-count
+ (byte-compile--decouple element
#'cdr))
+ if (>= match-count count)
+ collect element
+ else
+ append (recurse element)
+ end))
+ (first-atom
+ (form)
+ (cond ((atom form) form)
+ (t (cl-some #'first-atom form))))
+ (listify
+ (form)
+ (if (atom form)
+ (list form)
+ (unless (circular-list-p form)
+ (cl-loop for element in form
+ collect element)))))
+ (cl-loop with result
+ with best-score = 0
+ with best-milieu = 0
+ with matches =
+ (sort (recurse (list byte-compile-current-annotations))
+ (lambda (x y)
+ (> (safe-length x) (safe-length y))))
+ for match in matches
+ for match* = (byte-compile--decouple match #'cdr)
+ for cand-milieu = (if (atom match*) 1 (safe-length match*))
+ for cand-score =
+ (cl-loop for w in (listify match*)
+ count (member w (listify
byte-compile-current-form)))
+ when (and (>= cand-score best-score)
+ (or (not (= cand-milieu best-milieu))
+ (not (= cand-score best-score))))
+ do (setq result match
+ best-score cand-score
+ best-milieu cand-milieu)
+ finally return (or (first-atom result)
+ (first-atom
byte-compile-current-annotations))))))))
+
(defun byte-compile-function-warn (f nargs def)
+ "Record unresolved F or inconsistent arity NARGS.
+F is considered resolved if auxiliary DEF includes it."
(when (and (get f 'byte-obsolete-info)
(byte-compile-warning-enabled-p 'obsolete f))
(byte-compile-warn-obsolete f))
-
- ;; Check to see if the function will be available at runtime
- ;; and/or remember its arity if it's unknown.
- (or (and (or def (fboundp f)) ; might be a subr or autoload.
- (not (memq f byte-compile-noruntime-functions)))
- (eq f byte-compile-current-form) ; ## This doesn't work
- ; with recursion.
- ;; It's a currently-undefined function.
- ;; Remember number of args in call.
- (let ((cons (assq f byte-compile-unresolved-functions)))
- (if cons
- (or (memq nargs (cddr cons))
- (push nargs (cddr cons)))
- (push (list f
- (if (symbol-with-pos-p f)
- (symbol-with-pos-pos f)
- 1) ; Should never happen.
- nargs)
- byte-compile-unresolved-functions)))))
+ (when (and (or (and (not def) (not (fboundp f)))
+ (and (boundp 'cldefs-cl-lib-functions)
+ (memq f cldefs-cl-lib-functions)
+ ;; consider defining cl-incf as resolving all cl-lib
+ (not (memq 'cl-incf byte-compile-new-defuns)))
+ (memq f byte-compile-noruntime-functions))
+ (not (eq f byte-compile-current-func)))
+ (let ((cell (assq f byte-compile-unresolved-functions)))
+ (if cell
+ (unless (memq nargs (cddr cell))
+ ;; flag an inconsistent arity
+ (push nargs (cddr cell)))
+ (push (list f
+ (let ((byte-compile-current-form f))
+ (byte-compile-fuzzy-charpos))
+ nargs)
+ byte-compile-unresolved-functions)))))
(defun byte-compile-emit-callargs-warn (name actual-args min-args max-args)
- (byte-compile-warn-x
- name
+ (byte-compile-warn
"%s called with %d argument%s, but %s %s"
name actual-args
(if (= 1 actual-args) "" "s")
@@ -1544,21 +1550,21 @@ byte-compile-format-warn
n)))
(nargs (- (length form) 2)))
(unless (= nargs nfields)
- (byte-compile-warn-x (car form)
+ (byte-compile-warn
"`%s' called with %d args to fill %d format field(s)" (car form)
nargs nfields)))))
(dolist (elt '(format message error))
(put elt 'byte-compile-format-like t))
-;; Warn if a custom definition fails to specify :group, or :type.
(defun byte-compile-nogroup-warn (form)
+ "Warn if a custom definition fails to specify :group, or :type."
(let ((keyword-args (cdr (cdr (cdr (cdr form)))))
(name (cadr form)))
(when (eq (car-safe name) 'quote)
(or (not (eq (car form) 'custom-declare-variable))
(plist-get keyword-args :type)
- (byte-compile-warn-x (cadr name)
+ (byte-compile-warn
"defcustom for `%s' fails to specify type" (cadr name)))
(if (and (memq (car form) '(custom-declare-face custom-declare-variable))
byte-compile-current-group)
@@ -1567,7 +1573,7 @@ byte-compile-nogroup-warn
(or (and (eq (car form) 'custom-declare-group)
(equal name ''emacs))
(plist-get keyword-args :group)
- (byte-compile-warn-x (cadr name)
+ (byte-compile-warn
"%s for `%s' fails to specify containing group"
(cdr (assq (car form)
'((custom-declare-group . defgroup)
@@ -1575,35 +1581,33 @@ byte-compile-nogroup-warn
(custom-declare-variable . defcustom))))
(cadr name)))
;; Update the current group, if needed.
- (if (and byte-compile-current-file ;Only when compiling a whole file.
- (eq (car form) 'custom-declare-group))
- (setq byte-compile-current-group (cadr name)))))))
+ (when (and byte-compile-current-file ;Only when compiling a whole file.
+ (eq (car form) 'custom-declare-group))
+ (setq byte-compile-current-group (cadr name)))))))
-;; Warn if the function or macro is being redefined with a different
-;; number of arguments.
(defun byte-compile-arglist-warn (name arglist macrop)
- ;; This is the first definition. See if previous calls are compatible.
+ "Warn if the function or macro is being redefined with a different
+number of arguments."
(let ((calls (assq name byte-compile-unresolved-functions))
nums sig min max)
(when (and calls macrop)
- (byte-compile-warn-x name "macro `%s' defined too late" name))
+ (byte-compile-warn "macro `%s' defined too late" name))
(setq byte-compile-unresolved-functions
(delq calls byte-compile-unresolved-functions))
- (setq calls (delq t calls)) ;Ignore higher-order uses of the function.
+ (setq calls (delq t calls)) ; Ignore higher-order uses of the function.
(when (cddr calls)
(when (and (symbolp name)
(eq (function-get name 'byte-optimizer)
'byte-compile-inline-expand))
- (byte-compile-warn-x name "defsubst `%s' was used before it was
defined"
- name))
+ (byte-compile-warn "defsubst `%s' was used before it was defined"
+ name))
(setq sig (byte-compile-arglist-signature arglist)
nums (sort (copy-sequence (cddr calls)) (function <))
min (car nums)
max (car (nreverse nums)))
(when (or (< min (car sig))
(and (cdr sig) (> max (cdr sig))))
- (byte-compile-warn-x
- name
+ (byte-compile-warn
"%s being defined to take %s%s, but was previously called with %s"
name
(byte-compile-arglist-signature-string sig)
@@ -1613,16 +1617,15 @@ byte-compile-arglist-warn
(initial (and macrop
(cdr (assq name
byte-compile-initial-macro-environment)))))
- ;; Assumes an element of b-c-i-macro-env that is a symbol points
- ;; to a defined function. (Bug#8646)
- (and initial (symbolp initial)
- (setq old (byte-compile-fdefinition initial nil)))
+ (when (and initial (symbolp initial))
+ ;; Assume a symbol in byte-compile-initial-macro-env points to a
+ ;; defined function. (Bug#8646)
+ (setq old (byte-compile-fdefinition initial nil)))
(when (and old (not (eq old t)))
(let ((sig1 (byte-compile--function-signature old))
(sig2 (byte-compile-arglist-signature arglist)))
(unless (byte-compile-arglist-signatures-congruent-p sig1 sig2)
- (byte-compile-warn-x
- name
+ (byte-compile-warn
"%s %s used to take %s %s, now takes %s"
(if macrop "macro" "function")
name
@@ -1711,41 +1714,35 @@ byte-compile-docstring-length-warn
(setq name (if name (format " `%s' " name) ""))
(when (and kind docs (stringp docs)
(byte-compile--wide-docstring-p docs col))
- (byte-compile-warn-x
- name
- "%s%sdocstring wider than %s characters"
- kind name col))))
+ (byte-compile-warn "%s%sdocstring wider than %s characters"
+ kind name col))))
form)
-;; If we have compiled any calls to functions which are not known to be
-;; defined, issue a warning enumerating them.
-;; `unresolved' in the list `byte-compile-warnings' disables this.
(defun byte-compile-warn-about-unresolved-functions ()
- (when (byte-compile-warning-enabled-p 'unresolved)
- (let ((byte-compile-current-form :end))
- ;; Separate the functions that will not be available at runtime
- ;; from the truly unresolved ones.
- (dolist (urf byte-compile-unresolved-functions)
- (let ((f (car urf)))
- (when (not (memq f byte-compile-new-defuns))
- (byte-compile-warn-x
- f
- (if (fboundp f) "the function `%s' might not be defined at
runtime." "the function `%s' is not known to be defined.")
- (car urf)))))))
- nil)
-
-
-;; Dynamically bound in byte-compile-from-buffer.
-;; NB also used in cl.el and cl-macs.el.
-(defvar byte-compile--outbuffer)
+ "Separate the functions that will not be available at runtime
+from the truly unresolved ones."
+ (prog1 nil
+ (when (byte-compile-warning-enabled-p 'unresolved)
+ (let ((byte-compile-current-func :end))
+ (dolist (urf byte-compile-unresolved-functions)
+ (cl-destructuring-bind (f charpos &rest args)
+ urf
+ (unless (memq f byte-compile-new-defuns)
+ (let ((byte-compile-current-charpos charpos))
+ (byte-compile-warn
+ (if (fboundp f)
+ "the function `%s' might not be defined at runtime."
+ "the function `%s' is not known to be defined.")
+ f)))))))))
+
+
+(defvar byte-compile--outbuffer
+ "Dynamically bound in byte-compile-from-buffer, and used in cl.el
+and cl-macs.el.")
(defmacro byte-compile-close-variables (&rest body)
(declare (debug t))
- `(let (;;
- ;; Close over these variables to encapsulate the
- ;; compilation state
- ;;
- (byte-compile-macro-environment
+ `(let ((byte-compile-macro-environment
;; Copy it because the compiler may patch into the
;; macroenvironment.
(copy-alist byte-compile-initial-macro-environment))
@@ -1787,8 +1784,7 @@ displaying-byte-compile-warnings
(warning-series-started
(and (markerp warning-series)
(eq (marker-buffer warning-series)
- (get-buffer byte-compile-log-buffer))))
- (byte-compile-form-stack byte-compile-form-stack))
+ (get-buffer byte-compile-log-buffer)))))
(if (or (eq warning-series 'byte-compile-warning-series)
warning-series-started)
;; warning-series does come from compilation,
@@ -1800,19 +1796,19 @@ displaying-byte-compile-warnings
(setq warning-series (or tem 'byte-compile-warning-series)))
(if byte-compile-debug
(funcall --displaying-byte-compile-warnings-fn)
- (condition-case error-info
+ (condition-case err
(funcall --displaying-byte-compile-warnings-fn)
- (error (byte-compile-report-error error-info)))))
+ (error (byte-compile-report-error err)))))
;; 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
(funcall --displaying-byte-compile-warnings-fn)
- (condition-case error-info
+ (condition-case err
(funcall --displaying-byte-compile-warnings-fn)
- (error (byte-compile-report-error error-info))))))))
-
+ (error (byte-compile-report-error err))))))))
+
;;;###autoload
(defun byte-force-recompile (directory)
"Recompile every `.el' file in DIRECTORY that already has a `.elc' file.
@@ -2169,12 +2165,12 @@ byte-compile-file
target-file))))))
(unless byte-native-compiling
(kill-buffer (current-buffer))))
- (if (and byte-compile-generate-call-tree
- (or (eq t byte-compile-generate-call-tree)
- (y-or-n-p (format "Report call tree for %s? "
- filename))))
- (save-excursion
- (display-call-tree filename)))
+ (when (and byte-compile-generate-call-tree
+ (or (eq t byte-compile-generate-call-tree)
+ (y-or-n-p (format "Report call tree for %s? "
+ filename))))
+ (save-excursion
+ (display-call-tree filename)))
(let ((gen-dynvars (getenv "EMACS_GENERATE_DYNVARS")))
(when (and gen-dynvars (not (equal gen-dynvars ""))
byte-compile--seen-defvars)
@@ -2184,8 +2180,8 @@ byte-compile-file
(dolist (var (delete-dups byte-compile--seen-defvars))
(insert (format "%S\n" (cons var filename))))
(write-region (point-min) (point-max) dynvar-file)))))
- (if load
- (load target-file))
+ (when load
+ (load target-file))
t))))
;;; compiling a single function
@@ -2198,39 +2194,34 @@ compile-defun
(save-excursion
(end-of-defun)
(beginning-of-defun)
- (let* ((print-symbols-bare t) ; For the final `message'.
- (byte-compile-current-file (current-buffer))
+ (let* ((byte-compile-current-file (current-buffer))
(byte-compile-current-buffer (current-buffer))
- (start-read-position (point))
- (byte-compile-last-warned-form 'nothing)
- (symbols-with-pos-enabled t)
+ (point (point))
+ (byte-compile-last-warned-func 'nothing)
(value (eval
(displaying-byte-compile-warnings
- (byte-compile-sexp
- (let ((form (read-positioning-symbols (current-buffer))))
- (push form byte-compile-form-stack)
- (eval-sexp-add-defvars
- form
- start-read-position))))
+ (let* ((byte-compile-current-annotations
+ (read-annotated (current-buffer)))
+ (form (byte-compile--decouple
+ byte-compile-current-annotations
+ #'cdr)))
+ (byte-compile-sexp (eval-sexp-add-defvars form point))))
lexical-binding)))
(cond (arg
(message "Compiling from buffer... done.")
(prin1 value (current-buffer))
(insert "\n"))
- ((message "%s" (prin1-to-string value)))))))
+ (t
+ (message "%s" (prin1-to-string value)))))))
(defun byte-compile-from-buffer (inbuffer)
(let ((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)
- (print-length nil)
+ ;; Prevent truncation flonums
+ (float-output-format nil)
+ ;; Prevent truncation lists
(print-level nil)
- (print-symbols-bare t)
- ;; Prevent edebug from interfering when we compile
- ;; and put the output into a file.
-;; (edebug-all-defs nil)
-;; (edebug-all-forms nil)
+ (print-length nil)
;; Simulate entry to byte-compile-top-level
(byte-compile-jump-tables nil)
(byte-compile-constants nil)
@@ -2238,10 +2229,7 @@ byte-compile-from-buffer
(byte-compile-tag-number 0)
(byte-compile-depth 0)
(byte-compile-maxdepth 0)
- (byte-compile-output nil)
- ;; #### This is bound in b-c-close-variables.
- ;; (byte-compile-warnings byte-compile-warnings)
- (symbols-with-pos-enabled t))
+ (byte-compile-output nil))
(byte-compile-close-variables
(with-current-buffer
(setq byte-compile--outbuffer
@@ -2251,21 +2239,19 @@ byte-compile-from-buffer
(format "-%s" (1- byte-compile-level))))))
(set-buffer-multibyte t)
(erase-buffer)
- ;; (emacs-lisp-mode)
(setq case-fold-search nil))
(displaying-byte-compile-warnings
(with-current-buffer inbuffer
- (and byte-compile-current-file
- (byte-compile-insert-header byte-compile-current-file
- byte-compile--outbuffer))
+ (when byte-compile-current-file
+ (byte-compile-insert-header byte-compile-current-file
+ byte-compile--outbuffer))
(goto-char (point-min))
- ;; Should we always do this? When calling multiple files, it
- ;; would be useful to delay this warning until all have been
- ;; compiled. A: Yes! b-c-u-f might contain dross from a
- ;; previous byte-compile.
+
+ ;; Reset globals from previous byte-compile.
(setq byte-compile-unresolved-functions nil)
(setq byte-compile-noruntime-functions nil)
(setq byte-compile-new-defuns nil)
+
(when byte-native-compiling
(defvar native-comp-speed)
(push `(native-comp-speed . ,native-comp-speed)
byte-native-qualities)
@@ -2281,22 +2267,20 @@ byte-compile-from-buffer
(push `(no-native-compile . ,no-native-compile)
byte-native-qualities))
- ;; Compile the forms from the input buffer.
- (while (progn
+ (while (progn
(while (progn (skip-chars-forward " \t\n\^l")
(= (following-char) ?\;))
(forward-line 1))
(not (eobp)))
- (let* ((lread--unescaped-character-literals nil)
- ;; Don't bind `load-read-function' to
- ;; `read-positioning-symbols' here. Calls to `read'
- ;; at a lower level must not get symbols with
- ;; position.
- (form (read-positioning-symbols inbuffer))
- (warning (byte-run--unescaped-character-literals-warning)))
- (when warning (byte-compile-warn-x form "%s" warning))
- (byte-compile-toplevel-file-form form)))
- ;; Compile pending forms at end of file.
+ (let* ((byte-compile-current-annotations (read-annotated inbuffer))
+ (form (byte-compile--decouple byte-compile-current-annotations
+ #'cdr)))
+ (byte-compile-maybe-expand
+ form
+ (lambda (form*)
+ (let (byte-compile-current-func)
+ (byte-compile-file-form
+ (byte-compile-preprocess form*)))))))
(byte-compile-flush-pending)
(byte-compile-warn-about-unresolved-functions)))
byte-compile--outbuffer)))
@@ -2345,24 +2329,20 @@ byte-compile-insert-header
"\n\n"))))
(defun byte-compile-output-file-form (form)
- ;; Write the given form to the output buffer, being careful of docstrings
- ;; in defvar, defvaralias, defconst, autoload and
- ;; custom-declare-variable because make-docfile is so amazingly stupid.
- ;; defalias calls are output directly by byte-compile-file-form-defmumble;
- ;; it does not pay to first build the defalias in defmumble and then parse
- ;; it here.
+ "Write FORM to output buffer, being careful of
+docstrings in defvar, defvaralias, defconst, autoload and
+custom-declare-variable because make-docfile is so amazingly
+stupid (and also obsolete)."
(when byte-native-compiling
;; Spill output for the native compiler here
(push (make-byte-to-native-top-level :form form :lexical lexical-binding)
byte-to-native-top-level-forms))
- (let ((print-symbols-bare t) ; Possibly redundant binding.
- (print-escape-newlines t)
+ (let ((print-escape-newlines t)
(print-length nil)
(print-level nil)
(print-quoted t)
(print-gensym t)
- (print-circle ; Handle circular data structures.
- (not byte-compile-disable-print-circle)))
+ (print-circle (not byte-compile-disable-print-circle)))
(if (and (memq (car-safe form) '(defvar defvaralias defconst
autoload custom-declare-variable))
(stringp (nth 3 form)))
@@ -2371,8 +2351,7 @@ byte-compile-output-file-form
'(defvaralias autoload
custom-declare-variable)))
(princ "\n" byte-compile--outbuffer)
- (prin1 form byte-compile--outbuffer)
- nil)))
+ (prin1 form byte-compile--outbuffer))))
(defvar byte-compile--for-effect)
@@ -2386,13 +2365,14 @@ byte-compile-output-docform
\(the constants vector) together, for lazy loading.
QUOTED says that we have to put a quote before the
list that represents a doc string reference.
-`defvaralias', `autoload' and `custom-declare-variable' need that."
- ;; We need to examine byte-compile-dynamic-docstrings
- ;; in the input buffer (now current), not in the output buffer.
+`defvaralias', `autoload' and `custom-declare-variable' need that.
+
+We need to examine byte-compile-dynamic-docstrings
+in the input buffer (now current), not in the output buffer."
(let ((dynamic-docstrings byte-compile-dynamic-docstrings))
(with-current-buffer byte-compile--outbuffer
- (let (position
- (print-symbols-bare t)) ; Possibly redundant binding.
+ (let (position)
+
;; Insert the doc string, and make it a comment with #@LENGTH.
(and (>= (nth 1 info) 0)
dynamic-docstrings
@@ -2400,9 +2380,8 @@ byte-compile-output-docform
;; Make the doc string start at beginning of line
;; for make-docfile's sake.
(insert "\n")
- (setq position
- (byte-compile-output-as-comment
- (nth (nth 1 info) form) nil))
+ (setq position (byte-compile-output-as-comment
+ (nth (nth 1 info) form) nil))
;; If the doc string starts with * (a user variable),
;; negate POSITION.
(if (and (stringp (nth (nth 1 info) form))
@@ -2411,46 +2390,37 @@ byte-compile-output-docform
(setq position (- position)))))
(let ((print-continuous-numbering t)
- print-number-table
+ (print-number-table nil)
(index 0)
- ;; FIXME: The bindings below are only needed for when we're
- ;; called from ...-defmumble.
(print-escape-newlines t)
(print-length nil)
(print-level nil)
(print-quoted t)
(print-gensym t)
- (print-circle ; Handle circular data structures.
- (not byte-compile-disable-print-circle)))
- (if preface
- (progn
- ;; FIXME: We don't handle uninterned names correctly.
- ;; E.g. if cl-define-compiler-macro uses uninterned name we
get:
- ;; (defalias '#1=#:foo--cmacro #[514 ...])
- ;; (put 'foo 'compiler-macro '#:foo--cmacro)
- (insert preface)
- (prin1 name byte-compile--outbuffer)))
+ (print-circle (not byte-compile-disable-print-circle)))
+ (when preface
+ ;; FIXME: If cl-define-compiler-macro uses uninterned
+ ;; "#:foo", we get:
+ ;; (defalias '#1=#:foo--cmacro #[514 ...])
+ ;; (put 'foo 'compiler-macro '#:foo--cmacro)
+ (insert preface)
+ (prin1 name byte-compile--outbuffer))
(insert (car info))
(prin1 (car form) byte-compile--outbuffer)
(while (setq form (cdr form))
(setq index (1+ index))
(insert " ")
(cond ((and (numberp specindex) (= index specindex)
- ;; Don't handle the definition dynamically
- ;; if it refers (or might refer)
- ;; to objects already output
- ;; (for instance, gensyms in the arg list).
- (let (non-nil)
- (when (hash-table-p print-number-table)
- (maphash (lambda (_k v) (if v (setq non-nil t)))
- print-number-table))
- (not non-nil)))
+ ;; gensyms in the arglist might
+ ;; already be output; don't proceed
+ (or (not (hash-table-p print-number-table))
+ (not (catch 'already
+ (maphash (lambda (_k v) (when v (throw
'already t)))
+ print-number-table)))))
;; Output the byte code and constants specially
;; for lazy dynamic loading.
- (let ((position
- (byte-compile-output-as-comment
- (cons (car form) (nth 1 form))
- t)))
+ (let ((position (byte-compile-output-as-comment
+ (cons (car form) (nth 1 form)) t)))
(princ (format "(#$ . %d) nil" position)
byte-compile--outbuffer)
(setq form (cdr form))
@@ -2468,85 +2438,60 @@ byte-compile-output-docform
(goto-char (point-max)))))
(t
(prin1 (car form) byte-compile--outbuffer)))))
- (insert (nth 2 info)))))
- nil)
+ (insert (nth 2 info))))))
(defun byte-compile-keep-pending (form &optional handler)
- (if (memq byte-optimize '(t source))
- (setq form (byte-optimize-one-form form t)))
- (if handler
- (let ((byte-compile--for-effect t))
- ;; To avoid consing up monstrously large forms at load time, we split
- ;; the output regularly.
- (and (memq (car-safe form) '(fset defalias))
- (nthcdr 300 byte-compile-output)
- (byte-compile-flush-pending))
- (funcall handler form)
- (if byte-compile--for-effect
- (byte-compile-discard)))
- (byte-compile-form form t))
- nil)
+ (when (memq byte-optimize '(t source))
+ (setq form (byte-optimize-one-form form t)))
+ (prog1 nil
+ (if handler
+ (let ((byte-compile--for-effect t))
+ (when (and (memq (car-safe form) '(fset defalias))
+ (nthcdr 300 byte-compile-output))
+ ;; To avoid consing frenzy at load time, split here
+ (byte-compile-flush-pending))
+ (funcall handler form)
+ (when byte-compile--for-effect
+ (byte-compile-discard)))
+ (byte-compile-form form t))))
(defun byte-compile-flush-pending ()
- (if byte-compile-output
- (let ((form (byte-compile-out-toplevel t 'file)))
- (cond ((eq (car-safe form) 'progn)
- (mapc 'byte-compile-output-file-form (cdr form)))
- (form
- (byte-compile-output-file-form form)))
- (setq byte-compile-constants nil
- byte-compile-variables nil
- byte-compile-depth 0
- byte-compile-maxdepth 0
- byte-compile-output nil
- byte-compile-jump-tables nil))))
-
-(defun byte-compile-preprocess (form &optional _for-effect)
- (let ((print-symbols-bare t)) ; Possibly redundant binding.
- (setq form (macroexpand-all form byte-compile-macro-environment)))
- ;; FIXME: We should run byte-optimize-form here, but it currently does not
- ;; recurse through all the code, so we'd have to fix this first.
- ;; Maybe a good fix would be to merge byte-optimize-form into
- ;; macroexpand-all.
- ;; (if (memq byte-optimize '(t source))
- ;; (setq form (byte-optimize-form form for-effect)))
- (cond
- (lexical-binding (cconv-closure-convert form))
- (t form)))
-
-;; byte-hunk-handlers cannot call this!
-(defun byte-compile-toplevel-file-form (top-level-form)
- ;; (let ((byte-compile-form-stack
- ;; (cons top-level-form byte-compile-form-stack)))
- (push top-level-form byte-compile-form-stack)
- (prog1
- (byte-compile-recurse-toplevel
- top-level-form
- (lambda (form)
- (let ((byte-compile-current-form nil)) ; close over this for warnings.
- (byte-compile-file-form (byte-compile-preprocess form t)))))
- (pop byte-compile-form-stack)))
+ "Compile pending forms at end of file."
+ (when byte-compile-output
+ (let ((form (byte-compile-out-top-level t 'file)))
+ (cond ((eq (car-safe form) 'progn)
+ (mapc #'byte-compile-output-file-form (cdr form)))
+ (form
+ (byte-compile-output-file-form form)))
+ (setq byte-compile-constants nil
+ byte-compile-variables nil
+ byte-compile-depth 0
+ byte-compile-maxdepth 0
+ byte-compile-output nil
+ byte-compile-jump-tables nil))))
+
+(defun byte-compile-preprocess (form)
+ (let ((form* (macroexpand-all form byte-compile-macro-environment)))
+ (if lexical-binding
+ (cconv-closure-convert form*)
+ form*)))
;; byte-hunk-handlers can call this.
(defun byte-compile-file-form (form)
- (let (handler)
- (cond ((and (consp form)
- (symbolp (car form))
- (setq handler (get (car form) 'byte-hunk-handler)))
- (cond ((setq form (funcall handler form))
- (byte-compile-flush-pending)
- (byte-compile-output-file-form form))))
- (t
- (byte-compile-keep-pending form)))))
-
-;; Functions and variables with doc strings must be output separately,
-;; so make-docfile can recognize them. Most other things can be output
-;; as byte-code.
+ (if-let ((handler (and (consp form)
+ (symbolp (car form))
+ (get (car form) 'byte-hunk-handler))))
+ (let* ((byte-compile-current-form form)
+ (form* (funcall handler form)))
+ (byte-compile-flush-pending)
+ (byte-compile-output-file-form form*))
+ (byte-compile-keep-pending form)))
(put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload)
(defun byte-compile-file-form-autoload (form)
(and (let ((form form))
- (while (if (setq form (cdr form)) (macroexp-const-p (car form))))
+ (while (when (setq form (cdr form))
+ (macroexp-const-p (car form))))
(null form)) ;Constants only
(memq (eval (nth 5 form)) '(t macro)) ;Macro
(eval form)) ;Define the autoload.
@@ -2574,21 +2519,19 @@ byte-compile-file-form-autoload
(delq (assq funsym byte-compile-unresolved-functions)
byte-compile-unresolved-functions)))))
(if (stringp (nth 3 form))
- (prog1
- form
+ (prog1 form
(byte-compile-docstring-length-warn form))
;; No doc string, so we can compile this as a normal form.
(byte-compile-keep-pending form 'byte-compile-normal-call)))
-(put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar)
+(put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar)
(put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar)
(defun byte-compile--check-prefixed-var (sym)
(when (and (symbolp sym)
(not (string-match "[-*/:$]" (symbol-name sym)))
(byte-compile-warning-enabled-p 'lexical sym))
- (byte-compile-warn-x
- sym "global/dynamic var `%s' lacks a prefix" sym)))
+ (byte-compile-warn "global/dynamic var `%s' lacks a prefix" sym)))
(defun byte-compile--declare-var (sym)
(byte-compile--check-prefixed-var sym)
@@ -2596,29 +2539,21 @@ byte-compile--declare-var
(setq byte-compile-lexical-variables
(delq sym byte-compile-lexical-variables))
(when (byte-compile-warning-enabled-p 'lexical sym)
- (byte-compile-warn-x sym "Variable `%S' declared after its first use"
sym)))
+ (byte-compile-warn "Variable `%S' declared after its first use" sym)))
(push sym byte-compile-bound-variables)
(push sym byte-compile--seen-defvars))
(defun byte-compile-file-form-defvar (form)
(let ((sym (nth 1 form)))
(byte-compile--declare-var sym)
- (if (eq (car form) 'defconst)
- (push sym byte-compile-const-variables)))
- (if (and (null (cddr form)) ;No `value' provided.
- (eq (car form) 'defvar)) ;Just a declaration.
- nil
+ (when (eq (car form) 'defconst)
+ (push sym byte-compile-const-variables)))
+ (when (or (cddr form) (not (eq (car form) 'defvar)))
(byte-compile-docstring-length-warn form)
- (setq form (copy-sequence form))
(cond ((consp (nth 2 form))
+ (setq form (copy-sequence form))
(setcar (cdr (cdr form))
- (byte-compile-top-level (nth 2 form) nil 'file)))
- ((symbolp (nth 2 form))
- (setcar (cddr form) (bare-symbol (nth 2 form))))
- (t (setcar (cddr form) (nth 2 form))))
- (setcar form (bare-symbol (car form)))
- (if (symbolp (nth 1 form))
- (setcar (cdr form) (bare-symbol (nth 1 form))))
+ (byte-compile-top-level (nth 2 form) nil 'file))))
form))
(put 'define-abbrev-table 'byte-hunk-handler
@@ -2627,7 +2562,7 @@ byte-compile-file-form-defvar
(defun byte-compile-file-form-defvar-function (form)
(pcase-let (((or `',name (let name nil)) (nth 1 form)))
- (if name (byte-compile--declare-var name)))
+ (when name (byte-compile--declare-var name)))
;; Variable aliases are better declared before the corresponding variable,
;; since it makes it more likely that only one of the two vars has a value
;; before the `defvaralias' gets executed, which avoids the need to
@@ -2635,10 +2570,9 @@ byte-compile-file-form-defvar-function
(pcase form
(`(defvaralias ,_ ',newname . ,_)
(when (memq newname byte-compile-bound-variables)
- (if (byte-compile-warning-enabled-p 'suspicious)
- (byte-compile-warn-x
- newname
- "Alias for `%S' should be declared before its referent"
newname)))))
+ (when (byte-compile-warning-enabled-p 'suspicious)
+ (byte-compile-warn
+ "Alias for `%S' should be declared before its referent" newname)))))
(byte-compile-docstring-length-warn form)
(byte-compile-keep-pending form))
@@ -2651,189 +2585,149 @@ byte-compile-file-form-custom-declare-variable
(put 'require 'byte-hunk-handler 'byte-compile-file-form-require)
(defun byte-compile-file-form-require (form)
- (let* ((args (mapcar 'eval (cdr form)))
- ;; The following is for the byte-compile-warn in
- ;; `do-after-load-evaluation' (in subr.el).
- (byte-compile-form-stack (cons (car args) byte-compile-form-stack))
- hist-new prov-cons)
- (apply 'require args)
-
- ;; Record the functions defined by the require in
`byte-compile-new-defuns'.
- (setq hist-new load-history)
- (setq prov-cons (cons 'provide (car args)))
+ "Record functions defined by FORM in `byte-compile-new-defuns'."
+ (let* ((args (mapcar #'eval (cdr form)))
+ (hist-new (progn (apply #'require args)
+ load-history)))
(while (and hist-new
- (not (member prov-cons (car hist-new))))
+ (not (member (cons 'provide (car args))
+ (car hist-new))))
(setq hist-new (cdr hist-new)))
- (when hist-new
- (dolist (x (car hist-new))
- (when (and (consp x)
- (memq (car x) '(defun t)))
- (push (cdr x) byte-compile-new-defuns)))))
+ (dolist (x (car hist-new))
+ (when (and (consp x)
+ (memq (car x) '(defun t)))
+ (push (cdr x) byte-compile-new-defuns))))
(byte-compile-keep-pending form 'byte-compile-normal-call))
(put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn)
(put 'prog1 'byte-hunk-handler 'byte-compile-file-form-progn)
(defun byte-compile-file-form-progn (form)
- (mapc #'byte-compile-file-form (cdr form))
- ;; Return nil so the forms are not output twice.
- nil)
+ (prog1 nil
+ (mapc #'byte-compile-file-form (cdr form))))
(put 'with-no-warnings 'byte-hunk-handler
'byte-compile-file-form-with-no-warnings)
(defun byte-compile-file-form-with-no-warnings (form)
- ;; cf byte-compile-file-form-progn.
(let (byte-compile-warnings)
- (mapc 'byte-compile-file-form (cdr form))
- nil))
+ (byte-compile-file-form-progn form)))
(put 'internal--with-suppressed-warnings 'byte-hunk-handler
'byte-compile-file-form-with-suppressed-warnings)
(defun byte-compile-file-form-with-suppressed-warnings (form)
- ;; cf byte-compile-file-form-progn.
(let ((byte-compile--suppressed-warnings
(append (cadadr form) byte-compile--suppressed-warnings)))
- (mapc 'byte-compile-file-form (cddr form))
- nil))
+ (byte-compile-file-form-progn (cdr form))))
;; Automatically evaluate define-obsolete-function-alias etc at top-level.
(put 'make-obsolete 'byte-hunk-handler 'byte-compile-file-form-make-obsolete)
(defun byte-compile-file-form-make-obsolete (form)
(prog1 (byte-compile-keep-pending form)
- (apply 'make-obsolete
- (mapcar 'eval (cdr form)))))
-
-(defun byte-compile-file-form-defmumble (name macro arglist body rest)
- "Process a `defalias' for NAME.
-If MACRO is non-nil, the definition is known to be a macro.
-ARGLIST is the list of arguments, if it was recognized or t otherwise.
-BODY of the definition, or t if not recognized.
-Return non-nil if everything went as planned, or nil to imply that it decided
-not to take responsibility for the actual compilation of the code."
- (let* ((this-kind (if macro 'byte-compile-macro-environment
+ (apply #'make-obsolete (mapcar #'eval (cdr form)))))
+
+(defun byte-compile-file-form-defalias* (name macro-p arglist body rest)
+ "Rather than have `byte-compile-output-file-form' analyze NAME's
+defalias, output it by hand here. ARGLIST is the list of
+arguments, or t if not recognized. BODY is the function
+definition, or t if not recognized. Return t if compiled, nil
+otherwise."
+ (let* ((this-kind (if macro-p
+ 'byte-compile-macro-environment
'byte-compile-function-environment))
- (that-kind (if macro 'byte-compile-function-environment
+ (that-kind (if macro-p
+ 'byte-compile-function-environment
'byte-compile-macro-environment))
(this-one (assq name (symbol-value this-kind)))
(that-one (assq name (symbol-value that-kind)))
- (bare-name (bare-symbol name))
- (byte-compile-current-form name)) ; For warnings.
-
- (push bare-name byte-compile-new-defuns)
- ;; When a function or macro is defined, add it to the call tree so that
- ;; we can tell when functions are not used.
- (if byte-compile-generate-call-tree
- (or (assq bare-name byte-compile-call-tree)
- (setq byte-compile-call-tree
- (cons (list bare-name nil nil) byte-compile-call-tree))))
-
- (if (byte-compile-warning-enabled-p 'redefine name)
- (byte-compile-arglist-warn name arglist macro))
-
- (if byte-compile-verbose
- (message "Compiling %s... (%s)"
- (or byte-compile-current-file "") bare-name))
- (cond ((not (or macro (listp body)))
- ;; We do not know positively if the definition is a macro
- ;; or a function, so we shouldn't emit warnings.
- ;; This also silences "multiple definition" warnings for defmethods.
- nil)
- (that-one
- (if (and (byte-compile-warning-enabled-p 'redefine name)
- ;; Don't warn when compiling the stubs in byte-run...
- (not (assq bare-name
byte-compile-initial-macro-environment)))
- (byte-compile-warn-x
- name
+ (do-warn (byte-compile-warning-enabled-p 'redefine name))
+ (byte-compile-current-func name))
+ (push name byte-compile-new-defuns)
+ (when byte-compile-generate-call-tree
+ (unless (assq name byte-compile-call-tree)
+ ;; Add NAME to call tree to later detect unused functions.
+ (setq byte-compile-call-tree
+ (cons (list name nil nil) byte-compile-call-tree))))
+ (when do-warn
+ (byte-compile-arglist-warn name arglist macro-p))
+ (when byte-compile-verbose
+ (message "Compiling %s... (%s)"
+ (or byte-compile-current-file "") name))
+ (when (or macro-p (listp body))
+ (cond (that-one
+ (when (and do-warn
+ ;; Don't warn when compiling stubs in byte-run.el
+ (not (assq name
byte-compile-initial-macro-environment)))
+ (byte-compile-warn
"`%s' defined multiple times, as both function and macro"
- bare-name))
- (setcdr that-one nil))
- (this-one
- (when (and (byte-compile-warning-enabled-p 'redefine name)
- ;; Hack: Don't warn when compiling the magic internal
- ;; byte-compiler macros in byte-run.el...
- (not (assq bare-name
byte-compile-initial-macro-environment)))
- (byte-compile-warn-x
- name
- "%s `%s' defined multiple times in this file"
- (if macro "macro" "function")
- bare-name)))
- ((eq (car-safe (symbol-function bare-name))
- (if macro 'lambda 'macro))
- (when (byte-compile-warning-enabled-p 'redefine bare-name)
- (byte-compile-warn-x
- name
- "%s `%s' being redefined as a %s"
- (if macro "function" "macro")
- bare-name
- (if macro "macro" "function")))
- ;; Shadow existing definition.
- (set this-kind
- (cons (cons bare-name nil)
- (symbol-value this-kind))))
- )
+ name))
+ (setcdr that-one nil))
+ (this-one
+ (when (and do-warn
+ ;; Don't warn when compiling stubs in byte-run.el
+ (not (assq name
byte-compile-initial-macro-environment)))
+ (byte-compile-warn
+ "%s `%s' defined multiple times in this file"
+ (if macro-p "macro" "function")
+ name)))
+ ((eq (car-safe (symbol-function name))
+ (if macro-p 'lambda 'macro))
+ (when do-warn
+ (byte-compile-warn
+ "%s `%s' being redefined as a %s"
+ (if macro-p "function" "macro")
+ name
+ (if macro-p "macro" "function")))
+ ;; Shadow existing definition.
+ (set this-kind
+ (cons (cons name nil) (symbol-value this-kind))))))
(when (and (listp body)
(stringp (car body))
(symbolp (car-safe (cdr-safe body)))
(car-safe (cdr-safe body))
(stringp (car-safe (cdr-safe (cdr-safe body)))))
- (byte-compile-warn-x
- name "probable `\"' without `\\' in doc string of %s" bare-name))
+ (byte-compile-warn "probable `\"' without `\\' in doc string of %s"
+ name))
+ ;; Final expresssion must inform caller whether we compiled.
(if (not (listp body))
- ;; The precise definition requires evaluation to find out, so it
- ;; will only be known at runtime.
- ;; For a macro, that means we can't use that macro in the same file.
- (progn
- (unless macro
- (push (cons bare-name (if (listp arglist) `(declared ,arglist) t))
- byte-compile-function-environment))
- ;; Tell the caller that we didn't compile it yet.
- nil)
-
- (let* ((code (byte-compile-lambda (cons arglist body) t)))
+ (prog1 nil
+ (unless macro-p ;; macros undefined until runtime evaluation
+ (push (cons name (if (listp arglist) `(declared ,arglist) t))
+ byte-compile-function-environment)))
+ (let ((code (byte-compile-lambda (cons arglist body) t)))
(if this-one
- ;; A definition in b-c-initial-m-e should always take precedence
- ;; during compilation, so don't let it be redefined. (Bug#8647)
- (or (and macro
- (assq bare-name byte-compile-initial-macro-environment))
- (setcdr this-one code))
- (set this-kind
- (cons (cons bare-name code)
- (symbol-value this-kind))))
-
- (if rest
- ;; There are additional args to `defalias' (like maybe a docstring)
- ;; that the code below can't handle: punt!
- nil
- ;; Otherwise, we have a bona-fide defun/defmacro definition, and use
- ;; special code to allow dynamic docstrings and byte-code.
- (byte-compile-flush-pending)
- (let ((index
- ;; If there's no doc string, provide -1 as the "doc string
- ;; index" so that no element will be treated as a doc string.
- (if (not (stringp (documentation code t))) -1 4)))
+ ;; A definition in byte-compile-initial-macro-environment
+ ;; cannot be redefined. (Bug#8647)
+ (unless (and macro-p
+ (assq name byte-compile-initial-macro-environment))
+ (setcdr this-one code))
+ (set this-kind (cons (cons name code) (symbol-value this-kind))))
+
+ ;; If REST contains additional args (e.g., docstring) we don't
+ ;; handle below, punt back nil.
+ (unless rest
+ (prog1 t
+ (byte-compile-flush-pending)
(when byte-native-compiling
;; Spill output for the native compiler here.
- (push
- (if macro
- (make-byte-to-native-top-level
- :form `(defalias ',name '(macro . ,code) nil)
- :lexical lexical-binding)
- (make-byte-to-native-func-def :name name
- :byte-func code))
- byte-to-native-top-level-forms))
- ;; Output the form by hand, that's much simpler than having
- ;; b-c-output-file-form analyze the defalias.
- (byte-compile-output-docform
- "\n(defalias '"
- bare-name
- (if macro `(" '(macro . #[" ,index "])") `(" #[" ,index "]"))
- (append code nil) ; Turn byte-code-function-p into list.
- (and (atom code) byte-compile-dynamic
- 1)
- nil))
- (princ ")" byte-compile--outbuffer)
- t)))))
+ (push (if macro-p
+ (make-byte-to-native-top-level
+ :form `(defalias ',name '(macro . ,code) nil)
+ :lexical lexical-binding)
+ (make-byte-to-native-func-def :name name
+ :byte-func code))
+ byte-to-native-top-level-forms))
+ (let ((doc-index (if (stringp (documentation code t)) 4 -1)))
+ (byte-compile-output-docform
+ "\n(defalias '"
+ name
+ (if macro-p
+ `(" '(macro . #[" ,doc-index "])")
+ `(" #[" ,doc-index "]"))
+ (append code nil) ; function vector to list
+ (and (atom code) byte-compile-dynamic 1)
+ nil))
+ (princ ")" byte-compile--outbuffer)))))))
(defun byte-compile-output-as-comment (exp quoted)
"Print Lisp object EXP in the output file, inside a comment.
@@ -2841,7 +2735,6 @@ byte-compile-output-as-comment
If QUOTED is non-nil, print with quoting; otherwise, print without quoting."
(with-current-buffer byte-compile--outbuffer
(let ((position (point)))
-
;; Insert EXP, and make it a comment with #@LENGTH.
(insert " ")
(if quoted
@@ -2895,11 +2788,11 @@ byte-compile--reify-function
(if (null renv)
`(lambda ,args ,@preamble ,@body)
`(let ,renv (lambda ,args ,@preamble ,@body)))))
-
+
;;;###autoload
(defun byte-compile (form)
- "If FORM is a symbol, byte-compile its function definition.
-If FORM is a lambda or a macro, byte-compile it as a function."
+ "If FORM is a symbol, compile its function definition.
+If FORM is a lambda or a macro, compile into a function."
(displaying-byte-compile-warnings
(byte-compile-close-variables
(let* ((lexical-binding lexical-binding)
@@ -2907,40 +2800,35 @@ byte-compile
(symbol-function form)
form))
(macro (eq (car-safe fun) 'macro)))
- (if macro
- (setq fun (cdr fun)))
- (prog1
- (cond
- ;; Up until Emacs-24.1, byte-compile silently did nothing when
asked to
- ;; compile something invalid. So let's tune down the complaint
from an
- ;; error to a simple message for the known case where signaling an
error
- ;; causes problems.
- ((byte-code-function-p fun)
- (message "Function %s is already compiled"
- (if (symbolp form) form "provided"))
- fun)
- (t
- (let (final-eval)
- (when (or (symbolp form) (eq (car-safe fun) 'closure))
- ;; `fun' is a function *value*, so try to recover its
corresponding
- ;; source code.
- (setq lexical-binding (eq (car fun) 'closure))
- (setq fun (byte-compile--reify-function fun))
- (setq final-eval t))
- ;; Expand macros.
- (setq fun (byte-compile-preprocess fun))
- (setq fun (byte-compile-top-level fun nil 'eval))
- (if (symbolp form)
- ;; byte-compile-top-level returns an *expression* equivalent
to the
- ;; `fun' expression, so we need to evaluate it, tho normally
- ;; this is not needed because the expression is just a
constant
- ;; byte-code object, which is self-evaluating.
- (setq fun (eval fun t)))
- (if final-eval
- (setq fun (eval fun t)))
- (if macro (push 'macro fun))
- (if (symbolp form) (fset form fun))
- fun))))))))
+ (when macro
+ (setq fun (cdr fun)))
+ (cond
+ ((byte-code-function-p fun)
+ (message "Function %s is already compiled"
+ (if (symbolp form) form "provided"))
+ fun)
+ (t
+ (let (final-eval)
+ (when (or (symbolp form) (eq (car-safe fun) 'closure))
+ ;; FUN is a function *value*; recover its source code.
+ (setq lexical-binding (eq (car fun) 'closure))
+ (setq fun (byte-compile--reify-function fun))
+ (setq final-eval t))
+ ;; Expand macros.
+ (setq fun (byte-compile-preprocess fun))
+ (setq fun (byte-compile-top-level fun nil 'eval))
+ (when (symbolp form)
+ ;; byte-compile-top-level returns an *expression* we need
+ ;; to evaluate, although it's often a constant,
+ ;; self-evaluating byte-code object.
+ (setq fun (eval fun t)))
+ (when final-eval
+ (setq fun (eval fun t)))
+ (when macro
+ (push 'macro fun))
+ (when (symbolp form)
+ (fset form fun))
+ fun)))))))
(defun byte-compile-sexp (sexp)
"Compile and return SEXP."
@@ -2969,8 +2857,7 @@ byte-compile-check-lambda-list
((and (memq arg vars)
;; Allow repetitions for unused args.
(not (string-match "\\`_" (symbol-name arg))))
- (byte-compile-warn-x
- arg "repeated variable %s in lambda-list" arg))
+ (byte-compile-warn "repeated variable %s in lambda-list" arg))
(t
(push arg vars))))
(setq list (cdr list)))))
@@ -3013,8 +2900,7 @@ byte-compile-make-args-desc
(defun byte-compile--warn-lexical-dynamic (var context)
(when (byte-compile-warning-enabled-p 'lexical-dynamic var)
- (byte-compile-warn-x
- var
+ (byte-compile-warn
"`%s' lexically bound in %s here but declared dynamic in: %s"
var context
(mapconcat #'identity
@@ -3023,10 +2909,12 @@ byte-compile--warn-lexical-dynamic
byte-compile--known-dynamic-vars)
", "))))
-(defun byte-compile-lambda (fun &optional add-lambda reserved-csts)
+(defun byte-compile-lambda (fun &optional add-lambda num-constants)
"Byte-compile a lambda-expression and return a valid function.
The value is usually a compiled function but may be the original
-lambda-expression."
+lambda-expression.
+When ADD-LAMBDA is non-nil, the symbol `lambda' is added as head
+of the list FUN."
(if add-lambda
(setq fun (cons 'lambda fun))
(unless (eq 'lambda (car-safe fun))
@@ -3054,14 +2942,14 @@ byte-compile-lambda
;; Process the interactive spec.
(when int
;; Skip (interactive) if it is in front (the most usual location).
- (if (eq int (car body))
- (setq body (cdr body)))
+ (when (eq int (car body))
+ (setq body (cdr body)))
(cond ((consp (cdr int)) ; There is an `interactive' spec.
;; Check that the bit after the `interactive' spec is
;; just a list of symbols (i.e., modes).
(unless (seq-every-p #'symbolp (cdr (cdr int)))
- (byte-compile-warn-x int "malformed interactive specc: %s"
- int))
+ (byte-compile-warn "malformed interactive specc: %s"
+ (prin1-to-string int)))
(setq command-modes (cdr (cdr int)))
;; If the interactive spec is a call to `list', don't
;; compile it, because `call-interactively' looks at the
@@ -3073,43 +2961,39 @@ byte-compile-lambda
(while (consp (cdr form))
(setq form (cdr form)))
(setq form (car form)))
- (if (or (not (eq (car-safe form) 'list))
- ;; For code using lexical-binding, form is not
- ;; valid lisp, but rather an intermediate form
- ;; which may include "calls" to
- ;; internal-make-closure (Bug#29988).
- lexical-binding)
- (setq int `(interactive ,newform)))))
+ (when (or (not (eq (car-safe form) 'list))
+ ;; For code using lexical-binding, form is not
+ ;; valid lisp, but rather an intermediate form
+ ;; which may include "calls" to
+ ;; internal-make-closure (Bug#29988).
+ lexical-binding)
+ (setq int `(interactive ,newform)))))
((cdr int) ; Invalid (interactive . something).
- (byte-compile-warn-x int "malformed interactive spec: %s"
- int))))
+ (byte-compile-warn "malformed interactive spec: %s"
+ (prin1-to-string int)))))
;; Process the body.
(let ((compiled
(byte-compile-top-level (cons 'progn body) nil 'lambda
- ;; If doing lexical binding, push a new
- ;; lexical environment containing just the
- ;; args (since lambda expressions should be
- ;; closed by now).
- (and lexical-binding
- (byte-compile-make-lambda-lexenv
- arglistvars))
- reserved-csts))
- (bare-arglist arglist))
+ (when lexical-binding
+ ;; use env containing just args (since
lambda
+ ;; expressions will be closed by now).
+ (byte-compile-make-lambda-lexenv
arglistvars))
+ num-constants)))
;; Build the actual byte-coded function.
(cl-assert (eq 'byte-code (car-safe compiled)))
(let ((out
(apply #'make-byte-code
(if lexical-binding
(byte-compile-make-args-desc arglist)
- bare-arglist)
+ arglist)
(append
;; byte-string, constants-vector, stack depth
(cdr compiled)
;; optionally, the doc string.
(cond ((and lexical-binding arglist)
- ;; byte-compile-make-args-desc lost the args's
names,
+ ;; byte-compile-make-args-desc lost the argnames,
;; so preserve them in the docstring.
- (list (help-add-fundoc-usage doc bare-arglist)))
+ (list (help-add-fundoc-usage doc arglist)))
((or doc int)
(list doc)))
;; optionally, the interactive spec (and the modes the
@@ -3166,14 +3050,14 @@ byte-compile-constants-vector
(setq other rest))))
(apply 'vector (nreverse (mapcar 'car ret)))))
-;; Given an expression FORM, compile it and return an equivalent byte-code
-;; expression (a call to the function byte-code).
-(defun byte-compile-top-level (form &optional for-effect output-type
- lexenv reserved-csts)
- ;; OUTPUT-TYPE advises about how form is expected to be used:
- ;; 'eval or nil -> a single form,
- ;; 'lambda -> body of a lambda,
- ;; 'file -> used at file-level.
+(defun byte-compile-top-level (form
+ &optional
+ for-effect output-type lexenv num-constants)
+ "Return equivalent byte-code expression for FORM.
+OUTPUT-TYPE advises how form will be used,
+'eval or nil: a single form,
+'lambda: body of a lambda,
+'file: used at file-level."
(let ((byte-compile--for-effect for-effect)
(byte-compile-constants nil)
(byte-compile-variables nil)
@@ -3181,64 +3065,59 @@ byte-compile-top-level
(byte-compile-depth 0)
(byte-compile-maxdepth 0)
(byte-compile--lexical-environment lexenv)
- (byte-compile-reserved-constants (or reserved-csts 0))
+ (byte-compile-reserved-constants (or num-constants 0))
(byte-compile-output nil)
(byte-compile-jump-tables nil))
- (if (memq byte-optimize '(t source))
- (setq form (byte-optimize-one-form form byte-compile--for-effect)))
- (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form))))
+ (when (memq byte-optimize '(t source))
+ (setq form (byte-optimize-one-form form byte-compile--for-effect)))
+ (while (and (eq (car-safe form) 'progn)
+ (not (cdr (cdr form))))
(setq form (nth 1 form)))
;; Set up things for a lexically-bound function.
(when (and lexical-binding (eq output-type 'lambda))
- ;; See how many arguments there are, and set the current stack depth
- ;; accordingly.
+ ;; Stack depth is number of arguments.
(setq byte-compile-depth (length byte-compile--lexical-environment))
- ;; If there are args, output a tag to record the initial
- ;; stack-depth for the optimizer.
(when (> byte-compile-depth 0)
+ ;; Output tag to record initial stack depth for optimizer.
(byte-compile-out-tag (byte-compile-make-tag))))
- ;; Now compile FORM
(byte-compile-form form byte-compile--for-effect)
- (byte-compile-out-toplevel byte-compile--for-effect output-type)))
-
-(defun byte-compile-out-toplevel (&optional for-effect output-type)
- ;; OUTPUT-TYPE can be like that of `byte-compile-top-level'.
- (if for-effect
- ;; The stack is empty. Push a value to be returned from (byte-code ..).
- (if (eq (car (car byte-compile-output)) 'byte-discard)
- (setq byte-compile-output (cdr byte-compile-output))
- (byte-compile-push-constant
- ;; Push any constant - preferably one which already is used, and
- ;; a number or symbol - ie not some big sequence. The return value
- ;; isn't returned, but it would be a shame if some textually large
- ;; constant was not optimized away because we chose to return it.
- (and (not (assq nil byte-compile-constants)) ; Nil is often there.
- (let ((tmp (reverse byte-compile-constants)))
- (while (and tmp (not (or (symbolp (caar tmp))
- (numberp (caar tmp)))))
- (setq tmp (cdr tmp)))
- (caar tmp))))))
+ (byte-compile-out-top-level byte-compile--for-effect output-type)))
+
+(defun byte-compile-out-top-level (&optional for-effect output-type)
+ "OUTPUT-TYPE is described in `byte-compile-top-level'."
+ (when for-effect
+ ;; Stack is empty; push a value to be returned from (byte-code ...)
+ (if (eq (car (car byte-compile-output)) 'byte-discard)
+ (setq byte-compile-output (cdr byte-compile-output))
+ (byte-compile-push-constant
+ ;; Push a constant, preferably a previously used symbol or number
+ ;; which would be optimized away should we ever choose to return it.
+ (unless (assq nil byte-compile-constants)
+ (let ((tmp (reverse byte-compile-constants)))
+ (while (and tmp (not (or (symbolp (caar tmp))
+ (numberp (caar tmp)))))
+ (setq tmp (cdr tmp)))
+ (caar tmp))))))
(byte-compile-out 'byte-return 0)
(setq byte-compile-output (nreverse byte-compile-output))
- (if (memq byte-optimize '(t byte))
- (setq byte-compile-output
- (byte-optimize-lapcode byte-compile-output)))
-
- ;; Decompile trivial functions:
- ;; only constants and variables, or a single funcall except in lambdas.
- ;; Except for Lisp_Compiled objects, forms like (foo "hi")
- ;; are still quicker than (byte-code "..." [foo "hi"] 2).
+ (when (memq byte-optimize '(t byte))
+ (setq byte-compile-output (byte-optimize-lapcode byte-compile-output)))
+
+ ;; Decompile trivial constants, variables, or single funcalls
+ ;; excluding lambdas. Except for Lisp_Compiled objects, forms like
+ ;; (foo "hi") are still quicker than (byte-code "..." [foo "hi"] 2).
;; Note that even (quote foo) must be parsed just as any subr by the
- ;; interpreter, so quote should be compiled into byte-code in some contexts.
- ;; What to leave uncompiled:
+ ;; interpreter, so quote should be compiled into byte-code in some
+ ;; contexts.
+
+ ;; What to decompile:
;; lambda -> never. The compiled form is always faster.
;; eval -> atom, quote or (function atom atom atom)
;; file -> as progn, but takes both quotes and atoms, and longer forms.
- (let (rest
- (maycall (not (eq output-type 'lambda))) ; t if we may make a funcall.
- tmp body)
+ (let ((maycall (not (eq output-type 'lambda))) ;; t if we may make a funcall.
+ rest tmp body)
(cond
- ;; #### This should be split out into byte-compile-nontrivial-function-p.
+ ;; This should be split into byte-compile-nontrivial-function-p.
((or (eq output-type 'lambda)
(nthcdr (if (eq output-type 'file) 50 8) byte-compile-output)
(assq 'TAG byte-compile-output) ; Not necessary, but speeds up a bit.
@@ -3267,7 +3146,7 @@ byte-compile-out-toplevel
(eql (length body) (cdr (car rest))) ;bug#34757
(eq (car (nth 1 rest)) 'byte-discard)
(progn (setq rest (cdr rest)) t))))
- (setq maycall nil) ; Only allow one real function call.
+ (setq maycall nil) ;; Only allow one real function call.
(setq body (nreverse body))
(setq body (list
(if (and (eq tmp 'funcall)
@@ -3284,127 +3163,115 @@ byte-compile-out-toplevel
byte-compile-vector byte-compile-maxdepth)))
;; it's a trivial function
((cdr body) (cons 'progn (nreverse body)))
- ((car body)))))
-
-;; Given BODY, compile it and return a new body.
-(defun byte-compile-top-level-body (body &optional for-effect)
- (setq body
- (byte-compile-top-level (cons 'progn body) for-effect t))
- (cond ((eq (car-safe body) 'progn)
- (cdr body))
- (body
- (list body))))
-
-;; Special macro-expander used during byte-compilation.
+ (t (car body)))))
+
(defun byte-compile-macroexpand-declare-function (fn file &rest args)
+ "Special macro-expander used during byte-compilation."
(declare (advertised-calling-convention
(fn file &optional arglist fileonly) nil))
(let ((gotargs (and (consp args) (listp (car args))))
(unresolved (assq fn byte-compile-unresolved-functions)))
- (when unresolved ; function was called before declaration
+ (when unresolved
+ ;; function was called before declaration
(if (and gotargs (byte-compile-warning-enabled-p 'callargs))
(byte-compile-arglist-warn fn (car args) nil)
(setq byte-compile-unresolved-functions
(delq unresolved byte-compile-unresolved-functions))))
(push (cons fn (if gotargs
(list 'declared (car args))
- t)) ; Arglist not specified.
+ t))
byte-compile-function-environment))
;; We are stating that it _will_ be defined at runtime.
(setq byte-compile-noruntime-functions
(delq fn byte-compile-noruntime-functions))
;; Delegate the rest to the normal macro definition.
- (let ((print-symbols-bare t)) ; Possibly redundant binding.
- (macroexpand `(declare-function ,fn ,file ,@args))))
-
-
-;; This is the recursive entry point for compiling each subform of an
-;; expression.
-;; If for-effect is non-nil, byte-compile-form will output a byte-discard
-;; before terminating (ie no value will be left on the stack).
-;; A byte-compile handler may, when byte-compile--for-effect is non-nil, choose
-;; output code which does not leave a value on the stack, and then set
-;; byte-compile--for-effect to nil (to prevent byte-compile-form from
-;; outputting the byte-discard).
-;; If a handler wants to call another handler, it should do so via
-;; byte-compile-form, or take extreme care to handle byte-compile--for-effect
-;; correctly. (Use byte-compile-form-do-effect to reset the
-;; byte-compile--for-effect flag too.)
-;;
+ (macroexpand `(declare-function ,fn ,file ,@args)))
+
+(defsubst byte-compile--decouple-cell (form func)
+ (cond ((atom (car form)) (funcall func form))
+ (t (byte-compile--decouple form func))))
+
+(defun byte-compile--decouple (form func)
+ (unless (circular-list-p form)
+ (if (atom (car form))
+ (byte-compile--decouple-cell form func)
+ (cl-loop with tail = (unless (cl-tailp nil (last form))
+ (last form))
+ for element in form
+ when (or (consp element) (null element))
+ collect (byte-compile--decouple-cell element func) into result
+ finally return (nconc result
+ (when tail
+ (byte-compile--decouple-cell tail
func)))))))
+
(defun byte-compile-form (form &optional for-effect)
- (let ((byte-compile--for-effect for-effect))
- (push form byte-compile-form-stack)
+ "Compiles FORM.
+FOR-EFFECT means FORM is side-effect-only whose meaningless return
+value should be byte-discard."
+ (let ((byte-compile--for-effect for-effect)
+ (byte-compile-current-form form))
(cond
((not (consp form))
(cond ((or (not (symbolp form)) (macroexp--const-symbol-p form))
- (byte-compile-constant
- (if (symbolp form) (bare-symbol form) form)))
+ (byte-compile-constant form))
((and byte-compile--for-effect byte-compile-delete-errors)
(setq byte-compile--for-effect nil))
(t
- (byte-compile-variable-ref (bare-symbol form)))))
+ (byte-compile-variable-ref form))))
((symbolp (car form))
(let* ((fn (car form))
(handler (get fn 'byte-compile))
(interactive-only
(or (get fn 'interactive-only)
(memq fn byte-compile-interactive-only-functions))))
- (when (memq fn '(set symbol-value run-hooks ;; add-to-list
- add-hook remove-hook run-hook-with-args
- run-hook-with-args-until-success
- run-hook-with-args-until-failure))
+ (when (memq fn '(set symbol-value run-hooks
+ add-hook remove-hook run-hook-with-args
+ run-hook-with-args-until-success
+ run-hook-with-args-until-failure))
(pcase (cdr form)
(`(',var . ,_)
(when (memq var byte-compile-lexical-variables)
(byte-compile-report-error
(format-message "%s cannot use lexical var `%s'" fn var))))))
- ;; Warn about using obsolete hooks.
- (if (memq fn '(add-hook remove-hook))
- (let ((hook (car-safe (cdr form))))
- (if (eq (car-safe hook) 'quote)
- (byte-compile-check-variable (cadr hook) nil))))
+ ;; Warn about obsolete hooks.
+ (when (memq fn '(add-hook remove-hook))
+ (let ((hook (car-safe (cdr form))))
+ (when (eq (car-safe hook) 'quote)
+ (byte-compile-check-variable (cadr hook) nil))))
(when (and (byte-compile-warning-enabled-p 'suspicious)
(macroexp--const-symbol-p fn))
- (byte-compile-warn-x fn "`%s' called as a function" fn))
+ (byte-compile-warn "`%s' called as a function" fn))
(when (and (byte-compile-warning-enabled-p 'interactive-only fn)
interactive-only)
- (byte-compile-warn-x fn "`%s' is for interactive use only%s"
- fn
- (cond ((stringp interactive-only)
- (format "; %s"
- (substitute-command-keys
- interactive-only)))
- ((and (symbolp 'interactive-only)
- (not (eq interactive-only t)))
- (format-message "; use `%s' instead."
- interactive-only))
- (t "."))))
- (if (eq (car-safe (symbol-function (car form))) 'macro)
- (byte-compile-report-error
- (format "`%s' defined after use in %S (missing `require' of a
library file?)"
- (car form) form)))
- (if (and handler
- ;; Make sure that function exists.
- (and (functionp handler)
- ;; Ignore obsolete byte-compile function used by former
- ;; CL code to handle compiler macros (we do it
- ;; differently now).
- (not (eq handler 'cl-byte-compile-compiler-macro))))
+ (byte-compile-warn "`%s' is for interactive use only%s"
+ fn
+ (cond ((stringp interactive-only)
+ (format "; %s"
+ (substitute-command-keys
+ interactive-only)))
+ ((and (symbolp 'interactive-only)
+ (not (eq interactive-only t)))
+ (format-message "; use `%s' instead."
+ interactive-only))
+ (t "."))))
+ (when (eq (car-safe (symbol-function (car form))) 'macro)
+ (byte-compile-report-error
+ (format "macro `%s' defined after use in %S (missing require?)"
+ (car form) form)))
+ (if handler
(funcall handler form)
(byte-compile-normal-call form))))
((and (byte-code-function-p (car form))
(memq byte-optimize '(t lap)))
- (byte-compile-unfold-bcf form))
+ (byte-compile-unfold-byte-code-function form))
((and (eq (car-safe (car form)) 'lambda)
- ;; if the form comes out the same way it went in, that's
- ;; because it was malformed, and we couldn't unfold it.
+ ;; FORM must be different after unfold, else malformed
(not (eq form (setq form (macroexp--unfold-lambda form)))))
(byte-compile-form form byte-compile--for-effect)
(setq byte-compile--for-effect nil))
- ((byte-compile-normal-call form)))
- (if byte-compile--for-effect
- (byte-compile-discard))
- (pop byte-compile-form-stack)))
+ (t (byte-compile-normal-call form)))
+ (when byte-compile--for-effect
+ (byte-compile-discard))))
(defun byte-compile-normal-call (form)
(when (and (symbolp (car form))
@@ -3414,15 +3281,14 @@ byte-compile-normal-call
custom-declare-face))
(byte-compile-nogroup-warn form))
(byte-compile-callargs-warn form))
- (if byte-compile-generate-call-tree
- (byte-compile-annotate-call-tree form))
+ (when byte-compile-generate-call-tree
+ (byte-compile-annotate-call-tree form))
(when (and byte-compile--for-effect (eq (car form) 'mapcar)
(byte-compile-warning-enabled-p 'mapcar 'mapcar))
- (byte-compile-warn-x
- (car form)
+ (byte-compile-warn
"`mapcar' called for effect; use `mapc' or `dolist' instead"))
(byte-compile-push-constant (car form))
- (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster.
+ (mapc #'byte-compile-form (cdr form))
(byte-compile-out 'byte-call (length (cdr form))))
@@ -3491,26 +3357,21 @@ byte-compile-inline-lapcode
(byte-compile-out (car op) (cdr op)))))
(byte-compile-out-tag endtag)))
-(defun byte-compile-unfold-bcf (form)
+(defun byte-compile-unfold-byte-code-function (form)
"Inline call to byte-code-functions."
(let* ((byte-compile-bound-variables byte-compile-bound-variables)
(fun (car form))
(fargs (aref fun 0))
(start-depth byte-compile-depth)
- (fmax2 (if (numberp fargs) (ash fargs -7))) ;2*max+rest.
- ;; (fmin (if (numberp fargs) (logand fargs 127)))
+ (fmax2 (when (numberp fargs) (ash fargs -7))) ;; 2*max+rest.
(alen (length (cdr form)))
- (dynbinds ())
- lap)
+ dynbinds lap)
(fetch-bytecode fun)
(setq lap (byte-decompile-bytecode-1 (aref fun 1) (aref fun 2) t))
- ;; optimized switch bytecode makes it impossible to guess the correct
- ;; `byte-compile-depth', which can result in incorrect inlined code.
- ;; therefore, we do not inline code that uses the `byte-switch'
- ;; instruction.
(if (assq 'byte-switch lap)
+ ;; switch occludes `byte-compile-depth' so cannot inline
(byte-compile-normal-call form)
- (mapc 'byte-compile-form (cdr form))
+ (mapc #'byte-compile-form (cdr form))
(unless fmax2
;; Old-style byte-code.
(cl-assert (listp fargs))
@@ -3542,8 +3403,8 @@ byte-compile-unfold-bcf
(byte-compile-out 'byte-listN n)))))
(mapc #'byte-compile-dynamic-variable-bind dynbinds)
(byte-compile-inline-lapcode lap (1+ start-depth))
- ;; Unbind dynamic variables.
(when dynbinds
+ ;; Unbind dynamic variables.
(byte-compile-out 'byte-unbind (length dynbinds)))
(cl-assert (eq byte-compile-depth (1+ start-depth))
nil "Wrong depth start=%s end=%s" start-depth
byte-compile-depth))))
@@ -3553,13 +3414,11 @@ byte-compile-check-variable
(cond ((or (not (symbolp var)) (macroexp--const-symbol-p var))
(when (byte-compile-warning-enabled-p 'constants
(and (symbolp var) var))
- (byte-compile-warn-x
- var
- (if (eq access-type 'let-bind)
- "attempt to let-bind %s `%s'"
- "variable reference to %s `%s'")
- (if (symbolp var) "constant" "nonvariable")
- var)))
+ (byte-compile-warn (if (eq access-type 'let-bind)
+ "attempt to let-bind %s `%s'"
+ "variable reference to %s `%s'")
+ (if (symbolp var) "constant" "nonvariable")
+ (prin1-to-string var))))
((let ((od (get var 'byte-obsolete-variable)))
(and od
(not (memq var byte-compile-not-obsolete-vars))
@@ -3572,7 +3431,6 @@ byte-compile-check-variable
(byte-compile-warn-obsolete var))))
(defsubst byte-compile-dynamic-variable-op (base-op var)
- (if (symbolp var) (setq var (bare-symbol var)))
(let ((tmp (assq var byte-compile-variables)))
(unless tmp
(setq tmp (list var))
@@ -3585,24 +3443,23 @@ byte-compile-dynamic-variable-bind
(push var byte-compile-bound-variables)
(byte-compile-dynamic-variable-op 'byte-varbind var))
-(defun byte-compile-free-vars-warn (arg var &optional assignment)
+(defun byte-compile-free-vars-warn (var &optional assignment)
"Warn if symbol VAR refers to a free variable.
VAR must not be lexically bound.
-ARG is a position argument, used by byte-compile-warn-x.
-If optional argument ASSIGNMENT is non-nil, this is treated as an
-assignment (i.e. `setq')."
- (unless (or (not (byte-compile-warning-enabled-p 'free-vars var))
- (boundp var)
- (memq var byte-compile-bound-variables)
- (memq var (if assignment
- byte-compile-free-assignments
- byte-compile-free-references)))
+The free record for assignment special forms, i.e., setq, is
+kept separately and referenced for non-nil ASSIGNMENT."
+ (when (and (byte-compile-warning-enabled-p 'free-vars var)
+ (not (boundp var))
+ (not (memq var byte-compile-bound-variables))
+ (not (memq var (if assignment
+ byte-compile-free-assignments
+ byte-compile-free-references))))
(let* ((varname (prin1-to-string var))
(desc (if assignment "assignment" "reference"))
(suggestions (help-uni-confusable-suggestions varname)))
- (byte-compile-warn-x arg "%s to free variable `%s'%s"
- desc var
- (if suggestions (concat "\n " suggestions) "")))
+ (byte-compile-warn "%s to free variable `%s'%s"
+ desc varname
+ (if suggestions (concat "\n " suggestions) "")))
(push var (if assignment
byte-compile-free-assignments
byte-compile-free-references))))
@@ -3612,10 +3469,8 @@ byte-compile-variable-ref
(byte-compile-check-variable var 'reference)
(let ((lex-binding (assq var byte-compile--lexical-environment)))
(if lex-binding
- ;; VAR is lexically bound
(byte-compile-stack-ref (cdr lex-binding))
- ;; VAR is dynamically bound
- (byte-compile-free-vars-warn var var)
+ (byte-compile-free-vars-warn var)
(byte-compile-dynamic-variable-op 'byte-varref var))))
(defun byte-compile-variable-set (var)
@@ -3623,10 +3478,8 @@ byte-compile-variable-set
(byte-compile-check-variable var 'assign)
(let ((lex-binding (assq var byte-compile--lexical-environment)))
(if lex-binding
- ;; VAR is lexically bound.
(byte-compile-stack-set (cdr lex-binding))
- ;; VAR is dynamically bound.
- (byte-compile-free-vars-warn var var t)
+ (byte-compile-free-vars-warn var t)
(byte-compile-dynamic-variable-op 'byte-varset var))))
(defmacro byte-compile-get-constant (const)
@@ -3646,30 +3499,25 @@ byte-compile-get-constant
(defun byte-compile-constant (const)
(if byte-compile--for-effect
(setq byte-compile--for-effect nil)
- (inline (byte-compile-push-constant
- (if (symbolp const) (bare-symbol const) const)))))
+ (byte-compile-push-constant const)))
;; Use this for a constant that is not the value of its containing form.
;; This ignores byte-compile--for-effect.
(defun byte-compile-push-constant (const)
- (when (symbolp const)
- (setq const (bare-symbol const)))
- (byte-compile-out
- 'byte-constant
- (byte-compile-get-constant const)))
-
-;; Compile those primitive ordinary functions
-;; which have special byte codes just for speed.
+ "Use this for a constant that is not the value of its containing form.
+This ignores byte-compile--for-effect."
+ (byte-compile-out 'byte-constant (byte-compile-get-constant const)))
(defmacro byte-defop-compiler (function &optional compile-handler)
- "Add a compiler-form for FUNCTION.
-If function is a symbol, then the variable \"byte-SYMBOL\" must name
-the opcode to be used. If function is a list, the first element
-is the function and the second element is the bytecode-symbol.
-The second element may be nil, meaning there is no opcode.
-COMPILE-HANDLER is the function to use to compile this byte-op, or
-may be the abbreviations 0, 1, 2, 2-and, 3, 0-1, 1-2, 1-3, or 2-3.
-If it is nil, then the handler is \"byte-compile-SYMBOL.\""
+ "Construct a lisp form compiling FUNCTION.
+
+If FUNCTION is a symbol, the opcode used is byte-FUNCTION.
+FUNCTION may also be a list (FUNCTION OPCODE), where OPCODE may
+be nil signifying no opcode.
+
+COMPILE-HANDLER is a function to compile OPCODE, or the
+abbreviations 0, 1, 2, 2-and, 3, 0-1, 1-2, 1-3, or 2-3. It
+defaults to byte-compile-FUNCTION."
(let (opcode)
(if (symbolp function)
(setq opcode (intern (concat "byte-" (symbol-name function))))
@@ -3687,8 +3535,7 @@ byte-defop-compiler
(0-1 . byte-compile-zero-or-one-arg)
(1-2 . byte-compile-one-or-two-args)
(2-3 . byte-compile-two-or-three-args)
- (1-3 . byte-compile-one-to-three-args)
- )))
+ (1-3 .
byte-compile-one-to-three-args))))
compile-handler
(intern (concat "byte-compile-"
(symbol-name function))))))))
@@ -3703,7 +3550,6 @@ byte-defop-compiler
(defmacro byte-defop-compiler-1 (function &optional compile-handler)
(list 'byte-defop-compiler (list function nil) compile-handler))
-
(put 'byte-call 'byte-opcode-invert 'funcall)
(put 'byte-list1 'byte-opcode-invert 'list)
(put 'byte-list2 'byte-opcode-invert 'list)
@@ -3717,7 +3563,6 @@ byte-defop-compiler-1
(put 'byte-insertN 'byte-opcode-invert 'insert)
(byte-defop-compiler point 0)
-;;(byte-defop-compiler mark 0) ;; obsolete
(byte-defop-compiler point-max 0)
(byte-defop-compiler point-min 0)
(byte-defop-compiler following-char 0)
@@ -3728,8 +3573,6 @@ eobp
(byte-defop-compiler bolp 0)
(byte-defop-compiler bobp 0)
(byte-defop-compiler current-buffer 0)
-;;(byte-defop-compiler read-char 0) ;; obsolete
-;; (byte-defop-compiler interactive-p 0) ;; Obsolete.
(byte-defop-compiler widen 0)
(byte-defop-compiler end-of-line 0-1)
(byte-defop-compiler forward-char 0-1)
@@ -3750,7 +3593,6 @@ symbol-function
(byte-defop-compiler goto-char 1)
(byte-defop-compiler char-after 0-1)
(byte-defop-compiler set-buffer 1)
-;;(byte-defop-compiler set-mark 1) ;; obsolete
(byte-defop-compiler forward-word 0-1)
(byte-defop-compiler char-syntax 1)
(byte-defop-compiler nreverse 1)
@@ -3806,12 +3648,10 @@ min
;;####(byte-defop-compiler move-to-column 1)
(byte-defop-compiler-1 interactive byte-compile-noop)
-
(defun byte-compile-subr-wrong-args (form n)
- (byte-compile-warn-x (car form)
- "`%s' called with %d arg%s, but requires %s"
- (car form) (length (cdr form))
- (if (= 1 (length (cdr form))) "" "s") n)
+ (byte-compile-warn "`%s' called with %d arg%s, but requires %s"
+ (car form) (length (cdr form))
+ (if (= 1 (length (cdr form))) "" "s") n)
;; Get run-time wrong-number-of-args error.
(byte-compile-normal-call form))
@@ -3840,8 +3680,7 @@ byte-compile-and-folded
(cond
((< l 3) (byte-compile-form `(progn ,(nth 1 form) t)))
((= l 3) (byte-compile-two-args form))
- ;; Don't use `cl-every' here (see comment where we require cl-lib).
- ((not (memq nil (mapcar #'macroexp-copyable-p (nthcdr 2 form))))
+ ((cl-every #'identity (mapcar #'macroexp-copyable-p (nthcdr 2 form)))
(byte-compile-form `(and (,(car form) ,(nth 1 form) ,(nth 2 form))
(,(car form) ,@(nthcdr 2 form)))))
(t (byte-compile-normal-call form)))))
@@ -3888,12 +3727,9 @@ byte-compile-discard
If PRESERVE-TOS is non-nil, preserve the top-of-stack value, as if it were
popped before discarding the num values, and then pushed back again after
discarding."
- (if (and (null num) (not preserve-tos))
- ;; common case
+ (if (and (not num) (not preserve-tos))
(byte-compile-out 'byte-discard)
- ;; general case
- (unless num
- (setq num 1))
+ (setq num (or num 1))
(when (and preserve-tos (> num 0))
;; Preserve the top-of-stack value by writing it directly to the stack
;; location which will be at the top-of-stack after popping.
@@ -3922,14 +3758,14 @@ internal-make-closure
(byte-defop-compiler-1 internal-get-closed-var byte-compile-get-closed-var)
(defun byte-compile-make-closure (form)
- "Byte-compile the special `internal-make-closure' form."
- (if byte-compile--for-effect (setq byte-compile--for-effect nil)
+ "Special internal-make-closure form."
+ (if byte-compile--for-effect
+ (setq byte-compile--for-effect nil)
(let* ((vars (nth 1 form))
(env (nth 2 form))
(docstring-exp (nth 3 form))
(body (nthcdr 4 form))
- (fun
- (byte-compile-lambda `(lambda ,vars . ,body) nil (length env))))
+ (fun (byte-compile-lambda `(lambda ,vars . ,body) nil (length
env))))
(cl-assert (or (> (length env) 0)
docstring-exp)) ;Otherwise, we don't need a closure.
(cl-assert (byte-code-function-p fun))
@@ -3967,8 +3803,9 @@ byte-compile-make-closure
))))
(defun byte-compile-get-closed-var (form)
- "Byte-compile the special `internal-get-closed-var' form."
- (if byte-compile--for-effect (setq byte-compile--for-effect nil)
+ "Special internal-get-closed-var form."
+ (if byte-compile--for-effect
+ (setq byte-compile--for-effect nil)
(byte-compile-out 'byte-constant (nth 1 form))))
;; Compile a pure function that accepts zero or more numeric arguments
@@ -4002,9 +3839,6 @@ byte-compile-min-max
;; No args: warn and emit code that raises an error when executed.
(byte-compile-normal-call form)))
-
-;; more complicated compiler macros
-
(byte-defop-compiler char-before)
(byte-defop-compiler backward-char)
(byte-defop-compiler backward-word)
@@ -4019,8 +3853,8 @@ function
(byte-defop-compiler (/ byte-quo) byte-compile-quo)
(byte-defop-compiler nconc)
-;; Is this worth it? Both -before and -after are written in C.
(defun byte-compile-char-before (form)
+ "Is this worth it? Both -before and -after are written in C."
(cond ((or (= 1 (length form))
(and (= 2 (length form)) (not (nth 1 form))))
(byte-compile-form '(char-after (1- (point)))))
@@ -4031,9 +3865,9 @@ byte-compile-char-before
(point)))))))
(t (byte-compile-subr-wrong-args form "0-1"))))
-;; backward-... ==> forward-... with negated argument.
-;; Is this worth it? Both -backward and -forward are written in C.
(defun byte-compile-backward-char (form)
+ "backward-... ==> forward-... with negated argument.
+Is this worth it? Both -backward and -forward are written in C."
(cond ((or (= 1 (length form))
(and (= 2 (length form)) (not (nth 1 form))))
(byte-compile-form '(forward-char -1)))
@@ -4058,18 +3892,18 @@ byte-compile-list
(cond ((= count 0)
(byte-compile-constant nil))
((< count 5)
- (mapc 'byte-compile-form (cdr form))
- (byte-compile-out
- (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- count)) 0))
+ (mapc #'byte-compile-form (cdr form))
+ (byte-compile-out
+ (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- count)) 0))
((< count 256)
- (mapc 'byte-compile-form (cdr form))
+ (mapc #'byte-compile-form (cdr form))
(byte-compile-out 'byte-listN count))
(t (byte-compile-normal-call form)))))
(defun byte-compile-concat (form)
(let ((count (length (cdr form))))
(cond ((and (< 1 count) (< count 5))
- (mapc 'byte-compile-form (cdr form))
+ (mapc #'byte-compile-form (cdr form))
(byte-compile-out
(aref [byte-concat2 byte-concat3 byte-concat4] (- count 2))
0))
@@ -4077,7 +3911,7 @@ byte-compile-concat
((= count 0)
(byte-compile-form ""))
((< count 256)
- (mapc 'byte-compile-form (cdr form))
+ (mapc #'byte-compile-form (cdr form))
(byte-compile-out 'byte-concatN count))
((byte-compile-normal-call form)))))
@@ -4108,35 +3942,34 @@ byte-compile-nconc
(byte-compile-out 'byte-nconc 0))))))
(defun byte-compile-fset (form)
- ;; warn about forms like (fset 'foo '(lambda () ...))
- ;; (where the lambda expression is non-trivial...)
+ "Warn about forms like (fset 'foo '(lambda () ...))
+ (where the lambda expression is non-trivial...)"
(let ((fn (nth 2 form))
body)
(if (and (eq (car-safe fn) 'quote)
(eq (car-safe (setq fn (nth 1 fn))) 'lambda))
(progn
(setq body (cdr (cdr fn)))
- (if (stringp (car body)) (setq body (cdr body)))
- (if (eq 'interactive (car-safe (car body))) (setq body (cdr body)))
- (if (and (consp (car body))
- (not (eq 'byte-code (car (car body)))))
- (byte-compile-warn-x
- (nth 2 form)
- "A quoted lambda form is the second argument of `fset'. This is probably
+ (when (stringp (car body))
+ (setq body (cdr body)))
+ (when (eq 'interactive (car-safe (car body)))
+ (setq body (cdr body)))
+ (when (and (consp (car body))
+ (not (eq 'byte-code (car (car body)))))
+ (byte-compile-warn
+ "A quoted lambda form is the second argument of `fset'. This is
probably
not what you want, as that lambda cannot be compiled. Consider using
the syntax #'(lambda (...) ...) instead.")))))
(byte-compile-two-args form))
-;; (function foo) must compile like 'foo, not like (symbol-function 'foo).
-;; Otherwise it will be incompatible with the interpreter,
-;; and (funcall (function foo)) will lose with autoloads.
-
(defun byte-compile-function-form (form)
+ "(function foo) must compile like 'foo, not like (symbol-function 'foo).
+Otherwise it will be incompatible with the interpreter,
+and (funcall (function foo)) will lose with autoloads."
(let ((f (nth 1 form)))
(when (and (symbolp f)
(byte-compile-warning-enabled-p 'callargs f))
(byte-compile-function-warn f t (byte-compile-fdefinition f nil)))
-
(byte-compile-constant (if (eq 'lambda (car-safe f))
(byte-compile-lambda f)
f))))
@@ -4156,21 +3989,20 @@ byte-compile-insert
(cond ((null (cdr form))
(byte-compile-constant nil))
((<= (length form) 256)
- (mapc 'byte-compile-form (cdr form))
+ (mapc #'byte-compile-form (cdr form))
(if (cdr (cdr form))
(byte-compile-out 'byte-insertN (length (cdr form)))
(byte-compile-out 'byte-insert 0)))
((memq t (mapcar 'consp (cdr (cdr form))))
(byte-compile-normal-call form))
- ;; We can split it; there is no function call after inserting 1st arg.
(t
+ ;; We can split it; there is no function call after inserting 1st arg.
(while (setq form (cdr form))
(byte-compile-form (car form))
(byte-compile-out 'byte-insert 0)
- (if (cdr form)
- (byte-compile-discard))))))
+ (when (cdr form)
+ (byte-compile-discard))))))
-
(byte-defop-compiler-1 setq)
(byte-defop-compiler-1 quote)
@@ -4206,17 +4038,14 @@ byte-compile-set-default
(macroexp--const-symbol-p var t))
(byte-compile-warning-enabled-p 'constants
(and (symbolp var) var))
- (byte-compile-warn-x
- var
+ (byte-compile-warn
"variable assignment to %s `%s'"
(if (symbolp var) "constant" "nonvariable")
- var))))
+ (prin1-to-string var)))))
(byte-compile-normal-call form)))
(defun byte-compile-quote (form)
(byte-compile-constant (car (cdr form))))
-
-;;; control structures
(defun byte-compile-body (body &optional for-effect)
(while (cdr body)
@@ -4264,11 +4093,11 @@ byte-compile-ignore
(byte-compile-form arg t))
(byte-compile-form nil))
-;; Return the list of items in CONDITION-PARAM that match PRED-LIST.
-;; Only return items that are not in ONLY-IF-NOT-PRESENT.
(defun byte-compile-find-bound-condition (condition-param
pred-list
&optional only-if-not-present)
+ "Return the list of items in CONDITION-PARAM that match PRED-LIST.
+Only return items that are not in ONLY-IF-NOT-PRESENT."
(let ((result nil)
(nth-one nil)
(cond-list
@@ -4604,16 +4433,13 @@ byte-compile-while
(defun byte-compile-funcall (form)
(if (cdr form)
(progn
- (mapc 'byte-compile-form (cdr form))
+ (mapc #'byte-compile-form (cdr form))
(byte-compile-out 'byte-call (length (cdr (cdr form)))))
(byte-compile-report-error
(format-message "`funcall' called with no arguments"))
(byte-compile-form '(signal 'wrong-number-of-arguments '(funcall 0))
byte-compile--for-effect)))
-
-;; let binding
-
(defun byte-compile-push-binding-init (clause)
"Emit byte-codes to push the initialization value for CLAUSE on the stack.
Return the offset in the form (VAR . OFFSET)."
@@ -4727,7 +4553,7 @@ byte-compile-let
(byte-compile-unbind clauses init-lexenv
(> byte-compile-depth init-stack-depth))))))
-
+
(byte-defop-compiler-1 /= byte-compile-negated)
(byte-defop-compiler-1 atom byte-compile-negated)
@@ -4749,8 +4575,6 @@ byte-compile-negation-optimizer
"Compiler error: `%s' has no `byte-compile-negated-op' property"
(car form)))
(cdr form))))
-
-;;; other tricky macro-like special-forms
(byte-defop-compiler-1 catch)
(byte-defop-compiler-1 unwind-protect)
@@ -4758,8 +4582,6 @@ condition-case
(byte-defop-compiler-1 save-excursion)
(byte-defop-compiler-1 save-current-buffer)
(byte-defop-compiler-1 save-restriction)
-;; (byte-defop-compiler-1 save-window-excursion) ;Obsolete: now a macro.
-;; (byte-defop-compiler-1 with-output-to-temp-buffer) ;Obsolete: now a macro.
(defun byte-compile-catch (form)
(byte-compile-form (car (cdr form)))
@@ -4793,16 +4615,15 @@ byte-compile-condition-case
failure-handlers))
(endtag (byte-compile-make-tag)))
(unless (symbolp var)
- (byte-compile-warn-x
- var "`%s' is not a variable-name or nil (in condition-case)" var))
+ (byte-compile-warn "`%s' is not a variable-name or nil (in
condition-case)"
+ var))
(dolist (clause (reverse clauses))
(let ((condition (nth 1 clause)))
(unless (consp condition) (setq condition (list condition)))
(dolist (c condition)
(unless (and c (symbolp c))
- (byte-compile-warn-x
- c "`%S' is not a condition name (in condition-case)" c))
+ (byte-compile-warn "`%S' is not a condition name (in
condition-case)" c))
;; In reality, the `error-conditions' property is only required
;; for the argument to `signal', not to `condition-case'.
;;(unless (consp (get c 'error-conditions))
@@ -4853,8 +4674,7 @@ byte-compile-condition-case
(defun byte-compile-save-excursion (form)
(if (and (eq 'set-buffer (car-safe (car-safe (cdr form))))
(byte-compile-warning-enabled-p 'suspicious 'set-buffer))
- (byte-compile-warn-x
- form
+ (byte-compile-warn
"Use `with-current-buffer' rather than save-excursion+set-buffer"))
(byte-compile-out 'byte-save-excursion 0)
(byte-compile-body-do-effect (cdr form))
@@ -4869,7 +4689,7 @@ byte-compile-save-current-buffer
(byte-compile-out 'byte-save-current-buffer 0)
(byte-compile-body-do-effect (cdr form))
(byte-compile-out 'byte-unbind 1))
-
+
;;; top-level forms elsewhere
(byte-defop-compiler-1 defvar)
@@ -4895,10 +4715,8 @@ byte-compile-defvar
(when (and (symbolp (nth 1 form))
(not (string-match "[-*/:$]" (symbol-name (nth 1 form))))
(byte-compile-warning-enabled-p 'lexical (nth 1 form)))
- (byte-compile-warn-x
- (nth 1 form)
- "global/dynamic var `%s' lacks a prefix"
- (nth 1 form)))
+ (byte-compile-warn "global/dynamic var `%s' lacks a prefix"
+ (nth 1 form)))
(byte-compile-docstring-length-warn form)
(let ((fun (nth 0 form))
(var (nth 1 form))
@@ -4907,21 +4725,17 @@ byte-compile-defvar
(when (or (> (length form) 4)
(and (eq fun 'defconst) (null (cddr form))))
(let ((ncall (length (cdr form))))
- (byte-compile-warn-x
- fun
- "`%s' called with %d argument%s, but %s %s"
- fun ncall
- (if (= 1 ncall) "" "s")
- (if (< ncall 2) "requires" "accepts only")
- "2-3")))
+ (byte-compile-warn "`%s' called with %d argument%s, but %s %s"
+ fun ncall
+ (if (= 1 ncall) "" "s")
+ (if (< ncall 2) "requires" "accepts only")
+ "2-3")))
(push var byte-compile-bound-variables)
- (if (eq fun 'defconst)
- (push var byte-compile-const-variables))
+ (when (eq fun 'defconst)
+ (push var byte-compile-const-variables))
(when (and string (not (stringp string)))
- (byte-compile-warn-x
- string
- "third arg to `%s %s' is not a string: %s"
- fun var string))
+ (byte-compile-warn "third arg to `%s %s' is not a string: %s"
+ fun var string))
(byte-compile-form-do-effect
(if (cddr form) ; `value' provided
;; Quote with `quote' to prevent byte-compiling the body,
@@ -4940,33 +4754,23 @@ byte-compile-autoload
(macroexp-const-p (nth 5 form))
(memq (eval (nth 5 form)) '(t macro)) ; macro-p
(not (fboundp (eval (nth 1 form))))
- (byte-compile-warn-x
- form
+ (byte-compile-warn
"The compiler ignores `autoload' except at top level. You should
probably put the autoload of the macro `%s' at top-level."
(eval (nth 1 form))))
(byte-compile-normal-call form))
-;; Lambdas in valid places are handled as special cases by various code.
-;; The ones that remain are errors.
(defun byte-compile-lambda-form (_form)
+ "Any lambdas heretofore unhandled are errors."
(error "`lambda' used as function name is invalid"))
-;; Compile normally, but deal with warnings for the function being defined.
(put 'defalias 'byte-hunk-handler 'byte-compile-file-form-defalias)
-;; Used for eieio--defalias as well.
(defun byte-compile-file-form-defalias (form)
- ;; For the compilation itself, we could largely get rid of this hunk-handler,
- ;; if it weren't for the fact that we need to figure out when a defalias
- ;; defines a macro, so as to add it to byte-compile-macro-environment.
- ;;
- ;; FIXME: we also use this hunk-handler to implement the function's
- ;; dynamic docstring feature (via byte-compile-file-form-defmumble).
- ;; We should actually implement it (more elegantly) in
- ;; byte-compile-lambda so it applies to all lambdas. We did it here
- ;; so the resulting .elc format was recognizable by make-docfile,
- ;; but since then we stopped using DOC for the docstrings of
- ;; preloaded elc files so that obstacle is gone.
+ "When a defalias defines a macro, add it to byte-compile-macro-environment.
+
+This should be subsumed in byte-compile-lambda now that
+make-docfile is obsolete (and consequently, the elc docstrings no
+longer need to hew to its rules)."
(let ((byte-compile-free-references nil)
(byte-compile-free-assignments nil))
(pcase form
@@ -4993,22 +4797,9 @@ byte-compile-file-form-defalias
(and `(internal-make-closure ,arglist . ,_) (let body t))
(and (let arglist t) (let body t)))
lam))
- (unless (byte-compile-file-form-defmumble
- name macro arglist body rest)
- (when macro
- (if (null fun)
- (message "Macro %s unrecognized, won't work in file" name)
- (message "Macro %s partly recognized, trying our luck" name)
- (push (cons name (eval fun))
- byte-compile-macro-environment)))
+ (unless (byte-compile-file-form-defalias* name macro arglist
+ body rest)
(byte-compile-keep-pending form))))
-
- ;; We used to just do: (byte-compile-normal-call form)
- ;; But it turns out that this fails to optimize the code.
- ;; So instead we now do the same as what other byte-hunk-handlers do,
- ;; which is to call back byte-compile-file-form and then return nil.
- ;; Except that we can't just call byte-compile-file-form since it would
- ;; call us right back.
(_ (byte-compile-keep-pending form)))))
(byte-defop-compiler-1 with-no-warnings byte-compile-no-warnings)
@@ -5027,11 +4818,10 @@ byte-compile-suppressed-warnings
(byte-defop-compiler-1 make-variable-buffer-local
byte-compile-make-variable-buffer-local)
(defun byte-compile-make-variable-buffer-local (form)
- (if (and (eq (car-safe (car-safe (cdr-safe form))) 'quote)
- (byte-compile-warning-enabled-p 'make-local))
- (byte-compile-warn-x
- form
- "`make-variable-buffer-local' not called at toplevel"))
+ (when (and (eq (car-safe (car-safe (cdr-safe form))) 'quote)
+ (byte-compile-warning-enabled-p 'make-local))
+ (byte-compile-warn
+ "`make-variable-buffer-local' not called at toplevel"))
(byte-compile-normal-call form))
(put 'make-variable-buffer-local
'byte-hunk-handler 'byte-compile-form-make-variable-buffer-local)
@@ -5070,13 +4860,10 @@ byte-compile-define-symbol-prop
. (,prop ,val ,@(alist-get fun overriding-plist-environment)))
overriding-plist-environment)
(byte-compile-push-constant val)
- (byte-compile-out 'byte-call 3)
- nil))
-
+ (byte-compile-out 'byte-call 3)))
(_ (byte-compile-keep-pending form))))
-
;;; tags
;; Note: Most operations will strip off the 'TAG, but it speeds up
@@ -5122,37 +4909,29 @@ byte-compile-stack-adjustment
(defun byte-compile-out (op &optional operand)
(push (cons op operand) byte-compile-output)
(if (eq op 'byte-return)
- ;; This is actually an unnecessary case, because there should be no
- ;; more ops behind byte-return.
+ ;; Consider abort since byte-return no longer produces ops
(setq byte-compile-depth nil)
(setq byte-compile-depth
(+ byte-compile-depth (byte-compile-stack-adjustment op operand)))
- (setq byte-compile-maxdepth (max byte-compile-depth byte-compile-maxdepth))
- ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow"))
- ))
-
-;;; call tree stuff
+ (setq byte-compile-maxdepth (max byte-compile-depth
byte-compile-maxdepth))))
(defun byte-compile-annotate-call-tree (form)
- (let ((current-form (byte-run-strip-symbol-positions
- byte-compile-current-form))
- (bare-car-form (byte-run-strip-symbol-positions (car form)))
- entry)
+ (let (entry)
;; annotate the current call
- (if (setq entry (assq bare-car-form byte-compile-call-tree))
- (or (memq current-form (nth 1 entry)) ;callers
+ (if (setq entry (assq (car form) byte-compile-call-tree))
+ (or (memq byte-compile-current-func (nth 1 entry)) ;callers
(setcar (cdr entry)
- (cons current-form (nth 1 entry))))
+ (cons byte-compile-current-func (nth 1 entry))))
(setq byte-compile-call-tree
- (cons (list bare-car-form (list current-form) nil)
+ (cons (list (car form) (list byte-compile-current-func) nil)
byte-compile-call-tree)))
;; annotate the current function
- (if (setq entry (assq current-form byte-compile-call-tree))
- (or (memq bare-car-form (nth 2 entry)) ;called
+ (if (setq entry (assq byte-compile-current-func byte-compile-call-tree))
+ (or (memq (car form) (nth 2 entry)) ;called
(setcar (cdr (cdr entry))
- (cons bare-car-form (nth 2 entry))))
+ (cons (car form) (nth 2 entry))))
(setq byte-compile-call-tree
- (cons (list current-form nil (list bare-car-form))
+ (cons (list byte-compile-current-func nil (list (car form)))
byte-compile-call-tree)))))
;; Renamed from byte-compile-report-call-tree
@@ -5178,15 +4957,14 @@ display-call-tree
(set-buffer "*Call-Tree*")
(erase-buffer)
(message "Generating call tree... (sorting on %s)"
- (remove-pos-from-symbol byte-compile-call-tree-sort))
+ byte-compile-call-tree-sort)
(insert "Call tree for "
(cond ((null byte-compile-current-file) (or filename "???"))
((stringp byte-compile-current-file)
byte-compile-current-file)
(t (buffer-name byte-compile-current-file)))
" sorted on "
- (prin1-to-string (remove-pos-from-symbol
- byte-compile-call-tree-sort))
+ (prin1-to-string byte-compile-call-tree-sort)
":\n\n")
(if byte-compile-call-tree-sort
(setq byte-compile-call-tree
@@ -5206,8 +4984,7 @@ display-call-tree
('name
(lambda (x y) (string< (car x) (car y))))
(_ (error "`byte-compile-call-tree-sort': `%s' - unknown
sort mode"
- (remove-pos-from-symbol
- byte-compile-call-tree-sort)))))))
+ byte-compile-call-tree-sort))))))
(message "Generating call tree...")
(let ((rest byte-compile-call-tree)
(b (current-buffer))
@@ -5296,7 +5073,7 @@ display-call-tree
(fill-region-as-paragraph p (point))))))
(message "Generating call tree...done.")))
-
+
;;;###autoload
(defun batch-byte-compile-if-not-done ()
"Like `byte-compile-file' but doesn't recompile if already up to date.
@@ -5449,7 +5226,7 @@ batch-byte-recompile-directory
(provide 'byte-compile)
(provide 'bytecomp)
-
+
;;; report metering (see the hacks in bytecode.c)
(defvar byte-code-meter)
@@ -5479,30 +5256,28 @@ byte-compile-report-ops
(indent-to 40)
(insert (int-to-string n) "\n")))
(setq i (1+ i))))))
-
-;; To avoid "lisp nesting exceeds max-lisp-eval-depth" when bytecomp compiles
-;; itself, compile some of its most used recursive functions (at load time).
-;;
+
+;; Compile at load-time most frequently used recursive methods to
+;; avoid "lisp nesting exceeds max-lisp-eval-depth" errors.
(eval-when-compile
- (or (byte-code-function-p (symbol-function 'byte-compile-form))
- (subr-native-elisp-p (symbol-function 'byte-compile-form))
- (assq 'byte-code (symbol-function 'byte-compile-form))
- (let ((byte-optimize nil) ; do it fast
- (byte-compile-warnings nil))
- (mapc (lambda (x)
- (unless (subr-native-elisp-p x)
- (or noninteractive (message "compiling %s..." x))
- (byte-compile x)
- (or noninteractive (message "compiling %s...done" x))))
- '(byte-compile-normal-call
- byte-compile-form
- byte-compile-body
- ;; Inserted some more than necessary, to speed it up.
- byte-compile-top-level
- byte-compile-out-toplevel
- byte-compile-constant
- byte-compile-variable-ref))))
- nil)
+ (prog1 nil
+ (or (byte-code-function-p (symbol-function 'byte-compile-form))
+ (subr-native-elisp-p (symbol-function 'byte-compile-form))
+ (assq 'byte-code (symbol-function 'byte-compile-form))
+ (let ((byte-optimize nil) ; do it fast
+ (byte-compile-warnings nil))
+ (mapc (lambda (x)
+ (unless (subr-native-elisp-p x)
+ (or noninteractive (message "compiling %s..." x))
+ (byte-compile x)
+ (or noninteractive (message "compiling %s...done" x))))
+ '(byte-compile-normal-call
+ byte-compile-form
+ byte-compile-body
+ byte-compile-top-level
+ byte-compile-out-top-level
+ byte-compile-constant
+ byte-compile-variable-ref))))))
(make-obsolete-variable 'bytecomp-load-hook
"use `with-eval-after-load' instead." "28.1")
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index c16619bc45d..70bc9de0941 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -262,7 +262,7 @@ cconv--warn-unused-msg
(eq var 'ignored))
(let ((suggestions (help-uni-confusable-suggestions (symbol-name var))))
(format "Unused lexical %s `%S'%s"
- varkind (bare-symbol var)
+ varkind var
(if suggestions (concat "\n " suggestions) "")))))
(define-inline cconv--var-classification (binder form)
@@ -286,7 +286,7 @@ cconv--convert-funcbody
(let (and (pred stringp) msg)
(cconv--warn-unused-msg arg "argument")))
(if (assq arg env) (push `(,arg . nil) env)) ;FIXME: Is it needed?
- (push (lambda (body) (macroexp--warn-wrap arg msg body 'lexical))
wrappers))
+ (push (lambda (body) (macroexp--warn-wrap msg body 'lexical))
wrappers))
(_
(if (assq arg env) (push `(,arg . nil) env)))))
(setq funcbody (mapcar (lambda (form)
@@ -367,8 +367,7 @@ cconv-convert
(var (if (not (consp binder))
(prog1 binder (setq binder (list binder)))
(when (cddr binder)
- (byte-compile-warn-x
- binder
+ (byte-compile-warn
"Malformed `%S' binding: %S"
letsym binder))
(setq value (cadr binder))
@@ -376,9 +375,9 @@ cconv-convert
(cond
;; Ignore bindings without a valid name.
((not (symbolp var))
- (byte-compile-warn-x var "attempt to let-bind nonvariable `%S'"
var))
+ (byte-compile-warn "attempt to let-bind nonvariable `%S'" var))
((or (booleanp var) (keywordp var))
- (byte-compile-warn-x var "attempt to let-bind constant `%S'" var))
+ (byte-compile-warn "attempt to let-bind constant `%S'" var))
(t
(let ((new-val
(pcase (cconv--var-classification binder form)
@@ -428,14 +427,11 @@ cconv-convert
;; Declared variable is unused.
(if (assq var new-env)
(push `(,var) new-env)) ;FIXME:Needed?
- (let* ((Ignore (if (symbol-with-pos-p var)
- (position-symbol 'ignore var)
- 'ignore))
- (newval `(,Ignore
- ,(cconv-convert value env extend)))
- (msg (cconv--warn-unused-msg var "variable")))
+ (let ((newval
+ `(ignore ,(cconv-convert value env extend)))
+ (msg (cconv--warn-unused-msg var "variable")))
(if (null msg) newval
- (macroexp--warn-wrap var msg newval 'lexical))))
+ (macroexp--warn-wrap msg newval 'lexical))))
;; Normal default case.
(_
@@ -534,7 +530,7 @@ cconv-convert
(newprotform (cconv-convert protected-form env extend)))
`(condition-case ,var
,(if msg
- (macroexp--warn-wrap var msg newprotform 'lexical)
+ (macroexp--warn-wrap msg newprotform 'lexical)
newprotform)
,@(mapcar
(lambda (handler)
@@ -628,8 +624,7 @@ cconv--analyze-use
;; FIXME: Convert this warning to use `macroexp--warn-wrap'
;; so as to give better position information.
(when (byte-compile-warning-enabled-p 'not-unused var)
- (byte-compile-warn-x
- var "%s `%S' not left unused" varkind var)))
+ (byte-compile-warn "%s `%S' not left unused" varkind var)))
((and (let (or 'let* 'let) (car form))
`((,var) ;; (or `(,var nil) : Too many false positives: bug#47080
t nil ,_ ,_))
@@ -637,7 +632,7 @@ cconv--analyze-use
;; so as to give better position information and obey
;; `byte-compile-warnings'.
(unless (not (intern-soft var))
- (byte-compile-warn-x var "Variable `%S' left uninitialized" var))))
+ (byte-compile-warn "Variable `%S' left uninitialized" var))))
(pcase vardata
(`(,binder nil ,_ ,_ nil)
(push (cons (cons binder form) :unused) cconv-var-classification))
@@ -666,8 +661,7 @@ cconv--analyze-function
(dolist (arg args)
(cond
((byte-compile-not-lexical-var-p arg)
- (byte-compile-warn-x
- arg
+ (byte-compile-warn
"Lexical argument shadows the dynamic variable %S"
arg))
((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ...
@@ -750,8 +744,7 @@ cconv-analyze-form
(setq forms (cddr forms))))
(`((lambda . ,_) . ,_) ; First element is lambda expression.
- (byte-compile-warn-x
- (nth 1 (car form))
+ (byte-compile-warn
"Use of deprecated ((lambda %s ...) ...) form" (nth 1 (car form)))
(dolist (exp `((function ,(car form)) . ,(cdr form)))
(cconv-analyze-form exp env)))
@@ -770,8 +763,8 @@ cconv-analyze-form
(`(condition-case ,var ,protected-form . ,handlers)
(cconv-analyze-form protected-form env)
(when (and var (symbolp var) (byte-compile-not-lexical-var-p var))
- (byte-compile-warn-x
- var "Lexical variable shadows the dynamic variable %S" var))
+ (byte-compile-warn
+ "Lexical variable shadows the dynamic variable %S" var))
(let* ((varstruct (list var nil nil nil nil)))
(if var (push varstruct env))
(dolist (handler handlers)
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 5e0e0834fff..a7d25d070f0 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -498,8 +498,7 @@ cl-defmethod
cl--generic-edebug-make-name nil]
lambda-doc ; documentation string
def-body))) ; part to be debugged
- (let ((qualifiers nil)
- (org-name name))
+ (let ((qualifiers nil))
(while (cl-generic--method-qualifier-p args)
(push args qualifiers)
(setq args (pop body)))
@@ -512,9 +511,8 @@ cl-defmethod
,(and (get name 'byte-obsolete-info)
(or (not (fboundp 'byte-compile-warning-enabled-p))
(byte-compile-warning-enabled-p 'obsolete name))
- (let* ((obsolete (get name 'byte-obsolete-info)))
+ (let ((obsolete (get name 'byte-obsolete-info)))
(macroexp-warn-and-return
- org-name
(macroexp--obsolete-warning name obsolete "generic function")
nil)))
;; You could argue that `defmethod' modifies rather than defines the
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 470168177ca..6fcf3ccfb5d 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -748,7 +748,7 @@ cl-load-time-value
(if (macroexp-compiling-p)
(let* ((temp (cl-gentemp "--cl-load-time--"))
(set `(setq ,temp ,form)))
- (if (and (fboundp 'byte-compile-file-form-defmumble)
+ (if (and (fboundp 'byte-compile-file-form-defalias*)
(boundp 'this-kind) (boundp 'that-one))
;; Else, we can't output right away, so we have to delay it to the
;; next time we're at the top-level.
@@ -2429,12 +2429,10 @@ cl-symbol-macrolet
(append bindings venv))
macroexpand-all-environment))))
(if malformed-bindings
- (let ((rev-malformed-bindings (nreverse malformed-bindings)))
- (macroexp-warn-and-return
- rev-malformed-bindings
- (format-message "Malformed `cl-symbol-macrolet' binding(s):
%S"
- rev-malformed-bindings)
- expansion))
+ (macroexp-warn-and-return
+ (format-message "Malformed `cl-symbol-macrolet' binding(s):
%S"
+ (nreverse malformed-bindings))
+ expansion)
expansion)))
(unless advised
(advice-remove 'macroexpand #'cl--sm-macroexpand)))))
@@ -3118,7 +3116,6 @@ cl-defstruct
(when (cl-oddp (length desc))
(push
(macroexp-warn-and-return
- (car (last desc))
(format "Missing value for option `%S' of slot `%s' in
struct %s!"
(car (last desc)) slot name)
'nil)
@@ -3128,7 +3125,6 @@ cl-defstruct
(let ((kw (car defaults)))
(push
(macroexp-warn-and-return
- kw
(format " I'll take `%s' to be an option rather than a
default value."
kw)
'nil)
diff --git a/lisp/emacs-lisp/cldefs.el.in b/lisp/emacs-lisp/cldefs.el.in
new file mode 100644
index 00000000000..a88633d2864
--- /dev/null
+++ b/lisp/emacs-lisp/cldefs.el.in
@@ -0,0 +1,17 @@
+(require 'gv)
+
+(defconst cldefs--cl-lib-functions
+ (let (load-history)
+ (require 'cl-lib)
+ (require 'cl-macs)
+ (require 'cl-seq)
+ (mapcan
+ (lambda (defines)
+ (delq nil (mapcar
+ (lambda (define)
+ (when (memq (car-safe define) '(defun t))
+ (cdr define)))
+ defines)))
+ (mapcar #'cdr load-history)))
+ "Since cl-lib has yet to join loadup.el, we must flag user code which
+does not first require it before using its functions. (Bug#30635)")
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 122638077ce..ad00b2ef4ab 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -3570,7 +3570,7 @@ comp-finalize-relocs
;; Symbols imported by C inlined functions. We do this here because
;; is better to add all objs to the relocation containers before we
;; compacting them.
- (mapc #'comp-add-const-to-relocs '(nil t consp listp symbol-with-pos-p))
+ (mapc #'comp-add-const-to-relocs '(nil t consp listp))
(let* ((d-default (comp-ctxt-d-default comp-ctxt))
(d-default-idx (comp-data-container-idx d-default))
@@ -4006,12 +4006,9 @@ comp--native-compile
(signal 'native-compiler-error
(list "Not a function symbol or file" function-or-file)))
(catch 'no-native-compile
- (let* ((print-symbols-bare t)
- (max-specpdl-size (max max-specpdl-size 5000))
- (data function-or-file)
+ (let* ((data function-or-file)
(comp-native-compiling t)
(byte-native-qualities nil)
- (symbols-with-pos-enabled t)
;; Have byte compiler signal an error when compilation fails.
(byte-compile-debug t)
(comp-ctxt (make-comp-ctxt :output output
@@ -4055,10 +4052,10 @@ comp--native-compile
(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.
- (native-elisp-load data)))))
+ (if (stringp function-or-file)
+ data
+ ;; So we return the compiled function.
+ (native-elisp-load data)))))
(defun native-compile-async-skip-p (file load selector)
"Return non-nil if FILE's compilation should be skipped.
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el
index 7bcb2f2936d..688c76e0c54 100644
--- a/lisp/emacs-lisp/easy-mmode.el
+++ b/lisp/emacs-lisp/easy-mmode.el
@@ -230,7 +230,6 @@ define-minor-mode
(warnwrap (if (or (null body) (keywordp (car body))) #'identity
(lambda (exp)
(macroexp-warn-and-return
- exp
"Use keywords rather than deprecated positional
arguments to `define-minor-mode'"
exp))))
keyw keymap-sym tmp)
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index 45ded158990..95b755bf762 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -748,7 +748,6 @@ eieio-oref
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-slot-names))))
(macroexp-warn-and-return
- name
(format-message "Unknown slot `%S'" name)
exp nil 'compile-only))
(_ exp))))
@@ -785,13 +784,11 @@ eieio-oref-default
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-slot-names))))
(macroexp-warn-and-return
- name
(format-message "Unknown slot `%S'" name)
exp nil 'compile-only))
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-class-slot-names))))
(macroexp-warn-and-return
- name
(format-message "Slot `%S' is not class-allocated" name)
exp nil 'compile-only))
(_ exp)))))
@@ -849,13 +846,11 @@ eieio-oset-default
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-slot-names))))
(macroexp-warn-and-return
- name
(format-message "Unknown slot `%S'" name)
exp nil 'compile-only))
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-class-slot-names))))
(macroexp-warn-and-return
- name
(format-message "Slot `%S' is not class-allocated" name)
exp nil 'compile-only))
(_ exp)))))
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 6f97c25ca96..5198e344697 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -245,8 +245,7 @@ defclass
`(progn
,@(mapcar (lambda (w)
- (macroexp-warn-and-return
- (car w) (cdr w) `(progn ',(cdr w)) nil 'compile-only))
+ (macroexp-warn-and-return w `(progn ',w) nil 'compile-only))
warnings)
;; This test must be created right away so we can have self-
;; referencing classes. ei, a class whose slot can contain only
@@ -296,7 +295,6 @@ defclass
(if (not (stringp (car slots)))
whole
(macroexp-warn-and-return
- (car slots)
(format "Obsolete name arg %S to constructor %S"
(car slots) (car whole))
;; Keep the name arg, for backward compatibility,
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index 91538d1f06e..1e9793261f9 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -581,9 +581,7 @@ gv-ref
Note: this only works reliably with lexical binding mode, except for very
simple PLACEs such as (symbol-function \\='foo) which will also work in dynamic
binding mode."
- (let ((org-place place) ; It's too difficult to determine by inspection
whether
- ; the functions modify place.
- (code
+ (let ((code
(gv-letplace (getter setter) place
`(cons (lambda () ,getter)
(lambda (gv--val) ,(funcall setter 'gv--val))))))
@@ -595,7 +593,6 @@ gv-ref
(eq (car-safe code) 'cons))
code
(macroexp-warn-and-return
- org-place
"Use of gv-ref probably requires lexical-binding"
code))))
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 256092599b2..6e0027092d9 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -28,17 +28,6 @@
;;; Code:
-(defvar byte-compile-form-stack nil
- "Dynamic list of successive enclosing forms.
-This is used by the warning message routines to determine a
-source code position. The most accessible element is the current
-most deeply nested form.
-
-Normally a form is manually pushed onto the list at the beginning
-of `byte-compile-form', etc., and manually popped off at its end.
-This is to preserve the data in it in the event of a
-condition-case handling a signaled error.")
-
;; Bound by the top-level `macroexpand-all', and modified to include any
;; macros defined by `defmacro'.
(defvar macroexpand-all-environment nil)
@@ -107,10 +96,9 @@ macroexp--all-clauses
(defun macroexp--compiler-macro (handler form)
(condition-case-unless-debug err
- (let ((symbols-with-pos-enabled t))
- (apply handler form (cdr form)))
+ (apply handler form (cdr form))
(error
- (message "Compiler-macro error for %S: Handler: %S\n%S" (car form)
handler err)
+ (message "Compiler-macro error for %S: %S" (car form) err)
form)))
(defun macroexp--funcall-if-compiled (_form)
@@ -147,23 +135,21 @@ macroexp-file-name
(defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key))
-(defun macroexp--warn-wrap (arg msg form category)
+(defun macroexp--warn-wrap (msg form category)
(let ((when-compiled
(lambda ()
(when (if (consp category)
(apply #'byte-compile-warning-enabled-p category)
(byte-compile-warning-enabled-p category))
- (byte-compile-warn-x arg "%s" msg)))))
+ (byte-compile-warn "%s" msg)))))
`(progn
(macroexp--funcall-if-compiled ',when-compiled)
,form)))
(define-obsolete-function-alias 'macroexp--warn-and-return
#'macroexp-warn-and-return "28.1")
-(defun macroexp-warn-and-return (arg msg form &optional category compile-only)
+(defun macroexp-warn-and-return (msg form &optional category compile-only)
"Return code equivalent to FORM labeled with warning MSG.
-ARG is a symbol (or a form) giving the source code position of FORM
-for the message. It should normally be a symbol with position.
CATEGORY is the category of the warning, like the categories that
can appear in `byte-compile-warnings'.
COMPILE-ONLY non-nil means no warning should be emitted if the code
@@ -177,7 +163,7 @@ macroexp-warn-and-return
;; macroexpand-all gets right back to macroexpanding `form'.
form
(puthash form form macroexp--warned)
- (macroexp--warn-wrap arg msg form category)))
+ (macroexp--warn-wrap msg form category)))
(t
(unless compile-only
(message "%sWarning: %s"
@@ -233,7 +219,6 @@ macroexp-macroexpand
(let* ((fun (car form))
(obsolete (get fun 'byte-obsolete-info)))
(macroexp-warn-and-return
- fun
(macroexp--obsolete-warning
fun obsolete
(if (symbolp (symbol-function fun))
@@ -289,7 +274,6 @@ macroexp--unfold-lambda
(setq arglist (cdr arglist)))
(if values
(macroexp-warn-and-return
- arglist
(format (if (eq values 'too-few)
"attempt to open-code `%s' with too few arguments"
"attempt to open-code `%s' with too many arguments")
@@ -319,124 +303,119 @@ macroexp--expand-all
"Expand all macros in FORM.
This is an internal version of `macroexpand-all'.
Assumes the caller has bound `macroexpand-all-environment'."
- (push form byte-compile-form-stack)
- (prog1
- (if (eq (car-safe form) 'backquote-list*)
- ;; Special-case `backquote-list*', as it is normally a macro that
- ;; generates exceedingly deep expansions from relatively shallow
input
- ;; forms. We just process it `in reverse' -- first we expand all the
- ;; arguments, _then_ we expand the top-level definition.
- (macroexpand (macroexp--all-forms form 1)
- macroexpand-all-environment)
- ;; Normal form; get its expansion, and then expand arguments.
- (setq form (macroexp-macroexpand form macroexpand-all-environment))
- ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when
- ;; I tried it, it broke the bootstrap :-(
- (pcase form
- (`(cond . ,clauses)
- (macroexp--cons 'cond (macroexp--all-clauses clauses) form))
- (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare))
- (macroexp--cons
- 'condition-case
- (macroexp--cons err
- (macroexp--cons (macroexp--expand-all body)
- (macroexp--all-clauses handlers 1)
- (cddr form))
- (cdr form))
- form))
- (`(,(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 'function
- (macroexp--cons (macroexp--all-forms f 2)
- nil
- (cdr form))
- form)))
- (`(,(or 'function 'quote) . ,_) form)
- (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body)
- pcase--dontcare))
- (let ((macroexp--dynvars macroexp--dynvars))
- (macroexp--cons
- fun
- (macroexp--cons
- (macroexp--all-clauses bindings 1)
- (if (null body)
- (macroexp-unprogn
- (macroexp-warn-and-return
- fun
- (format "Empty %s body" fun)
- nil nil 'compile-only))
- (macroexp--all-forms body))
- (cdr form))
- form)))
- (`(,(and fun `(lambda . ,_)) . ,args)
- ;; Embedded lambda in function position.
- ;; If the byte-optimizer is loaded, try to unfold this,
- ;; i.e. rewrite it to (let (<args>) <body>). We'd do it in the
optimizer
- ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the
- ;; creation of a closure, thus resulting in much better code.
- (let ((newform (macroexp--unfold-lambda form)))
- (if (eq newform form)
- ;; Unfolding failed for some reason, avoid infinite recursion.
- (macroexp--cons (macroexp--all-forms fun 2)
- (macroexp--all-forms args)
- form)
- (macroexp--expand-all newform))))
- (`(funcall ,exp . ,args)
- (let ((eexp (macroexp--expand-all exp))
- (eargs (macroexp--all-forms args)))
- ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo'
- ;; has a compiler-macro, or to unfold it.
- (pcase eexp
- ((and `#',f
- (guard (not (or (special-form-p f) (macrop f))))) ;;
bug#46636
- (macroexp--expand-all `(,f . ,eargs)))
- (_ `(funcall ,eexp . ,eargs)))))
- (`(funcall . ,_) form) ;bug#53227
- (`(,func . ,_)
- (let ((handler (function-get func 'compiler-macro))
- (funargs (function-get func 'funarg-positions)))
- ;; Check functions quoted with ' rather than with #'
- (dolist (funarg funargs)
- (let ((arg (nth funarg form)))
- (when (and (eq 'quote (car-safe arg))
- (eq 'lambda (car-safe (cadr arg))))
- (setcar (nthcdr funarg form)
- (macroexp-warn-and-return
- (cadr arg)
- (format "%S quoted with ' rather than with #'"
- (let ((f (cadr arg)))
- (if (symbolp f) f `(lambda ,(nth 1 f)
...))))
- arg)))))
- ;; Macro expand compiler macros. This cannot be delayed to
- ;; byte-optimize-form because the output of the compiler-macro can
- ;; use macros.
- (if (null handler)
- ;; No compiler macro. We just expand each argument (for
- ;; setq/setq-default this works alright because the variable
names
- ;; are symbols).
- (macroexp--all-forms form 1)
- ;; If the handler is not loaded yet, try (auto)loading the
- ;; function itself, which may in turn load the handler.
- (unless (functionp handler)
- (with-demoted-errors "macroexp--expand-all: %S"
- (autoload-do-load (indirect-function func) func)))
- (let ((newform (macroexp--compiler-macro handler form)))
- (if (eq form newform)
- ;; The compiler macro did not find anything to do.
- (if (equal form (setq newform (macroexp--all-forms form
1)))
- form
- ;; Maybe after processing the args, some new
opportunities
- ;; appeared, so let's try the compiler macro again.
- (setq form (macroexp--compiler-macro handler newform))
- (if (eq newform form)
- newform
- (macroexp--expand-all newform)))
- (macroexp--expand-all newform))))))
- (_ form)))
- (pop byte-compile-form-stack)))
+ (if (eq (car-safe form) 'backquote-list*)
+ ;; Special-case `backquote-list*', as it is normally a macro that
+ ;; generates exceedingly deep expansions from relatively shallow input
+ ;; forms. We just process it `in reverse' -- first we expand all the
+ ;; arguments, _then_ we expand the top-level definition.
+ (macroexpand (macroexp--all-forms form 1)
+ macroexpand-all-environment)
+ ;; Normal form; get its expansion, and then expand arguments.
+ (setq form (macroexp-macroexpand form macroexpand-all-environment))
+ ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when
+ ;; I tried it, it broke the bootstrap :-(
+ (pcase form
+ (`(cond . ,clauses)
+ (macroexp--cons 'cond (macroexp--all-clauses clauses) form))
+ (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare))
+ (macroexp--cons
+ 'condition-case
+ (macroexp--cons err
+ (macroexp--cons (macroexp--expand-all body)
+ (macroexp--all-clauses handlers 1)
+ (cddr form))
+ (cdr form))
+ form))
+ (`(,(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 'function
+ (macroexp--cons (macroexp--all-forms f 2)
+ nil
+ (cdr form))
+ form)))
+ (`(,(or 'function 'quote) . ,_) form)
+ (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body)
+ pcase--dontcare))
+ (let ((macroexp--dynvars macroexp--dynvars))
+ (macroexp--cons
+ fun
+ (macroexp--cons
+ (macroexp--all-clauses bindings 1)
+ (if (null body)
+ (macroexp-unprogn
+ (macroexp-warn-and-return
+ (format "Empty %s body" fun)
+ nil nil 'compile-only))
+ (macroexp--all-forms body))
+ (cdr form))
+ form)))
+ (`(,(and fun `(lambda . ,_)) . ,args)
+ ;; Embedded lambda in function position.
+ ;; If the byte-optimizer is loaded, try to unfold this,
+ ;; i.e. rewrite it to (let (<args>) <body>). We'd do it in the
optimizer
+ ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the
+ ;; creation of a closure, thus resulting in much better code.
+ (let ((newform (macroexp--unfold-lambda form)))
+ (if (eq newform form)
+ ;; Unfolding failed for some reason, avoid infinite recursion.
+ (macroexp--cons (macroexp--all-forms fun 2)
+ (macroexp--all-forms args)
+ form)
+ (macroexp--expand-all newform))))
+ (`(funcall ,exp . ,args)
+ (let ((eexp (macroexp--expand-all exp))
+ (eargs (macroexp--all-forms args)))
+ ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo'
+ ;; has a compiler-macro, or to unfold it.
+ (pcase eexp
+ ((and `#',f
+ (guard (not (or (special-form-p f) (macrop f))))) ;; bug#46636
+ (macroexp--expand-all `(,f . ,eargs)))
+ (_ `(funcall ,eexp . ,eargs)))))
+ (`(funcall . ,_) form) ;bug#53227
+ (`(,func . ,_)
+ (let ((handler (function-get func 'compiler-macro))
+ (funargs (function-get func 'funarg-positions)))
+ ;; Check functions quoted with ' rather than with #'
+ (dolist (funarg funargs)
+ (let ((arg (nth funarg form)))
+ (when (and (eq 'quote (car-safe arg))
+ (eq 'lambda (car-safe (cadr arg))))
+ (setcar (nthcdr funarg form)
+ (macroexp-warn-and-return
+ (format "%S quoted with ' rather than with #'"
+ (let ((f (cadr arg)))
+ (if (symbolp f) f `(lambda ,(nth 1 f) ...))))
+ arg)))))
+ ;; Macro expand compiler macros. This cannot be delayed to
+ ;; byte-optimize-form because the output of the compiler-macro can
+ ;; use macros.
+ (if (null handler)
+ ;; No compiler macro. We just expand each argument (for
+ ;; setq/setq-default this works alright because the variable names
+ ;; are symbols).
+ (macroexp--all-forms form 1)
+ ;; If the handler is not loaded yet, try (auto)loading the
+ ;; function itself, which may in turn load the handler.
+ (unless (functionp handler)
+ (with-demoted-errors "macroexp--expand-all: %S"
+ (autoload-do-load (indirect-function func) func)))
+ (let ((newform (macroexp--compiler-macro handler form)))
+ (if (eq form newform)
+ ;; The compiler macro did not find anything to do.
+ (if (equal form (setq newform (macroexp--all-forms form 1)))
+ form
+ ;; Maybe after processing the args, some new opportunities
+ ;; appeared, so let's try the compiler macro again.
+ (setq form (macroexp--compiler-macro handler newform))
+ (if (eq newform form)
+ newform
+ (macroexp--expand-all newform)))
+ (macroexp--expand-all newform))))))
+ (_ form))))
;; Record which arguments expect functions, so we can warn when those
;; are accidentally quoted with ' rather than with #'
@@ -464,7 +443,7 @@ macroexpand-all
;; This function is like `macroexpand-all' but for use with top-level
;; 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)
+(defun macroexpand--all-top-level (form &optional environment)
(let ((macroexpand-all-environment environment))
(macroexp--expand-all form)))
@@ -726,40 +705,38 @@ macroexp--debug-eager
(defun internal-macroexpand-for-load (form full-p)
;; Called from the eager-macroexpansion in readevalloop.
- (let ((symbols-with-pos-enabled t)
- (print-symbols-bare t))
- (cond
- ;; Don't repeat the same warning for every top-level element.
- ((eq 'skip (car macroexp--pending-eager-loads)) form)
- ;; If we detect a cycle, skip macro-expansion for now, and output a
warning
- ;; with a trimmed backtrace.
- ((and load-file-name (member load-file-name
macroexp--pending-eager-loads))
- (let* ((bt (delq nil
- (mapcar #'macroexp--trim-backtrace-frame
- (macroexp--backtrace))))
- (elem `(load ,(file-name-nondirectory load-file-name)))
- (tail (member elem (cdr (member elem bt)))))
- (if tail (setcdr tail (list '…)))
- (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt)))
- (if macroexp--debug-eager
- (debug 'eager-macroexp-cycle)
- (message "Warning: Eager macro-expansion skipped due to cycle:\n %s"
- (mapconcat #'prin1-to-string (nreverse bt) " => ")))
- (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)))
- (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.
- (message "Eager macro-expansion failure: %S" err)
- form))))))
+ (cond
+ ;; Don't repeat the same warning for every top-level element.
+ ((eq 'skip (car macroexp--pending-eager-loads)) form)
+ ;; If we detect a cycle, skip macro-expansion for now, and output a warning
+ ;; with a trimmed backtrace.
+ ((and load-file-name (member load-file-name macroexp--pending-eager-loads))
+ (let* ((bt (delq nil
+ (mapcar #'macroexp--trim-backtrace-frame
+ (macroexp--backtrace))))
+ (elem `(load ,(file-name-nondirectory load-file-name)))
+ (tail (member elem (cdr (member elem bt)))))
+ (if tail (setcdr tail (list '…)))
+ (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt)))
+ (if macroexp--debug-eager
+ (debug 'eager-macroexp-cycle)
+ (message "Warning: Eager macro-expansion skipped due to cycle:\n %s"
+ (mapconcat #'prin1-to-string (nreverse bt) " => ")))
+ (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-top-level form)
+ (macroexpand form)))
+ (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.
+ (message "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/multisession.el b/lisp/emacs-lisp/multisession.el
index d6f1ab98faa..a132f9eee4a 100644
--- a/lisp/emacs-lisp/multisession.el
+++ b/lisp/emacs-lisp/multisession.el
@@ -2,7 +2,7 @@
;; Copyright (C) 2021-2022 Free Software Foundation, Inc.
-;; This file is part of GNU Emacs.
+;; This file is NOT part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index c3dbfe29473..7a82b416e55 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -433,7 +433,6 @@ pcase-compile-patterns
(memq (car case) pcase--dontwarn-upats))
(setq main
(macroexp-warn-and-return
- (car case)
(format "pcase pattern %S shadowed by previous pcase pattern"
(car case))
main))))
@@ -941,7 +940,6 @@ pcase--u1
(let ((code (pcase--u1 matches code vars rest)))
(if (eq upat '_) code
(macroexp-warn-and-return
- upat
"Pattern t is deprecated. Use `_' instead"
code))))
((eq upat 'pcase--dontcare) :pcase--dontcare)
diff --git a/lisp/help.el b/lisp/help.el
index 975be497e77..b13438c163f 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -2083,7 +2083,7 @@ help--make-usage
((symbolp arg)
(let ((name (symbol-name arg)))
(cond
- ((string-match "\\`&" name) (bare-symbol arg))
+ ((string-match "\\`&" name) arg)
((string-match "\\`_." name)
(intern (upcase (substring name 1))))
(t (intern (upcase name))))))
diff --git a/lisp/keymap.el b/lisp/keymap.el
index c0fdf8721b2..4dbf9cf72ff 100644
--- a/lisp/keymap.el
+++ b/lisp/keymap.el
@@ -462,19 +462,18 @@ define-keymap--compile
(keywordp (car args))
(not (eq (car args) :menu)))
(unless (memq (car args) '(:full :keymap :parent :suppress :name :prefix))
- (byte-compile-warn-x (car args) "Invalid keyword: %s" (car args)))
+ (byte-compile-warn "Invalid keyword: %s" (car args)))
(setq args (cdr args))
(when (null args)
- (byte-compile-warn-x form "Uneven number of keywords in %S" form))
+ (byte-compile-warn "Uneven number of keywords in %S" form))
(setq args (cdr args)))
;; Bindings.
(while args
- (let* ((wargs args)
- (key (pop args)))
+ (let ((key (pop args)))
(when (and (stringp key) (not (key-valid-p key)))
- (byte-compile-warn-x wargs "Invalid `kbd' syntax: %S" key)))
+ (byte-compile-warn "Invalid `kbd' syntax: %S" key)))
(when (null args)
- (byte-compile-warn-x form "Uneven number of key bindings in %S" form))
+ (byte-compile-warn "Uneven number of key bindings in %S" form))
(setq args (cdr args)))
form)
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 36b8d808417..291c6c439de 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -2442,8 +2442,8 @@ completion-in-region
(funcall completion-in-region-function start end collection predicate))
(defcustom read-file-name-completion-ignore-case
- (if (memq system-type '(ms-dos windows-nt darwin cygwin))
- t nil)
+ (when (memq system-type '(ms-dos windows-nt darwin cygwin))
+ t)
"Non-nil means when reading a file name completion ignores case."
:type 'boolean
:version "22.1")
diff --git a/lisp/sqlite-mode.el b/lisp/sqlite-mode.el
index ba1b81ef7e2..b23b5774e39 100644
--- a/lisp/sqlite-mode.el
+++ b/lisp/sqlite-mode.el
@@ -2,7 +2,7 @@
;; Copyright (C) 2021-2022 Free Software Foundation, Inc.
-;; This file is part of GNU Emacs.
+;; This file is NOT part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
diff --git a/src/Makefile.in b/src/Makefile.in
index 186e06735cc..adaec52c7f8 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -482,9 +482,9 @@ ALLOBJS =
# Must be first, before dep inclusion!
ifneq ($(HAVE_BE_APP),yes)
-all: emacs$(EXEEXT) $(pdmp) $(OTHER_FILES)
+all: emacs$(EXEEXT) $(pdmp) $(lispsource)/emacs-lisp/cldefs.el $(OTHER_FILES)
else
-all: Emacs Emacs.pdmp $(OTHER_FILES)
+all: Emacs Emacs.pdmp $(lispsource)/emacs-lisp/cldefs.el $(OTHER_FILES)
endif
ifeq ($(HAVE_NATIVE_COMP):$(NATIVE_DISABLED),yes:)
all: ../native-lisp
@@ -868,7 +868,7 @@ elnlisp := $(addprefix ${lispsource}/,${elnlisp}) $(lisp:
## native-lisp where the *.eln files will be produced, and the exact
## names of those *.eln files, cannot be known in advance; we must ask
## Emacs to produce them.
-../native-lisp: | $(pdmp)
+../native-lisp: $(lispsource)/emacs-lisp/cldefs.el | $(pdmp)
@if test ! -d $@; then \
mkdir $@ && $(MAKE) $(AM_V_NO_PD) $(elnlisp); \
if test $(SYSTEM_TYPE) = cygwin; then \
@@ -890,6 +890,9 @@ $(lispsource)/loaddefs.el:
bootstrap-emacs$(EXEEXT) $(bootstrap_pdmp)
$(MAKE) -C ../lisp autoloads EMACS="$(bootstrap_exe)"
+$(lispsource)/emacs-lisp/cldefs.el: $(pdmp)
+ $(MAKE) -C ../lisp cldefs EMACS="$(bootstrap_exe)"
+
## Dump an Emacs executable named bootstrap-emacs containing the
## files from loadup.el in source form.
diff --git a/src/alloc.c b/src/alloc.c
index 5d7b484f6ea..12020cdcb2f 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -592,7 +592,7 @@ pointer_align (void *ptr, int alignment)
static ATTRIBUTE_NO_SANITIZE_UNDEFINED void *
XPNTR (Lisp_Object a)
{
- return (BARE_SYMBOL_P (a)
+ return (SYMBOLP (a)
? (char *) lispsym + (XLI (a) - LISP_WORD_TAG (Lisp_Symbol))
: (char *) XLP (a) - (XLI (a) & ~VALMASK));
}
@@ -3625,13 +3625,13 @@ #define SYMBOL_BLOCK_SIZE \
static void
set_symbol_name (Lisp_Object sym, Lisp_Object name)
{
- XBARE_SYMBOL (sym)->u.s.name = name;
+ XSYMBOL (sym)->u.s.name = name;
}
void
init_symbol (Lisp_Object val, Lisp_Object name)
{
- struct Lisp_Symbol *p = XBARE_SYMBOL (val);
+ struct Lisp_Symbol *p = XSYMBOL (val);
set_symbol_name (val, name);
set_symbol_plist (val, Qnil);
p->u.s.redirect = SYMBOL_PLAINVAL;
@@ -3694,21 +3694,6 @@ make_misc_ptr (void *a)
return make_lisp_ptr (p, Lisp_Vectorlike);
}
-/* Return a new symbol with position with the specified SYMBOL and POSITION. */
-Lisp_Object
-build_symbol_with_pos (Lisp_Object symbol, Lisp_Object position)
-{
- Lisp_Object val;
- struct Lisp_Symbol_With_Pos *p
- = (struct Lisp_Symbol_With_Pos *) allocate_vector (2);
- XSETVECTOR (val, p);
- XSETPVECTYPESIZE (XVECTOR (val), PVEC_SYMBOL_WITH_POS, 2, 0);
- p->sym = symbol;
- p->pos = position;
-
- return val;
-}
-
/* Return a new overlay with specified START, END and PLIST. */
Lisp_Object
@@ -5253,7 +5238,7 @@ valid_lisp_object_p (Lisp_Object obj)
if (PURE_P (p))
return 1;
- if (BARE_SYMBOL_P (obj) && c_symbol_p (p))
+ if (SYMBOLP (obj) && c_symbol_p (p))
return ((char *) p - (char *) lispsym) % sizeof lispsym[0] == 0;
if (p == &buffer_defaults || p == &buffer_local_symbols)
@@ -5685,12 +5670,12 @@ purecopy (Lisp_Object obj)
pin_string (vec->contents[1]);
XSETVECTOR (obj, vec);
}
- else if (BARE_SYMBOL_P (obj))
+ else if (SYMBOLP (obj))
{
- if (!XBARE_SYMBOL (obj)->u.s.pinned && !c_symbol_p (XBARE_SYMBOL (obj)))
+ if (!XSYMBOL (obj)->u.s.pinned && !c_symbol_p (XSYMBOL (obj)))
{ /* We can't purify them, but they appear in many pure objects.
Mark them as `pinned' so we know to mark them at every GC cycle.
*/
- XBARE_SYMBOL (obj)->u.s.pinned = true;
+ XSYMBOL (obj)->u.s.pinned = true;
symbol_block_pinned = symbol_block;
}
/* Don't hash-cons it. */
@@ -6318,10 +6303,7 @@ DEFUN ("garbage-collect", Fgarbage_collect,
Sgarbage_collect, 0, 0, "",
if (garbage_collection_inhibited)
return Qnil;
- ptrdiff_t count = SPECPDL_INDEX ();
- specbind (Qsymbols_with_pos_enabled, Qnil);
garbage_collect ();
- unbind_to (count, Qnil);
struct gcstat gcst = gcstat;
Lisp_Object total[] = {
@@ -6460,7 +6442,7 @@ mark_char_table (struct Lisp_Vector *ptr, enum pvec_type
pvectype)
Lisp_Object val = ptr->contents[i];
if (FIXNUMP (val) ||
- (BARE_SYMBOL_P (val) && symbol_marked_p (XBARE_SYMBOL (val))))
+ (SYMBOLP (val) && symbol_marked_p (XSYMBOL (val))))
continue;
if (SUB_CHAR_TABLE_P (val))
{
@@ -6864,7 +6846,7 @@ #define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void)
0)
case Lisp_Symbol:
{
- struct Lisp_Symbol *ptr = XBARE_SYMBOL (obj);
+ struct Lisp_Symbol *ptr = XSYMBOL (obj);
nextsym:
if (symbol_marked_p (ptr))
break;
@@ -6985,7 +6967,7 @@ survives_gc_p (Lisp_Object obj)
break;
case Lisp_Symbol:
- survives_p = symbol_marked_p (XBARE_SYMBOL (obj));
+ survives_p = symbol_marked_p (XSYMBOL (obj));
break;
case Lisp_String:
@@ -7402,7 +7384,7 @@ DEFUN ("malloc-info", Fmalloc_info, Smalloc_info, 0, 0,
"",
static bool
symbol_uses_obj (Lisp_Object symbol, Lisp_Object obj)
{
- struct Lisp_Symbol *sym = XBARE_SYMBOL (symbol);
+ struct Lisp_Symbol *sym = XSYMBOL (symbol);
Lisp_Object val = find_symbol_value (symbol);
return (EQ (val, obj)
|| EQ (sym->u.s.function, obj)
diff --git a/src/comp.c b/src/comp.c
index 251613dc3d4..40cb0c1c23d 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -454,7 +454,6 @@ #define HASH_LENGTH 8
/* C symbols emitted for the load relocation mechanism. */
#define CURRENT_THREAD_RELOC_SYM "current_thread_reloc"
-#define F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM "f_symbols_with_pos_enabled_reloc"
#define PURE_RELOC_SYM "pure_reloc"
#define DATA_RELOC_SYM "d_reloc"
#define DATA_RELOC_IMPURE_SYM "d_reloc_imp"
@@ -547,7 +546,6 @@ #define NUM_CAST_TYPES 15
gcc_jit_type *emacs_int_type;
gcc_jit_type *emacs_uint_type;
gcc_jit_type *void_ptr_type;
- gcc_jit_type *bool_ptr_type;
gcc_jit_type *char_ptr_type;
gcc_jit_type *ptrdiff_type;
gcc_jit_type *uintptr_type;
@@ -569,16 +567,6 @@ #define NUM_CAST_TYPES 15
gcc_jit_field *lisp_cons_u_s_u_cdr;
gcc_jit_type *lisp_cons_type;
gcc_jit_type *lisp_cons_ptr_type;
- /* struct Lisp_Symbol_With_Position */
- gcc_jit_rvalue *f_symbols_with_pos_enabled_ref;
- gcc_jit_struct *lisp_symbol_with_position;
- gcc_jit_field *lisp_symbol_with_position_header;
- gcc_jit_field *lisp_symbol_with_position_sym;
- gcc_jit_field *lisp_symbol_with_position_pos;
- gcc_jit_type *lisp_symbol_with_position_type;
- gcc_jit_type *lisp_symbol_with_position_ptr_type;
- gcc_jit_function *get_symbol_with_position;
- gcc_jit_function *symbol_with_pos_sym;
/* struct jmp_buf. */
gcc_jit_struct *jmp_buf_s;
/* struct handler. */
@@ -671,7 +659,6 @@ #define NUM_CAST_TYPES 15
Lisp_Object helper_unbind_n (Lisp_Object n);
void helper_save_restriction (void);
bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code);
-struct Lisp_Symbol_With_Pos *helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a);
/* Note: helper_link_table must match the list created by
`declare_runtime_imported_funcs'. */
@@ -683,7 +670,6 @@ #define NUM_CAST_TYPES 15
record_unwind_protect_excursion,
helper_unbind_n,
helper_save_restriction,
- helper_GET_SYMBOL_WITH_POSITION,
record_unwind_current_buffer,
set_internal,
helper_unwind_protect,
@@ -1348,9 +1334,9 @@ emit_XCONS (gcc_jit_rvalue *a)
}
static gcc_jit_rvalue *
-emit_BASE_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
+emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
{
- emit_comment ("BASE_EQ");
+ emit_comment ("EQ");
return gcc_jit_context_new_comparison (
comp.ctxt,
@@ -1360,30 +1346,6 @@ emit_BASE_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
emit_XLI (y));
}
-static gcc_jit_rvalue *
-emit_AND (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
-{
- return gcc_jit_context_new_binary_op (
- comp.ctxt,
- NULL,
- GCC_JIT_BINARY_OP_LOGICAL_AND,
- comp.bool_type,
- x,
- y);
-}
-
-static gcc_jit_rvalue *
-emit_OR (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
-{
- return gcc_jit_context_new_binary_op (
- comp.ctxt,
- NULL,
- GCC_JIT_BINARY_OP_LOGICAL_OR,
- comp.bool_type,
- x,
- y);
-}
-
static gcc_jit_rvalue *
emit_TAGGEDP (gcc_jit_rvalue *obj, Lisp_Word_tag tag)
{
@@ -1445,85 +1407,6 @@ emit_CONSP (gcc_jit_rvalue *obj)
return emit_TAGGEDP (obj, Lisp_Cons);
}
-static gcc_jit_rvalue *
-emit_BARE_SYMBOL_P (gcc_jit_rvalue *obj)
-{
- emit_comment ("BARE_SYMBOL_P");
-
- return gcc_jit_context_new_cast (comp.ctxt,
- NULL,
- emit_TAGGEDP (obj, Lisp_Symbol),
- comp.bool_type);
-}
-
-static gcc_jit_rvalue *
-emit_SYMBOL_WITH_POS_P (gcc_jit_rvalue *obj)
-{
- emit_comment ("SYMBOL_WITH_POS_P");
-
- gcc_jit_rvalue *args[] =
- { obj,
- gcc_jit_context_new_rvalue_from_int (comp.ctxt,
- comp.int_type,
- PVEC_SYMBOL_WITH_POS)
- };
-
- return gcc_jit_context_new_call (comp.ctxt,
- NULL,
- comp.pseudovectorp,
- 2,
- args);
-}
-
-static gcc_jit_rvalue *
-emit_SYMBOL_WITH_POS_SYM (gcc_jit_rvalue *obj)
-{
- emit_comment ("SYMBOL_WITH_POS_SYM");
-
- gcc_jit_rvalue *arg [] = { obj };
- return gcc_jit_context_new_call (comp.ctxt,
- NULL,
- comp.symbol_with_pos_sym,
- 1,
- arg);
-}
-
-static gcc_jit_rvalue *
-emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
-{
- return
- emit_OR (
- gcc_jit_context_new_comparison (
- comp.ctxt, NULL,
- GCC_JIT_COMPARISON_EQ,
- emit_XLI (x), emit_XLI (y)),
- emit_AND (
- gcc_jit_lvalue_as_rvalue (
- gcc_jit_rvalue_dereference (comp.f_symbols_with_pos_enabled_ref,
- NULL)),
- emit_OR (
- emit_AND (
- emit_SYMBOL_WITH_POS_P (x),
- emit_OR (
- emit_AND (
- emit_SYMBOL_WITH_POS_P (y),
- emit_BASE_EQ (
- emit_XLI (emit_SYMBOL_WITH_POS_SYM (x)),
- emit_XLI (emit_SYMBOL_WITH_POS_SYM (y)))),
- emit_AND (
- emit_BARE_SYMBOL_P (y),
- emit_BASE_EQ (
- emit_XLI (emit_SYMBOL_WITH_POS_SYM (x)),
- emit_XLI (y))))),
- emit_AND (
- emit_BARE_SYMBOL_P (x),
- emit_AND (
- emit_SYMBOL_WITH_POS_P (y),
- emit_BASE_EQ (
- emit_XLI (x),
- emit_XLI (emit_SYMBOL_WITH_POS_SYM (y))))))));
-}
-
static gcc_jit_rvalue *
emit_FLOATP (gcc_jit_rvalue *obj)
{
@@ -1738,7 +1621,7 @@ emit_lisp_obj_rval (Lisp_Object obj)
emit_NILP (gcc_jit_rvalue *x)
{
emit_comment ("NILP");
- return emit_BASE_EQ (x, emit_lisp_obj_rval (Qnil));
+ return emit_EQ (x, emit_lisp_obj_rval (Qnil));
}
static gcc_jit_rvalue *
@@ -1854,29 +1737,6 @@ emit_CHECK_CONS (gcc_jit_rvalue *x)
args));
}
-static void
-emit_CHECK_SYMBOL_WITH_POS (gcc_jit_rvalue *x)
-{
- emit_comment ("CHECK_SYMBOL_WITH_POS");
-
- gcc_jit_rvalue *args[] =
- { gcc_jit_context_new_cast (comp.ctxt,
- NULL,
- emit_SYMBOL_WITH_POS_P (x),
- comp.int_type),
- emit_lisp_obj_rval (Qsymbol_with_pos_p),
- x };
-
- gcc_jit_block_add_eval (
- comp.block,
- NULL,
- gcc_jit_context_new_call (comp.ctxt,
- NULL,
- comp.check_type,
- 3,
- args));
-}
-
static gcc_jit_rvalue *
emit_car_addr (gcc_jit_rvalue *c)
{
@@ -2241,13 +2101,7 @@ emit_limple_insn (Lisp_Object insn)
gcc_jit_block *target1 = retrive_block (arg[2]);
gcc_jit_block *target2 = retrive_block (arg[3]);
- if ((!NILP (CALL1I (comp-cstr-imm-vld-p, arg[0]))
- && NILP (CALL1I (comp-cstr-imm, arg[0])))
- || (!NILP (CALL1I (comp-cstr-imm-vld-p, arg[1]))
- && NILP (CALL1I (comp-cstr-imm, arg[1]))))
- emit_cond_jump (emit_BASE_EQ (a, b), target1, target2);
- else
- emit_cond_jump (emit_EQ (a, b), target1, target2);
+ emit_cond_jump (emit_EQ (a, b), target1, target2);
}
else if (EQ (op, Qcond_jump_narg_leq))
{
@@ -2904,10 +2758,6 @@ #define ADD_IMPORTED(f_name, ret_type, nargs, args)
\
ADD_IMPORTED (helper_save_restriction, comp.void_type, 0, NULL);
- args[0] = comp.lisp_obj_type;
- ADD_IMPORTED (helper_GET_SYMBOL_WITH_POSITION,
comp.lisp_symbol_with_position_ptr_type,
- 1, args);
-
ADD_IMPORTED (record_unwind_current_buffer, comp.void_type, 0, NULL);
args[0] = args[1] = args[2] = comp.lisp_obj_type;
@@ -2955,15 +2805,6 @@ emit_ctxt_code (void)
gcc_jit_type_get_pointer (comp.thread_state_ptr_type),
CURRENT_THREAD_RELOC_SYM));
- comp.f_symbols_with_pos_enabled_ref =
- gcc_jit_lvalue_as_rvalue (
- gcc_jit_context_new_global (
- comp.ctxt,
- NULL,
- GCC_JIT_GLOBAL_EXPORTED,
- comp.bool_ptr_type,
- F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM));
-
comp.pure_ptr =
gcc_jit_lvalue_as_rvalue (
gcc_jit_context_new_global (
@@ -3143,39 +2984,6 @@ define_lisp_cons (void)
}
-static void
-define_lisp_symbol_with_position (void)
-{
- comp.lisp_symbol_with_position_header =
- gcc_jit_context_new_field (comp.ctxt,
- NULL,
- comp.ptrdiff_type,
- "header");
- comp.lisp_symbol_with_position_sym =
- gcc_jit_context_new_field (comp.ctxt,
- NULL,
- comp.lisp_obj_type,
- "sym");
- comp.lisp_symbol_with_position_pos =
- gcc_jit_context_new_field (comp.ctxt,
- NULL,
- comp.lisp_obj_type,
- "pos");
- gcc_jit_field *fields [3] = {comp.lisp_symbol_with_position_header,
- comp.lisp_symbol_with_position_sym,
- comp.lisp_symbol_with_position_pos};
- comp.lisp_symbol_with_position =
- gcc_jit_context_new_struct_type (comp.ctxt,
- NULL,
- "comp_lisp_symbol_with_position",
- 3,
- fields);
- comp.lisp_symbol_with_position_type =
- gcc_jit_struct_as_type (comp.lisp_symbol_with_position);
- comp.lisp_symbol_with_position_ptr_type =
- gcc_jit_type_get_pointer (comp.lisp_symbol_with_position_type);
-}
-
/* Opaque jmp_buf definition. */
static void
@@ -3871,82 +3679,6 @@ define_PSEUDOVECTORP (void)
comp.bool_type, 2, args, false));
}
-static void
-define_GET_SYMBOL_WITH_POSITION (void)
-{
- gcc_jit_param *param[] =
- { gcc_jit_context_new_param (comp.ctxt,
- NULL,
- comp.lisp_obj_type,
- "a") };
-
- comp.get_symbol_with_position =
- gcc_jit_context_new_function (comp.ctxt, NULL,
- GCC_JIT_FUNCTION_INTERNAL,
- comp.lisp_symbol_with_position_ptr_type,
- "GET_SYMBOL_WITH_POSITION",
- 1,
- param,
- 0);
-
- DECL_BLOCK (entry_block, comp.get_symbol_with_position);
-
- comp.block = entry_block;
- comp.func = comp.get_symbol_with_position;
-
- gcc_jit_rvalue *args[] =
- { gcc_jit_param_as_rvalue (param[0]) };
- /* FIXME use XUNTAG now that's available. */
- gcc_jit_block_end_with_return (
- entry_block,
- NULL,
- emit_call (intern_c_string ("helper_GET_SYMBOL_WITH_POSITION"),
- comp.lisp_symbol_with_position_ptr_type,
- 1, args, false));
-}
-
-static void define_SYMBOL_WITH_POS_SYM (void)
-{
- gcc_jit_rvalue *tmpr, *swp;
- gcc_jit_lvalue *tmpl;
-
- gcc_jit_param *param [] =
- { gcc_jit_context_new_param (comp.ctxt,
- NULL,
- comp.lisp_obj_type,
- "a") };
- comp.symbol_with_pos_sym =
- gcc_jit_context_new_function (comp.ctxt, NULL,
- GCC_JIT_FUNCTION_INTERNAL,
- comp.lisp_obj_type,
- "SYMBOL_WITH_POS_SYM",
- 1,
- param,
- 0);
-
- DECL_BLOCK (entry_block, comp.symbol_with_pos_sym);
- comp.func = comp.symbol_with_pos_sym;
- comp.block = entry_block;
-
- emit_CHECK_SYMBOL_WITH_POS (gcc_jit_param_as_rvalue (param [0]));
-
- gcc_jit_rvalue *args[] = { gcc_jit_param_as_rvalue (param [0]) };
-
- swp = gcc_jit_context_new_call (comp.ctxt,
- NULL,
- comp.get_symbol_with_position,
- 1,
- args);
- tmpl = gcc_jit_rvalue_dereference (swp, NULL);
- tmpr = gcc_jit_lvalue_as_rvalue (tmpl);
- gcc_jit_block_end_with_return (entry_block,
- NULL,
- gcc_jit_rvalue_access_field (
- tmpr,
- NULL,
- comp.lisp_symbol_with_position_sym));
-}
-
static void
define_CHECK_IMPURE (void)
{
@@ -4584,7 +4316,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt,
Scomp__init_ctxt,
gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG_LONG);
comp.unsigned_long_long_type =
gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG_LONG);
- comp.bool_ptr_type = gcc_jit_type_get_pointer (comp.bool_type);
comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type);
comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt,
sizeof (EMACS_INT),
@@ -4657,7 +4388,6 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt,
Scomp__init_ctxt,
/* Define data structures. */
define_lisp_cons ();
- define_lisp_symbol_with_position ();
define_jmp_buf ();
define_handler_struct ();
define_thread_state_struct ();
@@ -4879,9 +4609,7 @@ DEFUN ("comp--compile-ctxt-to-file",
Fcomp__compile_ctxt_to_file,
/* Define inline functions. */
define_CAR_CDR ();
define_PSEUDOVECTORP ();
- define_GET_SYMBOL_WITH_POSITION ();
define_CHECK_TYPE ();
- define_SYMBOL_WITH_POS_SYM ();
define_CHECK_IMPURE ();
define_bool_to_lisp_obj ();
define_setcar_setcdr ();
@@ -5013,14 +4741,6 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum
pvec_type code)
code);
}
-struct Lisp_Symbol_With_Pos *
-helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a)
-{
- if (!SYMBOL_WITH_POS_P (a))
- wrong_type_argument (Qwrong_type_argument, a);
- return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos);
-}
-
/* `native-comp-eln-load-path' clean-up support code. */
@@ -5288,15 +5008,12 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u,
bool loading_dump,
{
struct thread_state ***current_thread_reloc =
dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM);
- bool **f_symbols_with_pos_enabled_reloc =
- dynlib_sym (handle, F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM);
void **pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM);
Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM);
Lisp_Object *data_imp_relocs = comp_u->data_imp_relocs;
void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM);
if (!(current_thread_reloc
- && f_symbols_with_pos_enabled_reloc
&& pure_reloc
&& data_relocs
&& data_imp_relocs
@@ -5308,7 +5025,6 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u,
bool loading_dump,
xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file);
*current_thread_reloc = ¤t_thread;
- *f_symbols_with_pos_enabled_reloc = &symbols_with_pos_enabled;
*pure_reloc = pure;
/* Imported functions. */
@@ -5666,7 +5382,6 @@ syms_of_comp (void)
DEFSYM (Qnumberp, "numberp");
DEFSYM (Qintegerp, "integerp");
DEFSYM (Qcomp_maybe_gc_or_quit, "comp-maybe-gc-or-quit");
- DEFSYM (Qsymbol_with_pos_p, "symbol-with-pos-p");
/* Allocation classes. */
DEFSYM (Qd_default, "d-default");
diff --git a/src/data.c b/src/data.c
index 95d29ac9e98..b637efa6bde 100644
--- a/src/data.c
+++ b/src/data.c
@@ -216,7 +216,6 @@ DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
case PVEC_NORMAL_VECTOR: return Qvector;
case PVEC_BIGNUM: return Qinteger;
case PVEC_MARKER: return Qmarker;
- case PVEC_SYMBOL_WITH_POS: return Qsymbol_with_pos;
case PVEC_OVERLAY: return Qoverlay;
case PVEC_FINALIZER: return Qfinalizer;
case PVEC_USER_PTR: return Quser_ptr;
@@ -319,26 +318,6 @@ DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
return Qt;
}
-DEFUN ("bare-symbol-p", Fbare_symbol_p, Sbare_symbol_p, 1, 1, 0,
- doc: /* Return t if OBJECT is a symbol, but not a symbol together with
position. */
- attributes: const)
- (Lisp_Object object)
-{
- if (BARE_SYMBOL_P (object))
- return Qt;
- return Qnil;
-}
-
-DEFUN ("symbol-with-pos-p", Fsymbol_with_pos_p, Ssymbol_with_pos_p, 1, 1, 0,
- doc: /* Return t if OBJECT is a symbol together with position. */
- attributes: const)
- (Lisp_Object object)
-{
- if (SYMBOL_WITH_POS_P (object))
- return Qt;
- return Qnil;
-}
-
DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
doc: /* Return t if OBJECT is a symbol. */
attributes: const)
@@ -776,62 +755,6 @@ DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0,
return name;
}
-DEFUN ("bare-symbol", Fbare_symbol, Sbare_symbol, 1, 1, 0,
- doc: /* Extract, if need be, the bare symbol from SYM, a symbol. */)
- (register Lisp_Object sym)
-{
- if (BARE_SYMBOL_P (sym))
- return sym;
- /* Type checking is done in the following macro. */
- return SYMBOL_WITH_POS_SYM (sym);
-}
-
-DEFUN ("symbol-with-pos-pos", Fsymbol_with_pos_pos, Ssymbol_with_pos_pos, 1,
1, 0,
- doc: /* Extract the position from a symbol with position. */)
- (register Lisp_Object ls)
-{
- /* Type checking is done in the following macro. */
- return SYMBOL_WITH_POS_POS (ls);
-}
-
-DEFUN ("remove-pos-from-symbol", Fremove_pos_from_symbol,
- Sremove_pos_from_symbol, 1, 1, 0,
- doc: /* If ARG is a symbol with position, return it without the
position.
-Otherwise, return ARG unchanged. Compare with `bare-symbol'. */)
- (register Lisp_Object arg)
-{
- if (SYMBOL_WITH_POS_P (arg))
- return (SYMBOL_WITH_POS_SYM (arg));
- return arg;
-}
-
-DEFUN ("position-symbol", Fposition_symbol, Sposition_symbol, 2, 2, 0,
- doc: /* Create a new symbol with position.
-SYM is a symbol, with or without position, the symbol to position.
-POS, the position, is either a fixnum or a symbol with position from which
-the position will be taken. */)
- (register Lisp_Object sym, register Lisp_Object pos)
-{
- Lisp_Object bare;
- Lisp_Object position;
-
- if (BARE_SYMBOL_P (sym))
- bare = sym;
- else if (SYMBOL_WITH_POS_P (sym))
- bare = XSYMBOL_WITH_POS (sym)->sym;
- else
- wrong_type_argument (Qsymbolp, sym);
-
- if (FIXNUMP (pos))
- position = pos;
- else if (SYMBOL_WITH_POS_P (pos))
- position = XSYMBOL_WITH_POS (pos)->pos;
- else
- wrong_type_argument (Qfixnum_or_symbol_with_pos_p, pos);
-
- return build_symbol_with_pos (bare, position);
-}
-
DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
doc: /* Set SYMBOL's function definition to DEFINITION, and return
DEFINITION. */)
(register Lisp_Object symbol, Lisp_Object definition)
@@ -4046,6 +3969,9 @@ syms_of_data (void)
DEFSYM (Qtext_read_only, "text-read-only");
DEFSYM (Qmark_inactive, "mark-inactive");
DEFSYM (Qinhibited_interaction, "inhibited-interaction");
+ DEFSYM (Qrecursion_error, "recursion-error");
+ DEFSYM (Qexcessive_variable_binding, "excessive-variable-binding");
+ DEFSYM (Qexcessive_lisp_nesting, "excessive-lisp-nesting");
DEFSYM (Qrecursion_error, "recursion-error");
DEFSYM (Qexcessive_variable_binding, "excessive-variable-binding");
@@ -4053,8 +3979,6 @@ syms_of_data (void)
DEFSYM (Qlistp, "listp");
DEFSYM (Qconsp, "consp");
- DEFSYM (Qbare_symbol_p, "bare-symbol-p");
- DEFSYM (Qsymbol_with_pos_p, "symbol-with-pos-p");
DEFSYM (Qsymbolp, "symbolp");
DEFSYM (Qfixnump, "fixnump");
DEFSYM (Qintegerp, "integerp");
@@ -4080,7 +4004,6 @@ syms_of_data (void)
DEFSYM (Qchar_table_p, "char-table-p");
DEFSYM (Qvector_or_char_table_p, "vector-or-char-table-p");
- DEFSYM (Qfixnum_or_symbol_with_pos_p, "fixnum-or-symbol-with-pos-p");
DEFSYM (Qsubrp, "subrp");
DEFSYM (Qunevalled, "unevalled");
@@ -4158,6 +4081,15 @@ #define PUT_ERROR(sym, tail, msg)
\
"Arithmetic overflow error");
PUT_ERROR (Qunderflow_error, Fcons (Qrange_error, arith_tail),
"Arithmetic underflow error");
+ recursion_tail = pure_cons (Qrecursion_error, error_tail);
+ Fput (Qrecursion_error, Qerror_conditions, recursion_tail);
+ Fput (Qrecursion_error, Qerror_message, build_pure_c_string
+ ("Excessive recursive calling error"));
+
+ PUT_ERROR (Qexcessive_variable_binding, recursion_tail,
+ "Variable binding depth exceeds max-specpdl-size");
+ PUT_ERROR (Qexcessive_lisp_nesting, recursion_tail,
+ "Lisp nesting exceeds `max-lisp-eval-depth'");
recursion_tail = pure_cons (Qrecursion_error, error_tail);
Fput (Qrecursion_error, Qerror_conditions, recursion_tail);
@@ -4175,7 +4107,6 @@ #define PUT_ERROR(sym, tail, msg) \
DEFSYM (Qstring, "string");
DEFSYM (Qcons, "cons");
DEFSYM (Qmarker, "marker");
- DEFSYM (Qsymbol_with_pos, "symbol-with-pos");
DEFSYM (Qoverlay, "overlay");
DEFSYM (Qfinalizer, "finalizer");
DEFSYM (Qmodule_function, "module-function");
@@ -4228,8 +4159,6 @@ #define PUT_ERROR(sym, tail, msg) \
defsubr (&Snumber_or_marker_p);
defsubr (&Sfloatp);
defsubr (&Snatnump);
- defsubr (&Sbare_symbol_p);
- defsubr (&Ssymbol_with_pos_p);
defsubr (&Ssymbolp);
defsubr (&Skeywordp);
defsubr (&Sstringp);
@@ -4260,10 +4189,6 @@ #define PUT_ERROR(sym, tail, msg)
\
defsubr (&Sindirect_function);
defsubr (&Ssymbol_plist);
defsubr (&Ssymbol_name);
- defsubr (&Sbare_symbol);
- defsubr (&Ssymbol_with_pos_pos);
- defsubr (&Sremove_pos_from_symbol);
- defsubr (&Sposition_symbol);
defsubr (&Smakunbound);
defsubr (&Sfmakunbound);
defsubr (&Sboundp);
@@ -4346,12 +4271,6 @@ #define PUT_ERROR(sym, tail, msg)
\
Vmost_negative_fixnum = make_fixnum (MOST_NEGATIVE_FIXNUM);
make_symbol_constant (intern_c_string ("most-negative-fixnum"));
- DEFSYM (Qsymbols_with_pos_enabled, "symbols-with-pos-enabled");
- DEFVAR_BOOL ("symbols-with-pos-enabled", symbols_with_pos_enabled,
- doc: /* Non-nil when "symbols with position" can be used as
symbols.
-Bind this to non-nil in applications such as the byte compiler. */);
- symbols_with_pos_enabled = false;
-
DEFSYM (Qwatchers, "watchers");
DEFSYM (Qmakunbound, "makunbound");
DEFSYM (Qunlet, "unlet");
diff --git a/src/fns.c b/src/fns.c
index c67871da744..fb05bdc5be3 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -291,6 +291,21 @@ DEFUN ("proper-list-p", Fproper_list_p, Sproper_list_p, 1,
1, 0,
return make_fixnum (len);
}
+DEFUN ("circular-list-p", Fcircular_list_p, Scircular_list_p, 1, 1, 0,
+ doc: /* Return t if OBJECT is a circular list, nil otherwise.
+The expression (not (proper-list-p OBJECT)) also returns t if OBJECT
+is circular, but undesirably returns t if OBJECT is a dotted list. */
+ attributes: const)
+ (Lisp_Object object)
+{
+ Lisp_Object tail = object, circular_p = Qnil;
+ FOR_EACH_TAIL_INTERNAL (tail, (void) ((circular_p) = Qt), false)
+ {
+ (void) 0;
+ }
+ return circular_p;
+}
+
DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
doc: /* Return the number of bytes in STRING.
If STRING is multibyte, this may be greater than the length of STRING. */)
@@ -2631,13 +2646,6 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum
equal_kind equal_kind,
}
}
- /* A symbol with position compares the contained symbol, and is
- `equal' to the corresponding ordinary symbol. */
- if (SYMBOL_WITH_POS_P (o1))
- o1 = SYMBOL_WITH_POS_SYM (o1);
- if (SYMBOL_WITH_POS_P (o2))
- o2 = SYMBOL_WITH_POS_SYM (o2);
-
if (EQ (o1, o2))
return true;
if (XTYPE (o1) != XTYPE (o2))
@@ -4542,10 +4550,7 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key,
Lisp_Object *hash)
{
ptrdiff_t start_of_bucket, i;
- Lisp_Object hash_code;
- if (SYMBOL_WITH_POS_P (key))
- key = SYMBOL_WITH_POS_SYM (key);
- hash_code = h->test.hashfn (key, h);
+ Lisp_Object hash_code = h->test.hashfn (key, h);
if (hash)
*hash = hash_code;
@@ -6122,6 +6127,7 @@ syms_of_fns (void)
defsubr (&Slength_greater);
defsubr (&Slength_equal);
defsubr (&Sproper_list_p);
+ defsubr (&Scircular_list_p);
defsubr (&Sstring_bytes);
defsubr (&Sstring_distance);
defsubr (&Sstring_equal);
diff --git a/src/keyboard.c b/src/keyboard.c
index 441c23e10c7..70e055a9df9 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -689,8 +689,6 @@ recursive_edit_1 (void)
{
specbind (Qstandard_output, Qt);
specbind (Qstandard_input, Qt);
- specbind (Qsymbols_with_pos_enabled, Qnil);
- specbind (Qprint_symbols_bare, Qnil);
}
#ifdef HAVE_WINDOW_SYSTEM
diff --git a/src/lisp.h b/src/lisp.h
index 10f45057d50..ec615aa8d1e 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -353,41 +353,18 @@ #define LISP_WORDS_ARE_POINTERS (EMACS_INT_MAX ==
INTPTR_MAX)
# endif
#endif
-#define lisp_h_PSEUDOVECTORP(a,code) \
- (lisp_h_VECTORLIKEP((a)) && \
- ((XUNTAG ((a), Lisp_Vectorlike, union vectorlike_header)->size \
- & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK)) \
- == (PSEUDOVECTOR_FLAG | ((code) << PSEUDOVECTOR_AREA_BITS))))
-
#define lisp_h_CHECK_FIXNUM(x) CHECK_TYPE (FIXNUMP (x), Qfixnump, x)
#define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x)
#define lisp_h_CHECK_TYPE(ok, predicate, x) \
((ok) ? (void) 0 : wrong_type_argument (predicate, x))
#define lisp_h_CONSP(x) TAGGEDP (x, Lisp_Cons)
-#define lisp_h_BASE_EQ(x, y) (XLI (x) == XLI (y))
-
-/* FIXME: Do we really need to inline the whole thing?
- * What about keeping the part after `symbols_with_pos_enabled` in
- * a separate function? */
-#define lisp_h_EQ(x, y) \
- ((XLI ((x)) == XLI ((y))) \
- || (symbols_with_pos_enabled \
- && (SYMBOL_WITH_POS_P ((x)) \
- ? (BARE_SYMBOL_P ((y)) \
- ? XLI (XSYMBOL_WITH_POS((x))->sym) == XLI (y) \
- : SYMBOL_WITH_POS_P((y)) \
- && (XLI (XSYMBOL_WITH_POS((x))->sym) \
- == XLI (XSYMBOL_WITH_POS((y))->sym))) \
- : (SYMBOL_WITH_POS_P ((y)) \
- && BARE_SYMBOL_P ((x)) \
- && (XLI (x) == XLI ((XSYMBOL_WITH_POS ((y)))->sym))))))
-
+#define lisp_h_EQ(x, y) (XLI (x) == XLI (y))
#define lisp_h_FIXNUMP(x) \
(! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) \
- (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) \
& ((1 << INTTYPEBITS) - 1)))
#define lisp_h_FLOATP(x) TAGGEDP (x, Lisp_Float)
-#define lisp_h_NILP(x) BASE_EQ (x, Qnil)
+#define lisp_h_NILP(x) EQ (x, Qnil)
#define lisp_h_SET_SYMBOL_VAL(sym, v) \
(eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), \
(sym)->u.s.val.value = (v))
@@ -396,10 +373,7 @@ #define lisp_h_SYMBOL_CONSTANT_P(sym) \
#define lisp_h_SYMBOL_TRAPPED_WRITE_P(sym) (XSYMBOL (sym)->u.s.trapped_write)
#define lisp_h_SYMBOL_VAL(sym) \
(eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), (sym)->u.s.val.value)
-#define lisp_h_SYMBOL_WITH_POS_P(x) PSEUDOVECTORP ((x), PVEC_SYMBOL_WITH_POS)
-#define lisp_h_BARE_SYMBOL_P(x) TAGGEDP ((x), Lisp_Symbol)
-#define lisp_h_SYMBOLP(x) ((BARE_SYMBOL_P ((x)) || \
- (symbols_with_pos_enabled && (SYMBOL_WITH_POS_P
((x))))))
+#define lisp_h_SYMBOLP(x) TAGGEDP (x, Lisp_Symbol)
#define lisp_h_TAGGEDP(a, tag) \
(! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \
- (unsigned) (tag)) \
@@ -444,12 +418,11 @@ #define lisp_h_XHASH(a) XUFIXNUM_RAW (a)
# define XLI(o) lisp_h_XLI (o)
# define XIL(i) lisp_h_XIL (i)
# define XLP(o) lisp_h_XLP (o)
-# define BARE_SYMBOL_P(x) lisp_h_BARE_SYMBOL_P (x)
# define CHECK_FIXNUM(x) lisp_h_CHECK_FIXNUM (x)
# define CHECK_SYMBOL(x) lisp_h_CHECK_SYMBOL (x)
# define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x)
# define CONSP(x) lisp_h_CONSP (x)
-# define BASE_EQ(x, y) lisp_h_BASE_EQ (x, y)
+# define EQ(x, y) lisp_h_EQ (x, y)
# define FLOATP(x) lisp_h_FLOATP (x)
# define FIXNUMP(x) lisp_h_FIXNUMP (x)
# define NILP(x) lisp_h_NILP (x)
@@ -457,7 +430,7 @@ #define lisp_h_XHASH(a) XUFIXNUM_RAW (a)
# define SYMBOL_CONSTANT_P(sym) lisp_h_SYMBOL_CONSTANT_P (sym)
# define SYMBOL_TRAPPED_WRITE_P(sym) lisp_h_SYMBOL_TRAPPED_WRITE_P (sym)
# define SYMBOL_VAL(sym) lisp_h_SYMBOL_VAL (sym)
-/* # define SYMBOLP(x) lisp_h_SYMBOLP (x) */ /* X is accessed more than once.
*/
+# define SYMBOLP(x) lisp_h_SYMBOLP (x)
# define TAGGEDP(a, tag) lisp_h_TAGGEDP (a, tag)
# define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x)
# define XCAR(c) lisp_h_XCAR (c)
@@ -616,7 +589,6 @@ #define ENUM_BF(TYPE) enum TYPE
extern void char_table_set (Lisp_Object, int, Lisp_Object);
/* Defined in data.c. */
-extern bool symbols_with_pos_enabled;
extern AVOID args_out_of_range_3 (Lisp_Object, Lisp_Object, Lisp_Object);
extern AVOID wrong_type_argument (Lisp_Object, Lisp_Object);
extern Lisp_Object default_value (Lisp_Object symbol);
@@ -1002,12 +974,57 @@ #define ROUNDUP(x, y) (POWER_OF_2 (y)
\
ptrdiff_t size;
};
-struct Lisp_Symbol_With_Pos
+INLINE bool
+(SYMBOLP) (Lisp_Object x)
{
- union vectorlike_header header;
- Lisp_Object sym; /* A symbol */
- Lisp_Object pos; /* A fixnum */
-} GCALIGNED_STRUCT;
+ return lisp_h_SYMBOLP (x);
+}
+
+INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED
+XSYMBOL (Lisp_Object a)
+{
+ eassert (SYMBOLP (a));
+ intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol);
+ void *p = (char *) lispsym + i;
+ return p;
+}
+
+INLINE Lisp_Object
+make_lisp_symbol (struct Lisp_Symbol *sym)
+{
+ /* GCC 7 x86-64 generates faster code if lispsym is
+ cast to char * rather than to intptr_t. */
+ char *symoffset = (char *) ((char *) sym - (char *) lispsym);
+ Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset);
+ eassert (XSYMBOL (a) == sym);
+ return a;
+}
+
+INLINE Lisp_Object
+builtin_lisp_symbol (int index)
+{
+ return make_lisp_symbol (&lispsym[index]);
+}
+
+INLINE bool
+c_symbol_p (struct Lisp_Symbol *sym)
+{
+ char *bp = (char *) lispsym;
+ char *sp = (char *) sym;
+ if (PTRDIFF_MAX < INTPTR_MAX)
+ return bp <= sp && sp < bp + sizeof lispsym;
+ else
+ {
+ ptrdiff_t offset = sp - bp;
+ return 0 <= offset && offset < sizeof lispsym;
+ }
+}
+
+INLINE void
+(CHECK_SYMBOL) (Lisp_Object x)
+{
+ lisp_h_CHECK_SYMBOL (x);
+}
/* In the size word of a vector, this bit means the vector has been marked. */
@@ -1032,7 +1049,6 @@ DEFINE_GDB_SYMBOL_END (PSEUDOVECTOR_FLAG)
PVEC_MARKER,
PVEC_OVERLAY,
PVEC_FINALIZER,
- PVEC_SYMBOL_WITH_POS,
PVEC_MISC_PTR,
PVEC_USER_PTR,
PVEC_PROCESS,
@@ -1092,92 +1108,6 @@ DEFINE_GDB_SYMBOL_END (PSEUDOVECTOR_FLAG)
values. They are macros for use in #if and static initializers. */
#define MOST_POSITIVE_FIXNUM (EMACS_INT_MAX >> INTTYPEBITS)
#define MOST_NEGATIVE_FIXNUM (-1 - MOST_POSITIVE_FIXNUM)
-
-INLINE bool
-PSEUDOVECTORP (Lisp_Object a, int code)
-{
- return lisp_h_PSEUDOVECTORP (a, code);
-}
-
-INLINE bool
-(BARE_SYMBOL_P) (Lisp_Object x)
-{
- return lisp_h_BARE_SYMBOL_P (x);
-}
-
-INLINE bool
-(SYMBOL_WITH_POS_P) (Lisp_Object x)
-{
- return lisp_h_SYMBOL_WITH_POS_P (x);
-}
-
-INLINE bool
-(SYMBOLP) (Lisp_Object x)
-{
- return lisp_h_SYMBOLP (x);
-}
-
-INLINE struct Lisp_Symbol_With_Pos *
-XSYMBOL_WITH_POS (Lisp_Object a)
-{
- eassert (SYMBOL_WITH_POS_P (a));
- return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos);
-}
-
-INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED
-(XBARE_SYMBOL) (Lisp_Object a)
-{
- eassert (BARE_SYMBOL_P (a));
- intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol);
- void *p = (char *) lispsym + i;
- return p;
-}
-
-INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED
-(XSYMBOL) (Lisp_Object a)
-{
- eassert (SYMBOLP ((a)));
- if (!symbols_with_pos_enabled || BARE_SYMBOL_P (a))
- return XBARE_SYMBOL (a);
- return XBARE_SYMBOL (XSYMBOL_WITH_POS (a)->sym);
-}
-
-INLINE Lisp_Object
-make_lisp_symbol (struct Lisp_Symbol *sym)
-{
- /* GCC 7 x86-64 generates faster code if lispsym is
- cast to char * rather than to intptr_t. */
- char *symoffset = (char *) ((char *) sym - (char *) lispsym);
- Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset);
- eassert (XSYMBOL (a) == sym);
- return a;
-}
-
-INLINE Lisp_Object
-builtin_lisp_symbol (int index)
-{
- return make_lisp_symbol (&lispsym[index]);
-}
-
-INLINE bool
-c_symbol_p (struct Lisp_Symbol *sym)
-{
- char *bp = (char *) lispsym;
- char *sp = (char *) sym;
- if (PTRDIFF_MAX < INTPTR_MAX)
- return bp <= sp && sp < bp + sizeof lispsym;
- else
- {
- ptrdiff_t offset = sp - bp;
- return 0 <= offset && offset < sizeof lispsym;
- }
-}
-
-INLINE void
-(CHECK_SYMBOL) (Lisp_Object x)
-{
- lisp_h_CHECK_SYMBOL (x);
-}
/* True if the possibly-unsigned integer I doesn't fit in a fixnum. */
@@ -1309,14 +1239,7 @@ make_fixed_natnum (EMACS_INT n)
}
/* Return true if X and Y are the same object. */
-INLINE bool
-(BASE_EQ) (Lisp_Object x, Lisp_Object y)
-{
- return lisp_h_BASE_EQ (x, y);
-}
-/* Return true if X and Y are the same object, reckoning a symbol with
- position as being the same as the bare symbol. */
INLINE bool
(EQ) (Lisp_Object x, Lisp_Object y)
{
@@ -1791,6 +1714,20 @@ PSEUDOVECTOR_TYPEP (const union vectorlike_header *a,
enum pvec_type code)
== (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS)));
}
+INLINE bool
+PSEUDOVECTORP (Lisp_Object a, int code)
+{
+ if (! VECTORLIKEP (a))
+ return false;
+ else
+ {
+ /* Converting to union vectorlike_header * avoids aliasing issues. */
+ return PSEUDOVECTOR_TYPEP (XUNTAG (a, Lisp_Vectorlike,
+ union vectorlike_header),
+ code);
+ }
+}
+
/* A boolvector is a kind of vectorlike, with contents like a string. */
struct Lisp_Bool_Vector
@@ -2702,22 +2639,6 @@ XOVERLAY (Lisp_Object a)
return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Overlay);
}
-INLINE Lisp_Object
-SYMBOL_WITH_POS_SYM (Lisp_Object a)
-{
- if (!SYMBOL_WITH_POS_P (a))
- wrong_type_argument (Qsymbol_with_pos_p, a);
- return XSYMBOL_WITH_POS (a)->sym;
-}
-
-INLINE Lisp_Object
-SYMBOL_WITH_POS_POS (Lisp_Object a)
-{
- if (!SYMBOL_WITH_POS_P (a))
- wrong_type_argument (Qsymbol_with_pos_p, a);
- return XSYMBOL_WITH_POS (a)->pos;
-}
-
INLINE bool
USER_PTRP (Lisp_Object x)
{
@@ -4179,7 +4100,6 @@ #define ALLOCATE_ZEROED_PSEUDOVECTOR(type, field, tag)
\
extern Lisp_Object make_float (double);
extern void display_malloc_warning (void);
extern ptrdiff_t inhibit_garbage_collection (void);
-extern Lisp_Object build_symbol_with_pos (Lisp_Object, Lisp_Object);
extern Lisp_Object build_overlay (Lisp_Object, Lisp_Object, Lisp_Object);
extern void free_cons (struct Lisp_Cons *);
extern void init_alloc_once (void);
diff --git a/src/lread.c b/src/lread.c
index 713c03243cb..4d7560f80c1 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -128,8 +128,7 @@ #define file_tell ftell
static ptrdiff_t read_from_string_index_byte;
static ptrdiff_t read_from_string_limit;
-/* Position in object from which characters are being read by `readchar'. */
-static EMACS_INT readchar_offset;
+static EMACS_INT readchar_charpos; /* one-indexed */
/* This contains the last string skipped with #@. */
static char *saved_doc_string;
@@ -170,7 +169,7 @@ #define file_tell ftell
char **, ptrdiff_t *,
ptrdiff_t *);
-
+
/* Functions that read one byte from the current source READCHARFUN
or unreads one byte. If the integer argument C is -1, it returns
one read byte, or -1 when there's no more byte in the source. If C
@@ -192,6 +191,8 @@ #define UNREAD(c) unreadchar (readcharfun, c)
/* Same as READCHAR but set *MULTIBYTE to the multibyteness of the source. */
#define READCHAR_REPORT_MULTIBYTE(multibyte) readchar (readcharfun, multibyte)
+#define ANNOTATE(atom) \
+ (annotated ? Fcons (make_fixnum (initial_charpos), atom) : atom)
/* When READCHARFUN is Qget_file_char, Qget_emacs_mule_file_char,
Qlambda, or a cons, we use this to keep an unread character because
@@ -212,7 +213,7 @@ readchar (Lisp_Object readcharfun, bool *multibyte)
if (multibyte)
*multibyte = 0;
- readchar_offset++;
+ readchar_charpos++;
if (BUFFERP (readcharfun))
{
@@ -423,7 +424,7 @@ skip_dyn_eof (Lisp_Object readcharfun)
static void
unreadchar (Lisp_Object readcharfun, int c)
{
- readchar_offset--;
+ readchar_charpos--;
if (c == -1)
/* Don't back up the pointer if we're unreading the end-of-input mark,
since readchar didn't advance it when we read it. */
@@ -482,7 +483,6 @@ readbyte_for_lambda (int c, Lisp_Object readcharfun)
return read_bytecode_char (c >= 0);
}
-
static int
readbyte_from_stdio (void)
{
@@ -648,15 +648,15 @@ read_emacs_mule_char (int c, int (*readbyte) (int,
Lisp_Object), Lisp_Object rea
static Lisp_Object read_internal_start (Lisp_Object, Lisp_Object,
Lisp_Object, bool);
static Lisp_Object read0 (Lisp_Object, bool);
-static Lisp_Object read1 (Lisp_Object, int *, bool, bool);
+static Lisp_Object read1 (Lisp_Object, int *, bool);
static Lisp_Object read_list (bool, Lisp_Object, bool);
-static Lisp_Object read_vector (Lisp_Object, bool, bool);
+static Lisp_Object read_vector (Lisp_Object, bool);
static Lisp_Object substitute_object_recurse (struct subst *, Lisp_Object);
static void substitute_in_interval (INTERVAL, void *);
-
+
/* Get a character from the tty. */
/* Read input events until we get one that's acceptable for our purposes.
@@ -705,8 +705,10 @@ read_filtered_event (bool no_switch_frame, bool
ascii_required,
/* Read until we get an acceptable event. */
retry:
do
- val = read_char (0, Qnil, (input_method ? Qnil : Qt), 0,
- NUMBERP (seconds) ? &end_time : NULL);
+ {
+ val = read_char (0, Qnil, (input_method ? Qnil : Qt), 0,
+ NUMBERP (seconds) ? &end_time : NULL);
+ }
while (FIXNUMP (val) && XFIXNUM (val) == -2); /* wrong_kboard_jmpbuf */
if (BUFFERP (val))
@@ -732,12 +734,12 @@ read_filtered_event (bool no_switch_frame, bool
ascii_required,
{
Lisp_Object tem, tem1;
tem = Fget (val, Qevent_symbol_element_mask);
- if (!NILP (tem))
+ if (! NILP (tem))
{
tem1 = Fget (Fcar (tem), Qascii_character);
/* Merge this symbol's modifier bits
with the ASCII equivalent of its basic code. */
- if (!NILP (tem1))
+ if (! NILP (tem1))
XSETFASTINT (val, XFIXNUM (tem1) | XFIXNUM (Fcar (Fcdr (tem))));
}
}
@@ -907,7 +909,7 @@ DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0,
0, 0,
}
-
+
/* Return true if the lisp code read using READCHARFUN defines a non-nil
`lexical-binding' file variable. After returning, the stream is
@@ -1038,7 +1040,7 @@ #define UPDATE_BEG_END_STATE(ch)
\
return rv;
}
}
-
+
/* Value is a version number of byte compiled code if the file
associated with file descriptor FD is a compiled Lisp file that's
safe to load. Only files compiled with Emacs can be loaded. */
@@ -1100,14 +1102,9 @@ load_error_handler (Lisp_Object data)
static void
load_warn_unescaped_character_literals (Lisp_Object file)
{
- Lisp_Object function
- = Fsymbol_function (Qbyte_run_unescaped_character_literals_warning);
- /* If byte-run.el is being loaded,
- `byte-run--unescaped-character-literals-warning' isn't yet
- defined. Since it'll be byte-compiled later, ignore potential
- unescaped character literals. */
- Lisp_Object warning = NILP (function) ? Qnil : call0 (function);
- if (!NILP (warning))
+ Lisp_Object warning =
+ safe_call (1, intern ("byte-run--unescaped-character-literals-warning"));
+ if (! NILP (warning))
{
AUTO_STRING (format, "Loading `%s': %s");
CALLN (Fmessage, format, file, warning);
@@ -1235,7 +1232,7 @@ DEFUN ("load", Fload, Sload, 1, 5, 0,
/* If file name is magic, call the handler. */
/* This shouldn't be necessary any more now that `openp' handles it right.
handler = Ffind_file_name_handler (file, Qload);
- if (!NILP (handler))
+ if (! NILP (handler))
return call5 (handler, Qload, file, noerror, nomessage, nosuffix); */
/* The presence of this call is the result of a historical accident:
@@ -1289,7 +1286,7 @@ DEFUN ("load", Fload, Sload, 1, 5, 0,
must_suffix = Qnil;
}
- if (!NILP (nosuffix))
+ if (! NILP (nosuffix))
suffixes = Qnil;
else
{
@@ -1381,7 +1378,7 @@ DEFUN ("load", Fload, Sload, 1, 5, 0,
int load_count = 0;
Lisp_Object tem = Vloads_in_progress;
FOR_EACH_TAIL_SAFE (tem)
- if (!NILP (Fequal (found, XCAR (tem))) && (++load_count > 3))
+ if (! NILP (Fequal (found, XCAR (tem))) && (++load_count > 3))
signal_error ("Recursive load", Fcons (found, Vloads_in_progress));
record_unwind_protect (record_load_unwind, Vloads_in_progress);
Vloads_in_progress = Fcons (found, Vloads_in_progress);
@@ -1451,7 +1448,7 @@ DEFUN ("load", Fload, Sload, 1, 5, 0,
newer = 1;
/* If we won't print another message, mention this anyway.
*/
- if (!NILP (nomessage) && !force_load_messages)
+ if (! NILP (nomessage) && !force_load_messages)
{
Lisp_Object msg_file;
msg_file = Fsubstring (found, make_fixnum (0),
make_fixnum (-1));
@@ -1465,7 +1462,7 @@ DEFUN ("load", Fload, Sload, 1, 5, 0,
else if (!is_module && !is_native_elisp)
{
/* We are loading a source file (*.el). */
- if (!NILP (Vload_source_file_function))
+ if (! NILP (Vload_source_file_function))
{
Lisp_Object val;
@@ -1594,7 +1591,7 @@ DEFUN ("load", Fload, Sload, 1, 5, 0,
unbind_to (count, Qnil);
/* Run any eval-after-load forms for this file. */
- if (!NILP (Ffboundp (Qdo_after_load_evaluation)))
+ if (! NILP (Ffboundp (Qdo_after_load_evaluation)))
call1 (Qdo_after_load_evaluation, hist_file_name) ;
xfree (saved_doc_string);
@@ -1633,7 +1630,7 @@ save_match_data_load (Lisp_Object file, Lisp_Object
noerror,
Lisp_Object result = Fload (file, noerror, nomessage, nosuffix, must_suffix);
return unbind_to (count, result);
}
-
+
static bool
complete_filename_p (Lisp_Object pathname)
{
@@ -1725,7 +1722,7 @@ maybe_swap_for_eln (bool no_native, Lisp_Object
*filename, int *fd,
src_name = concat2 (src_name, build_string (".gz"));
if (NILP (Ffile_exists_p (src_name)))
{
- if (!NILP (find_symbol_value (
+ if (! NILP (find_symbol_value (
Qnative_comp_warning_on_missing_source)))
call2 (intern_c_string ("display-warning"),
Qcomp,
@@ -1901,12 +1898,12 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object
suffixes,
else
string = make_string (fn, fnlen);
handler = Ffind_file_name_handler (string, Qfile_exists_p);
- if ((!NILP (handler) || (!NILP (predicate) && !EQ (predicate, Qt)))
+ if ((! NILP (handler) || (! NILP (predicate) && !EQ (predicate, Qt)))
&& !FIXNATP (predicate))
{
bool exists;
if (NILP (predicate) || EQ (predicate, Qt))
- exists = !NILP (Ffile_readable_p (string));
+ exists = ! NILP (Ffile_readable_p (string));
else
{
Lisp_Object tmp = call1 (predicate, string);
@@ -2041,7 +2038,7 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object
suffixes,
return -1;
}
-
+
/* Merge the list we've accumulated of globals from the current input source
into the load_history variable. The details depend on whether
the source has an associated file name or not.
@@ -2066,7 +2063,7 @@ build_load_history (Lisp_Object filename, bool entire)
tem = XCAR (tail);
/* Find the feature's previous assoc list... */
- if (!NILP (Fequal (filename, Fcar (tem))))
+ if (! NILP (Fequal (filename, Fcar (tem))))
{
foundit = 1;
@@ -2199,7 +2196,7 @@ readevalloop (Lisp_Object readcharfun,
specbind (Qstandard_input, readcharfun);
specbind (Qcurrent_load_list, Qnil);
record_unwind_protect_int (readevalloop_1, load_convert_to_unibyte);
- load_convert_to_unibyte = !NILP (unibyte);
+ load_convert_to_unibyte = ! NILP (unibyte);
/* If lexical binding is active (either because it was specified in
the file's header, or via a buffer-local variable), create an empty
@@ -2212,7 +2209,7 @@ readevalloop (Lisp_Object readcharfun,
/* Ensure sourcename is absolute, except whilst preloading. */
if (!will_dump_p ()
- && !NILP (sourcename) && !NILP (Ffile_name_absolute_p (sourcename)))
+ && ! NILP (sourcename) && ! NILP (Ffile_name_absolute_p (sourcename)))
sourcename = Fexpand_file_name (sourcename, Qnil);
LOADHIST_ATTACH (sourcename);
@@ -2225,7 +2222,7 @@ readevalloop (Lisp_Object readcharfun,
if (b != 0 && !BUFFER_LIVE_P (b))
error ("Reading from killed buffer");
- if (!NILP (start))
+ if (! NILP (start))
{
/* Switch to the buffer we are reading from. */
record_unwind_protect_excursion ();
@@ -2239,7 +2236,7 @@ readevalloop (Lisp_Object readcharfun,
/* Set point and ZV around stuff to be read. */
Fgoto_char (start);
- if (!NILP (end))
+ if (! NILP (end))
Fnarrow_to_region (make_fixnum (BEGV), end);
/* Just for cleanliness, convert END to a marker
@@ -2284,14 +2281,14 @@ readevalloop (Lisp_Object readcharfun,
= make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE,
DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD,
Qnil, false);
- if (!NILP (Vpurify_flag) && c == '(')
+ if (! NILP (Vpurify_flag) && c == '(')
{
val = read_list (0, readcharfun, false);
}
else
{
UNREAD (c);
- if (!NILP (readfun))
+ if (! NILP (readfun))
{
val = call1 (readfun, readcharfun);
@@ -2318,14 +2315,14 @@ readevalloop (Lisp_Object readcharfun,
&& XHASH_TABLE (read_objects_completed)->count > 0)
read_objects_completed = Qnil;
- if (!NILP (start) && continue_reading_p)
+ if (! NILP (start) && continue_reading_p)
start = Fpoint_marker ();
/* Restore saved point and BEGV. */
unbind_to (count1, Qnil);
/* Now eval what we just read. */
- if (!NILP (macroexpand))
+ if (! NILP (macroexpand))
val = readevalloop_eager_expand_eval (val, macroexpand);
else
val = eval_sub (val);
@@ -2400,7 +2397,7 @@ DEFUN ("eval-buffer", Feval_buffer, Seval_buffer, 0, 5,
"",
specbind (Qlexical_binding, lisp_file_lexically_bound_p (buf) ? Qt : Qnil);
BUF_TEMP_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf)));
readevalloop (buf, 0, filename,
- !NILP (printflag), unibyte, Qnil, Qnil, Qnil);
+ ! NILP (printflag), unibyte, Qnil, Qnil, Qnil);
return unbind_to (count, Qnil);
}
@@ -2434,13 +2431,32 @@ DEFUN ("eval-region", Feval_region, Seval_region, 2, 4,
"r",
/* `readevalloop' calls functions which check the type of start and end. */
readevalloop (cbuf, 0, BVAR (XBUFFER (cbuf), filename),
- !NILP (printflag), Qnil, read_function,
+ ! NILP (printflag), Qnil, read_function,
start, end);
return unbind_to (count, Qnil);
}
-
+DEFUN ("read-annotated", Fread_annotated, Sread_annotated, 1, 1, 0,
+ doc: /* Return parsed s-expr as `read' with each atom bundled
+with its charpos as (CHARPOS . ATOM). */)
+ (Lisp_Object buffer)
+{
+ Lisp_Object retval, warning;
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+ CHECK_BUFFER (buffer);
+ specbind (Qlread_unescaped_character_literals, Qnil);
+ retval = read_internal_start (buffer, Qnil, Qnil, true);
+
+ warning = safe_call (1, intern
("byte-run--unescaped-character-literals-warning"));
+ if (! NILP (warning))
+ call2 (intern ("byte-compile-warn"), build_string ("%s"), warning);
+
+ unbind_to (count, Qnil);
+ return retval;
+}
+
DEFUN ("read", Fread, Sread, 0, 1, 0,
doc: /* Read one Lisp expression as text from STREAM, return as Lisp
object.
If STREAM is nil, use the value of `standard-input' (which see).
@@ -2469,34 +2485,6 @@ DEFUN ("read", Fread, Sread, 0, 1, 0,
return read_internal_start (stream, Qnil, Qnil, false);
}
-DEFUN ("read-positioning-symbols", Fread_positioning_symbols,
- Sread_positioning_symbols, 0, 1, 0,
- doc: /* Read one Lisp expression as text from STREAM, return as Lisp
object.
-Convert each occurrence of a symbol 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)
-{
- 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, true);
-}
-
DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0,
doc: /* Read one Lisp expression which is represented as text by STRING.
Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).
@@ -2515,16 +2503,14 @@ DEFUN ("read-from-string", Fread_from_string,
Sread_from_string, 1, 3, 0,
}
/* 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. */
static Lisp_Object
-read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end,
- bool locate_syms)
+read_internal_start (Lisp_Object stream, Lisp_Object start,
+ Lisp_Object end, bool annotated)
{
Lisp_Object retval;
- readchar_offset = BUFFERP (stream) ? XBUFFER (stream)->pt : 0;
+ readchar_charpos = BUFFERP (stream) ? XBUFFER (stream)->pt : 1;
/* We can get called from readevalloop which may have set these
already. */
if (! HASH_TABLE_P (read_objects_map)
@@ -2557,7 +2543,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, annotated);
if (HASH_TABLE_P (read_objects_map)
&& XHASH_TABLE (read_objects_map)->count > 0)
read_objects_map = Qnil;
@@ -2566,25 +2552,23 @@ read_internal_start (Lisp_Object stream, Lisp_Object
start, Lisp_Object end,
read_objects_completed = Qnil;
return retval;
}
-
-/* Use this for recursive reads, in contexts where internal tokens
- are not allowed. */
+/* "read0" is merely an error-checked version of "read1". */
static Lisp_Object
-read0 (Lisp_Object readcharfun, bool locate_syms)
+read0 (Lisp_Object readcharfun, bool annotated)
{
register Lisp_Object val;
int c;
- val = read1 (readcharfun, &c, 0, locate_syms);
+ val = read1 (readcharfun, &c, annotated);
if (!c)
return val;
invalid_syntax_lisp (Fmake_string (make_fixnum (1), make_fixnum (c), Qnil),
readcharfun);
}
-
+
/* Grow a read buffer BUF that contains OFFSET useful bytes of data,
by at least MAX_MULTIBYTE_LENGTH bytes. Update *BUF_ADDR and
*BUF_SIZE accordingly; 0 <= OFFSET <= *BUF_SIZE. If *BUF_ADDR is
@@ -3000,16 +2984,14 @@ read_integer (Lisp_Object readcharfun, int radix,
/* If the next token is ')' or ']' or '.', we store that character
in *PCH and the return value is not interesting. Else, we store
zero in *PCH and we read and return one lisp object.
-
- FIRST_IN_LIST is true if this is the first element of a list.
- LOCATE_SYMS true means read symbol occurrences as symbols with
- position. */
+*/
static Lisp_Object
-read1 (Lisp_Object readcharfun, int *pch, bool first_in_list, bool locate_syms)
+read1 (Lisp_Object readcharfun, int *pch, bool annotated)
{
int c;
- bool uninterned_symbol = false;
+ EMACS_INT initial_charpos = readchar_charpos;
+ bool q_interned = true;
bool skip_shorthand = false;
bool multibyte;
char stackbuf[stackbufsize];
@@ -3019,6 +3001,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
retry:
+ initial_charpos = readchar_charpos;
c = READCHAR_REPORT_MULTIBYTE (&multibyte);
if (c < 0)
end_of_file_error ();
@@ -3026,16 +3009,16 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
switch (c)
{
case '(':
- return read_list (0, readcharfun, locate_syms);
+ return read_list (0, readcharfun, annotated);
case '[':
- return read_vector (readcharfun, 0, locate_syms);
+ return ANNOTATE (read_vector (readcharfun, 0));
case ')':
case ']':
{
*pch = c;
- return Qnil;
+ return ANNOTATE (Qnil);
}
case '#':
@@ -3048,6 +3031,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
/* Accept extended format for hash tables (extensible to
other types), e.g.
#s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
+
Lisp_Object tmp = read_list (0, readcharfun, false);
Lisp_Object head = CAR_SAFE (tmp);
Lisp_Object data = Qnil;
@@ -3070,7 +3054,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
tmp = Fcdr (tmp);
ASET (record, i, Fcar (tmp));
}
- return record;
+ return ANNOTATE (record);
}
tmp = CDR_SAFE (tmp);
@@ -3078,32 +3062,32 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
/* This is repetitive but fast and simple. */
params[param_count] = QCsize;
params[param_count + 1] = Fplist_get (tmp, Qsize);
- if (!NILP (params[param_count + 1]))
+ if (! NILP (params[param_count + 1]))
param_count += 2;
params[param_count] = QCtest;
params[param_count + 1] = Fplist_get (tmp, Qtest);
- if (!NILP (params[param_count + 1]))
+ if (! NILP (params[param_count + 1]))
param_count += 2;
params[param_count] = QCweakness;
params[param_count + 1] = Fplist_get (tmp, Qweakness);
- if (!NILP (params[param_count + 1]))
+ if (! NILP (params[param_count + 1]))
param_count += 2;
params[param_count] = QCrehash_size;
params[param_count + 1] = Fplist_get (tmp, Qrehash_size);
- if (!NILP (params[param_count + 1]))
+ if (! NILP (params[param_count + 1]))
param_count += 2;
params[param_count] = QCrehash_threshold;
params[param_count + 1] = Fplist_get (tmp, Qrehash_threshold);
- if (!NILP (params[param_count + 1]))
+ if (! NILP (params[param_count + 1]))
param_count += 2;
params[param_count] = QCpurecopy;
params[param_count + 1] = Fplist_get (tmp, Qpurecopy);
- if (!NILP (params[param_count + 1]))
+ if (! NILP (params[param_count + 1]))
param_count += 2;
/* This is the hash table data. */
@@ -3123,10 +3107,10 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
last = XCDR (data);
Fputhash (key, val, ht);
}
- if (!NILP (last))
+ if (! NILP (last))
error ("Hash table data is not a list of even length");
- return ht;
+ return ANNOTATE (ht);
}
UNREAD (c);
invalid_syntax ("#", readcharfun);
@@ -3137,11 +3121,11 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
if (c == '[')
{
Lisp_Object tmp;
- tmp = read_vector (readcharfun, 0, false);
+ tmp = read_vector (readcharfun, 0);
if (ASIZE (tmp) < CHAR_TABLE_STANDARD_SLOTS)
error ("Invalid size char-table");
XSETPVECTYPE (XVECTOR (tmp), PVEC_CHAR_TABLE);
- return tmp;
+ return ANNOTATE (tmp);
}
else if (c == '^')
{
@@ -3179,7 +3163,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
cell = XCONS (tmp), tmp = XCDR (tmp);
free_cons (cell);
}
- return tbl;
+ return ANNOTATE (tbl);
}
invalid_syntax ("#^^", readcharfun);
}
@@ -3188,7 +3172,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
if (c == '&')
{
Lisp_Object length;
- length = read1 (readcharfun, pch, first_in_list, false);
+ length = read1 (readcharfun, pch, false);
c = READCHAR;
if (c == '"')
{
@@ -3197,7 +3181,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
unsigned char *data;
UNREAD (c);
- tmp = read1 (readcharfun, pch, first_in_list, false);
+ tmp = read1 (readcharfun, pch, false);
if (STRING_MULTIBYTE (tmp)
|| (size_in_chars != SCHARS (tmp)
/* We used to print 1 char too many
@@ -3215,7 +3199,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
if (XFIXNUM (length) != size_in_chars * BOOL_VECTOR_BITS_PER_CHAR)
data[size_in_chars - 1]
&= (1 << (XFIXNUM (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
- return val;
+ return ANNOTATE (val);
}
invalid_syntax ("#&...", readcharfun);
}
@@ -3225,7 +3209,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
build them using function calls. */
Lisp_Object tmp;
struct Lisp_Vector *vec;
- tmp = read_vector (readcharfun, 1, false);
+ tmp = read_vector (readcharfun, 1);
vec = XVECTOR (tmp);
if (! (COMPILED_STACK_DEPTH < ASIZE (tmp)
&& (FIXNUMP (AREF (tmp, COMPILED_ARGLIST))
@@ -3254,7 +3238,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
}
XSETPVECTYPE (vec, PVEC_COMPILED);
- return tmp;
+ return ANNOTATE (tmp);
}
if (c == '(')
{
@@ -3262,7 +3246,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
int ch;
/* Read the string itself. */
- tmp = read1 (readcharfun, &ch, 0, false);
+ tmp = read1 (readcharfun, &ch, false);
if (ch != 0 || !STRINGP (tmp))
invalid_syntax ("#", readcharfun);
/* Read the intervals and their properties. */
@@ -3270,20 +3254,20 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
{
Lisp_Object beg, end, plist;
- beg = read1 (readcharfun, &ch, 0, false);
+ beg = read1 (readcharfun, &ch, false);
end = plist = Qnil;
if (ch == ')')
break;
if (ch == 0)
- end = read1 (readcharfun, &ch, 0, false);
+ end = read1 (readcharfun, &ch, false);
if (ch == 0)
- plist = read1 (readcharfun, &ch, 0, false);
+ plist = read1 (readcharfun, &ch, false);
if (ch)
invalid_syntax ("Invalid string property list", readcharfun);
Fset_text_properties (beg, end, plist, tmp);
}
- return tmp;
+ return ANNOTATE (tmp);
}
/* #@NUMBER is used to skip NUMBER following bytes.
@@ -3306,7 +3290,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
if (digits == 2 && nskip == 0)
{ /* We've just seen #@00, which means "skip to end". */
skip_dyn_eof (readcharfun);
- return Qnil;
+ return ANNOTATE (Qnil);
}
}
if (nskip > 0)
@@ -3386,13 +3370,13 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
goto retry;
}
if (c == '$')
- return Vload_file_name;
+ return ANNOTATE (Vload_file_name);
if (c == '\'')
- return list2 (Qfunction, read0 (readcharfun, locate_syms));
+ return ANNOTATE (list2 (Qfunction, read0 (readcharfun, false)));
/* #:foo is the uninterned symbol named foo. */
if (c == ':')
{
- uninterned_symbol = true;
+ q_interned = false;
read_hash_prefixed_symbol:
c = READCHAR;
if (!(c > 040
@@ -3403,7 +3387,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
/* No symbol character follows, this is the empty
symbol. */
UNREAD (c);
- return Fmake_symbol (empty_unibyte_string);
+ return ANNOTATE (Fmake_symbol (empty_unibyte_string));
}
goto read_symbol;
}
@@ -3415,7 +3399,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
}
/* ## is the empty symbol. */
if (c == '#')
- return Fintern (empty_unibyte_string, Qnil);
+ return ANNOTATE (Fintern (empty_unibyte_string, Qnil));
if (c >= '0' && c <= '9')
{
@@ -3435,7 +3419,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
{
if (! (2 <= n && n <= 36))
invalid_radix_integer (n, stackbuf, readcharfun);
- return read_integer (readcharfun, n, stackbuf);
+ return ANNOTATE (read_integer (readcharfun, n, stackbuf));
}
if (n <= MOST_POSITIVE_FIXNUM && ! NILP (Vread_circle))
@@ -3471,7 +3455,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
hash_put (h, number, placeholder, hash);
/* Read the object itself. */
- Lisp_Object tem = read0 (readcharfun, locate_syms);
+ Lisp_Object tem = read0 (readcharfun, false);
/* If it can be recursive, remember it for
future substitutions. */
@@ -3491,7 +3475,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
{
Fsetcar (placeholder, XCAR (tem));
Fsetcdr (placeholder, XCDR (tem));
- return placeholder;
+ return ANNOTATE (placeholder);
}
else
{
@@ -3503,7 +3487,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
eassert (i >= 0);
set_hash_value_slot (h, i, tem);
- return tem;
+ return ANNOTATE (tem);
}
}
@@ -3514,18 +3498,18 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
= XHASH_TABLE (read_objects_map);
ptrdiff_t i = hash_lookup (h, make_fixnum (n), NULL);
if (i >= 0)
- return HASH_VALUE (h, i);
+ return ANNOTATE (HASH_VALUE (h, i));
}
}
}
/* Fall through to error message. */
}
else if (c == 'x' || c == 'X')
- return read_integer (readcharfun, 16, stackbuf);
+ return ANNOTATE (read_integer (readcharfun, 16, stackbuf));
else if (c == 'o' || c == 'O')
- return read_integer (readcharfun, 8, stackbuf);
+ return ANNOTATE (read_integer (readcharfun, 8, stackbuf));
else if (c == 'b' || c == 'B')
- return read_integer (readcharfun, 2, stackbuf);
+ return ANNOTATE (read_integer (readcharfun, 2, stackbuf));
char acm_buf[15]; /* FIXME!!! 2021-11-27. */
sprintf (acm_buf, "#%c", c);
@@ -3538,10 +3522,10 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
goto retry;
case '\'':
- return list2 (Qquote, read0 (readcharfun, locate_syms));
+ return ANNOTATE (list2 (Qquote, read0 (readcharfun, false)));
case '`':
- return list2 (Qbackquote, read0 (readcharfun, locate_syms));
+ return ANNOTATE (list2 (Qbackquote, read0 (readcharfun, false)));
case ',':
{
@@ -3557,8 +3541,8 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
comma_type = Qcomma;
}
- value = read0 (readcharfun, locate_syms);
- return list2 (comma_type, value);
+ value = read0 (readcharfun, false);
+ return ANNOTATE (list2 (comma_type, value));
}
case '?':
{
@@ -3575,7 +3559,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
Other literal whitespace like NL, CR, and FF are not accepted,
as there are well-established escape sequences for these. */
if (c == ' ' || c == '\t')
- return make_fixnum (c);
+ return ANNOTATE (make_fixnum (c));
if (c == '(' || c == ')' || c == '[' || c == ']'
|| c == '"' || c == ';')
@@ -3601,7 +3585,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
&& strchr ("\"';()[]#?`,.", next_char) != NULL));
UNREAD (next_char);
if (ok)
- return make_fixnum (c);
+ return ANNOTATE (make_fixnum (c));
invalid_syntax ("?", readcharfun);
}
@@ -3709,8 +3693,8 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
/* If purifying, and string starts with \ newline,
return zero instead. This is for doc strings
that we are really going to find in etc/DOC.nn.nn. */
- if (!NILP (Vpurify_flag) && NILP (Vdoc_file_name) && cancel)
- return unbind_to (count, make_fixnum (0));
+ if (! NILP (Vpurify_flag) && NILP (Vdoc_file_name) && cancel)
+ return ANNOTATE (unbind_to (count, make_fixnum (0)));
if (! force_multibyte && force_singlebyte)
{
@@ -3725,7 +3709,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
= make_specified_string (read_buffer, nchars, p - read_buffer,
(force_multibyte
|| (p - read_buffer != nchars)));
- return unbind_to (count, result);
+ return ANNOTATE (unbind_to (count, result));
}
case '.':
@@ -3738,7 +3722,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
&& strchr ("\"';([#?`,", next_char) != NULL))
{
*pch = c;
- return Qnil;
+ return ANNOTATE (Qnil);
}
}
/* The atom-reading loop below will now loop at least once,
@@ -3759,7 +3743,8 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
char *p = read_buffer;
char *end = read_buffer + read_buffer_size;
bool quoted = false;
- EMACS_INT start_position = readchar_offset - 1;
+ ptrdiff_t nchars = 0;
+ Lisp_Object result = Qnil;
do
{
@@ -3796,86 +3781,75 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
ptrdiff_t nbytes = p - read_buffer;
UNREAD (c);
- if (!quoted && !uninterned_symbol && !skip_shorthand)
+ if (! quoted && q_interned && ! skip_shorthand)
{
- ptrdiff_t len;
- Lisp_Object result = string_to_number (read_buffer, 10, &len);
- if (! NILP (result) && len == nbytes)
- return unbind_to (count, result);
+ result = string_to_number (read_buffer, 10, &nchars);
+ if (nchars != nbytes)
+ result = Qnil;
}
- {
- Lisp_Object result;
- ptrdiff_t nchars
- = (multibyte
- ? multibyte_chars_in_text ((unsigned char *) read_buffer,
- nbytes)
- : nbytes);
-
- if (uninterned_symbol)
- {
- Lisp_Object name
- = ((! NILP (Vpurify_flag)
- ? make_pure_string : make_specified_string)
- (read_buffer, nchars, nbytes, multibyte));
- result = Fmake_symbol (name);
- }
- else
- {
- /* Don't create the string object for the name unless
- we're going to retain it in a new symbol.
-
- Like intern_1 but supports multibyte names. */
- Lisp_Object obarray = check_obarray (Vobarray);
-
- char* longhand = NULL;
- ptrdiff_t longhand_chars = 0;
- ptrdiff_t longhand_bytes = 0;
-
- Lisp_Object tem;
- if (skip_shorthand
- /* The following ASCII characters are used in the
- only "core" Emacs Lisp symbols that are comprised
- entirely of characters that have the 'symbol
- constituent' syntax. We exempt them from
- transforming according to shorthands. */
- || strspn (read_buffer, "^*+-/<=>_|") >= nbytes)
- tem = oblookup (obarray, read_buffer, nchars, nbytes);
- else
- tem = oblookup_considering_shorthand (obarray, read_buffer,
- nchars, nbytes, &longhand,
- &longhand_chars,
- &longhand_bytes);
-
- if (SYMBOLP (tem))
- result = tem;
- else if (longhand)
- {
- Lisp_Object name
- = make_specified_string (longhand, longhand_chars,
- longhand_bytes, multibyte);
- xfree (longhand);
- result = intern_driver (name, obarray, tem);
- }
- else
- {
- Lisp_Object name
- = make_specified_string (read_buffer, nchars, nbytes,
- multibyte);
- result = intern_driver (name, obarray, tem);
- }
- }
- if (locate_syms
- && !NILP (result)
- )
- result = build_symbol_with_pos (result,
- make_fixnum (start_position));
- return unbind_to (count, result);
- }
+ if (NILP (result))
+ {
+ nchars = (multibyte
+ ? multibyte_chars_in_text ((unsigned char *) read_buffer,
+ nbytes)
+ : nbytes);
+ if (! q_interned)
+ {
+ Lisp_Object name
+ = ((! NILP (Vpurify_flag)
+ ? make_pure_string : make_specified_string)
+ (read_buffer, nchars, nbytes, multibyte));
+ result = Fmake_symbol (name);
+ }
+ else
+ {
+ /* Don't create the string object for the name unless
+ we're going to retain it in a new symbol.
+
+ Like intern_1 but supports multibyte names. */
+ char* longhand = NULL;
+ ptrdiff_t longhand_chars = 0, longhand_bytes = 0;
+
+ Lisp_Object tem;
+ if (skip_shorthand
+ /* The following ASCII characters are used in the
+ only "core" Emacs Lisp symbols that are comprised
+ entirely of characters that have the 'symbol
+ constituent' syntax. We exempt them from
+ transforming according to shorthands. */
+ || strspn (read_buffer, "^*+-/<=>_|") >= nbytes)
+ tem = oblookup (Vobarray, read_buffer, nchars, nbytes);
+ else
+ tem = oblookup_considering_shorthand (Vobarray, read_buffer,
+ nchars, nbytes,
&longhand,
+ &longhand_chars,
+ &longhand_bytes);
+ if (SYMBOLP (tem))
+ result = tem;
+ else if (longhand)
+ {
+ Lisp_Object name
+ = make_specified_string (longhand, longhand_chars,
+ longhand_bytes, multibyte);
+ xfree (longhand);
+ result = intern_driver (name, Vobarray, tem);
+ }
+ else
+ {
+ Lisp_Object name
+ = make_specified_string (read_buffer, nchars, nbytes,
+ multibyte);
+ result = intern_driver (name, Vobarray, tem);
+ }
+ }
+ }
+
+ return ANNOTATE (unbind_to (count, result));
}
}
}
-
+
DEFUN ("lread--substitute-object-in-subtree",
Flread__substitute_object_in_subtree,
Slread__substitute_object_in_subtree, 3, 3, 0,
@@ -3909,7 +3883,7 @@ substitute_object_recurse (struct subst *subst,
Lisp_Object subtree)
return subtree;
/* If we've been to this node before, don't explore it again. */
- if (!NILP (Fmemq (subtree, subst->seen)))
+ if (! NILP (Fmemq (subtree, subst->seen)))
return subtree;
/* If this node can be the entry point to a cycle, remember that
@@ -3980,7 +3954,7 @@ substitute_in_interval (INTERVAL interval, void *arg)
substitute_object_recurse (arg, interval->plist));
}
-
+
/* Convert the initial prefix of STRING to a number, assuming base BASE.
If the prefix has floating point syntax and BASE is 10, return a
nearest float; otherwise, if the prefix has integer syntax, return
@@ -4120,11 +4094,11 @@ string_to_number (char const *string, int base,
ptrdiff_t *plen)
return result;
}
-
+
static Lisp_Object
-read_vector (Lisp_Object readcharfun, bool bytecodeflag, bool locate_syms)
+read_vector (Lisp_Object readcharfun, bool bytecodeflag)
{
- Lisp_Object tem = read_list (1, readcharfun, locate_syms);
+ Lisp_Object tem = read_list (1, readcharfun, false);
ptrdiff_t size = list_length (tem);
Lisp_Object vector = make_nil_vector (size);
@@ -4196,40 +4170,30 @@ read_vector (Lisp_Object readcharfun, bool
bytecodeflag, bool locate_syms)
return vector;
}
-/* FLAG means check for ']' to terminate rather than ')' and '.'.
- LOCATE_SYMS true means read symbol occurrencess as symbols with
- position. */
+/* FLAG means check for ']' to terminate rather than ')' and '.'. */
static Lisp_Object
-read_list (bool flag, Lisp_Object readcharfun, bool locate_syms)
+read_list (bool flag, Lisp_Object readcharfun, bool annotated)
{
- Lisp_Object val, tail;
+ Lisp_Object val = Qnil, tail = Qnil;
Lisp_Object elt, tem;
/* 0 is the normal case.
1 means this list is a doc reference; replace it with the number 0.
2 means this list is a doc reference; replace it with the doc string. */
int doc_reference = 0;
- /* Initialize this to 1 if we are reading a list. */
- bool first_in_list = flag <= 0;
-
- val = Qnil;
- tail = Qnil;
-
while (1)
{
int ch;
- elt = read1 (readcharfun, &ch, first_in_list, locate_syms);
-
- first_in_list = 0;
+ elt = read1 (readcharfun, &ch, annotated);
/* While building, if the list starts with #$, treat it specially. */
if (EQ (elt, Vload_file_name)
&& ! NILP (elt))
{
- if (!NILP (Vpurify_flag))
+ if (! NILP (Vpurify_flag))
doc_reference = 0;
- else if (load_force_doc_strings)
+ else if (load_force_doc_strings && ! annotated)
doc_reference = 2;
}
if (ch)
@@ -4244,11 +4208,11 @@ read_list (bool flag, Lisp_Object readcharfun, bool
locate_syms)
return val;
if (ch == '.')
{
- if (!NILP (tail))
- XSETCDR (tail, read0 (readcharfun, locate_syms));
+ if (! NILP (tail))
+ XSETCDR (tail, read0 (readcharfun, annotated));
else
- val = read0 (readcharfun, locate_syms);
- read1 (readcharfun, &ch, 0, locate_syms);
+ val = read0 (readcharfun, annotated);
+ read1 (readcharfun, &ch, annotated);
if (ch == ')')
{
@@ -4321,14 +4285,15 @@ read_list (bool flag, Lisp_Object readcharfun, bool
locate_syms)
invalid_syntax ("] in a list", readcharfun);
}
tem = list1 (elt);
- if (!NILP (tail))
+ if (! NILP (tail))
XSETCDR (tail, tem);
else
val = tem;
tail = tem;
}
}
-
+#undef ANNOTATE
+
static Lisp_Object initial_obarray;
/* `oblookup' stores the bucket number here, for the sake of Funintern. */
@@ -4442,7 +4407,7 @@ define_symbol (Lisp_Object sym, char const *str)
intern_sym (sym, initial_obarray, bucket);
}
}
-
+
DEFUN ("intern", Fintern, Sintern, 1, 2, 0,
doc: /* Return the canonical symbol whose name is STRING.
If there is none, one is created by this function and returned.
@@ -4519,7 +4484,7 @@ DEFUN ("intern-soft", Fintern_soft, Sintern_soft, 1, 2, 0,
return EQ (name, tem) ? name : Qnil;
}
}
-
+
DEFUN ("unintern", Funintern, Sunintern, 1, 2, 0,
doc: /* Delete the symbol named NAME, if any, from OBARRAY.
The value is t if a symbol was found and deleted, nil otherwise.
@@ -4601,7 +4566,7 @@ DEFUN ("unintern", Funintern, Sunintern, 1, 2, 0,
return Qt;
}
-
+
/* Return the symbol in OBARRAY whose names matches the string
of SIZE characters (SIZE_BYTE bytes) at PTR.
If there is no such symbol, return the integer bucket number of
@@ -4704,7 +4669,7 @@ oblookup_considering_shorthand (Lisp_Object obarray,
const char *in,
return oblookup (obarray, in, size, size_byte);
}
-
+
void
map_obarray (Lisp_Object obarray, void (*fn) (Lisp_Object, Lisp_Object),
Lisp_Object arg)
{
@@ -4773,7 +4738,7 @@ init_obarray_once (void)
DEFSYM (Qvariable_documentation, "variable-documentation");
}
-
+
void
defsubr (union Aligned_Lisp_Subr *aname)
{
@@ -4854,7 +4819,7 @@ defvar_kboard (struct Lisp_Kboard_Objfwd const *ko_fwd,
char const *namestring)
XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
SET_SYMBOL_FWD (XSYMBOL (sym), ko_fwd);
}
-
+
/* Check that the elements of lpath exist. */
static void
@@ -4865,7 +4830,7 @@ load_path_check (Lisp_Object lpath)
/* The only elements that might not exist are those from
PATH_LOADSEARCH, EMACSLOADPATH. Anything else is only added if
it exists. */
- for (path_tail = lpath; !NILP (path_tail); path_tail = XCDR (path_tail))
+ for (path_tail = lpath; ! NILP (path_tail); path_tail = XCDR (path_tail))
{
Lisp_Object dirfile;
dirfile = Fcar (path_tail);
@@ -4923,7 +4888,7 @@ load_path_default (void)
lpath = decode_env_path (0, PATH_LOADSEARCH, 0);
- if (!NILP (Vinstallation_directory))
+ if (! NILP (Vinstallation_directory))
{
Lisp_Object tem, tem1;
@@ -4933,7 +4898,7 @@ load_path_default (void)
tem = Fexpand_file_name (build_string ("lisp"),
Vinstallation_directory);
tem1 = Ffile_accessible_directory_p (tem);
- if (!NILP (tem1))
+ if (! NILP (tem1))
{
if (NILP (Fmember (tem, lpath)))
{
@@ -4959,7 +4924,7 @@ load_path_default (void)
tem = Fexpand_file_name (build_string ("site-lisp"),
Vinstallation_directory);
tem1 = Ffile_accessible_directory_p (tem);
- if (!NILP (tem1))
+ if (! NILP (tem1))
{
if (NILP (Fmember (tem, lpath)))
lpath = Fcons (tem, lpath);
@@ -4985,7 +4950,7 @@ load_path_default (void)
tem = Fexpand_file_name (build_string ("src/Makefile.in"),
Vinstallation_directory);
tem2 = Ffile_exists_p (tem);
- if (!NILP (tem1) && NILP (tem2))
+ if (! NILP (tem1) && NILP (tem2))
{
tem = Fexpand_file_name (build_string ("lisp"),
Vsource_directory);
@@ -4998,7 +4963,7 @@ load_path_default (void)
tem = Fexpand_file_name (build_string ("site-lisp"),
Vsource_directory);
tem1 = Ffile_accessible_directory_p (tem);
- if (!NILP (tem1))
+ if (! NILP (tem1))
{
if (NILP (Fmember (tem, lpath)))
lpath = Fcons (tem, lpath);
@@ -5124,8 +5089,8 @@ dir_warning (char const *use, Lisp_Object dirname)
syms_of_lread (void)
{
defsubr (&Sread);
- defsubr (&Sread_positioning_symbols);
defsubr (&Sread_from_string);
+ defsubr (&Sread_annotated);
defsubr (&Slread__substitute_object_in_subtree);
defsubr (&Sintern);
defsubr (&Sintern_soft);
@@ -5366,10 +5331,6 @@ syms_of_lread (void)
DEFSYM (Qlread_unescaped_character_literals,
"lread--unescaped-character-literals");
- /* Defined in lisp/emacs-lisp/byte-run.el. */
- DEFSYM (Qbyte_run_unescaped_character_literals_warning,
- "byte-run--unescaped-character-literals-warning");
-
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
diff --git a/src/pdumper.c b/src/pdumper.c
index f4e8e4af28a..60280fcb043 100644
--- a/src/pdumper.c
+++ b/src/pdumper.c
@@ -2948,7 +2948,7 @@ dump_vectorlike (struct dump_context *ctx,
Lisp_Object lv,
dump_off offset)
{
-#if CHECK_STRUCTS && !defined HASH_pvec_type_AFF6FED5BD
+#if CHECK_STRUCTS && !defined HASH_pvec_type_19F6CF5169
# error "pvec_type changed. See CHECK_STRUCTS comment in config.h."
#endif
const struct Lisp_Vector *v = XVECTOR (lv);
@@ -3032,8 +3032,6 @@ dump_vectorlike (struct dump_context *ctx,
error_unsupported_dump_object (ctx, lv, "sqlite");
case PVEC_MODULE_FUNCTION:
error_unsupported_dump_object (ctx, lv, "module function");
- case PVEC_SYMBOL_WITH_POS:
- error_unsupported_dump_object (ctx, lv, "symbol with pos");
default:
error_unsupported_dump_object(ctx, lv, "weird pseudovector");
}
diff --git a/src/print.c b/src/print.c
index 04a271ce456..7440a82f6fd 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1649,30 +1649,6 @@ print_vectorlike (Lisp_Object obj, Lisp_Object
printcharfun, bool escapeflag,
printchar ('>', printcharfun);
break;
- case PVEC_SYMBOL_WITH_POS:
- {
- struct Lisp_Symbol_With_Pos *sp = XSYMBOL_WITH_POS (obj);
- if (print_symbols_bare)
- print_object (sp->sym, printcharfun, escapeflag);
- else
- {
- print_c_string ("#<symbol ", printcharfun);
- if (BARE_SYMBOL_P (sp->sym))
- print_object (sp->sym, printcharfun, escapeflag);
- else
- print_c_string ("NOT A SYMBOL!!", printcharfun);
- if (FIXNUMP (sp->pos))
- {
- print_c_string (" at ", printcharfun);
- print_object (sp->pos, printcharfun, escapeflag);
- }
- else
- print_c_string (" NOT A POSITION!!", printcharfun);
- printchar ('>', printcharfun);
- }
- }
- break;
-
case PVEC_OVERLAY:
print_c_string ("#<overlay ", printcharfun);
if (! XMARKER (OVERLAY_START (obj))->buffer)
@@ -1998,7 +1974,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun,
bool escapeflag)
error ("Apparently circular structure being printed");
for (i = 0; i < print_depth; i++)
- if (BASE_EQ (obj, being_printed[i]))
+ if (EQ (obj, being_printed[i]))
{
int len = sprintf (buf, "#%d", i);
strout (buf, len, len, printcharfun);
@@ -2502,13 +2478,6 @@ syms_of_print (void)
`default'. */);
Vprint_charset_text_property = Qdefault;
- DEFVAR_BOOL ("print-symbols-bare", print_symbols_bare,
- doc: /* A flag to control printing of symbols with position.
-If the value is nil, print these objects complete with position.
-Otherwise print just the bare symbol. */);
- print_symbols_bare = false;
- DEFSYM (Qprint_symbols_bare, "print-symbols-bare");
-
/* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
staticpro (&Vprin1_to_string_buffer);
diff --git a/src/sqlite.c b/src/sqlite.c
index 649cb382948..af88187b32c 100644
--- a/src/sqlite.c
+++ b/src/sqlite.c
@@ -1,7 +1,7 @@
/*
Copyright (C) 2021-2022 Free Software Foundation, Inc.
-This file is part of GNU Emacs.
+This file is NOT part of GNU Emacs.
GNU Emacs is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
diff --git a/test/Makefile.in b/test/Makefile.in
index 9ad994e1101..2badb614b18 100644
--- a/test/Makefile.in
+++ b/test/Makefile.in
@@ -159,8 +159,8 @@ SELECTOR_ACTUAL=
endif
## Byte-compile all test files to test for errors.
-%.elc: %.el
- $(AM_V_ELC)$(emacs) --batch -f batch-byte-compile $<
+%.elc: %.el $(srcdir)/../lisp/emacs-lisp/bytecomp.el
+ $(AM_V_ELC) $(emacs) --batch -f batch-byte-compile $<
## Save logs, and show logs for failed tests.
WRITE_LOG = > $@ 2>&1 || { STAT=$$?; cat $@; exit $$STAT; }
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el
b/test/lisp/emacs-lisp/bytecomp-tests.el
index abd33ab8e5a..8db9210f91d 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -790,11 +790,11 @@ test-byte-comp-macro-expand-lexical-override
(defun def () (m))))
(should (equal (funcall 'def) 4)))
-
+
;;;; Warnings.
(ert-deftest bytecomp-tests--warnings ()
- (with-current-buffer (get-buffer-create "*Compile-Log*")
+ (with-current-buffer (get-buffer-create byte-compile-log-buffer)
(let ((inhibit-read-only t)) (erase-buffer)))
(mapc #'fmakunbound '(my-test0 my--test11 my--test12 my--test2))
(test-byte-comp-compile-and-load t
@@ -807,7 +807,7 @@ bytecomp-tests--warnings
(eval-and-compile
(defmacro my--test12 (arg) (+ arg 1))
(defun my--test2 (arg) (+ arg 1)))))
- (with-current-buffer (get-buffer-create "*Compile-Log*")
+ (with-current-buffer (get-buffer-create byte-compile-log-buffer)
(goto-char (point-min))
;; Should warn that mt--test1[12] are first used as functions.
;; The second alternative is for when the file name is so long
@@ -822,12 +822,138 @@ bytecomp-tests--warnings
(defmacro bytecomp--with-warning-test (re-warning &rest form)
(declare (indent 1))
- `(with-current-buffer (get-buffer-create "*Compile-Log*")
+ `(with-current-buffer (get-buffer-create byte-compile-log-buffer)
(let ((inhibit-read-only t)) (erase-buffer))
(byte-compile ,@form)
(ert-info ((prin1-to-string (buffer-string)) :prefix "buffer: ")
(should (re-search-forward ,(string-replace " " "[ \n]+"
re-warning))))))
+(defmacro bytecomp--buffer-with-warning-test (re-warnings &rest forms)
+ (declare (indent 1))
+ `(with-current-buffer (get-buffer-create byte-compile-log-buffer)
+ (let ((inhibit-read-only t)) (erase-buffer))
+ (save-excursion
+ (let ((buffer (generate-new-buffer "*bytecomp-tests*")))
+ (with-current-buffer buffer
+ (mapc (lambda (form)
+ (if (stringp form)
+ (insert form)
+ (insert (format "%S\n" form))))
+ ',forms))
+ (byte-compile-from-buffer buffer)
+ (let (kill-buffer-query-functions)
+ (kill-buffer buffer))))
+ (ert-info ((prin1-to-string (buffer-string)) :prefix "buffer: ")
+ (dolist (re-warning (if (atom ,re-warnings)
+ (list ,re-warnings)
+ ,re-warnings))
+ (should (re-search-forward (string-replace " " "[ \n]+"
re-warning)))))))
+
+(ert-deftest bytecomp-warn-absent-require-cl-lib ()
+ (bytecomp--buffer-with-warning-test
+ "cl-member-if. might not be defined"
+ (cl-member-if (function cl-evenp) (list 1 2 3))))
+
+(ert-deftest bytecomp-warn-coordinates ()
+ (let ((byte-compile-current-file "his-fooness.el"))
+ (bytecomp--buffer-with-warning-test
+ '("his-fooness.el:3:2"
+ "his-fooness.el:9:6"
+ "his-fooness.el:16:6"
+ "his-fooness.el:20:6"
+ "his-fooness.el:24:11"
+ "his-fooness.el:24:11"
+ "his-fooness.el:29:2" ;; let special form kicks back to defun
+ "his-fooness.el:31:3"
+ "his-fooness.el:32:2" ;; let special form kicks back to defun
+ "his-fooness.el:34:10"
+ "his-fooness.el:32:2" ;; this one too
+ "his-fooness.el:4:4" ;; cl-lib might not be defined at runtime.
+ )
+ "
+(bytecomp-tests-warn-coordinates-basic)
+(defsubst bytecomp-tests-warn-coordinates-basic ()
+ (cl-member-if (function cl-evenp) (list 1 2 3)))
+(defun bytecomp-tests-warn-coordinates-roland ()
+ (unwind-protect
+ (let ((foo \"foo\"))
+ (insert foo))
+ (setq foo \"bar\")))
+(defun bytecomp-tests-warn-coordinates-eglen ()
+ \"Fix page breaks in SAS 6 print files.\"
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (if (looking-at \"\f\") (delete-char 1))
+ (replace-regexp \"^\\(.+\\)\f\" \"\\1\n\f\n\")
+ (goto-char (point-min))
+ (replace-regexp \"^\f\\(.+\\)\" \"\f\n\\1\")
+ (goto-char (point-min))))
+(defun bytecomp-tests-warn-coordinates-kenichi (v)
+ (or (= (length v 0))
+ (= (length v) 1)))
+(defun bytecomp-tests-warn-coordinates-ynyaaa (_files)
+ (and t (string-match 1))
+ (and t (string-match 1 2)))
+(defun bytecomp-tests-warn-coordinates-clement ()
+ (let ((a)))
+ a)
+(defun bytecomp-tests-warn-coordinates-not-clement ()
+ (let ((a)))
+ (progn a)
+ (let ((a)))
+ a)
+")))
+
+(ert-deftest bytecomp-warn-present-require-cl-lib ()
+ (should-error
+ (bytecomp--buffer-with-warning-test
+ "cl-member-if. might not be defined"
+ (require 'cl-lib)
+ (cl-member-if (function cl-evenp) (list 1 2 3)))))
+
+(ert-deftest bytecomp-read-annotated-equivalence ()
+ (cl-macrolet
+ ((bytecomp
+ (file &rest body)
+ `(with-temp-buffer
+ (save-excursion (insert-file-contents
+ (expand-file-name
+ ,file
+ (concat (file-name-as-directory
+ (or (getenv "EMACS_TEST_DIRECTORY")
+ default-directory))
+ ".."))))
+ ,@body)))
+ (dolist (file '("lisp/emacs-lisp/cl-generic.el"
+ "lisp/international/mule-cmds.el"
+ "test/lisp/emacs-lisp/macroexp-tests.el"))
+ (let ((annotated-read
+ (bytecomp
+ file
+ (cl-loop while (progn
+ (while (progn (skip-chars-forward " \t\n\^l")
+ (= (following-char) ?\;))
+ (forward-line 1))
+ (not (eobp)))
+ collect (byte-compile--decouple
+ (read-annotated (current-buffer))
+ #'cdr))))
+ (just-read
+ (bytecomp
+ file
+ (cl-loop while (progn
+ (while (progn (skip-chars-forward " \t\n\^l")
+ (= (following-char) ?\;))
+ (forward-line 1))
+ (not (eobp)))
+ collect (read (current-buffer))))))
+ (should
+ (condition-case nil
+ (equal annotated-read just-read)
+ (circular-list (equal (safe-length annotated-read)
+ (safe-length just-read)))))))))
+
(ert-deftest bytecomp-warn-wrong-args ()
(bytecomp--with-warning-test "remq.*3.*2"
'(remq 1 2 3)))
@@ -852,7 +978,7 @@ bytecomp-warn-wide-docstring/defvar
(defmacro bytecomp--define-warning-file-test (file re-warning &optional
reverse)
`(ert-deftest ,(intern (format "bytecomp/%s" file)) ()
- (with-current-buffer (get-buffer-create "*Compile-Log*")
+ (with-current-buffer (get-buffer-create byte-compile-log-buffer)
(let ((inhibit-read-only t)) (erase-buffer))
(byte-compile-file ,(ert-resource-file file))
(ert-info ((buffer-string) :prefix "buffer: ")
@@ -1023,7 +1149,6 @@ "warn-variable-set-nonvariable.el"
"nowarn-inline-after-defvar.el"
"Lexical argument shadows" 'reverse)
-
;;;; Macro expansion.
(ert-deftest test-eager-load-macro-expansion ()
@@ -1113,15 +1238,16 @@ bytecomp-tests--test-no-warnings-with-advice
(defun f ())
(define-advice f (:around (oldfun &rest args) test)
(apply oldfun args))
- (with-current-buffer (get-buffer-create "*Compile-Log*")
+ (with-current-buffer (get-buffer-create byte-compile-log-buffer)
(let ((inhibit-read-only t)) (erase-buffer)))
(test-byte-comp-compile-and-load t '(defun f ()))
- (with-current-buffer (get-buffer-create "*Compile-Log*")
+ (with-current-buffer (get-buffer-create byte-compile-log-buffer)
(goto-char (point-min))
(should-not (search-forward "Warning" nil t))))
(ert-deftest bytecomp-test-featurep-warnings ()
- (let ((byte-compile-log-buffer (generate-new-buffer " *Compile-Log*")))
+ (let ((byte-compile-log-buffer
+ (generate-new-buffer (concat " " byte-compile-log-buffer))))
(unwind-protect
(progn
(with-temp-buffer
@@ -1193,7 +1319,8 @@ bytecomp-test--switch-duplicates
(defun test-suppression (form suppress match)
(let ((lexical-binding t)
- (byte-compile-log-buffer (generate-new-buffer " *Compile-Log*")))
+ (byte-compile-log-buffer
+ (generate-new-buffer (concat " " byte-compile-log-buffer))))
;; Check that we get a warning without suppression.
(with-current-buffer byte-compile-log-buffer
(setq-local fill-column 9999)
diff --git a/test/lisp/emacs-lisp/gv-tests.el b/test/lisp/emacs-lisp/gv-tests.el
index 0757e3c7aa5..f150bd21cfa 100644
--- a/test/lisp/emacs-lisp/gv-tests.el
+++ b/test/lisp/emacs-lisp/gv-tests.el
@@ -32,7 +32,7 @@ gv-tests--in-temp-dir
(let ((,elvar "gv-test-deffoo.el")
(,elcvar "gv-test-deffoo.elc"))
(with-temp-file ,elvar
- (insert ";; -*- lexical-binding: t; -*-\n")
+ (insert ";; -*- lexical-binding: t; -*-\n(require 'gv)\n")
(dolist (form ',filebody)
(pp form (current-buffer))))
,@body)))
@@ -117,7 +117,8 @@ gv-define-expander-out-of-file
(with-temp-buffer
(call-process (concat invocation-directory invocation-name)
nil '(t t) nil
- "-Q" "-batch" "--eval" (prin1-to-string
`(byte-compile-file ,el))
+ "-Q" "-batch"
+ "--eval" (prin1-to-string `(byte-compile-file ,el))
"-l" elc
"--eval"
(prin1-to-string '(progn (setf (gv-test-foo gv-test-pair)
99)
--
2.26.2
In Commercial Emacs 0.2.1snapshot a8a0cc3 in dev (upstream 29.0.50,
x86_64-pc-linux-gnu) built on dick
Repository revision: a8a0cc3a11c149851f324a9a9bea0d4c6e0d5def
Repository branch: dev
Windowing system distributor 'The X.Org Foundation', version 11.0.12013000
System Description: Ubuntu 20.04.3 LTS
Configured using:
'configure --prefix=/home/dick/.local --with-tree-sitter
--enable-dumping-overwrite 'CFLAGS=-g3 -O2
-I/home/dick/.local/include/' LDFLAGS=-L/home/dick/.local/lib'
Configured features:
CAIRO DBUS FREETYPE GIF GLIB GMP GNUTLS GSETTINGS HARFBUZZ JPEG JSON
TREE_SITTER LCMS2 LIBSELINUX LIBXML2 MODULES NOTIFY INOTIFY PDUMPER PNG
RSVG SECCOMP SOUND THREADS TIFF TOOLKIT_SCROLL_BARS WEBP X11 XDBE XIM
XPM GTK3 ZLIB
Important settings:
value of $LANG: en_US.UTF-8
locale-coding-system: utf-8-unix
Major mode: Group
Minor modes in effect:
gnus-topic-mode: t
gnus-undo-mode: t
projectile-mode: t
flx-ido-mode: t
override-global-mode: t
winner-mode: t
tooltip-mode: t
show-paren-mode: t
mouse-wheel-mode: t
file-name-shadow-mode: t
global-font-lock-mode: t
font-lock-mode: t
blink-cursor-mode: t
auto-composition-mode: t
auto-encryption-mode: t
auto-compression-mode: t
buffer-read-only: t
column-number-mode: t
line-number-mode: t
transient-mark-mode: t
Load-path shadows:
/home/dick/gomacro-mode/gomacro-mode hides
/home/dick/.emacs.d/elpa/gomacro-mode-20200326.1103/gomacro-mode
/home/dick/.emacs.d/elpa/hydra-20170924.2259/lv hides
/home/dick/.emacs.d/elpa/lv-20191106.1238/lv
/home/dick/.emacs.d/elpa/magit-3.3.0/magit-section-pkg hides
/home/dick/.emacs.d/elpa/magit-section-3.3.0/magit-section-pkg
/home/dick/org-gcal.el/org-gcal hides
/home/dick/.emacs.d/elpa/org-gcal-0.3/org-gcal
/home/dick/.emacs.d/lisp/json hides
/home/dick/.local/share/emacs/0.2.1/lisp/json
/home/dick/.emacs.d/elpa/transient-0.3.6/transient hides
/home/dick/.local/share/emacs/0.2.1/lisp/transient
/home/dick/.emacs.d/elpa/hierarchy-20171221.1151/hierarchy hides
/home/dick/.local/share/emacs/0.2.1/lisp/emacs-lisp/hierarchy
Features:
(shadow bbdb-message footnote emacsbug sendmail gnus-html url-queue
help-fns radix-tree flow-fill gravatar dns gnus-notifications gnus-fun
notifications gnus-kill utf-7 qp sort smiley mail-extr textsec
uni-scripts idna-mapping ucs-normalize uni-confusable textsec-check
gnus-async gnus-ml disp-table nndoc gnus-dup benchmark mm-archive
url-cache debbugs-gnu add-log debbugs soap-client rng-xsd rng-dt
rng-util xsd-regexp nnrss nnfolder nndiscourse rbenv nnhackernews
nntwitter nntwitter-api bbdb-gnus gnus-demon nntp nnmairix nnml nnreddit
gnus-topic url-http url-auth url-gw network-stream gnutls nsm request
virtualenvwrapper gud s json-rpc python gnus-score score-mode gnus-bcklg
gnus-srvr gnus-cite anaphora bbdb-mua bbdb-com bbdb bbdb-site timezone
gnus-delay gnus-draft gnus-cache gnus-agent gnus-msg gnus-art mm-uu
mml2015 mm-view mml-smime smime dig gnus-sum shr pixel-fill kinsoku svg
dom nndraft nnmh gnus-group mm-url gnus-undo use-package
use-package-delight use-package-diminish gnus-start gnus-dbus dbus xml
gnus-cloud nnimap nnmail mail-source utf7 netrc nnoo parse-time iso8601
gnus-spec gnus-int gnus-range message yank-media rmc puny dired-x dired
dired-loaddefs rfc822 mml mml-sec epa epg rfc6068 epg-config mm-decode
mm-bodies mm-encode mail-parse rfc2231 rfc2047 rfc2045 ietf-drums
mailabbrev gmm-utils mailheader gnus-win smerge-mode diff vc-git
vc-dispatcher whitespace diff-mode paredit-ext paredit subed subed-vtt
subed-srt subed-common subed-mpv subed-debug subed-config inf-ruby
ruby-mode smie company pcase haskell-interactive-mode
haskell-presentation-mode haskell-process haskell-session
haskell-compile haskell-mode haskell-cabal haskell-utils
haskell-font-lock haskell-indentation haskell-string
haskell-sort-imports haskell-lexeme haskell-align-imports
haskell-complete-module haskell-ghc-support noutline outline
flymake-proc flymake warnings etags fileloop generator xref project
dabbrev haskell-customize hydra lv use-package-ensure solarized-theme
solarized-definitions projectile lisp-mnt ibuf-ext ibuffer
ibuffer-loaddefs thingatpt magit-autorevert autorevert filenotify
magit-git magit-section magit-utils crm dash rx grep compile comint
ansi-color gnus nnheader range mail-utils mm-util mail-prsvr gnus-util
text-property-search time-date flx-ido flx google-translate-default-ui
google-translate-core-ui facemenu color ido google-translate-core
google-translate-tk google-translate-backend use-package-bind-key
bind-key auto-complete easy-mmode advice edmacro kmacro popup cus-edit
pp cus-load wid-edit emms-player-mplayer emms-player-simple emms
emms-compat cl-extra help-mode use-package-core derived winner ring
finder-inf json-reformat-autoloads json-snatcher-autoloads
sml-mode-autoloads tornado-template-mode-autoloads info package
browse-url url url-proxy url-privacy url-expand url-methods url-history
url-cookie url-domsuf url-util mailcap url-handlers url-parse
auth-source cl-seq eieio eieio-core cl-macs eieio-loaddefs
password-cache json map url-vars seq gv subr-x byte-opt bytecomp
byte-compile cconv cldefs cl-loaddefs cl-lib iso-transl tooltip eldoc
paren electric uniquify ediff-hook vc-hooks lisp-float-type elisp-mode
mwheel term/x-win x-win term/common-win x-dnd tool-bar dnd fontset image
regexp-opt fringe tree-sitter tabulated-list replace newcomment
text-mode lisp-mode prog-mode register page tab-bar menu-bar rfn-eshadow
isearch easymenu timer select scroll-bar mouse jit-lock font-lock syntax
font-core term/tty-colors frame minibuffer cl-generic cham georgian
utf-8-lang misc-lang vietnamese tibetan thai tai-viet lao korean
japanese eucjp-ms cp51932 hebrew greek romanian slovak czech european
ethiopic indian cyrillic chinese composite emoji-zwj charscript charprop
case-table epa-hook jka-cmpr-hook help simple abbrev obarray
cl-preloaded nadvice button loaddefs faces cus-face macroexp files
window text-properties overlay sha1 md5 base64 format env code-pages
mule custom widget keymap hashtable-print-readable backquote threads
dbusbind inotify lcms2 dynamic-setting system-font-setting
font-render-setting cairo move-toolbar gtk x-toolkit x multi-tty
make-network-process emacs)
Memory information:
((conses 16 878999 83139)
(symbols 48 35304 3)
(strings 32 177445 23342)
(string-bytes 1 5085348)
(vectors 16 75009)
(vector-slots 8 1051120 70621)
(floats 8 4045 863)
(intervals 56 13903 1539)
(buffers 992 29))
- bug#53905: 29.0.50; [PATCH] Back out scratch/correct-warning-pos,
dick . r . chiang <=