mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-04-23 14:32:12 -07:00
Code Issues Projects Releases Wiki Activity

Merge commit '9cbdf20316' into native-comp

Browse source
This commit is contained in:
Andrea Corallo 2021-03-09 10:03:47 +01:00
commit 43b0df62cd
227 changed files with 37660 additions and 40546 deletions
Download patch file Download diff file Expand all files Collapse all files

2
.gitignore vendored
View file

@ -254,6 +254,8 @@ doc/*/*/*.ps
doc/emacs/emacsver.texi
doc/man/emacs.1
doc/misc/cc-mode.ss
doc/misc/modus-themes.texi
doc/misc/org.texi
etc/DOC
etc/refcards/emacsver.tex
gnustmp*

48
Makefile.in
View file

@ -168,9 +168,6 @@ infodir=@infodir@
# Info files not in the doc/misc directory (we get those via make echo-info).
INFO_NONMISC=emacs.info eintr.info elisp.info
# If no makeinfo was found and configured --without-makeinfo, "no"; else "yes".
HAVE_MAKEINFO=@HAVE_MAKEINFO@
# Directory for local state files for all programs.
localstatedir=@localstatedir@
@ -661,9 +658,6 @@ install-etcdoc: src install-arch-indep
## If info/dir is missing, but we have install-info, we should let
## that handle it. If info/dir is present and we do not have install-info,
## we should check for missing entries and add them by hand.
##
## FIXME:
## If HAVE_MAKEINFO = no and there are no info files, do not install info/dir.
install-info: info
umask 022; ${MKDIR_P} "$(DESTDIR)${infodir}"
-unset CDPATH; \
@ -675,10 +669,9 @@ install-info: info
[ -f "$(DESTDIR)${infodir}/dir" ] || \
[ ! -f ${srcdir}/info/dir ] || \
${INSTALL_DATA} ${srcdir}/info/dir "$(DESTDIR)${infodir}/dir"; \
info_misc=`$(MAKE) --no-print-directory -s -C doc/misc echo-info`; \
info_misc=`MAKEFLAGS= $(MAKE) --no-print-directory -s -C doc/misc echo-info`; \
cd ${srcdir}/info ; \
for elt in ${INFO_NONMISC} $${info_misc}; do \
test "$(HAVE_MAKEINFO)" = "no" && test ! -f $$elt && continue; \
for f in `ls $$elt $$elt-[1-9] $$elt-[1-9][0-9] 2>/dev/null`; do \
(cd "$${thisdir}"; \
${INSTALL_DATA} ${srcdir}/info/$$f "$(DESTDIR)${infodir}/$$f"); \
@ -796,7 +789,7 @@ uninstall: uninstall-$(NTDIR) uninstall-doc
done
-rm -rf "$(DESTDIR)${libexecdir}/emacs/${version}"
thisdir=`/bin/pwd`; \
(info_misc=`$(MAKE) --no-print-directory -s -C doc/misc echo-info`; \
(info_misc=`MAKEFLAGS= $(MAKE) --no-print-directory -s -C doc/misc echo-info`; \
if cd "$(DESTDIR)${infodir}"; then \
for elt in ${INFO_NONMISC} $${info_misc}; do \
(cd "$${thisdir}"; \
@ -1005,24 +998,34 @@ $(DOCS):
$(MAKE) -C doc/$(subst -, ,$@)
.PHONY: $(DOCS) docs pdf ps
.PHONY: info dvi dist html info-real info-dir check-info
.PHONY: info dvi dist html info-dir check-info
## TODO add etc/refcards.
docs: $(DOCS)
dvi: $(DVIS)
html: $(HTMLS)
info-real: $(INFOS)
info: $(INFOS) info-dir
pdf: $(PDFS)
ps: $(PSS)
# This dependency is due to those doc/misc/ manuals that use .org sources.
# Depending on src is sufficient, but ends up being slow, since the
# uncompiled lisp/org/*.el files are used to build the .texi files
# (which can be slow even with the elc files).
misc-info: lisp
# Using src rather than lisp because one is less likely to get unnecessary
# rebuilds of stuff that is not strictly necessary for generating manuals.
misc-dvi misc-html misc-pdf misc-ps: src
info-dir: ${srcdir}/info/dir
## Hopefully doc/misc/*.texi is not too long for some systems?
texi_misc = $(shell MAKEFLAGS= ${MAKE} --no-print-directory -s -C doc/misc echo-sources)
srcdir_doc_info_dir_inputs = \
${srcdir}/doc/emacs/emacs.texi \
${srcdir}/doc/lispintro/emacs-lisp-intro.texi \
${srcdir}/doc/lispref/elisp.texi \
$(sort $(wildcard ${srcdir}/doc/misc/*.texi))
$(addprefix ${srcdir}/doc/misc/,${texi_misc})
info_dir_inputs = \
../build-aux/dir_top \
$(subst ${srcdir}/doc/,,${srcdir_doc_info_dir_inputs})
@ -1035,7 +1038,7 @@ info_dir_deps = \
## installation location by the install-info rule, but we also
## need one in the source directory for people running uninstalled.
## FIXME it would be faster to use the install-info program if we have it,
## but then we would need to depend on info-real, which would
## but then we would need to depend on ${INFOS}, which would
## slow down parallelization.
${srcdir}/info/dir: ${info_dir_deps}
$(AM_V_at)${MKDIR_P} ${srcdir}/info
@ -1090,23 +1093,6 @@ uninstall-html: $(UNINSTALL_HTML)
uninstall-pdf: $(UNINSTALL_PDF)
uninstall-ps: $(UNINSTALL_PS)
# Note that man/Makefile knows how to put the info files in $(srcdir),
# so we can do ok running make in the build dir.
# This used to have a clause that exited with an error if MAKEINFO = no.
# But it is inappropriate to do so without checking if makeinfo is
# actually needed - it is not if the info files are up-to-date. (Bug#3982)
# Only the doc/*/Makefiles can decide that, so we let those rules run
# and give a standard error if makeinfo is needed but missing.
# While it would be nice to give a more detailed error message, that
# would require changing every rule in doc/ that builds an info file,
# and it's not worth it. This case is only relevant if you download a
# release, then change the .texi files.
info:
ifneq ($(HAVE_MAKEINFO),no)
$(MAKE) info-real info-dir
endif
## build-aux/make-info-dir expects only certain dircategories.
check-info: info
cd info ; \

5
admin/admin.el
View file

@ -665,6 +665,8 @@ style=\"text-align:left\">")
(defconst make-manuals-dist-output-variables
'(("@\\(top_\\)?srcdir@" . ".") ; top_srcdir is wrong, but not used
("@abs_top_builddir@" . ".") ; wrong but unused
("^\\(EMACS *=\\).*" . "\\1 emacs")
("^\\(\\(?:texinfo\\|buildinfo\\|emacs\\)dir *=\\).*" . "\\1 .")
("^\\(clean:.*\\)" . "\\1 infoclean")
("@MAKEINFO@" . "makeinfo")
@ -714,7 +716,8 @@ style=\"text-align:left\">")
(string-match-p "\\.\\(eps\\|pdf\\)\\'" file)))
(copy-file file stem)))
(with-temp-buffer
(let ((outvars make-manuals-dist-output-variables))
(let ((outvars make-manuals-dist-output-variables)
(case-fold-search nil))
(push `("@version@" . ,version) outvars)
(insert-file-contents (format "../doc/%s/Makefile.in" type))
(dolist (cons outvars)

2
admin/grammars/c.by
View file

@ -415,7 +415,7 @@ typesimple
: struct-or-class opt-class opt-name opt-template-specifier
opt-class-parents semantic-list
(TYPE-TAG (car $3) (car $1)
(let ((semantic-c-classname (cons (car ,$3) (car ,$1))))
(dlet ((semantic-c-classname (cons (car ,$3) (car ,$1))))
(EXPANDFULL $6 classsubparts))
$5
:template-specifier $4

29
admin/grammars/python.wy
View file

@ -88,7 +88,7 @@
%package wisent-python-wy
%provide semantic/wisent/python-wy
%expectedconflicts 4
%expectedconflicts 5
%{
(declare-function wisent-python-reconstitute-function-tag
@ -184,6 +184,7 @@
%token <punctuation> ASSIGN "="
%token <punctuation> BACKQUOTE "`"
%token <punctuation> AT "@"
%token <punctuation> FOLLOWS "->"
;; -----------------
@ -808,12 +809,17 @@ decorators
;; funcdef: [decorators] 'def' NAME parameters ':' suite
funcdef
: DEF NAME function_parameter_list COLON suite
: DEF NAME function_parameter_list return_type_hint COLON suite
(wisent-python-reconstitute-function-tag
(FUNCTION-TAG $2 nil $3) $5)
| decorators DEF NAME function_parameter_list COLON suite
(FUNCTION-TAG $2 nil $3) $6)
| decorators DEF NAME function_parameter_list return_type_hint COLON suite
(wisent-python-reconstitute-function-tag
(FUNCTION-TAG $3 nil $4 :decorators $1) $6)
(FUNCTION-TAG $3 nil $4 :decorators $1) $7)
;
return_type_hint
: ;;EMPTY
| FOLLOWS type
;
function_parameter_list
@ -887,7 +893,7 @@ paren_classes
;; parser can parse general expressions, I don't see much benefit in
;; generating a string of expression as base class "name".
paren_class
: dotted_name
: type
;
;;;****************************************************************************
@ -1140,7 +1146,7 @@ fpdef_opt_test
;; fpdef: NAME | '(' fplist ')'
fpdef
: NAME
: NAME type_hint
(VARIABLE-TAG $1 nil nil)
;; Below breaks the parser. Don't know why, but my guess is that
;; LPAREN/RPAREN clashes with the ones in function_parameters.
@ -1160,6 +1166,15 @@ fpdef
;; | fpdef_list COMMA fpdef
;; ;
type_hint
: ;;EMPTY
| COLON type
;
type
: test
;
;; ['=' test]
eq_test_opt
: ;;EMPTY

30
build-aux/make-info-dir
View file

@ -52,8 +52,11 @@ exec "${AWK-awk}" '
topic[ntopics++] = "Emacs misc features"
topic[ntopics++] = "Emacs lisp libraries"
topic[ntopics] = "Unknown category"
texinfo = 0
}
/^@dircategory / {
texinfo = 1
sub(/^@dircategory /, "")
detexinfo()
for (dircat = 0; dircat < ntopics && topic[dircat] != $0; dircat++)
@ -66,6 +69,33 @@ exec "${AWK-awk}" '
data[dircat] = data[dircat] $0 "\n"
}
}
## Org stuff. TODO we assume the order of the texinfo items.
{
## TODO Check FILENAME suffix instead?
## TODO Is this portable awk?
if (FNR == 1) texinfo = 0
## If applied to the generated org.texi file, this picks up the examples.
## Thanks for making life more difficult...
if (texinfo) next
if (tolower($0) ~ /^#\+texinfo_dir_category/) {
sub(/^#[^:]*: /, "")
for (dircat = 0; dircat < ntopics && topic[dircat] != $0; dircat++)
continue;
}
if (tolower($0) ~ /^#\+texinfo_dir_title/) {
sub(/^#[^:]*: /, "")
## Note this does not fill any long descriptions.
data[dircat] = data[dircat] sprintf("* %-30s", ($0 ". "))
}
if (tolower($0) ~ /^#\+texinfo_dir_desc/) {
sub(/^#[^:]*: /, "")
data[dircat] = data[dircat] $0 ".\n"
}
}
END {
for (dircat = 0; dircat <= ntopics; dircat++)
if (data[dircat])

34
configure.ac
View file

@ -508,11 +508,6 @@ otherwise for the first of 'inotify', 'kqueue' or 'gfile' that is usable.])
OPTION_DEFAULT_OFF([xwidgets],
[enable use of xwidgets in Emacs buffers (requires gtk3 or macOS Cocoa)])
## For the times when you want to build Emacs but don't have
## a suitable makeinfo, and can live without the manuals.
dnl https://lists.gnu.org/r/emacs-devel/2008-04/msg01844.html
OPTION_DEFAULT_ON([makeinfo],[don't require makeinfo for building manuals])
## Makefile.in needs the cache file name.
AC_SUBST(cache_file)
@ -1346,14 +1341,13 @@ if test -n "$BREW"; then
fi
## Require makeinfo >= 4.13 (last of the 4.x series) to build the manuals.
if test "${MAKEINFO:=makeinfo}" != "no"; then
case `($MAKEINFO --version) 2>/dev/null` in
*' (GNU texinfo) '4.1[[3-9]]* | \
*' (GNU texinfo) '[[5-9]]* | \
*' (GNU texinfo) '[[1-9][0-9]]* ) ;;
*) MAKEINFO=no;;
esac
fi
: ${MAKEINFO:=makeinfo}
case `($MAKEINFO --version) 2>/dev/null` in
*' (GNU texinfo) '4.1[[3-9]]* | \
*' (GNU texinfo) '[[5-9]]* | \
*' (GNU texinfo) '[[1-9][0-9]]* ) ;;
*) MAKEINFO=no;;
esac
## Makeinfo is unusual. For a released Emacs, the manuals are
## pre-built, and not deleted by the normal clean rules. makeinfo is
@ -1364,21 +1358,19 @@ fi
## should test for it as it does for any other build requirement.
## We use the presence of $srcdir/info/emacs to distinguish a release,
## with pre-built manuals, from a repository checkout.
HAVE_MAKEINFO=yes
if test "$MAKEINFO" = "no"; then
MAKEINFO=makeinfo
if test "x${with_makeinfo}" = "xno"; then
HAVE_MAKEINFO=no
elif test ! -e "$srcdir/info/emacs" && test ! -e "$srcdir/info/emacs.info"; then
if test ! -e "$srcdir/info/emacs" && test ! -e "$srcdir/info/emacs.info"; then
AC_MSG_ERROR( [You do not seem to have makeinfo >= 4.13, and your
source tree does not seem to have pre-built manuals in the 'info' directory.
Either install a suitable version of makeinfo, or re-run configure
with the '--without-makeinfo' option to build without the manuals.] )
Please install a suitable version of makeinfo.] )
else
AC_MSG_WARN( [You do not seem to have makeinfo >= 4.13.
You will not be able to rebuild the manuals if you delete them or change
their sources.] )
fi
fi
AC_SUBST([MAKEINFO])
AC_SUBST(HAVE_MAKEINFO)
if test $opsys = mingw32; then
DOCMISC_W32=efaq-w32

7
doc/emacs/package.texi
View file

@ -126,6 +126,13 @@ line; typing @kbd{x} (see below) will delete the package.
@xref{Package Files}, for information about what package deletion
entails.
@item w
@kindex w @r{(Package Menu)}
@findex package-browse-url
Open the home page of the package on the current line in a browser
(@code{package-browse-url}). @code{browse-url} is used to open the
browser.
@item ~
@kindex ~ @r{(Package Menu)}
@findex package-menu-mark-obsolete-for-deletion

12
doc/lispref/control.texi
View file

@ -617,17 +617,13 @@ match, @code{and} matches.
@item (or @var{pattern1} @var{pattern2}@dots{})
Attempts to match @var{pattern1}, @var{pattern2}, @dots{}, in order,
until one of them succeeds. In that case, @code{or} likewise matches,
and the rest of the sub-patterns are not tested. (Note that there
must be at least two sub-patterns.
Simply @w{@code{(or @var{pattern1})}} signals error.)
@c Issue: Is this correct and intended?
@c Are there exceptions, qualifications?
@c (Btw, ``Please avoid it'' is a poor error message.)
and the rest of the sub-patterns are not tested.
To present a consistent environment (@pxref{Intro Eval})
to @var{body-forms} (thus avoiding an evaluation error on match),
if any of the sub-patterns let-binds a set of symbols,
they @emph{must} all bind the same set of symbols.
the set of variables bound by the pattern is the union of the
variables bound by each sub-pattern. If a variable is not bound by
the sub-pattern that matched, then it is bound to @code{nil}.
@ifnottex
@anchor{rx in pcase}

26
doc/lispref/customize.texi
View file

@ -1474,7 +1474,7 @@ To protect against loading themes containing malicious code, Emacs
displays the source file and asks for confirmation from the user
before loading any non-built-in theme for the first time. As
such, themes are not ordinarily byte-compiled, and source files
always take precedence when Emacs is looking for a theme to load.
usually take precedence when Emacs is looking for a theme to load.
The following functions are useful for programmatically enabling and
disabling themes:
@ -1508,6 +1508,30 @@ confirmation before loading the theme, unless the optional argument
@var{no-confirm} is non-@code{nil}.
@end deffn
@defun require-theme feature &optional noerror
This function searches @code{custom-theme-load-path} for a file that
provides @var{feature} and then loads it. This is like the function
@code{require} (@pxref{Named Features}), except it searches
@code{custom-theme-load-path} instead of @code{load-path}
(@pxref{Library Search}). This can be useful in Custom themes that
need to load supporting Lisp files when @code{require} is unsuitable
for that.
If @var{feature}, which should be a symbol, is not already present in
the current Emacs session according to @code{featurep}, then
@code{require-theme} searches for a file named @var{feature} with an
added @samp{.elc} or @samp{.el} suffix, in that order, in the
directories specified by @code{custom-theme-load-path}.
If a file providing @var{feature} is successfully found and loaded,
then @code{require-theme} returns @var{feature}. The optional
argument @var{noerror} determines what happens if the search or
loading fails. If it is @code{nil}, the function signals an error;
otherwise, it returns @code{nil}. If the file loads successfully but
does not provide @var{feature}, then @code{require-theme} signals an
error; this cannot be suppressed.
@end defun
@deffn Command enable-theme theme
This function enables the Custom theme named @var{theme}. It signals
an error if no such theme has been loaded.

3
doc/lispref/elisp.texi
View file

@ -1408,8 +1408,9 @@ Low-Level Network Access
Packing and Unpacking Byte Arrays
* Bindat Spec:: Describing data layout.
* Bindat Types:: Describing data layout.
* Bindat Functions:: Doing the unpacking and packing.
* Bindat Computed Types:: Advanced data layout specifications.
Emacs Display

9
doc/lispref/functions.texi
View file

@ -1181,7 +1181,7 @@ This form defines a method like @code{cl-defmethod} does.
@end table
@end defmac
@defmac cl-defmethod name [qualifier] arguments [&context (expr spec)@dots{}] &rest [docstring] body
@defmac cl-defmethod name [extra] [qualifier] arguments [&context (expr spec)@dots{}] &rest [docstring] body
This macro defines a particular implementation for the generic
function called @var{name}. The implementation code is given by
@var{body}. If present, @var{docstring} is the documentation string
@ -1267,6 +1267,10 @@ Parent type: @code{array}.
@item font-object
@end table
The optional @var{extra} element, expressed as @samp{:extra
@var{string}}, allows you to add more methods, distinguished by
@var{string}, for the same specializers and qualifiers.
The optional @var{qualifier} allows combining several applicable
methods. If it is not present, the defined method is a @dfn{primary}
method, responsible for providing the primary implementation of the
@ -1288,9 +1292,6 @@ This auxiliary method will run @emph{instead} of the primary method.
The most specific of such methods will be run before any other method.
Such methods normally use @code{cl-call-next-method}, described below,
to invoke the other auxiliary or primary methods.
@item :extra @var{string}
This allows you to add more methods, distinguished by @var{string},
for the same specializers and qualifiers.
@end table
Functions defined using @code{cl-defmethod} cannot be made

5
doc/lispref/minibuf.texi
View file

@ -701,8 +701,9 @@ A history list for numbers read by @code{read-number}.
@end defvar
@defvar goto-line-history
A history list for arguments to @code{goto-line}. This variable is
buffer local.
A history list for arguments to @code{goto-line}. This variable can
be made local in every buffer by customizing the user option
@code{goto-line-history-local}.
@end defvar
@c Less common: coding-system-history, input-method-history,

2
doc/lispref/numbers.texi
View file

@ -1250,7 +1250,7 @@ other strings to choose various seed values.
This function returns a pseudo-random integer. Repeated calls return a
series of pseudo-random integers.
If @var{limit} is a positive fixnum, the value is chosen to be
If @var{limit} is a positive integer, the value is chosen to be
nonnegative and less than @var{limit}. Otherwise, the value might be
any fixnum, i.e., any integer from @code{most-negative-fixnum} through
@code{most-positive-fixnum} (@pxref{Integer Basics}).

317
doc/lispref/processes.texi
View file

