[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/native-comp 9daffe9: Merge remote-tracking branch 'savannah/mast
|
From: |
Andrea Corallo |
|
Subject: |
feature/native-comp 9daffe9: Merge remote-tracking branch 'savannah/master' into HEAD |
|
Date: |
Sun, 24 May 2020 08:47:59 -0400 (EDT) |
branch: feature/native-comp
commit 9daffe9cfe82d3b1e1e9fa8929dbb40cfed60f0f
Merge: f5dceed e021c2d
Author: Andrea Corallo <address@hidden>
Commit: Andrea Corallo <address@hidden>
Merge remote-tracking branch 'savannah/master' into HEAD
---
doc/emacs/killing.texi | 2 +
doc/emacs/mule.texi | 84 +++-
doc/lispintro/emacs-lisp-intro.texi | 5 +-
doc/lispref/control.texi | 1 +
doc/lispref/display.texi | 6 +-
doc/lispref/elisp.texi | 2 +-
doc/lispref/eval.texi | 21 +-
doc/lispref/lists.texi | 16 +-
doc/lispref/objects.texi | 93 ++--
doc/lispref/sequences.texi | 25 +-
doc/lispref/strings.texi | 11 +-
etc/NEWS | 47 ++
etc/TODO | 64 ++-
lib-src/etags.c | 2 +-
lisp/calculator.el | 10 +-
lisp/cedet/ede.el | 7 +-
lisp/doc-view.el | 4 +-
lisp/emacs-lisp/package.el | 28 +-
lisp/emacs-lisp/syntax.el | 35 +-
lisp/gnus/gnus-art.el | 14 +-
lisp/gnus/gnus-registry.el | 36 +-
lisp/ido.el | 19 +-
lisp/json.el | 576 ++++++++++++-----------
lisp/jsonrpc.el | 50 +-
lisp/language/tibet-util.el | 14 +-
lisp/mouse.el | 2 +-
lisp/net/eww.el | 30 +-
lisp/net/shr.el | 84 ++--
lisp/net/tramp-archive.el | 7 +-
lisp/net/tramp-rclone.el | 13 +-
lisp/net/webjump.el | 5 +-
lisp/obsolete/levents.el | 292 ------------
lisp/org/org-agenda.el | 5 +-
lisp/password-cache.el | 3 +-
lisp/progmodes/cc-langs.el | 10 +-
lisp/progmodes/cc-mode.el | 2 +-
lisp/progmodes/project.el | 153 ++++---
lisp/progmodes/python.el | 21 +-
lisp/progmodes/which-func.el | 97 ++--
lisp/progmodes/xref.el | 4 +-
lisp/subr.el | 6 +-
lisp/vc/vc-dir.el | 36 ++
lisp/vc/vc-git.el | 4 +
lisp/vc/vc-hooks.el | 2 +-
lisp/version.el | 4 -
lisp/xml.el | 13 +-
src/alloc.c | 53 +--
src/buffer.c | 40 +-
src/bytecode.c | 28 +-
src/emacs.c | 5 +
src/eval.c | 62 +--
src/fns.c | 51 ++-
src/lisp.h | 2 -
src/lread.c | 26 +-
src/w32.c | 12 +-
test/lisp/electric-tests.el | 18 +
test/lisp/emacs-lisp/syntax-tests.el | 67 +++
test/lisp/json-tests.el | 865 +++++++++++++++++++++++++++++------
test/lisp/net/webjump-tests.el | 73 +++
test/lisp/xml-tests.el | 10 +
test/src/buffer-tests.el | 6 +
61 files changed, 2064 insertions(+), 1219 deletions(-)
diff --git a/doc/emacs/killing.texi b/doc/emacs/killing.texi
index 834a5c6..6b1f35e 100644
--- a/doc/emacs/killing.texi
+++ b/doc/emacs/killing.texi
@@ -727,6 +727,8 @@ them. Rectangle commands are useful with text in
multicolumn formats,
and for changing text into or out of such formats.
@cindex mark rectangle
+@cindex region-rectangle
+@cindex rectangular region
To specify a rectangle for a command to work on, set the mark at one
corner and point at the opposite corner. The rectangle thus specified
is called the @dfn{region-rectangle}. If point and the mark are in
diff --git a/doc/emacs/mule.texi b/doc/emacs/mule.texi
index e3fe20c..373c7b5 100644
--- a/doc/emacs/mule.texi
+++ b/doc/emacs/mule.texi
@@ -1326,16 +1326,17 @@ stored in the system and the available font names are
defined by the
system, fontsets are defined within Emacs itself. Once you have
defined a fontset, you can use it within Emacs by specifying its name,
anywhere that you could use a single font. Of course, Emacs fontsets
-can use only the fonts that the system supports. If some characters
+can use only the fonts that your system supports. If some characters
appear on the screen as empty boxes or hex codes, this means that the
fontset in use for them has no font for those characters. In this
case, or if the characters are shown, but not as well as you would
-like, you may need to install extra fonts. Your operating system may
-have optional fonts that you can install; or you can install the GNU
-Intlfonts package, which includes fonts for most supported
-scripts.@footnote{If you run Emacs on X, you may need to inform the X
-server about the location of the newly installed fonts with commands
-such as:
+like, you may need to install extra fonts or modify the fontset to use
+specific fonts already installed on your system (see below). Your
+operating system may have optional fonts that you can install; or you
+can install the GNU Intlfonts package, which includes fonts for most
+supported scripts.@footnote{If you run Emacs on X, you may need to
+inform the X server about the location of the newly installed fonts
+with commands such as:
@c FIXME? I feel like this may be out of date.
@c E.g., the intlfonts tarfile is ~ 10 years old.
@@ -1376,14 +1377,20 @@ explicitly requested, despite its name.
@w{@kbd{M-x describe-fontset}} command. It prompts for a fontset
name, defaulting to the one used by the current frame, and then
displays all the subranges of characters and the fonts assigned to
-them in that fontset.
+them in that fontset. To see which fonts Emacs is using in a session
+started without a specific fontset (which is what happens normally),
+type @kbd{fontset-default @key{RET}} at the prompt, or just
+@kbd{@key{RET}} to describe the fontset used by the current frame.
A fontset does not necessarily specify a font for every character
code. If a fontset specifies no font for a certain character, or if
it specifies a font that does not exist on your system, then it cannot
display that character properly. It will display that character as a
-hex code or thin space or an empty box instead. (@xref{Text Display, ,
-glyphless characters}, for details.)
+hex code or thin space or an empty box instead. (@xref{Text Display,
+, glyphless characters}, for details.) Or a fontset might specify a
+font for some range of characters, but you may not like their visual
+appearance. If this happens, you may wish to modify your fontset; see
+@ref{Modifying Fontsets}, for how to do that.
@node Defining Fontsets
@section Defining Fontsets
@@ -1542,10 +1549,10 @@ call this function explicitly to create a fontset.
Fontsets do not always have to be created from scratch. If only
minor changes are required it may be easier to modify an existing
-fontset. Modifying @samp{fontset-default} will also affect other
-fontsets that use it as a fallback, so can be an effective way of
-fixing problems with the fonts that Emacs chooses for a particular
-script.
+fontset, usually @samp{fontset-default}. Modifying
+@samp{fontset-default} will also affect other fontsets that use it as
+a fallback, so can be an effective way of fixing problems with the
+fonts that Emacs chooses for a particular script.
Fontsets can be modified using the function @code{set-fontset-font},
specifying a character, a charset, a script, or a range of characters
@@ -1553,26 +1560,61 @@ to modify the font for, and a font specification for
the font to be
used. Some examples are:
@example
-;; Use Liberation Mono for latin-3 charset.
-(set-fontset-font "fontset-default" 'iso-8859-3
- "Liberation Mono")
-
;; Prefer a big5 font for han characters.
(set-fontset-font "fontset-default"
'han (font-spec :registry "big5")
nil 'prepend)
+;; Use MyPrivateFont for the Unicode private use area.
+(set-fontset-font "fontset-default" '(#xe000 . #xf8ff)
+ "MyPrivateFont")
+
+;; Use Liberation Mono for latin-3 charset.
+(set-fontset-font "fontset-default" 'iso-8859-3
+ "Liberation Mono")
+
;; Use DejaVu Sans Mono as a fallback in fontset-startup
;; before resorting to fontset-default.
(set-fontset-font "fontset-startup" nil "DejaVu Sans Mono"
nil 'append)
+@end example
-;; Use MyPrivateFont for the Unicode private use area.
-(set-fontset-font "fontset-default" '(#xe000 . #xf8ff)
- "MyPrivateFont")
+@noindent
+@xref{Fontsets, , , elisp, GNU Emacs Lisp Reference Manual}, for more
+details about using the @code{set-fontset-font} function.
+
+@cindex script of a character
+@cindex codepoint of a character
+If you don't know the character's codepoint or the script to which it
+belongs, you can ask Emacs. With point at the character, type
+@w{@kbd{C-u C-x =}} (@code{what-cursor-position}), and this
+information, together with much more, will be displayed in the
+@file{*Help*} buffer that Emacs pops up. @xref{Position Info}. For
+example, Japanese characters belong to the @samp{kana} script, but
+Japanese text also mixes them with Chinese characters so the following
+uses the @samp{han} script to set up Emacs to use the @samp{Kochi
+Gothic} font for Japanese text:
+@example
+(set-fontset-font "fontset-default" 'han "Kochi Gothic")
@end example
+@noindent
+@cindex CKJ characters
+(For convenience, the @samp{han} script in Emacs is set up to support
+all of the Chinese, Japanese, and Korean, a.k.a.@: @acronym{CJK},
+characters, not just Chinese characters.)
+
+@vindex script-representative-chars
+For the list of known scripts, see the variable
+@code{script-representative-chars}.
+
+Fontset settings like those above only affect characters that the
+default font doesn't support, so if the @samp{Kochi Gothic} font
+covers Latin characters, it will not be used for displaying Latin
+scripts, since the default font used by Emacs usually covers Basic
+Latin.
+
@cindex ignore font
@cindex fonts, how to ignore
@vindex face-ignored-fonts
diff --git a/doc/lispintro/emacs-lisp-intro.texi
b/doc/lispintro/emacs-lisp-intro.texi
index 7484ce5..f6dd77a 100644
--- a/doc/lispintro/emacs-lisp-intro.texi
+++ b/doc/lispintro/emacs-lisp-intro.texi
@@ -7317,8 +7317,6 @@ which leave the original list as it was. One way to find
out how this
works is to experiment. We will start with the @code{setcar} function.
@need 1200
-@cindex constant lists
-@cindex mutable lists
First, we can make a list and then set the value of a variable to the
list, using the @code{setq} special form. Because we intend to use
@code{setcar} to change the list, this @code{setq} should not use the
@@ -7327,8 +7325,7 @@ a list that is part of the program and bad things could
happen if we
tried to change part of the program while running it. Generally
speaking an Emacs Lisp program's components should be constant (or
unchanged) while the program is running. So we instead construct an
-animal list that is @dfn{mutable} (or changeable) by using the
-@code{list} function, as follows:
+animal list by using the @code{list} function, as follows:
@smallexample
(setq animals (list 'antelope 'giraffe 'lion 'tiger))
diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi
index c601e3a..58f9336 100644
--- a/doc/lispref/control.texi
+++ b/doc/lispref/control.texi
@@ -1905,6 +1905,7 @@ variables precisely as they were at the time of the error.
@subsubsection Writing Code to Handle Errors
@cindex error handler
@cindex handling errors
+@cindex handle Lisp errors
@cindex forms for handling errors
The usual effect of signaling an error is to terminate the command
diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi
index e53f0e9..3d738b9 100644
--- a/doc/lispref/display.texi
+++ b/doc/lispref/display.texi
@@ -3597,9 +3597,9 @@ characters in the range @var{from} and @var{to}
(inclusive).
@var{character} may be a charset (@pxref{Character Sets}). In that
case, use @var{font-spec} for all the characters in the charset.
-@var{character} may be a script name (@pxref{Character Properties}).
-In that case, use @var{font-spec} for all the characters belonging to
-the script.
+@var{character} may be a script name (@pxref{Character Properties,
+char-script-table}). In that case, use @var{font-spec} for all the
+characters belonging to the script.
@var{character} may be @code{nil}, which means to use @var{font-spec}
for any character which no font-spec is specified.
diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi
index bba1b63..9a67967 100644
--- a/doc/lispref/elisp.texi
+++ b/doc/lispref/elisp.texi
@@ -297,7 +297,7 @@ Lisp Data Types
* Circular Objects:: Read syntax for circular structure.
* Type Predicates:: Tests related to types.
* Equality Predicates:: Tests of equality between any two objects.
-* Constants and Mutability:: Whether an object's value can change.
+* Mutability:: Some objects should not be modified.
Programming Types
diff --git a/doc/lispref/eval.texi b/doc/lispref/eval.texi
index baddce4..39f342a 100644
--- a/doc/lispref/eval.texi
+++ b/doc/lispref/eval.texi
@@ -158,11 +158,11 @@ contents unchanged.
@end group
@end example
- A self-evaluating form yields constant conses, vectors and strings, and you
-should not attempt to modify their contents via @code{setcar}, @code{aset} or
+ A self-evaluating form yields a value that becomes part of the program,
+and you should not try to modify it via @code{setcar}, @code{aset} or
similar operations. The Lisp interpreter might unify the constants
yielded by your program's self-evaluating forms, so that these
-constants might share structure. @xref{Constants and Mutability}.
+constants might share structure. @xref{Mutability}.
It is common to write numbers, characters, strings, and even vectors
in Lisp code, taking advantage of the fact that they self-evaluate.
@@ -564,8 +564,8 @@ and vectors.)
@defspec quote object
This special form returns @var{object}, without evaluating it.
-The returned value is a constant, and should not be modified.
-@xref{Constants and Mutability}.
+The returned value might be shared and should not be modified.
+@xref{Self-Evaluating Forms}.
@end defspec
@cindex @samp{'} for quoting
@@ -608,9 +608,9 @@ Here are some examples of expressions that use @code{quote}:
Although the expressions @code{(list '+ 1 2)} and @code{'(+ 1 2)}
both yield lists equal to @code{(+ 1 2)}, the former yields a
-freshly-minted mutable list whereas the latter yields a constant list
-built from conses that may be shared with other constants.
-@xref{Constants and Mutability}.
+freshly-minted mutable list whereas the latter yields a list
+built from conses that might be shared and should not be modified.
+@xref{Self-Evaluating Forms}.
Other quoting constructs include @code{function} (@pxref{Anonymous
Functions}), which causes an anonymous lambda expression written in Lisp
@@ -710,8 +710,9 @@ Here are some examples:
@end example
If a subexpression of a backquote construct has no substitutions or
-splices, it acts like @code{quote} in that it yields constant conses,
-vectors and strings that should not be modified.
+splices, it acts like @code{quote} in that it yields conses,
+vectors and strings that might be shared and should not be modified.
+@xref{Self-Evaluating Forms}.
@node Eval
@section Eval
diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index fcaf438..ae793d5 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -873,8 +873,8 @@ primitives @code{setcar} and @code{setcdr}. These are
destructive
operations because they change existing list structure.
Destructive operations should be applied only to mutable lists,
that is, lists constructed via @code{cons}, @code{list} or similar
-operations. Lists created by quoting are constants and should not be
-changed by destructive operations. @xref{Constants and Mutability}.
+operations. Lists created by quoting are part of the program and
+should not be changed by destructive operations. @xref{Mutability}.
@cindex CL note---@code{rplaca} vs @code{setcar}
@quotation
@@ -911,7 +911,7 @@ value @var{object}. For example:
@example
@group
-(setq x (list 1 2)) ; @r{Create a mutable list.}
+(setq x (list 1 2))
@result{} (1 2)
@end group
@group
@@ -931,7 +931,7 @@ these lists. Here is an example:
@example
@group
-;; @r{Create two mutable lists that are partly shared.}
+;; @r{Create two lists that are partly shared.}
(setq x1 (list 'a 'b 'c))
@result{} (a b c)
(setq x2 (cons 'z (cdr x1)))
@@ -1022,11 +1022,11 @@ reached via the @sc{cdr}.
@example
@group
-(setq x (list 1 2 3)) ; @r{Create a mutable list.}
+(setq x (list 1 2 3))
@result{} (1 2 3)
@end group
@group
-(setcdr x '(4)) ; @r{Modify the list's tail to be a constant list.}
+(setcdr x '(4))
@result{} (4)
@end group
@group
@@ -1135,11 +1135,11 @@ Unlike @code{append} (@pxref{Building Lists}), the
@var{lists} are
@example
@group
-(setq x (list 1 2 3)) ; @r{Create a mutable list.}
+(setq x (list 1 2 3))
@result{} (1 2 3)
@end group
@group
-(nconc x '(4 5)) ; @r{Modify the list's tail to be a constant list.}
+(nconc x '(4 5))
@result{} (1 2 3 4 5)
@end group
@group
diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi
index cd037d6..8306674 100644
--- a/doc/lispref/objects.texi
+++ b/doc/lispref/objects.texi
@@ -46,10 +46,6 @@ you store in it, type and all. (Actually, a small number of
Emacs
Lisp variables can only take on values of a certain type.
@xref{Variables with Restricted Values}.)
- Some Lisp objects are @dfn{constant}: their values should never change.
-Others are @dfn{mutable}: their values can be changed via destructive
-operations that involve side effects.
-
This chapter describes the purpose, printed representation, and read
syntax of each of the standard types in GNU Emacs Lisp. Details on how
to use these types can be found in later chapters.
@@ -63,7 +59,7 @@ to use these types can be found in later chapters.
* Circular Objects:: Read syntax for circular structure.
* Type Predicates:: Tests related to types.
* Equality Predicates:: Tests of equality between any two objects.
-* Constants and Mutability:: Whether an object's value can change.
+* Mutability:: Some objects should not be modified.
@end menu
@node Printed Representation
@@ -2383,51 +2379,58 @@ that for two strings to be equal, they have the same
text properties.
@end example
@end defun
-@node Constants and Mutability
-@section Constants and Mutability
-@cindex constants
+@node Mutability
+@section Mutability
@cindex mutable objects
- Some Lisp objects are constant: their values should never change
-during a single execution of Emacs running well-behaved Lisp code.
-For example, you can create a new integer by calculating one, but you
-cannot modify the value of an existing integer.
-
- Other Lisp objects are mutable: it is safe to change their values
-via destructive operations involving side effects. For example, an
-existing marker can be changed by moving the marker to point to
-somewhere else.
-
- Although all numbers are constants and all markers are
-mutable, some types contain both constant and mutable members. These
-types include conses, vectors, strings, and symbols. For example, the string
-literal @code{"aaa"} yields a constant string, whereas the function
-call @code{(make-string 3 ?a)} yields a mutable string that can be
+ Some Lisp objects should never change. For example, the Lisp
+expression @code{"aaa"} yields a string, but you should not change
+its contents. And some objects cannot be changed; for example,
+although you can create a new number by calculating one, Lisp provides
+no operation to change the value of an existing number.
+
+ Other Lisp objects are @dfn{mutable}: it is safe to change their
+values via destructive operations involving side effects. For
+example, an existing marker can be changed by moving the marker to
+point to somewhere else.
+
+ Although numbers never change and all markers are mutable,
+some types have members some of which are mutable and others not. These
+types include conses, vectors, and strings. For example,
+although @code{"cons"} and @code{(symbol-name 'cons)} both yield
+strings that should not be changed, @code{(copy-sequence "cons")} and
+@code{(make-string 3 ?a)} both yield mutable strings that can be
changed via later calls to @code{aset}.
- A mutable object can become constant if it is part of an expression
-that is evaluated. The reverse does not occur: constant objects
-should stay constant.
-
- Trying to modify a constant variable signals an error
-(@pxref{Constant Variables}).
-A program should not attempt to modify other types of constants because the
-resulting behavior is undefined: the Lisp interpreter might or might
-not detect the error, and if it does not detect the error the
-interpreter can behave unpredictably thereafter. Another way to put
-this is that although mutable objects are safe to change and constant
-variables reliably prevent attempts to change them, other constants
-are not safely mutable: if a misbehaving program tries to change such a
-constant then the constant's value might actually change, or the
-program might crash or worse. This problem occurs
-with types that have both constant and mutable members, and that have
-mutators like @code{setcar} and @code{aset} that are valid on mutable
-objects but hazardous on constants.
-
- When the same constant occurs multiple times in a program, the Lisp
+ A mutable object stops being mutable if it is part of an expression
+that is evaluated. For example:
+
+@example
+(let* ((x (list 0.5))
+ (y (eval (list 'quote x))))
+ (setcar x 1.5) ;; The program should not do this.
+ y)
+@end example
+
+@noindent
+Although the list @code{(0.5)} was mutable when it was created, it should not
+have been changed via @code{setcar} because it given to @code{eval}. The
+reverse does not occur: an object that should not be changed never
+becomes mutable afterwards.
+
+ If a program attempts to change objects that should not be
+changed, the resulting behavior is undefined: the Lisp interpreter
+might signal an error, or it might crash or behave unpredictably in
+other ways.@footnote{This is the behavior specified for languages like
+Common Lisp and C for constants, and this differs from languages like
+JavaScript and Python where an interpreter is required to signal an
+error if a program attempts to change an immutable object. Ideally the Emacs
+Lisp interpreter will evolve in latter direction.}
+
+ When similar constants occur as parts of a program, the Lisp
interpreter might save time or space by reusing existing constants or
-constant components. For example, @code{(eq "abc" "abc")} returns
+their components. For example, @code{(eq "abc" "abc")} returns
@code{t} if the interpreter creates only one instance of the string
-constant @code{"abc"}, and returns @code{nil} if it creates two
+literal @code{"abc"}, and returns @code{nil} if it creates two
instances. Lisp programs should be written so that they work
regardless of whether this optimization is in use.
diff --git a/doc/lispref/sequences.texi b/doc/lispref/sequences.texi
index 1cb0d05..91c3049 100644
--- a/doc/lispref/sequences.texi
+++ b/doc/lispref/sequences.texi
@@ -183,11 +183,11 @@ for other ways to copy sequences.
@example
@group
-(setq bar (list 1 2)) ; @r{Create a mutable list.}
+(setq bar (list 1 2))
@result{} (1 2)
@end group
@group
-(setq x (vector 'foo bar)) ; @r{Create a mutable vector.}
+(setq x (vector 'foo bar))
@result{} [foo (1 2)]
@end group
@group
@@ -278,7 +278,7 @@ Unlike @code{reverse} the original @var{sequence} may be
modified.
@example
@group
-(setq x (list 'a 'b 'c)) ; @r{Create a mutable list.}
+(setq x (list 'a 'b 'c))
@result{} (a b c)
@end group
@group
@@ -320,7 +320,7 @@ presented graphically:
For the vector, it is even simpler because you don't need setq:
@example
-(setq x (copy-sequence [1 2 3 4])) ; @r{Create a mutable vector.}
+(setq x (copy-sequence [1 2 3 4]))
@result{} [1 2 3 4]
(nreverse x)
@result{} [4 3 2 1]
@@ -331,6 +331,7 @@ x
Note that unlike @code{reverse}, this function doesn't work with strings.
Although you can alter string data by using @code{aset}, it is strongly
encouraged to treat strings as immutable even when they are mutable.
+@xref{Mutability}.
@end defun
@@ -374,7 +375,7 @@ appears in a different position in the list due to the
change of
@example
@group
-(setq nums (list 1 3 2 6 5 4 0)) ; @r{Create a mutable list.}
+(setq nums (list 1 3 2 6 5 4 0))
@result{} (1 3 2 6 5 4 0)
@end group
@group
@@ -1228,7 +1229,7 @@ This function sets the @var{index}th element of
@var{array} to be
@example
@group
-(setq w (vector 'foo 'bar 'baz)) ; @r{Create a mutable vector.}
+(setq w (vector 'foo 'bar 'baz))
@result{} [foo bar baz]
(aset w 0 'fu)
@result{} fu
@@ -1237,7 +1238,7 @@ w
@end group
@group
-;; @r{@code{copy-sequence} creates a mutable string.}
+;; @r{@code{copy-sequence} copies the string to be modified later.}
(setq x (copy-sequence "asdfasfd"))
@result{} "asdfasfd"
(aset x 3 ?Z)
@@ -1247,9 +1248,7 @@ x
@end group
@end example
-The @var{array} should be mutable; that is, it should not be a constant,
-such as the constants created via quoting or via self-evaluating forms.
-@xref{Constants and Mutability}.
+The @var{array} should be mutable. @xref{Mutability}.
If @var{array} is a string and @var{object} is not a character, a
@code{wrong-type-argument} error results. The function converts a
@@ -1262,7 +1261,6 @@ each element of @var{array} is @var{object}. It returns
@var{array}.
@example
@group
-;; @r{Create a mutable vector and then fill it with zeros.}
(setq a (copy-sequence [a b c d e f g]))
@result{} [a b c d e f g]
(fillarray a 0)
@@ -1271,7 +1269,6 @@ a
@result{} [0 0 0 0 0 0 0]
@end group
@group
-;; @r{Create a mutable string and then fill it with "-".}
(setq s (copy-sequence "When in the course"))
@result{} "When in the course"
(fillarray s ?-)
@@ -1310,8 +1307,8 @@ same way in Lisp input.
evaluation: the result of evaluating it is the same vector. This does
not evaluate or even examine the elements of the vector.
@xref{Self-Evaluating Forms}. Vectors written with square brackets
-are constants and should not be modified via @code{aset} or other
-destructive operations. @xref{Constants and Mutability}.
+should not be modified via @code{aset} or other destructive
+operations. @xref{Mutability}.
Here are examples illustrating these principles:
diff --git a/doc/lispref/strings.texi b/doc/lispref/strings.texi
index a4c9c25..70c3b3c 100644
--- a/doc/lispref/strings.texi
+++ b/doc/lispref/strings.texi
@@ -49,10 +49,9 @@ by a distinguished character code.
Since strings are arrays, and therefore sequences as well, you can
operate on them with the general array and sequence functions documented
-in @ref{Sequences Arrays Vectors}. For example, you can access or
-change individual characters in a string using the functions @code{aref}
-and @code{aset} (@pxref{Array Functions}). However, you should not
-try to change the contents of constant strings (@pxref{Modifying Strings}).
+in @ref{Sequences Arrays Vectors}. For example, you can access
+individual characters in a string using the function @code{aref}
+(@pxref{Array Functions}).
There are two text representations for non-@acronym{ASCII}
characters in Emacs strings (and in buffers): unibyte and multibyte.
@@ -382,9 +381,7 @@ usual value is @w{@code{"[ \f\t\n\r\v]+"}}.
@cindex string modification
You can alter the contents of a mutable string via operations
-described in this section. However, you should not try to use these
-operations to alter the contents of a constant string.
-@xref{Constants and Mutability}.
+described in this section. @xref{Mutability}.
The most basic way to alter the contents of an existing string is with
@code{aset} (@pxref{Array Functions}). @code{(aset @var{string}
diff --git a/etc/NEWS b/etc/NEWS
index 303036e..efad273 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -139,6 +139,9 @@ directories with the help of new command
'dired-vc-next-action'.
*** New commands 'vc-dir-mark-registered-files' (bound to '* r') and
'vc-dir-mark-unregistered-files'.
+*** Support for bookmark.el.
+Bookmark locations can refer to VC directory buffers.
+
** Gnus
---
@@ -226,6 +229,12 @@ key binding
/ m package-menu-filter-marked
/ / package-menu-filter-clear
+---
++++ Column widths in 'list-packages' display can now be customized.
+See the new user options 'package-name-column-width',
+'package-version-column-width', 'package-status-column-width', and
+'package-archive-column-width'.
+
** gdb-mi
+++
@@ -353,6 +362,44 @@ symbol property to the browsing functions. With a new
command
'browse-url-with-browser-kind', an URL can explicitly be browsed with
either an internal or external browser.
+** SHR
+
+---
+*** The command 'shr-browse-url' now supports custom mailto handlers.
+Clicking on or otherwise following a 'mailto:' link in a HTML buffer
+rendered by SHR previously invoked the command 'browse-url-mailto'.
+This is still the case by default, but if you customize
+'browse-url-mailto-function' or 'browse-url-handlers' to call some
+other function, it will now be called instead of the default.
+
+** EWW
+
+---
+*** The command 'eww-follow-link' now supports custom mailto handlers.
+The function that is invoked when clicking on or otherwise following a
+'mailto:' link in an EWW buffer can now be customized. For more
+information, see the related entry about 'shr-browse-url' above.
+
+** Project
+
+*** New user option 'project-vc-merge-submodules'.
+
+** json.el
+
+---
+*** JSON number parsing is now stricter.
+Numbers with a leading plus sign, leading zeros, or a missing integer
+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.
+
+** xml.el
+
+*** XML serialization functions now reject invalid characters.
+Previously 'xml-print' would produce invalid XML when given a string
+with characters that are not valid in XML (see
+https://www.w3.org/TR/xml/#charsets). Now it rejects such strings.
+
* New Modes and Packages in Emacs 28.1
diff --git a/etc/TODO b/etc/TODO
index 20262a7..0f908de 100644
--- a/etc/TODO
+++ b/etc/TODO
@@ -220,10 +220,23 @@ https://lists.gnu.org/r/emacs-devel/2013-11/msg00515.html
width fonts. However, more features are still needed to achieve this.
** Support ligatures out of the box
-For the list of typographical ligatures, see
+For the list of frequently-used typographical ligatures, see
https://en.wikipedia.org/wiki/Orthographic_ligature#Ligatures_in_Unicode_(Latin_alphabets)
+(Note that in general, the number of possible ligatures can be much
+larger, and there's no way, in principle, to specify the superset of
+all the ligatures that could exist. Each font can support different
+ligatures. The reliable way of supporting any and all ligatures is to
+hand all text to be displayed to the shaping engine and get back the
+font glyphs to display that text. However, doing this is impossible
+with the current design of the Emacs display engine, since it examines
+buffer text one character at a time, and implements character
+composition by calls to Lisp, which makes doing this for every
+character impractically slow. Therefore, the rest of this item
+describes a limited form of ligature support which is compatible with
+the current display engine design and uses automatic compositions.)
+
For Text and derived modes, the job is to figure out which ligatures
we want to support, how to let the user customize that, and probably
define a minor mode for automatic ligation (as some contexts might not
@@ -237,12 +250,12 @@ prettify-symbols-mode. We need to figure out which
ligatures are
needed for each programming language, and provide user options to turn
this on and off.
-The implementation should use the infrastructure for character
-compositions, i.e., we should define appropriate regexp-based rules
-for character sequences that need to be composed into ligatures, and
-populate composition-function-table with those rules. See
-composite.el for examples of this, and also grep lisp/language/*.el
-for references to composition-function-table.
+The implementation should use the infrastructure for automatic
+character compositions, i.e., we should define appropriate
+regexp-based rules for character sequences that need to be composed
+into ligatures, and populate composition-function-table with those
+rules. See composite.el for examples of this, and also grep
+lisp/language/*.el for references to composition-function-table.
One problem with character compositions that will need to be solved is
that composition-function-table, the char-table which holds the
@@ -259,11 +272,46 @@ way of preventing the ligation from happening. One
possibility is to
have a ZWNJ character separate these ASCII characters; another
possibility is to introduce a special text property that prevents
character composition, and place that property on the relevant parts
-of the mode line.
+of the mode line. Yet another possibility would be to write a
+specialized composition function, which would detect that it is called
+on mode-line strings, and return nil to signal that composition is not
+possible in this case; then use that function in the rules for
+ligatures stored in composition-function-table.
The prettify-symbols-mode should be deprecated once ligature support
is in place.
+A related, but somewhat independent, feature is being able to move the
+cursor "into a ligature", whereby cursor motion commands shows some
+pseudo-cursor on some part of a ligature. For example, if "ffi" is
+displayed as a ligature, then moving by one buffer position should
+show the middle part of the ligature's glyph similar to the cursor
+display: some special background and perhaps also a special
+foreground. There are two possible ways of figuring out the offset at
+which to display the pseudo-cursor:
+
+ . Arbitrarily divide the ligature's glyph width W into N parts,
+ where N is the number of codepoints composed into the ligature, then
+ move that pseudo-cursor by W/N pixels each time a cursor-motion
+ command is invoked;
+ . Use the font information. For example, HarfBuzz has the
+ hb_ot_layout_get_ligature_carets API for that purpose. However,
+ it could be that few fonts actually have that information recorded
+ in them, in which case the previous heuristics will be needed as
+ fallback.
+
+One subtle issue needs to be resolved to have this feature of
+"sub-glyph" cursor movement inside composed characters. The way Emacs
+currently displays the default block cursor is by simply redrawing the
+glyph at point in reverse video. So Emacs currently doesn't have a
+way of displaying a cursor that "covers" only part of a glyph. To
+make this happen, the display code will probably need to be changed to
+draw the cursor as part of drawing the foreground and/or background of
+the corresponding glyph, which is against the current flow of the
+display code: it generally first completely draws the background and
+foreground of the entire text that needs to be redrawn, and only then
+draws the cursor where it should be placed.
+
** Support for Stylistic Sets
This will allow using "alternate glyphs" supported by modern fonts.
For an overview of this feature, see
diff --git a/lib-src/etags.c b/lib-src/etags.c
index eee2c59..4672e34 100644
--- a/lib-src/etags.c
+++ b/lib-src/etags.c
@@ -4197,9 +4197,9 @@ C_entries (int c_ext, FILE *inf)
break;
}
FALLTHROUGH;
- resetfvdef:
case '#': case '~': case '&': case '%': case '/':
case '|': case '^': case '!': case '.': case '?':
+ resetfvdef:
if (definedef != dnone)
break;
/* These surely cannot follow a function tag in C. */
diff --git a/lisp/calculator.el b/lisp/calculator.el
index 7e0b2fc..cd92f99 100644
--- a/lisp/calculator.el
+++ b/lisp/calculator.el
@@ -858,12 +858,10 @@ The result should not exceed the screen width."
"Convert the given STR to a number, according to the value of
`calculator-input-radix'."
(if calculator-input-radix
- (string-to-number str (cadr (assq calculator-input-radix
- '((bin 2) (oct 8) (hex 16)))))
- (let* ((str (replace-regexp-in-string
- "\\.\\([^0-9].*\\)?$" ".0\\1" str))
- (str (replace-regexp-in-string
- "[eE][+-]?\\([^0-9].*\\)?$" "e0\\1" str)))
+ (string-to-number str (cadr (assq calculator-input-radix
+ '((bin 2) (oct 8) (hex 16)))))
+ ;; Allow entry of "1.e3".
+ (let ((str (replace-regexp-in-string (rx "." (any "eE")) "e" str)))
(float (string-to-number str)))))
(defun calculator-push-curnum ()
diff --git a/lisp/cedet/ede.el b/lisp/cedet/ede.el
index 8c33611..4125281 100644
--- a/lisp/cedet/ede.el
+++ b/lisp/cedet/ede.el
@@ -1515,8 +1515,11 @@ It does not apply the value to buffers."
(when project-dir
(ede-directory-get-open-project project-dir 'ROOT))))
-(cl-defmethod project-roots ((project ede-project))
- (list (ede-project-root-directory project)))
+(cl-defmethod project-root ((project ede-project))
+ (ede-project-root-directory project))
+
+;;; FIXME: Could someone look into implementing `project-ignores' for
+;;; EDE and/or a faster `project-files'?
(add-hook 'project-find-functions #'project-try-ede)
diff --git a/lisp/doc-view.el b/lisp/doc-view.el
index 3cac262..de342f1 100644
--- a/lisp/doc-view.el
+++ b/lisp/doc-view.el
@@ -2050,8 +2050,8 @@ See the command `doc-view-mode' for more information on
this mode."
(when (memq (selected-frame) (alist-get 'frames attrs))
(let ((geom (alist-get 'geometry attrs)))
(when geom
- (setq monitor-top (nth 0 geom))
- (setq monitor-left (nth 1 geom))
+ (setq monitor-left (nth 0 geom))
+ (setq monitor-top (nth 1 geom))
(setq monitor-width (nth 2 geom))
(setq monitor-height (nth 3 geom))))))
(let ((frame (make-frame
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 9565984..808e4f3 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -397,6 +397,26 @@ synchronously."
:type 'boolean
:version "25.1")
+(defcustom package-name-column-width 30
+ "Column width for the Package name in the package menu."
+ :type 'number
+ :version "28.1")
+
+(defcustom package-version-column-width 14
+ "Column width for the Package version in the package menu."
+ :type 'number
+ :version "28.1")
+
+(defcustom package-status-column-width 12
+ "Column width for the Package status in the package menu."
+ :type 'number
+ :version "28.1")
+
+(defcustom package-archive-column-width 8
+ "Column width for the Package status in the package menu."
+ :type 'number
+ :version "28.1")
+
;;; `package-desc' object definition
;; This is the struct used internally to represent packages.
@@ -2750,11 +2770,11 @@ Letters do not insert themselves; instead, they are
commands.
(package-menu--transaction-status
package-menu--transaction-status)))
(setq tabulated-list-format
- `[("Package" 18 package-menu--name-predicate)
- ("Version" 13 package-menu--version-predicate)
- ("Status" 10 package-menu--status-predicate)
+ `[("Package" ,package-name-column-width package-menu--name-predicate)
+ ("Version" ,package-version-column-width
package-menu--version-predicate)
+ ("Status" ,package-status-column-width
package-menu--status-predicate)
,@(if (cdr package-archives)
- '(("Archive" 10 package-menu--archive-predicate)))
+ `(("Archive" ,package-archive-column-width
package-menu--archive-predicate)))
("Description" 0 package-menu--description-predicate)])
(setq tabulated-list-padding 2)
(setq tabulated-list-sort-key (cons "Status" nil))
diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el
index 46dc8d9..ce495af 100644
--- a/lisp/emacs-lisp/syntax.el
+++ b/lisp/emacs-lisp/syntax.el
@@ -139,14 +139,28 @@ delimiter or an Escaped or Char-quoted character."))
(point-max))))
(cons beg end))
-(defun syntax-propertize--shift-groups (re n)
- (replace-regexp-in-string
- "\\\\(\\?\\([0-9]+\\):"
- (lambda (s)
- (replace-match
- (number-to-string (+ n (string-to-number (match-string 1 s))))
- t t s 1))
- re t t))
+(defun syntax-propertize--shift-groups-and-backrefs (re n)
+ (let ((new-re (replace-regexp-in-string
+ "\\\\(\\?\\([0-9]+\\):"
+ (lambda (s)
+ (replace-match
+ (number-to-string
+ (+ n (string-to-number (match-string 1 s))))
+ t t s 1))
+ re t t))
+ (pos 0))
+ (while (string-match "\\\\\\([0-9]+\\)" new-re pos)
+ (setq pos (+ 1 (match-beginning 1)))
+ (when (save-match-data
+ ;; With \N, the \ must be in a subregexp context, i.e.,
+ ;; not in a character class or in a \{\} repetition.
+ (subregexp-context-p new-re (match-beginning 0)))
+ (let ((shifted (+ n (string-to-number (match-string 1 new-re)))))
+ (when (> shifted 9)
+ (error "There may be at most nine back-references"))
+ (setq new-re (replace-match (number-to-string shifted)
+ t t new-re 1)))))
+ new-re))
(defmacro syntax-propertize-precompile-rules (&rest rules)
"Return a precompiled form of RULES to pass to `syntax-propertize-rules'.
@@ -190,7 +204,8 @@ for subsequent HIGHLIGHTs.
Also SYNTAX is free to move point, in which case RULES may not be applied to
some parts of the text or may be applied several times to other parts.
-Note: back-references in REGEXPs do not work."
+Note: There may be at most nine back-references in the REGEXPs of
+all RULES in total."
(declare (debug (&rest &or symbolp ;FIXME: edebug this eval step.
(form &rest
(numberp
@@ -219,7 +234,7 @@ Note: back-references in REGEXPs do not work."
;; tell when *this* match 0 has succeeded.
(cl-incf offset)
(setq re (concat "\\(" re "\\)")))
- (setq re (syntax-propertize--shift-groups re offset))
+ (setq re (syntax-propertize--shift-groups-and-backrefs re
offset))
(let ((code '())
(condition
(cond
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index 6b9610d..614651a 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -5833,6 +5833,7 @@ all parts."
"" "..."))
(gnus-tmp-length (with-current-buffer (mm-handle-buffer handle)
(buffer-size)))
+ (help-echo "mouse-2: toggle the MIME part; down-mouse-3: more options")
gnus-tmp-type-long b e)
(when (string-match ".*/" gnus-tmp-name)
(setq gnus-tmp-name (replace-match "" t t gnus-tmp-name)))
@@ -5841,6 +5842,16 @@ all parts."
(concat "; " gnus-tmp-name))))
(unless (equal gnus-tmp-description "")
(setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
+ (when (zerop gnus-tmp-length)
+ (setq gnus-tmp-type-long
+ (concat
+ gnus-tmp-type-long
+ (substitute-command-keys
+ (concat "\\<gnus-summary-mode-map> (not downloaded, "
+ "\\[gnus-summary-show-complete-article] to fetch.)"))))
+ (setq help-echo
+ (concat "Type \\[gnus-summary-show-complete-article] "
+ "to download complete article. " help-echo)))
(setq b (point))
(gnus-eval-format
gnus-mime-button-line-format gnus-mime-button-line-format-alist
@@ -5859,8 +5870,7 @@ all parts."
'keymap gnus-mime-button-map
'face gnus-article-button-face
'follow-link t
- 'help-echo
- "mouse-2: toggle the MIME part; down-mouse-3: more options")))
+ 'help-echo help-echo)))
(defvar gnus-displaying-mime nil)
diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el
index 480ed80..f306889 100644
--- a/lisp/gnus/gnus-registry.el
+++ b/lisp/gnus/gnus-registry.el
@@ -485,23 +485,25 @@ This is not required after changing
`gnus-registry-cache-file'."
(when from
(setq entry (cons (delete from (assoc 'group entry))
(assq-delete-all 'group entry))))
-
- (dolist (kv `((group ,to)
- (sender ,sender)
- (recipient ,@recipients)
- (subject ,subject)))
- (when (cadr kv)
- (let ((new (or (assq (car kv) entry)
- (list (car kv)))))
- (dolist (toadd (cdr kv))
- (unless (member toadd new)
- (setq new (append new (list toadd)))))
- (setq entry (cons new
- (assq-delete-all (car kv) entry))))))
- (gnus-message 10 "Gnus registry: new entry for %s is %S"
- id
- entry)
- (gnus-registry-insert db id entry)))
+ ;; Only keep the entry if the message is going to a new group, or
+ ;; it's still in some previous group.
+ (when (or to (alist-get 'group entry))
+ (dolist (kv `((group ,to)
+ (sender ,sender)
+ (recipient ,@recipients)
+ (subject ,subject)))
+ (when (cadr kv)
+ (let ((new (or (assq (car kv) entry)
+ (list (car kv)))))
+ (dolist (toadd (cdr kv))
+ (unless (member toadd new)
+ (setq new (append new (list toadd)))))
+ (setq entry (cons new
+ (assq-delete-all (car kv) entry))))))
+ (gnus-message 10 "Gnus registry: new entry for %s is %S"
+ id
+ entry)
+ (gnus-registry-insert db id entry))))
;; Function for nn{mail|imap}-split-fancy: look up all references in
;; the cache and if a match is found, return that group.
diff --git a/lisp/ido.el b/lisp/ido.el
index 8188340..ad71d46 100644
--- a/lisp/ido.el
+++ b/lisp/ido.el
@@ -499,11 +499,14 @@ This means that \\[ido-complete] must always be followed
by \\[ido-exit-minibuff
even when there is only one unique completion."
:type 'boolean)
-(defcustom ido-cannot-complete-command 'ido-completion-help
+(defcustom ido-cannot-complete-command #'ido-completion-auto-help
"Command run when `ido-complete' can't complete any more.
The most useful values are `ido-completion-help', which pops up a
-window with completion alternatives, or `ido-next-match' or
-`ido-prev-match', which cycle the buffer list."
+window with completion alternatives; `ido-completion-auto-help',
+which does the same but respects the value of
+`completion-auto-help'; and `ido-next-match' or `ido-prev-match',
+which cycle the buffer list."
+ :version "28.1"
:type 'function)
@@ -1546,7 +1549,7 @@ This function also adds a hook to the minibuffer."
((> (prefix-numeric-value arg) 0) 'both)
(t nil)))
- (ido-everywhere (if ido-everywhere 1 -1))
+ (ido-everywhere (if (and ido-mode ido-everywhere) 1 -1))
(when ido-mode
(ido-common-initialization)
@@ -3926,6 +3929,14 @@ If `ido-change-word-sub' cannot be found in WORD, return
nil."
(when (bobp)
(next-completion 1)))))
+(defun ido-completion-auto-help ()
+ "Call `ido-completion-help' if `completion-auto-help' is non-nil."
+ (interactive)
+ ;; Note: `completion-auto-help' could also be `lazy', but this value
+ ;; is irrelevant to ido, which is fundamentally eager, so it is
+ ;; treated the same as t.
+ (when completion-auto-help
+ (ido-completion-help)))
(defun ido-completion-help ()
"Show possible completions in the `ido-completion-buffer'."
diff --git a/lisp/json.el b/lisp/json.el
index 6f3b791..9002e86 100644
--- a/lisp/json.el
+++ b/lisp/json.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2006-2020 Free Software Foundation, Inc.
;; Author: Theresa O'Connor <address@hidden>
-;; Version: 1.4
+;; Version: 1.5
;; Keywords: convenience
;; This file is part of GNU Emacs.
@@ -29,11 +29,11 @@
;; Learn all about JSON here: <URL:http://json.org/>.
;; The user-serviceable entry points for the parser are the functions
-;; `json-read' and `json-read-from-string'. The encoder has a single
+;; `json-read' and `json-read-from-string'. The encoder has a single
;; entry point, `json-encode'.
;; Since there are several natural representations of key-value pair
-;; mappings in elisp (alist, plist, hash-table), `json-read' allows you
+;; mappings in Elisp (alist, plist, hash-table), `json-read' allows you
;; to specify which you'd prefer (see `json-object-type' and
;; `json-array-type').
@@ -55,6 +55,7 @@
;;; Code:
(require 'map)
+(require 'seq)
(require 'subr-x)
;; Parameters
@@ -113,8 +114,10 @@ Used only when `json-encoding-pretty-print' is non-nil.")
"If non-nil, then the output of `json-encode' will be pretty-printed.")
(defvar json-encoding-lisp-style-closings nil
- "If non-nil, ] and } closings will be formatted lisp-style,
-without indentation.")
+ "If non-nil, delimiters ] and } will be formatted Lisp-style.
+This means they will be placed on the same line as the last
+element of the respective array or object, without indentation.
+Used only when `json-encoding-pretty-print' is non-nil.")
(defvar json-encoding-object-sort-predicate nil
"Sorting predicate for JSON object keys during encoding.
@@ -124,88 +127,81 @@ instance, setting this to `string<' will have JSON object
keys
ordered alphabetically.")
(defvar json-pre-element-read-function nil
- "Function called (if non-nil) by `json-read-array' and
-`json-read-object' right before reading a JSON array or object,
-respectively. The function is called with one argument, which is
-the current JSON key.")
+ "If non-nil, a function to call before reading a JSON array or object.
+It is called by `json-read-array' and `json-read-object',
+respectively, with one argument, which is the current JSON key.")
(defvar json-post-element-read-function nil
- "Function called (if non-nil) by `json-read-array' and
-`json-read-object' right after reading a JSON array or object,
-respectively.")
+ "If non-nil, a function to call after reading a JSON array or object.
+It is called by `json-read-array' and `json-read-object',
+respectively, with no arguments.")
;;; Utilities
-(defun json-join (strings separator)
- "Join STRINGS with SEPARATOR."
- (mapconcat 'identity strings separator))
+(define-obsolete-function-alias 'json-join #'string-join "28.1")
(defun json-alist-p (list)
- "Non-null if and only if LIST is an alist with simple keys."
- (while (consp list)
- (setq list (if (and (consp (car list))
- (atom (caar list)))
- (cdr list)
- 'not-alist)))
+ "Non-nil if and only if LIST is an alist with simple keys."
+ (declare (pure t) (side-effect-free error-free))
+ (while (and (consp (car-safe list))
+ (atom (caar list))
+ (setq list (cdr list))))
(null list))
(defun json-plist-p (list)
- "Non-null if and only if LIST is a plist with keyword keys."
- (while (consp list)
- (setq list (if (and (keywordp (car list))
- (consp (cdr list)))
- (cddr list)
- 'not-plist)))
+ "Non-nil if and only if LIST is a plist with keyword keys."
+ (declare (pure t) (side-effect-free error-free))
+ (while (and (keywordp (car-safe list))
+ (consp (cdr list))
+ (setq list (cddr list))))
(null list))
-(defun json--plist-reverse (plist)
- "Return a copy of PLIST in reverse order.
-Unlike `reverse', this keeps the property-value pairs intact."
- (let (res)
- (while plist
- (let ((prop (pop plist))
- (val (pop plist)))
- (push val res)
- (push prop res)))
- res))
-
-(defun json--plist-to-alist (plist)
- "Return an alist of the property-value pairs in PLIST."
- (let (res)
- (while plist
- (let ((prop (pop plist))
- (val (pop plist)))
- (push (cons prop val) res)))
- (nreverse res)))
-
-(defmacro json--with-indentation (body)
+(defun json--plist-nreverse (plist)
+ "Return PLIST in reverse order.
+Unlike `nreverse', this keeps the ordering of each property
+relative to its value intact. Like `nreverse', this function may
+destructively modify PLIST to produce the result."
+ (let (prev (next (cddr plist)))
+ (while next
+ (setcdr (cdr plist) prev)
+ (setq prev plist plist next next (cddr next))
+ (setcdr (cdr plist) prev)))
+ plist)
+
+(defmacro json--with-indentation (&rest body)
+ "Evaluate BODY with the correct indentation for JSON encoding.
+This macro binds `json--encoding-current-indentation' according
+to `json-encoding-pretty-print' around BODY."
+ (declare (debug t) (indent 0))
`(let ((json--encoding-current-indentation
(if json-encoding-pretty-print
(concat json--encoding-current-indentation
json-encoding-default-indentation)
"")))
- ,body))
+ ,@body))
;; Reader utilities
(define-inline json-advance (&optional n)
- "Advance N characters forward."
+ "Advance N characters forward, or 1 character if N is nil.
+On reaching the end of the accessible region of the buffer, stop
+and signal an error."
(inline-quote (forward-char ,n)))
(define-inline json-peek ()
- "Return the character at point."
+ "Return the character at point.
+At the end of the accessible region of the buffer, return 0."
(inline-quote (following-char)))
(define-inline json-pop ()
- "Advance past the character at point, returning it."
+ "Advance past the character at point, returning it.
+Signal `json-end-of-file' if called at the end of the buffer."
(inline-quote
- (let ((char (json-peek)))
- (if (zerop char)
- (signal 'json-end-of-file nil)
- (json-advance)
- char))))
+ (prog1 (or (char-after)
+ (signal 'json-end-of-file ()))
+ (json-advance))))
(define-inline json-skip-whitespace ()
"Skip past the whitespace at point."
@@ -213,7 +209,7 @@ Unlike `reverse', this keeps the property-value pairs
intact."
;; https://www.ecma-international.org/publications/files/ECMA-ST/ECMA-404.pdf
;; or https://tools.ietf.org/html/rfc7159#section-2 for the
;; definition of whitespace in JSON.
- (inline-quote (skip-chars-forward "\t\r\n ")))
+ (inline-quote (skip-chars-forward "\t\n\r ")))
@@ -236,8 +232,8 @@ Unlike `reverse', this keeps the property-value pairs
intact."
;;; Paths
(defvar json--path '()
- "Used internally by `json-path-to-position' to keep track of
-the path during recursive calls to `json-read'.")
+ "Keeps track of the path during recursive calls to `json-read'.
+Used internally by `json-path-to-position'.")
(defun json--record-path (key)
"Record the KEY to the current JSON path.
@@ -248,7 +244,7 @@ Used internally by `json-path-to-position'."
"Check if the last parsed JSON structure passed POSITION.
Used internally by `json-path-to-position'."
(let ((start (caar json--path)))
- (when (< start position (+ (point) 1))
+ (when (< start position (1+ (point)))
(throw :json-path (list :path (nreverse (mapcar #'cdr json--path))
:match-start start
:match-end (point)))))
@@ -266,13 +262,13 @@ properties:
:path -- A list of strings and numbers forming the path to
the JSON element at the given position. Strings
denote object names, while numbers denote array
- indexes.
+ indices.
:match-start -- Position where the matched JSON element begins.
:match-end -- Position where the matched JSON element ends.
-This can for instance be useful to determine the path to a JSON
+This can, for instance, be useful to determine the path to a JSON
element in a deeply nested structure."
(save-excursion
(unless string
@@ -280,7 +276,7 @@ element in a deeply nested structure."
(let* ((json--path '())
(json-pre-element-read-function #'json--record-path)
(json-post-element-read-function
- (apply-partially #'json--check-position position))
+ (lambda () (json--check-position position)))
(path (catch :json-path
(if string
(json-read-from-string string)
@@ -290,38 +286,33 @@ element in a deeply nested structure."
;;; Keywords
-(defvar json-keywords '("true" "false" "null")
+(defconst json-keywords '("true" "false" "null")
"List of JSON keywords.")
+(make-obsolete-variable 'json-keywords "it is no longer used." "28.1")
;; Keyword parsing
+;; Characters that can follow a JSON value.
+(rx-define json--post-value (| (in "\t\n\r ,]}") eos))
+
(defun json-read-keyword (keyword)
- "Read a JSON keyword at point.
-KEYWORD is the keyword expected."
- (unless (member keyword json-keywords)
- (signal 'json-unknown-keyword (list keyword)))
- (mapc (lambda (char)
- (when (/= char (json-peek))
- (signal 'json-unknown-keyword
- (list (save-excursion
- (backward-word-strictly 1)
- (thing-at-point 'word)))))
- (json-advance))
- keyword)
- (json-skip-whitespace)
- (unless (looking-at "\\([],}]\\|$\\)")
- (signal 'json-unknown-keyword
- (list (save-excursion
- (backward-word-strictly 1)
- (thing-at-point 'word)))))
- (cond ((string-equal keyword "true") t)
- ((string-equal keyword "false") json-false)
- ((string-equal keyword "null") json-null)))
+ "Read the expected JSON KEYWORD at point."
+ (prog1 (cond ((equal keyword "true") t)
+ ((equal keyword "false") json-false)
+ ((equal keyword "null") json-null)
+ (t (signal 'json-unknown-keyword (list keyword))))
+ (or (looking-at-p keyword)
+ (signal 'json-unknown-keyword (list (thing-at-point 'word))))
+ (json-advance (length keyword))
+ (or (looking-at-p (rx json--post-value))
+ (signal 'json-unknown-keyword (list (thing-at-point 'word))))
+ (json-skip-whitespace)))
;; Keyword encoding
(defun json-encode-keyword (keyword)
"Encode KEYWORD as a JSON value."
+ (declare (side-effect-free t))
(cond ((eq keyword t) "true")
((eq keyword json-false) "false")
((eq keyword json-null) "null")))
@@ -330,37 +321,31 @@ KEYWORD is the keyword expected."
;; Number parsing
-(defun json-read-number (&optional sign)
- "Read the JSON number following point.
-The optional SIGN argument is for internal use.
-
-N.B.: Only numbers which can fit in Emacs Lisp's native number
-representation will be parsed correctly."
- ;; If SIGN is non-nil, the number is explicitly signed.
- (let ((number-regexp
- "\\([0-9]+\\)?\\(\\.[0-9]+\\)?\\([Ee][+-]?[0-9]+\\)?"))
- (cond ((and (null sign) (= (json-peek) ?-))
- (json-advance)
- (- (json-read-number t)))
- ((and (null sign) (= (json-peek) ?+))
- (json-advance)
- (json-read-number t))
- ((and (looking-at number-regexp)
- (or (match-beginning 1)
- (match-beginning 2)))
- (goto-char (match-end 0))
- (string-to-number (match-string 0)))
- (t (signal 'json-number-format (list (point)))))))
+(rx-define json--number
+ (: (? ?-) ; Sign.
+ (| (: (in "1-9") (* digit)) ?0) ; Integer.
+ (? ?. (+ digit)) ; Fraction.
+ (? (in "Ee") (? (in ?+ ?-)) (+ digit)))) ; Exponent.
+
+(defun json-read-number (&optional _sign)
+ "Read the JSON number following point."
+ (declare (advertised-calling-convention () "28.1"))
+ (or (looking-at (rx json--number))
+ (signal 'json-number-format (list (point))))
+ (goto-char (match-end 0))
+ (prog1 (string-to-number (match-string 0))
+ (or (looking-at-p (rx json--post-value))
+ (signal 'json-number-format (list (point))))
+ (json-skip-whitespace)))
;; Number encoding
-(defun json-encode-number (number)
- "Return a JSON representation of NUMBER."
- (format "%s" number))
+(defalias 'json-encode-number #'number-to-string
+ "Return a JSON representation of NUMBER.")
;;; Strings
-(defvar json-special-chars
+(defconst json-special-chars
'((?\" . ?\")
(?\\ . ?\\)
(?b . ?\b)
@@ -368,7 +353,7 @@ representation will be parsed correctly."
(?n . ?\n)
(?r . ?\r)
(?t . ?\t))
- "Characters which are escaped in JSON, with their elisp counterparts.")
+ "Characters which are escaped in JSON, with their Elisp counterparts.")
;; String parsing
@@ -378,48 +363,47 @@ representation will be parsed correctly."
(defun json-read-escaped-char ()
"Read the JSON string escaped character at point."
- ;; Skip over the '\'
+ ;; Skip over the '\'.
(json-advance)
- (let* ((char (json-pop))
- (special (assq char json-special-chars)))
+ (let ((char (json-pop)))
(cond
- (special (cdr special))
- ((not (eq char ?u)) char)
+ ((cdr (assq char json-special-chars)))
+ ((/= char ?u) char)
;; Special-case UTF-16 surrogate pairs,
;; cf. <https://tools.ietf.org/html/rfc7159#section-7>. Note that
;; this clause overlaps with the next one and therefore has to
;; come first.
((looking-at
- (rx (group (any "Dd") (any "89ABab") (= 2 (any xdigit)))
- "\\u" (group (any "Dd") (any "C-Fc-f") (= 2 (any xdigit)))))
+ (rx (group (any "Dd") (any "89ABab") (= 2 xdigit))
+ "\\u" (group (any "Dd") (any "C-Fc-f") (= 2 xdigit))))
(json-advance 10)
(json--decode-utf-16-surrogates
(string-to-number (match-string 1) 16)
(string-to-number (match-string 2) 16)))
((looking-at (rx (= 4 xdigit)))
- (let ((hex (match-string 0)))
- (json-advance 4)
- (string-to-number hex 16)))
+ (json-advance 4)
+ (string-to-number (match-string 0) 16))
(t
(signal 'json-string-escape (list (point)))))))
(defun json-read-string ()
"Read the JSON string at point."
- (unless (= (json-peek) ?\")
- (signal 'json-string-format (list "doesn't start with `\"'!")))
- ;; Skip over the '"'
+ ;; Skip over the '"'.
(json-advance)
(let ((characters '())
(char (json-peek)))
- (while (not (= char ?\"))
+ (while (/= char ?\")
(when (< char 32)
- (signal 'json-string-format (list (prin1-char char))))
+ (if (zerop char)
+ (signal 'json-end-of-file ())
+ (signal 'json-string-format (list char))))
(push (if (= char ?\\)
(json-read-escaped-char)
- (json-pop))
+ (json-advance)
+ char)
characters)
(setq char (json-peek)))
- ;; Skip over the '"'
+ ;; Skip over the '"'.
(json-advance)
(if characters
(concat (nreverse characters))
@@ -427,29 +411,47 @@ representation will be parsed correctly."
;; String encoding
+;; Escape only quotation mark, backslash, and the control
+;; characters U+0000 to U+001F (RFC 4627, ECMA-404).
+(rx-define json--escape (in ?\" ?\\ cntrl))
+
+(defvar json--long-string-threshold 200
+ "Length above which strings are considered long for JSON encoding.
+It is generally faster to manipulate such strings in a buffer
+rather than directly.")
+
+(defvar json--string-buffer nil
+ "Buffer used for encoding Lisp strings as JSON.
+Initialized lazily by `json-encode-string'.")
+
(defun json-encode-string (string)
"Return a JSON representation of STRING."
- ;; Reimplement the meat of `replace-regexp-in-string', for
- ;; performance (bug#20154).
- (let ((l (length string))
- (start 0)
- res mb)
- ;; Only escape quotation mark, backslash and the control
- ;; characters U+0000 to U+001F (RFC 4627, ECMA-404).
- (while (setq mb (string-match "[\"\\[:cntrl:]]" string start))
- (let* ((c (aref string mb))
- (special (rassq c json-special-chars)))
- (push (substring string start mb) res)
- (push (if special
- ;; Special JSON character (\n, \r, etc.).
- (string ?\\ (car special))
- ;; Fallback: UCS code point in \uNNNN form.
- (format "\\u%04x" c))
- res)
- (setq start (1+ mb))))
- (push (substring string start l) res)
- (push "\"" res)
- (apply #'concat "\"" (nreverse res))))
+ ;; Try to avoid buffer overhead in trivial cases, while also
+ ;; avoiding searching pathological strings for escape characters.
+ ;; Since `string-match-p' doesn't take a LIMIT argument, we use
+ ;; string length as our heuristic. See also bug#20154.
+ (if (and (< (length string) json--long-string-threshold)
+ (not (string-match-p (rx json--escape) string)))
+ (concat "\"" string "\"")
+ (with-current-buffer
+ (or json--string-buffer
+ (with-current-buffer (generate-new-buffer " *json-string*")
+ ;; This seems to afford decent performance gains.
+ (setq-local inhibit-modification-hooks t)
+ (setq json--string-buffer (current-buffer))))
+ (insert ?\" string)
+ (goto-char (1+ (point-min)))
+ (while (re-search-forward (rx json--escape) nil 'move)
+ (let ((char (preceding-char)))
+ (delete-char -1)
+ (insert ?\\ (or
+ ;; Special JSON character (\n, \r, etc.).
+ (car (rassq char json-special-chars))
+ ;; Fallback: UCS code point in \uNNNN form.
+ (format "u%04x" char)))))
+ (insert ?\")
+ ;; Empty buffer for next invocation.
+ (delete-and-extract-region (point-min) (point-max)))))
(defun json-encode-key (object)
"Return a JSON representation of OBJECT.
@@ -460,15 +462,13 @@ this signals `json-key-format'."
(signal 'json-key-format (list object)))
encoded))
-;;; JSON Objects
+;;; Objects
(defun json-new-object ()
- "Create a new Elisp object corresponding to a JSON object.
+ "Create a new Elisp object corresponding to an empty JSON object.
Please see the documentation of `json-object-type'."
- (cond ((eq json-object-type 'hash-table)
- (make-hash-table :test 'equal))
- (t
- ())))
+ (and (eq json-object-type 'hash-table)
+ (make-hash-table :test #'equal)))
(defun json-add-to-object (object key value)
"Add a new KEY -> VALUE association to OBJECT.
@@ -476,10 +476,10 @@ Returns the updated object, which you should save, e.g.:
(setq obj (json-add-to-object obj \"foo\" \"bar\"))
Please see the documentation of `json-object-type' and `json-key-type'."
(let ((json-key-type
- (or json-key-type
- (cdr (assq json-object-type '((hash-table . string)
- (alist . symbol)
- (plist . keyword)))))))
+ (cond (json-key-type)
+ ((eq json-object-type 'hash-table) 'string)
+ ((eq json-object-type 'alist) 'symbol)
+ ((eq json-object-type 'plist) 'keyword))))
(setq key
(cond ((eq json-key-type 'string)
key)
@@ -499,13 +499,13 @@ Please see the documentation of `json-object-type' and
`json-key-type'."
(defun json-read-object ()
"Read the JSON object at point."
- ;; Skip over the "{"
+ ;; Skip over the '{'.
(json-advance)
(json-skip-whitespace)
- ;; read key/value pairs until "}"
+ ;; Read key/value pairs until '}'.
(let ((elements (json-new-object))
key value)
- (while (not (= (json-peek) ?}))
+ (while (/= (json-peek) ?\})
(json-skip-whitespace)
(setq key (json-read-string))
(json-skip-whitespace)
@@ -520,94 +520,94 @@ Please see the documentation of `json-object-type' and
`json-key-type'."
(funcall json-post-element-read-function))
(setq elements (json-add-to-object elements key value))
(json-skip-whitespace)
- (when (/= (json-peek) ?})
+ (when (/= (json-peek) ?\})
(if (= (json-peek) ?,)
(json-advance)
(signal 'json-object-format (list "," (json-peek))))))
- ;; Skip over the "}"
+ ;; Skip over the '}'.
(json-advance)
(pcase json-object-type
('alist (nreverse elements))
- ('plist (json--plist-reverse elements))
+ ('plist (json--plist-nreverse elements))
(_ elements))))
;; Hash table encoding
(defun json-encode-hash-table (hash-table)
"Return a JSON representation of HASH-TABLE."
- (if json-encoding-object-sort-predicate
- (json-encode-alist (map-into hash-table 'list))
- (format "{%s%s}"
- (json-join
- (let (r)
- (json--with-indentation
- (maphash
- (lambda (k v)
- (push (format
- (if json-encoding-pretty-print
- "%s%s: %s"
- "%s%s:%s")
- json--encoding-current-indentation
- (json-encode-key k)
- (json-encode v))
- r))
- hash-table))
- r)
- json-encoding-separator)
- (if (or (not json-encoding-pretty-print)
- json-encoding-lisp-style-closings)
- ""
- json--encoding-current-indentation))))
+ (cond ((hash-table-empty-p hash-table) "{}")
+ (json-encoding-object-sort-predicate
+ (json--encode-alist (map-pairs hash-table) t))
+ (t
+ (let ((kv-sep (if json-encoding-pretty-print ": " ":"))
+ result)
+ (json--with-indentation
+ (maphash
+ (lambda (k v)
+ (push (concat json--encoding-current-indentation
+ (json-encode-key k)
+ kv-sep
+ (json-encode v))
+ result))
+ hash-table))
+ (concat "{"
+ (string-join (nreverse result) json-encoding-separator)
+ (and json-encoding-pretty-print
+ (not json-encoding-lisp-style-closings)
+ json--encoding-current-indentation)
+ "}")))))
;; List encoding (including alists and plists)
-(defun json-encode-alist (alist)
- "Return a JSON representation of ALIST."
+(defun json--encode-alist (alist &optional destructive)
+ "Return a JSON representation of ALIST.
+DESTRUCTIVE non-nil means it is safe to modify ALIST by
+side-effects."
(when json-encoding-object-sort-predicate
- (setq alist
- (sort alist (lambda (a b)
+ (setq alist (sort (if destructive alist (copy-sequence alist))
+ (lambda (a b)
(funcall json-encoding-object-sort-predicate
(car a) (car b))))))
- (format "{%s%s}"
- (json-join
- (json--with-indentation
- (mapcar (lambda (cons)
- (format (if json-encoding-pretty-print
- "%s%s: %s"
- "%s%s:%s")
- json--encoding-current-indentation
- (json-encode-key (car cons))
- (json-encode (cdr cons))))
- alist))
- json-encoding-separator)
- (if (or (not json-encoding-pretty-print)
- json-encoding-lisp-style-closings)
- ""
- json--encoding-current-indentation)))
+ (concat "{"
+ (let ((kv-sep (if json-encoding-pretty-print ": " ":")))
+ (json--with-indentation
+ (mapconcat (lambda (cons)
+ (concat json--encoding-current-indentation
+ (json-encode-key (car cons))
+ kv-sep
+ (json-encode (cdr cons))))
+ alist
+ json-encoding-separator)))
+ (and json-encoding-pretty-print
+ (not json-encoding-lisp-style-closings)
+ json--encoding-current-indentation)
+ "}"))
+
+(defun json-encode-alist (alist)
+ "Return a JSON representation of ALIST."
+ (if alist (json--encode-alist alist) "{}"))
(defun json-encode-plist (plist)
"Return a JSON representation of PLIST."
- (if json-encoding-object-sort-predicate
- (json-encode-alist (json--plist-to-alist plist))
- (let (result)
- (json--with-indentation
- (while plist
- (push (concat
- json--encoding-current-indentation
- (json-encode-key (car plist))
- (if json-encoding-pretty-print
- ": "
- ":")
- (json-encode (cadr plist)))
+ (cond ((null plist) "{}")
+ (json-encoding-object-sort-predicate
+ (json--encode-alist (map-pairs plist) t))
+ (t
+ (let ((kv-sep (if json-encoding-pretty-print ": " ":"))
result)
- (setq plist (cddr plist))))
- (concat "{"
- (json-join (nreverse result) json-encoding-separator)
- (if (and json-encoding-pretty-print
- (not json-encoding-lisp-style-closings))
- json--encoding-current-indentation
- "")
- "}"))))
+ (json--with-indentation
+ (while plist
+ (push (concat json--encoding-current-indentation
+ (json-encode-key (pop plist))
+ kv-sep
+ (json-encode (pop plist)))
+ result)))
+ (concat "{"
+ (string-join (nreverse result) json-encoding-separator)
+ (and json-encoding-pretty-print
+ (not json-encoding-lisp-style-closings)
+ json--encoding-current-indentation)
+ "}")))))
(defun json-encode-list (list)
"Return a JSON representation of LIST.
@@ -625,15 +625,17 @@ become JSON objects."
(defun json-read-array ()
"Read the JSON array at point."
- ;; Skip over the "["
+ ;; Skip over the '['.
(json-advance)
(json-skip-whitespace)
- ;; read values until "]"
- (let (elements)
- (while (not (= (json-peek) ?\]))
+ ;; Read values until ']'.
+ (let (elements
+ (len 0))
+ (while (/= (json-peek) ?\])
(json-skip-whitespace)
(when json-pre-element-read-function
- (funcall json-pre-element-read-function (length elements)))
+ (funcall json-pre-element-read-function len)
+ (setq len (1+ len)))
(push (json-read) elements)
(when json-post-element-read-function
(funcall json-post-element-read-function))
@@ -641,8 +643,8 @@ become JSON objects."
(when (/= (json-peek) ?\])
(if (= (json-peek) ?,)
(json-advance)
- (signal 'json-array-format (list ?, (json-peek))))))
- ;; Skip over the "]"
+ (signal 'json-array-format (list "," (json-peek))))))
+ ;; Skip over the ']'.
(json-advance)
(pcase json-array-type
('vector (nreverse (vconcat elements)))
@@ -653,42 +655,43 @@ become JSON objects."
(defun json-encode-array (array)
"Return a JSON representation of ARRAY."
(if (and json-encoding-pretty-print
- (> (length array) 0))
+ (not (seq-empty-p array)))
(concat
+ "["
(json--with-indentation
- (concat (format "[%s" json--encoding-current-indentation)
- (json-join (mapcar 'json-encode array)
- (format "%s%s"
- json-encoding-separator
+ (concat json--encoding-current-indentation
+ (mapconcat #'json-encode array
+ (concat json-encoding-separator
json--encoding-current-indentation))))
- (format "%s]"
- (if json-encoding-lisp-style-closings
- ""
- json--encoding-current-indentation)))
+ (unless json-encoding-lisp-style-closings
+ json--encoding-current-indentation)
+ "]")
(concat "["
- (mapconcat 'json-encode array json-encoding-separator)
+ (mapconcat #'json-encode array json-encoding-separator)
"]")))
-;;; JSON reader.
+;;; Reader
(defmacro json-readtable-dispatch (char)
- "Dispatch reader function for CHAR."
- (declare (debug (symbolp)))
- (let ((table
- '((?t json-read-keyword "true")
- (?f json-read-keyword "false")
- (?n json-read-keyword "null")
- (?{ json-read-object)
- (?\[ json-read-array)
- (?\" json-read-string)))
- res)
- (dolist (c '(?- ?+ ?. ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))
- (push (list c 'json-read-number) table))
- (pcase-dolist (`(,c . ,rest) table)
- (push `((eq ,char ,c) (,@rest)) res))
- `(cond ,@res (t (signal 'json-readtable-error (list ,char))))))
+ "Dispatch reader function for CHAR at point.
+If CHAR is nil, signal `json-end-of-file'."
+ (declare (debug t))
+ (macroexp-let2 nil char char
+ `(cond ,@(map-apply
+ (lambda (key expr)
+ `((eq ,char ,key) ,expr))
+ `((?\" ,#'json-read-string)
+ (?\[ ,#'json-read-array)
+ (?\{ ,#'json-read-object)
+ (?n ,#'json-read-keyword "null")
+ (?f ,#'json-read-keyword "false")
+ (?t ,#'json-read-keyword "true")
+ ,@(mapcar (lambda (c) (list c #'json-read-number))
+ '(?- ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))))
+ (,char (signal 'json-readtable-error (list ,char)))
+ (t (signal 'json-end-of-file ())))))
(defun json-read ()
"Parse and return the JSON object following point.
@@ -706,10 +709,7 @@ you will get the following structure returned:
((c . :json-false))])
(b . \"foo\"))"
(json-skip-whitespace)
- (let ((char (json-peek)))
- (if (zerop char)
- (signal 'json-end-of-file nil)
- (json-readtable-dispatch char))))
+ (json-readtable-dispatch (char-after)))
;; Syntactic sugar for the reader
@@ -724,12 +724,11 @@ you will get the following structure returned:
"Read the first JSON object contained in FILE and return it."
(with-temp-buffer
(insert-file-contents file)
- (goto-char (point-min))
(json-read)))
-;;; JSON encoder
+;;; Encoder
(defun json-encode (object)
"Return a JSON representation of OBJECT as a string.
@@ -737,20 +736,21 @@ you will get the following structure returned:
OBJECT should have a structure like one returned by `json-read'.
If an error is detected during encoding, an error based on
`json-error' is signaled."
- (cond ((memq object (list t json-null json-false))
- (json-encode-keyword object))
- ((stringp object) (json-encode-string object))
- ((keywordp object) (json-encode-string
- (substring (symbol-name object) 1)))
- ((listp object) (json-encode-list object))
- ((symbolp object) (json-encode-string
- (symbol-name object)))
- ((numberp object) (json-encode-number object))
- ((arrayp object) (json-encode-array object))
- ((hash-table-p object) (json-encode-hash-table object))
- (t (signal 'json-error (list object)))))
-
-;; Pretty printing & minimizing
+ (cond ((eq object t) (json-encode-keyword object))
+ ((eq object json-null) (json-encode-keyword object))
+ ((eq object json-false) (json-encode-keyword object))
+ ((stringp object) (json-encode-string object))
+ ((keywordp object) (json-encode-string
+ (substring (symbol-name object) 1)))
+ ((listp object) (json-encode-list object))
+ ((symbolp object) (json-encode-string
+ (symbol-name object)))
+ ((numberp object) (json-encode-number object))
+ ((arrayp object) (json-encode-array object))
+ ((hash-table-p object) (json-encode-hash-table object))
+ (t (signal 'json-error (list object)))))
+
+;;; Pretty printing & minimizing
(defun json-pretty-print-buffer (&optional minimize)
"Pretty-print current buffer.
@@ -769,9 +769,9 @@ MAX-SECS.")
With prefix argument MINIMIZE, minimize it instead."
(interactive "r\nP")
(let ((json-encoding-pretty-print (null minimize))
- ;; Distinguish an empty objects from 'null'
+ ;; Distinguish an empty object from 'null'.
(json-null :json-null)
- ;; Ensure that ordering is maintained
+ ;; Ensure that ordering is maintained.
(json-object-type 'alist)
(orig-buf (current-buffer))
error)
@@ -800,9 +800,7 @@ With prefix argument MINIMIZE, minimize it instead."
;; them.
(let ((space (buffer-substring
(point)
- (+ (point)
- (skip-chars-forward
- " \t\n" (point-max)))))
+ (+ (point) (skip-chars-forward " \t\n"))))
(json (json-read)))
(setq pos (point)) ; End of last good json-read.
(set-buffer tmp-buf)
@@ -832,14 +830,14 @@ With prefix argument MINIMIZE, minimize it instead."
"Pretty-print current buffer with object keys ordered.
With prefix argument MINIMIZE, minimize it instead."
(interactive "P")
- (let ((json-encoding-object-sort-predicate 'string<))
+ (let ((json-encoding-object-sort-predicate #'string<))
(json-pretty-print-buffer minimize)))
(defun json-pretty-print-ordered (begin end &optional minimize)
"Pretty-print the region with object keys ordered.
With prefix argument MINIMIZE, minimize it instead."
(interactive "r\nP")
- (let ((json-encoding-object-sort-predicate 'string<))
+ (let ((json-encoding-object-sort-predicate #'string<))
(json-pretty-print begin end minimize)))
(provide 'json)
diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el
index 293dfaa..42e7701 100644
--- a/lisp/jsonrpc.el
+++ b/lisp/jsonrpc.el
@@ -37,7 +37,6 @@
;;; Code:
(require 'cl-lib)
-(require 'json)
(require 'eieio)
(eval-when-compile (require 'subr-x))
(require 'warnings)
@@ -470,26 +469,35 @@ With optional CLEANUP, kill any associated buffers."
;;;
(define-error 'jsonrpc-error "jsonrpc-error")
-(defun jsonrpc--json-read ()
- "Read JSON object in buffer, move point to end of buffer."
- ;; TODO: I guess we can make these macros if/when jsonrpc.el
- ;; goes into Emacs core.
- (cond ((fboundp 'json-parse-buffer) (json-parse-buffer
- :object-type 'plist
- :null-object nil
- :false-object :json-false))
- (t (let ((json-object-type 'plist))
- (json-read)))))
-
-(defun jsonrpc--json-encode (object)
- "Encode OBJECT into a JSON string."
- (cond ((fboundp 'json-serialize) (json-serialize
- object
- :false-object :json-false
- :null-object nil))
- (t (let ((json-false :json-false)
- (json-null nil))
- (json-encode object)))))
+(defalias 'jsonrpc--json-read
+ (if (fboundp 'json-parse-buffer)
+ (lambda ()
+ (json-parse-buffer :object-type 'plist
+ :null-object nil
+ :false-object :json-false))
+ (require 'json)
+ (defvar json-object-type)
+ (declare-function json-read "json" ())
+ (lambda ()
+ (let ((json-object-type 'plist))
+ (json-read))))
+ "Read JSON object in buffer, move point to end of buffer.")
+
+(defalias 'jsonrpc--json-encode
+ (if (fboundp 'json-serialize)
+ (lambda (object)
+ (json-serialize object
+ :false-object :json-false
+ :null-object nil))
+ (require 'json)
+ (defvar json-false)
+ (defvar json-null)
+ (declare-function json-encode "json" (object))
+ (lambda (object)
+ (let ((json-false :json-false)
+ (json-null nil))
+ (json-encode object))))
+ "Encode OBJECT into a JSON string.")
(cl-defun jsonrpc--reply
(connection id &key (result nil result-supplied-p) (error nil
error-supplied-p))
diff --git a/lisp/language/tibet-util.el b/lisp/language/tibet-util.el
index 29fff91..8684cdb 100644
--- a/lisp/language/tibet-util.el
+++ b/lisp/language/tibet-util.el
@@ -43,13 +43,17 @@
("་" . "་")
("༔" . "༔")
;; Yes these are dirty. But ...
- ("༎ ༎" . ,(compose-string "༎ ༎" 0 3 [?༎ (Br . Bl) ? (Br . Bl) ?༎]))
+ ("༎ ༎" . ,(compose-string (copy-sequence "༎ ༎")
+ 0 3 [?༎ (Br . Bl) ? (Br . Bl) ?༎]))
("༄༅༅" . ,(compose-string
- "࿁࿂࿂࿂" 0 4
+ (copy-sequence "࿁࿂࿂࿂") 0 4
[?࿁ (Br . Bl) ?࿂ (Br . Bl) ?࿂ (Br . Bl) ?࿂]))
- ("༄༅" . ,(compose-string "࿁࿂࿂" 0 3 [?࿁ (Br . Bl) ?࿂ (Br . Bl) ?࿂]))
- ("༆" . ,(compose-string "࿁࿂༙" 0 3 [?࿁ (Br . Bl) ?࿂ (br . tr) ?༙]))
- ("༄" . ,(compose-string "࿁࿂" 0 2 [?࿁ (Br . Bl) ?࿂]))))
+ ("༄༅" . ,(compose-string (copy-sequence "࿁࿂࿂")
+ 0 3 [?࿁ (Br . Bl) ?࿂ (Br . Bl) ?࿂]))
+ ("༆" . ,(compose-string (copy-sequence "࿁࿂༙")
+ 0 3 [?࿁ (Br . Bl) ?࿂ (br . tr) ?༙]))
+ ("༄" . ,(compose-string (copy-sequence "࿁࿂")
+ 0 2 [?࿁ (Br . Bl) ?࿂]))))
;;;###autoload
(defun tibetan-char-p (ch)
diff --git a/lisp/mouse.el b/lisp/mouse.el
index f045e5b..640f10a 100644
--- a/lisp/mouse.el
+++ b/lisp/mouse.el
@@ -2580,7 +2580,7 @@ in a tooltip."
:type '(choice
(const :tag "Do not show tooltips" nil)
(const :tag "Show all text" t)
- (integer :tag "Show characters (max)" 256))
+ (integer :tag "Max number of characters to show" 256))
:version "26.1")
(defcustom mouse-drag-and-drop-region-show-cursor t
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index a6c1abd..2a70560 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -307,10 +307,10 @@ the default EWW buffer."
(insert (format "Loading %s..." url))
(goto-char (point-min)))
(let ((url-mime-accept-string eww-accept-content-types))
- (url-retrieve url 'eww-render
+ (url-retrieve url #'eww-render
(list url nil (current-buffer)))))
-(put 'eww 'browse-url-browser-kind 'internal)
+(function-put 'eww 'browse-url-browser-kind 'internal)
(defun eww--dwim-expand-url (url)
(setq url (string-trim url))
@@ -375,8 +375,8 @@ engine used."
(let ((region-string (buffer-substring (region-beginning) (region-end))))
(if (not (string-match-p "\\`[ \n\t\r\v\f]*\\'" region-string))
(eww region-string)
- (call-interactively 'eww)))
- (call-interactively 'eww)))
+ (call-interactively #'eww)))
+ (call-interactively #'eww)))
(defun eww-open-in-new-buffer ()
"Fetch link at point in a new EWW buffer."
@@ -1013,7 +1013,7 @@ just re-display the HTML already fetched."
(eww-display-html 'utf-8 url (plist-get eww-data :dom)
(point) (current-buffer)))
(let ((url-mime-accept-string eww-accept-content-types))
- (url-retrieve url 'eww-render
+ (url-retrieve url #'eww-render
(list url (point) (current-buffer) encode))))))
;; Form support.
@@ -1576,8 +1576,10 @@ If EXTERNAL is double prefix, browse in new buffer."
(cond
((not url)
(message "No link under point"))
- ((string-match "^mailto:"; url)
- (browse-url-mail url))
+ ((string-match-p "\\`mailto:"; url)
+ ;; This respects the user options `browse-url-handlers'
+ ;; and `browse-url-mailto-function'.
+ (browse-url url))
((and (consp external) (<= (car external) 4))
(funcall browse-url-secondary-browser-function url)
(shr--blink-link))
@@ -1615,7 +1617,7 @@ Use link at point if there is one, else the current
page's URL."
(eww-current-url))))
(if (not url)
(message "No URL under point")
- (url-retrieve url 'eww-download-callback (list url)))))
+ (url-retrieve url #'eww-download-callback (list url)))))
(defun eww-download-callback (status url)
(unless (plist-get status :error)
@@ -2128,12 +2130,12 @@ entries (if any) will be removed from the list.
Only the properties listed in `eww-desktop-data-save' are included.
Generally, the list should not include the (usually overly large)
:dom, :source and :text properties."
- (let ((history (mapcar 'eww-desktop-data-1
- (cons eww-data eww-history))))
- (list :history (if eww-desktop-remove-duplicates
- (cl-remove-duplicates
- history :test 'eww-desktop-history-duplicate)
- history))))
+ (let ((history (mapcar #'eww-desktop-data-1
+ (cons eww-data eww-history))))
+ (list :history (if eww-desktop-remove-duplicates
+ (cl-remove-duplicates
+ history :test #'eww-desktop-history-duplicate)
+ history))))
(defun eww-restore-desktop (file-name buffer-name misc-data)
"Restore an eww buffer from its desktop file record.
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 1f80ab7..03260c9 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -135,7 +135,7 @@ same domain as the main data."
This is used for cid: URLs, and the function is called with the
cid: URL as the argument.")
-(defvar shr-put-image-function 'shr-put-image
+(defvar shr-put-image-function #'shr-put-image
"Function called to put image and alt string.")
(defface shr-strike-through '((t :strike-through t))
@@ -365,25 +365,20 @@ If the URL is already at the front of the kill ring act
like
(shr-copy-url url)))
(defun shr--current-link-region ()
- (let ((current (get-text-property (point) 'shr-url))
- start)
- (save-excursion
- ;; Go to the beginning.
- (while (and (not (bobp))
- (equal (get-text-property (point) 'shr-url) current))
- (forward-char -1))
- (unless (equal (get-text-property (point) 'shr-url) current)
- (forward-char 1))
- (setq start (point))
- ;; Go to the end.
- (while (and (not (eobp))
- (equal (get-text-property (point) 'shr-url) current))
- (forward-char 1))
- (list start (point)))))
+ "Return the start and end positions of the URL at point, if any.
+Value is a pair of positions (START . END) if there is a non-nil
+`shr-url' text property at point; otherwise nil."
+ (when (get-text-property (point) 'shr-url)
+ (let* ((end (or (next-single-property-change (point) 'shr-url)
+ (point-max)))
+ (beg (or (previous-single-property-change end 'shr-url)
+ (point-min))))
+ (cons beg end))))
(defun shr--blink-link ()
- (let* ((region (shr--current-link-region))
- (overlay (make-overlay (car region) (cadr region))))
+ "Briefly fontify URL at point with the face `shr-selected-link'."
+ (when-let* ((region (shr--current-link-region))
+ (overlay (make-overlay (car region) (cdr region))))
(overlay-put overlay 'face 'shr-selected-link)
(run-at-time 1 nil (lambda ()
(delete-overlay overlay)))))
@@ -437,7 +432,7 @@ the URL of the image to the kill buffer instead."
(if (not url)
(message "No image under point")
(message "Inserting %s..." url)
- (url-retrieve url 'shr-image-fetched
+ (url-retrieve url #'shr-image-fetched
(list (current-buffer) (1- (point)) (point-marker))
t))))
@@ -463,7 +458,7 @@ size, and full-buffer size."
(when (> (- (point) start) 2)
(delete-region start (1- (point)))))
(message "Inserting %s..." url)
- (url-retrieve url 'shr-image-fetched
+ (url-retrieve url #'shr-image-fetched
(list (current-buffer) (1- (point)) (point-marker)
(list (cons 'size
(cond ((or (eq size 'default)
@@ -493,7 +488,7 @@ size, and full-buffer size."
((fboundp function)
(apply function dom args))
(t
- (apply 'shr-generic dom args)))))
+ (apply #'shr-generic dom args)))))
(defun shr-descend (dom)
(let ((function
@@ -730,9 +725,10 @@ size, and full-buffer size."
(let ((gap-start (point))
(face (get-text-property (point) 'face)))
;; Extend the background to the end of the line.
- (if face
- (insert (propertize "\n" 'face (shr-face-background face)))
- (insert "\n"))
+ (insert ?\n)
+ (when face
+ (put-text-property (1- (point)) (point)
+ 'face (shr-face-background face)))
(shr-indent)
(when (and (> (1- gap-start) (point-min))
(get-text-property (point) 'shr-url)
@@ -935,12 +931,11 @@ size, and full-buffer size."
(defun shr-indent ()
(when (> shr-indentation 0)
- (insert
- (if (not shr-use-fonts)
- (make-string shr-indentation ?\s)
- (propertize " "
- 'display
- `(space :width (,shr-indentation)))))))
+ (if (not shr-use-fonts)
+ (insert-char ?\s shr-indentation)
+ (insert ?\s)
+ (put-text-property (1- (point)) (point)
+ 'display `(space :width (,shr-indentation))))))
(defun shr-fontize-dom (dom &rest types)
(let ((start (point)))
@@ -987,16 +982,11 @@ the mouse click event."
(cond
((not url)
(message "No link under point"))
- ((string-match "^mailto:"; url)
- (browse-url-mail url))
+ (external
+ (funcall browse-url-secondary-browser-function url)
+ (shr--blink-link))
(t
- (if external
- (progn
- (funcall browse-url-secondary-browser-function url)
- (shr--blink-link))
- (browse-url url (if new-window
- (not browse-url-new-window-flag)
- browse-url-new-window-flag)))))))
+ (browse-url url (xor new-window browse-url-new-window-flag))))))
(defun shr-save-contents (directory)
"Save the contents from URL in a file."
@@ -1005,7 +995,7 @@ the mouse click event."
(if (not url)
(message "No link under point")
(url-retrieve (shr-encode-url url)
- 'shr-store-contents (list url directory)))))
+ #'shr-store-contents (list url directory)))))
(defun shr-store-contents (status url directory)
(unless (plist-get status :error)
@@ -1156,7 +1146,6 @@ width/height instead."
;; url-cache-extract autoloads url-cache.
(declare-function url-cache-create-filename "url-cache" (url))
-(autoload 'browse-url-mail "browse-url")
(defun shr-get-image-data (url)
"Get image data for URL.
@@ -1230,7 +1219,7 @@ START, and END. Note that START and END should be
markers."
(funcall shr-put-image-function
image (buffer-substring start end))
(delete-region (point) end))))
- (url-retrieve url 'shr-image-fetched
+ (url-retrieve url #'shr-image-fetched
(list (current-buffer) start end)
t t)))))
@@ -1679,7 +1668,7 @@ The preference is a float determined from
`shr-prefer-media-type'."
(or alt "")))
(insert " ")
(url-queue-retrieve
- (shr-encode-url url) 'shr-image-fetched
+ (shr-encode-url url) #'shr-image-fetched
(list (current-buffer) start (set-marker (make-marker) (point))
(list :width width :height height))
t
@@ -2006,12 +1995,11 @@ BASE is the URL of the HTML being rendered."
(cond
((null tbodies)
dom)
- ((= (length tbodies) 1)
+ ((null (cdr tbodies))
(car tbodies))
(t
;; Table with multiple tbodies. Convert into a single tbody.
- `(tbody nil ,@(cl-reduce 'append
- (mapcar 'dom-non-text-children tbodies)))))))
+ `(tbody nil ,@(mapcan #'dom-non-text-children tbodies))))))
(defun shr--fix-tbody (tbody)
(nconc (list 'tbody (dom-attributes tbody))
@@ -2311,8 +2299,8 @@ flags that control whether to collect or render objects."
(dolist (column row)
(aset natural-widths i (max (aref natural-widths i) column))
(setq i (1+ i)))))
- (let ((extra (- (apply '+ (append suggested-widths nil))
- (apply '+ (append widths nil))
+ (let ((extra (- (apply #'+ (append suggested-widths nil))
+ (apply #'+ (append widths nil))
(* shr-table-separator-pixel-width (1+ (length widths)))))
(expanded-columns 0))
;; We have extra, unused space, so divide this space amongst the
diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el
index 95cbfb8..24ee6fa 100644
--- a/lisp/net/tramp-archive.el
+++ b/lisp/net/tramp-archive.el
@@ -109,7 +109,7 @@
(eval-when-compile (require 'cl-lib))
;; Sometimes, compilation fails with "Variable binding depth exceeds
-;; max-specpdl-size".
+;; max-specpdl-size". Shall be fixed in Emacs 27.
(eval-and-compile
(let ((max-specpdl-size (* 2 max-specpdl-size))) (require 'tramp-gvfs)))
@@ -318,7 +318,10 @@ arguments to pass to the OPERATION."
(let* ((filename (apply #'tramp-archive-file-name-for-operation
operation args))
- (archive (tramp-archive-file-name-archive filename)))
+ (archive (tramp-archive-file-name-archive filename))
+ ;; Sometimes, it fails with "Variable binding depth exceeds
+ ;; max-specpdl-size". Shall be fixed in Emacs 27.
+ (max-specpdl-size (* 2 max-specpdl-size)))
;; `filename' could be a quoted file name. Or the file
;; archive could be a directory, see Bug#30293.
diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el
index 445098a..08bba33 100644
--- a/lisp/net/tramp-rclone.el
+++ b/lisp/net/tramp-rclone.el
@@ -477,7 +477,18 @@ file names."
(with-tramp-connection-property
(tramp-get-connection-process vec) "rclone-pid"
(catch 'pid
- (dolist (pid (list-system-processes)) ;; "pidof rclone" ?
+ (dolist
+ (pid
+ ;; Until Emacs 25, `process-attributes' could
+ ;; crash Emacs for some processes. So we use
+ ;; "pidof", which might not work everywhere.
+ (if (<= emacs-major-version 25)
+ (let ((default-directory temporary-file-directory))
+ (mapcar
+ #'string-to-number
+ (split-string
+ (shell-command-to-string "pidof rclone"))))
+ (list-system-processes)))
(and (string-match-p
(regexp-quote
(format "rclone mount %s:" (tramp-file-name-host vec)))
diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el
index 6edd03c..8bb1561 100644
--- a/lisp/net/webjump.el
+++ b/lisp/net/webjump.el
@@ -1,4 +1,4 @@
-;;; webjump.el --- programmable Web hotlist
+;;; webjump.el --- programmable Web hotlist -*- lexical-binding: t; -*-
;; Copyright (C) 1996-1997, 2001-2020 Free Software Foundation, Inc.
@@ -323,8 +323,7 @@ Please submit bug reports and other feedback to the author,
Neil W. Van Dyke
(defun webjump-read-url-choice (what urls &optional default)
;; Note: Convert this to use `webjump-read-choice' someday.
- (let* ((completions (mapcar (function (lambda (n) (cons n n)))
- urls))
+ (let* ((completions (mapcar (lambda (n) (cons n n)) urls))
(input (completing-read (concat what
;;(if default " (RET for default)" "")
": ")
diff --git a/lisp/obsolete/levents.el b/lisp/obsolete/levents.el
deleted file mode 100644
index 2ae1ca4..0000000
--- a/lisp/obsolete/levents.el
+++ /dev/null
@@ -1,292 +0,0 @@
-;;; levents.el --- emulate the Lucid event data type and associated functions
-
-;; Copyright (C) 1993, 2001-2020 Free Software Foundation, Inc.
-
-;; Maintainer: address@hidden
-;; Keywords: emulations
-;; Obsolete-since: 23.2
-
-;; 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/>.
-
-;;; Commentary:
-
-;; Things we cannot emulate in Lisp:
-;; It is not possible to emulate current-mouse-event as a variable,
-;; though it is not hard to obtain the data from (this-command-keys).
-
-;; We do not have a variable unread-command-event;
-;; instead, we have the more general unread-command-events.
-
-;; Our read-key-sequence and read-char are not precisely
-;; compatible with those in Lucid Emacs, but they should work ok.
-
-;;; Code:
-
-(defun next-command-event (event)
- (error "You must rewrite to use `read-command-event' instead of
`next-command-event'"))
-
-(defun next-event (event)
- (error "You must rewrite to use `read-event' instead of `next-event'"))
-
-(defun dispatch-event (event)
- (error "`dispatch-event' not supported"))
-
-;; Make events of type eval, menu and timeout
-;; execute properly.
-
-(define-key global-map [menu] 'execute-eval-event)
-(define-key global-map [timeout] 'execute-eval-event)
-(define-key global-map [eval] 'execute-eval-event)
-
-(defun execute-eval-event (event)
- (interactive "e")
- (funcall (nth 1 event) (nth 2 event)))
-
-(put 'eval 'event-symbol-elements '(eval))
-(put 'menu 'event-symbol-elements '(eval))
-(put 'timeout 'event-symbol-elements '(eval))
-
-(defun allocate-event ()
- "Return an empty event structure.
-In this emulation, it returns nil."
- nil)
-
-(defun button-press-event-p (obj)
- "True if the argument is a mouse-button-press event object."
- (and (consp obj) (symbolp (car obj))
- (memq 'down (get (car obj) 'event-symbol-elements))))
-
-(defun button-release-event-p (obj)
- "True if the argument is a mouse-button-release event object."
- (and (consp obj) (symbolp (car obj))
- (or (memq 'click (get (car obj) 'event-symbol-elements))
- (memq 'drag (get (car obj) 'event-symbol-elements)))))
-
-(defun button-event-p (obj)
- "True if the argument is a mouse-button press or release event object."
- (and (consp obj) (symbolp (car obj))
- (or (memq 'click (get (car obj) 'event-symbol-elements))
- (memq 'down (get (car obj) 'event-symbol-elements))
- (memq 'drag (get (car obj) 'event-symbol-elements)))))
-
-(defun mouse-event-p (obj)
- "True if the argument is a mouse-button press or release event object."
- (and (consp obj) (symbolp (car obj))
- (or (eq (car obj) 'mouse-movement)
- (memq 'click (get (car obj) 'event-symbol-elements))
- (memq 'down (get (car obj) 'event-symbol-elements))
- (memq 'drag (get (car obj) 'event-symbol-elements)))))
-
-(defun character-to-event (ch &optional event)
- "Converts a numeric ASCII value to an event structure, replete with
-bucky bits. The character is the first argument, and the event to fill
-in is the second. This function contains knowledge about what the codes
-mean -- for example, the number 9 is converted to the character Tab,
-not the distinct character Control-I.
-
-Beware that character-to-event and event-to-character are not strictly
-inverse functions, since events contain much more information than the
-ASCII character set can encode."
- ch)
-
-(defun copy-event (event1 &optional event2)
- "Make a copy of the given event object.
-In this emulation, `copy-event' just returns its argument."
- event1)
-
-(defun deallocate-event (event)
- "Allow the given event structure to be reused.
-In actual Lucid Emacs, you MUST NOT use this event object after
-calling this function with it. You will lose. It is not necessary to
-call this function, as event objects are garbage- collected like all
-other objects; however, it may be more efficient to explicitly
-deallocate events when you are sure that this is safe.
-
-This emulation does not actually deallocate or reuse events
-except via garbage collection and `cons'."
- nil)
-
-(defun enqueue-eval-event: (function object)
- "Add an eval event to the back of the queue.
-It will be the next event read after all pending events."
- (setq unread-command-events
- (nconc unread-command-events
- (list (list 'eval function object)))))
-
-(defun eval-event-p (obj)
- "True if the argument is an eval or menu event object."
- (eq (car-safe obj) 'eval))
-
-(defun event-button (event)
- "Return the button-number of the given mouse-button-press event."
- (let ((sym (car (get (car event) 'event-symbol-elements))))
- (cdr (assq sym '((mouse-1 . 1) (mouse-2 . 2) (mouse-3 . 3)
- (mouse-4 . 4) (mouse-5 . 5))))))
-
-(defun event-function (event)
- "Return the callback function of the given timeout, menu, or eval event."
- (nth 1 event))
-
-(defun event-key (event)
- "Return the KeySym of the given key-press event.
-The value is an ASCII printing character (not upper case) or a symbol."
- (if (symbolp event)
- (car (get event 'event-symbol-elements))
- (let ((base (logand event (1- (ash 1 18)))))
- (downcase (if (< base 32) (logior base 64) base)))))
-
-(defun event-object (event)
- "Return the function argument of the given timeout, menu, or eval event."
- (nth 2 event))
-
-(defun event-point (event)
- "Return the character position of the given mouse-related event.
-If the event did not occur over a window, or did
-not occur over text, then this returns nil. Otherwise, it returns an index
-into the buffer visible in the event's window."
- (posn-point (event-end event)))
-
-;; Return position of start of line LINE in WINDOW.
-;; If LINE is nil, return the last position
-;; visible in WINDOW.
-(defun event-closest-point-1 (window &optional line)
- (let* ((total (- (window-height window)
- (if (window-minibuffer-p window)
- 0 1)))
- (distance (or line total)))
- (save-excursion
- (goto-char (window-start window))
- (if (= (vertical-motion distance) distance)
- (if (not line)
- (forward-char -1)))
- (point))))
-
-(defun event-closest-point (event &optional start-window)
- "Return the nearest position to where EVENT ended its motion.
-This is computed for the window where EVENT's motion started,
-or for window WINDOW if that is specified."
- (or start-window (setq start-window (posn-window (event-start event))))
- (if (eq start-window (posn-window (event-end event)))
- (if (eq (event-point event) 'vertical-line)
- (event-closest-point-1 start-window
- (cdr (posn-col-row (event-end event))))
- (if (eq (event-point event) 'mode-line)
- (event-closest-point-1 start-window)
- (event-point event)))
- ;; EVENT ended in some other window.
- (let* ((end-w (posn-window (event-end event)))
- (end-w-top)
- (w-top (nth 1 (window-edges start-window))))
- (setq end-w-top
- (if (windowp end-w)
- (nth 1 (window-edges end-w))
- (/ (cdr (posn-x-y (event-end event)))
- (frame-char-height end-w))))
- (if (>= end-w-top w-top)
- (event-closest-point-1 start-window)
- (window-start start-window)))))
-
-(defun event-process (event)
- "Return the process of the given process-output event."
- (nth 1 event))
-
-(defun event-timestamp (event)
- "Return the timestamp of the given event object.
-In Lucid Emacs, this works for any kind of event.
-In this emulation, it returns nil for non-mouse-related events."
- (and (listp event)
- (posn-timestamp (event-end event))))
-
-(defun event-to-character (event &optional lenient)
- "Return the closest ASCII approximation to the given event object.
-If the event isn't a keypress, this returns nil.
-If the second argument is non-nil, then this is lenient in its
-translation; it will ignore modifier keys other than control and meta,
-and will ignore the shift modifier on those characters which have no
-shifted ASCII equivalent (Control-Shift-A for example, will be mapped to
-the same ASCII code as Control-A.) If the second arg is nil, then nil
-will be returned for events which have no direct ASCII equivalent."
- (if (symbolp event)
- (and lenient
- (cdr (assq event '((backspace . 8) (delete . 127) (tab . 9)
- (return . 10) (enter . 10)))))
- ;; Our interpretation is, ASCII means anything a number can represent.
- (if (integerp event)
- event nil)))
-
-(defun event-window (event)
- "Return the window of the given mouse-related event object."
- (posn-window (event-end event)))
-
-(defun event-x (event)
- "Return the X position in characters of the given mouse-related event."
- (/ (car (posn-col-row (event-end event)))
- (frame-char-width (window-frame (event-window event)))))
-
-(defun event-x-pixel (event)
- "Return the X position in pixels of the given mouse-related event."
- (car (posn-col-row (event-end event))))
-
-(defun event-y (event)
- "Return the Y position in characters of the given mouse-related event."
- (/ (cdr (posn-col-row (event-end event)))
- (frame-char-height (window-frame (event-window event)))))
-
-(defun event-y-pixel (event)
- "Return the Y position in pixels of the given mouse-related event."
- (cdr (posn-col-row (event-end event))))
-
-(defun key-press-event-p (obj)
- "True if the argument is a keyboard event object."
- (or (integerp obj)
- (and (symbolp obj)
- (get obj 'event-symbol-elements))))
-
-(defun menu-event-p (obj)
- "True if the argument is a menu event object."
- (eq (car-safe obj) 'menu))
-
-(defun motion-event-p (obj)
- "True if the argument is a mouse-motion event object."
- (eq (car-safe obj) 'mouse-movement))
-
-(defun read-command-event ()
- "Return the next keyboard or mouse event; execute other events.
-This is similar to the function `next-command-event' of Lucid Emacs,
-but different in that it returns the event rather than filling in
-an existing event object."
- (let (event)
- (while (progn
- (setq event (read-event))
- (not (or (key-press-event-p event)
- (button-press-event-p event)
- (button-release-event-p event)
- (menu-event-p event))))
- (let ((type (car-safe event)))
- (cond ((eq type 'eval)
- (funcall (nth 1 event) (nth 2 event)))
- ((eq type 'switch-frame)
- (select-frame (nth 1 event))))))
- event))
-
-(defun process-event-p (obj)
- "True if the argument is a process-output event object.
-GNU Emacs 19 does not currently generate process-output events."
- (eq (car-safe obj) 'process))
-
-(provide 'levents)
-
-;;; levents.el ends here
diff --git a/lisp/org/org-agenda.el b/lisp/org/org-agenda.el
index 5fe140d..689d134 100644
--- a/lisp/org/org-agenda.el
+++ b/lisp/org/org-agenda.el
@@ -2995,7 +2995,8 @@ Agenda views are separated by
`org-agenda-block-separator'."
(erase-buffer)
(insert (eval-when-compile
(let ((header
- "Press key for an agenda command:
+ (copy-sequence
+ "Press key for an agenda command:
-------------------------------- < Buffer, subtree/region restriction
a Agenda for current week or day > Remove restriction
t List of all TODO entries e Export agenda views
@@ -3004,7 +3005,7 @@ s Search for keywords M Like m, but
only TODO entries
/ Multi-occur S Like s, but only TODO entries
? Find :FLAGGED: entries C Configure custom agenda commands
* Toggle sticky agenda views # List stuck projects (!=configure)
-")
+"))
(start 0))
(while (string-match
"\\(^\\| \\|(\\)\\(\\S-\\)\\( \\|=\\)"
diff --git a/lisp/password-cache.el b/lisp/password-cache.el
index 86d802f..f500757 100644
--- a/lisp/password-cache.el
+++ b/lisp/password-cache.el
@@ -31,7 +31,8 @@
;; ;; Minibuffer prompt for password.
;; => "foo"
;;
-;; (password-cache-add "test" (copy-sequence "foo"))
+;; (password-cache-add "test" (read-passwd "Password? "))
+;; ;; Minibuffer prompt from read-passwd, which returns "foo".
;; => nil
;; (password-read "Password? " "test")
diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el
index 1e72352..17ffea5 100644
--- a/lisp/progmodes/cc-langs.el
+++ b/lisp/progmodes/cc-langs.el
@@ -3412,8 +3412,14 @@ regexp should match \"(\" if parentheses are valid in
declarators.
The end of the first submatch is taken as the end of the operator.
Identifier syntax is in effect when this is matched (see
`c-identifier-syntax-table')."
- t (if (c-lang-const c-type-modifier-kwds)
- (concat (regexp-opt (c-lang-const c-type-modifier-kwds) t) "\\>")
+ t (if (or (c-lang-const c-type-modifier-kwds) (c-lang-const c-modifier-kwds))
+ (concat
+ (regexp-opt (c--delete-duplicates
+ (append (c-lang-const c-type-modifier-kwds)
+ (c-lang-const c-modifier-kwds))
+ :test 'string-equal)
+ t)
+ "\\>")
;; Default to a regexp that never matches.
regexp-unmatchable)
;; Check that there's no "=" afterwards to avoid matching tokens
diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el
index d822788..b3b2374 100644
--- a/lisp/progmodes/cc-mode.el
+++ b/lisp/progmodes/cc-mode.el
@@ -795,7 +795,7 @@ compatible with old code; callers should always specify it."
(set (make-local-variable 'outline-level) 'c-outline-level)
(set (make-local-variable 'add-log-current-defun-function)
(lambda ()
- (or (c-cpp-define-name) (c-defun-name))))
+ (or (c-cpp-define-name) (car (c-defun-name-and-limits nil)))))
(let ((rfn (assq mode c-require-final-newline)))
(when rfn
(if (boundp 'mode-require-final-newline)
diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index 198f040..c72e9d9 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -1,7 +1,7 @@
;;; project.el --- Operations on the current project -*- lexical-binding: t;
-*-
;; Copyright (C) 2015-2020 Free Software Foundation, Inc.
-;; Version: 0.1.3
+;; Version: 0.2.0
;; Package-Requires: ((emacs "26.3"))
;; This is a GNU ELPA :core package. Avoid using functionality that
@@ -40,7 +40,7 @@
;; Infrastructure:
;;
;; Function `project-current', to determine the current project
-;; instance, and 5 (at the moment) generic functions that act on it.
+;; instance, and 4 (at the moment) generic functions that act on it.
;; This list is to be extended in future versions.
;;
;; Utils:
@@ -122,14 +122,25 @@ is not a part of a detectable project either, return a
(defun project--find-in-directory (dir)
(run-hook-with-args-until-success 'project-find-functions dir))
-(cl-defgeneric project-roots (project)
- "Return the list of directory roots of the current project.
+(cl-defgeneric project-root (project)
+ "Return root directory of the current project.
+
+It usually contains the main build file, dependencies
+configuration file, etc. Though neither is mandatory.
-Most often it's just one directory which contains the project
-build file and everything else in the project. But in more
-advanced configurations, a project can span multiple directories.
+The directory name must be absolute."
+ (car (project-roots project)))
-The directory names should be absolute.")
+(cl-defgeneric project-roots (project)
+ "Return the list containing the current project root.
+
+The function is obsolete, all projects have one main root anyway,
+and the rest should be possible to express through
+`project-external-roots'."
+ ;; FIXME: Can we specify project's version here?
+ ;; FIXME: Could we make this affect cl-defmethod calls too?
+ (declare (obsolete project-root "0.3.0"))
+ (list (project-root project)))
;; FIXME: Add MODE argument, like in `ede-source-paths'?
(cl-defgeneric project-external-roots (_project)
@@ -138,18 +149,14 @@ The directory names should be absolute.")
It's the list of directories outside of the project that are
still related to it. If the project deals with source code then,
depending on the languages used, this list should include the
-headers search path, load path, class path, and so on.
-
-The rule of thumb for whether to include a directory here, and
-not in `project-roots', is whether its contents are meant to be
-edited together with the rest of the project."
+headers search path, load path, class path, and so on."
nil)
(cl-defgeneric project-ignores (_project _dir)
"Return the list of glob patterns to ignore inside DIR.
Patterns can match both regular files and directories.
To root an entry, start it with `./'. To match directories only,
-end it with `/'. DIR must be one of `project-roots' or
+end it with `/'. DIR must be either `project-root' or one of
`project-external-roots'."
;; TODO: Document and support regexp ignores as used by Hg.
;; TODO: Support whitelist entries.
@@ -170,13 +177,13 @@ end it with `/'. DIR must be one of `project-roots' or
(t
(complete-with-action action all-files string pred)))))
-(cl-defmethod project-roots ((project (head transient)))
- (list (cdr project)))
+(cl-defmethod project-root ((project (head transient)))
+ (cdr project))
(cl-defgeneric project-files (project &optional dirs)
"Return a list of files in directories DIRS in PROJECT.
DIRS is a list of absolute directories; it should be some
-subset of the project roots and external roots.
+subset of the project root and external roots.
The default implementation uses `find-program'. PROJECT is used
to find the list of ignores for each directory."
@@ -184,7 +191,8 @@ to find the list of ignores for each directory."
(lambda (dir)
(project--files-in-directory dir
(project--dir-ignores project dir)))
- (or dirs (project-roots project))))
+ (or dirs
+ (list (project-root project)))))
(defun project--files-in-directory (dir ignores &optional files)
(require 'find-dired)
@@ -223,7 +231,7 @@ to find the list of ignores for each directory."
local-files))))
(defgroup project-vc nil
- "Project implementation using the VC package."
+ "Project implementation based on the VC package."
:version "25.1"
:group 'tools)
@@ -232,6 +240,15 @@ to find the list of ignores for each directory."
:type '(repeat string)
:safe 'listp)
+(defcustom project-vc-merge-submodules t
+ "Non-nil to consider submodules part of the parent project.
+
+After changing this variable (using Customize or .dir-locals.el)
+you might have to restart Emacs to see the effect."
+ :type 'boolean
+ :package-version '(project . "0.2.0")
+ :safe 'booleanp)
+
;; FIXME: Using the current approach, major modes are supposed to set
;; this variable to a buffer-local value. So we don't have access to
;; the "external roots" of language A from buffers of language B, which
@@ -273,38 +290,48 @@ backend implementation of `project-external-roots'.")
(pcase backend
('Git
;; Don't stop at submodule boundary.
- ;; Note: It's not necessarily clear-cut what should be
- ;; considered a "submodule" in the sense that some users
- ;; may setup things equivalent to "git-submodule"s using
- ;; "git worktree" instead (for example).
- ;; FIXME: Also it may be the case that some users would consider
- ;; a submodule as its own project. So there's a good chance
- ;; we will need to let the user tell us what is their intention.
(or (vc-file-getprop dir 'project-git-root)
- (let* ((root (vc-call-backend backend 'root dir))
- (gitfile (expand-file-name ".git" root)))
+ (let ((root (vc-call-backend backend 'root dir)))
(vc-file-setprop
dir 'project-git-root
- (cond
- ((file-directory-p gitfile)
- root)
- ((with-temp-buffer
- (insert-file-contents gitfile)
- (goto-char (point-min))
- ;; Kind of a hack to distinguish a submodule from
- ;; other cases of .git files pointing elsewhere.
- (looking-at "gitdir: [./]+/\\.git/modules/"))
- (let* ((parent (file-name-directory
- (directory-file-name root))))
- (vc-call-backend backend 'root parent)))
- (t root)))
- )))
+ (if (and
+ ;; FIXME: Invalidate the cache when the value
+ ;; of this variable changes.
+ project-vc-merge-submodules
+ (project--submodule-p root))
+ (let* ((parent (file-name-directory
+ (directory-file-name root))))
+ (vc-call-backend backend 'root parent))
+ root)))))
('nil nil)
(_ (ignore-errors (vc-call-backend backend 'root dir))))))
(and root (cons 'vc root))))
-(cl-defmethod project-roots ((project (head vc)))
- (list (cdr project)))
+(defun project--submodule-p (root)
+ ;; XXX: We only support Git submodules for now.
+ ;;
+ ;; For submodules, at least, we expect the users to prefer them to
+ ;; be considered part of the parent project. For those who don't,
+ ;; there is the custom var now.
+ ;;
+ ;; Some users may also set up things equivalent to Git submodules
+ ;; using "git worktree" (for example). However, we expect that most
+ ;; of them would prefer to treat those as separate projects anyway.
+ (let* ((gitfile (expand-file-name ".git" root)))
+ (cond
+ ((file-directory-p gitfile)
+ nil)
+ ((with-temp-buffer
+ (insert-file-contents gitfile)
+ (goto-char (point-min))
+ ;; Kind of a hack to distinguish a submodule from
+ ;; other cases of .git files pointing elsewhere.
+ (looking-at "gitdir: [./]+/\\.git/modules/"))
+ t)
+ (t nil))))
+
+(cl-defmethod project-root ((project (head vc)))
+ (cdr project))
(cl-defmethod project-external-roots ((project (head vc)))
(project-subtract-directories
@@ -312,7 +339,7 @@ backend implementation of `project-external-roots'.")
(mapcar
#'file-name-as-directory
(funcall project-vc-external-roots-function)))
- (project-roots project)))
+ (list (project-root project))))
(cl-defmethod project-files ((project (head vc)) &optional dirs)
(cl-mapcan
@@ -330,7 +357,8 @@ backend implementation of `project-external-roots'.")
(project--files-in-directory
dir
(project--dir-ignores project dir)))))
- (or dirs (project-roots project))))
+ (or dirs
+ (list (project-root project)))))
(declare-function vc-git--program-version "vc-git")
(declare-function vc-git--run-command-string "vc-git")
@@ -372,7 +400,9 @@ backend implementation of `project-external-roots'.")
submodules)))
(setq files
(apply #'nconc files sub-files)))
- files))
+ ;; 'git ls-files' returns duplicate entries for merge conflicts.
+ ;; XXX: Better solutions welcome, but this seems cheap enough.
+ (delete-consecutive-dups files)))
(`Hg
(let ((default-directory (expand-file-name (file-name-as-directory dir)))
args)
@@ -471,7 +501,7 @@ requires quoting, e.g. `\\[quoted-insert]<space>'."
(let* ((pr (project-current t))
(files
(if (not current-prefix-arg)
- (project-files pr (project-roots pr))
+ (project-files pr)
(let ((dir (read-directory-name "Base directory: "
nil default-directory t)))
(project--files-in-directory dir
@@ -482,9 +512,8 @@ requires quoting, e.g. `\\[quoted-insert]<space>'."
nil)))
(defun project--dir-ignores (project dir)
- (let* ((roots (project-roots project))
- (root (cl-find dir roots :test #'file-in-directory-p)))
- (if (not root)
+ (let ((root (project-root project)))
+ (if (not (file-in-directory-p dir root))
(project-ignores nil nil) ;The defaults.
(let ((ignores (project-ignores project root)))
(if (file-equal-p root dir)
@@ -502,8 +531,8 @@ pattern to search for."
(require 'xref)
(let* ((pr (project-current t))
(files
- (project-files pr (append
- (project-roots pr)
+ (project-files pr (cons
+ (project-root pr)
(project-external-roots pr)))))
(xref--show-xrefs
(apply-partially #'project--find-regexp-in-files regexp files)
@@ -541,23 +570,23 @@ pattern to search for."
;;;###autoload
(defun project-find-file ()
- "Visit a file (with completion) in the current project's roots.
+ "Visit a file (with completion) in the current project.
The completion default is the filename at point, if one is
recognized."
(interactive)
(let* ((pr (project-current t))
- (dirs (project-roots pr)))
+ (dirs (list (project-root pr))))
(project-find-file-in (thing-at-point 'filename) dirs pr)))
;;;###autoload
(defun project-or-external-find-file ()
- "Visit a file (with completion) in the current project's roots or external
roots.
+ "Visit a file (with completion) in the current project or external roots.
The completion default is the filename at point, if one is
recognized."
(interactive)
(let* ((pr (project-current t))
- (dirs (append
- (project-roots pr)
+ (dirs (cons
+ (project-root pr)
(project-external-roots pr))))
(project-find-file-in (thing-at-point 'filename) dirs pr)))
@@ -660,5 +689,13 @@ loop using the command \\[fileloop-continue]."
from to (project-files (project-current t)) 'default)
(fileloop-continue))
+;;;###autoload
+(defun project-compile ()
+ "Run `compile' in the project root."
+ (interactive)
+ (let* ((pr (project-current t))
+ (default-directory (project-root pr)))
+ (call-interactively 'compile)))
+
(provide 'project)
;;; project.el ends here
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el
index 67383b3..1ca9f01 100644
--- a/lisp/progmodes/python.el
+++ b/lisp/progmodes/python.el
@@ -261,7 +261,6 @@
(require 'ansi-color)
(require 'cl-lib)
(require 'comint)
-(require 'json)
(require 'tramp-sh)
;; Avoid compiler warnings
@@ -2276,6 +2275,18 @@ Do not set this variable directly, instead use
Do not set this variable directly, instead use
`python-shell-prompt-set-calculated-regexps'.")
+(defalias 'python--parse-json-array
+ (if (fboundp 'json-parse-string)
+ (lambda (string)
+ (json-parse-string string :array-type 'list))
+ (require 'json)
+ (defvar json-array-type)
+ (declare-function json-read-from-string "json" (string))
+ (lambda (string)
+ (let ((json-array-type 'list))
+ (json-read-from-string string))))
+ "Parse the JSON array in STRING into a Lisp list.")
+
(defun python-shell-prompt-detect ()
"Detect prompts for the current `python-shell-interpreter'.
When prompts can be retrieved successfully from the
@@ -2324,11 +2335,11 @@ detection and just returns nil."
(catch 'prompts
(dolist (line (split-string output "\n" t))
(let ((res
- ;; Check if current line is a valid JSON array
- (and (string= (substring line 0 2) "[\"")
+ ;; Check if current line is a valid JSON array.
+ (and (string-prefix-p "[\"" line)
(ignore-errors
- ;; Return prompts as a list, not vector
- (append (json-read-from-string line) nil)))))
+ ;; Return prompts as a list.
+ (python--parse-json-array line)))))
;; The list must contain 3 strings, where the first
;; is the input prompt, the second is the block
;; prompt and the last one is the output prompt. The
diff --git a/lisp/progmodes/which-func.el b/lisp/progmodes/which-func.el
index 1cee552..266f40a 100644
--- a/lisp/progmodes/which-func.el
+++ b/lisp/progmodes/which-func.el
@@ -186,7 +186,7 @@ and you want to simplify them for the mode line
"Non-nil means display current function name in mode line.
This makes a difference only if `which-function-mode' is non-nil.")
-(add-hook 'find-file-hook 'which-func-ff-hook t)
+(add-hook 'after-change-major-mode-hook 'which-func-ff-hook t)
(defun which-func-try-to-enable ()
(unless (or (not which-function-mode)
@@ -195,7 +195,7 @@ This makes a difference only if `which-function-mode' is
non-nil.")
(member major-mode which-func-modes)))))
(defun which-func-ff-hook ()
- "File find hook for Which Function mode.
+ "`after-change-major-mode-hook' for Which Function mode.
It creates the Imenu index for the buffer, if necessary."
(which-func-try-to-enable)
@@ -282,52 +282,55 @@ If no function name is found, return nil."
(when (null name)
(setq name (add-log-current-defun)))
;; If Imenu is loaded, try to make an index alist with it.
+ ;; If `add-log-current-defun' ran and gave nil, accept that.
(when (and (null name)
- (boundp 'imenu--index-alist)
- (or (null imenu--index-alist)
- ;; Update if outdated
- (/= (buffer-chars-modified-tick)
imenu-menubar-modified-tick))
- (null which-function-imenu-failed))
- (ignore-errors (imenu--make-index-alist t))
- (unless imenu--index-alist
- (set (make-local-variable 'which-function-imenu-failed) t)))
- ;; If we have an index alist, use it.
- (when (and (null name)
- (boundp 'imenu--index-alist) imenu--index-alist)
- (let ((alist imenu--index-alist)
- (minoffset (point-max))
- offset pair mark imstack namestack)
- ;; Elements of alist are either ("name" . marker), or
- ;; ("submenu" ("name" . marker) ... ). The list can be
- ;; arbitrarily nested.
- (while (or alist imstack)
- (if (null alist)
- (setq alist (car imstack)
- namestack (cdr namestack)
- imstack (cdr imstack))
-
- (setq pair (car-safe alist)
- alist (cdr-safe alist))
-
- (cond
- ((atom pair)) ; Skip anything not a cons.
-
- ((imenu--subalist-p pair)
- (setq imstack (cons alist imstack)
- namestack (cons (car pair) namestack)
- alist (cdr pair)))
-
- ((or (number-or-marker-p (setq mark (cdr pair)))
- (and (overlayp mark)
- (setq mark (overlay-start mark))))
- (when (and (>= (setq offset (- (point) mark)) 0)
- (< offset minoffset)) ; Find the closest item.
- (setq minoffset offset
- name (if (null which-func-imenu-joiner-function)
- (car pair)
- (funcall
- which-func-imenu-joiner-function
- (reverse (cons (car pair) namestack))))))))))))
+ (null add-log-current-defun-function))
+ (when (and (null name)
+ (boundp 'imenu--index-alist)
+ (or (null imenu--index-alist)
+ ;; Update if outdated
+ (/= (buffer-chars-modified-tick)
imenu-menubar-modified-tick))
+ (null which-function-imenu-failed))
+ (ignore-errors (imenu--make-index-alist t))
+ (unless imenu--index-alist
+ (set (make-local-variable 'which-function-imenu-failed) t)))
+ ;; If we have an index alist, use it.
+ (when (and (null name)
+ (boundp 'imenu--index-alist) imenu--index-alist)
+ (let ((alist imenu--index-alist)
+ (minoffset (point-max))
+ offset pair mark imstack namestack)
+ ;; Elements of alist are either ("name" . marker), or
+ ;; ("submenu" ("name" . marker) ... ). The list can be
+ ;; arbitrarily nested.
+ (while (or alist imstack)
+ (if (null alist)
+ (setq alist (car imstack)
+ namestack (cdr namestack)
+ imstack (cdr imstack))
+
+ (setq pair (car-safe alist)
+ alist (cdr-safe alist))
+
+ (cond
+ ((atom pair)) ; Skip anything not a cons.
+
+ ((imenu--subalist-p pair)
+ (setq imstack (cons alist imstack)
+ namestack (cons (car pair) namestack)
+ alist (cdr pair)))
+
+ ((or (number-or-marker-p (setq mark (cdr pair)))
+ (and (overlayp mark)
+ (setq mark (overlay-start mark))))
+ (when (and (>= (setq offset (- (point) mark)) 0)
+ (< offset minoffset)) ; Find the closest item.
+ (setq minoffset offset
+ name (if (null which-func-imenu-joiner-function)
+ (car pair)
+ (funcall
+ which-func-imenu-joiner-function
+ (reverse (cons (car pair)
namestack)))))))))))))
;; Filter the name if requested.
(when name
(if which-func-cleanup-function
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index 7d1ee70..2477884 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -268,8 +268,8 @@ find a search tool; by default, this uses \"find | grep\"
in the
(lambda (dir)
(xref-references-in-directory identifier dir))
(let ((pr (project-current t)))
- (append
- (project-roots pr)
+ (cons
+ (project-root pr)
(project-external-roots pr)))))
(cl-defgeneric xref-backend-apropos (backend pattern)
diff --git a/lisp/subr.el b/lisp/subr.el
index 971bce3..683e441 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -4117,7 +4117,11 @@ MODES is as for `set-default-file-modes'."
;; now, but it generates slower code.
(defmacro save-match-data (&rest body)
"Execute the BODY forms, restoring the global value of the match data.
-The value returned is the value of the last form in BODY."
+The value returned is the value of the last form in BODY.
+NOTE: The convention in Elisp is that any function, except for a few
+exceptions like car/assoc/+/goto-char, can clobber the match data,
+so `save-match-data' should normally be used to save *your* match data
+rather than your caller's match data."
;; It is better not to use backquote here,
;; because that makes a bootstrapping problem
;; if you need to recompile all the Lisp files using interpreted code.
diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el
index 0c9e656..a86c37c 100644
--- a/lisp/vc/vc-dir.el
+++ b/lisp/vc/vc-dir.el
@@ -1106,6 +1106,7 @@ the *vc-dir* buffer.
(set (make-local-variable 'vc-dir-backend) use-vc-backend)
(set (make-local-variable 'desktop-save-buffer)
'vc-dir-desktop-buffer-misc-data)
+ (setq-local bookmark-make-record-function #'vc-dir-bookmark-make-record)
(setq buffer-read-only t)
(when (boundp 'tool-bar-map)
(set (make-local-variable 'tool-bar-map) vc-dir-tool-bar-map))
@@ -1466,6 +1467,41 @@ These are the commands available for use in the file
status buffer:
'(vc-dir-mode . vc-dir-restore-desktop-buffer))
+;;; Support for bookmark.el (adapted from what info.el does).
+
+(declare-function bookmark-make-record-default
+ "bookmark" (&optional no-file no-context posn))
+(declare-function bookmark-prop-get "bookmark" (bookmark prop))
+(declare-function bookmark-default-handler "bookmark" (bmk))
+(declare-function bookmark-get-bookmark-record "bookmark" (bmk))
+
+(defun vc-dir-bookmark-make-record ()
+ "Make record used to bookmark a `vc-dir' buffer.
+This implements the `bookmark-make-record-function' type for
+`vc-dir' buffers."
+ (let* ((bookmark-name
+ (concat "(" (symbol-name vc-dir-backend) ") "
+ (file-name-nondirectory
+ (directory-file-name default-directory))))
+ (defaults (list bookmark-name default-directory)))
+ `(,bookmark-name
+ ,@(bookmark-make-record-default 'no-file)
+ (filename . ,default-directory)
+ (handler . vc-dir-bookmark-jump)
+ (defaults . ,defaults))))
+
+;;;###autoload
+(defun vc-dir-bookmark-jump (bmk)
+ "Provides the bookmark-jump behavior for a `vc-dir' buffer.
+This implements the `handler' function interface for the record
+type returned by `vc-dir-bookmark-make-record'."
+ (let* ((file (bookmark-prop-get bmk 'filename))
+ (buf (save-window-excursion
+ (vc-dir file) (current-buffer))))
+ (bookmark-default-handler
+ `("" (buffer . ,buf) . ,(bookmark-get-bookmark-record bmk)))))
+
+
(provide 'vc-dir)
;;; vc-dir.el ends here
diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el
index 2caa287..dcb5228 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -72,6 +72,7 @@
;; by git, so it's probably
;; not a good idea.
;; - merge-news (file) see `merge-file'
+;; - mark-resolved (file) OK
;; - steal-lock (file &optional revision) NOT NEEDED
;; HISTORY FUNCTIONS
;; * print-log (files buffer &optional shortlog start-revision limit) OK
@@ -1530,6 +1531,9 @@ This requires git 1.8.4 or later, for the \"-L\" option
of \"git log\"."
(defun vc-git-rename-file (old new)
(vc-git-command nil 0 (list old new) "mv" "-f" "--"))
+(defun vc-git-mark-resolved (files)
+ (vc-git-command nil 0 files "add"))
+
(defvar vc-git-extra-menu-map
(let ((map (make-sparse-keymap)))
(define-key map [git-grep]
diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el
index 2ca9d3e..ce72a49 100644
--- a/lisp/vc/vc-hooks.el
+++ b/lisp/vc/vc-hooks.el
@@ -498,7 +498,7 @@ status of this file. Otherwise, the value returned is one
of:
"Return the repository version from which FILE was checked out.
If FILE is not registered, this function always returns nil."
(or (vc-file-getprop file 'vc-working-revision)
- (progn
+ (let ((default-directory (file-name-directory file)))
(setq backend (or backend (vc-backend file)))
(when backend
(vc-file-setprop file 'vc-working-revision
diff --git a/lisp/version.el b/lisp/version.el
index 24da21c..b247232 100644
--- a/lisp/version.el
+++ b/lisp/version.el
@@ -163,8 +163,4 @@ correspond to the running Emacs.
Optional argument DIR is a directory to use instead of `source-directory'."
(emacs-repository-branch-git (or dir source-directory)))
-;; We put version info into the executable in the form that `ident' uses.
-(purecopy (concat "\n$Id: " (subst-char-in-string ?\n ?\s (emacs-version))
- " $\n"))
-
;;; version.el ends here
diff --git a/lisp/xml.el b/lisp/xml.el
index dc774a2..767cf04 100644
--- a/lisp/xml.el
+++ b/lisp/xml.el
@@ -1023,9 +1023,17 @@ entity references (e.g., replace each & with &).
XML character data must not contain & or < characters, nor the >
character under some circumstances. The XML spec does not impose
restriction on \" or \\=', but we just substitute for these too
-\(as is permitted by the spec)."
+\(as is permitted by the spec).
+
+If STRING contains characters that are invalid in XML (as defined
+by https://www.w3.org/TR/xml/#charsets), signal an error of type
+`xml-invalid-character'."
(with-temp-buffer
(insert string)
+ (goto-char (point-min))
+ (when (re-search-forward
+
"[^\u0009\u000A\u000D\u0020-\uD7FF\uE000-\uFFFD\U00010000-\U0010FFFF]")
+ (signal 'xml-invalid-character (list (char-before) (match-beginning 0))))
(dolist (substitution '(("&" . "&")
("<" . "<")
(">" . ">")
@@ -1036,6 +1044,9 @@ restriction on \" or \\=', but we just substitute for
these too
(replace-match (cdr substitution) t t nil)))
(buffer-string)))
+(define-error 'xml-invalid-character "Invalid XML character"
+ 'wrong-type-argument)
+
(defun xml-debug-print-internal (xml indent-string)
"Outputs the XML tree in the current buffer.
The first line is indented with INDENT-STRING."
diff --git a/src/alloc.c b/src/alloc.c
index d6ba4d9..76d49d2 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3429,23 +3429,6 @@ usage: (vector &rest OBJECTS) */)
return val;
}
-void
-make_byte_code (struct Lisp_Vector *v)
-{
- /* Don't allow the global zero_vector to become a byte code object. */
- eassert (0 < v->header.size);
-
- if (v->header.size > 1 && STRINGP (v->contents[1])
- && STRING_MULTIBYTE (v->contents[1]))
- /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
- earlier because they produced a raw 8-bit string for byte-code
- and now such a byte-code string is loaded as multibyte while
- raw 8-bit characters converted to multibyte form. Thus, now we
- must convert them back to the original unibyte form. */
- v->contents[1] = Fstring_as_unibyte (v->contents[1]);
- XSETPVECTYPE (v, PVEC_COMPILED);
-}
-
DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
doc: /* Create a byte-code object with specified arguments as elements.
The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
@@ -3464,8 +3447,14 @@ stack before executing the byte-code.
usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING
INTERACTIVE-SPEC &rest ELEMENTS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- Lisp_Object val = make_uninit_vector (nargs);
- struct Lisp_Vector *p = XVECTOR (val);
+ if (! ((FIXNUMP (args[COMPILED_ARGLIST])
+ || CONSP (args[COMPILED_ARGLIST])
+ || NILP (args[COMPILED_ARGLIST]))
+ && STRINGP (args[COMPILED_BYTECODE])
+ && !STRING_MULTIBYTE (args[COMPILED_BYTECODE])
+ && VECTORP (args[COMPILED_CONSTANTS])
+ && FIXNATP (args[COMPILED_STACK_DEPTH])))
+ error ("Invalid byte-code object");
/* We used to purecopy everything here, if purify-flag was set. This worked
OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
@@ -3474,10 +3463,8 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH
&optional DOCSTRING INT
copied into pure space, including its free variables, which is sometimes
just wasteful and other times plainly wrong (e.g. those free vars may want
to be setcar'd). */
-
- memcpy (p->contents, args, nargs * sizeof *args);
- make_byte_code (p);
- XSETCOMPILED (val, p);
+ Lisp_Object val = Fvector (nargs, args);
+ XSETPVECTYPE (XVECTOR (val), PVEC_COMPILED);
return val;
}
@@ -5019,8 +5006,9 @@ mark_stack (char const *bottom, char const *end)
#endif
}
-/* This is a trampoline function that flushes registers to the stack,
- and then calls FUNC. ARG is passed through to FUNC verbatim.
+/* flush_stack_call_func is the trampoline function that flushes
+ registers to the stack, and then calls FUNC. ARG is passed through
+ to FUNC verbatim.
This function must be called whenever Emacs is about to release the
global interpreter lock. This lets the garbage collector easily
@@ -5028,7 +5016,20 @@ mark_stack (char const *bottom, char const *end)
Lisp.
It is invalid to run any Lisp code or to allocate any GC memory
- from FUNC. */
+ from FUNC.
+
+ Note: all register spilling is done in flush_stack_call_func before
+ flush_stack_call_func1 is activated.
+
+ flush_stack_call_func1 is responsible for identifying the stack
+ address range to be scanned. It *must* be carefully kept as
+ noinline to make sure that registers has been spilled before it is
+ called, otherwise given __builtin_frame_address (0) typically
+ returns the frame pointer (base pointer) and not the stack pointer
+ [1] GC will miss to scan callee-saved registers content
+ (Bug#41357).
+
+ [1] <https://gcc.gnu.org/onlinedocs/gcc/Return-Address.html>. */
NO_INLINE void
flush_stack_call_func1 (void (*func) (void *arg), void *arg)
diff --git a/src/buffer.c b/src/buffer.c
index 53b3bd9..f1cb4d5 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -119,6 +119,7 @@ static void free_buffer_text (struct buffer *b);
static struct Lisp_Overlay * copy_overlays (struct buffer *, struct
Lisp_Overlay *);
static void modify_overlay (struct buffer *, ptrdiff_t, ptrdiff_t);
static Lisp_Object buffer_lisp_local_variables (struct buffer *, bool);
+static Lisp_Object buffer_local_variables_1 (struct buffer *buf, int offset,
Lisp_Object sym);
static void
CHECK_OVERLAY (Lisp_Object x)
@@ -1300,6 +1301,25 @@ buffer_lisp_local_variables (struct buffer *buf, bool
clone)
return result;
}
+
+/* If the variable at position index OFFSET in buffer BUF has a
+ buffer-local value, return (name . value). If SYM is non-nil,
+ it replaces name. */
+
+static Lisp_Object
+buffer_local_variables_1 (struct buffer *buf, int offset, Lisp_Object sym)
+{
+ int idx = PER_BUFFER_IDX (offset);
+ if ((idx == -1 || PER_BUFFER_VALUE_P (buf, idx))
+ && SYMBOLP (PER_BUFFER_SYMBOL (offset)))
+ {
+ sym = NILP (sym) ? PER_BUFFER_SYMBOL (offset) : sym;
+ Lisp_Object val = per_buffer_value (buf, offset);
+ return EQ (val, Qunbound) ? sym : Fcons (sym, val);
+ }
+ return Qnil;
+}
+
DEFUN ("buffer-local-variables", Fbuffer_local_variables,
Sbuffer_local_variables, 0, 1, 0,
doc: /* Return an alist of variables that are buffer-local in BUFFER.
@@ -1311,25 +1331,25 @@ No argument or nil as argument means use current buffer
as BUFFER. */)
{
struct buffer *buf = decode_buffer (buffer);
Lisp_Object result = buffer_lisp_local_variables (buf, 0);
+ Lisp_Object tem;
/* Add on all the variables stored in special slots. */
{
- int offset, idx;
+ int offset;
FOR_EACH_PER_BUFFER_OBJECT_AT (offset)
{
- idx = PER_BUFFER_IDX (offset);
- if ((idx == -1 || PER_BUFFER_VALUE_P (buf, idx))
- && SYMBOLP (PER_BUFFER_SYMBOL (offset)))
- {
- Lisp_Object sym = PER_BUFFER_SYMBOL (offset);
- Lisp_Object val = per_buffer_value (buf, offset);
- result = Fcons (EQ (val, Qunbound) ? sym : Fcons (sym, val),
- result);
- }
+ tem = buffer_local_variables_1 (buf, offset, Qnil);
+ if (!NILP (tem))
+ result = Fcons (tem, result);
}
}
+ tem = buffer_local_variables_1 (buf, PER_BUFFER_VAR_OFFSET (undo_list),
+ intern ("buffer-undo-list"));
+ if (!NILP (tem))
+ result = Fcons (tem, result);
+
return result;
}
diff --git a/src/bytecode.c b/src/bytecode.c
index 3c90544..5ac30aa 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -319,6 +319,19 @@ the third, MAXDEPTH, the maximum stack depth used in this
function.
If the third argument is incorrect, Emacs may crash. */)
(Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth)
{
+ if (! (STRINGP (bytestr) && VECTORP (vector) && FIXNATP (maxdepth)))
+ error ("Invalid byte-code");
+
+ if (STRING_MULTIBYTE (bytestr))
+ {
+ /* BYTESTR must have been produced by Emacs 20.2 or earlier
+ because it produced a raw 8-bit string for byte-code and now
+ such a byte-code string is loaded as multibyte with raw 8-bit
+ characters converted to multibyte form. Convert them back to
+ the original unibyte form. */
+ bytestr = Fstring_as_unibyte (bytestr);
+ }
+
return exec_byte_code (bytestr, vector, maxdepth, Qnil, 0, NULL);
}
@@ -344,21 +357,10 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector,
Lisp_Object maxdepth,
int volatile this_op = 0;
#endif
- CHECK_STRING (bytestr);
- CHECK_VECTOR (vector);
- CHECK_FIXNAT (maxdepth);
+ eassert (!STRING_MULTIBYTE (bytestr));
ptrdiff_t const_length = ASIZE (vector);
-
- if (STRING_MULTIBYTE (bytestr))
- /* BYTESTR must have been produced by Emacs 20.2 or the earlier
- because they produced a raw 8-bit string for byte-code and now
- such a byte-code string is loaded as multibyte while raw 8-bit
- characters converted to multibyte form. Thus, now we must
- convert them back to the originally intended unibyte form. */
- bytestr = Fstring_as_unibyte (bytestr);
-
- ptrdiff_t bytestr_length = SBYTES (bytestr);
+ ptrdiff_t bytestr_length = SCHARS (bytestr);
Lisp_Object *vectorp = XVECTOR (vector)->contents;
unsigned char quitcounter = 1;
diff --git a/src/emacs.c b/src/emacs.c
index e75cb58..93a837a 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -124,6 +124,11 @@ static const char emacs_version[] = PACKAGE_VERSION;
static const char emacs_copyright[] = COPYRIGHT;
static const char emacs_bugreport[] = PACKAGE_BUGREPORT;
+/* Put version info into the executable in the form that 'ident' uses. */
+char const EXTERNALLY_VISIBLE RCS_Id[]
+ = "$Id" ": GNU Emacs " PACKAGE_VERSION
+ " (" EMACS_CONFIGURATION " " EMACS_CONFIG_FEATURES ") $";
+
/* Empty lisp strings. To avoid having to build any others. */
Lisp_Object empty_unibyte_string, empty_multibyte_string;
diff --git a/src/eval.c b/src/eval.c
index 1091b08..37d466f 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -2913,6 +2913,21 @@ funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs,
Lisp_Object *args)
}
}
+/* Call the compiled Lisp function FUN. If we have not yet read FUN's
+ bytecode string and constants vector, fetch them from the file first. */
+
+static Lisp_Object
+fetch_and_exec_byte_code (Lisp_Object fun, Lisp_Object syms_left,
+ ptrdiff_t nargs, Lisp_Object *args)
+{
+ if (CONSP (AREF (fun, COMPILED_BYTECODE)))
+ Ffetch_bytecode (fun);
+ return exec_byte_code (AREF (fun, COMPILED_BYTECODE),
+ AREF (fun, COMPILED_CONSTANTS),
+ AREF (fun, COMPILED_STACK_DEPTH),
+ syms_left, nargs, args);
+}
+
static Lisp_Object
apply_lambda (Lisp_Object fun, Lisp_Object args, ptrdiff_t count)
{
@@ -2977,9 +2992,6 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
}
else if (COMPILEDP (fun))
{
- ptrdiff_t size = PVSIZE (fun);
- if (size <= COMPILED_STACK_DEPTH)
- xsignal1 (Qinvalid_function, fun);
syms_left = AREF (fun, COMPILED_ARGLIST);
if (FIXNUMP (syms_left))
/* A byte-code object with an integer args template means we
@@ -2991,15 +3003,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
argument-binding code below instead (as do all interpreted
functions, even lexically bound ones). */
{
- /* If we have not actually read the bytecode string
- and constants vector yet, fetch them from the file. */
- if (CONSP (AREF (fun, COMPILED_BYTECODE)))
- Ffetch_bytecode (fun);
- return exec_byte_code (AREF (fun, COMPILED_BYTECODE),
- AREF (fun, COMPILED_CONSTANTS),
- AREF (fun, COMPILED_STACK_DEPTH),
- syms_left,
- nargs, arg_vector);
+ return fetch_and_exec_byte_code (fun, syms_left, nargs, arg_vector);
}
lexenv = Qnil;
}
@@ -3068,16 +3072,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
if (CONSP (fun))
val = Fprogn (XCDR (XCDR (fun)));
else
- {
- /* If we have not actually read the bytecode string
- and constants vector yet, fetch them from the file. */
- if (CONSP (AREF (fun, COMPILED_BYTECODE)))
- Ffetch_bytecode (fun);
- val = exec_byte_code (AREF (fun, COMPILED_BYTECODE),
- AREF (fun, COMPILED_CONSTANTS),
- AREF (fun, COMPILED_STACK_DEPTH),
- Qnil, 0, 0);
- }
+ val = fetch_and_exec_byte_code (fun, Qnil, 0, NULL);
return unbind_to (count, val);
}
@@ -3162,9 +3157,6 @@ lambda_arity (Lisp_Object fun)
}
else if (COMPILEDP (fun))
{
- ptrdiff_t size = PVSIZE (fun);
- if (size <= COMPILED_STACK_DEPTH)
- xsignal1 (Qinvalid_function, fun);
syms_left = AREF (fun, COMPILED_ARGLIST);
if (FIXNUMP (syms_left))
return get_byte_code_arity (syms_left);
@@ -3207,13 +3199,11 @@ DEFUN ("fetch-bytecode", Ffetch_bytecode,
Sfetch_bytecode,
if (COMPILEDP (object))
{
- ptrdiff_t size = PVSIZE (object);
- if (size <= COMPILED_STACK_DEPTH)
- xsignal1 (Qinvalid_function, object);
if (CONSP (AREF (object, COMPILED_BYTECODE)))
{
tem = read_doc_string (AREF (object, COMPILED_BYTECODE));
- if (!CONSP (tem))
+ if (! (CONSP (tem) && STRINGP (XCAR (tem))
+ && VECTORP (XCDR (tem))))
{
tem = AREF (object, COMPILED_BYTECODE);
if (CONSP (tem) && STRINGP (XCAR (tem)))
@@ -3221,7 +3211,19 @@ DEFUN ("fetch-bytecode", Ffetch_bytecode,
Sfetch_bytecode,
else
error ("Invalid byte code");
}
- ASET (object, COMPILED_BYTECODE, XCAR (tem));
+
+ Lisp_Object bytecode = XCAR (tem);
+ if (STRING_MULTIBYTE (bytecode))
+ {
+ /* BYTECODE must have been produced by Emacs 20.2 or earlier
+ because it produced a raw 8-bit string for byte-code and now
+ such a byte-code string is loaded as multibyte with raw 8-bit
+ characters converted to multibyte form. Convert them back to
+ the original unibyte form. */
+ bytecode = Fstring_as_unibyte (bytecode);
+ }
+
+ ASET (object, COMPILED_BYTECODE, bytecode);
ASET (object, COMPILED_CONSTANTS, XCDR (tem));
}
}
diff --git a/src/fns.c b/src/fns.c
index 301bd59..b2f84b2 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -2508,26 +2508,36 @@ ARRAY is a vector, string, char-table, or bool-vector.
*/)
}
else if (STRINGP (array))
{
- register unsigned char *p = SDATA (array);
- int charval;
+ unsigned char *p = SDATA (array);
CHECK_CHARACTER (item);
- charval = XFIXNAT (item);
+ int charval = XFIXNAT (item);
size = SCHARS (array);
- if (STRING_MULTIBYTE (array))
+ if (size != 0)
{
+ CHECK_IMPURE (array, XSTRING (array));
unsigned char str[MAX_MULTIBYTE_LENGTH];
- int len = CHAR_STRING (charval, str);
- ptrdiff_t size_byte = SBYTES (array);
- ptrdiff_t product;
+ int len;
+ if (STRING_MULTIBYTE (array))
+ len = CHAR_STRING (charval, str);
+ else
+ {
+ str[0] = charval;
+ len = 1;
+ }
- if (INT_MULTIPLY_WRAPV (size, len, &product) || product != size_byte)
- error ("Attempt to change byte length of a string");
- for (idx = 0; idx < size_byte; idx++)
- *p++ = str[idx % len];
+ ptrdiff_t size_byte = SBYTES (array);
+ if (len == 1 && size == size_byte)
+ memset (p, str[0], size);
+ else
+ {
+ ptrdiff_t product;
+ if (INT_MULTIPLY_WRAPV (size, len, &product)
+ || product != size_byte)
+ error ("Attempt to change byte length of a string");
+ for (idx = 0; idx < size_byte; idx++)
+ *p++ = str[idx % len];
+ }
}
- else
- for (idx = 0; idx < size; idx++)
- p[idx] = charval;
}
else if (BOOL_VECTOR_P (array))
return bool_vector_fill (array, item);
@@ -2542,12 +2552,15 @@ DEFUN ("clear-string", Fclear_string, Sclear_string,
This makes STRING unibyte and may change its length. */)
(Lisp_Object string)
{
- ptrdiff_t len;
CHECK_STRING (string);
- len = SBYTES (string);
- memset (SDATA (string), 0, len);
- STRING_SET_CHARS (string, len);
- STRING_SET_UNIBYTE (string);
+ ptrdiff_t len = SBYTES (string);
+ if (len != 0 || STRING_MULTIBYTE (string))
+ {
+ CHECK_IMPURE (string, XSTRING (string));
+ memset (SDATA (string), 0, len);
+ STRING_SET_CHARS (string, len);
+ STRING_SET_UNIBYTE (string);
+ }
return Qnil;
}
diff --git a/src/lisp.h b/src/lisp.h
index 9e4d53c..4c0057b 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -1343,7 +1343,6 @@ dead_object (void)
#define XSETWINDOW(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW))
#define XSETTERMINAL(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_TERMINAL))
#define XSETSUBR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUBR))
-#define XSETCOMPILED(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_COMPILED))
#define XSETBUFFER(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BUFFER))
#define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE))
#define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR))
@@ -3943,7 +3942,6 @@ build_string (const char *str)
extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object);
extern Lisp_Object make_vector (ptrdiff_t, Lisp_Object);
-extern void make_byte_code (struct Lisp_Vector *);
extern struct Lisp_Vector *allocate_vector (ptrdiff_t);
extern struct Lisp_Vector *allocate_nil_vector (ptrdiff_t);
diff --git a/src/lread.c b/src/lread.c
index 01f359c..46725d9 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -3030,8 +3030,26 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
struct Lisp_Vector *vec;
tmp = read_vector (readcharfun, 1);
vec = XVECTOR (tmp);
- if (vec->header.size == 0)
- invalid_syntax ("Empty byte-code object");
+ if (! (COMPILED_STACK_DEPTH < vec->header.size
+ && (FIXNUMP (vec->contents[COMPILED_ARGLIST])
+ || CONSP (vec->contents[COMPILED_ARGLIST])
+ || NILP (vec->contents[COMPILED_ARGLIST]))
+ && ((STRINGP (vec->contents[COMPILED_BYTECODE])
+ && VECTORP (vec->contents[COMPILED_CONSTANTS]))
+ || CONSP (vec->contents[COMPILED_BYTECODE]))
+ && FIXNATP (vec->contents[COMPILED_STACK_DEPTH])))
+ invalid_syntax ("Invalid byte-code object");
+
+ if (STRING_MULTIBYTE (AREF (tmp, COMPILED_BYTECODE)))
+ {
+ /* BYTESTR must have been produced by Emacs 20.2 or earlier
+ because it produced a raw 8-bit string for byte-code and
+ now such a byte-code string is loaded as multibyte with
+ raw 8-bit characters converted to multibyte form.
+ Convert them back to the original unibyte form. */
+ ASET (tmp, COMPILED_BYTECODE,
+ Fstring_as_unibyte (AREF (tmp, COMPILED_BYTECODE)));
+ }
if (COMPILED_DOC_STRING < vec->header.size
&& EQ (AREF (tmp, COMPILED_DOC_STRING), make_fixnum (0)))
@@ -3050,7 +3068,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
ASET (tmp, COMPILED_DOC_STRING, make_ufixnum (hash));
}
- make_byte_code (vec);
+ XSETPVECTYPE (vec, PVEC_COMPILED);
return tmp;
}
if (c == '(')
@@ -3888,8 +3906,6 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag)
{
Lisp_Object tem = read_list (1, readcharfun);
ptrdiff_t size = list_length (tem);
- if (bytecodeflag && size <= COMPILED_STACK_DEPTH)
- error ("Invalid byte code");
Lisp_Object vector = make_nil_vector (size);
Lisp_Object *ptr = XVECTOR (vector)->contents;
diff --git a/src/w32.c b/src/w32.c
index d01a450..38bbc49 100644
--- a/src/w32.c
+++ b/src/w32.c
@@ -6519,7 +6519,15 @@ acl_get_file (const char *fname, acl_type_t type)
if (!get_file_security (fname, si, psd, sd_len, &sd_len))
{
xfree (psd);
- errno = EIO;
+ err = GetLastError ();
+ if (err == ERROR_NOT_SUPPORTED)
+ errno = ENOTSUP;
+ else if (err == ERROR_FILE_NOT_FOUND
+ || err == ERROR_PATH_NOT_FOUND
+ || err == ERROR_INVALID_NAME)
+ errno = ENOENT;
+ else
+ errno = EIO;
psd = NULL;
}
}
@@ -6530,6 +6538,8 @@ acl_get_file (const char *fname, acl_type_t type)
be encoded in the current ANSI codepage. */
|| err == ERROR_INVALID_NAME)
errno = ENOENT;
+ else if (err == ERROR_NOT_SUPPORTED)
+ errno = ENOTSUP;
else
errno = EIO;
}
diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el
index 56d1bdb..67f474c 100644
--- a/test/lisp/electric-tests.el
+++ b/test/lisp/electric-tests.el
@@ -547,6 +547,24 @@ baz\"\""
(should (equal "" (buffer-string))))))
+;;; Undoing
+(ert-deftest electric-pair-undo-unrelated-state ()
+ "Make sure `electric-pair-mode' does not confuse `undo' (bug#39680)."
+ (with-temp-buffer
+ (buffer-enable-undo)
+ (electric-pair-local-mode)
+ (let ((last-command-event ?\())
+ (ert-simulate-command '(self-insert-command 1)))
+ (undo-boundary)
+ (let ((last-command-event ?a))
+ (ert-simulate-command '(self-insert-command 1)))
+ (undo-boundary)
+ (ert-simulate-command '(undo))
+ (let ((last-command-event ?\())
+ (ert-simulate-command '(self-insert-command 1)))
+ (should (string= (buffer-string) "(())"))))
+
+
;;; Electric newlines between pairs
;;; TODO: better tests
(ert-deftest electric-pair-open-extra-newline ()
diff --git a/test/lisp/emacs-lisp/syntax-tests.el
b/test/lisp/emacs-lisp/syntax-tests.el
new file mode 100644
index 0000000..9d4c411
--- /dev/null
+++ b/test/lisp/emacs-lisp/syntax-tests.el
@@ -0,0 +1,67 @@
+;;; syntax-tests.el --- tests for syntax.el -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2020 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/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'syntax)
+
+(ert-deftest syntax-propertize--shift-groups-and-backrefs ()
+ "Test shifting of numbered groups and back-references in regexps."
+ ;; A numbered group must be shifted.
+ (should
+ (string=
+ (syntax-propertize--shift-groups-and-backrefs
+ "\\(?2:[abc]+\\)foobar" 2)
+ "\\(?4:[abc]+\\)foobar"))
+ ;; A back-reference \1 on a normal sub-regexp context must be
+ ;; shifted.
+ (should
+ (string=
+ (syntax-propertize--shift-groups-and-backrefs "\\(a\\)\\1" 2)
+ "\\(a\\)\\3"))
+ ;; Shifting must not happen if the \1 appears in a character class,
+ ;; or in a \{\} repetition construct (although \1 isn't valid there
+ ;; anyway).
+ (let ((rx-with-class "\\(a\\)[\\1-2]")
+ (rx-with-rep "\\(a\\)\\{1,\\1\\}"))
+ (should
+ (string=
+ (syntax-propertize--shift-groups-and-backrefs rx-with-class 2)
+ rx-with-class))
+ (should
+ (string=
+ (syntax-propertize--shift-groups-and-backrefs rx-with-rep 2)
+ rx-with-rep)))
+ ;; Now numbered groups and back-references in combination.
+ (should
+ (string=
+ (syntax-propertize--shift-groups-and-backrefs
+ "\\(?2:[abc]+\\)foo\\(\\2\\)" 2)
+ "\\(?4:[abc]+\\)foo\\(\\4\\)"))
+ ;; Emacs supports only the back-references \1,...,\9, so when a
+ ;; shift would result in \10 or more, an error must be signalled.
+ (should-error
+ (syntax-propertize--shift-groups-and-backrefs "\\(a\\)\\3" 7)))
+
+;; Local Variables:
+;; no-byte-compile: t
+;; End:
+
+;;; syntax-tests.el ends here.
diff --git a/test/lisp/json-tests.el b/test/lisp/json-tests.el
index ac9706a..a0e8c87 100644
--- a/test/lisp/json-tests.el
+++ b/test/lisp/json-tests.el
@@ -21,11 +21,16 @@
(require 'ert)
(require 'json)
+(require 'map)
+(require 'seq)
+
+(eval-when-compile
+ (require 'cl-lib))
(defmacro json-tests--with-temp-buffer (content &rest body)
"Create a temporary buffer with CONTENT and evaluate BODY there.
Point is moved to beginning of the buffer."
- (declare (indent 1))
+ (declare (debug t) (indent 1))
`(with-temp-buffer
(insert ,content)
(goto-char (point-min))
@@ -33,66 +38,107 @@ Point is moved to beginning of the buffer."
;;; Utilities
-(ert-deftest test-json-join ()
- (should (equal (json-join '() ", ") ""))
- (should (equal (json-join '("a" "b" "c") ", ") "a, b, c")))
-
(ert-deftest test-json-alist-p ()
(should (json-alist-p '()))
- (should (json-alist-p '((a 1) (b 2) (c 3))))
- (should (json-alist-p '((:a 1) (:b 2) (:c 3))))
- (should (json-alist-p '(("a" 1) ("b" 2) ("c" 3))))
+ (should (json-alist-p '((()))))
+ (should (json-alist-p '((a))))
+ (should (json-alist-p '((a . 1))))
+ (should (json-alist-p '((a . 1) (b 2) (c))))
+ (should (json-alist-p '((:a) (:b 2) (:c . 3))))
+ (should (json-alist-p '(("a" . 1) ("b" 2) ("c"))))
+ (should-not (json-alist-p '(())))
+ (should-not (json-alist-p '(a)))
+ (should-not (json-alist-p '(a . 1)))
+ (should-not (json-alist-p '((a . 1) . [])))
+ (should-not (json-alist-p '((a . 1) [])))
(should-not (json-alist-p '(:a :b :c)))
(should-not (json-alist-p '(:a 1 :b 2 :c 3)))
- (should-not (json-alist-p '((:a 1) (:b 2) 3))))
+ (should-not (json-alist-p '((:a 1) (:b 2) 3)))
+ (should-not (json-alist-p '((:a 1) (:b 2) ())))
+ (should-not (json-alist-p '(((a) 1) (b 2) (c 3))))
+ (should-not (json-alist-p []))
+ (should-not (json-alist-p [(a . 1)]))
+ (should-not (json-alist-p #s(hash-table))))
(ert-deftest test-json-plist-p ()
(should (json-plist-p '()))
+ (should (json-plist-p '(:a 1)))
(should (json-plist-p '(:a 1 :b 2 :c 3)))
+ (should (json-plist-p '(:a :b)))
+ (should (json-plist-p '(:a :b :c :d)))
+ (should-not (json-plist-p '(a)))
+ (should-not (json-plist-p '(a 1)))
(should-not (json-plist-p '(a 1 b 2 c 3)))
(should-not (json-plist-p '("a" 1 "b" 2 "c" 3)))
+ (should-not (json-plist-p '(:a)))
(should-not (json-plist-p '(:a :b :c)))
- (should-not (json-plist-p '((:a 1) (:b 2) (:c 3)))))
-
-(ert-deftest test-json-plist-reverse ()
- (should (equal (json--plist-reverse '()) '()))
- (should (equal (json--plist-reverse '(:a 1)) '(:a 1)))
- (should (equal (json--plist-reverse '(:a 1 :b 2 :c 3))
+ (should-not (json-plist-p '(:a 1 :b 2 :c)))
+ (should-not (json-plist-p '((:a 1))))
+ (should-not (json-plist-p '((:a 1) (:b 2) (:c 3))))
+ (should-not (json-plist-p []))
+ (should-not (json-plist-p [:a 1]))
+ (should-not (json-plist-p #s(hash-table))))
+
+(ert-deftest test-json-plist-nreverse ()
+ (should (equal (json--plist-nreverse '()) '()))
+ (should (equal (json--plist-nreverse (list :a 1)) '(:a 1)))
+ (should (equal (json--plist-nreverse (list :a 1 :b 2)) '(:b 2 :a 1)))
+ (should (equal (json--plist-nreverse (list :a 1 :b 2 :c 3))
'(:c 3 :b 2 :a 1))))
-(ert-deftest test-json-plist-to-alist ()
- (should (equal (json--plist-to-alist '()) '()))
- (should (equal (json--plist-to-alist '(:a 1)) '((:a . 1))))
- (should (equal (json--plist-to-alist '(:a 1 :b 2 :c 3))
- '((:a . 1) (:b . 2) (:c . 3)))))
-
(ert-deftest test-json-advance ()
(json-tests--with-temp-buffer "{ \"a\": 1 }"
(json-advance 0)
- (should (= (point) (point-min)))
+ (should (bobp))
+ (json-advance)
+ (should (= (point) (1+ (point-min))))
+ (json-advance 0)
+ (should (= (point) (1+ (point-min))))
+ (json-advance 1)
+ (should (= (point) (+ (point-min) 2)))
(json-advance 3)
- (should (= (point) (+ (point-min) 3)))))
+ (should (= (point) (+ (point-min) 5)))))
(ert-deftest test-json-peek ()
(json-tests--with-temp-buffer ""
(should (zerop (json-peek))))
(json-tests--with-temp-buffer "{ \"a\": 1 }"
- (should (equal (json-peek) ?{))))
+ (should (= (json-peek) ?\{))
+ (goto-char (1- (point-max)))
+ (should (= (json-peek) ?\}))
+ (json-advance)
+ (should (zerop (json-peek)))))
(ert-deftest test-json-pop ()
(json-tests--with-temp-buffer ""
(should-error (json-pop) :type 'json-end-of-file))
(json-tests--with-temp-buffer "{ \"a\": 1 }"
- (should (equal (json-pop) ?{))
- (should (= (point) (+ (point-min) 1)))))
+ (should (= (json-pop) ?\{))
+ (should (= (point) (1+ (point-min))))
+ (goto-char (1- (point-max)))
+ (should (= (json-pop) ?\}))
+ (should-error (json-pop) :type 'json-end-of-file)))
(ert-deftest test-json-skip-whitespace ()
+ (json-tests--with-temp-buffer ""
+ (json-skip-whitespace)
+ (should (bobp))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "{}"
+ (json-skip-whitespace)
+ (should (bobp))
+ (json-advance)
+ (json-skip-whitespace)
+ (should (= (point) (1+ (point-min))))
+ (json-advance)
+ (json-skip-whitespace)
+ (should (eobp)))
(json-tests--with-temp-buffer "\t\r\n\f\b { \"a\": 1 }"
(json-skip-whitespace)
- (should (equal (char-after) ?\f)))
+ (should (= (json-peek) ?\f)))
(json-tests--with-temp-buffer "\t\r\n\t { \"a\": 1 }"
(json-skip-whitespace)
- (should (equal (char-after) ?{))))
+ (should (= (json-peek) ?\{))))
;;; Paths
@@ -113,59 +159,243 @@ Point is moved to beginning of the buffer."
(ert-deftest test-json-path-to-position-no-match ()
(let* ((json-string "{\"foo\": {\"bar\": \"baz\"}}")
(matched-path (json-path-to-position 5 json-string)))
- (should (null matched-path))))
+ (should-not matched-path)))
;;; Keywords
(ert-deftest test-json-read-keyword ()
(json-tests--with-temp-buffer "true"
- (should (json-read-keyword "true")))
+ (should (eq (json-read-keyword "true") t))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "true "
+ (should (eq (json-read-keyword "true") t))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "true}"
+ (should (eq (json-read-keyword "true") t))
+ (should (= (point) (+ (point-min) 4))))
+ (json-tests--with-temp-buffer "true false"
+ (should (eq (json-read-keyword "true") t))
+ (should (= (point) (+ (point-min) 5))))
+ (json-tests--with-temp-buffer "true }"
+ (should (eq (json-read-keyword "true") t))
+ (should (= (point) (+ (point-min) 5))))
+ (json-tests--with-temp-buffer "true |"
+ (should (eq (json-read-keyword "true") t))
+ (should (= (point) (+ (point-min) 5))))
+ (json-tests--with-temp-buffer "false"
+ (let ((json-false 'false))
+ (should (eq (json-read-keyword "false") 'false)))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "null"
+ (let ((json-null 'null))
+ (should (eq (json-read-keyword "null") 'null)))
+ (should (eobp))))
+
+(ert-deftest test-json-read-keyword-invalid ()
+ (json-tests--with-temp-buffer ""
+ (should (equal (should-error (json-read-keyword ""))
+ '(json-unknown-keyword "")))
+ (should (equal (should-error (json-read-keyword "true"))
+ '(json-unknown-keyword ()))))
(json-tests--with-temp-buffer "true"
- (should-error
- (json-read-keyword "false") :type 'json-unknown-keyword))
+ (should (equal (should-error (json-read-keyword "false"))
+ '(json-unknown-keyword "true"))))
(json-tests--with-temp-buffer "foo"
- (should-error
- (json-read-keyword "foo") :type 'json-unknown-keyword)))
+ (should (equal (should-error (json-read-keyword "foo"))
+ '(json-unknown-keyword "foo")))
+ (should (equal (should-error (json-read-keyword "bar"))
+ '(json-unknown-keyword "bar"))))
+ (json-tests--with-temp-buffer " true"
+ (should (equal (should-error (json-read-keyword "true"))
+ '(json-unknown-keyword ()))))
+ (json-tests--with-temp-buffer "truefalse"
+ (should (equal (should-error (json-read-keyword "true"))
+ '(json-unknown-keyword "truefalse"))))
+ (json-tests--with-temp-buffer "true|"
+ (should (equal (should-error (json-read-keyword "true"))
+ '(json-unknown-keyword "true")))))
(ert-deftest test-json-encode-keyword ()
(should (equal (json-encode-keyword t) "true"))
- (should (equal (json-encode-keyword json-false) "false"))
- (should (equal (json-encode-keyword json-null) "null")))
+ (let ((json-false 'false))
+ (should (equal (json-encode-keyword 'false) "false"))
+ (should (equal (json-encode-keyword json-false) "false")))
+ (let ((json-null 'null))
+ (should (equal (json-encode-keyword 'null) "null"))
+ (should (equal (json-encode-keyword json-null) "null"))))
;;; Numbers
-(ert-deftest test-json-read-number ()
- (json-tests--with-temp-buffer "3"
- (should (= (json-read-number) 3)))
- (json-tests--with-temp-buffer "-5"
- (should (= (json-read-number) -5)))
- (json-tests--with-temp-buffer "123.456"
- (should (= (json-read-number) 123.456)))
- (json-tests--with-temp-buffer "1e3"
- (should (= (json-read-number) 1e3)))
- (json-tests--with-temp-buffer "2e+3"
- (should (= (json-read-number) 2e3)))
- (json-tests--with-temp-buffer "3E3"
- (should (= (json-read-number) 3e3)))
- (json-tests--with-temp-buffer "1e-7"
- (should (= (json-read-number) 1e-7)))
- (json-tests--with-temp-buffer "abc"
- (should-error (json-read-number) :type 'json-number-format)))
+(ert-deftest test-json-read-integer ()
+ (json-tests--with-temp-buffer "0 "
+ (should (= (json-read-number) 0))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "-0 "
+ (should (= (json-read-number) 0))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "3 "
+ (should (= (json-read-number) 3))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "-10 "
+ (should (= (json-read-number) -10))
+ (should (eobp)))
+ (json-tests--with-temp-buffer (format "%d " (1+ most-positive-fixnum))
+ (should (= (json-read-number) (1+ most-positive-fixnum)))
+ (should (eobp)))
+ (json-tests--with-temp-buffer (format "%d " (1- most-negative-fixnum))
+ (should (= (json-read-number) (1- most-negative-fixnum)))
+ (should (eobp))))
+
+(ert-deftest test-json-read-fraction ()
+ (json-tests--with-temp-buffer "0.0 "
+ (should (= (json-read-number) 0.0))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "-0.0 "
+ (should (= (json-read-number) 0.0))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "0.01 "
+ (should (= (json-read-number) 0.01))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "-0.01 "
+ (should (= (json-read-number) -0.01))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "123.456 "
+ (should (= (json-read-number) 123.456))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "-123.456 "
+ (should (= (json-read-number) -123.456))
+ (should (eobp))))
+
+(ert-deftest test-json-read-exponent ()
+ (json-tests--with-temp-buffer "0e0 "
+ (should (= (json-read-number) 0e0))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "-0E0 "
+ (should (= (json-read-number) 0e0))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "-0E+0 "
+ (should (= (json-read-number) 0e0))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "0e-0 "
+ (should (= (json-read-number) 0e0))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "12e34 "
+ (should (= (json-read-number) 12e34))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "-12E34 "
+ (should (= (json-read-number) -12e34))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "-12E+34 "
+ (should (= (json-read-number) -12e34))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "12e-34 "
+ (should (= (json-read-number) 12e-34))
+ (should (eobp))))
+
+(ert-deftest test-json-read-fraction-exponent ()
+ (json-tests--with-temp-buffer "0.0e0 "
+ (should (= (json-read-number) 0.0e0))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "-0.0E0 "
+ (should (= (json-read-number) 0.0e0))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "0.12E-0 "
+ (should (= (json-read-number) 0.12e0))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "-12.34e+56 "
+ (should (= (json-read-number) -12.34e+56))
+ (should (eobp))))
+
+(ert-deftest test-json-read-number-invalid ()
+ (cl-flet ((read (str)
+ ;; Return error and point resulting from reading STR.
+ (json-tests--with-temp-buffer str
+ (cons (should-error (json-read-number)) (point)))))
+ ;; POS is where each of its STRINGS becomes invalid.
+ (pcase-dolist (`(,pos . ,strings)
+ '((1 "" "+" "-" "." "e" "e1" "abc" "++0" "++1"
+ "+0" "+0.0" "+12" "+12.34" "+12.34e56"
+ ".0" "+.0" "-.0" ".12" "+.12" "-.12"
+ ".e0" "+.e0" "-.e0" ".0e0" "+.0e0" "-.0e0")
+ (2 "01" "1ee1" "1e++1")
+ (3 "-01")
+ (4 "0.0.0" "1.1.1" "1e1e1")
+ (5 "-0.0.0" "-1.1.1")))
+ ;; Expected error and point.
+ (let ((res `((json-number-format ,pos) . ,pos)))
+ (dolist (str strings)
+ (should (equal (read str) res)))))))
(ert-deftest test-json-encode-number ()
+ (should (equal (json-encode-number 0) "0"))
+ (should (equal (json-encode-number -0) "0"))
(should (equal (json-encode-number 3) "3"))
(should (equal (json-encode-number -5) "-5"))
- (should (equal (json-encode-number 123.456) "123.456")))
+ (should (equal (json-encode-number 123.456) "123.456"))
+ (let ((bignum (1+ most-positive-fixnum)))
+ (should (equal (json-encode-number bignum)
+ (number-to-string bignum)))))
-;; Strings
+;;; Strings
(ert-deftest test-json-read-escaped-char ()
(json-tests--with-temp-buffer "\\\""
- (should (equal (json-read-escaped-char) ?\"))))
+ (should (= (json-read-escaped-char) ?\"))
+ (should (eobp)))
+ (json-tests--with-temp-buffer "\\\\ "
+ (should (= (json-read-escaped-char) ?\\))
+ (should (= (point) (+ (point-min) 2))))
+ (json-tests--with-temp-buffer "\\b "
+ (should (= (json-read-escaped-char) ?\b))
+ (should (= (point) (+ (point-min) 2))))
+ (json-tests--with-temp-buffer "\\f "
+ (should (= (json-read-escaped-char) ?\f))
+ (should (= (point) (+ (point-min) 2))))
+ (json-tests--with-temp-buffer "\\n "
+ (should (= (json-read-escaped-char) ?\n))
+ (should (= (point) (+ (point-min) 2))))
+ (json-tests--with-temp-buffer "\\r "
+ (should (= (json-read-escaped-char) ?\r))
+ (should (= (point) (+ (point-min) 2))))
+ (json-tests--with-temp-buffer "\\t "
+ (should (= (json-read-escaped-char) ?\t))
+ (should (= (point) (+ (point-min) 2))))
+ (json-tests--with-temp-buffer "\\x "
+ (should (= (json-read-escaped-char) ?x))
+ (should (= (point) (+ (point-min) 2))))
+ (json-tests--with-temp-buffer "\\ud800\\uDC00 "
+ (should (= (json-read-escaped-char) #x10000))
+ (should (= (point) (+ (point-min) 12))))
+ (json-tests--with-temp-buffer "\\ud7ff\\udc00 "
+ (should (= (json-read-escaped-char) #xd7ff))
+ (should (= (point) (+ (point-min) 6))))
+ (json-tests--with-temp-buffer "\\uffff "
+ (should (= (json-read-escaped-char) #xffff))
+ (should (= (point) (+ (point-min) 6))))
+ (json-tests--with-temp-buffer "\\ufffff "
+ (should (= (json-read-escaped-char) #xffff))
+ (should (= (point) (+ (point-min) 6)))))
+
+(ert-deftest test-json-read-escaped-char-invalid ()
+ (json-tests--with-temp-buffer ""
+ (should-error (json-read-escaped-char)))
+ (json-tests--with-temp-buffer "\\"
+ (should-error (json-read-escaped-char) :type 'json-end-of-file))
+ (json-tests--with-temp-buffer "\\ufff "
+ (should (equal (should-error (json-read-escaped-char))
+ (list 'json-string-escape (+ (point-min) 2)))))
+ (json-tests--with-temp-buffer "\\ufffg "
+ (should (equal (should-error (json-read-escaped-char))
+ (list 'json-string-escape (+ (point-min) 2))))))
(ert-deftest test-json-read-string ()
+ (json-tests--with-temp-buffer ""
+ (should-error (json-read-string)))
(json-tests--with-temp-buffer "\"formfeed\f\""
- (should-error (json-read-string) :type 'json-string-format))
+ (should (equal (should-error (json-read-string))
+ '(json-string-format ?\f))))
+ (json-tests--with-temp-buffer "\"\""
+ (should (equal (json-read-string) "")))
(json-tests--with-temp-buffer "\"foo \\\"bar\\\"\""
(should (equal (json-read-string) "foo \"bar\"")))
(json-tests--with-temp-buffer "\"abcαβγ\""
@@ -175,57 +405,117 @@ Point is moved to beginning of the buffer."
;; Bug#24784
(json-tests--with-temp-buffer "\"\\uD834\\uDD1E\""
(should (equal (json-read-string) "\U0001D11E")))
+ (json-tests--with-temp-buffer "f"
+ (should-error (json-read-string) :type 'json-end-of-file))
(json-tests--with-temp-buffer "foo"
- (should-error (json-read-string) :type 'json-string-format)))
+ (should-error (json-read-string) :type 'json-end-of-file)))
(ert-deftest test-json-encode-string ()
+ (should (equal (json-encode-string "") "\"\""))
+ (should (equal (json-encode-string "a") "\"a\""))
(should (equal (json-encode-string "foo") "\"foo\""))
(should (equal (json-encode-string "a\n\fb") "\"a\\n\\fb\""))
(should (equal (json-encode-string "\nasdфыв\u001f\u007ffgh\t")
"\"\\nasdфыв\\u001f\u007ffgh\\t\"")))
(ert-deftest test-json-encode-key ()
+ (should (equal (json-encode-key "") "\"\""))
+ (should (equal (json-encode-key '##) "\"\""))
+ (should (equal (json-encode-key :) "\"\""))
(should (equal (json-encode-key "foo") "\"foo\""))
(should (equal (json-encode-key 'foo) "\"foo\""))
(should (equal (json-encode-key :foo) "\"foo\""))
- (should-error (json-encode-key 5) :type 'json-key-format)
- (should-error (json-encode-key ["foo"]) :type 'json-key-format)
- (should-error (json-encode-key '("foo")) :type 'json-key-format))
+ (should (equal (should-error (json-encode-key 5))
+ '(json-key-format 5)))
+ (should (equal (should-error (json-encode-key ["foo"]))
+ '(json-key-format ["foo"])))
+ (should (equal (should-error (json-encode-key '("foo")))
+ '(json-key-format ("foo")))))
;;; Objects
(ert-deftest test-json-new-object ()
(let ((json-object-type 'alist))
- (should (equal (json-new-object) '())))
+ (should-not (json-new-object)))
(let ((json-object-type 'plist))
- (should (equal (json-new-object) '())))
+ (should-not (json-new-object)))
(let* ((json-object-type 'hash-table)
(json-object (json-new-object)))
(should (hash-table-p json-object))
- (should (= (hash-table-count json-object) 0))))
+ (should (map-empty-p json-object))
+ (should (eq (hash-table-test json-object) #'equal))))
-(ert-deftest test-json-add-to-object ()
+(ert-deftest test-json-add-to-alist ()
(let* ((json-object-type 'alist)
- (json-key-type nil)
(obj (json-new-object)))
- (setq obj (json-add-to-object obj "a" 1))
- (setq obj (json-add-to-object obj "b" 2))
- (should (equal (assq 'a obj) '(a . 1)))
- (should (equal (assq 'b obj) '(b . 2))))
+ (let ((json-key-type nil))
+ (setq obj (json-add-to-object obj "a" 1))
+ (setq obj (json-add-to-object obj "b" 2))
+ (should (equal (assq 'a obj) '(a . 1)))
+ (should (equal (assq 'b obj) '(b . 2))))
+ (let ((json-key-type 'symbol))
+ (setq obj (json-add-to-object obj "c" 3))
+ (setq obj (json-add-to-object obj "d" 4))
+ (should (equal (assq 'c obj) '(c . 3)))
+ (should (equal (assq 'd obj) '(d . 4))))
+ (let ((json-key-type 'keyword))
+ (setq obj (json-add-to-object obj "e" 5))
+ (setq obj (json-add-to-object obj "f" 6))
+ (should (equal (assq :e obj) '(:e . 5)))
+ (should (equal (assq :f obj) '(:f . 6))))
+ (let ((json-key-type 'string))
+ (setq obj (json-add-to-object obj "g" 7))
+ (setq obj (json-add-to-object obj "h" 8))
+ (should (equal (assoc "g" obj) '("g" . 7)))
+ (should (equal (assoc "h" obj) '("h" . 8))))))
+
+(ert-deftest test-json-add-to-plist ()
(let* ((json-object-type 'plist)
- (json-key-type nil)
(obj (json-new-object)))
- (setq obj (json-add-to-object obj "a" 1))
- (setq obj (json-add-to-object obj "b" 2))
- (should (= (plist-get obj :a) 1))
- (should (= (plist-get obj :b) 2)))
+ (let ((json-key-type nil))
+ (setq obj (json-add-to-object obj "a" 1))
+ (setq obj (json-add-to-object obj "b" 2))
+ (should (= (plist-get obj :a) 1))
+ (should (= (plist-get obj :b) 2)))
+ (let ((json-key-type 'keyword))
+ (setq obj (json-add-to-object obj "c" 3))
+ (setq obj (json-add-to-object obj "d" 4))
+ (should (= (plist-get obj :c) 3))
+ (should (= (plist-get obj :d) 4)))
+ (let ((json-key-type 'symbol))
+ (setq obj (json-add-to-object obj "e" 5))
+ (setq obj (json-add-to-object obj "f" 6))
+ (should (= (plist-get obj 'e) 5))
+ (should (= (plist-get obj 'f) 6)))
+ (let ((json-key-type 'string))
+ (setq obj (json-add-to-object obj "g" 7))
+ (setq obj (json-add-to-object obj "h" 8))
+ (should (= (lax-plist-get obj "g") 7))
+ (should (= (lax-plist-get obj "h") 8)))))
+
+(ert-deftest test-json-add-to-hash-table ()
(let* ((json-object-type 'hash-table)
- (json-key-type nil)
(obj (json-new-object)))
- (setq obj (json-add-to-object obj "a" 1))
- (setq obj (json-add-to-object obj "b" 2))
- (should (= (gethash "a" obj) 1))
- (should (= (gethash "b" obj) 2))))
+ (let ((json-key-type nil))
+ (setq obj (json-add-to-object obj "a" 1))
+ (setq obj (json-add-to-object obj "b" 2))
+ (should (= (gethash "a" obj) 1))
+ (should (= (gethash "b" obj) 2)))
+ (let ((json-key-type 'string))
+ (setq obj (json-add-to-object obj "c" 3))
+ (setq obj (json-add-to-object obj "d" 4))
+ (should (= (gethash "c" obj) 3))
+ (should (= (gethash "d" obj) 4)))
+ (let ((json-key-type 'symbol))
+ (setq obj (json-add-to-object obj "e" 5))
+ (setq obj (json-add-to-object obj "f" 6))
+ (should (= (gethash 'e obj) 5))
+ (should (= (gethash 'f obj) 6)))
+ (let ((json-key-type 'keyword))
+ (setq obj (json-add-to-object obj "g" 7))
+ (setq obj (json-add-to-object obj "h" 8))
+ (should (= (gethash :g obj) 7))
+ (should (= (gethash :h obj) 8)))))
(ert-deftest test-json-read-object ()
(json-tests--with-temp-buffer "{ \"a\": 1, \"b\": 2 }"
@@ -238,94 +528,384 @@ Point is moved to beginning of the buffer."
(let* ((json-object-type 'hash-table)
(hash-table (json-read-object)))
(should (= (gethash "a" hash-table) 1))
- (should (= (gethash "b" hash-table) 2))))
+ (should (= (gethash "b" hash-table) 2)))))
+
+(ert-deftest test-json-read-object-empty ()
+ (json-tests--with-temp-buffer "{}"
+ (let ((json-object-type 'alist))
+ (should-not (save-excursion (json-read-object))))
+ (let ((json-object-type 'plist))
+ (should-not (save-excursion (json-read-object))))
+ (let* ((json-object-type 'hash-table)
+ (hash-table (json-read-object)))
+ (should (hash-table-p hash-table))
+ (should (map-empty-p hash-table)))))
+
+(ert-deftest test-json-read-object-invalid ()
+ (json-tests--with-temp-buffer "{ \"a\" 1, \"b\": 2 }"
+ (should (equal (should-error (json-read-object))
+ '(json-object-format ":" ?1))))
(json-tests--with-temp-buffer "{ \"a\": 1 \"b\": 2 }"
- (should-error (json-read-object) :type 'json-object-format)))
+ (should (equal (should-error (json-read-object))
+ '(json-object-format "," ?\")))))
+
+(ert-deftest test-json-read-object-function ()
+ (let* ((pre nil)
+ (post nil)
+ (keys '("b" "a"))
+ (json-pre-element-read-function
+ (lambda (key)
+ (setq pre 'pre)
+ (should (equal key (pop keys)))))
+ (json-post-element-read-function
+ (lambda () (setq post 'post))))
+ (json-tests--with-temp-buffer "{ \"b\": 2, \"a\": 1 }"
+ (json-read-object)
+ (should (eq pre 'pre))
+ (should (eq post 'post)))))
(ert-deftest test-json-encode-hash-table ()
- (let ((hash-table (make-hash-table))
- (json-encoding-object-sort-predicate 'string<)
+ (let ((json-encoding-object-sort-predicate nil)
(json-encoding-pretty-print nil))
- (puthash :a 1 hash-table)
- (puthash :b 2 hash-table)
- (puthash :c 3 hash-table)
- (should (equal (json-encode hash-table)
- "{\"a\":1,\"b\":2,\"c\":3}"))))
-
-(ert-deftest json-encode-simple-alist ()
- (let ((json-encoding-pretty-print nil))
- (should (equal (json-encode '((a . 1) (b . 2)))
- "{\"a\":1,\"b\":2}"))))
-
-(ert-deftest test-json-encode-plist ()
- (let ((plist '(:a 1 :b 2))
+ (should (equal (json-encode-hash-table #s(hash-table)) "{}"))
+ (should (equal (json-encode-hash-table #s(hash-table data (a 1)))
+ "{\"a\":1}"))
+ (should (member (json-encode-hash-table #s(hash-table data (b 2 a 1)))
+ '("{\"a\":1,\"b\":2}" "{\"b\":2,\"a\":1}")))
+ (should (member (json-encode-hash-table #s(hash-table data (c 3 b 2 a 1)))
+ '("{\"a\":1,\"b\":2,\"c\":3}"
+ "{\"a\":1,\"c\":3,\"b\":2}"
+ "{\"b\":2,\"a\":1,\"c\":3}"
+ "{\"b\":2,\"c\":3,\"a\":1}"
+ "{\"c\":3,\"a\":1,\"b\":2}"
+ "{\"c\":3,\"b\":2,\"a\":1}")))))
+
+(ert-deftest test-json-encode-hash-table-pretty ()
+ (let ((json-encoding-object-sort-predicate nil)
+ (json-encoding-pretty-print t)
+ (json-encoding-default-indentation " ")
+ (json-encoding-lisp-style-closings nil))
+ (should (equal (json-encode-hash-table #s(hash-table)) "{}"))
+ (should (equal (json-encode-hash-table #s(hash-table data (a 1)))
+ "{\n \"a\": 1\n}"))
+ (should (member (json-encode-hash-table #s(hash-table data (b 2 a 1)))
+ '("{\n \"a\": 1,\n \"b\": 2\n}"
+ "{\n \"b\": 2,\n \"a\": 1\n}")))
+ (should (member (json-encode-hash-table #s(hash-table data (c 3 b 2 a 1)))
+ '("{\n \"a\": 1,\n \"b\": 2,\n \"c\": 3\n}"
+ "{\n \"a\": 1,\n \"c\": 3,\n \"b\": 2\n}"
+ "{\n \"b\": 2,\n \"a\": 1,\n \"c\": 3\n}"
+ "{\n \"b\": 2,\n \"c\": 3,\n \"a\": 1\n}"
+ "{\n \"c\": 3,\n \"a\": 1,\n \"b\": 2\n}"
+ "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1\n}")))))
+
+(ert-deftest test-json-encode-hash-table-lisp-style ()
+ (let ((json-encoding-object-sort-predicate nil)
+ (json-encoding-pretty-print t)
+ (json-encoding-default-indentation " ")
+ (json-encoding-lisp-style-closings t))
+ (should (equal (json-encode-hash-table #s(hash-table)) "{}"))
+ (should (equal (json-encode-hash-table #s(hash-table data (a 1)))
+ "{\n \"a\": 1}"))
+ (should (member (json-encode-hash-table #s(hash-table data (b 2 a 1)))
+ '("{\n \"a\": 1,\n \"b\": 2}"
+ "{\n \"b\": 2,\n \"a\": 1}")))
+ (should (member (json-encode-hash-table #s(hash-table data (c 3 b 2 a 1)))
+ '("{\n \"a\": 1,\n \"b\": 2,\n \"c\": 3}"
+ "{\n \"a\": 1,\n \"c\": 3,\n \"b\": 2}"
+ "{\n \"b\": 2,\n \"a\": 1,\n \"c\": 3}"
+ "{\n \"b\": 2,\n \"c\": 3,\n \"a\": 1}"
+ "{\n \"c\": 3,\n \"a\": 1,\n \"b\": 2}"
+ "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1}")))))
+
+(ert-deftest test-json-encode-hash-table-sort ()
+ (let ((json-encoding-object-sort-predicate #'string<)
(json-encoding-pretty-print nil))
- (should (equal (json-encode plist) "{\"a\":1,\"b\":2}"))))
-
-(ert-deftest test-json-encode-plist-with-sort-predicate ()
- (let ((plist '(:c 3 :a 1 :b 2))
- (json-encoding-object-sort-predicate 'string<)
+ (pcase-dolist (`(,in . ,out)
+ '((#s(hash-table) . "{}")
+ (#s(hash-table data (a 1)) . "{\"a\":1}")
+ (#s(hash-table data (b 2 a 1)) . "{\"a\":1,\"b\":2}")
+ (#s(hash-table data (c 3 b 2 a 1))
+ . "{\"a\":1,\"b\":2,\"c\":3}")))
+ (let ((copy (map-pairs in)))
+ (should (equal (json-encode-hash-table in) out))
+ ;; Ensure sorting isn't destructive.
+ (should (seq-set-equal-p (map-pairs in) copy))))))
+
+(ert-deftest test-json-encode-alist ()
+ (let ((json-encoding-object-sort-predicate nil)
(json-encoding-pretty-print nil))
- (should (equal (json-encode plist) "{\"a\":1,\"b\":2,\"c\":3}"))))
+ (should (equal (json-encode-alist ()) "{}"))
+ (should (equal (json-encode-alist '((a . 1))) "{\"a\":1}"))
+ (should (equal (json-encode-alist '((b . 2) (a . 1))) "{\"b\":2,\"a\":1}"))
+ (should (equal (json-encode-alist '((c . 3) (b . 2) (a . 1)))
+ "{\"c\":3,\"b\":2,\"a\":1}"))))
+
+(ert-deftest test-json-encode-alist-pretty ()
+ (let ((json-encoding-object-sort-predicate nil)
+ (json-encoding-pretty-print t)
+ (json-encoding-default-indentation " ")
+ (json-encoding-lisp-style-closings nil))
+ (should (equal (json-encode-alist ()) "{}"))
+ (should (equal (json-encode-alist '((a . 1))) "{\n \"a\": 1\n}"))
+ (should (equal (json-encode-alist '((b . 2) (a . 1)))
+ "{\n \"b\": 2,\n \"a\": 1\n}"))
+ (should (equal (json-encode-alist '((c . 3) (b . 2) (a . 1)))
+ "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1\n}"))))
+
+(ert-deftest test-json-encode-alist-lisp-style ()
+ (let ((json-encoding-object-sort-predicate nil)
+ (json-encoding-pretty-print t)
+ (json-encoding-default-indentation " ")
+ (json-encoding-lisp-style-closings t))
+ (should (equal (json-encode-alist ()) "{}"))
+ (should (equal (json-encode-alist '((a . 1))) "{\n \"a\": 1}"))
+ (should (equal (json-encode-alist '((b . 2) (a . 1)))
+ "{\n \"b\": 2,\n \"a\": 1}"))
+ (should (equal (json-encode-alist '((c . 3) (b . 2) (a . 1)))
+ "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1}"))))
+
+(ert-deftest test-json-encode-alist-sort ()
+ (let ((json-encoding-object-sort-predicate #'string<)
+ (json-encoding-pretty-print nil))
+ (pcase-dolist (`(,in . ,out)
+ '((() . "{}")
+ (((a . 1)) . "{\"a\":1}")
+ (((b . 2) (a . 1)) . "{\"a\":1,\"b\":2}")
+ (((c . 3) (b . 2) (a . 1))
+ . "{\"a\":1,\"b\":2,\"c\":3}")))
+ (let ((copy (copy-alist in)))
+ (should (equal (json-encode-alist in) out))
+ ;; Ensure sorting isn't destructive (bug#40693).
+ (should (equal in copy))))))
-(ert-deftest test-json-encode-alist-with-sort-predicate ()
- (let ((alist '((:c . 3) (:a . 1) (:b . 2)))
- (json-encoding-object-sort-predicate 'string<)
+(ert-deftest test-json-encode-plist ()
+ (let ((json-encoding-object-sort-predicate nil)
(json-encoding-pretty-print nil))
- (should (equal (json-encode alist) "{\"a\":1,\"b\":2,\"c\":3}"))))
+ (should (equal (json-encode-plist ()) "{}"))
+ (should (equal (json-encode-plist '(:a 1)) "{\"a\":1}"))
+ (should (equal (json-encode-plist '(:b 2 :a 1)) "{\"b\":2,\"a\":1}"))
+ (should (equal (json-encode-plist '(:c 3 :b 2 :a 1))
+ "{\"c\":3,\"b\":2,\"a\":1}"))))
+
+(ert-deftest test-json-encode-plist-pretty ()
+ (let ((json-encoding-object-sort-predicate nil)
+ (json-encoding-pretty-print t)
+ (json-encoding-default-indentation " ")
+ (json-encoding-lisp-style-closings nil))
+ (should (equal (json-encode-plist ()) "{}"))
+ (should (equal (json-encode-plist '(:a 1)) "{\n \"a\": 1\n}"))
+ (should (equal (json-encode-plist '(:b 2 :a 1))
+ "{\n \"b\": 2,\n \"a\": 1\n}"))
+ (should (equal (json-encode-plist '(:c 3 :b 2 :a 1))
+ "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1\n}"))))
+
+(ert-deftest test-json-encode-plist-lisp-style ()
+ (let ((json-encoding-object-sort-predicate nil)
+ (json-encoding-pretty-print t)
+ (json-encoding-default-indentation " ")
+ (json-encoding-lisp-style-closings t))
+ (should (equal (json-encode-plist ()) "{}"))
+ (should (equal (json-encode-plist '(:a 1)) "{\n \"a\": 1}"))
+ (should (equal (json-encode-plist '(:b 2 :a 1))
+ "{\n \"b\": 2,\n \"a\": 1}"))
+ (should (equal (json-encode-plist '(:c 3 :b 2 :a 1))
+ "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1}"))))
+
+(ert-deftest test-json-encode-plist-sort ()
+ (let ((json-encoding-object-sort-predicate #'string<)
+ (json-encoding-pretty-print nil))
+ (pcase-dolist (`(,in . ,out)
+ '((() . "{}")
+ ((:a 1) . "{\"a\":1}")
+ ((:b 2 :a 1) . "{\"a\":1,\"b\":2}")
+ ((:c 3 :b 2 :a 1) . "{\"a\":1,\"b\":2,\"c\":3}")))
+ (let ((copy (copy-sequence in)))
+ (should (equal (json-encode-plist in) out))
+ ;; Ensure sorting isn't destructive.
+ (should (equal in copy))))))
(ert-deftest test-json-encode-list ()
- (let ((json-encoding-pretty-print nil))
- (should (equal (json-encode-list '(:a 1 :b 2))
- "{\"a\":1,\"b\":2}"))
- (should (equal (json-encode-list '((:a . 1) (:b . 2)))
- "{\"a\":1,\"b\":2}"))
- (should (equal (json-encode-list '(1 2 3 4)) "[1,2,3,4]"))))
+ (let ((json-encoding-object-sort-predicate nil)
+ (json-encoding-pretty-print nil))
+ (should (equal (json-encode-list ()) "{}"))
+ (should (equal (json-encode-list '(a)) "[\"a\"]"))
+ (should (equal (json-encode-list '(:a)) "[\"a\"]"))
+ (should (equal (json-encode-list '("a")) "[\"a\"]"))
+ (should (equal (json-encode-list '(a 1)) "[\"a\",1]"))
+ (should (equal (json-encode-list '("a" 1)) "[\"a\",1]"))
+ (should (equal (json-encode-list '(:a 1)) "{\"a\":1}"))
+ (should (equal (json-encode-list '((a . 1))) "{\"a\":1}"))
+ (should (equal (json-encode-list '((:a . 1))) "{\"a\":1}"))
+ (should (equal (json-encode-list '(:b 2 :a)) "[\"b\",2,\"a\"]"))
+ (should (equal (json-encode-list '(4 3 2 1)) "[4,3,2,1]"))
+ (should (equal (json-encode-list '(b 2 a 1)) "[\"b\",2,\"a\",1]"))
+ (should (equal (json-encode-list '(:b 2 :a 1)) "{\"b\":2,\"a\":1}"))
+ (should (equal (json-encode-list '((b . 2) (a . 1))) "{\"b\":2,\"a\":1}"))
+ (should (equal (json-encode-list '((:b . 2) (:a . 1)))
+ "{\"b\":2,\"a\":1}"))
+ (should (equal (json-encode-list '((a) 1)) "[[\"a\"],1]"))
+ (should (equal (json-encode-list '((:a) 1)) "[[\"a\"],1]"))
+ (should (equal (json-encode-list '(("a") 1)) "[[\"a\"],1]"))
+ (should (equal (json-encode-list '((a 1) 2)) "[[\"a\",1],2]"))
+ (should (equal (json-encode-list '((:a 1) 2)) "[{\"a\":1},2]"))
+ (should (equal (json-encode-list '(((a . 1)) 2)) "[{\"a\":1},2]"))
+ (should (equal (json-encode-list '(:a 1 :b (2))) "{\"a\":1,\"b\":[2]}"))
+ (should (equal (json-encode-list '((a . 1) (b 2))) "{\"a\":1,\"b\":[2]}"))
+ (should-error (json-encode-list '(a . 1)) :type 'wrong-type-argument)
+ (should-error (json-encode-list '((a . 1) 2)) :type 'wrong-type-argument)
+ (should (equal (should-error (json-encode-list []))
+ '(json-error [])))
+ (should (equal (should-error (json-encode-list [a]))
+ '(json-error [a])))))
;;; Arrays
(ert-deftest test-json-read-array ()
(let ((json-array-type 'vector))
+ (json-tests--with-temp-buffer "[]"
+ (should (equal (json-read-array) [])))
+ (json-tests--with-temp-buffer "[ ]"
+ (should (equal (json-read-array) [])))
+ (json-tests--with-temp-buffer "[1]"
+ (should (equal (json-read-array) [1])))
(json-tests--with-temp-buffer "[1, 2, \"a\", \"b\"]"
(should (equal (json-read-array) [1 2 "a" "b"]))))
(let ((json-array-type 'list))
+ (json-tests--with-temp-buffer "[]"
+ (should-not (json-read-array)))
+ (json-tests--with-temp-buffer "[ ]"
+ (should-not (json-read-array)))
+ (json-tests--with-temp-buffer "[1]"
+ (should (equal (json-read-array) '(1))))
(json-tests--with-temp-buffer "[1, 2, \"a\", \"b\"]"
(should (equal (json-read-array) '(1 2 "a" "b")))))
(json-tests--with-temp-buffer "[1 2]"
- (should-error (json-read-array) :type 'json-error)))
+ (should (equal (should-error (json-read-array))
+ '(json-array-format "," ?2)))))
+
+(ert-deftest test-json-read-array-function ()
+ (let* ((pre nil)
+ (post nil)
+ (keys '(0 1))
+ (json-pre-element-read-function
+ (lambda (key)
+ (setq pre 'pre)
+ (should (equal key (pop keys)))))
+ (json-post-element-read-function
+ (lambda () (setq post 'post))))
+ (json-tests--with-temp-buffer "[1, 0]"
+ (json-read-array)
+ (should (eq pre 'pre))
+ (should (eq post 'post)))))
(ert-deftest test-json-encode-array ()
- (let ((json-encoding-pretty-print nil))
- (should (equal (json-encode-array [1 2 "a" "b"])
- "[1,2,\"a\",\"b\"]"))))
+ (let ((json-encoding-object-sort-predicate nil)
+ (json-encoding-pretty-print nil))
+ (should (equal (json-encode-array ()) "[]"))
+ (should (equal (json-encode-array []) "[]"))
+ (should (equal (json-encode-array '(1)) "[1]"))
+ (should (equal (json-encode-array '[1]) "[1]"))
+ (should (equal (json-encode-array '(2 1)) "[2,1]"))
+ (should (equal (json-encode-array '[2 1]) "[2,1]"))
+ (should (equal (json-encode-array '[:b a 2 1]) "[\"b\",\"a\",2,1]"))))
+
+(ert-deftest test-json-encode-array-pretty ()
+ (let ((json-encoding-object-sort-predicate nil)
+ (json-encoding-pretty-print t)
+ (json-encoding-default-indentation " ")
+ (json-encoding-lisp-style-closings nil))
+ (should (equal (json-encode-array ()) "[]"))
+ (should (equal (json-encode-array []) "[]"))
+ (should (equal (json-encode-array '(1)) "[\n 1\n]"))
+ (should (equal (json-encode-array '[1]) "[\n 1\n]"))
+ (should (equal (json-encode-array '(2 1)) "[\n 2,\n 1\n]"))
+ (should (equal (json-encode-array '[2 1]) "[\n 2,\n 1\n]"))
+ (should (equal (json-encode-array '[:b a 2 1])
+ "[\n \"b\",\n \"a\",\n 2,\n 1\n]"))))
+
+(ert-deftest test-json-encode-array-lisp-style ()
+ (let ((json-encoding-object-sort-predicate nil)
+ (json-encoding-pretty-print t)
+ (json-encoding-default-indentation " ")
+ (json-encoding-lisp-style-closings t))
+ (should (equal (json-encode-array ()) "[]"))
+ (should (equal (json-encode-array []) "[]"))
+ (should (equal (json-encode-array '(1)) "[\n 1]"))
+ (should (equal (json-encode-array '[1]) "[\n 1]"))
+ (should (equal (json-encode-array '(2 1)) "[\n 2,\n 1]"))
+ (should (equal (json-encode-array '[2 1]) "[\n 2,\n 1]"))
+ (should (equal (json-encode-array '[:b a 2 1])
+ "[\n \"b\",\n \"a\",\n 2,\n 1]"))))
;;; Reader
(ert-deftest test-json-read ()
- (json-tests--with-temp-buffer "{ \"a\": 1 }"
- ;; We don't care exactly what the return value is (that is tested
- ;; in `test-json-read-object'), but it should parse without error.
- (should (json-read)))
+ (pcase-dolist (`(,fn . ,contents)
+ '((json-read-string "\"\"" "\"a\"")
+ (json-read-array "[]" "[1]")
+ (json-read-object "{}" "{\"a\":1}")
+ (json-read-keyword "null" "false" "true")
+ (json-read-number
+ "-0" "0" "1" "2" "3" "4" "5" "6" "7" "8" "9")))
+ (dolist (content contents)
+ ;; Check that leading whitespace is skipped.
+ (dolist (str (list content (concat " " content)))
+ (cl-letf* ((called nil)
+ ((symbol-function fn)
+ (lambda (&rest _) (setq called t))))
+ (json-tests--with-temp-buffer str
+ ;; We don't care exactly what the return value is (that is
+ ;; tested elsewhere), but it should parse without error.
+ (should (json-read))
+ (should called)))))))
+
+(ert-deftest test-json-read-invalid ()
(json-tests--with-temp-buffer ""
(should-error (json-read) :type 'json-end-of-file))
- (json-tests--with-temp-buffer "xxx"
- (let ((err (should-error (json-read) :type 'json-readtable-error)))
- (should (equal (cdr err) '(?x))))))
+ (json-tests--with-temp-buffer " "
+ (should-error (json-read) :type 'json-end-of-file))
+ (json-tests--with-temp-buffer "x"
+ (should (equal (should-error (json-read))
+ '(json-readtable-error ?x))))
+ (json-tests--with-temp-buffer " x"
+ (should (equal (should-error (json-read))
+ '(json-readtable-error ?x)))))
(ert-deftest test-json-read-from-string ()
- (let ((json-string "{ \"a\": 1 }"))
- (json-tests--with-temp-buffer json-string
- (should (equal (json-read-from-string json-string)
+ (dolist (str '("\"\"" "\"a\"" "[]" "[1]" "{}" "{\"a\":1}"
+ "null" "false" "true" "0" "123"))
+ (json-tests--with-temp-buffer str
+ (should (equal (json-read-from-string str)
(json-read))))))
-;;; JSON encoder
+;;; Encoder
(ert-deftest test-json-encode ()
+ (should (equal (json-encode t) "true"))
+ (let ((json-null 'null))
+ (should (equal (json-encode json-null) "null")))
+ (let ((json-false 'false))
+ (should (equal (json-encode json-false) "false")))
+ (should (equal (json-encode "") "\"\""))
(should (equal (json-encode "foo") "\"foo\""))
+ (should (equal (json-encode :) "\"\""))
+ (should (equal (json-encode :foo) "\"foo\""))
+ (should (equal (json-encode '(1)) "[1]"))
+ (should (equal (json-encode 'foo) "\"foo\""))
+ (should (equal (json-encode 0) "0"))
+ (should (equal (json-encode 123) "123"))
+ (let ((json-encoding-object-sort-predicate nil)
+ (json-encoding-pretty-print nil))
+ (should (equal (json-encode []) "[]"))
+ (should (equal (json-encode [1]) "[1]"))
+ (should (equal (json-encode #s(hash-table)) "{}"))
+ (should (equal (json-encode #s(hash-table data (a 1))) "{\"a\":1}")))
(with-temp-buffer
- (should-error (json-encode (current-buffer)) :type 'json-error)))
+ (should (equal (should-error (json-encode (current-buffer)))
+ (list 'json-error (current-buffer))))))
-;;; Pretty-print
+;;; Pretty printing & minimizing
(defun json-tests-equal-pretty-print (original &optional expected)
"Abort current test if pretty-printing ORIGINAL does not yield EXPECTED.
@@ -351,46 +931,45 @@ nil, ORIGINAL should stay unchanged by pretty-printing."
(json-tests-equal-pretty-print "0.123"))
(ert-deftest test-json-pretty-print-object ()
- ;; empty (regression test for bug#24252)
- (json-tests-equal-pretty-print
- "{}"
- "{\n}")
- ;; one pair
+ ;; Empty (regression test for bug#24252).
+ (json-tests-equal-pretty-print "{}")
+ ;; One pair.
(json-tests-equal-pretty-print
"{\"key\":1}"
"{\n \"key\": 1\n}")
- ;; two pairs
+ ;; Two pairs.
(json-tests-equal-pretty-print
"{\"key1\":1,\"key2\":2}"
"{\n \"key1\": 1,\n \"key2\": 2\n}")
- ;; embedded object
+ ;; Nested object.
(json-tests-equal-pretty-print
"{\"foo\":{\"key\":1}}"
"{\n \"foo\": {\n \"key\": 1\n }\n}")
- ;; embedded array
+ ;; Nested array.
(json-tests-equal-pretty-print
"{\"key\":[1,2]}"
"{\n \"key\": [\n 1,\n 2\n ]\n}"))
(ert-deftest test-json-pretty-print-array ()
- ;; empty
+ ;; Empty.
(json-tests-equal-pretty-print "[]")
- ;; one item
+ ;; One item.
(json-tests-equal-pretty-print
"[1]"
"[\n 1\n]")
- ;; two items
+ ;; Two items.
(json-tests-equal-pretty-print
"[1,2]"
"[\n 1,\n 2\n]")
- ;; embedded object
+ ;; Nested object.
(json-tests-equal-pretty-print
"[{\"key\":1}]"
"[\n {\n \"key\": 1\n }\n]")
- ;; embedded array
+ ;; Nested array.
(json-tests-equal-pretty-print
"[[1,2]]"
"[\n [\n 1,\n 2\n ]\n]"))
(provide 'json-tests)
+
;;; json-tests.el ends here
diff --git a/test/lisp/net/webjump-tests.el b/test/lisp/net/webjump-tests.el
new file mode 100644
index 0000000..47569c9
--- /dev/null
+++ b/test/lisp/net/webjump-tests.el
@@ -0,0 +1,73 @@
+;;; webjump-tests.el --- Tests for webjump.el -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2020 Free Software Foundation, Inc.
+
+;; Author: Simen Heggestøyl <address@hidden>
+;; Keywords:
+
+;; 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/>.
+
+;;; Commentary:
+
+;;
+
+;;; Code:
+
+(require 'ert)
+(require 'webjump)
+
+(ert-deftest webjump-tests-builtin ()
+ (should (equal (webjump-builtin '[name] "gnu.org") "gnu.org")))
+
+(ert-deftest webjump-tests-builtin-check-args ()
+ (should (webjump-builtin-check-args [1 2 3] "Foo" 2))
+ (should-error (webjump-builtin-check-args [1 2 3] "Foo" 3)))
+
+(ert-deftest webjump-tests-mirror-default ()
+ (should (equal (webjump-mirror-default
+ '("https://ftp.gnu.org/pub/gnu/";
+ "https://ftpmirror.gnu.org";))
+ "https://ftp.gnu.org/pub/gnu/";)))
+
+(ert-deftest webjump-tests-null-or-blank-string-p ()
+ (should (webjump-null-or-blank-string-p nil))
+ (should (webjump-null-or-blank-string-p ""))
+ (should (webjump-null-or-blank-string-p " "))
+ (should-not (webjump-null-or-blank-string-p " . ")))
+
+(ert-deftest webjump-tests-url-encode ()
+ (should (equal (webjump-url-encode "") ""))
+ (should (equal (webjump-url-encode "a b c") "a+b+c"))
+ (should (equal (webjump-url-encode "foo?") "foo%3F"))
+ (should (equal (webjump-url-encode "/foo\\") "/foo%5C"))
+ (should (equal (webjump-url-encode "f&o") "f%26o")))
+
+(ert-deftest webjump-tests-url-fix ()
+ (should (equal (webjump-url-fix nil) ""))
+ (should (equal (webjump-url-fix "/tmp/") "file:///tmp/"))
+ (should (equal (webjump-url-fix "gnu.org") "http://gnu.org/";))
+ (should (equal (webjump-url-fix "ftp.x.org") "ftp://ftp.x.org/";))
+ (should (equal (webjump-url-fix "https://gnu.org";)
+ "https://gnu.org/";)))
+
+(ert-deftest webjump-tests-url-fix-trailing-slash ()
+ (should (equal (webjump-url-fix-trailing-slash "https://gnu.org";)
+ "https://gnu.org/";))
+ (should (equal (webjump-url-fix-trailing-slash "https://gnu.org/";)
+ "https://gnu.org/";)))
+
+(provide 'webjump-tests)
+;;; webjump-tests.el ends here
diff --git a/test/lisp/xml-tests.el b/test/lisp/xml-tests.el
index 57e685c..72c78d0 100644
--- a/test/lisp/xml-tests.el
+++ b/test/lisp/xml-tests.el
@@ -164,6 +164,16 @@ Parser is called with and without 'symbol-qnames
argument.")
(should (equal (cdr xml-parse-test--namespace-attribute-qnames)
(xml-parse-region nil nil nil nil 'symbol-qnames)))))
+(ert-deftest xml-print-invalid-cdata ()
+ "Check that Bug#41094 is fixed."
+ (with-temp-buffer
+ (should (equal (should-error (xml-print '((foo () "\0")))
+ :type 'xml-invalid-character)
+ '(xml-invalid-character 0 1)))
+ (should (equal (should-error (xml-print '((foo () "\u00FF \xFF")))
+ :type 'xml-invalid-character)
+ '(xml-invalid-character #x3FFFFF 3)))))
+
;; Local Variables:
;; no-byte-compile: t
;; End:
diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el
index 6e87cb9..6e97646 100644
--- a/test/src/buffer-tests.el
+++ b/test/src/buffer-tests.el
@@ -1327,4 +1327,10 @@ with parameters from the *Messages* buffer modification."
(set-buffer-multibyte t)
(buffer-string)))))))
+;; https://debbugs.gnu.org/33492
+(ert-deftest buffer-tests-buffer-local-variables-undo ()
+ "Test that `buffer-undo-list' appears in `buffer-local-variables'."
+ (with-temp-buffer
+ (should (assq 'buffer-undo-list (buffer-local-variables)))))
+
;;; buffer-tests.el ends here