@ -3354,29 +3354,37 @@ To use the functions referred to in this section, load the
direction is also known as @dfn{serializing} or @dfn{packing}.
@menu
* Bindat Spec:: Describing data layout.
* Bindat Functions:: Doing the unpacking and packing.
* Bindat Types:: Describing data layout.
* Bindat Functions:: Doing the unpacking and packing.
* Bindat Computed Types:: Advanced data layout specifications.
@end menu
@node Bindat Spec
@node Bindat Types
@subsection Describing Data Layout
@cindex bindat types
@cindex data layout specification
@cindex bindat type expression
@cindex base type, in bindat specification
@cindex composite type, in bindat specification
To control unpacking and packing, you write a @dfn{data layout
specification}, a special nested list describing named and typed
@dfn{fields}. This specification controls the length of each field to be
processed, and how to pack or unpack it. We normally keep bindat specs
in variables whose names end in @samp{-bindat-spec}; that kind of name
is automatically recognized as risky.
specification}, also called a @dfn{Bindat type expression}. This can
be a @dfn{base type} or a @dfn{composite type} made of several fields,
where the specification controls the length of each field to be
processed, and how to pack or unpack it. We normally keep bindat type
values in variables whose names end in @code{-bindat-spec}; that kind
of name is automatically recognized as risky (@pxref{File Local
Variables}).
@defmac bindat-spec &rest specs
Creates a Bindat spec object according to the data layout
specification @var{specs}.
@defmac bindat-type &rest type
Creates a Bindat type @emph{value} object according to the Bindat type
@emph{expression} @var{type}.
@end defmac
@cindex endianness
@cindex big endian
@cindex little endian
@cindex network byte ordering
@cindex endianness, in bindat specification
@cindex big endian, in bindat specification
@cindex little endian, in bindat specification
@cindex network byte ordering, in Bindat specification
A field's @dfn{type} describes the size (in bytes) of the object
that the field represents and, in the case of multibyte fields, how
the bytes are ordered within the field. The two possible orderings
@ -3391,167 +3399,90 @@ type values:
@itemx byte
Unsigned byte, with length 1.
@item u16
@itemx word
@itemx short
Unsigned integer in network byte order, with length 2.
@item uint @var{bitlen}
Unsigned integer in network byte order, with @var{bitlen} bits.
@var{bitlen} has to be a multiple of 8.
@item u24
Unsigned integer in network byte order, with length 3.
@item u32
@itemx dword
@itemx long
Unsigned integer in network byte order, with length 4.
@item u64
Unsigned integer in network byte order, with length 8.
@item u16r
@itemx u24r
@itemx u32r
@itemx u64r
Unsigned integer in little endian order, with length 2, 3, 4, and
8, respectively.
@item uintr @var{bitlen}
Unsigned integer in little endian order, with @var{bitlen} bits.
@var{bitlen} has to be a multiple of 8.
@item str @var{len}
String of length @var{len}.
String of bytes of length @var{len}.
@item strz @var{len}
Zero-terminated string, in a fixed-size field with length @var{len}.
Zero-terminated string of bytes, in a fixed-size field with length @var{len}.
@item vec @var{len} [@var{type}]
Vector of @var{len} elements of type @var{type}, defaulting to bytes.
The @var{type} is any of the simple types above, or another vector
specified as a list of the form @code{(vec @var{len} [@var{type}])}.
Vector of @var{len} elements. The type of the elements is given by
@var{type}, defaulting to bytes. The @var{type} can be any Bindat
type expression.
@item ip
@c FIXME? IPv6?
Four-byte vector representing an Internet address. For example:
@code{[127 0 0 1]} for localhost.
@item repeat @var{len} [@var{type}]
Like @code{vec}, but it unpacks to and packs from lists, whereas
@code{vec} unpacks to vectors.
@item bits @var{len}
List of set bits in @var{len} bytes. The bytes are taken in big
endian order and the bits are numbered starting with @code{8 *
@var{len} @minus{} 1} and ending with zero. For example: @code{bits
2} unpacks @code{#x28} @code{#x1c} to @code{(2 3 4 11 13)} and
@code{#x1c} @code{#x28} to @code{(3 5 10 11 12)}.
@item (eval @var{form})
@var{form} is a Lisp expression evaluated at the moment the field is
unpacked or packed. The result of the evaluation should be one of the
above-listed type specifications.
@end table
For a fixed-size field, the length @var{len} is given as an integer
specifying the number of bytes in the field.
When the length of a field is not fixed, it typically depends on the
value of a preceding field. In this case, the length @var{len} can be
given either as a list @code{(@var{name} ...)} identifying a
@dfn{field name} in the format specified for @code{bindat-get-field}
below, or by an expression @code{(eval @var{form})} where @var{form}
should evaluate to an integer, specifying the field length.
A field specification generally has the form @code{([@var{name}]
@var{handler})}, where @var{name} is optional. Don't use names that
are symbols meaningful as type specifications (above) or handler
specifications (below), since that would be ambiguous. @var{name} can
be a symbol or an expression @code{(eval @var{form})}, in which case
@var{form} should evaluate to a symbol.
@var{handler} describes how to unpack or pack the field and can be one
of the following:
@table @code
@item @var{type}
Unpack/pack this field according to the type specification @var{type}.
@item eval @var{form}
Evaluate @var{form}, a Lisp expression, for side-effect only. If the
field name is specified, the value is bound to that field name.
List of bits that are set to 1 in @var{len} bytes. The bytes are
taken in big-endian order, and the bits are numbered starting with
@code{8 * @var{len} @minus{} 1} and ending with zero. For example:
@code{bits 2} unpacks @code{#x28} @code{#x1c} to @w{@code{(2 3 4 11 13)}}
and @code{#x1c} @code{#x28} to @w{@code{(3 5 10 11 12)}}.
@item fill @var{len}
Skip @var{len} bytes. In packing, this leaves them unchanged,
which normally means they remain zero. In unpacking, this means
they are ignored.
@var{len} bytes used as a mere filler. In packing, these bytes are
are left unchanged, which normally means they remain zero.
When unpacking, this just returns nil.
@item align @var{len}
Skip to the next multiple of @var{len} bytes.
Same as @code{fill} except the number of bytes is that needed to skip
to the next multiple of @var{len} bytes.
@item struct @var{spec-name}
Process @var{spec-name} as a sub-specification. This describes a
structure nested within another structure.
@item type @var{exp}
This lets you refer to a type indirectly: @var{exp} is a Lisp
expression which should return a Bindat type @emph{value}.
@item union @var{form} (@var{tag} @var{spec})@dots{}
@c ??? I don't see how one would actually use this.
@c ??? what kind of expression would be useful for @var{form}?
Evaluate @var{form}, a Lisp expression, find the first @var{tag}
that matches it, and process its associated data layout specification
@var{spec}. Matching can occur in one of three ways:
@item unit @var{exp}
This is a trivial type which uses up 0 bits of space. @var{exp}
describes the value returned when we try to ``unpack'' such a field.
@itemize
@item
If a @var{tag} has the form @code{(eval @var{expr})}, evaluate
@var{expr} with the variable @code{tag} dynamically bound to the value
of @var{form}. A non-@code{nil} result indicates a match.
@item
@var{tag} matches if it is @code{equal} to the value of @var{form}.
@item
@var{tag} matches unconditionally if it is @code{t}.
@end itemize
@item repeat @var{count} @var{field-specs}@dots{}
Process the @var{field-specs} recursively, in order, then repeat
starting from the first one, processing all the specifications @var{count}
times overall. The @var{count} is given using the same formats as a
field length---if an @code{eval} form is used, it is evaluated just once.
For correct operation, each specification in @var{field-specs} must
include a name.
@item struct @var{fields}...
Composite type made of several fields. Every field is of the form
@code{(@var{name} @var{type})} where @var{type} can be any Bindat
type expression. @var{name} can be @code{_} when the field's value
does not deserve to be named, as is often the case for @code{align}
and @code{fill} fields.
When the context makes it clear that this is a Bindat type expression,
the symbol @code{struct} can be omitted.
@end table
For the @code{(eval @var{form})} forms used in a bindat specification,
the @var{form} can access and update these dynamically bound variables
during evaluation:
In the types above, @var{len} and @var{bitlen} are given as an integer
specifying the number of bytes (or bits) in the field. When the
length of a field is not fixed, it typically depends on the value of
preceding fields. For this reason, the length @var{len} does not have
to be a constant but can be any Lisp expression and it can refer to
the value of previous fields via their name.
@table @code
@item last
Value of the last field processed.
@item bindat-raw
The data as a byte array.
@item bindat-idx
Current index (within @code{bindat-raw}) for unpacking or packing.
@item struct
The alist containing the structured data that have been unpacked so
far, or the entire structure being packed. You can use
@code{bindat-get-field} to access specific fields of this structure.
@item count
@itemx index
Inside a @code{repeat} block, these contain the maximum number of
repetitions (as specified by the @var{count} parameter), and the
current repetition number (counting from 0). Setting @code{count} to
zero will terminate the inner-most repeat block after the current
repetition has completed.
@end table
For example, the specification of a data layout where a leading byte gives
the size of a subsequent vector of 16 bit integers could be:
@example
(bindat-type
(len u8)
(payload vec (1+ len) uint 16))
@end example
@node Bindat Functions
@subsection Functions to Unpack and Pack Bytes
@cindex bindat functions
In the following documentation, @var{spec} refers to a Bindat spec
object as returned from @code{bindat-spec}, @code{raw} to a byte
In the following documentation, @var{type} refers to a Bindat type
value as returned from @code{bindat-type}, @var{raw} to a byte
array, and @var{struct} to an alist representing unpacked field data.
@defun bindat-unpack spec raw &optional idx
@c FIXME? Again, no multibyte?
@defun bindat-unpack type raw &optional idx
This function unpacks data from the unibyte string or byte
array @var{raw}
according to @var{spec}. Normally, this starts unpacking at the
according to @var{type}. Normally, this starts unpacking at the
beginning of the byte array, but if @var{idx} is non-@code{nil}, it
specifies a zero-based starting position to use instead.
@ -3564,12 +3495,13 @@ This function selects a field's data from the nested alist
@var{struct}. Usually @var{struct} was returned by
@code{bindat-unpack}. If @var{name} corresponds to just one argument,
that means to extract a top-level field value. Multiple @var{name}
arguments specify repeated lookup of sub-structures. An integer name
acts as an array index.
arguments specify repeated lookup of sub-structures. An integer
@var{name} acts as an array index.
For example, if @var{name} is @code{(a b 2 c)}, that means to find
field @code{c} in the third element of subfield @code{b} of field
@code{a}. (This corresponds to @code{struct.a.b[2].c} in C.)
For example, @w{@code{(bindat-get-field @var{struct} a b 2 c)}} means
to find field @code{c} in the third element of subfield @code{b} of
field @code{a}. (This corresponds to @code{@var{struct}.a.b[2].c} in
the C programming language syntax.)
@end defun
Although packing and unpacking operations change the organization of
@ -3580,13 +3512,13 @@ both pieces of information contribute to its calculation. Likewise, the
length of a string or array being unpacked may be longer than the data's
total length as described by the specification.
@defun bindat-length spec struct
@defun bindat-length type struct
This function returns the total length of the data in @var{struct},
according to @var{spec}.
according to @var{type}.
@end defun
@defun bindat-pack spec struct &optional raw idx
This function returns a byte array packed according to @var{spec} from
@defun bindat-pack type struct &optional raw idx
This function returns a byte array packed according to @var{type} from
the data in the alist @var{struct}. It normally creates and fills a
new byte array starting at the beginning. However, if @var{raw}
is non-@code{nil}, it specifies a pre-allocated unibyte string or vector to
@ -3607,3 +3539,74 @@ dotted notation.
@result{} "127.0.0.1"
@end example
@end defun
@node Bindat Computed Types
@subsection Advanced data layout specifications
@cindex bindat computed types
Bindat type expressions are not limited to the types described
earlier. They can also be arbitrary Lisp forms returning Bindat
type expressions. For example, the type below describes data which
can either contain a 24-bit error code or a vector of bytes:
@example
(bindat-type
(len u8)
(payload . (if (zerop len) (uint 24) (vec (1- len)))))
@end example
@cindex bindat packing and unpacking into arbitrary types
Furthermore, while composite types are normally unpacked to (and
packed from) association lists, this can be changed via the use of
the following special keyword arguments:
@table @code
@item :unpack-val @var{exp}
When the list of fields ends with this keyword argument, then the value
returned when unpacking is the value of @var{exp} instead of the
standard alist. @var{exp} can refer to all the previous fields by
their name.
@item :pack-val @var{exp}
If a field's type is followed by this keyword argument, then the value
packed into this field is returned by @var{exp} instead of being
extracted from the alist.
@item :pack-var @var{name}
If the list of fields is preceded by this keyword argument, then all
the subsequent @code{:pack-val} arguments can refer to the overall
value to pack into this composite type via the variable named
@var{name}.
@end table
For example, one could describe a 16-bit signed integer as follows:
@example
(defconst sint16-bindat-spec
(let* ((max (ash 1 15))
(wrap (+ max max)))
(bindat-type :pack-var v
(n uint 16 :pack-val (if (< v 0) (+ v wrap) v))
:unpack-val (if (>= n max) (- n wrap) n))))
@end example
Which would then behave as follows:
@example
(bindat-pack sint16-bindat-spec -8)
@result{} "\377\370"
(bindat-unpack sint16-bindat-spec "\300\100")
@result{} -16320
@end example
@cindex define new bindat type forms
@cindex bindat, define new type forms
Finally, you can define new Bindat type forms to use in Bindat type
expressions with @code{bindat-defmacro}:
@defmac bindat-defmacro name args &rest body
Define a new Bindat type expression named @var{name} and taking
arguments @var{args}. Its behavior follows that of @code{defmacro},
which the important difference that the new forms can only be used
within Bindat type expressions.
@end defmac

4
doc/lispref/tips.texi
View file

@ -75,8 +75,8 @@ example, it is our convention to have commands that list objects named
as @samp{list-@var{something}}, e.g., a package called @samp{frob}
could have a command @samp{list-frobs}, when its other global symbols
begin with @samp{frob-}. Also, constructs that define functions,
variables, etc., work better if they start with @samp{defun} or
@samp{defvar}, so put the name prefix later on in the name.
variables, etc., work better if they start with @samp{define-}, so put
the name prefix later on in the name.
This recommendation applies even to names for traditional Lisp
primitives that are not primitives in Emacs Lisp---such as

47
doc/misc/Makefile.in
View file

@ -82,11 +82,27 @@ INFO_INSTALL = $(INFO_COMMON) $(DOCMISC_W32)
## because the info files are pre-built in release tarfiles.
INFO_TARGETS = $(INFO_COMMON) efaq-w32
## Some manuals have their source in .org format.
## This is discouraged because the .texi files it generates
## are not as well formatted as handwritten ones.
ORG_SETUP = $(wildcard ${srcdir}/*-setup.org)
ORG_SRC = $(filter-out ${ORG_SETUP},$(wildcard ${srcdir}/*.org))
TEXI_FROM_ORG = ${ORG_SRC:.org=.texi}
# There are some naming differences between the info targets and the other
# targets, so let's resolve them here.
TARGETS_1 = $(INFO_INSTALL:ccmode=cc-mode)
TARGETS = $(TARGETS_1:info.info=info)
texi_sources = $(addsuffix .texi,${TARGETS})
texi_notgen = $(filter-out $(notdir ${TEXI_FROM_ORG}),${texi_sources})
texi_and_org = $(notdir ${ORG_SRC}) ${texi_notgen}
SOURCES = $(sort ${texi_and_org})
.PHONY: echo-sources
## Used by the top-level Makefile.
echo-sources:
@echo ${SOURCES}
DVI_TARGETS = $(TARGETS:=.dvi)
HTML_TARGETS = $(TARGETS:=.html)
PDF_TARGETS = $(TARGETS:=.pdf)
@ -221,6 +237,30 @@ gnus.pdf: $(gnus_deps)
${buildinfodir}/tramp.info tramp.html: ${srcdir}/trampver.texi
abs_top_builddir = @abs_top_builddir@
EMACS = ${abs_top_builddir}/src/emacs
emacs = "${EMACS}" -batch --no-site-file --no-site-lisp
# Generated .texi files go in srcdir so they can be included in the
# release tarfile along with the others.
# Work in srcdir (and use abs_top_builddir) so that +setupfile and
# things like org-setup's "version" macro work. Sigh.
define org_template
$(1:.org=.texi): $(1)
$${AM_V_GEN}cd "$${srcdir}" && $${emacs} -l ox-texinfo \
-f org-texinfo-export-to-texinfo-batch $$(notdir $$<) $$(notdir $$@)
endef
$(foreach orgfile,${ORG_SRC},$(eval $(call org_template,$(orgfile))))
## foo.org depends on foo-setup.org, if the latter exists.
define org_setup_template
$(1:-setup.org=.texi): $(1)
endef
$(foreach orgfile,${ORG_SETUP},$(eval $(call org_setup_template,$(orgfile))))
.PHONY: mostlyclean clean distclean bootstrap-clean maintainer-clean
mostlyclean:
@ -245,7 +285,12 @@ infoclean:
$(buildinfodir)/$${file}-[1-9][0-9]; \
done
bootstrap-clean maintainer-clean: distclean infoclean
.PHONY: orgclean
orgclean:
rm -f ${TEXI_FROM_ORG}
bootstrap-clean maintainer-clean: distclean infoclean orgclean
.PHONY: install-dvi install-html install-pdf install-ps install-doc

111
doc/misc/calc.texi
View file

@ -6612,7 +6612,8 @@ further discussion of infinite and indeterminate values.
@subsection Modes Tutorial Exercise 1
@noindent
Calc always stores its numbers in decimal, so even though one-third has
Calc always stores its floating-point numbers in decimal,
so even though one-third has
an exact base-3 representation (@samp{3#0.1}), it is still stored as
0.3333333 (chopped off after 12 or however many decimal digits) inside
the calculator's memory. When this inexact number is converted back
@ -18888,9 +18889,7 @@ Each possible value @expr{N} appears with equal probability.
With no numeric prefix argument, the @kbd{k r} command takes its argument
from the stack instead. Once again, if this is a positive integer @expr{M}
the result is a random integer less than @expr{M}. However, note that
while numeric prefix arguments are limited to six digits or so, an @expr{M}
taken from the stack can be arbitrarily large. If @expr{M} is negative,
the result is a random integer less than @expr{M}. If @expr{M} is negative,
the result is a random integer in the range
@texline @math{M < N \le 0}.
@infoline @expr{M < N <= 0}.
@ -32240,7 +32239,7 @@ as the value of a function. You can use @code{return} anywhere
inside the body of the function.
@end itemize
Non-integer numbers (and extremely large integers) cannot be included
Non-integer numbers cannot be included
directly into a @code{defmath} definition. This is because the Lisp
reader will fail to parse them long before @code{defmath} ever gets control.
Instead, use the notation, @samp{:"3.1415"}. In fact, any algebraic
@ -32374,7 +32373,7 @@ This expands to the pair of definitions,
@noindent
where in this case the latter function would never really be used! Note
that since the Calculator stores small integers as plain Lisp integers,
that since the Calculator stores integers as plain Lisp integers,
the @code{math-add} function will work just as well as the native
@code{+} even when the intent is to operate on native Lisp integers.
@ -32643,8 +32642,8 @@ Like @samp{integer}, but the argument must be non-negative.
@item fixnum
@findex fixnum
Like @samp{integer}, but the argument must fit into a native Lisp integer,
which on most systems means less than 2^23 in absolute value. The
Like @samp{integer}, but the argument must fit into a native Lisp fixnum,
which on most systems means less than 2^61 in absolute value. The
argument is converted into Lisp-integer form if necessary.
@item float
@ -32740,50 +32739,6 @@ Emacs Lisp function:
count))
@end smallexample
If the input numbers are large, this function involves a fair amount
of arithmetic. A binary right shift is essentially a division by two;
recall that Calc stores integers in decimal form so bit shifts must
involve actual division.
To gain a bit more efficiency, we could divide the integer into
@var{n}-bit chunks, each of which can be handled quickly because
they fit into Lisp integers. It turns out that Calc's arithmetic
routines are especially fast when dividing by an integer less than
1000, so we can set @var{n = 9} bits and use repeated division by 512:
@smallexample
(defmath bcount ((natnum n))
(interactive 1 "bcnt")
(let ((count 0))
(while (not (fixnump n))
(let ((qr (idivmod n 512)))
(setq count (+ count (bcount-fixnum (cdr qr)))
n (car qr))))
(+ count (bcount-fixnum n))))
(defun bcount-fixnum (n)
(let ((count 0))
(while (> n 0)
(setq count (+ count (logand n 1))
n (ash n -1)))
count))
@end smallexample
@noindent
Note that the second function uses @code{defun}, not @code{defmath}.
Because this function deals only with native Lisp integers (``fixnums''),
it can use the actual Emacs @code{+} and related functions rather
than the slower but more general Calc equivalents which @code{defmath}
uses.
The @code{idivmod} function does an integer division, returning both
the quotient and the remainder at once. Again, note that while it
might seem that @samp{(logand n 511)} and @samp{(ash n -9)} are
more efficient ways to split off the bottom nine bits of @code{n},
actually they are less efficient because each operation is really
a division by 512 in disguise; @code{idivmod} allows us to do the
same thing with a single division by 512.
@node Sine Example, , Bit Counting Example, Example Definitions
@subsubsection The Sine Function
@ -33042,9 +32997,7 @@ in this case it would be easier to call the low-level @code{math-add}
function in Calc, if you can remember its name.
In particular, note that a plain Lisp integer is acceptable to Calc
as a raw object. (All Lisp integers are accepted on input, but
integers of more than six decimal digits are converted to ``big-integer''
form for output. @xref{Data Type Formats}.)
as a raw object.
When it comes time to display the object, just use @samp{(calc-eval a)}
to format it as a string.
@ -33308,31 +33261,11 @@ you can't prove this file will already be loaded.
@subsubsection Data Type Formats
@noindent
Integers are stored in either of two ways, depending on their magnitude.
Integers less than one million in absolute value are stored as standard
Lisp integers. This is the only storage format for Calc data objects
which is not a Lisp list.
Large integers are stored as lists of the form @samp{(bigpos @var{d0}
@var{d1} @var{d2} @dots{})} for sufficiently large positive integers
(where ``sufficiently large'' depends on the machine), or
@samp{(bigneg @var{d0} @var{d1} @var{d2} @dots{})} for negative
integers. Each @var{d} is a base-@expr{10^n} ``digit'' (where again,
@expr{n} depends on the machine), a Lisp integer from 0 to
99@dots{}9. The least significant digit is @var{d0}; the last digit,
@var{dn}, which is always nonzero, is the most significant digit. For
example, the integer @mathit{-12345678} might be stored as
@samp{(bigneg 678 345 12)}.
The distinction between small and large integers is entirely hidden from
the user. In @code{defmath} definitions, the Lisp predicate @code{integerp}
returns true for either kind of integer, and in general both big and small
integers are accepted anywhere the word ``integer'' is used in this manual.
If the distinction must be made, native Lisp integers are called @dfn{fixnums}
and large integers are called @dfn{bignums}.
Integers are stored as standard Lisp integers. This is the only
storage format for Calc data objects which is not a Lisp list.
Fractions are stored as a list of the form, @samp{(frac @var{n} @var{d})}
where @var{n} is an integer (big or small) numerator, @var{d} is an
where @var{n} is an integer numerator, @var{d} is an
integer denominator greater than one, and @var{n} and @var{d} are relatively
prime. Note that fractions where @var{d} is one are automatically converted
to plain integers by all math routines; fractions where @var{d} is negative
@ -33341,7 +33274,7 @@ are normalized by negating the numerator and denominator.
Floating-point numbers are stored in the form, @samp{(float @var{mant}
@var{exp})}, where @var{mant} (the ``mantissa'') is an integer less than
@samp{10^@var{p}} in absolute value (@var{p} represents the current
precision), and @var{exp} (the ``exponent'') is a fixnum. The value of
precision), and @var{exp} (the ``exponent'') is an integer. The value of
the float is @samp{@var{mant} * 10^@var{exp}}. For example, the number
@mathit{-3.14} is stored as @samp{(float -314 -2) = -314*10^-2}. Other constraints
are that the number 0.0 is always stored as @samp{(float 0 0)}, and,
@ -33736,7 +33669,7 @@ Returns true if @var{x} is an integer of any size.
@end defun
@defun fixnump x
Returns true if @var{x} is a native Lisp integer.
Returns true if @var{x} is a native Lisp fixnum.
@end defun
@defun natnump x
@ -33744,7 +33677,7 @@ Returns true if @var{x} is a nonnegative integer of any size.
@end defun
@defun fixnatnump x
Returns true if @var{x} is a nonnegative Lisp integer.
Returns true if @var{x} is a nonnegative Lisp fixnum.
@end defun
@defun num-integerp x
@ -33899,7 +33832,7 @@ converted to @samp{(math-equal x y)}.
@defun equal-int x n
Returns true if @var{x} and @var{n} are numerically equal, where @var{n}
is a fixnum which is not a multiple of 10. This will automatically be
is an integer which is not a multiple of 10. This will automatically be
used by @code{defmath} in place of the more general @code{math-equal}
whenever possible.
@end defun
@ -33980,12 +33913,8 @@ respectively, instead.
@defun normalize val
(Full form: @code{math-normalize}.)
Reduce the value @var{val} to standard form. For example, if @var{val}
is a fixnum, it will be converted to a bignum if it is too large, and
if @var{val} is a bignum it will be normalized by clipping off trailing
(i.e., most-significant) zero digits and converting to a fixnum if it is
small. All the various data types are similarly converted to their standard
forms. Variables are left alone, but function calls are actually evaluated
Reduce the value @var{val} to standard form.
Variables are left alone, but function calls are actually evaluated
in formulas. For example, normalizing @samp{(+ 2 (calcFunc-abs -4))} will
return 6.
@ -34098,9 +34027,9 @@ integer rather than truncating.
@end defun
@defun fixnum n
Return the integer @var{n} as a fixnum, i.e., a native Lisp integer.
If @var{n} is outside the permissible range for Lisp integers (usually
24 binary bits) the result is undefined.
Return the integer @var{n} as a fixnum, i.e., a small Lisp integer.
If @var{n} is outside the permissible range for Lisp fixnums (usually
62 binary bits) the result is undefined.
@end defun
@defun sqr x

3303
doc/misc/modus-themes.org Normal file
View file

File diff suppressed because it is too large Load diff

2834
doc/misc/modus-themes.texi
View file

File diff suppressed because it is too large Load diff

53
doc/misc/org-setup.org Normal file
View file

@ -0,0 +1,53 @@
# SETUPFILE for Org manual
# Copyright (C) 2021 Free Software Foundation, Inc.
#
# This file is 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
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# GNU Emacs is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
# XXX: We cannot use TODO keyword as a node starts with "TODO".
#+todo: REVIEW FIXME | DONE
#+property: header-args :eval no
#+startup: overview nologdone
# Use proper quote and backtick for code sections in PDF output
# Cf. Texinfo manual 14.2
#+texinfo_header: @set txicodequoteundirected
#+texinfo_header: @set txicodequotebacktick
# Contact Info
#+texinfo_header: @set MAINTAINERSITE @uref{https://orgmode.org,maintainers webpage}
#+texinfo_header: @set MAINTAINER Bastien Guerry
#+texinfo_header: @set MAINTAINEREMAIL @email{bzg@gnu.org}
#+texinfo_header: @set MAINTAINERCONTACT @uref{mailto:bzg@gnu.org,contact the maintainer}
#+options: H:4 num:t toc:t author:t \n:nil ::t |:t ^:nil -:t f:t *:t <:t e:t ':t
#+options: d:nil todo:nil pri:nil tags:not-in-toc stat:nil broken-links:mark
#+select_tags: export
#+exclude_tags: noexport
#+macro: cite @@texinfo:@cite{@@$1@@texinfo:}@@
#+macro: var @@texinfo:@var{@@$1@@texinfo:}@@
# The "version" macro extracts "Version" keyword from "org.el". It
# returns major.minor version number. This is sufficient since bugfix
# releases are not expected to add features and therefore imply manual
# modifications.
#+macro: version (eval (with-current-buffer (find-file-noselect "../../lisp/org/org.el") (org-with-point-at 1 (if (re-search-forward "Version: +\\([0-9.]+\\)" nil t) (mapconcat #'identity (cl-subseq (split-string (match-string-no-properties 1) "\\.") 0 2) ".") (error "Missing \"Version\" keyword in \"org.el\"")))))
# The "kbd" macro turns KBD into @kbd{KBD}. Additionally, it
# encloses case-sensitive special keys (SPC, RET...) within @key{...}.
#+macro: kbd (eval (let ((case-fold-search nil) (regexp (regexp-opt '("SPC" "RET" "LFD" "TAB" "BS" "ESC" "DELETE" "SHIFT" "Ctrl" "Meta" "Alt" "Cmd" "Super" "UP" "LEFT" "RIGHT" "DOWN") 'words))) (format "@@texinfo:@kbd{@@%s@@texinfo:}@@" (replace-regexp-in-string regexp "@@texinfo:@key{@@\\&@@texinfo:}@@" $1 t))))

21904
doc/misc/org.org Normal file
View file

File diff suppressed because it is too large Load diff

23148
doc/misc/org.texi
View file

File diff suppressed because it is too large Load diff

2
doc/misc/tramp.texi
View file

@ -2211,7 +2211,7 @@ be recomputed. To force @value{tramp} to recompute afresh, call
By default, @value{tramp} uses the command @command{/bin/sh} for
starting a shell on the remote host. This can be changed by setting
the connection property @t{"remote-shell"}; see @pxref{Predefined
the connection property @t{"remote-shell"}; see @ref{Predefined
connection information}. If you want, for example, use
@command{/usr/bin/zsh} on a remote host, you might apply

102
etc/NEWS
View file

@ -71,6 +71,12 @@ shaping, so 'configure' now recommends that combination.
** The ftx font backend driver has been removed.
It was declared obsolete in Emacs 27.1.
---
** The configure option '--without-makeinfo' has been removed.
This was only ever relevant when building from a repository checkout.
Please install makeinfo, or if all else fails run 'make lisp' instead
of 'make [all]'.
---
** Support for building with '-fcheck-pointer-bounds' has been removed.
GCC has withdrawn the '-fcheck-pointer-bounds' option and support for
@ -310,10 +316,12 @@ Additionally, the function now accepts a HIST argument which can be
used to specify a custom history variable.
+++
** Input history for 'goto-line' is now local to every buffer.
Each buffer will keep a separate history of line numbers used with
'goto-line'. This should help making faster the process of finding
line numbers that were previously jumped to.
** Input history for 'goto-line' can now be made local to every buffer.
In any event, line numbers used with 'goto-line' are kept in their own
history list. This should help make faster the process of finding
line numbers that were previously jumped to. By default, all buffers
share a single history list. To make every buffer have its own
history list, customize the user option 'goto-line-history-local'.
+++
** New command 'goto-line-relative' to use in a narrowed buffer.
@ -357,19 +365,28 @@ trying to be non-destructive.
This command opens a new buffer called "*Memory Report*" and gives a
summary of where Emacs is using memory currently.
+++
** The history list for the 'goto-line' command is now a single list
for all buffers by default. You can configure a separate list for
each buffer by customizing the user option 'goto-line-history-local'.
** Outline
+++
*** New commands to cycle heading visibility.
Typing 'TAB' on a heading cycles the current section between "hide
all", "subheadings", and "show all" state. Typing 'S-TAB' anywhere in
the buffer cycles the whole buffer between "only top-level headings",
"all headings and subheadings", and "show all" states.
Typing 'TAB' on a heading line cycles the current section between
"hide all", "subheadings", and "show all" states. Typing 'S-TAB'
anywhere in the buffer cycles the whole buffer between "only top-level
headings", "all headings and subheadings", and "show all" states.
*** New minor mode 'outline-cycle-minor-mode'.
This mode is a variant of 'outline-minor-mode', with the difference
that 'TAB' and 'S-TAB' on heading lines cycle heading visibility.
Typing 'TAB' on a heading line cycles the current section between
"hide all", "subheadings", and "show all" states. Typing 'S-TAB' on a
heading line cycles the whole buffer between "only top-level
headings", "all headings and subheadings", and "show all" states.
*** New minor mode 'outline-cycle-highlight-minor-mode'.
This mode is a variant of 'outline-cycle-minor-mode'. It puts
highlighting on heading lines using standard outline faces. This
works well only when there are no conflicts with faces used by the
major mode.
* Changes in Specialized Modes and Packages in Emacs 28.1
@ -379,6 +396,10 @@ the buffer cycles the whole buffer between "only top-level headings",
*** New function 'macroexp-file-name' to know the name of the current file
---
*** New function 'macroexp-compiling-p' to know if we're compiling.
---
*** New function 'macroexp-warn-and-return' to help emit warnings.
This used to be named 'macroexp--warn-and-return' and has proved useful
and well-behaved enough to lose the "internal" marker.
** 'blink-cursor-mode' is now enabled by default regardless of the UI.
It used to be enabled when Emacs is started in GUI mode but not when started
@ -386,11 +407,19 @@ in text mode. The cursor still only actually blinks in GUI frames.
** Bindat
+++
*** New types 'u64' and 'u64r'
+++
*** New macro 'bindat-spec' to define specs, with Edebug support
*** New 'Bindat type expression' description language.
This new system is provided by the new macro 'bindat-type' and
obsoletes the old data layout specifications. It supports
arbitrary-size integers, recursive types, and more. See the Info node
'Byte Packing' in the ELisp manual for more details.
** pcase
+++
*** The 'or' pattern now binds the union of the vars of its sub-patterns
If a variable is not bound by the subpattern that matched, it gets bound
to nil. This was already sometimes the case, but it is now guaranteed.
+++
*** The 'pred' pattern can now take the form '(pred (not FUN))'.
This is like '(pred (lambda (x) (not (FUN x))))' but results
@ -494,6 +523,13 @@ value of 'tab-bar-show'.
It can be used to enable/disable the tab bar individually on each frame
independently from the value of 'tab-bar-mode' and 'tab-bar-show'.
---
*** New variable 'tab-bar-format' defines a list of tab bar items.
When it contains 'tab-bar-format-global' (possibly appended after
'tab-bar-format-align-right'), then after enabling 'display-time-mode'
(or any other mode that uses 'global-mode-string') it displays time
aligned to the right on the tab bar instead of the mode line.
---
*** 'Mod-9' bound to 'tab-last' now switches to the last tab.
It also supports a negative argument.
@ -1135,8 +1171,18 @@ effect.
A pattern like '(map :sym)' binds the map's value for ':sym' to 'sym',
equivalent to '(map (:sym sym))'.
---
*** The function 'map-copy' now uses 'copy-alist' on alists.
This is a slightly deeper copy than the previous 'copy-sequence'.
---
*** The function 'map-contains-key' now supports plists.
** Package
+++
*** New command 'package-browse-url' and keystroke 'w'.
+++
*** New commands to filter the package list.
The filter commands are bound to the following keys:
@ -1532,6 +1578,16 @@ component are now rejected by 'json-read' and friends. This makes
them more compliant with the JSON specification and consistent with
the native JSON parsing functions.
---
*** Some JSON encoding functions are now obsolete.
The functions 'json-encode-number', 'json-encode-hash-table',
'json-encode-key', and 'json-encode-list' are now obsolete.
The first two are kept as aliases of 'json-encode', which should be
used instead. Uses of 'json-encode-list' should be changed to call
one of 'json-encode', 'json-encode-alist', 'json-encode-plist', or
'json-encode-array' instead.
** xml.el
*** XML serialization functions now reject invalid characters.
@ -2259,7 +2315,10 @@ This is no longer supported, and setting this variable has no effect.
Use macro 'with-current-buffer-window' with action alist entry 'body-function'.
---
** The metamail.el library is now marked obsolete.
** The inversion.el library is now obsolete.
---
** The metamail.el library is now obsolete.
---
** Some obsolete variable and function aliases in dbus.el have been removed.
@ -2396,6 +2455,9 @@ This can be used to control whether the defined mode is a command
or not, and is useful when defining commands that aren't meant to be
used by users directly.
---
** The 'easymenu' library is now preloaded.
** The 'values' variable is now obsolete.
---
@ -2508,6 +2570,12 @@ region's (or buffer's) end.
This function can be used by modes to add elements to the
'choice' customization type of a variable.
+++
** New function 'require-theme'.
This function is like 'require', but searches 'custom-theme-load-path'
instead of 'load-path'. It can be used by Custom themes to load
supporting Lisp files when 'require' is unsuitable.
+++
** New function 'file-modes-number-to-symbolic' to convert a numeric
file mode specification into symbolic form.

6
etc/compilation.txt
View file

@ -692,3 +692,9 @@ COPYING PERMISSIONS:
You should have received a copy of the GNU General Public License
along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Local Variables:
;;; outline-regexp: "\\*\\_>"
;;; eval: (outline-cycle-highlight-minor-mode)
;;; End:

2
etc/grep.txt
View file

@ -102,6 +102,7 @@ grep -nH -e "xyzxyz" ../info/*
../info/emacs-2 1205 inserts `xyzxyzxyzxyz' in the current buffer.
* Miscellaneous
Copyright (C) 2005-2021 Free Software Foundation, Inc.
@ -124,4 +125,5 @@ COPYING PERMISSIONS:
;;; Local Variables:
;;; eval: (let ((inhibit-read-only t) (compilation-filter-start (point-min))) (save-excursion (goto-char (point-max)) (grep-filter) (set-buffer-modified-p nil)))
;;; buffer-read-only: t
;;; eval: (outline-cycle-highlight-minor-mode)
;;; End:

4673
etc/themes/modus-operandi-theme.el
View file

File diff suppressed because it is too large Load diff

6442
etc/themes/modus-themes.el Normal file
View file

File diff suppressed because it is too large Load diff

4673
etc/themes/modus-vivendi-theme.el
View file

File diff suppressed because it is too large Load diff

3
lisp/allout.el
View file

@ -75,9 +75,6 @@
(declare-function epa-passphrase-callback-function
"epa" (context key-id handback))
;;;_* Dependency loads
(require 'overlay)
;;;_* USER CUSTOMIZATION VARIABLES:
;;;_ > defgroup allout, allout-keybindings

130
lisp/buff-menu.el
View file

@ -117,8 +117,7 @@ This is set by the prefix argument to `buffer-menu' and related
commands.")
(defvar Buffer-menu-mode-map
(let ((map (make-sparse-keymap))
(menu-map (make-sparse-keymap)))
(let ((map (make-sparse-keymap)))
(set-keymap-parent map tabulated-list-mode-map)
(define-key map "v" 'Buffer-menu-select)
(define-key map "2" 'Buffer-menu-2-window)
@ -152,82 +151,63 @@ commands.")
(define-key map [mouse-2] 'Buffer-menu-mouse-select)
(define-key map [follow-link] 'mouse-face)
(define-key map [menu-bar Buffer-menu-mode] (cons (purecopy "Buffer-Menu") menu-map))
(bindings--define-key menu-map [quit]
'(menu-item "Quit" quit-window
:help "Remove the buffer menu from the display"))
(bindings--define-key menu-map [rev]
'(menu-item "Refresh" revert-buffer
:help "Refresh the *Buffer List* buffer contents"))
(bindings--define-key menu-map [s0] menu-bar-separator)
(bindings--define-key menu-map [tf]
'(menu-item "Show Only File Buffers" Buffer-menu-toggle-files-only
:button (:toggle . Buffer-menu-files-only)
:help "Toggle whether the current buffer-menu displays only file buffers"))
(bindings--define-key menu-map [s1] menu-bar-separator)
;; FIXME: The "Select" entries could use better names...
(bindings--define-key menu-map [sel]
'(menu-item "Select Marked" Buffer-menu-select
:help "Select this line's buffer; also display buffers marked with `>'"))
(bindings--define-key menu-map [bm2]
'(menu-item "Select Two" Buffer-menu-2-window
:help "Select this line's buffer, with previous buffer in second window"))
(bindings--define-key menu-map [bm1]
'(menu-item "Select Current" Buffer-menu-1-window
:help "Select this line's buffer, alone, in full frame"))
(bindings--define-key menu-map [ow]
'(menu-item "Select in Other Window" Buffer-menu-other-window
:help "Select this line's buffer in other window, leaving buffer menu visible"))
(bindings--define-key menu-map [tw]
'(menu-item "Select in Current Window" Buffer-menu-this-window
:help "Select this line's buffer in this window"))
(bindings--define-key menu-map [s2] menu-bar-separator)
(bindings--define-key menu-map [is]
'(menu-item "Regexp Isearch Marked Buffers..." Buffer-menu-isearch-buffers-regexp
:help "Search for a regexp through all marked buffers using Isearch"))
(bindings--define-key menu-map [ir]
'(menu-item "Isearch Marked Buffers..." Buffer-menu-isearch-buffers
:help "Search for a string through all marked buffers using Isearch"))
(bindings--define-key menu-map [mo]
'(menu-item "Multi Occur Marked Buffers..." Buffer-menu-multi-occur
:help "Show lines matching a regexp in marked buffers using Occur"))
(bindings--define-key menu-map [s3] menu-bar-separator)
(bindings--define-key menu-map [by]
'(menu-item "Bury" Buffer-menu-bury
:help "Bury the buffer listed on this line"))
(bindings--define-key menu-map [vt]
'(menu-item "Set Unmodified" Buffer-menu-not-modified
:help "Mark buffer on this line as unmodified (no changes to save)"))
(bindings--define-key menu-map [ex]
'(menu-item "Execute" Buffer-menu-execute
:help "Save and/or delete buffers marked with s or k commands"))
(bindings--define-key menu-map [s4] menu-bar-separator)
(bindings--define-key menu-map [delb]
'(menu-item "Mark for Delete and Move Backwards" Buffer-menu-delete-backwards
:help "Mark buffer on this line to be deleted by x command and move up one line"))
(bindings--define-key menu-map [del]
'(menu-item "Mark for Delete" Buffer-menu-delete
:help "Mark buffer on this line to be deleted by x command"))
(bindings--define-key menu-map [sv]
'(menu-item "Mark for Save" Buffer-menu-save
:help "Mark buffer on this line to be saved by x command"))
(bindings--define-key menu-map [umk]
'(menu-item "Unmark" Buffer-menu-unmark
:help "Cancel all requested operations on buffer on this line and move down"))
(bindings--define-key menu-map [umkab]
'(menu-item "Remove marks..." Buffer-menu-unmark-all-buffers
:help "Cancel a requested operation on all buffers"))
(bindings--define-key menu-map [umka]
'(menu-item "Unmark all" Buffer-menu-unmark-all
:help "Cancel all requested operations on buffers"))
(bindings--define-key menu-map [mk]
'(menu-item "Mark" Buffer-menu-mark
:help "Mark buffer on this line for being displayed by v command"))
map)
"Local keymap for `Buffer-menu-mode' buffers.")
(easy-menu-define Buffer-menu-mode-menu Buffer-menu-mode-map
"Menu for `Buffer-menu-mode' buffers."
'("Buffer-Menu"
["Mark" Buffer-menu-mark
:help "Mark buffer on this line for being displayed by v command"]
["Unmark all" Buffer-menu-unmark-all
:help "Cancel all requested operations on buffers"]
["Remove marks..." Buffer-menu-unmark-all-buffers
:help "Cancel a requested operation on all buffers"]
["Unmark" Buffer-menu-unmark
:help "Cancel all requested operations on buffer on this line and move down"]
["Mark for Save" Buffer-menu-save
:help "Mark buffer on this line to be saved by x command"]
["Mark for Delete" Buffer-menu-delete
:help "Mark buffer on this line to be deleted by x command"]
["Mark for Delete and Move Backwards" Buffer-menu-delete-backwards
:help "Mark buffer on this line to be deleted by x command and move up one line"]
"---"
["Execute" Buffer-menu-execute
:help "Save and/or delete buffers marked with s or k commands"]
["Set Unmodified" Buffer-menu-not-modified
:help "Mark buffer on this line as unmodified (no changes to save)"]
["Bury" Buffer-menu-bury
:help "Bury the buffer listed on this line"]
"---"
["Multi Occur Marked Buffers..." Buffer-menu-multi-occur
:help "Show lines matching a regexp in marked buffers using Occur"]
["Isearch Marked Buffers..." Buffer-menu-isearch-buffers
:help "Search for a string through all marked buffers using Isearch"]
["Regexp Isearch Marked Buffers..." Buffer-menu-isearch-buffers-regexp
:help "Search for a regexp through all marked buffers using Isearch"]
"---"
;; FIXME: The "Select" entries could use better names...
["Select in Current Window" Buffer-menu-this-window
:help "Select this line's buffer in this window"]
["Select in Other Window" Buffer-menu-other-window
:help "Select this line's buffer in other window, leaving buffer menu visible"]
["Select Current" Buffer-menu-1-window
:help "Select this line's buffer, alone, in full frame"]
["Select Two" Buffer-menu-2-window
:help "Select this line's buffer, with previous buffer in second window"]
["Select Marked" Buffer-menu-select
:help "Select this line's buffer; also display buffers marked with `>'"]
"---"
["Show Only File Buffers" Buffer-menu-toggle-files-only
:help "Toggle whether the current buffer-menu displays only file buffers"
:style toggle
:selected Buffer-menu-files-only]
"---"
["Refresh" revert-buffer
:help "Refresh the *Buffer List* buffer contents"]
["Quit" quit-window
:help "Remove the buffer menu from the display"]))
(define-derived-mode Buffer-menu-mode tabulated-list-mode "Buffer Menu"
"Major mode for Buffer Menu buffers.
The Buffer Menu is invoked by the commands \\[list-buffers],

4
lisp/calc/calc-ext.el
View file

@ -2565,9 +2565,9 @@ If X is not an error form, return 1."
;;; True if A is numerically equal to the integer B. [P N S] [Public]
;;; B must not be a multiple of 10.
(defun math-equal-int (a b)
(or (eq a b)
(or (eql a b)
(and (eq (car-safe a) 'float)
(eq (nth 1 a) b)
(eql (nth 1 a) b)
(= (nth 2 a) 0))))

65
lisp/calc/calc-prog.el
View file

@ -1985,22 +1985,37 @@ Redefine the corresponding command."
(cons 'quote
(math-define-lambda (nth 1 exp) math-exp-env))
exp))
((memq func '(let let* for foreach))
(let ((head (nth 1 exp))
(body (cdr (cdr exp))))
(if (memq func '(let let*))
()
(setq func (cdr (assq func '((for . math-for)
(foreach . math-foreach)))))
(if (not (listp (car head)))
(setq head (list head))))
(macroexpand
(cons func
(cons (math-define-let head)
(math-define-body body
(nconc
(math-define-let-env head)
math-exp-env)))))))
((eq func 'let)
(let ((bindings (nth 1 exp))
(body (cddr exp)))
`(let ,(math-define-let bindings)
,@(math-define-body
body (append (math-define-let-env bindings)
math-exp-env)))))
((eq func 'let*)
;; Rewrite in terms of `let'.
(let ((bindings (nth 1 exp))
(body (cddr exp)))
(math-define-exp
(if (> (length bindings) 1)
`(let ,(list (car bindings))
(let* ,(cdr bindings) ,@body))
`(let ,bindings ,@body)))))
((memq func '(for foreach))
(let ((bindings (nth 1 exp))
(body (cddr exp)))
(if (> (length bindings) 1)
;; Rewrite as nested loops.
(math-define-exp
`(,func ,(list (car bindings))
(,func ,(cdr bindings) ,@body)))
(let ((mac (cdr (assq func '((for . math-for)
(foreach . math-foreach))))))
(macroexpand
`(,mac ,(math-define-let bindings)
,@(math-define-body
body (append (math-define-let-env bindings)
math-exp-env))))))))
((and (memq func '(setq setf))
(math-complicated-lhs (cdr exp)))
(if (> (length exp) 3)
@ -2017,7 +2032,7 @@ Redefine the corresponding command."
(math-define-cond (cdr exp))))
((and (consp func) ; ('spam a b) == force use of plain spam
(eq (car func) 'quote))
(cons func (math-define-list (cdr exp))))
(cons (cadr func) (math-define-list (cdr exp))))
((symbolp func)
(let ((args (math-define-list (cdr exp)))
(prim (assq func math-prim-funcs)))
@ -2276,20 +2291,16 @@ Redefine the corresponding command."
(defun math-handle-foreach (head body)
(let ((var (nth 0 (car head)))
(loop-var (gensym "foreach"))
(data (nth 1 (car head)))
(body (if (cdr head)
(list (math-handle-foreach (cdr head) body))
body)))
(cons 'let
(cons (list (list var data))
(list
(cons 'while
(cons var
(append body
(list (list 'setq
var
(list 'cdr var)))))))))))
`(let ((,loop-var ,data))
(while ,loop-var
(let ((,var (car ,loop-var)))
,@(append body
`((setq ,loop-var (cdr ,loop-var)))))))))
(defun math-body-refers-to (body thing)
(or (equal body thing)

5
lisp/cedet/cedet-cscope.el
View file

@ -26,8 +26,6 @@
;;; Code:
(declare-function inversion-check-version "inversion")
(defvar cedet-cscope-min-version "15.7"
"Minimum version of CScope required.")
@ -139,7 +137,6 @@ If optional programmatic argument NOERROR is non-nil,
then instead of throwing an error if CScope isn't available,
return nil."
(interactive)
(require 'inversion)
(let ((b (condition-case nil
(cedet-cscope-call (list "-V"))
(error nil)))
@ -153,7 +150,7 @@ return nil."
(goto-char (point-min))
(re-search-forward "cscope: version \\([0-9.]+\\)" nil t)
(setq rev (match-string 1))
(if (inversion-check-version rev nil cedet-cscope-min-version)
(if (version< rev cedet-cscope-min-version)
(if noerror
nil
(error "Version of CScope is %s. Need at least %s"

5
lisp/cedet/cedet-global.el
View file

@ -24,8 +24,6 @@
;;
;; Basic support for calling GNU Global, and testing version numbers.
(declare-function inversion-check-version "inversion")
(defvar cedet-global-min-version "5.0"
"Minimum version of GNU Global required.")
@ -143,7 +141,6 @@ If optional programmatic argument NOERROR is non-nil,
then instead of throwing an error if Global isn't available,
return nil."
(interactive)
(require 'inversion)
(let ((b (condition-case nil
(cedet-gnu-global-call (list "--version"))
(error nil)))
@ -157,7 +154,7 @@ return nil."
(goto-char (point-min))
(re-search-forward "(?GNU GLOBAL)? \\([0-9.]+\\)" nil t)
(setq rev (match-string 1))
(if (inversion-check-version rev nil cedet-global-min-version)
(if (version< rev cedet-global-min-version)
(if noerror
nil
(error "Version of GNU Global is %s. Need at least %s"

5
lisp/cedet/cedet-idutils.el
View file

@ -29,8 +29,6 @@
;;; Code:
(declare-function inversion-check-version "inversion")
(defvar cedet-idutils-min-version "4.0"
"Minimum version of ID Utils required.")
@ -167,7 +165,6 @@ If optional programmatic argument NOERROR is non-nil,
then instead of throwing an error if Global isn't available,
return nil."
(interactive)
(require 'inversion)
(let ((b (condition-case nil
(cedet-idutils-fnid-call (list "--version"))
(error nil)))
@ -182,7 +179,7 @@ return nil."
(if (re-search-forward "fnid - \\([0-9.]+\\)" nil t)
(setq rev (match-string 1))
(setq rev "0"))
(if (inversion-check-version rev nil cedet-idutils-min-version)
(if (version< rev cedet-idutils-min-version)
(if noerror
nil
(error "Version of ID Utils is %s. Need at least %s"

1
lisp/cedet/cedet.el
View file

@ -85,6 +85,7 @@ for the specified PACKAGE.
LOADED VERSION is the version of PACKAGE currently loaded in Emacs
memory and (presumably) running in this Emacs instance. Value is X
if the package has not been loaded."
(declare (obsolete emacs-version "28.1"))
(interactive)
(require 'inversion)
(with-output-to-temp-buffer "*CEDET*"

4
lisp/cedet/ede/custom.el
View file

@ -53,7 +53,7 @@
(setq-local eieio-ede-old-variables ov)))
;;;###autoload
(defalias 'customize-project 'ede-customize-project)
(defalias 'customize-project #'ede-customize-project)
;;;###autoload
(defun ede-customize-current-target()
@ -65,7 +65,7 @@
(ede-customize-target ede-object))
;;;###autoload
(defalias 'customize-target 'ede-customize-current-target)
(defalias 'customize-target #'ede-customize-current-target)
(defun ede-customize-target (obj)
"Edit fields of the current target through EIEIO & Custom.

1
lisp/cedet/ede/dired.el
View file

@ -30,7 +30,6 @@
;;; Code:
(require 'easymenu)
(require 'dired)
(require 'ede)

15
lisp/cedet/ede/make.el
View file

@ -30,8 +30,6 @@
;;; Code:
(declare-function inversion-check-version "inversion")
(defsubst ede--find-executable (exec)
"Return an expanded file name for a program EXEC on the exec path."
(declare (obsolete locate-file "28.1"))
@ -60,8 +58,7 @@ If NOERROR is nil, then throw an error on failure. Return t otherwise."
(let ((b (get-buffer-create "*EDE Make Version*"))
(cd default-directory)
(rev nil)
(ans nil)
)
(ans nil))
(with-current-buffer b
;; Setup, and execute make.
(setq default-directory cd)
@ -70,18 +67,18 @@ If NOERROR is nil, then throw an error on failure. Return t otherwise."
"--version")
;; Check the buffer for the string
(goto-char (point-min))
(when (looking-at "GNU Make\\(?: version\\)? \\([0-9][^,]+\\),")
(when (looking-at "GNU Make\\(?: version\\)? \\([0-9][^,[:space:]]+\\),?")
(setq rev (match-string 1))
(require 'inversion)
(setq ans (not (inversion-check-version rev nil ede-make-min-version))))
(setq ans (not (version< rev ede-make-min-version))))
;; Answer reporting.
(when (and (called-interactively-p 'interactive) ans)
(message "GNU Make version %s. Good enough for CEDET." rev))
(when (and (not noerror) (not ans))
(error "EDE requires GNU Make version %s or later. Configure `ede-make-command' to fix"
ede-make-min-version))
(error "EDE requires GNU Make version %s or later (found %s). Configure `ede-make-command' to fix"
ede-make-min-version
rev))
ans)))
(provide 'ede/make)

1
lisp/cedet/semantic.el
View file

@ -57,6 +57,7 @@ excluded if a released version is required.
It is assumed that if the current version is newer than that specified,
everything passes. Exceptions occur when known incompatibilities are
introduced."
(declare (obsolete emacs-version "28.1"))
(require 'inversion)
(inversion-test 'semantic
(concat major "." minor

32
lisp/cedet/semantic/analyze.el
View file

@ -1,4 +1,4 @@
;;; semantic/analyze.el --- Analyze semantic tags against local context
;;; semantic/analyze.el --- Analyze semantic tags against local context -*- lexical-binding: t; -*-
;; Copyright (C) 2000-2005, 2007-2021 Free Software Foundation, Inc.
@ -167,7 +167,7 @@ of the parent function.")
;; Simple methods against the context classes.
;;
(cl-defmethod semantic-analyze-type-constraint
((context semantic-analyze-context) &optional desired-type)
((_context semantic-analyze-context) &optional desired-type)
"Return a type constraint for completing :prefix in CONTEXT.
Optional argument DESIRED-TYPE may be a non-type tag to analyze."
(when (semantic-tag-p desired-type)
@ -344,8 +344,8 @@ This function knows of flags:
(setq tagtype (cons tmptype tagtype))
(when miniscope
(let ((rawscope
(apply 'append
(mapcar 'semantic-tag-type-members tagtype))))
(apply #'append
(mapcar #'semantic-tag-type-members tagtype))))
(oset miniscope fullscope rawscope)))
)
(setq s (cdr s)))
@ -437,6 +437,8 @@ to provide a large number of non-cached analysis for filtering symbols."
(:override)))
)
(defvar semantic--prefixtypes)
(defun semantic-analyze-current-symbol-default (analyzehookfcn position)
"Call ANALYZEHOOKFCN on the analyzed symbol at POSITION."
(let* ((semantic-analyze-error-stack nil)
@ -453,14 +455,14 @@ to provide a large number of non-cached analysis for filtering symbols."
(catch 'unfindable
;; If debug on error is on, allow debugging in this fcn.
(setq prefix (semantic-analyze-find-tag-sequence
prefix scope 'prefixtypes 'unfindable)))
prefix scope 'semantic--prefixtypes 'unfindable)))
;; Debug on error is off. Capture errors and move on
(condition-case err
;; NOTE: This line is duplicated in
;; semantic-analyzer-debug-global-symbol
;; You will need to update both places.
(setq prefix (semantic-analyze-find-tag-sequence
prefix scope 'prefixtypes))
prefix scope 'semantic--prefixtypes))
(error (semantic-analyze-push-error err))))
;;(message "Analysis took %.2f sec" (semantic-elapsed-time LLstart nil))
@ -531,7 +533,7 @@ Returns an object based on symbol `semantic-analyze-context'."
(bounds (nth 2 prefixandbounds))
;; @todo - vv too early to really know this answer! vv
(prefixclass (semantic-ctxt-current-class-list))
(prefixtypes nil)
(semantic--prefixtypes nil)
(scope (semantic-calculate-scope position))
(function nil)
(fntag nil)
@ -611,13 +613,13 @@ Returns an object based on symbol `semantic-analyze-context'."
(if debug-on-error
(catch 'unfindable
(setq prefix (semantic-analyze-find-tag-sequence
prefix scope 'prefixtypes 'unfindable))
prefix scope 'semantic--prefixtypes 'unfindable))
;; If there's an alias, dereference it and analyze
;; sequence again.
(when (setq newseq
(semantic-analyze-dereference-alias prefix))
(setq prefix (semantic-analyze-find-tag-sequence
newseq scope 'prefixtypes 'unfindable))))
newseq scope 'semantic--prefixtypes 'unfindable))))
;; Debug on error is off. Capture errors and move on
(condition-case err
;; NOTE: This line is duplicated in
@ -625,11 +627,11 @@ Returns an object based on symbol `semantic-analyze-context'."
;; You will need to update both places.
(progn
(setq prefix (semantic-analyze-find-tag-sequence
prefix scope 'prefixtypes))
prefix scope 'semantic--prefixtypes))
(when (setq newseq
(semantic-analyze-dereference-alias prefix))
(setq prefix (semantic-analyze-find-tag-sequence
newseq scope 'prefixtypes))))
newseq scope 'semantic--prefixtypes))))
(error (semantic-analyze-push-error err))))
)
@ -650,7 +652,7 @@ Returns an object based on symbol `semantic-analyze-context'."
:prefix prefix
:prefixclass prefixclass
:bounds bounds
:prefixtypes prefixtypes
:prefixtypes semantic--prefixtypes
:errors semantic-analyze-error-stack)))
;; No function, try assignment
@ -670,7 +672,7 @@ Returns an object based on symbol `semantic-analyze-context'."
:bounds bounds
:prefix prefix
:prefixclass prefixclass
:prefixtypes prefixtypes
:prefixtypes semantic--prefixtypes
:errors semantic-analyze-error-stack)))
;; TODO: Identify return value condition.
@ -686,7 +688,7 @@ Returns an object based on symbol `semantic-analyze-context'."
:bounds bounds
:prefix prefix
:prefixclass prefixclass
:prefixtypes prefixtypes
:prefixtypes semantic--prefixtypes
:errors semantic-analyze-error-stack)))
(t (setq context-return nil))
@ -750,7 +752,7 @@ Some useful functions are found in `semantic-format-tag-functions'."
:group 'semantic
:type semantic-format-tag-custom-list)
(defun semantic-analyze-princ-sequence (sequence &optional prefix buff)
(defun semantic-analyze-princ-sequence (sequence &optional prefix _buff)
"Send the tag SEQUENCE to standard out.
Use PREFIX as a label.
Use BUFF as a source of override methods."

16
lisp/cedet/semantic/analyze/complete.el
View file

@ -1,4 +1,4 @@
;;; semantic/analyze/complete.el --- Smart Completions
;;; semantic/analyze/complete.el --- Smart Completions -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@ -45,7 +45,7 @@
"For the tag TYPE, return any constant symbols of TYPE.
Used as options when completing.")
(defun semantic-analyze-type-constants-default (type)
(defun semantic-analyze-type-constants-default (_type)
"Do nothing with TYPE."
nil)
@ -54,7 +54,7 @@ Used as options when completing.")
(let ((origc tags))
;; Accept only tags that are of the datatype specified by
;; the desired classes.
(setq tags (apply 'nconc ;; All input lists are permutable.
(setq tags (apply #'nconc ;; All input lists are permutable.
(mapcar (lambda (class)
(semantic-find-tags-by-class class origc))
classlist)))
@ -109,6 +109,8 @@ in a buffer."
(when (called-interactively-p 'any)
(error "Buffer was not parsed by Semantic."))))
(defvar semantic--prefixtypes)
(defun semantic-analyze-possible-completions-default (context &optional flags)
"Default method for producing smart completions.
Argument CONTEXT is an object specifying the locally derived context.
@ -121,14 +123,14 @@ FLAGS can be any number of:
(desired-type (semantic-analyze-type-constraint a))
(desired-class (oref a prefixclass))
(prefix (oref a prefix))
(prefixtypes (oref a prefixtypes))
(semantic--prefixtypes (oref a prefixtypes))
(completetext nil)
(completetexttype nil)
(scope (oref a scope))
(localvar (when scope (oref scope localvar)))
(origc nil)
(c nil)
(any nil)
;; (any nil)
(do-typeconstraint (not (memq 'no-tc flags)))
(do-longprefix (not (memq 'no-longprefix flags)))
(do-unique (not (memq 'no-unique flags)))
@ -138,7 +140,7 @@ FLAGS can be any number of:
;; If we are not doing the long prefix, shorten all the key
;; elements.
(setq prefix (list (car (reverse prefix)))
prefixtypes nil))
semantic--prefixtypes nil))
;; Calculate what our prefix string is so that we can
;; find all our matching text.
@ -155,7 +157,7 @@ FLAGS can be any number of:
;; The prefixtypes should always be at least 1 less than
;; the prefix since the type is never looked up for the last
;; item when calculating a sequence.
(setq completetexttype (car (reverse prefixtypes)))
(setq completetexttype (car (reverse semantic--prefixtypes)))
(when (or (not completetexttype)
(not (and (semantic-tag-p completetexttype)
(eq (semantic-tag-class completetexttype) 'type))))

8
lisp/cedet/semantic/analyze/debug.el
View file

@ -1,4 +1,4 @@
;;; semantic/analyze/debug.el --- Debug the analyzer
;;; semantic/analyze/debug.el --- Debug the analyzer -*- lexical-binding: t; -*-
;;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@ -109,11 +109,11 @@ Argument COMP are possible completions here."
(condition-case err
(with-current-buffer origbuf
(let* ((position (or (cdr-safe (oref ctxt bounds)) (point)))
(prefixtypes nil) ; Used as type return
;; (semantic--prefixtypes nil) ; Used as type return
(scope (semantic-calculate-scope position))
)
(semantic-analyze-find-tag-sequence
(list prefix "") scope 'prefixtypes)
(list prefix "") scope) ;; 'semantic--prefixtypes
)
)
(error (setq finderr err)))
@ -149,7 +149,7 @@ path was setup incorrectly.\n")
(semantic-analyzer-debug-add-buttons)
))
(defun semantic-analyzer-debug-missing-datatype (ctxt idx comp)
(defun semantic-analyzer-debug-missing-datatype (ctxt idx _comp)
"Debug why we can't find a datatype entry for CTXT prefix at IDX.
Argument COMP are possible completions here."
(let* ((prefixitem (nth idx (oref ctxt prefix)))

4
lisp/cedet/semantic/analyze/fcn.el
View file

@ -1,4 +1,4 @@
;;; semantic/analyze/fcn.el --- Analyzer support functions.
;;; semantic/analyze/fcn.el --- Analyzer support functions. -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@ -55,7 +55,7 @@ Return the string representing the compound name.")
(defun semantic-analyze-unsplit-name-default (namelist)
"Concatenate the names in NAMELIST with a . between."
(mapconcat 'identity namelist "."))
(mapconcat #'identity namelist "."))
;;; SELECTING
;;

4
lisp/cedet/semantic/analyze/refs.el
View file

@ -1,4 +1,4 @@
;;; semantic/analyze/refs.el --- Analysis of the references between tags.
;;; semantic/analyze/refs.el --- Analysis of the references between tags. -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@ -296,7 +296,7 @@ Only works for tags in the global namespace."
(let* ((classmatch (semantic-tag-class tag))
(RES
(semanticdb-find-tags-collector
(lambda (table tags)
(lambda (_table tags)
(semantic-find-tags-by-class classmatch tags)
;; @todo - Add parent check also.
)

5
lisp/cedet/semantic/bovine.el
View file

@ -1,4 +1,4 @@
;;; semantic/bovine.el --- LL Parser/Analyzer core.
;;; semantic/bovine.el --- LL Parser/Analyzer core -*- lexical-binding: t; -*-
;; Copyright (C) 1999-2004, 2006-2007, 2009-2021 Free Software
;; Foundation, Inc.
@ -54,6 +54,7 @@ Use this to detect infinite recursion during a parse.")
"Create a lambda expression to return a list including RETURN-VAL.
The return list is a lambda expression to be used in a bovine table."
`(lambda (vals start end)
(ignore vals)
(append ,@return-val (list start end))))
;;; Semantic Bovination
@ -283,7 +284,7 @@ list of semantic tokens found."
;; Make it the default parser
;;;###autoload
(defalias 'semantic-parse-stream-default 'semantic-bovinate-stream)
(defalias 'semantic-parse-stream-default #'semantic-bovinate-stream)
(provide 'semantic/bovine)

8
lisp/cedet/semantic/bovine/grammar.el
View file

@ -1,4 +1,4 @@
;;; semantic/bovine/grammar.el --- Bovine's input grammar mode
;;; semantic/bovine/grammar.el --- Bovine's input grammar mode -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
;;
@ -243,7 +243,8 @@ QUOTEMODE is the mode in which quoted symbols are slurred."
(insert "\n")
(cond
((eq (car sexp) 'EXPAND)
(insert ",(lambda (vals start end)")
(insert ",(lambda (vals start end)"
"\n(ignore vals start end)")
;; The EXPAND macro definition is mandatory
(bovine-grammar-expand-form
(apply (cdr (assq 'EXPAND bovine--grammar-macros)) (cdr sexp))
@ -520,7 +521,8 @@ Menu items are appended to the common grammar menu.")
(goto-char (point-min))
(delete-region (point-min) (line-end-position))
(insert ";;; " packagename
" --- Generated parser support file")
" --- Generated parser support file "
"-*- lexical-binding:t -*-")
(delete-trailing-whitespace)
(re-search-forward ";;; \\(.*\\) ends here")
(replace-match packagename nil nil nil 1)))))

29
lisp/cedet/semantic/db-file.el
View file

@ -154,8 +154,6 @@ If DIRECTORY doesn't exist, create a new one."
;;; File IO
(declare-function inversion-test "inversion")
(defun semanticdb-load-database (filename)
"Load the database FILENAME."
(condition-case foo
@ -163,32 +161,19 @@ If DIRECTORY doesn't exist, create a new one."
'semanticdb-project-database-file))
(c (semanticdb-get-database-tables r))
(tv (oref r semantic-tag-version))
(fv (oref r semanticdb-version))
)
(fv (oref r semanticdb-version)))
;; Restore the parent-db connection
(while c
(oset (car c) parent-db r)
(setq c (cdr c)))
(unless (and (equal semanticdb-file-version fv)
(equal semantic-tag-version tv))
;; Try not to load inversion unless we need it:
(require 'inversion)
(if (not (inversion-test 'semanticdb-file fv))
(when (inversion-test 'semantic-tag tv)
;; Incompatible version. Flush tables.
(semanticdb-flush-database-tables r)
;; Reset the version to new version.
(oset r semantic-tag-version semantic-tag-version)
;; Warn user
(message "Semanticdb file is old. Starting over for %s"
filename))
;; Version is not ok. Flush whole system
(message "semanticdb file is old. Starting over for %s"
filename)
;; This database is so old, we need to replace it.
;; We also need to delete it from the instance tracker.
(delete-instance r)
(setq r nil)))
;; Version is not ok. Flush whole system
(message "semanticdb file is old. Starting over for %s" filename)
;; This database is so old, we need to replace it.
;; We also need to delete it from the instance tracker.
(delete-instance r)
(setq r nil))
r)
(error (message "Cache Error: [%s] %s, Restart"
filename foo)

6
lisp/cedet/semantic/ede-grammar.el
View file

@ -162,10 +162,9 @@ Lays claim to all -by.el, and -wy.el files."
"Insert variables needed by target THIS."
(ede-proj-makefile-insert-loadpath-items
(ede-proj-elisp-packages-to-loadpath
(list "eieio" "semantic" "inversion" "ede")))
(list "eieio" "semantic" "ede")))
;; eieio for object system needed in ede
;; semantic because it is
;; Inversion for versioning system.
;; ede for project regeneration
(ede-pmake-insert-variable-shared
(concat (ede-pmake-varname this) "_SEMANTIC_GRAMMAR_EL")
@ -174,8 +173,7 @@ Lays claim to all -by.el, and -wy.el files."
(with-current-buffer (find-file-noselect src)
(concat (semantic-grammar-package) ".el")))
(oref this source)
" ")))
)
" "))))
(cl-defmethod ede-proj-makefile-insert-rules :after ((this semantic-ede-proj-target-grammar))
"Insert rules needed by THIS target.

3
lisp/cedet/semantic/edit.el
View file

@ -828,8 +828,7 @@ This function is for internal use by `semantic-edits-incremental-parser'."
;; Make it the default changes parser
;;;###autoload
(defalias 'semantic-parse-changes-default
'semantic-edits-incremental-parser)
(defalias 'semantic-parse-changes-default #'semantic-edits-incremental-parser)
;;; Cache Splicing
;;

432
lisp/cedet/semantic/grammar-wy.el
View file

@ -1,6 +1,6 @@
;;; semantic/grammar-wy.el --- Generated parser support file
;;; semantic/grammar-wy.el --- Generated parser support file -*- lexical-binding:t -*-
;; Copyright (C) 2002-2004, 2009-2021 Free Software Foundation, Inc.
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@ -23,8 +23,9 @@
;;; Code:
(require 'semantic)
(require 'semantic/lex)
(eval-when-compile (require 'semantic/bovine))
;;; Prologue
;;
(defvar semantic-grammar-lex-c-char-re)
@ -36,16 +37,20 @@
;;; Declarations
;;
(eval-and-compile (defconst semantic-grammar-wy--expected-conflicts
nil
"The number of expected shift/reduce conflicts in this grammar."))
(defconst semantic-grammar-wy--keyword-table
(semantic-lex-make-keyword-table
'(("%default-prec" . DEFAULT-PREC)
("%no-default-prec" . NO-DEFAULT-PREC)
("%keyword" . KEYWORD)
("%expectedconflicts" . EXPECTEDCONFLICTS)
("%languagemode" . LANGUAGEMODE)
("%left" . LEFT)
("%nonassoc" . NONASSOC)
("%package" . PACKAGE)
("%expectedconflicts" . EXPECTEDCONFLICTS)
("%provide" . PROVIDE)
("%prec" . PREC)
("%put" . PUT)
@ -111,239 +116,239 @@
(eval-when-compile
(require 'semantic/wisent/comp))
(wisent-compile-grammar
'((DEFAULT-PREC NO-DEFAULT-PREC KEYWORD LANGUAGEMODE EXPECTEDCONFLICTS LEFT NONASSOC PACKAGE PROVIDE PREC PUT QUOTEMODE RIGHT SCOPESTART START TOKEN TYPE USE-MACROS STRING SYMBOL PERCENT_PERCENT CHARACTER PREFIXED_LIST SEXP PROLOGUE EPILOGUE PAREN_BLOCK BRACE_BLOCK LPAREN RPAREN LBRACE RBRACE COLON SEMI OR LT GT)
'((DEFAULT-PREC NO-DEFAULT-PREC KEYWORD LANGUAGEMODE LEFT NONASSOC PACKAGE EXPECTEDCONFLICTS PROVIDE PREC PUT QUOTEMODE RIGHT SCOPESTART START TOKEN TYPE USE-MACROS STRING SYMBOL PERCENT_PERCENT CHARACTER PREFIXED_LIST SEXP PROLOGUE EPILOGUE PAREN_BLOCK BRACE_BLOCK LPAREN RPAREN LBRACE RBRACE COLON SEMI OR LT GT)
nil
(grammar
((prologue))
((epilogue))
((declaration))
((nonterminal))
((PERCENT_PERCENT)))
((prologue))
((epilogue))
((declaration))
((nonterminal))
((PERCENT_PERCENT)))
(prologue
((PROLOGUE)
(wisent-raw-tag
((PROLOGUE)
(wisent-raw-tag
(semantic-tag-new-code "prologue" nil))))
(epilogue
((EPILOGUE)
(wisent-raw-tag
((EPILOGUE)
(wisent-raw-tag
(semantic-tag-new-code "epilogue" nil))))
(declaration
((decl)
(eval $1)))
((decl)
(eval $1)))
(decl
((default_prec_decl))
((no_default_prec_decl))
((languagemode_decl))
((expectedconflicts_decl))
((package_decl))
((provide_decl))
((precedence_decl))
((put_decl))
((quotemode_decl))
((scopestart_decl))
((start_decl))
((keyword_decl))
((token_decl))
((type_decl))
((use_macros_decl)))
((default_prec_decl))
((no_default_prec_decl))
((languagemode_decl))
((package_decl))
((expectedconflicts_decl))
((provide_decl))
((precedence_decl))
((put_decl))
((quotemode_decl))
((scopestart_decl))
((start_decl))
((keyword_decl))
((token_decl))
((type_decl))
((use_macros_decl)))
(default_prec_decl
((DEFAULT-PREC)
((DEFAULT-PREC)
`(wisent-raw-tag
(semantic-tag "default-prec" 'assoc :value
'("t")))))
(no_default_prec_decl
((NO-DEFAULT-PREC)
`(wisent-raw-tag
((NO-DEFAULT-PREC)
`(wisent-raw-tag
(semantic-tag "default-prec" 'assoc :value
'("nil")))))
'("nil")))))
(languagemode_decl
((LANGUAGEMODE symbols)
`(wisent-raw-tag
((LANGUAGEMODE symbols)
`(wisent-raw-tag
(semantic-tag ',(car $2)
'languagemode :rest ',(cdr $2)))))
(expectedconflicts_decl
((EXPECTEDCONFLICTS symbols)
`(wisent-raw-tag
(semantic-tag ',(car $2)
'expectedconflicts :rest ',(cdr $2)))))
'languagemode :rest ',(cdr $2)))))
(package_decl
((PACKAGE SYMBOL)
`(wisent-raw-tag
((PACKAGE SYMBOL)
`(wisent-raw-tag
(semantic-tag-new-package ',$2 nil))))
(expectedconflicts_decl
((EXPECTEDCONFLICTS symbols)
`(wisent-raw-tag
(semantic-tag ',(car $2)
'expectedconflicts :rest ',(cdr $2)))))
(provide_decl
((PROVIDE SYMBOL)
`(wisent-raw-tag
((PROVIDE SYMBOL)
`(wisent-raw-tag
(semantic-tag ',$2 'provide))))
(precedence_decl
((associativity token_type_opt items)
`(wisent-raw-tag
((associativity token_type_opt items)
`(wisent-raw-tag
(semantic-tag ',$1 'assoc :type ',$2 :value ',$3))))
(associativity
((LEFT)
(progn "left"))
((RIGHT)
(progn "right"))
((NONASSOC)
(progn "nonassoc")))
((LEFT)
(progn "left"))
((RIGHT)
(progn "right"))
((NONASSOC)
(progn "nonassoc")))
(put_decl
((PUT put_name put_value)
`(wisent-raw-tag
((PUT put_name put_value)
`(wisent-raw-tag
(semantic-tag ',$2 'put :value ',(list $3))))
((PUT put_name put_value_list)
`(wisent-raw-tag
((PUT put_name put_value_list)
`(wisent-raw-tag
(semantic-tag ',$2 'put :value ',$3)))
((PUT put_name_list put_value)
`(wisent-raw-tag
((PUT put_name_list put_value)
`(wisent-raw-tag
(semantic-tag ',(car $2)
'put :rest ',(cdr $2)
:value ',(list $3))))
((PUT put_name_list put_value_list)
`(wisent-raw-tag
'put :rest ',(cdr $2)
:value ',(list $3))))
((PUT put_name_list put_value_list)
`(wisent-raw-tag
(semantic-tag ',(car $2)
'put :rest ',(cdr $2)
:value ',$3))))
'put :rest ',(cdr $2)
:value ',$3))))
(put_name_list
((BRACE_BLOCK)
(mapcar 'semantic-tag-name
(semantic-parse-region
((BRACE_BLOCK)
(mapcar 'semantic-tag-name
(semantic-parse-region
(car $region1)
(cdr $region1)
'put_names 1))))
(put_names
((LBRACE)
nil)
((RBRACE)
nil)
((put_name)
(wisent-raw-tag
((LBRACE)
nil)
((RBRACE)
nil)
((put_name)
(wisent-raw-tag
(semantic-tag $1 'put-name))))
(put_name
((SYMBOL))
((token_type)))
((SYMBOL))
((token_type)))
(put_value_list
((BRACE_BLOCK)
(mapcar 'semantic-tag-code-detail
(semantic-parse-region
((BRACE_BLOCK)
(mapcar 'semantic-tag-code-detail
(semantic-parse-region
(car $region1)
(cdr $region1)
'put_values 1))))
(put_values
((LBRACE)
nil)
((RBRACE)
nil)
((put_value)
(wisent-raw-tag
((LBRACE)
nil)
((RBRACE)
nil)
((put_value)
(wisent-raw-tag
(semantic-tag-new-code "put-value" $1))))
(put_value
((SYMBOL any_value)
(cons $1 $2)))
((SYMBOL any_value)
(cons $1 $2)))
(scopestart_decl
((SCOPESTART SYMBOL)
`(wisent-raw-tag
((SCOPESTART SYMBOL)
`(wisent-raw-tag
(semantic-tag ',$2 'scopestart))))
(quotemode_decl
((QUOTEMODE SYMBOL)
`(wisent-raw-tag
((QUOTEMODE SYMBOL)
`(wisent-raw-tag
(semantic-tag ',$2 'quotemode))))
(start_decl
((START symbols)
`(wisent-raw-tag
((START symbols)
`(wisent-raw-tag
(semantic-tag ',(car $2)
'start :rest ',(cdr $2)))))
'start :rest ',(cdr $2)))))
(keyword_decl
((KEYWORD SYMBOL string_value)
`(wisent-raw-tag
((KEYWORD SYMBOL string_value)
`(wisent-raw-tag
(semantic-tag ',$2 'keyword :value ',$3))))
(token_decl
((TOKEN token_type_opt SYMBOL string_value)
`(wisent-raw-tag
((TOKEN token_type_opt SYMBOL string_value)
`(wisent-raw-tag
(semantic-tag ',$3 ',(if $2 'token 'keyword)
:type ',$2 :value ',$4)))
((TOKEN token_type_opt symbols)
`(wisent-raw-tag
:type ',$2 :value ',$4)))
((TOKEN token_type_opt symbols)
`(wisent-raw-tag
(semantic-tag ',(car $3)
'token :type ',$2 :rest ',(cdr $3)))))
'token :type ',$2 :rest ',(cdr $3)))))
(token_type_opt
(nil)
((token_type)))
(nil)
((token_type)))
(token_type
((LT SYMBOL GT)
(progn $2)))
((LT SYMBOL GT)
(progn $2)))
(type_decl
((TYPE token_type plist_opt)
`(wisent-raw-tag
((TYPE token_type plist_opt)
`(wisent-raw-tag
(semantic-tag ',$2 'type :value ',$3))))
(plist_opt
(nil)
((plist)))
(nil)
((plist)))
(plist
((plist put_value)
(append
((plist put_value)
(append
(list $2)
$1))
((put_value)
(list $1)))
((put_value)
(list $1)))
(use_name_list
((BRACE_BLOCK)
(mapcar 'semantic-tag-name
(semantic-parse-region
((BRACE_BLOCK)
(mapcar 'semantic-tag-name
(semantic-parse-region
(car $region1)
(cdr $region1)
'use_names 1))))
(use_names
((LBRACE)
nil)
((RBRACE)
nil)
((SYMBOL)
(wisent-raw-tag
((LBRACE)
nil)
((RBRACE)
nil)
((SYMBOL)
(wisent-raw-tag
(semantic-tag $1 'use-name))))
(use_macros_decl
((USE-MACROS SYMBOL use_name_list)
`(wisent-raw-tag
((USE-MACROS SYMBOL use_name_list)
`(wisent-raw-tag
(semantic-tag "macro" 'macro :type ',$2 :value ',$3))))
(string_value
((STRING)
(read $1)))
((STRING)
(read $1)))
(any_value
((SYMBOL))
((STRING))
((PAREN_BLOCK))
((PREFIXED_LIST))
((SEXP)))
((SYMBOL))
((STRING))
((PAREN_BLOCK))
((PREFIXED_LIST))
((SEXP)))
(symbols
((lifo_symbols)
(nreverse $1)))
((lifo_symbols)
(nreverse $1)))
(lifo_symbols
((lifo_symbols SYMBOL)
(cons $2 $1))
((SYMBOL)
(list $1)))
((lifo_symbols SYMBOL)
(cons $2 $1))
((SYMBOL)
(list $1)))
(nonterminal
((SYMBOL
((SYMBOL
(setq semantic-grammar-wy--nterm $1 semantic-grammar-wy--rindx 0)
COLON rules SEMI)
(wisent-raw-tag
(wisent-raw-tag
(semantic-tag $1 'nonterminal :children $4))))
(rules
((lifo_rules)
(apply 'nconc
(nreverse $1))))
((lifo_rules)
(apply 'nconc
(nreverse $1))))
(lifo_rules
((lifo_rules OR rule)
(cons $3 $1))
((rule)
(list $1)))
((lifo_rules OR rule)
(cons $3 $1))
((rule)
(list $1)))
(rule
((rhs)
(let*
((rhs)
(let*
((nterm semantic-grammar-wy--nterm)
(rindx semantic-grammar-wy--rindx)
(rhs $1)
comps prec action elt)
(setq semantic-grammar-wy--rindx
(1+ semantic-grammar-wy--rindx))
(1+ semantic-grammar-wy--rindx))
(while rhs
(setq elt
(car rhs)
@ -359,10 +364,10 @@
(if
(or action comps)
(setq comps
(cons elt comps)
semantic-grammar-wy--rindx
(1+ semantic-grammar-wy--rindx))
(setq action
(cons elt comps)
semantic-grammar-wy--rindx
(1+ semantic-grammar-wy--rindx))
(setq action
(car elt))))
(t
(setq comps
@ -375,46 +380,46 @@
(if comps "group" "empty")
:value comps :prec prec :expr action))))))
(rhs
(nil)
((rhs item)
(cons $2 $1))
((rhs action)
(cons
(nil)
((rhs item)
(cons $2 $1))
((rhs action)
(cons
(list $2)
$1))
((rhs PREC item)
(cons
((rhs PREC item)
(cons
(vector $3)
$1)))
(action
((PAREN_BLOCK))
((PREFIXED_LIST))
((BRACE_BLOCK)
(format "(progn\n%s)"
(let
((PAREN_BLOCK))
((PREFIXED_LIST))
((BRACE_BLOCK)
(format "(progn\n%s)"
(let
((s $1))
(if
(string-match "^{[\r\n\t ]*" s)
(string-match "^{[ \n ]*" s)
(setq s
(substring s
(match-end 0))))
(match-end 0))))
(if
(string-match "[\r\n\t ]*}$" s)
(string-match "[ \n ]*}$" s)
(setq s
(substring s 0
(match-beginning 0))))
(match-beginning 0))))
s))))
(items
((lifo_items)
(nreverse $1)))
((lifo_items)
(nreverse $1)))
(lifo_items
((lifo_items item)
(cons $2 $1))
((item)
(list $1)))
((lifo_items item)
(cons $2 $1))
((item)
(list $1)))
(item
((SYMBOL))
((CHARACTER))))
((SYMBOL))
((CHARACTER))))
'(grammar prologue epilogue declaration nonterminal rule put_names put_values use_names)))
"Parser table.")
@ -423,17 +428,38 @@
(semantic-install-function-overrides
'((semantic-parse-stream . wisent-parse-stream)))
(setq semantic-parser-name "LALR"
semantic--parse-table semantic-grammar-wy--parse-table
semantic-debug-parser-source "grammar.wy"
semantic-flex-keywords-obarray semantic-grammar-wy--keyword-table
semantic-lex-types-obarray semantic-grammar-wy--token-table)
semantic--parse-table semantic-grammar-wy--parse-table
semantic-debug-parser-source "grammar.wy"
semantic-flex-keywords-obarray semantic-grammar-wy--keyword-table
semantic-lex-types-obarray semantic-grammar-wy--token-table)
;; Collect unmatched syntax lexical tokens
(add-hook 'wisent-discarding-token-functions
'wisent-collect-unmatched-syntax nil t))
'wisent-collect-unmatched-syntax nil t))
;;; Analyzers
;;
(define-lex-regex-type-analyzer semantic-grammar-wy--<symbol>-regexp-analyzer
"regexp analyzer for <symbol> tokens."
":?\\(\\sw\\|\\s_\\)+"
'((PERCENT_PERCENT . "\\`%%\\'"))
'SYMBOL)
(define-lex-keyword-type-analyzer semantic-grammar-wy--<keyword>-keyword-analyzer
"keyword analyzer for <keyword> tokens."
"\\(\\sw\\|\\s_\\)+")
(define-lex-regex-type-analyzer semantic-grammar-wy--<char>-regexp-analyzer
"regexp analyzer for <char> tokens."
semantic-grammar-lex-c-char-re
nil
'CHARACTER)
(define-lex-sexp-type-analyzer semantic-grammar-wy--<qlist>-sexp-analyzer
"sexp analyzer for <qlist> tokens."
"\\s'\\s-*("
'PREFIXED_LIST)
(define-lex-block-type-analyzer semantic-grammar-wy--<block>-block-analyzer
"block analyzer for <block> tokens."
"\\s(\\|\\s)"
@ -443,28 +469,6 @@
("}" RBRACE))
)
(define-lex-regex-type-analyzer semantic-grammar-wy--<char>-regexp-analyzer
"regexp analyzer for <char> tokens."
semantic-grammar-lex-c-char-re
nil
'CHARACTER)
(define-lex-regex-type-analyzer semantic-grammar-wy--<symbol>-regexp-analyzer
"regexp analyzer for <symbol> tokens."
":?\\(\\sw\\|\\s_\\)+"
'((PERCENT_PERCENT . "\\`%%\\'"))
'SYMBOL)
(define-lex-sexp-type-analyzer semantic-grammar-wy--<qlist>-sexp-analyzer
"sexp analyzer for <qlist> tokens."
"\\s'\\s-*("
'PREFIXED_LIST)
(define-lex-sexp-type-analyzer semantic-grammar-wy--<string>-sexp-analyzer
"sexp analyzer for <string> tokens."
"\\s\""
'STRING)
(define-lex-string-type-analyzer semantic-grammar-wy--<punctuation>-string-analyzer
"string analyzer for <punctuation> tokens."
"\\(\\s.\\|\\s$\\|\\s'\\)+"
@ -475,9 +479,10 @@
(COLON . ":"))
'punctuation)
(define-lex-keyword-type-analyzer semantic-grammar-wy--<keyword>-keyword-analyzer
"keyword analyzer for <keyword> tokens."
"\\(\\sw\\|\\s_\\)+")
(define-lex-sexp-type-analyzer semantic-grammar-wy--<string>-sexp-analyzer
"sexp analyzer for <string> tokens."
"\\s\""
'STRING)
(define-lex-sexp-type-analyzer semantic-grammar-wy--<sexp>-sexp-analyzer
"sexp analyzer for <sexp> tokens."
@ -493,4 +498,9 @@
(provide 'semantic/grammar-wy)
;; Local Variables:
;; version-control: never
;; no-update-autoloads: t
;; End:
;;; semantic/grammar-wy.el ends here

58
lisp/cedet/semantic/idle.el
View file

@ -47,8 +47,6 @@
;; For the semantic-find-tags-by-name macro.
(eval-when-compile (require 'semantic/find))
(defvar eldoc-last-message)
(declare-function eldoc-message "eldoc")
(declare-function semantic-analyze-unsplit-name "semantic/analyze/fcn")
(declare-function semantic-complete-analyze-inline-idle "semantic/complete")
(declare-function semanticdb-deep-find-tags-by-name "semantic/db-find")
@ -730,8 +728,8 @@ specific to a major mode. For example, in jde mode:
:group 'semantic
:type 'hook)
(defun semantic-idle-summary-idle-function ()
"Display a tag summary of the lexical token under the cursor.
(defun semantic--eldoc-info (_callback &rest _)
"Return the eldoc info for the current symbol.
Call `semantic-idle-summary-current-symbol-info' for getting the
current tag to display information."
(or (eq major-mode 'emacs-lisp-mode)
@ -741,21 +739,7 @@ current tag to display information."
((semantic-tag-p found)
(funcall semantic-idle-summary-function
found nil t)))))
;; Show the message with eldoc functions
(unless (and str (boundp 'eldoc-echo-area-use-multiline-p)
eldoc-echo-area-use-multiline-p)
(let ((w (1- (window-width (minibuffer-window)))))
(if (> (length str) w)
(setq str (substring str 0 w)))))
;; I borrowed some bits from eldoc to shorten the
;; message.
(when semantic-idle-truncate-long-summaries
(let ((ea-width (1- (window-width (minibuffer-window))))
(strlen (length str)))
(when (> strlen ea-width)
(setq str (substring str 0 ea-width)))))
;; Display it
(eldoc-message str))))
str)))
(define-minor-mode semantic-idle-summary-mode
"Toggle Semantic Idle Summary mode.
@ -764,30 +748,16 @@ When this minor mode is enabled, the echo area displays a summary
of the lexical token at point whenever Emacs is idle."
:group 'semantic
:group 'semantic-modes
(if semantic-idle-summary-mode
;; Enable the mode
(progn
(unless (and (featurep 'semantic) (semantic-active-p))
;; Disable minor mode if semantic stuff not available
(setq semantic-idle-summary-mode nil)
(error "Buffer %s was not set up for parsing"
(buffer-name)))
(require 'eldoc)
(semantic-idle-scheduler-add 'semantic-idle-summary-idle-function)
(add-hook 'pre-command-hook 'semantic-idle-summary-refresh-echo-area t))
;; Disable the mode
(semantic-idle-scheduler-remove 'semantic-idle-summary-idle-function)
(remove-hook 'pre-command-hook 'semantic-idle-summary-refresh-echo-area t)))
(defun semantic-idle-summary-refresh-echo-area ()
(and semantic-idle-summary-mode
eldoc-last-message
(if (and (not executing-kbd-macro)
(not (and (boundp 'edebug-active) edebug-active))
(not cursor-in-echo-area)
(not (eq (selected-window) (minibuffer-window))))
(eldoc-message eldoc-last-message)
(setq eldoc-last-message nil))))
(remove-hook 'eldoc-documentation-functions #'semantic--eldoc-info t)
(when semantic-idle-summary-mode
;; Enable the mode
(unless (and (featurep 'semantic) (semantic-active-p))
;; Disable minor mode if semantic stuff not available
(setq semantic-idle-summary-mode nil)
(error "Buffer %s was not set up for parsing"
(buffer-name)))
(add-hook 'eldoc-documentation-functions #'semantic--eldoc-info nil t)
(eldoc-mode 1)))
(semantic-add-minor-mode 'semantic-idle-summary-mode "")
@ -1092,7 +1062,7 @@ be called."
;; mouse-3 pops up a context menu
(define-key map
[ header-line mouse-3 ]
'semantic-idle-breadcrumbs--popup-menu)
#'semantic-idle-breadcrumbs--popup-menu)
map)
"Keymap for semantic idle breadcrumbs minor mode.")

44
lisp/cedet/semantic/tag.el
View file

@ -229,6 +229,28 @@ See also the function `semantic-ctxt-current-mode'."
(require 'semantic/ctxt)
(semantic-ctxt-current-mode)))))
;; Is this function still necessary?
(defun semantic-tag-make-plist (args)
"Create a property list with ARGS.
Args is a property list of the form (KEY1 VALUE1 ... KEYN VALUEN).
Where KEY is a symbol, and VALUE is the value for that symbol.
The return value will be a new property list, with these KEY/VALUE
pairs eliminated:
- KEY associated to nil VALUE.
- KEY associated to an empty string VALUE.
- KEY associated to a zero VALUE."
(let (plist key val)
(while args
(setq key (car args)
val (nth 1 args)
args (nthcdr 2 args))
(or (member val '("" nil))
(and (numberp val) (zerop val))
(setq plist (cons key (cons val plist)))))
;; It is not useful to reverse the new plist.
plist))
(defsubst semantic--tag-attributes-cdr (tag)
"Return the cons cell whose car is the ATTRIBUTES part of TAG.
That function is for internal use only."
@ -441,28 +463,6 @@ class to store those methods."
;;; Tag creation
;;
;; Is this function still necessary?
(defun semantic-tag-make-plist (args)
"Create a property list with ARGS.
Args is a property list of the form (KEY1 VALUE1 ... KEYN VALUEN).
Where KEY is a symbol, and VALUE is the value for that symbol.
The return value will be a new property list, with these KEY/VALUE
pairs eliminated:
- KEY associated to nil VALUE.
- KEY associated to an empty string VALUE.
- KEY associated to a zero VALUE."
(let (plist key val)
(while args
(setq key (car args)
val (nth 1 args)
args (nthcdr 2 args))
(or (member val '("" nil))
(and (numberp val) (zerop val))
(setq plist (cons key (cons val plist)))))
;; It is not useful to reverse the new plist.
plist))
(defsubst semantic-tag (name class &rest attributes)
"Create a generic semantic tag.
NAME is a string representing the name of this tag.

7
lisp/cedet/semantic/wisent/grammar.el
View file

@ -1,4 +1,4 @@
;;; semantic/wisent/grammar.el --- Wisent's input grammar mode
;;; semantic/wisent/grammar.el --- Wisent's input grammar mode -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
;;
@ -228,7 +228,7 @@ Keep order of declaration in the WY file without duplicates."
Return the expanded expression."
(if (or (atom expr) (semantic-grammar-quote-p (car expr)))
expr ;; Just return atom or quoted expression.
(let* ((expr (mapcar 'wisent-grammar-expand-macros expr))
(let* ((expr (mapcar #'wisent-grammar-expand-macros expr))
(macro (assq (car expr) wisent--grammar-macros)))
(if macro ;; Expand Semantic built-in.
(apply (cdr macro) (cdr expr))
@ -514,7 +514,8 @@ Menu items are appended to the common grammar menu.")
(goto-char (point-min))
(delete-region (point-min) (line-end-position))
(insert ";;; " packagename
" --- Generated parser support file")
" --- Generated parser support file "
"-*- lexical-binding:t -*-")
(re-search-forward ";;; \\(.*\\) ends here")
(replace-match packagename nil nil nil 1)
(delete-trailing-whitespace))))))

2
lisp/cedet/srecode/args.el
View file

@ -1,4 +1,4 @@
;;; srecode/args.el --- Provide some simple template arguments
;;; srecode/args.el --- Provide some simple template arguments -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.

6
lisp/cedet/srecode/compile.el
View file

@ -1,4 +1,4 @@
;;; srecode/compile --- Compilation of srecode template files.
;;; srecode/compile --- Compilation of srecode template files. -*- lexical-binding: t; -*-
;; Copyright (C) 2005, 2007-2021 Free Software Foundation, Inc.
@ -499,7 +499,7 @@ PROPS are additional properties that might need to be passed
to the inserter constructor."
;;(message "Compile: %s %S" name props)
(if (not key)
(apply 'srecode-template-inserter-variable name props)
(apply #'make-instance 'srecode-template-inserter-variable name props)
(let ((classes (eieio-class-children 'srecode-template-inserter))
(new nil))
;; Loop over the various subclasses and
@ -510,7 +510,7 @@ to the inserter constructor."
(when (and (not (class-abstract-p (car classes)))
(equal (oref-default (car classes) key) key))
;; Create the new class, and apply state.
(setq new (apply (car classes) name props))
(setq new (apply #'make-instance (car classes) name props))
(srecode-inserter-apply-state new STATE)
)
(setq classes (cdr classes)))

3
lisp/cedet/srecode/cpp.el
View file

@ -1,4 +1,4 @@
;;; srecode/cpp.el --- C++ specific handlers for Semantic Recoder
;;; srecode/cpp.el --- C++ specific handlers for Semantic Recoder -*- lexical-binding: t; -*-
;; Copyright (C) 2007, 2009-2021 Free Software Foundation, Inc.
@ -44,7 +44,6 @@
A dictionary entry of the named PREFIX_NAMESPACE with the value
NAMESPACE:: is created for each namespace unless the current
buffer contains a using NAMESPACE; statement."
:group 'srecode-cpp
:type '(repeat string))
;;; :c ARGUMENT HANDLING

2
lisp/cedet/srecode/ctxt.el
View file

@ -1,4 +1,4 @@
;;; srecode/ctxt.el --- Derive a context from the source buffer.
;;; srecode/ctxt.el --- Derive a context from the source buffer. -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.

21
lisp/cedet/srecode/dictionary.el
View file

@ -1,4 +1,4 @@
;;; srecode/dictionary.el --- Dictionary code for the semantic recoder.
;;; srecode/dictionary.el --- Dictionary code for the semantic recoder. -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@ -443,8 +443,8 @@ The root dictionary is usually for a current or active insertion."
;; for use in converting the compound value into something insertable.
(cl-defmethod srecode-compound-toString ((cp srecode-dictionary-compound-value)
function
dictionary)
_function
_dictionary)
"Convert the compound dictionary value CP to a string.
If FUNCTION is non-nil, then FUNCTION is somehow applied to an aspect
of the compound value. The FUNCTION could be a fraction
@ -457,14 +457,15 @@ standard out is a buffer, and using `insert'."
(eieio-object-name cp))
(cl-defmethod srecode-dump ((cp srecode-dictionary-compound-value)
&optional indent)
&optional _indent)
"Display information about this compound value."
(princ (eieio-object-name cp))
)
(cl-defmethod srecode-compound-toString ((cp srecode-dictionary-compound-variable)
function
dictionary)
(cl-defmethod srecode-compound-toString
((cp srecode-dictionary-compound-variable)
_function
dictionary)
"Convert the compound dictionary variable value CP into a string.
FUNCTION and DICTIONARY are as for the baseclass."
(require 'srecode/insert)
@ -606,9 +607,9 @@ STATE is the current compiler state."
(require 'srecode/find)
(let* ((modesym major-mode)
(start (current-time))
(junk (or (progn (srecode-load-tables-for-mode modesym)
(srecode-get-mode-table modesym))
(error "No table found for mode %S" modesym)))
(_ (or (progn (srecode-load-tables-for-mode modesym)
(srecode-get-mode-table modesym))
(error "No table found for mode %S" modesym)))
(dict (srecode-create-dictionary (current-buffer)))
)
(message "Creating a dictionary took %.2f seconds."

11
lisp/cedet/srecode/document.el
View file

@ -1,4 +1,4 @@
;;; srecode/document.el --- Documentation (comment) generation
;;; srecode/document.el --- Documentation (comment) generation -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@ -88,7 +88,6 @@ versions of names. This is an alist with each element of the form:
(MATCH . RESULT)
MATCH is a regexp to match in the type field.
RESULT is a string."
:group 'document
:type '(repeat (cons (regexp :tag "Regexp")
(string :tag "Doc Text"))))
@ -144,7 +143,6 @@ A string may end in a space, in which case, last-alist is searched to
see how best to describe what can be returned.
Doesn't always work correctly, but that is just because English
doesn't always work correctly."
:group 'document
:type '(repeat (cons (regexp :tag "Regexp")
(string :tag "Doc Text"))))
@ -175,7 +173,6 @@ versions of names. This is an alist with each element of the form:
(MATCH . RESULT)
MATCH is a regexp to match in the type field.
RESULT is a string."
:group 'document
:type '(repeat (cons (regexp :tag "Regexp")
(string :tag "Doc Text"))))
@ -192,7 +189,6 @@ This is an alist with each element of the form:
(MATCH . RESULT)
MATCH is a regexp to match in the type field.
RESULT is a string."
:group 'document
:type '(repeat (cons (regexp :tag "Regexp")
(string :tag "Doc Text"))))
@ -213,7 +209,6 @@ This is an alist with each element of the form:
MATCH is a regexp to match in the type field.
RESULT is a string, which can contain %s, which is replaced with
`match-string' 1."
:group 'document
:type '(repeat (cons (regexp :tag "Regexp")
(string :tag "Doc Text"))))
@ -233,7 +228,6 @@ MATCH is a regexp to match in the type field.
RESULT is a string of text to use to describe MATCH.
When one is encountered, document-insert-parameters will automatically
place this comment after the parameter name."
:group 'document
:type '(repeat (cons (regexp :tag "Regexp")
(string :tag "Doc Text"))))
@ -258,7 +252,6 @@ This is an alist with each element of the form:
(MATCH . RESULT)
MATCH is a regexp to match in the type field.
RESULT is a string."
:group 'document
:type '(repeat (cons (regexp :tag "Regexp")
(string :tag "Doc Text"))))
@ -716,7 +709,7 @@ allocating something based on its type."
(setq al (cdr al)))))
news))
(defun srecode-document-parameter-comment (param &optional commentlist)
(defun srecode-document-parameter-comment (param &optional _commentlist)
"Convert tag or string PARAM into a name,comment pair.
Optional COMMENTLIST is list of previously existing comments to
use instead in alist form. If the name doesn't appear in the list of

2
lisp/cedet/srecode/el.el
View file

@ -1,4 +1,4 @@
;;; srecode/el.el --- Emacs Lisp specific arguments
;;; srecode/el.el --- Emacs Lisp specific arguments -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.

2
lisp/cedet/srecode/expandproto.el
View file

@ -1,4 +1,4 @@
;;; srecode/expandproto.el --- Expanding prototypes.
;;; srecode/expandproto.el --- Expanding prototypes. -*- lexical-binding: t; -*-
;; Copyright (C) 2007, 2009-2021 Free Software Foundation, Inc.

20
lisp/cedet/srecode/extract.el
View file

@ -1,4 +1,4 @@
;;; srecode/extract.el --- Extract content from previously inserted macro.
;;; srecode/extract.el --- Extract content from previously inserted macro. -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@ -139,24 +139,24 @@ Uses STATE to maintain the current extraction state."
;;; Inserter Base Extractors
;;
(cl-defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter))
(cl-defmethod srecode-inserter-do-extract-p ((_ins srecode-template-inserter))
"Return non-nil if this inserter can extract values."
nil)
(cl-defmethod srecode-inserter-extract ((ins srecode-template-inserter)
start end dict state)
(cl-defmethod srecode-inserter-extract ((_ins srecode-template-inserter)
_start _end _dict _state)
"Extract text from START/END and store in DICT.
Return nil as this inserter will extract nothing."
nil)
;;; Variable extractor is simple and can extract later.
;;
(cl-defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter-variable))
(cl-defmethod srecode-inserter-do-extract-p ((_ins srecode-template-inserter-variable))
"Return non-nil if this inserter can extract values."
'later)
(cl-defmethod srecode-inserter-extract ((ins srecode-template-inserter-variable)
start end vdict state)
start end vdict _state)
"Extract text from START/END and store in VDICT.
Return t if something was extracted.
Return nil if this inserter doesn't need to extract anything."
@ -168,12 +168,12 @@ Return nil if this inserter doesn't need to extract anything."
;;; Section Inserter
;;
(cl-defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter-section-start))
(cl-defmethod srecode-inserter-do-extract-p ((_ins srecode-template-inserter-section-start))
"Return non-nil if this inserter can extract values."
'now)
(cl-defmethod srecode-inserter-extract ((ins srecode-template-inserter-section-start)
start end indict state)
_start _end indict state)
"Extract text from START/END and store in INDICT.
Return the starting location of the first plain-text match.
Return nil if nothing was extracted."
@ -201,12 +201,12 @@ Return nil if nothing was extracted."
;;; Include Extractor must extract now.
;;
(cl-defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter-include))
(cl-defmethod srecode-inserter-do-extract-p ((_ins srecode-template-inserter-include))
"Return non-nil if this inserter can extract values."
'now)
(cl-defmethod srecode-inserter-extract ((ins srecode-template-inserter-include)
start end dict state)
start _end dict state)
"Extract text from START/END and store in DICT.
Return the starting location of the first plain-text match.
Return nil if nothing was extracted."

31
lisp/cedet/srecode/fields.el
View file

@ -1,4 +1,4 @@
;;; srecode/fields.el --- Handling type-in fields in a buffer.
;;; srecode/fields.el --- Handling type-in fields in a buffer. -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2009-2021 Free Software Foundation, Inc.
;;
@ -193,7 +193,7 @@ If SET-TO is a string, then replace the text of OLAID with SET-TO."
"Manage a buffer region in which fields exist.")
(cl-defmethod initialize-instance ((ir srecode-template-inserted-region)
&rest args)
&rest _args)
"Initialize IR, capturing the active fields, and creating the overlay."
;; Fill in the fields
(oset ir fields srecode-field-archive)
@ -221,7 +221,7 @@ If SET-TO is a string, then replace the text of OLAID with SET-TO."
(oset ir active-region ir)
;; Setup the post command hook.
(add-hook 'post-command-hook 'srecode-field-post-command t t)
(add-hook 'post-command-hook #'srecode-field-post-command t t)
)
(cl-defmethod srecode-delete ((ir srecode-template-inserted-region))
@ -229,12 +229,11 @@ If SET-TO is a string, then replace the text of OLAID with SET-TO."
;; Clear us out of the baseclass.
(oset ir active-region nil)
;; Clear our fields.
(mapc 'srecode-delete (oref ir fields))
(mapc #'srecode-delete (oref ir fields))
;; Call to our base
(cl-call-next-method)
;; Clear our hook.
(remove-hook 'post-command-hook 'srecode-field-post-command t)
)
(remove-hook 'post-command-hook #'srecode-field-post-command t))
(defsubst srecode-active-template-region ()
"Return the active region for template fields."
@ -246,7 +245,7 @@ If SET-TO is a string, then replace the text of OLAID with SET-TO."
)
(if (not ar)
;; Find a bug and fix it.
(remove-hook 'post-command-hook 'srecode-field-post-command t)
(remove-hook 'post-command-hook #'srecode-field-post-command t)
(if (srecode-point-in-region-p ar)
nil ;; Keep going
;; We moved out of the template. Cancel the edits.
@ -277,16 +276,16 @@ Try to use this to provide useful completion when available.")
(defvar srecode-field-keymap
(let ((km (make-sparse-keymap)))
(define-key km "\C-i" 'srecode-field-next)
(define-key km "\M-\C-i" 'srecode-field-prev)
(define-key km "\C-e" 'srecode-field-end)
(define-key km "\C-a" 'srecode-field-start)
(define-key km "\M-m" 'srecode-field-start)
(define-key km "\C-c\C-c" 'srecode-field-exit-ask)
(define-key km "\C-i" #'srecode-field-next)
(define-key km "\M-\C-i" #'srecode-field-prev)
(define-key km "\C-e" #'srecode-field-end)
(define-key km "\C-a" #'srecode-field-start)
(define-key km "\M-m" #'srecode-field-start)
(define-key km "\C-c\C-c" #'srecode-field-exit-ask)
km)
"Keymap applied to field overlays.")
(cl-defmethod initialize-instance ((field srecode-field) &optional args)
(cl-defmethod initialize-instance ((field srecode-field) &optional _args)
"Initialize FIELD, being sure it archived."
(add-to-list 'srecode-field-archive field t)
(cl-call-next-method)
@ -327,7 +326,7 @@ Try to use this to provide useful completion when available.")
(defvar srecode-field-replication-max-size 100
"Maximum size of a field before canceling replication.")
(defun srecode-field-mod-hook (ol after start end &optional pre-len)
(defun srecode-field-mod-hook (ol after _start _end &optional _pre-len)
"Modification hook for the field overlay.
OL is the overlay.
AFTER is non-nil if it is called after the change.
@ -374,7 +373,7 @@ AFTER is non-nil if it is called after the change.
START and END are the bounds of the change.
PRE-LEN is used in the after mode for the length of the changed text."
(when after
(let* ((field (overlay-get ol 'srecode))
(let* (;; (field (overlay-get ol 'srecode))
)
(move-overlay ol (overlay-start ol) end)
(srecode-field-mod-hook ol after start end pre-len))

2
lisp/cedet/srecode/filters.el
View file

@ -1,4 +1,4 @@
;;; srecode/filters.el --- Filters for use in template variables.
;;; srecode/filters.el --- Filters for use in template variables. -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.

23
lisp/cedet/srecode/find.el
View file

@ -1,4 +1,4 @@
;;;; srecode/find.el --- Tools for finding templates in the database.
;;;; srecode/find.el --- Tools for finding templates in the database. -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@ -58,17 +58,14 @@ See `srecode-get-maps' for more.
APPNAME is the name of an application. In this case,
all template files for that application will be loaded."
(let ((files
(if appname
(apply 'append
(mapcar
(apply #'append
(mapcar
(if appname
(lambda (map)
(srecode-map-entries-for-app-and-mode map appname mmode))
(srecode-get-maps)))
(apply 'append
(mapcar
(lambda (map)
(srecode-map-entries-for-mode map mmode))
(srecode-get-maps)))))
(srecode-map-entries-for-mode map mmode)))
(srecode-get-maps))))
)
;; Don't recurse if we are already the 'default state.
(when (not (eq mmode 'default))
@ -112,8 +109,8 @@ If TAB is nil, then always return t."
;; Find a given template based on name, and features of the current
;; buffer.
(cl-defmethod srecode-template-get-table ((tab srecode-template-table)
template-name &optional
context application)
template-name &optional
context _application)
"Find in the template in table TAB, the template with TEMPLATE-NAME.
Optional argument CONTEXT specifies that the template should part
of a particular context.
@ -218,7 +215,7 @@ tables that do not belong to an application will be searched."
(defvar srecode-read-template-name-history nil
"History for completing reads for template names.")
(defun srecode-user-template-p (template)
(defun srecode-user-template-p (_template)
"Non-nil if TEMPLATE is intended for user insertion.
Templates not matching this predicate are used for code
generation or other internal purposes."
@ -264,7 +261,7 @@ with `srecode-calculate-context'."
;; the prefix for the completing read
(concat (nth 0 ctxt) ":"))))
(defun srecode-read-template-name (prompt &optional initial hist default)
(defun srecode-read-template-name (prompt &optional initial hist _default)
"Completing read for Semantic Recoder template names.
PROMPT is used to query for the name of the template desired.
INITIAL is the initial string to use.

4
lisp/cedet/srecode/getset.el
View file

@ -1,4 +1,4 @@
;;; srecode/getset.el --- Package for inserting new get/set methods.
;;; srecode/getset.el --- Package for inserting new get/set methods. -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@ -33,6 +33,8 @@
(defvar srecode-insert-getset-fully-automatic-flag nil
"Non-nil means accept choices srecode comes up with without asking.")
(defvar srecode-semantic-selected-tag)
;;;###autoload
(defun srecode-insert-getset (&optional class-in field-in)
"Insert get/set methods for the current class.

2
lisp/cedet/srecode/java.el
View file

@ -1,4 +1,4 @@
;;; srecode/java.el --- Srecode Java support
;;; srecode/java.el --- Srecode Java support -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2021 Free Software Foundation, Inc.

6
lisp/cedet/srecode/map.el
View file

@ -1,4 +1,4 @@
;;; srecode/map.el --- Manage a template file map
;;; srecode/map.el --- Manage a template file map -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@ -245,7 +245,7 @@ Optional argument RESET forces a reset of the current map."
(princ "\n")
))
(defun srecode-map-file-still-valid-p (filename map)
(defun srecode-map-file-still-valid-p (filename _map)
"Return t if FILENAME should be in MAP still."
(let ((valid nil))
(and (file-exists-p filename)
@ -407,7 +407,7 @@ Return non-nil if the map changed."
"Global load path for SRecode template files."
:group 'srecode
:type '(repeat file)
:set 'srecode-map-load-path-set)
:set #'srecode-map-load-path-set)
(provide 'srecode/map)

27
lisp/cedet/srecode/mode.el
View file

@ -1,4 +1,4 @@
;;; srecode/mode.el --- Minor mode for managing and using SRecode templates
;;; srecode/mode.el --- Minor mode for managing and using SRecode templates -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@ -54,14 +54,14 @@
(defvar srecode-prefix-map
(let ((km (make-sparse-keymap)))
;; Basic template codes
(define-key km "/" 'srecode-insert)
(define-key km [insert] 'srecode-insert)
(define-key km "." 'srecode-insert-again)
(define-key km "E" 'srecode-edit)
(define-key km "/" #'srecode-insert)
(define-key km [insert] #'srecode-insert)
(define-key km "." #'srecode-insert-again)
(define-key km "E" #'srecode-edit)
;; Template indirect binding
(let ((k ?a))
(while (<= k ?z)
(define-key km (format "%c" k) 'srecode-bind-insert)
(define-key km (format "%c" k) #'srecode-bind-insert)
(setq k (1+ k))))
km)
"Keymap used behind the srecode prefix key in srecode minor mode.")
@ -141,16 +141,17 @@ non-nil if the minor mode is enabled.
;; this mode first.
(if srecode-minor-mode
(if (not (apply
'append
#'append
(mapcar (lambda (map)
(srecode-map-entries-for-mode map major-mode))
(srecode-get-maps))))
(setq srecode-minor-mode nil)
;; Else, we have success, do stuff
(add-hook 'cedet-m3-menu-do-hooks 'srecode-m3-items nil t)
)
(remove-hook 'cedet-m3-menu-do-hooks 'srecode-m3-items t)
)
;; FIXME: Where are `cedet-m3-menu-do-hooks' nor `srecode-m3-items'?
(when (fboundp 'srecode-m3-items)
(add-hook 'cedet-m3-menu-do-hooks #'srecode-m3-items nil t)))
(when (fboundp 'srecode-m3-items)
(remove-hook 'cedet-m3-menu-do-hooks #'srecode-m3-items t)))
;; Run hooks if we are turning this on.
(when srecode-minor-mode
(run-hooks 'srecode-minor-mode-hook))
@ -170,7 +171,7 @@ non-nil if the minor mode is enabled.
;;; Menu Filters
;;
(defun srecode-minor-mode-templates-menu (menu-def)
(defun srecode-minor-mode-templates-menu (_menu-def)
"Create a menu item of cascading filters active for this mode.
MENU-DEF is the menu to bind this into."
;; Doing this SEGVs Emacs on windows.
@ -246,7 +247,7 @@ MENU-DEF is the menu to bind this into."
(defvar srecode-minor-mode-generators nil
"List of code generators to be displayed in the srecoder menu.")
(defun srecode-minor-mode-generate-menu (menu-def)
(defun srecode-minor-mode-generate-menu (_menu-def)
"Create a menu item of cascading filters active for this mode.
MENU-DEF is the menu to bind this into."
;; Doing this SEGVs Emacs on windows.

16
lisp/cedet/srecode/srt-mode.el
View file

@ -1,4 +1,4 @@
;;; srecode/srt-mode.el --- Major mode for writing screcode macros
;;; srecode/srt-mode.el --- Major mode for writing screcode macros -*- lexical-binding: t; -*-
;; Copyright (C) 2005, 2007-2021 Free Software Foundation, Inc.
@ -181,9 +181,9 @@ we can tell font lock about them.")
(defvar srecode-template-mode-map
(let ((km (make-sparse-keymap)))
(define-key km "\C-c\C-c" 'srecode-compile-templates)
(define-key km "\C-c\C-m" 'srecode-macro-help)
(define-key km "/" 'srecode-self-insert-complete-end-macro)
(define-key km "\C-c\C-c" #'srecode-compile-templates)
(define-key km "\C-c\C-m" #'srecode-macro-help)
(define-key km "/" #'srecode-self-insert-complete-end-macro)
km)
"Keymap used in srecode mode.")
@ -205,7 +205,7 @@ we can tell font lock about them.")
((?_ . "w") (?- . "w")))))
;;;###autoload
(defalias 'srt-mode 'srecode-template-mode)
(defalias 'srt-mode #'srecode-template-mode)
;;; Template Commands
;;
@ -436,7 +436,7 @@ Moves to the end of one named section."
(when point (goto-char (point)))
(let* ((tag (semantic-current-tag))
(args (semantic-tag-function-arguments tag))
(argsym (mapcar 'intern args))
(argsym (mapcar #'intern args))
(argvars nil)
;; Create a temporary dictionary in which the
;; arguments can be resolved so we can extract
@ -475,7 +475,7 @@ section or ? for an ask variable."
(ee (regexp-quote (srecode-template-get-escape-end)))
(start (point))
(macrostart nil)
(raw nil)
;; (raw nil)
)
(when (and tag (semantic-tag-of-class-p tag 'function)
(srecode-in-macro-p point)
@ -627,7 +627,7 @@ section or ? for an ask variable."
context-return)))
(define-mode-local-override semantic-analyze-possible-completions
srecode-template-mode (context &rest flags)
srecode-template-mode (context &rest _flags)
"Return a list of possible completions based on NONTEXT."
(with-current-buffer (oref context buffer)
(let* ((prefix (car (last (oref context prefix))))

8
lisp/cedet/srecode/srt.el
View file

@ -1,4 +1,4 @@
;;; srecode/srt.el --- argument handlers for SRT files
;;; srecode/srt.el --- argument handlers for SRT files -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@ -43,7 +43,7 @@ DEFAULT is the default if RET is hit."
(currfcn (semantic-current-tag))
)
(srecode-resolve-argument-list
(mapcar 'read
(mapcar #'read
(semantic-tag-get-attribute currfcn :arguments))
newdict)
@ -56,7 +56,7 @@ DEFAULT is the default if RET is hit."
(defvar srecode-read-major-mode-history nil
"History for `srecode-read-variable-name'.")
(defun srecode-read-major-mode-name (prompt &optional initial hist default)
(defun srecode-read-major-mode-name (prompt &optional initial hist _default)
"Read in the name of a desired `major-mode'.
PROMPT is the prompt to use.
INITIAL is the initial string.
@ -64,7 +64,7 @@ HIST is the history value, otherwise `srecode-read-variable-name-history'
is used.
DEFAULT is the default if RET is hit."
(completing-read prompt obarray
(lambda (s) (string-match "-mode$" (symbol-name s)))
(lambda (s) (string-match "-mode\\'" (symbol-name s)))
nil initial (or hist 'srecode-read-major-mode-history))
)

6
lisp/cedet/srecode/table.el
View file

@ -1,4 +1,4 @@
;;; srecode/table.el --- Tables of Semantic Recoders
;;; srecode/table.el --- Tables of Semantic Recoders -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
@ -169,7 +169,7 @@ calculate all inherited templates from parent modes."
:modetables nil
:tables nil)))
;; Save this new mode table in that mode's variable.
(eval `(setq-mode-local ,mode srecode-table ,new))
(eval `(setq-mode-local ,mode srecode-table ,new) t)
new))))
@ -184,7 +184,7 @@ INIT are the initialization parameters for the new template table."
(let* ((mt (srecode-make-mode-table mode))
(old (srecode-mode-table-find mt file))
(attr (file-attributes file))
(new (apply 'srecode-template-table
(new (apply #'srecode-template-table
(file-name-nondirectory file)
:file file
:filesize (file-attribute-size attr)

2
lisp/cedet/srecode/template.el
View file

@ -1,4 +1,4 @@
;;; srecode/template.el --- SRecoder template language parser support.
;;; srecode/template.el --- SRecoder template language parser support. -*- lexical-binding: t; -*-
;; Copyright (C) 2005, 2007-2021 Free Software Foundation, Inc.

4
lisp/cedet/srecode/texi.el
View file

@ -1,4 +1,4 @@
;;; srecode/texi.el --- Srecode texinfo support.
;;; srecode/texi.el --- Srecode texinfo support. -*- lexical-binding: t; -*-
;; Copyright (C) 2008-2021 Free Software Foundation, Inc.
@ -224,7 +224,7 @@ Takes a few very generic guesses as to what the formatting is."
;; Return our modified doc string.
docstring))
(defun srecode-texi-massage-to-texinfo (tag buffer string)
(defun srecode-texi-massage-to-texinfo (_tag buffer string)
"Massage TAG's documentation from BUFFER as STRING.
This is to take advantage of TeXinfo's markup symbols."
(save-excursion

2
lisp/cus-start.el
View file

@ -36,7 +36,7 @@
(defun minibuffer-prompt-properties--setter (symbol value)
(set-default symbol value)
(if (memq 'cursor-intangible value)
(add-hook 'minibuffer-setup-hook 'cursor-intangible-mode)
(add-hook 'minibuffer-setup-hook #'cursor-intangible-mode)
;; Removing it is a bit trickier since it could have been added by someone
;; else as well, so let's just not bother.
))

26
lisp/custom.el
View file

@ -1200,6 +1200,32 @@ property `theme-feature' (which is usually a symbol created by
(custom-check-theme theme)
(provide (get theme 'theme-feature)))
(defun require-theme (feature &optional noerror)
"Load FEATURE from a file along `custom-theme-load-path'.
This function is like `require', but searches along
`custom-theme-load-path' instead of `load-path'. It can be used
by Custom themes to load supporting Lisp files when `require' is
unsuitable.
If FEATURE is not already loaded, search for a file named FEATURE
with an added `.elc' or `.el' suffix, in that order, in the
directories specified by `custom-theme-load-path'.
Return FEATURE if the file is successfully found and loaded, or
if FEATURE was already loaded. If the file fails to load, signal
an error. If optional argument NOERROR is non-nil, return nil
instead of signaling an error. If the file loads but does not
provide FEATURE, signal an error. This cannot be suppressed."
(cond
((featurep feature) feature)
((let* ((path (custom-theme--load-path))
(file (locate-file (symbol-name feature) path '(".elc" ".el"))))
(and file (require feature (file-name-sans-extension file) noerror))))
((not noerror)
(signal 'file-missing `("Cannot open load file" "No such file or directory"
,(symbol-name feature))))))
(defcustom custom-safe-themes '(default)
"Themes that are considered safe to load.
If the value is a list, each element should be either the SHA-256

9
lisp/dired-aux.el
View file

@ -1072,8 +1072,13 @@ To kill an entire subdirectory \(without killing its line in the
parent directory), go to its directory header line and use this
command with a prefix argument (the value does not matter).
To undo the killing, the undo command can be used as normally."
;; Returns count of killed lines. FMT="" suppresses message.
To undo the killing, the undo command can be used as normally.
This function returns the number of killed lines.
FMT is a format string used for messaging the user about the
killed lines, and defaults to \"Killed %d line%s.\" if not
present. A FMT of \"\" will suppress the messaging."
(interactive "P")
(if arg
(if (dired-get-subdir)

2
lisp/dired-x.el
View file

@ -236,8 +236,6 @@ to nil: a pipe using `zcat' or `gunzip -c' will be used."
;;; MENU BINDINGS
(require 'easymenu)
(when-let ((menu (lookup-key dired-mode-map [menu-bar])))
(easy-menu-add-item menu '("Operate")
["Find Files" dired-do-find-marked-files

522
lisp/dired.el
View file

@ -1966,328 +1966,217 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST."
(define-key map ":s" 'epa-dired-do-sign)
(define-key map ":e" 'epa-dired-do-encrypt)
;; Make menu bar items.
;; No need to do this, now that top-level items are fewer.
;;;;
;; Get rid of the Edit menu bar item to save space.
;(define-key map [menu-bar edit] 'undefined)
(define-key map [menu-bar subdir]
(cons "Subdir" (make-sparse-keymap "Subdir")))
(define-key map [menu-bar subdir hide-all]
'(menu-item "Hide All" dired-hide-all
:help "Hide all subdirectories, leave only header lines"))
(define-key map [menu-bar subdir hide-subdir]
'(menu-item "Hide/UnHide Subdir" dired-hide-subdir
:help "Hide or unhide current directory listing"))
(define-key map [menu-bar subdir tree-down]
'(menu-item "Tree Down" dired-tree-down
:help "Go to first subdirectory header down the tree"))
(define-key map [menu-bar subdir tree-up]
'(menu-item "Tree Up" dired-tree-up
:help "Go to first subdirectory header up the tree"))
(define-key map [menu-bar subdir up]
'(menu-item "Up Directory" dired-up-directory
:help "Edit the parent directory"))
(define-key map [menu-bar subdir prev-subdir]
'(menu-item "Prev Subdir" dired-prev-subdir
:help "Go to previous subdirectory header line"))
(define-key map [menu-bar subdir next-subdir]
'(menu-item "Next Subdir" dired-next-subdir
:help "Go to next subdirectory header line"))
(define-key map [menu-bar subdir prev-dirline]
'(menu-item "Prev Dirline" dired-prev-dirline
:help "Move to next directory-file line"))
(define-key map [menu-bar subdir next-dirline]
'(menu-item "Next Dirline" dired-next-dirline
:help "Move to previous directory-file line"))
(define-key map [menu-bar subdir insert]
'(menu-item "Insert This Subdir" dired-maybe-insert-subdir
:help "Insert contents of subdirectory"
:enable (let ((f (dired-get-filename nil t)))
(and f (file-directory-p f)))))
(define-key map [menu-bar immediate]
(cons "Immediate" (make-sparse-keymap "Immediate")))
(define-key map
[menu-bar immediate image-dired-dired-display-external]
'(menu-item "Display Image Externally" image-dired-dired-display-external
:help "Display image in external viewer"))
(define-key map
[menu-bar immediate image-dired-dired-display-image]
'(menu-item "Display Image" image-dired-dired-display-image
:help "Display sized image in a separate window"))
(define-key map
[menu-bar immediate image-dired-dired-toggle-marked-thumbs]
'(menu-item "Toggle Image Thumbnails in This Buffer" image-dired-dired-toggle-marked-thumbs
:help "Add or remove image thumbnails in front of marked file names"))
(define-key map [menu-bar immediate hide-details]
'(menu-item "Hide Details" dired-hide-details-mode
:help "Hide details in buffer"
:button (:toggle . dired-hide-details-mode)))
(define-key map [menu-bar immediate revert-buffer]
'(menu-item "Refresh" revert-buffer
:help "Update contents of shown directories"))
(define-key map [menu-bar immediate dired-number-of-marked-files]
'(menu-item "#Marked Files" dired-number-of-marked-files
:help "Display the number and size of the marked files"))
(define-key map [menu-bar immediate dashes]
'("--"))
(define-key map [menu-bar immediate isearch-filenames-regexp]
'(menu-item "Isearch Regexp in File Names..." dired-isearch-filenames-regexp
:help "Incrementally search for regexp in file names only"))
(define-key map [menu-bar immediate isearch-filenames]
'(menu-item "Isearch in File Names..." dired-isearch-filenames
:help "Incrementally search for string in file names only."))
(define-key map [menu-bar immediate compare-directories]
'(menu-item "Compare Directories..." dired-compare-directories
:help "Mark files with different attributes in two Dired buffers"))
(define-key map [menu-bar immediate backup-diff]
'(menu-item "Compare with Backup" dired-backup-diff
:help "Diff file at cursor with its latest backup"))
(define-key map [menu-bar immediate diff]
'(menu-item "Diff..." dired-diff
:help "Compare file at cursor with another file"))
(define-key map [menu-bar immediate view]
'(menu-item "View This File" dired-view-file
:help "Examine file at cursor in read-only mode"))
(define-key map [menu-bar immediate display]
'(menu-item "Display in Other Window" dired-display-file
:help "Display file at cursor in other window"))
(define-key map [menu-bar immediate find-file-other-window]
'(menu-item "Find in Other Window" dired-find-file-other-window
:help "Edit file at cursor in other window"))
(define-key map [menu-bar immediate find-file]
'(menu-item "Find This File" dired-find-file
:help "Edit file at cursor"))
(define-key map [menu-bar immediate create-directory]
'(menu-item "Create Directory..." dired-create-directory
:help "Create a directory"))
(define-key map [menu-bar immediate create-empty-file]
'(menu-item "Create Empty file..." dired-create-empty-file
:help "Create an empty file"))
(define-key map [menu-bar immediate wdired-mode]
'(menu-item "Edit File Names" wdired-change-to-wdired-mode
:help "Put a Dired buffer in a mode in which filenames are editable"
:keys "C-x C-q"
:filter (lambda (x) (if (eq major-mode 'dired-mode) x))))
(define-key map [menu-bar regexp]
(cons "Regexp" (make-sparse-keymap "Regexp")))
(define-key map
[menu-bar regexp image-dired-mark-tagged-files]
'(menu-item "Mark From Image Tag..." image-dired-mark-tagged-files
:help "Mark files whose image tags matches regexp"))
(define-key map [menu-bar regexp dashes-1]
'("--"))
(define-key map [menu-bar regexp downcase]
'(menu-item "Downcase" dired-downcase
;; When running on plain MS-DOS, there's only one
;; letter-case for file names.
:enable (or (not (fboundp 'msdos-long-file-names))
(msdos-long-file-names))
:help "Rename marked files to lower-case name"))
(define-key map [menu-bar regexp upcase]
'(menu-item "Upcase" dired-upcase
:enable (or (not (fboundp 'msdos-long-file-names))
(msdos-long-file-names))
:help "Rename marked files to upper-case name"))
(define-key map [menu-bar regexp hardlink]
'(menu-item "Hardlink..." dired-do-hardlink-regexp
:help "Make hard links for files matching regexp"))
(define-key map [menu-bar regexp symlink]
'(menu-item "Symlink..." dired-do-symlink-regexp
:visible (fboundp 'make-symbolic-link)
:help "Make symbolic links for files matching regexp"))
(define-key map [menu-bar regexp rename]
'(menu-item "Rename..." dired-do-rename-regexp
:help "Rename marked files matching regexp"))
(define-key map [menu-bar regexp copy]
'(menu-item "Copy..." dired-do-copy-regexp
:help "Copy marked files matching regexp"))
(define-key map [menu-bar regexp flag]
'(menu-item "Flag..." dired-flag-files-regexp
:help "Flag files matching regexp for deletion"))
(define-key map [menu-bar regexp mark]
'(menu-item "Mark..." dired-mark-files-regexp
:help "Mark files matching regexp for future operations"))
(define-key map [menu-bar regexp mark-cont]
'(menu-item "Mark Containing..." dired-mark-files-containing-regexp
:help "Mark files whose contents matches regexp"))
(define-key map [menu-bar mark]
(cons "Mark" (make-sparse-keymap "Mark")))
(define-key map [menu-bar mark prev]
'(menu-item "Previous Marked" dired-prev-marked-file
:help "Move to previous marked file"))
(define-key map [menu-bar mark next]
'(menu-item "Next Marked" dired-next-marked-file
:help "Move to next marked file"))
(define-key map [menu-bar mark marks]
'(menu-item "Change Marks..." dired-change-marks
:help "Replace marker with another character"))
(define-key map [menu-bar mark unmark-all]
'(menu-item "Unmark All" dired-unmark-all-marks))
(define-key map [menu-bar mark symlinks]
'(menu-item "Mark Symlinks" dired-mark-symlinks
:visible (fboundp 'make-symbolic-link)
:help "Mark all symbolic links"))
(define-key map [menu-bar mark directories]
'(menu-item "Mark Directories" dired-mark-directories
:help "Mark all directories except `.' and `..'"))
(define-key map [menu-bar mark directory]
'(menu-item "Mark Old Backups" dired-clean-directory
:help "Flag old numbered backups for deletion"))
(define-key map [menu-bar mark executables]
'(menu-item "Mark Executables" dired-mark-executables
:help "Mark all executable files"))
(define-key map [menu-bar mark garbage-files]
'(menu-item "Flag Garbage Files" dired-flag-garbage-files
:help "Flag unneeded files for deletion"))
(define-key map [menu-bar mark backup-files]
'(menu-item "Flag Backup Files" dired-flag-backup-files
:help "Flag all backup files for deletion"))
(define-key map [menu-bar mark auto-save-files]
'(menu-item "Flag Auto-save Files" dired-flag-auto-save-files
:help "Flag auto-save files for deletion"))
(define-key map [menu-bar mark deletion]
'(menu-item "Flag" dired-flag-file-deletion
:help "Flag current line's file for deletion"))
(define-key map [menu-bar mark unmark]
'(menu-item "Unmark" dired-unmark
:help "Unmark or unflag current line's file"))
(define-key map [menu-bar mark mark]
'(menu-item "Mark" dired-mark
:help "Mark current line's file for future operations"))
(define-key map [menu-bar mark toggle-marks]
'(menu-item "Toggle Marks" dired-toggle-marks
:help "Mark unmarked files, unmark marked ones"))
(define-key map [menu-bar operate]
(cons "Operate" (make-sparse-keymap "Operate")))
(define-key map
[menu-bar operate image-dired-delete-tag]
'(menu-item "Delete Image Tag..." image-dired-delete-tag
:help "Delete image tag from current or marked files"))
(define-key map
[menu-bar operate image-dired-tag-files]
'(menu-item "Add Image Tags..." image-dired-tag-files
:help "Add image tags to current or marked files"))
(define-key map
[menu-bar operate image-dired-dired-comment-files]
'(menu-item "Add Image Comment..." image-dired-dired-comment-files
:help "Add image comment to current or marked files"))
(define-key map
[menu-bar operate image-dired-display-thumbs]
'(menu-item "Display Image Thumbnails" image-dired-display-thumbs
:help "Display image thumbnails for current or marked image files"))
(define-key map [menu-bar operate dashes-4]
'("--"))
(define-key map
[menu-bar operate epa-dired-do-decrypt]
'(menu-item "Decrypt..." epa-dired-do-decrypt
:help "Decrypt current or marked files"))
(define-key map
[menu-bar operate epa-dired-do-verify]
'(menu-item "Verify" epa-dired-do-verify
:help "Verify digital signature of current or marked files"))
(define-key map
[menu-bar operate epa-dired-do-sign]
'(menu-item "Sign..." epa-dired-do-sign
:help "Create digital signature of current or marked files"))
(define-key map
[menu-bar operate epa-dired-do-encrypt]
'(menu-item "Encrypt..." epa-dired-do-encrypt
:help "Encrypt current or marked files"))
(define-key map [menu-bar operate dashes-3]
'("--"))
(define-key map [menu-bar operate query-replace]
'(menu-item "Query Replace in Files..." dired-do-find-regexp-and-replace
:help "Replace regexp matches in marked files"))
(define-key map [menu-bar operate search]
'(menu-item "Search Files..." dired-do-find-regexp
:help "Search marked files for matches of regexp"))
(define-key map [menu-bar operate isearch-regexp]
'(menu-item "Isearch Regexp Files..." dired-do-isearch-regexp
:help "Incrementally search marked files for regexp"))
(define-key map [menu-bar operate isearch]
'(menu-item "Isearch Files..." dired-do-isearch
:help "Incrementally search marked files for string"))
(define-key map [menu-bar operate chown]
'(menu-item "Change Owner..." dired-do-chown
:visible (not (memq system-type '(ms-dos windows-nt)))
:help "Change the owner of marked files"))
(define-key map [menu-bar operate chgrp]
'(menu-item "Change Group..." dired-do-chgrp
:visible (not (memq system-type '(ms-dos windows-nt)))
:help "Change the group of marked files"))
(define-key map [menu-bar operate chmod]
'(menu-item "Change Mode..." dired-do-chmod
:help "Change mode (attributes) of marked files"))
(define-key map [menu-bar operate touch]
'(menu-item "Change Timestamp..." dired-do-touch
:help "Change timestamp of marked files"))
(define-key map [menu-bar operate load]
'(menu-item "Load" dired-do-load
:help "Load marked Emacs Lisp files"))
(define-key map [menu-bar operate compile]
'(menu-item "Byte-compile" dired-do-byte-compile
:help "Byte-compile marked Emacs Lisp files"))
(define-key map [menu-bar operate compress]
'(menu-item "Compress" dired-do-compress
:help "Compress/uncompress marked files"))
(define-key map [menu-bar operate print]
'(menu-item "Print..." dired-do-print
:help "Ask for print command and print marked files"))
(define-key map [menu-bar operate hardlink]
'(menu-item "Hardlink to..." dired-do-hardlink
:help "Make hard links for current or marked files"))
(define-key map [menu-bar operate symlink]
'(menu-item "Symlink to..." dired-do-symlink
:visible (fboundp 'make-symbolic-link)
:help "Make symbolic links for current or marked files"))
(define-key map [menu-bar operate async-command]
'(menu-item "Asynchronous Shell Command..." dired-do-async-shell-command
:help "Run a shell command asynchronously on current or marked files"))
(define-key map [menu-bar operate command]
'(menu-item "Shell Command..." dired-do-shell-command
:help "Run a shell command on current or marked files"))
(define-key map [menu-bar operate delete]
`(menu-item "Delete"
,(let ((menu (make-sparse-keymap "Delete")))
(define-key menu [delete-flagged]
'(menu-item "Delete Flagged Files" dired-do-flagged-delete
:help "Delete all files flagged for deletion (D)"))
(define-key menu [delete-marked]
'(menu-item "Delete Marked (Not Flagged) Files" dired-do-delete
:help "Delete current file or all marked files (excluding flagged files)"))
menu)))
(define-key map [menu-bar operate rename]
'(menu-item "Rename to..." dired-do-rename
:help "Rename current file or move marked files"))
(define-key map [menu-bar operate copy]
'(menu-item "Copy to..." dired-do-copy
:help "Copy current file or all marked files"))
map)
"Local keymap for Dired mode buffers.")
(easy-menu-define dired-mode-subdir-menu dired-mode-map
"Subdir menu for Dired mode."
'("Subdir"
["Insert This Subdir" dired-maybe-insert-subdir
:help "Insert contents of subdirectory"
:enable (let ((f (dired-get-filename nil t)))
(and f (file-directory-p f)))]
["Next Dirline" dired-next-dirline
:help "Move to previous directory-file line"]
["Prev Dirline" dired-prev-dirline
:help "Move to next directory-file line"]
["Next Subdir" dired-next-subdir
:help "Go to next subdirectory header line"]
["Prev Subdir" dired-prev-subdir
:help "Go to previous subdirectory header line"]
["Up Directory" dired-up-directory
:help "Edit the parent directory"]
["Tree Up" dired-tree-up
:help "Go to first subdirectory header up the tree"]
["Tree Down" dired-tree-down
:help "Go to first subdirectory header down the tree"]
["Hide/UnHide Subdir" dired-hide-subdir
:help "Hide or unhide current directory listing"]
["Hide All" dired-hide-all
:help "Hide all subdirectories, leave only header lines"]))
(easy-menu-define dired-mode-immediate-menu dired-mode-map
"Immediate menu for Dired mode."
'("Immediate"
["Edit File Names" wdired-change-to-wdired-mode
:help "Put a Dired buffer in a mode in which filenames are editable"
:keys "C-x C-q"
:filter (lambda (x) (if (eq major-mode 'dired-mode) x))]
["Create Empty file..." dired-create-empty-file
:help "Create an empty file"]
["Create Directory..." dired-create-directory
:help "Create a directory"]
["Find This File" dired-find-file
:help "Edit file at cursor"]
["Find in Other Window" dired-find-file-other-window
:help "Edit file at cursor in other window"]
["Display in Other Window" dired-display-file
:help "Display file at cursor in other window"]
["View This File" dired-view-file
:help "Examine file at cursor in read-only mode"]
["Diff..." dired-diff
:help "Compare file at cursor with another file"]
["Compare with Backup" dired-backup-diff
:help "Diff file at cursor with its latest backup"]
["Compare Directories..." dired-compare-directories
:help "Mark files with different attributes in two Dired buffers"]
["Isearch in File Names..." dired-isearch-filenames
:help "Incrementally search for string in file names only."]
["Isearch Regexp in File Names..." dired-isearch-filenames-regexp
:help "Incrementally search for regexp in file names only"]
"---"
["#Marked Files" dired-number-of-marked-files
:help "Display the number and size of the marked files"]
["Refresh" revert-buffer
:help "Update contents of shown directories"]
["Hide Details" dired-hide-details-mode
:help "Hide details in buffer"
:style toggle
:selected dired-hide-details-mode]
["Toggle Image Thumbnails in This Buffer" image-dired-dired-toggle-marked-thumbs
:help "Add or remove image thumbnails in front of marked file names"]
["Display Image" image-dired-dired-display-image
:help "Display sized image in a separate window"]
["Display Image Externally" image-dired-dired-display-external
:help "Display image in external viewer"]))
(easy-menu-define dired-mode-regexp-menu dired-mode-map
"Regexp menu for Dired mode."
'("Regexp"
["Mark Containing..." dired-mark-files-containing-regexp
:help "Mark files whose contents matches regexp"]
["Mark..." dired-mark-files-regexp
:help "Mark files matching regexp for future operations"]
["Flag..." dired-flag-files-regexp
:help "Flag files matching regexp for deletion"]
["Copy..." dired-do-copy-regexp
:help "Copy marked files matching regexp"]
["Rename..." dired-do-rename-regexp
:help "Rename marked files matching regexp"]
["Symlink..." dired-do-symlink-regexp
:visible (fboundp 'make-symbolic-link)
:help "Make symbolic links for files matching regexp"]
["Hardlink..." dired-do-hardlink-regexp
:help "Make hard links for files matching regexp"]
["Upcase" dired-upcase
:enable (or (not (fboundp 'msdos-long-file-names))
(msdos-long-file-names))
:help "Rename marked files to upper-case name"]
["Downcase" dired-downcase
;; When running on plain MS-DOS, there's only one
;; letter-case for file names.
:enable (or (not (fboundp 'msdos-long-file-names))
(msdos-long-file-names))
:help "Rename marked files to lower-case name"]
"---"
["Mark From Image Tag..." image-dired-mark-tagged-files
:help "Mark files whose image tags matches regexp"]))
(easy-menu-define dired-mode-mark-menu dired-mode-map
"Mark menu for Dired mode."
'("Mark"
["Toggle Marks" dired-toggle-marks
:help "Mark unmarked files, unmark marked ones"]
["Mark" dired-mark
:help "Mark current line's file for future operations"]
["Unmark" dired-unmark
:help "Unmark or unflag current line's file"]
["Flag" dired-flag-file-deletion
:help "Flag current line's file for deletion"]
["Flag Auto-save Files" dired-flag-auto-save-files
:help "Flag auto-save files for deletion"]
["Flag Backup Files" dired-flag-backup-files
:help "Flag all backup files for deletion"]
["Flag Garbage Files" dired-flag-garbage-files
:help "Flag unneeded files for deletion"]
["Mark Executables" dired-mark-executables
:help "Mark all executable files"]
["Mark Old Backups" dired-clean-directory
:help "Flag old numbered backups for deletion"]
["Mark Directories" dired-mark-directories
:help "Mark all directories except `.' and `..'"]
["Mark Symlinks" dired-mark-symlinks
:visible (fboundp 'make-symbolic-link)
:help "Mark all symbolic links"]
["Unmark All" dired-unmark-all-marks]
["Change Marks..." dired-change-marks
:help "Replace marker with another character"]
["Next Marked" dired-next-marked-file
:help "Move to next marked file"]
["Previous Marked" dired-prev-marked-file
:help "Move to previous marked file"]))
(easy-menu-define dired-mode-operate-menu dired-mode-map
"Operate menu for Dired mode."
'("Operate"
["Copy to..." dired-do-copy
:help "Copy current file or all marked files"]
["Rename to..." dired-do-rename
:help "Rename current file or move marked files"]
("Delete"
["Delete Flagged Files" dired-do-flagged-delete
:help "Delete all files flagged for deletion (D)"]
["Delete Marked (Not Flagged) Files" dired-do-delete
:help "Delete current file or all marked files (excluding flagged files)"])
["Shell Command..." dired-do-shell-command
:help "Run a shell command on current or marked files"]
["Asynchronous Shell Command..." dired-do-async-shell-command
:help "Run a shell command asynchronously on current or marked files"]
["Symlink to..." dired-do-symlink
:visible (fboundp 'make-symbolic-link)
:help "Make symbolic links for current or marked files"]
["Hardlink to..." dired-do-hardlink
:help "Make hard links for current or marked files"]
["Print..." dired-do-print
:help "Ask for print command and print marked files"]
["Compress" dired-do-compress
:help "Compress/uncompress marked files"]
["Byte-compile" dired-do-byte-compile
:help "Byte-compile marked Emacs Lisp files"]
["Load" dired-do-load
:help "Load marked Emacs Lisp files"]
["Change Timestamp..." dired-do-touch
:help "Change timestamp of marked files"]
["Change Mode..." dired-do-chmod
:help "Change mode (attributes) of marked files"]
["Change Group..." dired-do-chgrp
:visible (not (memq system-type '(ms-dos windows-nt)))
:help "Change the group of marked files"]
["Change Owner..." dired-do-chown
:visible (not (memq system-type '(ms-dos windows-nt)))
:help "Change the owner of marked files"]
["Isearch Files..." dired-do-isearch
:help "Incrementally search marked files for string"]
["Isearch Regexp Files..." dired-do-isearch-regexp
:help "Incrementally search marked files for regexp"]
["Search Files..." dired-do-find-regexp
:help "Search marked files for matches of regexp"]
["Query Replace in Files..." dired-do-find-regexp-and-replace
:help "Replace regexp matches in marked files"]
"---"
["Encrypt..." epa-dired-do-encrypt
:help "Encrypt current or marked files"]
["Sign..." epa-dired-do-sign
:help "Create digital signature of current or marked files"]
["Verify" epa-dired-do-verify
:help "Verify digital signature of current or marked files"]
["Decrypt..." epa-dired-do-decrypt
:help "Decrypt current or marked files"]
"---"
["Display Image Thumbnails" image-dired-display-thumbs
:help "Display image thumbnails for current or marked image files"]
["Add Image Comment..." image-dired-dired-comment-files
:help "Add image comment to current or marked files"]
["Add Image Tags..." image-dired-tag-files
:help "Add image tags to current or marked files"]
["Delete Image Tag..." image-dired-delete-tag
:help "Delete image tag from current or marked files"]))
;; Dired mode is suitable only for specially formatted data.
(put 'dired-mode 'mode-class 'special)
@ -4240,7 +4129,8 @@ Possible values:
* `as-is': Show full switches.
* Integer: Show only the first N chars of full switches.
* Function: Pass `dired-actual-switches' as arg and show result."
:group 'Dired-Plus
:group 'dired
:version "28.1"
:type '(choice
(const :tag "Indicate by name or date, else full" nil)
(const :tag "Show full switches" as-is)

704
lisp/emacs-lisp/bindat.el
View file

@ -62,39 +62,40 @@
;; struct data item[/* items */];
;; };
;;
;; The corresponding Lisp bindat specification looks like this:
;; The corresponding Lisp bindat specification could look like this:
;;
;; (bindat-defmacro ip () '(vec 4 byte))
;;
;; (setq header-bindat-spec
;; (bindat-spec
;; (bindat-type
;; (dest-ip ip)
;; (src-ip ip)
;; (dest-port u16)
;; (src-port u16)))
;; (dest-port uint 16)
;; (src-port uint 16)))
;;
;; (setq data-bindat-spec
;; (bindat-spec
;; (bindat-type
;; (type u8)
;; (opcode u8)
;; (length u32r) ;; little endian order
;; (length uintr 32) ;; little endian order
;; (id strz 8)
;; (data vec (length))
;; (align 4)))
;; (data vec length)
;; (_ align 4)))
;;
;; (setq packet-bindat-spec
;; (bindat-spec
;; (header struct header-bindat-spec)
;; (items u8)
;; (fill 3)
;; (item repeat (items)
;; (struct data-bindat-spec))))
;;
;; (bindat-type
;; (header type header-bindat-spec)
;; (nitems u8)
;; (_ fill 3)
;; (items repeat nitems type data-bindat-spec)))
;;
;; A binary data representation may look like
;; [ 192 168 1 100 192 168 1 101 01 28 21 32 2 0 0 0
;; 2 3 5 0 ?A ?B ?C ?D ?E ?F 0 0 1 2 3 4 5 0 0 0
;; 1 4 7 0 ?B ?C ?D ?E ?F ?G 0 0 6 7 8 9 10 11 12 0 ]
;;
;; The corresponding decoded structure looks like
;; The corresponding decoded structure returned by `bindat-unpack' (or taken
;; by `bindat-pack') looks like:
;;
;; ((header
;; (dest-ip . [192 168 1 100])
@ -114,94 +115,28 @@
;; (type . 1))))
;;
;; To access a specific value in this structure, use the function
;; bindat-get-field with the structure as first arg followed by a list
;; `bindat-get-field' with the structure as first arg followed by a list
;; of field names and array indexes, e.g. using the data above,
;; (bindat-get-field decoded-structure 'item 1 'id)
;; returns "BCDEFG".
;; Binary Data Structure Specification Format
;; ------------------------------------------
;; We recommend using names that end in `-bindat-spec'; such names
;; are recognized automatically as "risky" variables.
;; The data specification is formatted as follows:
;; SPEC ::= ( ITEM... )
;; ITEM ::= ( FIELD TYPE )
;; | ( [FIELD] eval FORM ) -- eval FORM for side-effect only
;; | ( [FIELD] fill LEN ) -- skip LEN bytes
;; | ( [FIELD] align LEN ) -- skip to next multiple of LEN bytes
;; | ( [FIELD] struct SPEC_NAME )
;; | ( [FIELD] union TAG_VAL (TAG SPEC)... [(t SPEC)] )
;; | ( FIELD repeat ARG ITEM... )
;; -- In (eval EXPR), the value of the last field is available in
;; the dynamically bound variable `last' and all the previous
;; ones in the variable `struct'.
;; TYPE ::= ( eval EXPR ) -- interpret result as TYPE
;; | u8 | byte -- length 1
;; | u16 | word | short -- length 2, network byte order
;; | u24 -- 3-byte value
;; | u32 | dword | long -- length 4, network byte order
;; | u64 -- length 8, network byte order
;; | u16r | u24r | u32r | u64r - little endian byte order.
;; | str LEN -- LEN byte string
;; | strz LEN -- LEN byte (zero-terminated) string
;; | vec LEN [TYPE] -- vector of LEN items of TYPE (default: u8)
;; | ip -- 4 byte vector
;; | bits LEN -- bit vector using LEN bytes.
;;
;; -- Example: `bits 2' will unpack 0x28 0x1c to (2 3 4 11 13)
;; and 0x1c 0x28 to (3 5 10 11 12).
;; FIELD ::= ( eval EXPR ) -- use result as NAME
;; | NAME
;; LEN ::= ARG
;; | <omitted> | nil -- LEN = 1
;; TAG_VAL ::= ARG
;; TAG ::= LISP_CONSTANT
;; | ( eval EXPR ) -- return non-nil if tag match;
;; current TAG_VAL in `tag'.
;; ARG ::= ( eval EXPR ) -- interpret result as ARG
;; | INTEGER_CONSTANT
;; | DEREF
;; DEREF ::= ( [NAME | INTEGER]... ) -- Field NAME or Array index relative
;; to current structure spec.
;; -- see bindat-get-field
;; A `union' specification
;; ([FIELD] union TAG_VAL (TAG SPEC) ... [(t SPEC)])
;; is interpreted by evalling TAG_VAL and then comparing that to
;; each TAG using equal; if a match is found, the corresponding SPEC
;; is used.
;; If TAG is a form (eval EXPR), EXPR is eval'ed with `tag' bound to the
;; value of TAG_VAL; the corresponding SPEC is used if the result is non-nil.
;; Finally, if TAG is t, the corresponding SPEC is used unconditionally.
;;
;; An `eval' specification
;; ([FIELD] eval FORM)
;; is interpreted by evalling FORM for its side effects only.
;; If FIELD is specified, the value is bound to that field.
;; The FORM may access and update `bindat-raw' and `bindat-idx' (see `bindat-unpack').
;;; Code:
;; Helper functions for structure unpacking.
;; Relies on dynamic binding of `bindat-raw' and `bindat-idx'.
(eval-when-compile (require 'cl-lib))
(eval-when-compile (require 'subr-x)) ;For `named-let'.
(cl-defstruct (bindat--type
(:predicate nil)
(:constructor bindat--make))
le ue pe)
(defvar bindat-raw)
(defvar bindat-idx)
(defun bindat--unpack-u8 ()
(defsubst bindat--unpack-u8 ()
(prog1
(aref bindat-raw bindat-idx)
(setq bindat-idx (1+ bindat-idx))))
@ -215,9 +150,6 @@
(defun bindat--unpack-u32 ()
(logior (ash (bindat--unpack-u16) 16) (bindat--unpack-u16)))
(defun bindat--unpack-u64 ()
(logior (ash (bindat--unpack-u32) 32) (bindat--unpack-u32)))
(defun bindat--unpack-u16r ()
(logior (bindat--unpack-u8) (ash (bindat--unpack-u8) 8)))
@ -227,50 +159,48 @@
(defun bindat--unpack-u32r ()
(logior (bindat--unpack-u16r) (ash (bindat--unpack-u16r) 16)))
(defun bindat--unpack-u64r ()
(logior (bindat--unpack-u32r) (ash (bindat--unpack-u32r) 32)))
(defun bindat--unpack-str (len)
(let ((s (substring bindat-raw bindat-idx (+ bindat-idx len))))
(setq bindat-idx (+ bindat-idx len))
(if (stringp s) s
(apply #'unibyte-string s))))
(defun bindat--unpack-strz (len)
(let ((i 0) s)
(while (and (< i len) (/= (aref bindat-raw (+ bindat-idx i)) 0))
(setq i (1+ i)))
(setq s (substring bindat-raw bindat-idx (+ bindat-idx i)))
(setq bindat-idx (+ bindat-idx len))
(if (stringp s) s
(apply #'unibyte-string s))))
(defun bindat--unpack-bits (len)
(let ((bits nil) (bnum (1- (* 8 len))) j m)
(while (>= bnum 0)
(if (= (setq m (bindat--unpack-u8)) 0)
(setq bnum (- bnum 8))
(setq j 128)
(while (> j 0)
(if (/= 0 (logand m j))
(setq bits (cons bnum bits)))
(setq bnum (1- bnum)
j (ash j -1)))))
bits))
(defun bindat--unpack-item (type len &optional vectype)
(if (eq type 'ip)
(setq type 'vec len 4))
(pcase type
((or 'u8 'byte)
(bindat--unpack-u8))
((or 'u16 'word 'short)
(bindat--unpack-u16))
((or 'u8 'byte) (bindat--unpack-u8))
((or 'u16 'word 'short) (bindat--unpack-u16))
('u24 (bindat--unpack-u24))
((or 'u32 'dword 'long)
(bindat--unpack-u32))
('u64 (bindat--unpack-u64))
((or 'u32 'dword 'long) (bindat--unpack-u32))
('u16r (bindat--unpack-u16r))
('u24r (bindat--unpack-u24r))
('u32r (bindat--unpack-u32r))
('u64r (bindat--unpack-u64r))
('bits
(let ((bits nil) (bnum (1- (* 8 len))) j m)
(while (>= bnum 0)
(if (= (setq m (bindat--unpack-u8)) 0)
(setq bnum (- bnum 8))
(setq j 128)
(while (> j 0)
(if (/= 0 (logand m j))
(setq bits (cons bnum bits)))
(setq bnum (1- bnum)
j (ash j -1)))))
bits))
('str
(let ((s (substring bindat-raw bindat-idx (+ bindat-idx len))))
(setq bindat-idx (+ bindat-idx len))
(if (stringp s) s
(apply #'unibyte-string s))))
('strz
(let ((i 0) s)
(while (and (< i len) (/= (aref bindat-raw (+ bindat-idx i)) 0))
(setq i (1+ i)))
(setq s (substring bindat-raw bindat-idx (+ bindat-idx i)))
(setq bindat-idx (+ bindat-idx len))
(if (stringp s) s
(apply #'unibyte-string s))))
('bits (bindat--unpack-bits len))
('str (bindat--unpack-str len))
('strz (bindat--unpack-strz len))
('vec
(let ((v (make-vector len 0)) (vlen 1))
(if (consp vectype)
@ -283,7 +213,15 @@
v))
(_ nil)))
(defsubst bindat--align (n len)
(* len (/ (+ n (1- len)) len))) ;Isn't there a simpler way?
(defun bindat--unpack-group (spec)
;; FIXME: Introduce a new primitive so we can mark `bindat-unpack'
;; as obsolete (maybe that primitive should be a macro which takes
;; a bindat type *expression* as argument).
(if (cl-typep spec 'bindat--type)
(funcall (bindat--type-ue spec))
(with-suppressed-warnings ((lexical struct last))
(defvar struct) (defvar last))
(let (struct last)
@ -317,8 +255,7 @@
('fill
(setq bindat-idx (+ bindat-idx len)))
('align
(while (/= (% bindat-idx len) 0)
(setq bindat-idx (1+ bindat-idx))))
(setq bindat-idx (bindat--align bindat-idx len)))
('struct
(setq data (bindat--unpack-group (eval len t))))
('repeat
@ -345,7 +282,7 @@
(setq struct (if field
(cons (cons field data) struct)
(append data struct))))))
struct))
struct)))
(defun bindat-unpack (spec raw &optional idx)
"Return structured data according to SPEC for binary data in RAW.
@ -366,9 +303,8 @@ An integer value in the field list is taken as an array index,
e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(while (and struct field)
(setq struct (if (integerp (car field))
(nth (car field) struct)
(let ((val (assq (car field) struct)))
(if (consp val) (cdr val)))))
(elt struct (car field))
(cdr (assq (car field) struct))))
(setq field (cdr field)))
struct)
@ -379,10 +315,11 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(u16 . 2) (u16r . 2) (word . 2) (short . 2)
(u24 . 3) (u24r . 3)
(u32 . 4) (u32r . 4) (dword . 4) (long . 4)
(u64 . 8) (u64r . 8)
(ip . 4)))
(defun bindat--length-group (struct spec)
(if (cl-typep spec 'bindat--type)
(funcall (bindat--type-le spec) struct)
(with-suppressed-warnings ((lexical struct last))
(defvar struct) (defvar last))
(let ((struct struct) last)
@ -421,8 +358,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
('fill
(setq bindat-idx (+ bindat-idx len)))
('align
(while (/= (% bindat-idx len) 0)
(setq bindat-idx (1+ bindat-idx))))
(setq bindat-idx (bindat--align bindat-idx len)))
('struct
(bindat--length-group
(if field (bindat-get-field struct field) struct) (eval len t)))
@ -449,7 +385,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(setq len (* len (cdr type))))
(if field
(setq last (bindat-get-field struct field)))
(setq bindat-idx (+ bindat-idx len))))))))
(setq bindat-idx (+ bindat-idx len)))))))))
(defun bindat-length (spec struct)
"Calculate `bindat-raw' length for STRUCT according to bindat SPEC."
@ -460,7 +396,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
;;;; Pack structured data into bindat-raw
(defun bindat--pack-u8 (v)
(defsubst bindat--pack-u8 (v)
(aset bindat-raw bindat-idx (logand v 255))
(setq bindat-idx (1+ bindat-idx)))
@ -498,42 +434,39 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(bindat--pack-u32r v)
(bindat--pack-u32r (ash v -32)))
(defun bindat--pack-str (len v)
(dotimes (i (min len (length v)))
(aset bindat-raw (+ bindat-idx i) (aref v i)))
(setq bindat-idx (+ bindat-idx len)))
(defun bindat--pack-bits (len v)
(let ((bnum (1- (* 8 len))) j m)
(while (>= bnum 0)
(setq m 0)
(if (null v)
(setq bnum (- bnum 8))
(setq j 128)
(while (> j 0)
(if (memq bnum v)
(setq m (logior m j)))
(setq bnum (1- bnum)
j (ash j -1))))
(bindat--pack-u8 m))))
(defun bindat--pack-item (v type len &optional vectype)
(if (eq type 'ip)
(setq type 'vec len 4))
(pcase type
((guard (null v))
(setq bindat-idx (+ bindat-idx len)))
((or 'u8 'byte)
(bindat--pack-u8 v))
((or 'u16 'word 'short)
(bindat--pack-u16 v))
('u24
(bindat--pack-u24 v))
((or 'u32 'dword 'long)
(bindat--pack-u32 v))
('u64 (bindat--pack-u64 v))
((guard (null v)) (setq bindat-idx (+ bindat-idx len)))
((or 'u8 'byte) (bindat--pack-u8 v))
((or 'u16 'word 'short) (bindat--pack-u16 v))
('u24 (bindat--pack-u24 v))
((or 'u32 'dword 'long) (bindat--pack-u32 v))
('u16r (bindat--pack-u16r v))
('u24r (bindat--pack-u24r v))
('u32r (bindat--pack-u32r v))
('u64r (bindat--pack-u64r v))
('bits
(let ((bnum (1- (* 8 len))) j m)
(while (>= bnum 0)
(setq m 0)
(if (null v)
(setq bnum (- bnum 8))
(setq j 128)
(while (> j 0)
(if (memq bnum v)
(setq m (logior m j)))
(setq bnum (1- bnum)
j (ash j -1))))
(bindat--pack-u8 m))))
((or 'str 'strz)
(dotimes (i (min len (length v)))
(aset bindat-raw (+ bindat-idx i) (aref v i)))
(setq bindat-idx (+ bindat-idx len)))
('bits (bindat--pack-bits len v))
((or 'str 'strz) (bindat--pack-str len v))
('vec
(let ((l (length v)) (vlen 1))
(if (consp vectype)
@ -548,6 +481,8 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(setq bindat-idx (+ bindat-idx len)))))
(defun bindat--pack-group (struct spec)
(if (cl-typep spec 'bindat--type)
(funcall (bindat--type-pe spec) struct)
(with-suppressed-warnings ((lexical struct last))
(defvar struct) (defvar last))
(let ((struct struct) last)
@ -580,8 +515,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
('fill
(setq bindat-idx (+ bindat-idx len)))
('align
(while (/= (% bindat-idx len) 0)
(setq bindat-idx (1+ bindat-idx))))
(setq bindat-idx (bindat--align bindat-idx len)))
('struct
(bindat--pack-group
(if field (bindat-get-field struct field) struct) (eval len t)))
@ -606,7 +540,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..."
(_
(setq last (bindat-get-field struct field))
(bindat--pack-item last type len vectype)
))))))
)))))))
(defun bindat-pack (spec struct &optional raw idx)
"Return binary data packed according to SPEC for structured data STRUCT.
@ -622,52 +556,6 @@ Optional fourth arg IDX is the starting offset into RAW."
(bindat--pack-group struct spec)
(if raw nil bindat-raw)))
;;;; Debugging support
(def-edebug-elem-spec 'bindat-spec '(&rest bindat-item))
(def-edebug-elem-spec 'bindat--item-aux
;; Field types which can come without a field label.
'(&or ["eval" form]
["fill" bindat-len]
["align" bindat-len]
["struct" form] ;A reference to another bindat-spec.
["union" bindat-tag-val &rest (bindat-tag bindat-spec)]))
(def-edebug-elem-spec 'bindat-item
'((&or bindat--item-aux ;Without label..
[bindat-field ;..or with label
&or bindat--item-aux
["repeat" bindat-arg bindat-spec]
bindat-type])))
(def-edebug-elem-spec 'bindat-type
'(&or ("eval" form)
["str" bindat-len]
["strz" bindat-len]
["vec" bindat-len &optional bindat-type]
["bits" bindat-len]
symbolp))
(def-edebug-elem-spec 'bindat-field
'(&or ("eval" form) symbolp))
(def-edebug-elem-spec 'bindat-len '(&or [] "nil" bindat-arg))
(def-edebug-elem-spec 'bindat-tag-val '(bindat-arg))
(def-edebug-elem-spec 'bindat-tag '(&or ("eval" form) atom))
(def-edebug-elem-spec 'bindat-arg
'(&or ("eval" form) integerp (&rest symbolp integerp)))
(defmacro bindat-spec (&rest fields)
"Build the bindat spec described by FIELDS."
(declare (indent 0) (debug (bindat-spec)))
;; FIXME: We should really "compile" this to a triplet of functions!
`',fields)
;;;; Misc. format conversions
(defun bindat-format-vector (vect fmt sep &optional len)
@ -696,6 +584,384 @@ The port (if any) is omitted. IP can be a string, as well."
(format "%d.%d.%d.%d"
(aref ip 0) (aref ip 1) (aref ip 2) (aref ip 3))))
;;;; New approach based on macro-expansion
;; Further improvements suggested by reading websocket.el:
;; - Support for bit-sized fields?
;;
;; - Add some way to verify redundant/checksum fields's contents without
;; having to provide a complete `:unpack-val' expression.
;; The `:pack-val' thingy can work nicely to compute checksum fields
;; based on previous fields's contents (without impacting or being impacted
;; by the unpacked representation), but if we want to verify
;; those checksums when unpacking, we have to use the :unpack-val
;; and build the whole object by hand instead of being able to focus
;; just on the checksum field.
;; Maybe this could be related to `unit' type fields where we might like
;; to make sure that the "value" we write into it is the same as the
;; value it holds (tho those checks don't happen at the same time (pack
;; vs unpack).
;;
;; - Support for packing/unpacking to/from something else than
;; a unibyte string, e.g. from a buffer. Problems to do that are:
;; - the `str' and `strz' types which use `substring' rather than reading
;; one byte at a time.
;; - the `align' and `fill' which just want to skip without reading/writing
;; - the `pack-uint' case, which would prefer writing the LSB first.
;; - the `align' case needs to now the current position in order to know
;; how far to advance
;;
;; - Don't write triple code when the type is only ever used at a single place
;; (e.g. to unpack).
(defun bindat--unpack-uint (bitlen)
(let ((v 0) (bitsdone 0))
(while (< bitsdone bitlen)
(setq v (logior (ash v 8) (bindat--unpack-u8)))
(setq bitsdone (+ bitsdone 8)))
v))
(defun bindat--unpack-uintr (bitlen)
(let ((v 0) (bitsdone 0))
(while (< bitsdone bitlen)
(setq v (logior v (ash (bindat--unpack-u8) bitsdone)))
(setq bitsdone (+ bitsdone 8)))
v))
(defun bindat--pack-uint (bitlen v)
(let* ((len (/ bitlen 8))
(shift (- (* 8 (1- len)))))
(dotimes (_ len)
(bindat--pack-u8 (logand 255 (ash v shift)))
(setq shift (+ 8 shift)))))
(defun bindat--pack-uintr (bitlen v)
(let* ((len (/ bitlen 8)))
(dotimes (_ len)
(bindat--pack-u8 (logand v 255))
(setq v (ash v -8)))))
(defmacro bindat--pcase (&rest args)
"Like `pcase' but optimize the code under the assumption that it's exhaustive."
(declare (indent 1) (debug pcase))
`(pcase ,@args (pcase--dontcare nil)))
(cl-defgeneric bindat--type (op head &rest args)
"Return the code for the operation OP of the Bindat type (HEAD . ARGS).
OP can be one of: unpack', (pack VAL), or (length VAL) where VAL
is the name of a variable that will hold the value we need to pack.")
(cl-defmethod bindat--type (op (_ (eql byte)))
(bindat--pcase op
('unpack `(bindat--unpack-u8))
(`(length . ,_) `(cl-incf bindat-idx 1))
(`(pack . ,args) `(bindat--pack-u8 . ,args))))
(cl-defmethod bindat--type (op (_ (eql uint)) n)
(if (eq n 8) (bindat--type op 'byte)
(bindat--pcase op
('unpack `(bindat--unpack-uint ,n))
(`(length . ,_) `(cl-incf bindat-idx (/ ,n 8)))
(`(pack . ,args) `(bindat--pack-uint ,n . ,args)))))
(cl-defmethod bindat--type (op (_ (eql uintr)) n)
(if (eq n 8) (bindat--type op 'byte)
(bindat--pcase op
('unpack `(bindat--unpack-uintr ,n))
(`(length . ,_) `(cl-incf bindat-idx (/ ,n 8)))
(`(pack . ,args) `(bindat--pack-uintr ,n . ,args)))))
(cl-defmethod bindat--type (op (_ (eql str)) len)
(bindat--pcase op
('unpack `(bindat--unpack-str ,len))
(`(length . ,_) `(cl-incf bindat-idx ,len))
(`(pack . ,args) `(bindat--pack-str ,len . ,args))))
(cl-defmethod bindat--type (op (_ (eql strz)) len)
(bindat--pcase op
('unpack `(bindat--unpack-strz ,len))
(`(length . ,_) `(cl-incf bindat-idx ,len))
;; Here we don't add the terminating zero because we rely
;; on the fact that `bindat-raw' was presumably initialized with
;; all-zeroes before we started.
(`(pack . ,args) `(bindat--pack-str ,len . ,args))))
(cl-defmethod bindat--type (op (_ (eql bits)) len)
(bindat--pcase op
('unpack `(bindat--unpack-bits ,len))
(`(length . ,_) `(cl-incf bindat-idx ,len))
(`(pack . ,args) `(bindat--pack-bits ,len . ,args))))
(cl-defmethod bindat--type (_op (_ (eql fill)) len)
`(progn (cl-incf bindat-idx ,len) nil))
(cl-defmethod bindat--type (_op (_ (eql align)) len)
`(progn (cl-callf bindat--align bindat-idx ,len) nil))
(cl-defmethod bindat--type (op (_ (eql type)) exp)
(bindat--pcase op
('unpack `(funcall (bindat--type-ue ,exp)))
(`(length . ,args) `(funcall (bindat--type-le ,exp) . ,args))
(`(pack . ,args) `(funcall (bindat--type-pe ,exp) . ,args))))
(cl-defmethod bindat--type (op (_ (eql vec)) count &rest type)
(unless type (setq type '(byte)))
(let ((fun (macroexpand-all (bindat--fun type) macroexpand-all-environment)))
(bindat--pcase op
('unpack
`(let* ((bindat--len ,count)
(bindat--v (make-vector bindat--len 0)))
(dotimes (bindat--i bindat--len)
(aset bindat--v bindat--i (funcall ,fun)))
bindat--v))
((and `(length . ,_)
;; FIXME: Improve the pattern match to recognize more complex
;; "constant" functions?
(let `#'(lambda (,val) (setq bindat-idx (+ bindat-idx ,len))) fun)
(guard (not (macroexp--fgrep `((,val)) len))))
;; Optimize the case where the size of each element is constant.
`(cl-incf bindat-idx (* ,count ,len)))
;; FIXME: It's tempting to use `(mapc (lambda (,val) ,exp) ,val)'
;; which would be more efficient when `val' is a list,
;; but that's only right if length of `val' is indeed `count'.
(`(,_ ,val)
`(dotimes (bindat--i ,count)
(funcall ,fun (elt ,val bindat--i)))))))
(cl-defmethod bindat--type (op (_ (eql unit)) val)
(pcase op ('unpack val) (_ nil)))
(cl-defmethod bindat--type (op (_ (eql struct)) &rest args)
(apply #'bindat--type op args))
(cl-defmethod bindat--type (op (_ (eql :pack-var)) var &rest fields)
(unless (consp (cdr fields))
(error "`:pack-var VAR' needs to be followed by fields"))
(bindat--pcase op
((or 'unpack (guard (null var)))
(apply #'bindat--type op fields))
(`(,_ ,val)
`(let ((,var ,val)) ,(apply #'bindat--type op fields)))))
(cl-defmethod bindat--type (op (field cons) &rest fields)
(named-let loop
((fields (cons field fields))
(labels ()))
(bindat--pcase fields
('nil
(bindat--pcase op
('unpack
(let ((exp ()))
(pcase-dolist (`(,label . ,labelvar) labels)
(setq exp
(if (eq label '_)
(if exp `(nconc ,labelvar ,exp) labelvar)
`(cons (cons ',label ,labelvar) ,exp))))
exp))
(_ nil)))
(`(:unpack-val ,exp)
;; Make it so `:kwd nil' is the same as the absence of the keyword arg.
(if exp (pcase op ('unpack exp)) (loop nil labels)))
(`((,label . ,type) . ,fields)
(let* ((get-field-val
(let ((tail (memq :pack-val type)))
;; FIXME: This `TYPE.. :pack EXP' syntax doesn't work well
;; when TYPE is a struct (a list of fields) or with extensions
;; such as allowing TYPE to be `if ...'.
(if tail
(prog1 (cadr tail)
(setq type (butlast type (length tail)))))))
(fieldvar (make-symbol (format "field%d" (length fields))))
(labelvar
(cond
((eq label '_) fieldvar)
((keywordp label)
(intern (substring (symbol-name label) 1)))
(t label)))
(field-fun (bindat--fun type))
(rest-exp (loop fields `((,label . ,labelvar) . ,labels))))
(bindat--pcase op
('unpack
(let ((code
`(let ((,labelvar (funcall ,field-fun)))
,rest-exp)))
(if (or (eq label '_) (not (assq label labels)))
code
(macroexp-warn-and-return
(format "Duplicate label: %S" label)
code))))
(`(,_ ,val)
;; `cdr-safe' is easier to optimize (can't signal an error).
`(let ((,fieldvar ,(or get-field-val
(if (eq label '_) val
`(cdr-safe (assq ',label ,val))))))
(funcall ,field-fun ,fieldvar)
,@(when rest-exp
`((let ,(unless (eq labelvar fieldvar)
`((,labelvar ,fieldvar)))
(ignore ,labelvar)
,rest-exp))))))))
(_ (error "Unrecognized format in bindat fields: %S" fields)))))
(def-edebug-elem-spec 'bindat-struct
'([&rest (symbolp bindat-type &optional ":pack-val" def-form)]
&optional ":unpack-val" def-form))
(def-edebug-elem-spec 'bindat-type
'(&or ["uint" def-form]
["uintr" def-form]
["str" def-form]
["strz" def-form]
["bits" def-form]
["fill" def-form]
["align" def-form]
["vec" def-form bindat-type]
["repeat" def-form bindat-type]
["type" def-form]
["struct" bindat-struct]
["unit" def-form]
[":pack-var" symbolp bindat-type]
symbolp ;; u8, u16, etc...
bindat-struct))
(defmacro bindat-type (&rest type)
"Return the Bindat type value to pack&unpack TYPE.
TYPE is a Bindat type expression. It can take the following forms:
uint BITLEN - Big-endian unsigned integer
uintr BITLEN - Little-endian unsigned integer
str LEN - Byte string
strz LEN - Zero-terminated byte-string
bits LEN - Bit vector (LEN is counted in bytes)
fill LEN - Just a filler
align LEN - Fill up to the next multiple of LEN bytes
vec COUNT TYPE - COUNT repetitions of TYPE
type EXP - Indirection; EXP should return a Bindat type value
unit EXP - 0-width type holding the value returned by EXP
struct FIELDS... - A composite type
When the context makes it clear, the symbol `struct' can be omitted.
A composite type is a list of FIELDS where each FIELD is of the form
(LABEL TYPE)
where LABEL can be `_' if the field should not deserve a name.
Composite types get normally packed/unpacked to/from alists, but this can be
controlled in the following way:
- If the list of fields ends with `:unpack-val EXP', then unpacking will
return the value of EXP (which has the previous fields in its scope).
- If a field's TYPE is followed by `:pack-val EXP', then the value placed
into this field will be that returned by EXP instead of looking up the alist.
- If the list of fields is preceded with `:pack-var VAR' then the object to
be packed is bound to VAR when evaluating the EXPs of `:pack-val'.
All the above BITLEN, LEN, COUNT, and EXP are ELisp expressions evaluated
in the current lexical context extended with the previous fields.
TYPE can additionally be one of the Bindat type macros defined with
`bindat-defmacro' (and listed below) or an ELisp expression which returns
a bindat type expression."
(declare (indent 0) (debug (bindat-type)))
`(progn
(defvar bindat-idx)
(bindat--make :ue ,(bindat--toplevel 'unpack type)
:le ,(bindat--toplevel 'length type)
:pe ,(bindat--toplevel 'pack type))))
(eval-and-compile
(defconst bindat--primitives '(byte uint uintr str strz bits fill align
struct type vec unit)))
(eval-and-compile
(defvar bindat--macroenv
(mapcar (lambda (s) (cons s (lambda (&rest args)
(bindat--makefun (cons s args)))))
bindat--primitives)))
(defmacro bindat-defmacro (name args &rest body)
"Define a new Bindat type as a macro."
(declare (indent 2) (doc-string 3) (debug (&define name sexp def-body)))
(let ((leaders ()))
(while (and (cdr body)
(or (stringp (car body))
(memq (car-safe (car body)) '(:documentation declare))))
(push (pop body) leaders))
;; FIXME: Add support for Edebug decls to those macros.
`(eval-and-compile ;; Yuck! But needed to define types where you use them!
(setf (alist-get ',name bindat--macroenv)
(lambda ,args ,@(nreverse leaders)
(bindat--fun ,(macroexp-progn body)))))))
(put 'bindat-type 'function-documentation '(bindat--make-docstring))
(defun bindat--make-docstring ()
;; Largely inspired from `pcase--make-docstring'.
(let* ((main (documentation (symbol-function 'bindat-type) 'raw))
(ud (help-split-fundoc main 'bindat-type)))
(require 'help-fns)
(declare-function help-fns--signature "help-fns")
(with-temp-buffer
(insert (or (cdr ud) main))
(pcase-dolist (`(,name . ,me) (reverse bindat--macroenv))
(unless (memq name bindat--primitives)
(let ((doc (documentation me 'raw)))
(insert "\n\n-- ")
(setq doc (help-fns--signature name doc me
(indirect-function me)
nil))
(insert "\n" (or doc "Not documented.")))))
(let ((combined-doc (buffer-string)))
(if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc)))))
(bindat-defmacro u8 () "Unsigned 8bit integer." '(byte))
(bindat-defmacro sint (bitlen r)
"Signed integer of size BITLEN.
Bigendian if R is nil and little endian if not."
(let ((bl (make-symbol "bitlen"))
(max (make-symbol "max"))
(wrap (make-symbol "wrap")))
`(let* ((,bl ,bitlen)
(,max (ash 1 (1- ,bl)))
(,wrap (+ ,max ,max)))
(struct :pack-var v
(n if ,r (uintr ,bl) (uint ,bl)
:pack-val (if (< v 0) (+ v ,wrap) v))
:unpack-val (if (>= n ,max) (- n ,wrap) n)))))
(bindat-defmacro repeat (count &rest type)
"Like `vec', but unpacks to a list rather than a vector."
`(:pack-var v
(v vec ,count ,@type :pack-val v)
:unpack-val (append v nil)))
(defvar bindat--op nil
"The operation we're currently building.
This is a simple symbol and can be one of: `unpack', `pack', or `length'.
This is used during macroexpansion of `bindat-type' so that the
macros know which code to generate.
FIXME: this is closely related and very similar to the `op' argument passed
to `bindat--type', yet it's annoyingly different.")
(defun bindat--fun (type)
(if (or (keywordp (car type)) (consp (car type))) (cons 'struct type)
type))
(defun bindat--makefun (type)
(let* ((v (make-symbol "v"))
(args (pcase bindat--op ('unpack ()) (_ (list v)))))
(pcase (apply #'bindat--type
(pcase bindat--op ('unpack 'unpack) (op `(,op . ,args)))
type)
(`(funcall ,f . ,(pred (equal args))) f) ;η-reduce.
(exp `(lambda ,args ,exp)))))
(defun bindat--toplevel (op type)
(let* ((bindat--op op)
(env `(,@bindat--macroenv
,@macroexpand-all-environment)))
(macroexpand-all (bindat--fun type) env)))
(provide 'bindat)
;;; bindat.el ends here

12
lisp/emacs-lisp/byte-opt.el
View file

@ -607,9 +607,12 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.")
(setq args (cddr args)))
(cons fn (nreverse var-expr-list))))
(`(defvar ,(and (pred symbolp) name) . ,_)
(push name byte-optimize--dynamic-vars)
form)
(`(defvar ,(and (pred symbolp) name) . ,rest)
(let ((optimized-rest (and rest
(cons (byte-optimize-form (car rest) nil)
(cdr rest)))))
(push name byte-optimize--dynamic-vars)
`(defvar ,name . ,optimized-rest)))
(`(,(pred byte-code-function-p) . ,exps)
(cons fn (mapcar #'byte-optimize-form exps)))
@ -1413,7 +1416,8 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.")
copysign isnan ldexp float logb
floor ceiling round truncate
ffloor fceiling fround ftruncate
string= string-equal string< string-lessp
string= string-equal string< string-lessp string> string-greaterp
string-empty-p string-blank-p string-prefix-p string-suffix-p
string-search
consp atom listp nlistp proper-list-p
sequencep arrayp vectorp stringp bool-vector-p hash-table-p

4
lisp/emacs-lisp/byte-run.el
View file

@ -253,7 +253,7 @@ The return value is undefined.
#'(lambda (x)
(let ((f (cdr (assq (car x) macro-declarations-alist))))
(if f (apply (car f) name arglist (cdr x))
(macroexp--warn-and-return
(macroexp-warn-and-return
(format-message
"Unknown macro property %S in %S"
(car x) name)
@ -326,7 +326,7 @@ The return value is undefined.
body)))
nil)
(t
(macroexp--warn-and-return
(macroexp-warn-and-return
(format-message "Unknown defun property `%S' in %S"
(car x) name)
nil)))))

54
lisp/emacs-lisp/bytecomp.el
View file

@ -2497,8 +2497,6 @@ list that represents a doc string reference.
byte-compile-output nil
byte-compile-jump-tables nil))))
(defvar byte-compile-force-lexical-warnings nil)
(defun byte-compile-preprocess (form &optional _for-effect)
(setq form (macroexpand-all form byte-compile-macro-environment))
;; FIXME: We should run byte-optimize-form here, but it currently does not
@ -2509,7 +2507,6 @@ list that represents a doc string reference.
;; (setq form (byte-optimize-form form for-effect)))
(cond
(lexical-binding (cconv-closure-convert form))
(byte-compile-force-lexical-warnings (cconv-warnings-only form))
(t form)))
;; byte-hunk-handlers cannot call this!
@ -2872,16 +2869,12 @@ FUN should be either a `lambda' value or a `closure' value."
(dolist (binding env)
(cond
((consp binding)
;; We check shadowing by the args, so that the `let' can be moved
;; within the lambda, which can then be unfolded. FIXME: Some of those
;; bindings might be unused in `body'.
(unless (memq (car binding) args) ;Shadowed.
(push `(,(car binding) ',(cdr binding)) renv)))
(push `(,(car binding) ',(cdr binding)) renv))
((eq binding t))
(t (push `(defvar ,binding) body))))
(if (null renv)
`(lambda ,args ,@preamble ,@body)
`(lambda ,args ,@preamble (let ,(nreverse renv) ,@body)))))
`(let ,renv (lambda ,args ,@preamble ,@body)))))
;;;###autoload
(defun byte-compile (form)
@ -2906,23 +2899,27 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(if (symbolp form) form "provided"))
fun)
(t
(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)))
;; 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 macro (push 'macro fun))
(if (symbolp form) (fset form fun))
fun))))))
(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)))))))
(defun byte-compile-sexp (sexp)
"Compile and return SEXP."
@ -5319,8 +5316,9 @@ already up-to-date."
"Reload any Lisp file that was changed since Emacs was dumped.
Use with caution."
(let* ((argv0 (car command-line-args))
(emacs-file (executable-find argv0)))
(if (not (and emacs-file (file-executable-p emacs-file)))
(emacs-file (or (cdr (nth 2 (pdumper-stats)))
(executable-find argv0))))
(if (not (and emacs-file (file-exists-p emacs-file)))
(message "Can't find %s to refresh preloaded Lisp files" argv0)
(dolist (f (reverse load-history))
(setq f (car f))

209
lisp/emacs-lisp/cconv.el
View file

@ -121,19 +121,22 @@
(defconst cconv-liftwhen 6
"Try to do lambda lifting if the number of arguments + free variables
is less than this number.")
;; List of all the variables that are both captured by a closure
;; and mutated. Each entry in the list takes the form
;; (BINDER . PARENTFORM) where BINDER is the (VAR VAL) that introduces the
;; variable (or is just (VAR) for variables not introduced by let).
(defvar cconv-captured+mutated)
(defvar cconv-var-classification
;; Alist mapping variables to a given class.
;; The keys are of the form (BINDER . PARENTFORM) where BINDER
;; is the (VAR VAL) that introduces it (or is just (VAR) for variables
;; not introduced by let).
;; The class can be one of:
;; - :unused
;; - :lambda-candidate
;; - :captured+mutated
;; - nil for "normal" variables, which would then just not appear
;; in the alist at all.
)
;; List of candidates for lambda lifting.
;; Each candidate has the form (BINDER . PARENTFORM). A candidate
;; is a variable that is only passed to `funcall' or `apply'.
(defvar cconv-lambda-candidates)
;; Alist associating to each function body the list of its free variables.
(defvar cconv-freevars-alist)
(defvar cconv-freevars-alist
;; Alist associating to each function body the list of its free variables.
)
;;;###autoload
(defun cconv-closure-convert (form)
@ -144,25 +147,13 @@ is less than this number.")
Returns a form where all lambdas don't have any free variables."
;; (message "Entering cconv-closure-convert...")
(let ((cconv-freevars-alist '())
(cconv-lambda-candidates '())
(cconv-captured+mutated '()))
(cconv-var-classification '()))
;; Analyze form - fill these variables with new information.
(cconv-analyze-form form '())
(setq cconv-freevars-alist (nreverse cconv-freevars-alist))
(prog1 (cconv-convert form nil nil) ; Env initially empty.
(cl-assert (null cconv-freevars-alist)))))
;;;###autoload
(defun cconv-warnings-only (form)
"Add the warnings that closure conversion would encounter."
(let ((cconv-freevars-alist '())
(cconv-lambda-candidates '())
(cconv-captured+mutated '()))
;; Analyze form - fill these variables with new information.
(cconv-analyze-form form '())
;; But don't perform the closure conversion.
form))
(defconst cconv--dummy-var (make-symbol "ignored"))
(defun cconv--set-diff (s1 s2)
@ -261,28 +252,55 @@ Returns a form where all lambdas don't have any free variables."
(nthcdr 3 mapping)))))
new-env))
(defun cconv--warn-unused-msg (var varkind)
(unless (or ;; Uninterned symbols typically come from macro-expansion, so
;; it is often non-trivial for the programmer to avoid such
;; unused vars.
(not (intern-soft var))
(eq ?_ (aref (symbol-name var) 0))
;; As a special exception, ignore "ignore".
(eq var 'ignored))
(let ((suggestions (help-uni-confusable-suggestions (symbol-name var))))
(format "Unused lexical %s `%S'%s"
varkind var
(if suggestions (concat "\n " suggestions) "")))))
(define-inline cconv--var-classification (binder form)
(inline-quote
(alist-get (cons ,binder ,form) cconv-var-classification
nil nil #'equal)))
(defun cconv--convert-funcbody (funargs funcbody env parentform)
"Run `cconv-convert' on FUNCBODY, the forms of a lambda expression.
PARENTFORM is the form containing the lambda expression. ENV is a
lexical environment (same format as for `cconv-convert'), not
including FUNARGS, the function's argument list. Return a list
of converted forms."
(let ((letbind ()))
(let ((wrappers ()))
(dolist (arg funargs)
(if (not (member (cons (list arg) parentform) cconv-captured+mutated))
(if (assq arg env) (push `(,arg . nil) env))
(push `(,arg . (car-safe ,arg)) env)
(push `(,arg (list ,arg)) letbind)))
(pcase (cconv--var-classification (list arg) parentform)
(:captured+mutated
(push `(,arg . (car-safe ,arg)) env)
(push (lambda (body) `(let ((,arg (list ,arg))) ,body)) wrappers))
((and :unused
(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 msg body)) wrappers))
(_
(if (assq arg env) (push `(,arg . nil) env)))))
(setq funcbody (mapcar (lambda (form)
(cconv-convert form env nil))
funcbody))
(if letbind
(if wrappers
(let ((special-forms '()))
;; Keep special forms at the beginning of the body.
(while (or (stringp (car funcbody)) ;docstring.
(memq (car-safe (car funcbody)) '(interactive declare)))
(push (pop funcbody) special-forms))
`(,@(nreverse special-forms) (let ,letbind . ,funcbody)))
(let ((body (macroexp-progn funcbody)))
(dolist (wrapper wrappers) (setq body (funcall wrapper body)))
`(,@(nreverse special-forms) ,@(macroexp-unprogn body))))
funcbody)))
(defun cconv-convert (form env extend)
@ -340,46 +358,58 @@ places where they originally did not directly appear."
(setq value (cadr binder))
(car binder)))
(new-val
(cond
;; Check if var is a candidate for lambda lifting.
((and (member (cons binder form) cconv-lambda-candidates)
(progn
(cl-assert (and (eq (car value) 'function)
(eq (car (cadr value)) 'lambda)))
(cl-assert (equal (cddr (cadr value))
(caar cconv-freevars-alist)))
;; Peek at the freevars to decide whether to λ-lift.
(let* ((fvs (cdr (car cconv-freevars-alist)))
(fun (cadr value))
(funargs (cadr fun))
(funcvars (append fvs funargs)))
(pcase (cconv--var-classification binder form)
;; Check if var is a candidate for lambda lifting.
((and :lambda-candidate
(guard
(progn
(cl-assert (and (eq (car value) 'function)
(eq (car (cadr value)) 'lambda)))
(cl-assert (equal (cddr (cadr value))
(caar cconv-freevars-alist)))
;; Peek at the freevars to decide whether to λ-lift.
(let* ((fvs (cdr (car cconv-freevars-alist)))
(fun (cadr value))
(funargs (cadr fun))
(funcvars (append fvs funargs)))
; lambda lifting condition
(and fvs (>= cconv-liftwhen (length funcvars))))))
(and fvs (>= cconv-liftwhen
(length funcvars)))))))
; Lift.
(let* ((fvs (cdr (pop cconv-freevars-alist)))
(fun (cadr value))
(funargs (cadr fun))
(funcvars (append fvs funargs))
(funcbody (cddr fun))
(funcbody-env ()))
(push `(,var . (apply-partially ,var . ,fvs)) new-env)
(dolist (fv fvs)
(cl-pushnew fv new-extend)
(if (and (eq 'car-safe (car-safe (cdr (assq fv env))))
(not (memq fv funargs)))
(push `(,fv . (car-safe ,fv)) funcbody-env)))
`(function (lambda ,funcvars .
,(cconv--convert-funcbody
funargs funcbody funcbody-env value)))))
(let* ((fvs (cdr (pop cconv-freevars-alist)))
(fun (cadr value))
(funargs (cadr fun))
(funcvars (append fvs funargs))
(funcbody (cddr fun))
(funcbody-env ()))
(push `(,var . (apply-partially ,var . ,fvs)) new-env)
(dolist (fv fvs)
(cl-pushnew fv new-extend)
(if (and (eq 'car-safe (car-safe (cdr (assq fv env))))
(not (memq fv funargs)))
(push `(,fv . (car-safe ,fv)) funcbody-env)))
`(function (lambda ,funcvars .
,(cconv--convert-funcbody
funargs funcbody funcbody-env value)))))
;; Check if it needs to be turned into a "ref-cell".
((member (cons binder form) cconv-captured+mutated)
(:captured+mutated
;; Declared variable is mutated and captured.
(push `(,var . (car-safe ,var)) new-env)
`(list ,(cconv-convert value env extend)))
;; Check if it needs to be turned into a "ref-cell".
(:unused
;; Declared variable is unused.
(if (assq var new-env) (push `(,var) new-env)) ;FIXME:Needed?
(let ((newval
`(ignore ,(cconv-convert value env extend)))
(msg (cconv--warn-unused-msg var "variable")))
(if (null msg) newval
(macroexp--warn-wrap msg newval))))
;; Normal default case.
(t
(_
(if (assq var new-env) (push `(,var) new-env))
(cconv-convert value env extend)))))
@ -464,22 +494,28 @@ places where they originally did not directly appear."
; condition-case
(`(condition-case ,var ,protected-form . ,handlers)
`(condition-case ,var
,(cconv-convert protected-form env extend)
,@(let* ((cm (and var (member (cons (list var) form)
cconv-captured+mutated)))
(newenv
(cond (cm (cons `(,var . (car-save ,var)) env))
((assq var env) (cons `(,var) env))
(t env))))
(mapcar
(let* ((class (and var (cconv--var-classification (list var) form)))
(newenv
(cond ((eq class :captured+mutated)
(cons `(,var . (car-save ,var)) env))
((assq var env) (cons `(,var) env))
(t env)))
(msg (when (eq class :unused)
(cconv--warn-unused-msg var "variable")))
(newprotform (cconv-convert protected-form env extend)))
`(condition-case ,var
,(if msg
(macroexp--warn-wrap msg newprotform)
newprotform)
,@(mapcar
(lambda (handler)
`(,(car handler)
,@(let ((body
(mapcar (lambda (form)
(cconv-convert form newenv extend))
(cdr handler))))
(if (not cm) body
(if (not (eq class :captured+mutated))
body
`((let ((,var (list ,var))) ,@body))))))
handlers))))
@ -563,29 +599,21 @@ FORM is the parent form that binds this var."
(`(,_ nil nil nil nil) nil)
(`((,(and var (guard (eq ?_ (aref (symbol-name var) 0)))) . ,_)
,_ ,_ ,_ ,_)
;; FIXME: Convert this warning to use `macroexp--warn-wrap'
;; so as to give better position information.
(byte-compile-warn
"%s `%S' not left unused" varkind var)))
(pcase vardata
(`((,var . ,_) nil ,_ ,_ nil)
;; FIXME: This gives warnings in the wrong order, with imprecise line
;; numbers and without function name info.
(unless (or ;; Uninterned symbols typically come from macro-expansion, so
;; it is often non-trivial for the programmer to avoid such
;; unused vars.
(not (intern-soft var))
(eq ?_ (aref (symbol-name var) 0))
;; As a special exception, ignore "ignore".
(eq var 'ignored))
(let ((suggestions (help-uni-confusable-suggestions (symbol-name var))))
(byte-compile-warn "Unused lexical %s `%S'%s"
varkind var
(if suggestions (concat "\n " suggestions) "")))))
(`(,binder nil ,_ ,_ nil)
(push (cons (cons binder form) :unused) cconv-var-classification))
;; If it's unused, there's no point converting it into a cons-cell, even if
;; it's captured and mutated.
(`(,binder ,_ t t ,_)
(push (cons binder form) cconv-captured+mutated))
(push (cons (cons binder form) :captured+mutated)
cconv-var-classification))
(`(,(and binder `(,_ (function (lambda . ,_)))) nil nil nil t)
(push (cons binder form) cconv-lambda-candidates))))
(push (cons (cons binder form) :lambda-candidate)
cconv-var-classification))))
(defun cconv--analyze-function (args body env parentform)
(let* ((newvars nil)
@ -638,8 +666,7 @@ Analyze lambdas if they are suitable for lambda lifting.
- ENV is an alist mapping each enclosing lexical variable to its info.
I.e. each element has the form (VAR . (READ MUTATED CAPTURED CALLED)).
This function does not return anything but instead fills the
`cconv-captured+mutated' and `cconv-lambda-candidates' variables
and updates the data stored in ENV."
`cconv-var-classification' variable and updates the data stored in ENV."
(pcase form
; let special form
(`(,(and (or 'let* 'let) letsym) ,binders . ,body-forms)

21
lisp/emacs-lisp/checkdoc.el
View file

@ -932,7 +932,7 @@ don't move point."
;; definition ends prematurely.
(end-of-file)))
(`(,(or 'defun 'defvar 'defcustom 'defmacro 'defconst 'defsubst 'defadvice
'cl-defun 'cl-defgeneric 'cl-defmethod 'cl-defmacro)
'cl-defun 'cl-defgeneric 'cl-defmacro)
,(pred symbolp)
;; Require an initializer, i.e. ignore single-argument `defvar'
;; forms, which never have a doc string.
@ -942,6 +942,25 @@ don't move point."
;; initializer or argument list.
(forward-sexp 3)
(skip-chars-forward " \n\t")
t)
(`(,'cl-defmethod
,(pred symbolp)
. ,rest)
(down-list)
(forward-sexp (pcase (car rest)
;; No qualifier, so skip like we would have skipped in
;; the first clause of the outer `pcase'.
((pred listp) 3)
(':extra
;; Skip the :extra qualifier together with its string too.
;; Skip any additional qualifier.
(if (memq (nth 2 rest) '(:around :before :after))
6
5))
;; Skip :before, :after or :around qualifier too.
((or ':around ':before ':after)
4)))
(skip-chars-forward " \n\t")
t)))
;;;###autoload

23
lisp/emacs-lisp/cl-extra.el
View file

@ -94,7 +94,7 @@ strings case-insensitively."
(defun cl--mapcar-many (cl-func cl-seqs &optional acc)
(if (cdr (cdr cl-seqs))
(let* ((cl-res nil)
(cl-n (apply 'min (mapcar 'length cl-seqs)))
(cl-n (apply #'min (mapcar #'length cl-seqs)))
(cl-i 0)
(cl-args (copy-sequence cl-seqs))
cl-p1 cl-p2)
@ -131,7 +131,7 @@ strings case-insensitively."
"Map a FUNCTION across one or more SEQUENCEs, returning a sequence.
TYPE is the sequence type to return.
\n(fn TYPE FUNCTION SEQUENCE...)"
(let ((cl-res (apply 'cl-mapcar cl-func cl-seq cl-rest)))
(let ((cl-res (apply #'cl-mapcar cl-func cl-seq cl-rest)))
(and cl-type (cl-coerce cl-res cl-type))))
;;;###autoload
@ -190,14 +190,14 @@ the elements themselves.
"Like `cl-mapcar', but nconc's together the values returned by the function.
\n(fn FUNCTION SEQUENCE...)"
(if cl-rest
(apply 'nconc (apply 'cl-mapcar cl-func cl-seq cl-rest))
(apply #'nconc (apply #'cl-mapcar cl-func cl-seq cl-rest))
(mapcan cl-func cl-seq)))
;;;###autoload
(defun cl-mapcon (cl-func cl-list &rest cl-rest)
"Like `cl-maplist', but nconc's together the values returned by the function.
\n(fn FUNCTION LIST...)"
(apply 'nconc (apply 'cl-maplist cl-func cl-list cl-rest)))
(apply #'nconc (apply #'cl-maplist cl-func cl-list cl-rest)))
;;;###autoload
(defun cl-some (cl-pred cl-seq &rest cl-rest)
@ -236,13 +236,13 @@ non-nil value.
(defun cl-notany (cl-pred cl-seq &rest cl-rest)
"Return true if PREDICATE is false of every element of SEQ or SEQs.
\n(fn PREDICATE SEQ...)"
(not (apply 'cl-some cl-pred cl-seq cl-rest)))
(not (apply #'cl-some cl-pred cl-seq cl-rest)))
;;;###autoload
(defun cl-notevery (cl-pred cl-seq &rest cl-rest)
"Return true if PREDICATE is false of some element of SEQ or SEQs.
\n(fn PREDICATE SEQ...)"
(not (apply 'cl-every cl-pred cl-seq cl-rest)))
(not (apply #'cl-every cl-pred cl-seq cl-rest)))
;;;###autoload
(defun cl--map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
@ -693,12 +693,11 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
"Expand macros in FORM and insert the pretty-printed result."
(declare (advertised-calling-convention (form) "27.1"))
(message "Expanding...")
(let ((byte-compile-macro-environment nil))
(setq form (macroexpand-all form))
(message "Formatting...")
(prog1
(cl-prettyprint form)
(message ""))))
(setq form (macroexpand-all form))
(message "Formatting...")
(prog1
(cl-prettyprint form)
(message "")))
;;; Integration into the online help system.

24
lisp/emacs-lisp/cl-generic.el
View file

@ -425,6 +425,16 @@ the specializer used will be the one returned by BODY."
(defun cl-generic--method-qualifier-p (x)
(not (listp x)))
(defun cl--defmethod-doc-pos ()
"Return the index of the docstring for a `cl-defmethod'.
Presumes point is at the end of the `cl-defmethod' symbol."
(save-excursion
(let ((n 2))
(while (and (ignore-errors (forward-sexp 1) t)
(not (eq (char-before) ?\))))
(cl-incf n))
n)))
;;;###autoload
(defmacro cl-defmethod (name args &rest body)
"Define a new method for generic function NAME.
@ -445,8 +455,12 @@ all methods of NAME have to use the same set of arguments for dispatch.
Each dispatch argument and TYPE are specified in ARGS where the corresponding
formal argument appears as (VAR TYPE) rather than just VAR.
The optional second argument QUALIFIER is a specifier that
modifies how the method is combined with other methods, including:
The optional EXTRA element, on the form `:extra STRING', allows
you to add more methods for the same specializers and qualifiers.
These are distinguished by STRING.
The optional argument QUALIFIER is a specifier that modifies how
the method is combined with other methods, including:
:before - Method will be called before the primary
:after - Method will be called after the primary
:around - Method will be called around everything else
@ -463,8 +477,8 @@ method to be applicable.
The set of acceptable TYPEs (also called \"specializers\") is defined
\(and can be extended) by the various methods of `cl-generic-generalizers'.
\(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)"
(declare (doc-string 3) (indent defun)
\(fn NAME [EXTRA] [QUALIFIER] ARGS &rest [DOCSTRING] BODY)"
(declare (doc-string cl--defmethod-doc-pos) (indent defun)
(debug
(&define ; this means we are defining something
[&name [sexp ;Allow (setf ...) additionally to symbols.
@ -487,7 +501,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
(or (not (fboundp 'byte-compile-warning-enabled-p))
(byte-compile-warning-enabled-p 'obsolete name))
(let* ((obsolete (get name 'byte-obsolete-info)))
(macroexp--warn-and-return
(macroexp-warn-and-return
(macroexp--obsolete-warning name obsolete "generic function")
nil)))
;; You could argue that `defmethod' modifies rather than defines the

19
lisp/emacs-lisp/cl-macs.el
View file

@ -565,7 +565,7 @@ its argument list allows full Common Lisp conventions."
,(length (cl-ldiff args p)))
exactarg (not (eq args p)))))
(while (and args (not (memq (car args) cl--lambda-list-keywords)))
(let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car)
(let ((poparg (list (if (or (cdr args) (not exactarg)) 'pop 'car-safe)
restarg)))
(cl--do-arglist
(pop args)
@ -723,7 +723,7 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level.
(defun cl--compile-time-too (form)
(or (and (symbolp (car-safe form)) (get (car-safe form) 'byte-hunk-handler))
(setq form (macroexpand
form (cons '(cl-eval-when) byte-compile-macro-environment))))
form (cons '(cl-eval-when) macroexpand-all-environment))))
(cond ((eq (car-safe form) 'progn)
(cons 'progn (mapcar #'cl--compile-time-too (cdr form))))
((eq (car-safe form) 'cl-eval-when)
@ -2298,7 +2298,7 @@ of `cl-symbol-macrolet' to additionally expand symbol macros."
;; The behavior of CL made sense in a dynamically scoped
;; language, but nowadays, lexical scoping semantics is more often
;; expected.
(`(,(or 'let 'let*) . ,(or `(,bindings . ,body) dontcare))
(`(,(or 'let 'let*) . ,(or `(,bindings . ,body) pcase--dontcare))
(let ((nbs ()) (found nil))
(dolist (binding bindings)
(let* ((var (if (symbolp binding) binding (car binding)))
@ -2393,7 +2393,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
(append bindings venv))
macroexpand-all-environment))))
(if malformed-bindings
(macroexp--warn-and-return
(macroexp-warn-and-return
(format-message "Malformed `cl-symbol-macrolet' binding(s): %S"
(nreverse malformed-bindings))
expansion)
@ -2511,12 +2511,12 @@ Example:
'(nil byte-compile-inline-expand))
(error "%s already has a byte-optimizer, can't make it inline"
(car spec)))
(put (car spec) 'byte-optimizer 'byte-compile-inline-expand)))
(put (car spec) 'byte-optimizer #'byte-compile-inline-expand)))
((eq (car-safe spec) 'notinline)
(while (setq spec (cdr spec))
(if (eq (get (car spec) 'byte-optimizer)
'byte-compile-inline-expand)
#'byte-compile-inline-expand)
(put (car spec) 'byte-optimizer nil))))
((eq (car-safe spec) 'optimize)
@ -3062,7 +3062,7 @@ Supported keywords for slots are:
forms)
(when (cl-oddp (length desc))
(push
(macroexp--warn-and-return
(macroexp-warn-and-return
(format "Missing value for option `%S' of slot `%s' in struct %s!"
(car (last desc)) slot name)
'nil)
@ -3071,7 +3071,7 @@ Supported keywords for slots are:
(not (keywordp (car desc))))
(let ((kw (car defaults)))
(push
(macroexp--warn-and-return
(macroexp-warn-and-return
(format " I'll take `%s' to be an option rather than a default value."
kw)
'nil)
@ -3287,7 +3287,6 @@ does not contain SLOT-NAME."
(signal 'cl-struct-unknown-slot (list struct-type slot-name))))
(defvar byte-compile-function-environment)
(defvar byte-compile-macro-environment)
(defun cl--macroexp-fboundp (sym)
"Return non-nil if SYM will be bound when we run the code.
@ -3295,7 +3294,7 @@ Of course, we really can't know that for sure, so it's just a heuristic."
(or (fboundp sym)
(and (macroexp-compiling-p)
(or (cdr (assq sym byte-compile-function-environment))
(cdr (assq sym byte-compile-macro-environment))))))
(cdr (assq sym macroexpand-all-environment))))))
(pcase-dolist (`(,type . ,pred)
;; Mostly kept in alphabetical order.

10
lisp/emacs-lisp/easymenu.el
View file

@ -35,7 +35,6 @@
(defsubst easy-menu-intern (s)
(if (stringp s) (intern s) s))
;;;###autoload
(defmacro easy-menu-define (symbol maps doc menu)
"Define a pop-up menu and/or menu bar menu specified by MENU.
If SYMBOL is non-nil, define SYMBOL as a function to pop up the
@ -166,7 +165,6 @@ This is expected to be bound to a mouse event."
""))
(cons menu props)))))
;;;###autoload
(defun easy-menu-do-define (symbol maps doc menu)
;; We can't do anything that might differ between Emacs dialects in
;; `easy-menu-define' in order to make byte compiled files
@ -192,7 +190,11 @@ This is expected to be bound to a mouse event."
(function-put symbol 'completion-predicate #'ignore))
(dolist (map (if (keymapp maps) (list maps) maps))
(define-key map
(vector 'menu-bar (easy-menu-intern (car menu)))
(vector 'menu-bar (if (symbolp (car menu))
(car menu)
;; If a string, then use the downcased
;; version for greater backwards compatibility.
(intern (downcase (car menu)))))
(easy-menu-binding keymap (car menu))))))
(defun easy-menu-filter-return (menu &optional name)
@ -218,7 +220,6 @@ If NAME is provided, it is used for the keymap."
If it holds a list, this is expected to be a list of keys already seen in the
menu we're processing. Else it means we're not processing a menu.")
;;;###autoload
(defun easy-menu-create-menu (menu-name menu-items)
"Create a menu called MENU-NAME with items described in MENU-ITEMS.
MENU-NAME is a string, the name of the menu. MENU-ITEMS is a list of items
@ -474,7 +475,6 @@ When non-nil, NOEXP indicates that CALLBACK cannot be an expression
(eval `(lambda () (interactive) ,callback) t)))
command))
;;;###autoload
(defun easy-menu-change (path name items &optional before map)
"Change menu found at PATH as item NAME to contain ITEMS.
PATH is a list of strings for locating the menu that

2
lisp/emacs-lisp/eieio-core.el
View file

@ -729,7 +729,7 @@ Argument FN is the function calling this verifier."
(pcase slot
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-slot-names))))
(macroexp--warn-and-return
(macroexp-warn-and-return
(format-message "Unknown slot `%S'" name) exp 'compile-only))
(_ exp))))
(gv-setter eieio-oset))

2
lisp/emacs-lisp/eieio.el
View file

@ -269,7 +269,7 @@ This method is obsolete."
(lambda (whole)
(if (not (stringp (car slots)))
whole
(macroexp--warn-and-return
(macroexp-warn-and-return
(format "Obsolete name arg %S to constructor %S"
(car slots) (car whole))
;; Keep the name arg, for backward compatibility,

2
lisp/emacs-lisp/elp.el
View file

@ -583,7 +583,7 @@ displayed."
;; continue standard unloading
nil)
(cl-defmethod loadhist-unload-element :before :extra "elp" ((x (head defun)))
(cl-defmethod loadhist-unload-element :extra "elp" :before ((x (head defun)))
"Un-instrument before unloading a function."
(elp-restore-function (cdr x)))

13
lisp/emacs-lisp/ert.el
View file

@ -277,14 +277,7 @@ It should only be stopped when ran from inside ert--run-test-internal."
(let ((form
;; catch macroexpansion errors
(condition-case err
(macroexpand-all form
(append (bound-and-true-p
byte-compile-macro-environment)
(cond
((boundp 'macroexpand-all-environment)
macroexpand-all-environment)
((boundp 'cl-macro-environment)
cl-macro-environment))))
(macroexpand-all form macroexpand-all-environment)
(error `(signal ',(car err) ',(cdr err))))))
(cond
((or (atom form) (ert--special-operator-p (car form)))
@ -1550,7 +1543,7 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\
(message "------------------")
(setq tests (sort tests (lambda (x y) (> (car x) (car y)))))
(when (< high (length tests)) (setcdr (nthcdr (1- high) tests) nil))
(message "%s" (mapconcat 'cdr tests "\n")))
(message "%s" (mapconcat #'cdr tests "\n")))
;; More details on hydra, where the logs are harder to get to.
(when (and (getenv "EMACS_HYDRA_CI")
(not (zerop (+ nunexpected nskipped))))
@ -2077,7 +2070,7 @@ and how to display message."
(ert-run-tests selector listener t)))
;;;###autoload
(defalias 'ert 'ert-run-tests-interactively)
(defalias 'ert #'ert-run-tests-interactively)
;;; Simple view mode for auxiliary information like stack traces or

2
lisp/emacs-lisp/gv.el
View file

@ -593,7 +593,7 @@ binding mode."
;; dynamic binding mode as well.
(eq (car-safe code) 'cons))
code
(macroexp--warn-and-return
(macroexp-warn-and-return
"Use of gv-ref probably requires lexical-binding"
code))))

2
lisp/emacs-lisp/inline.el
View file

@ -262,7 +262,7 @@ See Info node `(elisp)Defining Functions' for more details."
'(throw 'inline--just-use
;; FIXME: This would inf-loop by calling us right back when
;; macroexpand-all recurses to expand inline--form.
;; (macroexp--warn-and-return (format ,@args)
;; (macroexp-warn-and-return (format ,@args)
;; inline--form)
inline--form))

28
lisp/emacs-lisp/lisp-mode.el
View file

@ -740,25 +740,24 @@ font-lock keywords will not be case sensitive."
;;; Generic Lisp mode.
(defvar lisp-mode-map
(let ((map (make-sparse-keymap))
(menu-map (make-sparse-keymap "Lisp")))
(let ((map (make-sparse-keymap)))
(set-keymap-parent map lisp-mode-shared-map)
(define-key map "\e\C-x" 'lisp-eval-defun)
(define-key map "\C-c\C-z" 'run-lisp)
(bindings--define-key map [menu-bar lisp] (cons "Lisp" menu-map))
(bindings--define-key menu-map [run-lisp]
'(menu-item "Run inferior Lisp" run-lisp
:help "Run an inferior Lisp process, input and output via buffer `*inferior-lisp*'"))
(bindings--define-key menu-map [ev-def]
'(menu-item "Eval defun" lisp-eval-defun
:help "Send the current defun to the Lisp process made by M-x run-lisp"))
(bindings--define-key menu-map [ind-sexp]
'(menu-item "Indent sexp" indent-sexp
:help "Indent each line of the list starting just after point"))
map)
"Keymap for ordinary Lisp mode.
All commands in `lisp-mode-shared-map' are inherited by this map.")
(easy-menu-define lisp-mode-menu lisp-mode-map
"Menu for ordinary Lisp mode."
'("Lisp"
["Indent sexp" indent-sexp
:help "Indent each line of the list starting just after point"]
["Eval defun" lisp-eval-defun
:help "Send the current defun to the Lisp process made by M-x run-lisp"]
["Run inferior Lisp" run-lisp
:help "Run an inferior Lisp process, input and output via buffer `*inferior-lisp*'"]))
(define-derived-mode lisp-mode lisp-data-mode "Lisp"
"Major mode for editing Lisp code for Lisps other than GNU Emacs Lisp.
Commands:
@ -1372,7 +1371,8 @@ and initial semicolons."
fill-column)))
(save-restriction
(save-excursion
(let ((ppss (syntax-ppss)))
(let ((ppss (syntax-ppss))
(start (point)))
;; If we're in a string, then narrow (roughly) to that
;; string before filling. This avoids filling Lisp
;; statements that follow the string.
@ -1387,6 +1387,8 @@ and initial semicolons."
t))
(narrow-to-region (ppss-comment-or-string-start ppss)
(point))))
;; Move back to where we were.
(goto-char start)
(fill-paragraph justify)))))
;; Never return nil.
t))

114
lisp/emacs-lisp/macroexp.el
View file

@ -135,28 +135,33 @@ Other uses risk returning non-nil value that point to the wrong file."
(defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key))
(defun macroexp--warn-and-return (msg form &optional compile-only)
(defun macroexp--warn-wrap (msg form)
(let ((when-compiled (lambda () (byte-compile-warn "%s" msg))))
(cond
((null msg) form)
((macroexp-compiling-p)
(if (and (consp form) (gethash form macroexp--warned))
;; Already wrapped this exp with a warning: avoid inf-looping
;; where we keep adding the same warning onto `form' because
;; macroexpand-all gets right back to macroexpanding `form'.
form
(puthash form form macroexp--warned)
`(progn
(macroexp--funcall-if-compiled ',when-compiled)
,form)))
(t
(unless compile-only
(message "%sWarning: %s"
(if (stringp load-file-name)
(concat (file-relative-name load-file-name) ": ")
"")
msg))
form))))
`(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 (msg form &optional compile-only)
(cond
((null msg) form)
((macroexp-compiling-p)
(if (and (consp form) (gethash form macroexp--warned))
;; Already wrapped this exp with a warning: avoid inf-looping
;; where we keep adding the same warning onto `form' because
;; macroexpand-all gets right back to macroexpanding `form'.
form
(puthash form form macroexp--warned)
(macroexp--warn-wrap msg form)))
(t
(unless compile-only
(message "%sWarning: %s"
(if (stringp load-file-name)
(concat (file-relative-name load-file-name) ": ")
"")
msg))
form)))
(defun macroexp--obsolete-warning (fun obsolescence-data type)
(let ((instead (car obsolescence-data))
@ -205,7 +210,7 @@ Other uses risk returning non-nil value that point to the wrong file."
(byte-compile-warning-enabled-p 'obsolete (car form))))
(let* ((fun (car form))
(obsolete (get fun 'byte-obsolete-info)))
(macroexp--warn-and-return
(macroexp-warn-and-return
(macroexp--obsolete-warning
fun obsolete
(if (symbolp (symbol-function fun))
@ -260,7 +265,7 @@ Other uses risk returning non-nil value that point to the wrong file."
values (cdr values))))
(setq arglist (cdr arglist)))
(if values
(macroexp--warn-and-return
(macroexp-warn-and-return
(format (if (eq values 'too-few)
"attempt to open-code `%s' with too few arguments"
"attempt to open-code `%s' with too many arguments")
@ -289,10 +294,12 @@ Assumes the caller has bound `macroexpand-all-environment'."
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) dontcare))
(`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare))
(macroexp--cons
'condition-case
(macroexp--cons err
@ -309,12 +316,13 @@ Assumes the caller has bound `macroexpand-all-environment'."
(cdr form))
form))
(`(,(or 'function 'quote) . ,_) form)
(`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) dontcare))
(`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body)
pcase--dontcare))
(macroexp--cons fun
(macroexp--cons (macroexp--all-clauses bindings 1)
(if (null body)
(macroexp-unprogn
(macroexp--warn-and-return
(macroexp-warn-and-return
(format "Empty %s body" fun)
nil t))
(macroexp--all-forms body))
@ -334,27 +342,7 @@ Assumes the caller has bound `macroexpand-all-environment'."
form)
(macroexp--expand-all newform))))
;; The following few cases are for normal function calls that
;; are known to funcall one of their arguments. The byte
;; compiler has traditionally handled these functions specially
;; by treating a lambda expression quoted by `quote' as if it
;; were quoted by `function'. We make the same transformation
;; here, so that any code that cares about the difference will
;; see the same transformation.
;; First arg is a function:
(`(,(and fun (or 'funcall 'apply 'mapcar 'mapatoms 'mapconcat 'mapc))
',(and f `(lambda . ,_)) . ,args)
(macroexp--warn-and-return
(format "%s quoted with ' rather than with #'"
(list 'lambda (nth 1 f) '...))
(macroexp--expand-all `(,fun #',f . ,args))))
;; Second arg is a function:
(`(,(and fun (or 'sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args)
(macroexp--warn-and-return
(format "%s quoted with ' rather than with #'"
(list 'lambda (nth 1 f) '...))
(macroexp--expand-all `(,fun ,arg1 #',f . ,args))))
(`(funcall ,exp . ,args)
(`(funcall . ,(or `(,exp . ,args) pcase--dontcare))
(let ((eexp (macroexp--expand-all exp))
(eargs (macroexp--all-forms args)))
;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo'
@ -363,10 +351,22 @@ Assumes the caller has bound `macroexpand-all-environment'."
(`#',f (macroexp--expand-all `(,f . ,eargs)))
(_ `(funcall ,eexp . ,eargs)))))
(`(,func . ,_)
;; Macro expand compiler macros. This cannot be delayed to
;; byte-optimize-form because the output of the compiler-macro can
;; use macros.
(let ((handler (function-get func 'compiler-macro)))
(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
@ -392,6 +392,18 @@ Assumes the caller has bound `macroexpand-all-environment'."
(_ form))))
;; Record which arguments expect functions, so we can warn when those
;; are accidentally quoted with ' rather than with #'
(dolist (f '(funcall apply mapcar mapatoms mapconcat mapc cl-mapcar maphash))
(put f 'funarg-positions '(1)))
(dolist (f '( add-hook remove-hook advice-remove advice--remove-function
defalias fset global-set-key run-after-idle-timeout
set-process-filter set-process-sentinel sort))
(put f 'funarg-positions '(2)))
(dolist (f '( advice-add define-key
run-at-time run-with-idle-timer run-with-timer ))
(put f 'funarg-positions '(3)))
;;;###autoload
(defun macroexpand-all (form &optional environment)
"Return result of expanding macros at all levels in FORM.

Some files were not shown because too many files have changed in this diff Show more