[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
scratch/etags-regen 834c52d: Merge branch 'master' into scratch/etags-re
|
From: |
Dmitry Gutov |
|
Subject: |
scratch/etags-regen 834c52d: Merge branch 'master' into scratch/etags-regen |
|
Date: |
Sun, 10 Jan 2021 17:47:26 -0500 (EST) |
branch: scratch/etags-regen
commit 834c52de8f966f734027c1beb9d63a67c7393602
Merge: 9a1fc1e 17bd039
Author: Dmitry Gutov <dgutov@yandex.ru>
Commit: Dmitry Gutov <dgutov@yandex.ru>
Merge branch 'master' into scratch/etags-regen
---
doc/emacs/mini.texi | 10 +-
doc/emacs/trouble.texi | 7 +
doc/lispref/display.texi | 17 +-
doc/lispref/minibuf.texi | 24 ++-
doc/lispref/windows.texi | 6 +
doc/misc/auth.texi | 12 ++
doc/misc/gnus.texi | 2 +-
etc/NEWS | 47 ++++-
etc/w32-feature.el | 35 +++-
lisp/cus-start.el | 6 +-
lisp/custom.el | 2 +
lisp/emacs-lisp/cl-generic.el | 26 +--
lisp/emacs-lisp/cl-macs.el | 123 +++++++++++-
lisp/emacs-lisp/lisp-mode.el | 6 +-
lisp/emacs-lisp/macroexp.el | 29 +++
lisp/emacs-lisp/pcase.el | 27 +--
lisp/emacs-lisp/shortdoc.el | 13 +-
lisp/gnus/gnus-win.el | 1 -
lisp/gnus/message.el | 12 +-
lisp/help-fns.el | 4 +-
lisp/help-mode.el | 3 +-
lisp/international/characters.el | 11 +-
lisp/mb-depth.el | 1 +
lisp/minibuffer.el | 8 +-
lisp/net/pop3.el | 2 +-
lisp/net/socks.el | 1 +
lisp/net/tramp-sh.el | 153 +++++++--------
lisp/progmodes/flymake.el | 7 +-
lisp/progmodes/prolog.el | 6 +-
lisp/progmodes/python.el | 6 +-
lisp/progmodes/xref.el | 15 +-
lisp/subr.el | 53 ++++-
lisp/tab-bar.el | 27 ++-
lisp/textmodes/fill.el | 11 +-
lisp/textmodes/paragraphs.el | 63 +++---
lisp/textmodes/reftex-vars.el | 11 +-
lisp/window.el | 66 +++++--
src/buffer.c | 2 +-
src/callproc.c | 33 ++--
src/emacs.c | 4 +-
src/eval.c | 26 +++
src/keymap.c | 23 ---
src/lisp.h | 7 +-
src/minibuf.c | 185 +++++++++++++++---
src/pdumper.c | 2 +-
src/process.c | 13 +-
src/sysdep.c | 217 +++++++++++++++++++++
src/w32term.c | 3 +-
src/window.c | 18 +-
src/window.h | 4 -
src/xfaces.c | 8 +-
test/Makefile.in | 6 +-
test/lisp/emacs-lisp/cl-macs-tests.el | 23 +++
test/lisp/filenotify-tests.el | 2 +-
.../gnus/mm-decode-resources/8bit-multipart.bin | 20 ++
.../gnus/mm-decode-resources/win1252-multipart.bin | 44 +++++
test/lisp/gnus/mm-decode-tests.el | 102 ++++++++++
test/lisp/help-mode-tests.el | 21 +-
test/lisp/help-tests.el | 2 +-
test/lisp/net/socks-tests.el | 103 ++++++++++
test/lisp/net/tramp-tests.el | 59 +++++-
test/lisp/subr-tests.el | 46 ++++-
test/lisp/textmodes/fill-tests.el | 31 +++
.../paragraphs-resources/mark-paragraph.bin | 9 +
test/lisp/textmodes/paragraphs-tests.el | 23 +++
test/src/process-tests.el | 5 +
66 files changed, 1529 insertions(+), 365 deletions(-)
diff --git a/doc/emacs/mini.texi b/doc/emacs/mini.texi
index c7c8fb3..f81e64b 100644
--- a/doc/emacs/mini.texi
+++ b/doc/emacs/mini.texi
@@ -76,9 +76,13 @@ default, the active minibuffer moves to this new frame. If
you set
the user option @code{minibuffer-follows-selected-frame} to
@code{nil}, then the minibuffer stays in the frame where you opened
it, and you must switch back to that frame in order to complete (or
-abort) the current command. Note that the effect of the command, when
-you finally finish using the minibuffer, always takes place in the
-frame where you first opened it.
+abort) the current command. If you set that option to a value which
+is neither @code{nil} nor @code{t}, the minibuffer moves frame only
+after a recursive minibuffer has been opened in the current command
+(@pxref{Recursive Mini,,, elisp}). This option is mainly to retain
+(approximately) the behavior prior to Emacs 28.1. Note that the
+effect of the command, when you finally finish using the minibuffer,
+always takes place in the frame where you first opened it.
@node Minibuffer File
@section Minibuffers for File Names
diff --git a/doc/emacs/trouble.texi b/doc/emacs/trouble.texi
index 4da3d4a..9a63881 100644
--- a/doc/emacs/trouble.texi
+++ b/doc/emacs/trouble.texi
@@ -57,6 +57,13 @@ incremental search, @kbd{C-g} behaves specially; it may take
two
successive @kbd{C-g} characters to get out of a search.
@xref{Incremental Search}, for details.
+ If you type @kbd{C-g} in a minibuffer, this quits the command that
+opened that minibuffer, closing it. If that minibuffer is not the
+most recently opened one (which can happen when
+@code{minibuffer-follows-selected-frame} is @code{nil} (@pxref{Basic
+Minibuffer})), @kbd{C-g} also closes the more recently opened ones,
+quitting their associated commands, after asking you for confirmation.
+
On MS-DOS, the character @kbd{C-@key{Break}} serves as a quit character
like @kbd{C-g}. The reason is that it is not feasible, on MS-DOS, to
recognize @kbd{C-g} while a command is running, between interactions
diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi
index b149a66..93e935c 100644
--- a/doc/lispref/display.texi
+++ b/doc/lispref/display.texi
@@ -2485,15 +2485,16 @@ avoiding any increase in the character height or width.
For simplification
the width could be specified with only a single number @var{n} instead
of a list, such case is equivalent to @code{((abs @var{n}) . @var{n})}.
-The value @var{color} specifies the color to draw with. The default is
-the foreground color of the face for simple boxes, and the background
-color of the face for 3D boxes.
-
The value @var{style} specifies whether to draw a 3D box. If it is
-@code{released-button}, the box looks like a 3D button that is not being
-pressed. If it is @code{pressed-button}, the box looks like a 3D button
-that is being pressed. If it is @code{nil} or omitted, a plain 2D box
-is used.
+@code{released-button}, the box looks like a 3D button that is not
+being pressed. If it is @code{pressed-button}, the box looks like a
+3D button that is being pressed. If it is @code{nil},
+@code{flat-button} or omitted, a plain 2D box is used.
+
+The value @var{color} specifies the color to draw with. The default
+is the background color of the face for 3D boxes and
+@code{flat-button}, and the foreground color of the face for other
+boxes.
@end table
@item :inverse-video
diff --git a/doc/lispref/minibuf.texi b/doc/lispref/minibuf.texi
index f0036f0..d316c1f 100644
--- a/doc/lispref/minibuf.texi
+++ b/doc/lispref/minibuf.texi
@@ -82,10 +82,12 @@ there is an active minibuffer; such a minibuffer is called a
incrementing the number at the end of the name. (The names begin with
a space so that they won't show up in normal buffer lists.) Of
several recursive minibuffers, the innermost (or most recently
-entered) is the active minibuffer. We usually call this @emph{the}
-minibuffer. You can permit or forbid recursive minibuffers by setting
-the variable @code{enable-recursive-minibuffers}, or by putting
-properties of that name on command symbols (@xref{Recursive Mini}.)
+entered) is the @dfn{active minibuffer}--it is the one you can
+terminate by typing @key{RET} (@code{exit-minibuffer}) in. We usually
+call this @emph{the} minibuffer. You can permit or forbid recursive
+minibuffers by setting the variable
+@code{enable-recursive-minibuffers}, or by putting properties of that
+name on command symbols (@xref{Recursive Mini}.)
Like other buffers, a minibuffer uses a local keymap
(@pxref{Keymaps}) to specify special key bindings. The function that
@@ -2380,7 +2382,8 @@ minibuffer.
@deffn Command exit-minibuffer
This command exits the active minibuffer. It is normally bound to
-keys in minibuffer local keymaps.
+keys in minibuffer local keymaps. The command throws an error if the
+current buffer is not the active minibuffer.
@end deffn
@deffn Command self-insert-and-exit
@@ -2594,8 +2597,11 @@ returns zero.
If this variable is non-@code{nil}, you can invoke commands (such as
@code{find-file}) that use minibuffers even while the minibuffer is
active. Such invocation produces a recursive editing level for a new
-minibuffer. The outer-level minibuffer is invisible while you are
-editing the inner one.
+minibuffer. By default, the outer-level minibuffer is invisible while
+you are editing the inner one. If you have
+@code{minibuffer-follows-selected-frame} set to @code{nil}, you can
+have minibuffers visible on several frames at the same time.
+@xref{Basic Minibuffer,,, emacs}.
If this variable is @code{nil}, you cannot invoke minibuffer commands
when the minibuffer is active, not even if you switch to another window
@@ -2623,7 +2629,7 @@ active minibuffer.
@end defun
@defvar minibuffer-setup-hook
-This is a normal hook that is run whenever the minibuffer is entered.
+This is a normal hook that is run whenever a minibuffer is entered.
@xref{Hooks}.
@end defvar
@@ -2641,7 +2647,7 @@ called once, for the outermost use of the minibuffer.
@end defmac
@defvar minibuffer-exit-hook
-This is a normal hook that is run whenever the minibuffer is exited.
+This is a normal hook that is run whenever a minibuffer is exited.
@xref{Hooks}.
@end defvar
diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi
index b0906ac..f305d1a 100644
--- a/doc/lispref/windows.texi
+++ b/doc/lispref/windows.texi
@@ -2634,6 +2634,12 @@ window and displaying the buffer in that window. It can
fail if all
windows are dedicated to other buffers (@pxref{Dedicated Windows}).
@end defun
+@defun display-buffer-use-least-recent-window buffer alist
+This function is like @code{display-buffer-use-some-window}, but will
+not reuse the current window, and will use the least recently
+switched-to window.
+@end defun
+
@defun display-buffer-in-direction buffer alist
This function tries to display @var{buffer} at a location specified by
@var{alist}. For this purpose, @var{alist} should contain a
diff --git a/doc/misc/auth.texi b/doc/misc/auth.texi
index d810f15..034004d 100644
--- a/doc/misc/auth.texi
+++ b/doc/misc/auth.texi
@@ -107,6 +107,18 @@ The @code{user} is the user name. It's known as
@var{:user} in
@code{auth-source-search} queries. You can also use @code{login} and
@code{account}.
+Matching entries are usually used in the order they appear, so placing
+the most specific entries first in the file is a good idea. For
+instance:
+
+@example
+machine example.com login foobar password geheimnis port smtp
+machine example.com login foobar password hemmelig
+@end example
+
+Here we're using one password for the @code{smtp} service, and a
+different one for all the other services.
+
You can also use this file to specify client certificates to use when
setting up TLS connections. The format is:
diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi
index 797315d..5a79cbc 100644
--- a/doc/misc/gnus.texi
+++ b/doc/misc/gnus.texi
@@ -20195,7 +20195,7 @@ Phu.
For example, to do hierarchical scoring but use a non-server-specific
overall score file, you could use the value
@example
-(list (lambda (group) ("all.SCORE"))
+(list (lambda (group) (list "all.SCORE"))
'gnus-score-find-hierarchical)
@end example
diff --git a/etc/NEWS b/etc/NEWS
index 48fb4b8..7e84d69 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -102,12 +102,13 @@ effect should be negligible in the vast majority of cases
anyway.
By default, when you switch to another frame, an active minibuffer now
moves to the newly selected frame. Nevertheless, the effect of what
you type in the minibuffer happens in the frame where the minibuffer
-was first activated, even if it moved to another frame. An
-alternative behavior is available by customizing
-'minibuffer-follows-selected-frame' to nil. Here, the minibuffer
-stays in the frame where you first opened it, and you must switch back
-to this frame to continue or abort its command. The old, somewhat
-unsystematic behavior, which mixed these two is no longer available.
+was first activated. An alternative behavior is available by
+customizing 'minibuffer-follows-selected-frame' to nil. Here, the
+minibuffer stays in the frame where you first opened it, and you must
+switch back to this frame to continue or abort its command. The old
+behavior, which mixed these two, can be approximated by customizing
+'minibuffer-follows-selected-frame' to a value which is neither nil
+nor t.
+++
** New system for displaying documentation for groups of functions.
@@ -347,6 +348,8 @@ is set to nil, this message is inhibited.
** Python mode
+*** 'python-shell-interpreter' now defaults to python3 on systems with python3.
+
*** 'C-c C-r' can now be used on arbitrary regions.
The command previously extended the start of the region to the start
of the line, but will now actually send the marked region, as
@@ -373,6 +376,15 @@ disabled entirely.
** Windows
++++
+*** New 'display-buffer' function 'display-buffer-use-least-recent-window'
+This is like 'display-buffer-use-some-window', but won't reuse the
+current window, and when called repeatedly will try not to reuse a
+previously selected window.
+
+*** New function 'window-bump-use-time'.
+This updates the use time of a window.
+
*** The key prefix 'C-x 4 1' displays next command buffer in the same window.
It's bound to the command 'same-window-prefix' that requests the buffer
of the next command to be displayed in the same window.
@@ -403,8 +415,8 @@ value of 'tab-bar-show'.
---
*** New command 'toggle-frame-tab-bar'.
-It can be used to enable/disable the tab bar individually
-on each frame independently from the state of `tab-bar-mode'.
+It can be used to enable/disable the tab bar individually on each frame
+independently from the value of 'tab-bar-mode' and 'tab-bar-show'.
---
*** New user option 'tab-bar-tab-name-format-function'.
@@ -690,6 +702,13 @@ not.
** Message
+---
+*** Respect 'message-forward-ignored-headers' more.
+Previously, this variable would not be consulted if
+'message-forward-show-mml' was nil. It's now always used, except if
+'message-forward-show-mml' is 'best', and we're forwarding an
+encrypted/signed message.
+
+++
*** Message now supports the OpenPGP header.
To generate these headers, add the new function
@@ -1324,6 +1343,11 @@ have been renamed to have "proper" public names and
documented
('xref-show-definitions-buffer' and
'xref-show-definitions-buffer-at-bottom').
+*** New command 'xref-quit-and-pop-marker-stack' and a binding for it
+in Xref buffers ('M-,'). This combination is easy to press
+semi-accidentally if the user wants to go back in the middle of
+choosing the exact definition to go to, and this should do TRT.
+
---
*** New value 'project-relative' for 'xref-file-name-display'
If chosen, file names in *xref* buffers will be displayed relative
@@ -1504,8 +1528,13 @@ that makes it a valid button.
** Miscellaneous
+---
+*** 'process-attributes' now works under OpenBSD, too.
+
+++
-*** 'add-to-ordered-list' can now take a test predicate.
+*** New button face 'flat-button'.
+This is a plain 2D button, but uses the background color instead of
+the foreground color.
+++
*** New predicate functions 'length<', 'length>' and 'length='.
diff --git a/etc/w32-feature.el b/etc/w32-feature.el
index c5f2cd5..364e934 100644
--- a/etc/w32-feature.el
+++ b/etc/w32-feature.el
@@ -25,9 +25,21 @@
;; designed to check whether bundled binary distributions of Emacs on
;; windows are fully functional.
+;; By default is checks whether the features that we are expect to be
+;; available on Emacs for Windows are reported to be available. It
+;; should be possible to run these tests from a distributed version of
+;; Emacs.
+
+;; In addition, it provides a single command
+;; `w32-feature-load-tests'. If the full source repository of Emacs is
+;; available, this will load selected files from the repository which
+;; test these features.
+
;;; Code:
(require 'ert)
+(defvar w32-feature-core-tests nil)
+
(ert-deftest feature-optimization ()
(should
(string-match-p "CFLAGS=-O2" system-configuration-options)))
@@ -41,16 +53,24 @@
(ert-deftest feature-gnutls ()
(should (gnutls-available-p)))
+(add-to-list 'w32-feature-core-tests "lisp/net/gnutls-tests.el")
+
(ert-deftest feature-zlib ()
(should (zlib-available-p)))
+(add-to-list 'w32-feature-core-tests "src/decompress-tests.el")
+
(ert-deftest feature-thread ()
(should (fboundp 'make-thread)))
+(add-to-list 'w32-feature-core-tests "lisp/thread-tests.el")
+
(ert-deftest feature-json ()
(should
(fboundp 'json-serialize)))
+(add-to-list 'w32-feature-core-tests "src/json-tests.el")
+
(ert-deftest feature-gmp ()
(should
(string-match-p "GMP" system-configuration-features)))
@@ -61,9 +81,13 @@
(ert-deftest feature-libxml ()
(should (libxml-available-p)))
+(add-to-list 'w32-feature-core-tests "src/xml-tests.el")
+
(ert-deftest feature-lcms2 ()
(should (lcms2-available-p)))
+(add-to-list 'w32-feature-core-tests "src/lcms-tests.el")
+
(ert-deftest feature-xpm ()
(should (image-type-available-p 'xpm)))
@@ -73,8 +97,7 @@
(ert-deftest feature-png ()
(should (image-type-available-p 'png)))
-(ert-deftest feature-xpm ()
- (should (image-type-available-p 'xpm)))
+(add-to-list 'w32-feature-core-tests "lisp/image-file-tests.el")
(ert-deftest feature-jpeg ()
(should (image-type-available-p 'jpeg)))
@@ -84,4 +107,12 @@
(ert-deftest feature-svg ()
(should (image-type-available-p 'svg)))
+
+(defun w32-feature-load-tests (dir)
+ (interactive "D")
+ (mapc
+ (lambda(f)
+ (load-file (concat dir "test/" f)))
+ w32-feature-core-tests))
+
;;; feature.el ends here
diff --git a/lisp/cus-start.el b/lisp/cus-start.el
index 85dd14f..0293d34 100644
--- a/lisp/cus-start.el
+++ b/lisp/cus-start.el
@@ -394,7 +394,11 @@ Leaving \"Default\" unchecked is equivalent with
specifying a default of
;; (directory :format "%v"))))
(load-prefer-newer lisp boolean "24.4")
;; minibuf.c
- (minibuffer-follows-selected-frame minibuffer boolean "28.1")
+ (minibuffer-follows-selected-frame
+ minibuffer (choice (const :tag "Always" t)
+ (const :tag "When used" hybrid)
+ (const :tag "Never" nil))
+ "28.1")
(enable-recursive-minibuffers minibuffer boolean)
(history-length minibuffer
(choice (const :tag "Infinite" t) integer)
diff --git a/lisp/custom.el b/lisp/custom.el
index d9d0898..0c82df9 100644
--- a/lisp/custom.el
+++ b/lisp/custom.el
@@ -237,6 +237,8 @@ The following keywords are meaningful:
:type VALUE should be a widget type for editing the symbol's value.
Every `defcustom' should specify a value for this keyword.
+ See Info node `(elisp) Customization Types' for a list of
+ base types and useful composite types.
:options VALUE should be a list of valid members of the widget type.
:initialize
VALUE should be a function used to initialize the
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 19dd54c..8e36dbe 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -304,15 +304,6 @@ the specializer used will be the one returned by BODY."
(lambda ,args ,@body))))
(eval-and-compile ;Needed while compiling the cl-defmethod calls below!
- (defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el.
- "Check which of the symbols VARS appear in SEXP."
- (let ((res '()))
- (while (consp sexp)
- (dolist (var (cl--generic-fgrep vars (pop sexp)))
- (unless (memq var res) (push var res))))
- (and (memq sexp vars) (not (memq sexp res)) (push sexp res))
- res))
-
(defun cl--generic-split-args (args)
"Return (SPEC-ARGS . PLAIN-ARGS)."
(let ((plain-args ())
@@ -375,11 +366,11 @@ the specializer used will be the one returned by BODY."
;; is used.
;; FIXME: Also, optimize the case where call-next-method is
;; only called with explicit arguments.
- (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody)))
+ (uses-cnm (macroexp--fgrep `((,cnm) (,nmp)) nbody)))
(cons (not (not uses-cnm))
`#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
,@(car parsed-body)
- ,(if (not (memq nmp uses-cnm))
+ ,(if (not (assq nmp uses-cnm))
nbody
`(let ((,nmp (lambda ()
(cl--generic-isnot-nnm-p ,cnm))))
@@ -617,11 +608,11 @@ The set of acceptable TYPEs (also called
\"specializers\") is defined
(lambda (,@fixedargs &rest args)
(let ,bindings
(apply (cl--generic-with-memoization
- (gethash ,tag-exp method-cache)
- (cl--generic-cache-miss
- generic ',dispatch-arg dispatches-left methods
- ,(if (cdr typescodes)
- `(append ,@typescodes) (car typescodes))))
+ (gethash ,tag-exp method-cache)
+ (cl--generic-cache-miss
+ generic ',dispatch-arg dispatches-left methods
+ ,(if (cdr typescodes)
+ `(append ,@typescodes) (car typescodes))))
,@fixedargs args)))))))))
(defun cl--generic-make-function (generic)
@@ -1110,7 +1101,8 @@ These match if the argument is a cons cell whose car is
`eql' to VAL."
(if (not (eq (car-safe specializer) 'head))
(cl-call-next-method)
(cl--generic-with-memoization
- (gethash (cadr specializer) cl--generic-head-used) specializer)
+ (gethash (cadr specializer) cl--generic-head-used)
+ specializer)
(list cl--generic-head-generalizer)))
(cl--generic-prefill-dispatchers 0 (head eql))
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 1cb195d..c2bf02c 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2060,10 +2060,99 @@ Like `cl-flet' but the definitions can refer to
previous ones.
((null (cdr bindings)) `(cl-flet ,bindings ,@body))
(t `(cl-flet (,(pop bindings)) (cl-flet* ,bindings ,@body)))))
+(defun cl--self-tco (var fargs body)
+ ;; This tries to "optimize" tail calls for the specific case
+ ;; of recursive self-calls by replacing them with a `while' loop.
+ ;; It is quite far from a general tail-call optimization, since it doesn't
+ ;; even handle mutually recursive functions.
+ (letrec
+ ((done nil) ;; Non-nil if some TCO happened.
+ (retvar (make-symbol "retval"))
+ (ofargs (mapcar (lambda (s) (if (memq s cl--lambda-list-keywords) s
+ (make-symbol (symbol-name s))))
+ fargs))
+ (opt-exps (lambda (exps) ;; `exps' is in tail position!
+ (append (butlast exps)
+ (list (funcall opt (car (last exps)))))))
+ (opt
+ (lambda (exp) ;; `exp' is in tail position!
+ (pcase exp
+ ;; FIXME: Optimize `apply'?
+ (`(funcall ,(pred (eq var)) . ,aargs)
+ ;; This is a self-recursive call in tail position.
+ (let ((sets nil)
+ (fargs ofargs))
+ (while fargs
+ (pcase (pop fargs)
+ ('&rest
+ (push (pop fargs) sets)
+ (push `(list . ,aargs) sets)
+ ;; (cl-assert (null fargs))
+ )
+ ('&optional nil)
+ (farg
+ (push farg sets)
+ (push (pop aargs) sets))))
+ (setq done t)
+ `(progn (setq . ,(nreverse sets))
+ :recurse)))
+ (`(progn . ,exps) `(progn . ,(funcall opt-exps exps)))
+ (`(if ,cond ,then . ,else)
+ `(if ,cond ,(funcall opt then) . ,(funcall opt-exps else)))
+ (`(cond . ,conds)
+ (let ((cs '()))
+ (while conds
+ (pcase (pop conds)
+ (`(,exp)
+ (push (if conds
+ ;; This returns the value of `exp' but it's
+ ;; only in tail position if it's the
+ ;; last condition.
+ `((setq ,retvar ,exp) nil)
+ `(,(funcall opt exp)))
+ cs))
+ (exps
+ (push (funcall opt-exps exps) cs))))
+ (if (eq t (caar cs))
+ `(cond . ,(nreverse cs))
+ `(cond ,@(nreverse cs) (t (setq ,retvar nil))))))
+ ((and `(,(or 'let 'let*) ,bindings . ,exps)
+ (guard
+ ;; Note: it's OK for this `let' to shadow any
+ ;; of the formal arguments since we will only
+ ;; setq the fresh new `ofargs' vars instead ;-)
+ (let ((shadowings
+ (mapcar (lambda (b) (if (consp b) (car b) b))
bindings)))
+ ;; If `var' is shadowed, then it clearly can't be
+ ;; tail-called any more.
+ (not (memq var shadowings)))))
+ `(,(car exp) ,bindings . ,(funcall opt-exps exps)))
+ (_
+ `(progn (setq ,retvar ,exp) nil))))))
+
+ (let ((optimized-body (funcall opt-exps body)))
+ (if (not done)
+ (cons fargs body)
+ ;; We use two sets of vars: `ofargs' and `fargs' because we need
+ ;; to be careful that if a closure captures a formal argument
+ ;; in one iteration, it needs to capture a different binding
+ ;; then that of other iterations, e.g.
+ (cons
+ ofargs
+ `((let (,retvar)
+ (while (let ,(delq nil
+ (cl-mapcar
+ (lambda (a oa)
+ (unless (memq a cl--lambda-list-keywords)
+ (list a oa)))
+ fargs ofargs))
+ . ,optimized-body))
+ ,retvar)))))))
+
;;;###autoload
(defmacro cl-labels (bindings &rest body)
- "Make local (recursive) function definitions.
-Each definition can take the form (FUNC ARGLIST BODY...) where
+ "Make local (recursive) function definitions.
++BINDINGS is a list of definitions of the form (FUNC ARGLIST BODY...) where
FUNC is the function name, ARGLIST its arguments, and BODY the
forms of the function body. FUNC is defined in any BODY, as well
as FORM, so you can write recursive and mutually recursive
@@ -2075,17 +2164,33 @@ details.
(let ((binds ()) (newenv macroexpand-all-environment))
(dolist (binding bindings)
(let ((var (make-symbol (format "--cl-%s--" (car binding)))))
- (push (list var `(cl-function (lambda . ,(cdr binding)))) binds)
+ (push (cons var (cdr binding)) binds)
(push (cons (car binding)
(lambda (&rest args)
(if (eq (car args) cl--labels-magic)
(list cl--labels-magic var)
(cl-list* 'funcall var args))))
newenv)))
- (macroexpand-all `(letrec ,(nreverse binds) ,@body)
- ;; Don't override lexical-let's macro-expander.
- (if (assq 'function newenv) newenv
- (cons (cons 'function #'cl--labels-convert) newenv)))))
+ ;; Don't override lexical-let's macro-expander.
+ (unless (assq 'function newenv)
+ (push (cons 'function #'cl--labels-convert) newenv))
+ ;; Perform self-tail call elimination.
+ (setq binds (mapcar
+ (lambda (bind)
+ (pcase-let*
+ ((`(,var ,sargs . ,sbody) bind)
+ (`(function (lambda ,fargs . ,ebody))
+ (macroexpand-all `(cl-function (lambda ,sargs .
,sbody))
+ newenv))
+ (`(,ofargs . ,obody)
+ (cl--self-tco var fargs ebody)))
+ `(,var (function (lambda ,ofargs . ,obody)))))
+ (nreverse binds)))
+ `(letrec ,binds
+ . ,(macroexp-unprogn
+ (macroexpand-all
+ (macroexp-progn body)
+ newenv)))))
;; The following ought to have a better definition for use with newer
;; byte compilers.
@@ -3383,8 +3488,8 @@ macro that returns its `&whole' argument."
(put y 'side-effect-free t))
;;; Things that are inline.
-(cl-proclaim '(inline cl-acons cl-map cl-concatenate cl-notany
- cl-notevery cl-revappend cl-nreconc gethash))
+(cl-proclaim '(inline cl-acons cl-map cl-notany cl-notevery cl-revappend
+ cl-nreconc gethash))
;;; Things that are side-effect-free.
(mapc (lambda (x) (function-put x 'side-effect-free t))
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index 1ae216c..8780c5d 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -456,8 +456,7 @@ This will generate compile-time constants from BINDINGS."
("\\(\\\\\\)\\([^\"\\]\\)"
(1 (elisp--font-lock-backslash) prepend))
;; Words inside ‘’ and `' tend to be symbol names.
- (,(concat "[`‘]\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)"
- lisp-mode-symbol-regexp "\\)['’]")
+ (,(concat "[`‘]\\(" lisp-mode-symbol-regexp "\\)['’]")
(1 font-lock-constant-face prepend))
;; Constant values.
(,(concat "\\_<:" lisp-mode-symbol-regexp "\\_>")
@@ -507,8 +506,7 @@ This will generate compile-time constants from BINDINGS."
(,(concat "(" cl-errs-re "\\_>")
(1 font-lock-warning-face))
;; Words inside ‘’ and `' tend to be symbol names.
- (,(concat "[`‘]\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)"
- lisp-mode-symbol-regexp "\\)['’]")
+ (,(concat "[`‘]\\(" lisp-mode-symbol-regexp "\\)['’]")
(1 font-lock-constant-face prepend))
;; Uninterned symbols, e.g., (defpackage #:my-package ...)
;; must come before keywords below to have effect
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 82a8cd2..3784497 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -480,6 +480,35 @@ itself or not."
v
(list 'quote v)))
+(defun macroexp--fgrep (bindings sexp)
+ "Return those of the BINDINGS which might be used in SEXP.
+It is used as a poor-man's \"free variables\" test. It differs from a true
+test of free variables in the following ways:
+- It does not distinguish variables from functions, so it can be used
+ both to detect whether a given variable is used by SEXP and to
+ detect whether a given function is used by SEXP.
+- It does not actually know ELisp syntax, so it only looks for the presence
+ of symbols in SEXP and can't distinguish if those symbols are truly
+ references to the given variable (or function). That can make the result
+ include bindings which actually aren't used.
+- For the same reason it may cause the result to fail to include bindings
+ which will be used if SEXP is not yet fully macro-expanded and the
+ use of the binding will only be revealed by macro expansion."
+ (let ((res '()))
+ (while (and (consp sexp) bindings)
+ (dolist (binding (macroexp--fgrep bindings (pop sexp)))
+ (push binding res)
+ (setq bindings (remove binding bindings))))
+ (if (or (vectorp sexp) (byte-code-function-p sexp))
+ ;; With backquote, code can appear within vectors as well.
+ ;; This wouldn't be needed if we `macroexpand-all' before
+ ;; calling macroexp--fgrep, OTOH.
+ (macroexp--fgrep bindings (mapcar #'identity sexp))
+ (let ((tmp (assq sexp bindings)))
+ (if tmp
+ (cons tmp res)
+ res)))))
+
;;; Load-time macro-expansion.
;; Because macro-expansion used to be more lazy, eager macro-expansion
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 8fb79d2..72ea1ba 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -344,7 +344,7 @@ of the elements of LIST is performed as if by `pcase-let'.
(seen '())
(codegen
(lambda (code vars)
- (let ((vars (pcase--fgrep vars code))
+ (let ((vars (macroexp--fgrep vars code))
(prev (assq code seen)))
(if (not prev)
(let ((res (pcase-codegen code vars)))
@@ -401,7 +401,7 @@ of the elements of LIST is performed as if by `pcase-let'.
;; occurrences of this leaf since it's small.
(lambda (code vars)
(pcase-codegen code
- (pcase--fgrep vars code)))
+ (macroexp--fgrep vars code)))
codegen)
(cdr case)
vars))))
@@ -668,7 +668,7 @@ MATCH is the pattern that needs to be matched, of the form:
;; run, but we don't have the environment in which `pat' will
;; run, so we can't do a reliable verification. But let's try
;; and catch at least the easy cases such as (bug#14773).
- (not (pcase--fgrep (mapcar #'car vars) (cadr upat)))))
+ (not (macroexp--fgrep (mapcar #'car vars) (cadr upat)))))
'(:pcase--succeed . :pcase--fail))
((and (eq 'pred (car upat))
(let ((otherpred
@@ -692,23 +692,6 @@ MATCH is the pattern that needs to be matched, of the form:
'(nil . :pcase--fail)
'(:pcase--fail . nil))))))
-(defun pcase--fgrep (bindings sexp)
- "Return those of the BINDINGS which might be used in SEXP."
- (let ((res '()))
- (while (and (consp sexp) bindings)
- (dolist (binding (pcase--fgrep bindings (pop sexp)))
- (push binding res)
- (setq bindings (remove binding bindings))))
- (if (vectorp sexp)
- ;; With backquote, code can appear within vectors as well.
- ;; This wouldn't be needed if we `macroexpand-all' before
- ;; calling pcase--fgrep, OTOH.
- (pcase--fgrep bindings (mapcar #'identity sexp))
- (let ((tmp (assq sexp bindings)))
- (if tmp
- (cons tmp res)
- res)))))
-
(defun pcase--self-quoting-p (upat)
(or (keywordp upat) (integerp upat) (stringp upat)))
@@ -749,7 +732,7 @@ MATCH is the pattern that needs to be matched, of the form:
`(,fun ,arg)
(let* (;; `env' is an upper bound on the bindings we need.
(env (mapcar (lambda (x) (list (car x) (cdr x)))
- (pcase--fgrep vars fun)))
+ (macroexp--fgrep vars fun)))
(call (progn
(when (assq arg env)
;; `arg' is shadowed by `env'.
@@ -770,7 +753,7 @@ MATCH is the pattern that needs to be matched, of the form:
"Build an expression that will evaluate EXP."
(let* ((found (assq exp vars)))
(if found (cdr found)
- (let* ((env (pcase--fgrep vars exp)))
+ (let* ((env (macroexp--fgrep vars exp)))
(if env
(macroexp-let* (mapcar (lambda (x) (list (car x) (cdr x)))
env)
diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el
index 698467e..39e69f5 100644
--- a/lisp/emacs-lisp/shortdoc.el
+++ b/lisp/emacs-lisp/shortdoc.el
@@ -1126,12 +1126,21 @@ There can be any number of :example/:result elements."
(insert (propertize "("
'shortdoc-function t))
(if (plist-get data :no-manual)
- (insert (symbol-name function))
+ (insert-text-button
+ (symbol-name function)
+ 'face 'button
+ 'action (lambda (_)
+ (describe-function function))
+ 'follow-link t
+ 'help-echo (purecopy "mouse-1, RET: describe function"))
(insert-text-button
(symbol-name function)
'face 'button
'action (lambda (_)
- (info-lookup-symbol function 'emacs-lisp-mode))))
+ (info-lookup-symbol function 'emacs-lisp-mode))
+ 'follow-link t
+ 'help-echo (purecopy "mouse-1, RET: show \
+function's documentation in the Info manual")))
(setq arglist-start (point))
(insert ")\n")
;; Doc string.
diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el
index 18924a3..3fb8e46 100644
--- a/lisp/gnus/gnus-win.el
+++ b/lisp/gnus/gnus-win.el
@@ -145,7 +145,6 @@ used to display Gnus windows."
(,shell-command-buffer-name 1.0)))
(bug
(vertical 1.0
- (if gnus-bug-create-help-buffer '("*Gnus Help Bug*" 0.5))
("*Gnus Bug*" 1.0 point)))
(score-trace
(vertical 1.0
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index 3ff3d29..50e0218 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -620,8 +620,8 @@ Done before generating the new subject of a forward."
(defcustom message-forward-ignored-headers
"^Content-Transfer-Encoding:\\|^X-Gnus"
"All headers that match this regexp will be deleted when forwarding a
message.
-This variable is only consulted when forwarding \"normally\", not
-when forwarding as MIME or the like.
+This variable is not consulted when forwarding encrypted messages
+and `message-forward-show-mml' is `best'.
This may also be a list of regexps."
:version "21.1"
@@ -7638,7 +7638,8 @@ Optional DIGEST will use digest to forward."
message-forward-included-headers)
t nil t)))))
-(defun message-forward-make-body-mime (forward-buffer &optional beg end)
+(defun message-forward-make-body-mime (forward-buffer &optional beg end
+ remove-headers)
(let ((b (point)))
(insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")
(save-restriction
@@ -7648,6 +7649,8 @@ Optional DIGEST will use digest to forward."
(goto-char (point-min))
(when (looking-at "From ")
(replace-match "X-From-Line: "))
+ (when remove-headers
+ (message-remove-ignored-headers (point-min) (point-max)))
(goto-char (point-max)))
(insert "<#/part>\n")
;; Consider there is no illegible text.
@@ -7786,7 +7789,8 @@ is for the internal use."
(message-signed-or-encrypted-p)
(error t))))))
(message-forward-make-body-mml forward-buffer)
- (message-forward-make-body-mime forward-buffer))
+ (message-forward-make-body-mime
+ forward-buffer nil nil (not (eq message-forward-show-mml 'best))))
(message-forward-make-body-plain forward-buffer)))
(message-position-point))
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index afbb5e3..d559221 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -713,7 +713,9 @@ FILE is the file where FUNCTION was probably defined."
(insert-text-button
(symbol-name group)
'action (lambda (_)
- (shortdoc-display-group group))))
+ (shortdoc-display-group group))
+ 'follow-link t
+ 'help-echo (purecopy "mouse-1, RET: show documentation group")))
groups)
(insert (if (= (length groups) 1)
" group.\n"
diff --git a/lisp/help-mode.el b/lisp/help-mode.el
index cd08b2b..7043f12 100644
--- a/lisp/help-mode.el
+++ b/lisp/help-mode.el
@@ -357,8 +357,7 @@ Commands:
"\\(symbol\\|program\\|property\\)\\|" ; Don't link
"\\(source \\(?:code \\)?\\(?:of\\|for\\)\\)\\)"
"[ \t\n]+\\)?"
- ;; Note starting with word-syntax character:
- "['`‘]\\(\\sw\\(\\sw\\|\\s_\\)+\\|`\\)['’]"))
+ "['`‘]\\(\\(?:\\sw\\|\\s_\\)+\\|`\\)['’]"))
"Regexp matching doc string references to symbols.
The words preceding the quoted symbol can be used in doc strings to
diff --git a/lisp/international/characters.el b/lisp/international/characters.el
index 87e8589..9bce419 100644
--- a/lisp/international/characters.el
+++ b/lisp/international/characters.el
@@ -526,9 +526,6 @@ with L, LRE, or LRO Unicode bidi character type.")
;; FIXME: We should probably just use the Unicode properties to set
;; up the syntax table.
- ;; NBSP isn't semantically interchangeable with other whitespace chars,
- ;; so it's more like punctuation.
- (set-case-syntax ? "." tbl)
(set-case-syntax ?¡ "." tbl)
(set-case-syntax ?¦ "_" tbl)
(set-case-syntax ?§ "." tbl)
@@ -602,11 +599,17 @@ with L, LRE, or LRO Unicode bidi character type.")
;; Cyrillic Extended-C
(modify-category-entry '(#x1C80 . #x1C8F) ?y)
- ;; general punctuation
+ ;; space characters (see section 6.2 in the Unicode Standard)
+ (set-case-syntax ? " " tbl)
(setq c #x2000)
(while (<= c #x200b)
(set-case-syntax c " " tbl)
(setq c (1+ c)))
+ (let ((chars '(#x202F #x205F #x3000)))
+ (while chars
+ (set-case-syntax (car chars) " " tbl)
+ (setq chars (cdr chars))))
+ ;; general punctuation
(while (<= c #x200F)
(set-case-syntax c "." tbl)
(setq c (1+ c)))
diff --git a/lisp/mb-depth.el b/lisp/mb-depth.el
index ea2ea17..f9a24e3 100644
--- a/lisp/mb-depth.el
+++ b/lisp/mb-depth.el
@@ -37,6 +37,7 @@ and must return a string.")
(defface minibuffer-depth-indicator '((t :inherit highlight))
"Face to use for minibuffer depth indicator."
+ :group 'minibuffer
:version "28.1")
;; An overlay covering the prompt. This is a buffer-local variable in
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 556f5d3..315f2d3 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -2125,8 +2125,10 @@ variables.")
;; A better solution would be to make deactivate-mark buffer-local
;; (or to turn it into a list of buffers, ...), but in the mean time,
;; this should do the trick in most cases.
- (setq deactivate-mark nil)
- (throw 'exit nil))
+ (when (innermost-minibuffer-p)
+ (setq deactivate-mark nil)
+ (throw 'exit nil))
+ (error "%s" "Not in most nested minibuffer"))
(defun self-insert-and-exit ()
"Terminate minibuffer input."
@@ -2394,7 +2396,7 @@ The completion method is determined by
`completion-at-point-functions'."
;;; Key bindings.
(let ((map minibuffer-local-map))
- (define-key map "\C-g" 'abort-recursive-edit)
+ (define-key map "\C-g" 'abort-minibuffers)
(define-key map "\M-<" 'minibuffer-beginning-of-buffer)
(define-key map "\r" 'exit-minibuffer)
diff --git a/lisp/net/pop3.el b/lisp/net/pop3.el
index aa34fe7..dcac36f 100644
--- a/lisp/net/pop3.el
+++ b/lisp/net/pop3.el
@@ -463,7 +463,7 @@ Return non-nil if it is necessary to update the local UIDL
file."
(when (cdr elt)
(insert "(\"" (pop elt) "\"\n ")
(while elt
- (insert (format "\"%s\" %s\n " (pop elt) (pop elt))))
+ (insert (format "%S %s\n " (pop elt) (pop elt))))
(delete-char -4)
(insert ")\n ")))
(delete-char -3)
diff --git a/lisp/net/socks.el b/lisp/net/socks.el
index 0d48fd7..96fafc8 100644
--- a/lisp/net/socks.el
+++ b/lisp/net/socks.el
@@ -385,6 +385,7 @@
)
)
(process-put proc 'socks-state socks-state-authenticated)
+ (process-put proc 'socks-scratch "")
(set-process-filter proc #'socks-filter)))
proc)))
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index b43b448..7287315 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -2601,7 +2601,7 @@ The method used must be an out-of-band method."
(t nil)))))))))
(defun tramp-sh-handle-insert-directory
- (filename switches &optional wildcard full-directory-p)
+ (filename switches &optional wildcard full-directory-p)
"Like `insert-directory' for Tramp files."
(setq filename (expand-file-name filename))
(unless switches (setq switches ""))
@@ -2636,66 +2636,65 @@ The method used must be an out-of-band method."
v 4 "Inserting directory `ls %s %s', wildcard %s, fulldir %s"
switches filename (if wildcard "yes" "no")
(if full-directory-p "yes" "no"))
- ;; If `full-directory-p', we just say `ls -l FILENAME'.
- ;; Else we chdir to the parent directory, then say `ls -ld BASENAME'.
+ ;; If `full-directory-p', we just say `ls -l FILENAME'. Else we
+ ;; chdir to the parent directory, then say `ls -ld BASENAME'.
(if full-directory-p
(tramp-send-command
- v
- (format "%s %s %s 2>%s"
- (tramp-get-ls-command v)
- switches
- (if wildcard
- localname
- (tramp-shell-quote-argument (concat localname ".")))
- (tramp-get-remote-null-device v)))
+ v (format "%s %s %s 2>%s"
+ (tramp-get-ls-command v)
+ switches
+ (if wildcard
+ localname
+ (tramp-shell-quote-argument (concat localname ".")))
+ (tramp-get-remote-null-device v)))
(tramp-barf-unless-okay
- v
- (format "cd %s" (tramp-shell-quote-argument
- (tramp-run-real-handler
- #'file-name-directory (list localname))))
+ v (format "cd %s" (tramp-shell-quote-argument
+ (tramp-run-real-handler
+ #'file-name-directory (list localname))))
"Couldn't `cd %s'"
(tramp-shell-quote-argument
(tramp-run-real-handler #'file-name-directory (list localname))))
(tramp-send-command
- v
- (format "%s %s %s 2>%s"
- (tramp-get-ls-command v)
- switches
- (if (or wildcard
- (zerop (length
- (tramp-run-real-handler
- #'file-name-nondirectory (list localname)))))
- ""
- (tramp-shell-quote-argument
- (tramp-run-real-handler
- #'file-name-nondirectory (list localname))))
- (tramp-get-remote-null-device v))))
-
- (save-restriction
- (let ((beg (point))
- (emc enable-multibyte-characters))
- (narrow-to-region (point) (point))
- ;; We cannot use `insert-buffer-substring' because the Tramp
- ;; buffer changes its contents before insertion due to calling
- ;; `expand-file-name' and alike.
- (insert
- (with-current-buffer (tramp-get-buffer v)
- (buffer-string)))
-
- ;; Check for "--dired" output. We must enable unibyte
- ;; strings, because the "--dired" output counts in bytes.
- (set-buffer-multibyte nil)
+ v (format "%s %s %s 2>%s"
+ (tramp-get-ls-command v)
+ switches
+ (if (or wildcard
+ (zerop (length
+ (tramp-run-real-handler
+ #'file-name-nondirectory (list
localname)))))
+ ""
+ (tramp-shell-quote-argument
+ (tramp-run-real-handler
+ #'file-name-nondirectory (list localname))))
+ (tramp-get-remote-null-device v))))
+
+ (let ((beg-marker (point-marker))
+ (end-marker (point-marker))
+ (emc enable-multibyte-characters))
+ (set-marker-insertion-type beg-marker nil)
+ (set-marker-insertion-type end-marker t)
+ ;; We cannot use `insert-buffer-substring' because the Tramp
+ ;; buffer changes its contents before insertion due to calling
+ ;; `expand-file-name' and alike.
+ (insert (with-current-buffer (tramp-get-buffer v) (buffer-string)))
+
+ ;; We must enable unibyte strings, because the "--dired"
+ ;; output counts in bytes.
+ (set-buffer-multibyte nil)
+ (save-restriction
+ (narrow-to-region beg-marker end-marker)
+ ;; Check for "--dired" output.
(forward-line -2)
(when (looking-at-p "//SUBDIRED//")
(forward-line -1))
(when (looking-at "//DIRED//\\s-+")
- (let ((databeg (match-end 0))
+ (let ((beg (match-end 0))
(end (point-at-eol)))
;; Now read the numeric positions of file names.
- (goto-char databeg)
+ (goto-char beg)
(while (< (point) end)
- (let ((start (+ beg (read (current-buffer))))
- (end (+ beg (read (current-buffer)))))
+ (let ((start (+ (point-min) (read (current-buffer))))
+ (end (+ (point-min) (read (current-buffer)))))
(if (memq (char-after end) '(?\n ?\ ))
;; End is followed by \n or by " -> ".
(put-text-property start end 'dired-filename t))))))
@@ -2703,18 +2702,18 @@ The method used must be an out-of-band method."
(goto-char (point-at-bol))
(while (looking-at "//")
(forward-line 1)
- (delete-region (match-beginning 0) (point)))
- ;; Reset multibyte if needed.
- (set-buffer-multibyte emc)
+ (delete-region (match-beginning 0) (point))))
+ ;; Reset multibyte if needed.
+ (set-buffer-multibyte emc)
+ (save-restriction
+ (narrow-to-region beg-marker end-marker)
;; Some busyboxes are reluctant to discard colors.
(unless
(string-match-p "color" (tramp-get-connection-property v "ls" ""))
- (save-excursion
- (goto-char beg)
- (while
- (re-search-forward tramp-display-escape-sequence-regexp nil t)
- (replace-match ""))))
+ (goto-char (point-min))
+ (while (re-search-forward tramp-display-escape-sequence-regexp nil
t)
+ (replace-match "")))
;; Now decode what read if necessary. Stolen from
`insert-directory'.
(let ((coding (or coding-system-for-read
@@ -2729,36 +2728,32 @@ The method used must be an out-of-band method."
;; If no coding system is specified or detection is
;; requested, detect the coding.
(if (eq (coding-system-base coding) 'undecided)
- (setq coding (detect-coding-region beg (point) t)))
- (if (not (eq (coding-system-base coding) 'undecided))
- (save-restriction
- (setq coding-no-eol
- (coding-system-change-eol-conversion coding 'unix))
- (narrow-to-region beg (point))
- (goto-char (point-min))
- (while (not (eobp))
- (setq pos (point)
- val (get-text-property (point) 'dired-filename))
- (goto-char (next-single-property-change
- (point) 'dired-filename nil (point-max)))
- ;; Force no eol conversion on a file name, so
- ;; that CR is preserved.
- (decode-coding-region pos (point)
- (if val coding-no-eol coding))
- (if val
- (put-text-property pos (point)
- 'dired-filename t)))))))
+ (setq coding (detect-coding-region (point-min) (point) t)))
+ (unless (eq (coding-system-base coding) 'undecided)
+ (setq coding-no-eol
+ (coding-system-change-eol-conversion coding 'unix))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq pos (point)
+ val (get-text-property (point) 'dired-filename))
+ (goto-char (next-single-property-change
+ (point) 'dired-filename nil (point-max)))
+ ;; Force no eol conversion on a file name, so that
+ ;; CR is preserved.
+ (decode-coding-region
+ pos (point) (if val coding-no-eol coding))
+ (if val (put-text-property pos (point) 'dired-filename t))))))
;; The inserted file could be from somewhere else.
(when (and (not wildcard) (not full-directory-p))
(goto-char (point-max))
(when (file-symlink-p filename)
- (goto-char (search-backward "->" beg 'noerror)))
+ (goto-char (search-backward "->" (point-min) 'noerror)))
(search-backward
(if (directory-name-p filename)
"."
(file-name-nondirectory filename))
- beg 'noerror)
+ (point-min) 'noerror)
(replace-match (file-relative-name filename) t))
;; Try to insert the amount of free space.
@@ -2769,9 +2764,11 @@ The method used must be an out-of-band method."
;; Replace "total" with "total used", to avoid confusion.
(replace-match "\\1 used in directory")
(end-of-line)
- (insert " available " available)))
+ (insert " available " available))))
- (goto-char (point-max)))))))
+ (prog1 (goto-char end-marker)
+ (set-marker beg-marker nil)
+ (set-marker end-marker nil))))))
;; Canonicalization of file names.
diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el
index fddc13f..460af71 100644
--- a/lisp/progmodes/flymake.el
+++ b/lisp/progmodes/flymake.el
@@ -4,7 +4,7 @@
;; Author: Pavel Kobyakov <pk_at_work@yahoo.com>
;; Maintainer: João Távora <joaotavora@gmail.com>
-;; Version: 1.1.0
+;; Version: 1.1.1
;; Keywords: c languages tools
;; Package-Requires: ((emacs "26.1") (eldoc "1.1.0"))
@@ -1283,6 +1283,8 @@ correctly.")
(when (flymake-running-backends) flymake-mode-line-counter-format))
(defun flymake--mode-line-counter (type &optional no-space)
+ "Compute number of diagnostics in buffer with TYPE's severity.
+TYPE is usually keyword `:error', `:warning' or `:note'."
(let ((count 0)
(face (flymake--lookup-type-property type
'mode-line-face
@@ -1290,7 +1292,8 @@ correctly.")
(maphash (lambda
(_b state)
(dolist (d (flymake--backend-state-diags state))
- (when (eq type (flymake--diag-type d))
+ (when (= (flymake--severity type)
+ (flymake--severity (flymake--diag-type d)))
(cl-incf count))))
flymake--backend-state)
(when (or (cl-plusp count)
diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el
index c8f6c12..9f5f9ed 100644
--- a/lisp/progmodes/prolog.el
+++ b/lisp/progmodes/prolog.el
@@ -1201,7 +1201,9 @@ Commands:
(define-derived-mode mercury-mode prolog-mode "Prolog[Mercury]"
"Major mode for editing Mercury programs.
Actually this is just customized `prolog-mode'."
- (setq-local prolog-system 'mercury))
+ (setq-local prolog-system 'mercury)
+ ;; Run once more to set up based on `prolog-system'
+ (prolog-mode-variables))
;;-------------------------------------------------------------------
@@ -2082,7 +2084,7 @@ Argument BOUND is a buffer position limiting searching."
(delq
nil
(cond
- ((eq major-mode 'prolog-mode)
+ ((derived-mode-p 'prolog-mode)
(list
head-predicates
head-predicates-1
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el
index 0965fec..d6c0a4d 100644
--- a/lisp/progmodes/python.el
+++ b/lisp/progmodes/python.el
@@ -2027,8 +2027,12 @@ position, else returns nil."
:group 'python
:safe 'stringp)
-(defcustom python-shell-interpreter "python"
+(defcustom python-shell-interpreter
+ (cond ((executable-find "python3") "python3")
+ ((executable-find "python") "python")
+ (t "python3"))
"Default Python interpreter for shell."
+ :version "28.1"
:type 'string
:group 'python)
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index b393b8d..b6778de 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -663,6 +663,12 @@ means to first quit the *xref* buffer."
(interactive)
(xref-goto-xref t))
+(defun xref-quit-and-pop-marker-stack ()
+ "Quit *xref* buffer, then pop the xref marker stack."
+ (interactive)
+ (quit-window)
+ (xref-pop-marker-stack))
+
(defun xref-query-replace-in-results (from to)
"Perform interactive replacement of FROM with TO in all displayed xrefs.
@@ -793,6 +799,7 @@ references displayed in the current *xref* buffer."
(define-key map (kbd ".") #'xref-next-line)
(define-key map (kbd ",") #'xref-prev-line)
(define-key map (kbd "g") #'xref-revert-buffer)
+ (define-key map (kbd "M-,") #'xref-quit-and-pop-marker-stack)
map))
(define-derived-mode xref--xref-buffer-mode special-mode "XREF"
@@ -928,8 +935,10 @@ Return an alist of the form ((FILENAME . (XREF ...)) ...)."
(or
(assoc-default 'fetched-xrefs alist)
(funcall fetcher)))
- (xref-alist (xref--analyze xrefs)))
+ (xref-alist (xref--analyze xrefs))
+ (dd default-directory))
(with-current-buffer (get-buffer-create xref-buffer-name)
+ (setq default-directory dd)
(xref--xref-buffer-mode)
(xref--show-common-initialize xref-alist fetcher alist)
(pop-to-buffer (current-buffer))
@@ -992,13 +1001,15 @@ When only one definition found, jump to it right away
instead."
When there is more than one definition, split the selected window
and show the list in a small window at the bottom. And use a
local keymap that binds `RET' to `xref-quit-and-goto-xref'."
- (let ((xrefs (funcall fetcher)))
+ (let ((xrefs (funcall fetcher))
+ (dd default-directory))
(cond
((not (cdr xrefs))
(xref-pop-to-location (car xrefs)
(assoc-default 'display-action alist)))
(t
(with-current-buffer (get-buffer-create xref-buffer-name)
+ (setq default-directory dd)
(xref--transient-buffer-mode)
(xref--show-common-initialize (xref--analyze xrefs) fetcher alist)
(pop-to-buffer (current-buffer)
diff --git a/lisp/subr.el b/lisp/subr.el
index a5a979a..6d3ea45 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -995,6 +995,22 @@ a menu, so this function is not useful for non-menu
keymaps."
(setq inserted t)))
(setq tail (cdr tail)))))
+(defun define-prefix-command (command &optional mapvar name)
+ "Define COMMAND as a prefix command. COMMAND should be a symbol.
+A new sparse keymap is stored as COMMAND's function definition and its
+value.
+This prepares COMMAND for use as a prefix key's binding.
+If a second optional argument MAPVAR is given, it should be a symbol.
+The map is then stored as MAPVAR's value instead of as COMMAND's
+value; but COMMAND is still defined as a function.
+The third optional argument NAME, if given, supplies a menu name
+string for the map. This is required to use the keymap as a menu.
+This function returns COMMAND."
+ (let ((map (make-sparse-keymap name)))
+ (fset command map)
+ (set (or mapvar command) map)
+ command))
+
(defun map-keymap-sorted (function keymap)
"Implement `map-keymap' with sorting.
Don't call this function; it is for internal use only."
@@ -1239,9 +1255,6 @@ in a cleaner way with command remapping, like this:
;;;; The global keymap tree.
-;; global-map, esc-map, and ctl-x-map have their values set up in
-;; keymap.c; we just give them docstrings here.
-
(defvar esc-map
(let ((map (make-keymap)))
(define-key map "u" #'upcase-word)
@@ -1317,7 +1330,9 @@ The normal global definition of the character C-x
indirects to this keymap.")
map)
"Default global keymap mapping Emacs keyboard input into commands.
The value is a keymap that is usually (but not necessarily) Emacs's
-global map.")
+global map.
+
+See also `current-global-map'.")
(use-global-map global-map)
@@ -1861,9 +1876,33 @@ all symbols are bound before any of the VALUEFORMs are
evalled."
;; As a special-form, we could implement it more efficiently (and cleanly,
;; making the vars actually unbound during evaluation of the binders).
(declare (debug let) (indent 1))
- `(let ,(mapcar #'car binders)
- ,@(mapcar (lambda (binder) `(setq ,@binder)) binders)
- ,@body))
+ ;; Use plain `let*' for the non-recursive definitions.
+ ;; This only handles the case where the first few definitions are not
+ ;; recursive. Nothing as fancy as an SCC analysis.
+ (let ((seqbinds nil))
+ ;; Our args haven't yet been macro-expanded, so `macroexp--fgrep'
+ ;; may fail to see references that will be introduced later by
+ ;; macroexpansion. We could call `macroexpand-all' to avoid that,
+ ;; but in order to avoid that, we instead check to see if the binders
+ ;; appear in the macroexp environment, since that's how references can be
+ ;; introduced later on.
+ (unless (macroexp--fgrep binders macroexpand-all-environment)
+ (while (and binders
+ (null (macroexp--fgrep binders (nth 1 (car binders)))))
+ (push (pop binders) seqbinds)))
+ (let ((nbody (if (null binders)
+ (macroexp-progn body)
+ `(let ,(mapcar #'car binders)
+ ,@(mapcar (lambda (binder) `(setq ,@binder)) binders)
+ ,@body))))
+ (cond
+ ;; All bindings are recursive.
+ ((null seqbinds) nbody)
+ ;; Special case for trivial uses.
+ ((and (symbolp nbody) (null (cdr seqbinds)) (eq nbody (caar seqbinds)))
+ (nth 1 (car seqbinds)))
+ ;; General case.
+ (t `(let* ,(nreverse seqbinds) ,nbody))))))
(defmacro dlet (binders &rest body)
"Like `let*' but using dynamic scoping."
diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el
index 5a95e59..7e55655 100644
--- a/lisp/tab-bar.el
+++ b/lisp/tab-bar.el
@@ -187,9 +187,9 @@ on a console which has no window system but does have a
mouse."
;; Clicking anywhere outside existing tabs will add a new tab
(tab-bar-new-tab)))))
-;; Used in the Show/Hide menu, to have the toggle reflect the current frame.
(defun toggle-tab-bar-mode-from-frame (&optional arg)
"Toggle tab bar on or off, based on the status of the current frame.
+Used in the Show/Hide menu, to have the toggle reflect the current frame.
See `tab-bar-mode' for more information."
(interactive (list (or current-prefix-arg 'toggle)))
(if (eq arg 'toggle)
@@ -236,18 +236,31 @@ If the value is `1', then hide the tab bar when it has
only one tab,
and show it again once more tabs are created.
If nil, always keep the tab bar hidden. In this case it's still
possible to use persistent named window configurations by relying on
-keyboard commands `tab-new', `tab-close', `tab-next', `tab-switcher', etc."
+keyboard commands `tab-new', `tab-close', `tab-next', `tab-switcher', etc.
+
+Setting this variable directly does not take effect; please customize
+it (see the info node `Easy Customization'), then it will automatically
+update the tab bar on all frames according to the new value.
+
+To enable or disable the tab bar individually on each frame,
+you can use the command `toggle-frame-tab-bar'."
:type '(choice (const :tag "Always" t)
(const :tag "When more than one tab" 1)
(const :tag "Never" nil))
:initialize 'custom-initialize-default
:set (lambda (sym val)
(set-default sym val)
- (tab-bar-mode
- (if (or (eq val t)
- (and (natnump val)
- (> (length (funcall tab-bar-tabs-function)) val)))
- 1 -1)))
+ ;; Preload button images
+ (tab-bar-mode 1)
+ ;; Then handle each frame individually
+ (dolist (frame (frame-list))
+ (set-frame-parameter
+ frame 'tab-bar-lines
+ (if (or (eq val t)
+ (and (natnump val)
+ (> (length (funcall tab-bar-tabs-function frame))
+ val)))
+ 1 0))))
:group 'tab-bar
:version "27.1")
diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el
index 3346c55..6681b03 100644
--- a/lisp/textmodes/fill.el
+++ b/lisp/textmodes/fill.el
@@ -743,9 +743,16 @@ space does not end a sentence, so don't break a line
there."
;; This is the actual filling loop.
(goto-char from)
- (let (linebeg)
+ (let ((first t)
+ linebeg)
(while (< (point) to)
- (setq linebeg (point))
+ ;; On the first line, there may be text in the fill prefix
+ ;; zone. In that case, don't consider that area when
+ ;; trying to find a place to put a line break (bug#45720).
+ (if (not first)
+ (setq linebeg (point))
+ (setq first nil
+ linebeg (+ (point) (length fill-prefix))))
(move-to-column (current-fill-column))
(if (when (< (point) to)
;; Find the position where we'll break the line.
diff --git a/lisp/textmodes/paragraphs.el b/lisp/textmodes/paragraphs.el
index 217ae10..96edfd6 100644
--- a/lisp/textmodes/paragraphs.el
+++ b/lisp/textmodes/paragraphs.el
@@ -371,50 +371,33 @@ See `forward-paragraph' for more information."
(defun mark-paragraph (&optional arg allow-extend)
"Put point at beginning of this paragraph, mark at end.
-The paragraph marked is the one that contains point or follows
-point.
+The paragraph marked is the one that contains point or follows point.
-With argument ARG, puts mark at the end of this or a following
-paragraph, so that the number of paragraphs marked equals ARG.
+With argument ARG, puts mark at end of a following paragraph, so that
+the number of paragraphs marked equals ARG.
-If ARG is negative, point is put at the end of this paragraph,
-mark is put at the beginning of this or a previous paragraph.
+If ARG is negative, point is put at end of this paragraph, mark is put
+at beginning of this or a previous paragraph.
Interactively (or if ALLOW-EXTEND is non-nil), if this command is
-repeated or (in Transient Mark mode) if the mark is active, it
-marks the next ARG paragraphs after the region already marked.
-This also means when activating the mark immediately before using
-this command, the current paragraph is only marked from point."
- (interactive "P\np")
- (let ((numeric-arg (prefix-numeric-value arg)))
- (cond ((zerop numeric-arg))
- ((and allow-extend
- (or (and (eq last-command this-command) mark-active)
- (region-active-p)))
- (if arg
- (setq arg numeric-arg)
- (if (< (mark) (point))
- (setq arg -1)
- (setq arg 1)))
- (set-mark
- (save-excursion
- (goto-char (mark))
- (forward-paragraph arg)
- (point))))
- ;; don't activate the mark when at eob
- ((and (eobp) (> numeric-arg 0)))
- (t
- (unless (save-excursion
- (forward-line 0)
- (looking-at paragraph-start))
- (backward-paragraph (cond ((> numeric-arg 0) 1)
- ((< numeric-arg 0) -1)
- (t 0))))
- (push-mark
- (save-excursion
- (forward-paragraph numeric-arg)
- (point))
- t t)))))
+repeated or (in Transient Mark mode) if the mark is active,
+it marks the next ARG paragraphs after the ones already marked."
+ (interactive "p\np")
+ (unless arg (setq arg 1))
+ (when (zerop arg)
+ (error "Cannot mark zero paragraphs"))
+ (cond ((and allow-extend
+ (or (and (eq last-command this-command) (mark t))
+ (and transient-mark-mode mark-active)))
+ (set-mark
+ (save-excursion
+ (goto-char (mark))
+ (forward-paragraph arg)
+ (point))))
+ (t
+ (forward-paragraph arg)
+ (push-mark nil t t)
+ (backward-paragraph arg))))
(defun kill-paragraph (arg)
"Kill forward to end of paragraph.
diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el
index 073059d..d4c1b87 100644
--- a/lisp/textmodes/reftex-vars.el
+++ b/lisp/textmodes/reftex-vars.el
@@ -906,7 +906,8 @@ DOWNCASE t: Downcase words before using them."
;; begin, optional spaces and opening brace
"begin[[:space:]]*{"
;; Build a regexp for env names
- (regexp-opt '("lstlisting" "dmath" "dseries" "dgroup" "darray"))
+ (regexp-opt '("lstlisting" "dmath" "dseries" "dgroup"
+ "darray" "frame"))
;; closing brace, optional spaces
"}[[:space:]]*"
;; Now for macros
@@ -919,9 +920,9 @@ DOWNCASE t: Downcase words before using them."
"\\[[^][]*"
;; Allow nested levels of chars enclosed in braces
"\\(?:{[^}{]*"
- "\\(?:{[^}{]*"
- "\\(?:{[^}{]*}[^}{]*\\)*"
- "}[^}{]*\\)*"
+ "\\(?:{[^}{]*"
+ "\\(?:{[^}{]*}[^}{]*\\)*"
+ "}[^}{]*\\)*"
"}[^][]*\\)*"
;; Match the label key
"\\<label[[:space:]]*=[[:space:]]*"
@@ -944,7 +945,7 @@ you have to define it using \\(?1:...\\) when adding new
regexps.
When changed from Lisp, make sure to call
`reftex-compile-variables' afterwards to make the change
effective."
- :version "27.1"
+ :version "28.1"
:set (lambda (symbol value)
(set symbol value)
(when (fboundp 'reftex-compile-variables)
diff --git a/lisp/window.el b/lisp/window.el
index cd13e66..a6cdd4d 100644
--- a/lisp/window.el
+++ b/lisp/window.el
@@ -4116,7 +4116,10 @@ frame can be safely deleted."
frame))
(throw 'other t))))
(let ((minibuf (active-minibuffer-window)))
- (and minibuf (eq frame (window-frame minibuf)))))
+ (and minibuf (eq frame (window-frame minibuf))
+ (not (eq (default-toplevel-value
+ minibuffer-follows-selected-frame)
+ t)))))
'frame))
((window-minibuffer-p window)
;; If WINDOW is the minibuffer window of a non-minibuffer-only
@@ -7243,6 +7246,7 @@ The actual non-nil value of this variable will be copied
to the
(const display-buffer-below-selected)
(const display-buffer-at-bottom)
(const display-buffer-in-previous-window)
+ (const display-buffer-use-least-recent-window)
(const display-buffer-use-some-window)
(const display-buffer-use-some-frame)
(function :tag "Other function"))
@@ -7378,6 +7382,37 @@ fails, call `display-buffer-pop-up-frame'.")
(defun display-buffer (buffer-or-name &optional action frame)
"Display BUFFER-OR-NAME in some window, without selecting it.
+To change which window is used, set `display-buffer-alist'
+to an expression containing one of these \"action\" functions:
+
+ `display-buffer-same-window' -- Use the selected window.
+ `display-buffer-reuse-window' -- Use a window already showing
+ the buffer.
+ `display-buffer-in-previous-window' -- Use a window that did
+ show the buffer before.
+ `display-buffer-use-some-window' -- Use some existing window.
+ `display-buffer-use-least-recent-window' -- Try to avoid re-using
+ windows that have recently been switched to.
+ `display-buffer-pop-up-window' -- Pop up a new window.
+ `display-buffer-below-selected' -- Use or pop up a window below
+ the selected one.
+ `display-buffer-at-bottom' -- Use or pop up a window at the
+ bottom of the selected frame.
+ `display-buffer-pop-up-frame' -- Show the buffer on a new frame.
+ `display-buffer-in-child-frame' -- Show the buffer in a
+ child frame.
+ `display-buffer-no-window' -- Do not display the buffer and
+ have `display-buffer' return nil immediately.
+
+For instance:
+
+ (setq display-buffer-alist '((\".*\" display-buffer-at-bottom)))
+
+Buffer display can be further customized to a very high degree;
+the rest of this docstring explains some of the many
+possibilities, and also see `(emacs)Window Choice' for more
+information.
+
BUFFER-OR-NAME must be a buffer or a string naming a live buffer.
Return the window chosen for displaying that buffer, or nil if no
such window is found.
@@ -7403,23 +7438,8 @@ function in the combined function list in turn, passing
the
buffer as the first argument and the combined action alist as the
second argument, until one of the functions returns non-nil.
-Action functions and the action they try to perform are:
- `display-buffer-same-window' -- Use the selected window.
- `display-buffer-reuse-window' -- Use a window already showing
- the buffer.
- `display-buffer-in-previous-window' -- Use a window that did
- show the buffer before.
- `display-buffer-use-some-window' -- Use some existing window.
- `display-buffer-pop-up-window' -- Pop up a new window.
- `display-buffer-below-selected' -- Use or pop up a window below
- the selected one.
- `display-buffer-at-bottom' -- Use or pop up a window at the
- bottom of the selected frame.
- `display-buffer-pop-up-frame' -- Show the buffer on a new frame.
- `display-buffer-in-child-frame' -- Show the buffer in a
- child frame.
- `display-buffer-no-window' -- Do not display the buffer and
- have `display-buffer' return nil immediately.
+See above for the action functions and the action they try to
+perform.
Action alist entries are:
`inhibit-same-window' -- A non-nil value prevents the same
@@ -8242,6 +8262,16 @@ indirectly called by the latter."
(when (setq window (or best-window second-best-window))
(window--display-buffer buffer window 'reuse alist))))
+(defun display-buffer-use-least-recent-window (buffer alist)
+ "Display BUFFER in an existing window, but that hasn't been used lately.
+This `display-buffer' action function is like
+`display-buffer-use-some-window', but will cycle through windows
+when displaying buffers repeatedly, and if there's only a single
+window, it will split the window."
+ (when-let ((window (display-buffer-use-some-window
+ buffer (cons (cons 'inhibit-same-window t) alist))))
+ (window-bump-use-time window)))
+
(defun display-buffer-use-some-window (buffer alist)
"Display BUFFER in an existing window.
Search for a usable window, set that window to the buffer, and
diff --git a/src/buffer.c b/src/buffer.c
index 71ad5ed..80c799e 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -4785,7 +4785,7 @@ mmap_init (void)
if (mmap_fd <= 0)
{
/* No anonymous mmap -- we need the file descriptor. */
- mmap_fd = emacs_open ("/dev/zero", O_RDONLY, 0);
+ mmap_fd = emacs_open_noquit ("/dev/zero", O_RDONLY, 0);
if (mmap_fd == -1)
fatal ("Cannot open /dev/zero: %s", emacs_strerror (errno));
}
diff --git a/src/callproc.c b/src/callproc.c
index 8d2a561..cb72b07 100644
--- a/src/callproc.c
+++ b/src/callproc.c
@@ -314,6 +314,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int
filefd,
#ifdef MSDOS /* Demacs 1.1.1 91/10/16 HIRANO Satoshi */
char *tempfile = NULL;
#else
+ sigset_t oldset;
pid_t pid = -1;
#endif
int child_errno;
@@ -601,9 +602,12 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int
filefd,
#ifndef MSDOS
+ block_input ();
+ block_child_signal (&oldset);
+
child_errno
= emacs_spawn (&pid, filefd, fd_output, fd_error, new_argv, env,
- SSDATA (current_dir), NULL);
+ SSDATA (current_dir), NULL, &oldset);
eassert ((child_errno == 0) == (0 < pid));
if (pid > 0)
@@ -624,6 +628,9 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int
filefd,
}
}
+ unblock_child_signal (&oldset);
+ unblock_input ();
+
if (pid < 0)
report_file_errno (CHILD_SETUP_ERROR_DESC, Qnil, child_errno);
@@ -1227,17 +1234,21 @@ child_setup (int in, int out, int err, char **new_argv,
char **env,
process image file ARGV[0]. Use ENVP for the environment block for
the new process. Use CWD as working directory for the new process.
If PTY is not NULL, it must be a pseudoterminal device. If PTY is
- NULL, don't perform any terminal setup. */
+ NULL, don't perform any terminal setup. OLDSET must be a pointer
+ to a signal set initialized by `block_child_signal'. Before
+ calling this function, call `block_input' and `block_child_signal';
+ afterwards, call `unblock_input' and `unblock_child_signal'. Be
+ sure to call `unblock_child_signal' only after registering NEWPID
+ in a list where `handle_child_signal' can find it! */
int
emacs_spawn (pid_t *newpid, int std_in, int std_out, int std_err,
- char **argv, char **envp, const char *cwd, const char *pty)
+ char **argv, char **envp, const char *cwd,
+ const char *pty, const sigset_t *oldset)
{
- sigset_t oldset;
int pid;
- block_input ();
- block_child_signal (&oldset);
+ eassert (input_blocked_p ());
#ifndef WINDOWSNT
/* vfork, and prevent local vars from being clobbered by the vfork. */
@@ -1249,6 +1260,7 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int
std_err,
int volatile stdout_volatile = std_out;
int volatile stderr_volatile = std_err;
char **volatile envp_volatile = envp;
+ const sigset_t *volatile oldset_volatile = oldset;
#ifdef DARWIN_OS
/* Darwin doesn't let us run setsid after a vfork, so use fork when
@@ -1270,6 +1282,7 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int
std_err,
std_out = stdout_volatile;
std_err = stderr_volatile;
envp = envp_volatile;
+ oldset = oldset_volatile;
if (pid == 0)
#endif /* not WINDOWSNT */
@@ -1323,7 +1336,7 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int
std_err,
would work? */
if (std_in >= 0)
emacs_close (std_in);
- std_out = std_in = emacs_open (pty, O_RDWR, 0);
+ std_out = std_in = emacs_open_noquit (pty, O_RDWR, 0);
if (std_in < 0)
{
@@ -1364,7 +1377,7 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int
std_err,
#endif
/* Stop blocking SIGCHLD in the child. */
- unblock_child_signal (&oldset);
+ unblock_child_signal (oldset);
if (pty_flag)
child_setup_tty (std_out);
@@ -1382,10 +1395,6 @@ emacs_spawn (pid_t *newpid, int std_in, int std_out, int
std_err,
int vfork_error = pid < 0 ? errno : 0;
- /* Stop blocking in the parent. */
- unblock_child_signal (&oldset);
- unblock_input ();
-
if (pid < 0)
{
eassert (0 < vfork_error);
diff --git a/src/emacs.c b/src/emacs.c
index 69d1082..7711427 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -1275,7 +1275,7 @@ main (int argc, char **argv)
{
emacs_close (STDIN_FILENO);
emacs_close (STDOUT_FILENO);
- int result = emacs_open (term, O_RDWR, 0);
+ int result = emacs_open_noquit (term, O_RDWR, 0);
if (result != STDIN_FILENO
|| (fcntl (STDIN_FILENO, F_DUPFD_CLOEXEC, STDOUT_FILENO)
!= STDOUT_FILENO))
@@ -2847,7 +2847,7 @@ from the parent process and its tty file descriptors. */)
int nfd;
/* Get rid of stdin, stdout and stderr. */
- nfd = emacs_open ("/dev/null", O_RDWR, 0);
+ nfd = emacs_open_noquit ("/dev/null", O_RDWR, 0);
err |= nfd < 0;
err |= dup2 (nfd, STDIN_FILENO) < 0;
err |= dup2 (nfd, STDOUT_FILENO) < 0;
diff --git a/src/eval.c b/src/eval.c
index 706aafd..5bf3fae 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1167,9 +1167,18 @@ Lisp_Object
internal_catch (Lisp_Object tag,
Lisp_Object (*func) (Lisp_Object), Lisp_Object arg)
{
+ /* MINIBUFFER_QUIT_LEVEL is to handle quitting from nested minibuffers by
+ throwing t to tag `exit'.
+ Value -1 means there is no (throw 'exit t) in progress;
+ 0 means the `throw' wasn't done from an active minibuffer;
+ N > 0 means the `throw' was done from the minibuffer at level N. */
+ static EMACS_INT minibuffer_quit_level = -1;
/* This structure is made part of the chain `catchlist'. */
struct handler *c = push_handler (tag, CATCHER);
+ if (EQ (tag, Qexit))
+ minibuffer_quit_level = -1;
+
/* Call FUNC. */
if (! sys_setjmp (c->jmp))
{
@@ -1183,6 +1192,23 @@ internal_catch (Lisp_Object tag,
Lisp_Object val = handlerlist->val;
clobbered_eassert (handlerlist == c);
handlerlist = handlerlist->next;
+ if (EQ (tag, Qexit) && EQ (val, Qt))
+ /* If we've thrown t to tag `exit' from within a minibuffer, we
+ exit all minibuffers more deeply nested than the current
+ one. */
+ {
+ EMACS_INT mini_depth = this_minibuffer_depth (Qnil);
+ if (mini_depth && mini_depth != minibuffer_quit_level)
+ {
+ if (minibuffer_quit_level == -1)
+ minibuffer_quit_level = mini_depth;
+ if (minibuffer_quit_level
+ && (minibuf_level > minibuffer_quit_level))
+ Fthrow (Qexit, Qt);
+ }
+ else
+ minibuffer_quit_level = -1;
+ }
return val;
}
}
diff --git a/src/keymap.c b/src/keymap.c
index 3d19938..1197f6f 100644
--- a/src/keymap.c
+++ b/src/keymap.c
@@ -1712,28 +1712,6 @@ bindings; see the description of `lookup-key' for more
details about this. */)
return Flist (j, maps);
}
-DEFUN ("define-prefix-command", Fdefine_prefix_command,
Sdefine_prefix_command, 1, 3, 0,
- doc: /* Define COMMAND as a prefix command. COMMAND should be a symbol.
-A new sparse keymap is stored as COMMAND's function definition and its
-value.
-This prepares COMMAND for use as a prefix key's binding.
-If a second optional argument MAPVAR is given, it should be a symbol.
-The map is then stored as MAPVAR's value instead of as COMMAND's
-value; but COMMAND is still defined as a function.
-The third optional argument NAME, if given, supplies a menu name
-string for the map. This is required to use the keymap as a menu.
-This function returns COMMAND. */)
- (Lisp_Object command, Lisp_Object mapvar, Lisp_Object name)
-{
- Lisp_Object map = Fmake_sparse_keymap (name);
- Ffset (command, map);
- if (!NILP (mapvar))
- Fset (mapvar, map);
- else
- Fset (command, map);
- return command;
-}
-
DEFUN ("use-global-map", Fuse_global_map, Suse_global_map, 1, 1, 0,
doc: /* Select KEYMAP as the global keymap. */)
(Lisp_Object keymap)
@@ -3280,7 +3258,6 @@ be preferred. */);
defsubr (&Sminor_mode_key_binding);
defsubr (&Sdefine_key);
defsubr (&Slookup_key);
- defsubr (&Sdefine_prefix_command);
defsubr (&Suse_global_map);
defsubr (&Suse_local_map);
defsubr (&Scurrent_local_map);
diff --git a/src/lisp.h b/src/lisp.h
index ca0eb51..9d8dbbd 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -4346,6 +4346,8 @@ extern Lisp_Object Vminibuffer_list;
extern Lisp_Object last_minibuf_string;
extern void move_minibuffer_onto_frame (void);
extern bool is_minibuffer (EMACS_INT, Lisp_Object);
+extern EMACS_INT this_minibuffer_depth (Lisp_Object);
+extern EMACS_INT minibuf_level;
extern Lisp_Object get_minibuffer (EMACS_INT);
extern void init_minibuf_once (void);
extern void syms_of_minibuf (void);
@@ -4495,8 +4497,8 @@ extern void setup_process_coding_systems (Lisp_Object);
# define CHILD_SETUP_ERROR_DESC "Doing vfork"
#endif
-extern int emacs_spawn (pid_t *, int, int, int, char **, char **, const char *,
- const char *);
+extern int emacs_spawn (pid_t *, int, int, int, char **, char **,
+ const char *, const char *, const sigset_t *);
extern char **make_environment_block (Lisp_Object);
extern void init_callproc_1 (void);
extern void init_callproc (void);
@@ -4575,6 +4577,7 @@ extern AVOID emacs_abort (void) NO_INLINE;
extern int emacs_fstatat (int, char const *, void *, int);
extern int emacs_openat (int, char const *, int, int);
extern int emacs_open (const char *, int, int);
+extern int emacs_open_noquit (const char *, int, int);
extern int emacs_pipe (int[2]);
extern int emacs_close (int);
extern ptrdiff_t emacs_read (int, void *, ptrdiff_t);
diff --git a/src/minibuf.c b/src/minibuf.c
index 8b23569..868e481 100644
--- a/src/minibuf.c
+++ b/src/minibuf.c
@@ -63,10 +63,31 @@ static Lisp_Object minibuf_prompt;
static ptrdiff_t minibuf_prompt_width;
+static Lisp_Object nth_minibuffer (EMACS_INT depth);
+
+/* Return TRUE when a frame switch causes a minibuffer on the old
+ frame to move onto the new one. */
static bool
minibuf_follows_frame (void)
{
+ return EQ (Fdefault_toplevel_value (Qminibuffer_follows_selected_frame),
+ Qt);
+}
+
+/* Return TRUE when a minibuffer always remains on the frame where it
+ was first invoked. */
+static bool
+minibuf_stays_put (void)
+{
+ return NILP (Fdefault_toplevel_value (Qminibuffer_follows_selected_frame));
+}
+
+/* Return TRUE when opening a (recursive) minibuffer causes
+ minibuffers on other frames to move to the selected frame. */
+static bool
+minibuf_moves_frame_when_opened (void)
+{
return !NILP (Fdefault_toplevel_value (Qminibuffer_follows_selected_frame));
}
@@ -90,7 +111,7 @@ choose_minibuf_frame (void)
minibuf_window = sf->minibuffer_window;
/* If we've still got another minibuffer open, use its mini-window
instead. */
- if (minibuf_level && !minibuf_follows_frame ())
+ if (minibuf_level > 1 && minibuf_stays_put ())
{
Lisp_Object buffer = get_minibuffer (minibuf_level);
Lisp_Object tail, frame;
@@ -105,26 +126,40 @@ choose_minibuf_frame (void)
}
}
- if (minibuf_follows_frame ())
+ if (minibuf_moves_frame_when_opened ()
+ && FRAMEP (selected_frame)
+ && FRAME_LIVE_P (XFRAME (selected_frame)))
/* Make sure no other frame has a minibuffer as its selected window,
because the text would not be displayed in it, and that would be
confusing. Only allow the selected frame to do this,
and that only if the minibuffer is active. */
- {
- Lisp_Object tail, frame;
-
- FOR_EACH_FRAME (tail, frame)
- if (MINI_WINDOW_P (XWINDOW (FRAME_SELECTED_WINDOW (XFRAME (frame))))
- && !(EQ (frame, selected_frame)
- && minibuf_level > 0))
- Fset_frame_selected_window (frame, Fframe_first_window (frame),
- Qnil);
- }
+ {
+ Lisp_Object tail, frame;
+ struct frame *of;
+
+ FOR_EACH_FRAME (tail, frame)
+ if (!EQ (frame, selected_frame)
+ && minibuf_level > 1
+ /* The frame's minibuffer can be on a different frame. */
+ && ! EQ (XWINDOW ((of = XFRAME (frame))->minibuffer_window)->frame,
+ selected_frame))
+ {
+ if (MINI_WINDOW_P (XWINDOW (FRAME_SELECTED_WINDOW (of))))
+ Fset_frame_selected_window (frame, Fframe_first_window (frame),
+ Qnil);
+
+ if (!EQ (XWINDOW (of->minibuffer_window)->contents,
+ nth_minibuffer (0)))
+ set_window_buffer (of->minibuffer_window,
+ nth_minibuffer (0), 0, 0);
+ }
+ }
}
-/* If `minibuffer_follows_selected_frame' and we have a minibuffer, move it
- from its current frame to the selected frame. This function is
- intended to be called from `do_switch_frame' in frame.c. */
+/* If `minibuffer_follows_selected_frame' is t and we have a
+ minibuffer, move it from its current frame to the selected frame.
+ This function is intended to be called from `do_switch_frame' in
+ frame.c. */
void move_minibuffer_onto_frame (void)
{
if (!minibuf_level)
@@ -135,14 +170,18 @@ void move_minibuffer_onto_frame (void)
&& FRAME_LIVE_P (XFRAME (selected_frame))
&& !EQ (minibuf_window, XFRAME (selected_frame)->minibuffer_window))
{
+ EMACS_INT i;
struct frame *sf = XFRAME (selected_frame);
Lisp_Object old_frame = XWINDOW (minibuf_window)->frame;
struct frame *of = XFRAME (old_frame);
- Lisp_Object buffer = XWINDOW (minibuf_window)->contents;
- set_window_buffer (sf->minibuffer_window, buffer, 0, 0);
+ /* Stack up all the (recursively) open minibuffers on the selected
+ mini_window. */
+ for (i = 1; i <= minibuf_level; i++)
+ set_window_buffer (sf->minibuffer_window, nth_minibuffer (i), 0, 0);
minibuf_window = sf->minibuffer_window;
- set_window_buffer (of->minibuffer_window, get_minibuffer (0), 0, 0);
+ if (of != sf)
+ set_window_buffer (of->minibuffer_window, get_minibuffer (0), 0, 0);
}
}
@@ -336,6 +375,63 @@ return t only if BUFFER is an active minibuffer. */)
? Qt : Qnil;
}
+DEFUN ("innermost-minibuffer-p", Finnermost_minibuffer_p,
+ Sinnermost_minibuffer_p, 0, 1, 0,
+ doc: /* Return t if BUFFER is the most nested active minibuffer.
+No argument or nil as argument means use the current buffer as BUFFER. */)
+ (Lisp_Object buffer)
+{
+ if (NILP (buffer))
+ buffer = Fcurrent_buffer ();
+ return EQ (buffer, (Fcar (Fnthcdr (make_fixnum (minibuf_level),
+ Vminibuffer_list))))
+ ? Qt
+ : Qnil;
+}
+
+/* Return the nesting depth of the active minibuffer BUFFER, or 0 if
+ BUFFER isn't such a thing. If BUFFER is nil, this means use the current
+ buffer. */
+EMACS_INT
+this_minibuffer_depth (Lisp_Object buffer)
+{
+ EMACS_INT i;
+ Lisp_Object bufs;
+
+ if (NILP (buffer))
+ buffer = Fcurrent_buffer ();
+ for (i = 1, bufs = Fcdr (Vminibuffer_list);
+ i <= minibuf_level;
+ i++, bufs = Fcdr (bufs))
+ if (EQ (Fcar (bufs), buffer))
+ return i;
+ return 0;
+}
+
+DEFUN ("abort-minibuffers", Fabort_minibuffers, Sabort_minibuffers, 0, 0, "",
+ doc: /* Abort the current minibuffer.
+If we are not currently in the innermost minibuffer, prompt the user to
+confirm the aborting of the current minibuffer and all contained ones. */)
+ (void)
+{
+ EMACS_INT minibuf_depth = this_minibuffer_depth (Qnil);
+ Lisp_Object array[2];
+ AUTO_STRING (fmt, "Abort %s minibuffer levels? ");
+
+ if (!minibuf_depth)
+ error ("Not in a minibuffer");
+ if (minibuf_depth < minibuf_level)
+ {
+ array[0] = fmt;
+ array[1] = make_fixnum (minibuf_level - minibuf_depth + 1);
+ if (!NILP (Fyes_or_no_p (Fformat (2, array))))
+ Fthrow (Qexit, Qt);
+ }
+ else
+ Fthrow (Qexit, Qt);
+ return Qnil;
+}
+
DEFUN ("minibuffer-prompt-end", Fminibuffer_prompt_end,
Sminibuffer_prompt_end, 0, 0, 0,
doc: /* Return the buffer position of the end of the minibuffer prompt.
@@ -411,6 +507,7 @@ read_minibuf (Lisp_Object map, Lisp_Object initial,
Lisp_Object prompt,
Lisp_Object val;
ptrdiff_t count = SPECPDL_INDEX ();
Lisp_Object mini_frame, ambient_dir, minibuffer, input_method;
+ Lisp_Object calling_frame = selected_frame;
Lisp_Object enable_multibyte;
EMACS_INT pos = 0;
/* String to add to the history. */
@@ -648,6 +745,17 @@ read_minibuf (Lisp_Object map, Lisp_Object initial,
Lisp_Object prompt,
}
}
+ if (minibuf_moves_frame_when_opened ())
+ {
+ EMACS_INT i;
+
+ /* Stack up all the (recursively) open minibuffers on the selected
+ mini_window. */
+ for (i = 1; i < minibuf_level; i++)
+ set_window_buffer (XFRAME (mini_frame)->minibuffer_window,
+ nth_minibuffer (i), 0, 0);
+ }
+
/* Display this minibuffer in the proper window. */
/* Use set_window_buffer instead of Fset_window_buffer (see
discussion of bug#11984, bug#12025, bug#12026). */
@@ -729,6 +837,20 @@ read_minibuf (Lisp_Object map, Lisp_Object initial,
Lisp_Object prompt,
recursive_edit_1 ();
+ /* We've exited the recursive edit without an error, so switch the
+ current window away from the expired minibuffer window. */
+ {
+ Lisp_Object prev = Fprevious_window (minibuf_window, Qnil, Qnil);
+ /* PREV can be on a different frame when we have a minibuffer only
+ frame, the other frame's minibuffer window is MINIBUF_WINDOW,
+ and its "focus window" is also MINIBUF_WINDOW. */
+ while (!EQ (prev, minibuf_window)
+ && !EQ (selected_frame, WINDOW_FRAME (XWINDOW (prev))))
+ prev = Fprevious_window (prev, Qnil, Qnil);
+ if (!EQ (prev, minibuf_window))
+ Fset_frame_selected_window (selected_frame, prev, Qnil);
+ }
+
/* If cursor is on the minibuffer line,
show the user we have exited by putting it in column 0. */
if (XWINDOW (minibuf_window)->cursor.vpos >= 0
@@ -767,6 +889,12 @@ read_minibuf (Lisp_Object map, Lisp_Object initial,
Lisp_Object prompt,
in set-window-configuration. */
unbind_to (count, Qnil);
+ /* Switch the frame back to the calling frame. */
+ if (!EQ (selected_frame, calling_frame)
+ && FRAMEP (calling_frame)
+ && FRAME_LIVE_P (XFRAME (calling_frame)))
+ call2 (intern ("select-frame-set-input-focus"), calling_frame, Qnil);
+
/* Add the value to the appropriate history list, if any. This is
done after the previous buffer has been made current again, in
case the history variable is buffer-local. */
@@ -790,6 +918,14 @@ is_minibuffer (EMACS_INT depth, Lisp_Object buf)
&& EQ (Fcar (tail), buf);
}
+/* Return the DEPTHth minibuffer, or nil if such does not yet exist. */
+static Lisp_Object
+nth_minibuffer (EMACS_INT depth)
+{
+ Lisp_Object tail = Fnthcdr (make_fixnum (depth), Vminibuffer_list);
+ return XCAR (tail);
+}
+
/* Return a buffer to be used as the minibuffer at depth `depth'.
depth = 0 is the lowest allowed argument, and that is the value
used for nonrecursive minibuffer invocations. */
@@ -2013,9 +2149,6 @@ syms_of_minibuf (void)
DEFSYM (Qminibuffer_setup_hook, "minibuffer-setup-hook");
DEFSYM (Qminibuffer_exit_hook, "minibuffer-exit-hook");
- /* The maximum length of a minibuffer history. */
- DEFSYM (Qhistory_length, "history-length");
-
DEFSYM (Qcurrent_input_method, "current-input-method");
DEFSYM (Qactivate_input_method, "activate-input-method");
DEFSYM (Qcase_fold_search, "case-fold-search");
@@ -2035,13 +2168,15 @@ For example, `eval-expression' uses this. */);
The function is called with the arguments passed to `read-buffer'. */);
Vread_buffer_function = Qnil;
- DEFVAR_BOOL ("minibuffer-follows-selected-frame",
minibuffer_follows_selected_frame,
- doc: /* Non-nil means the active minibuffer always displays on
the selected frame.
+ DEFVAR_LISP ("minibuffer-follows-selected-frame",
minibuffer_follows_selected_frame,
+ doc: /* t means the active minibuffer always displays on the
selected frame.
Nil means that a minibuffer will appear only in the frame which created it.
+Any other value means the minibuffer will move onto another frame, but
+only when the user starts using a minibuffer there.
Any buffer local or dynamic binding of this variable is ignored. Only the
default top level value is used. */);
- minibuffer_follows_selected_frame = 1;
+ minibuffer_follows_selected_frame = Qt;
DEFVAR_BOOL ("read-buffer-completion-ignore-case",
read_buffer_completion_ignore_case,
@@ -2199,6 +2334,8 @@ uses to hide passwords. */);
defsubr (&Sminibuffer_prompt);
defsubr (&Sminibufferp);
+ defsubr (&Sinnermost_minibuffer_p);
+ defsubr (&Sabort_minibuffers);
defsubr (&Sminibuffer_prompt_end);
defsubr (&Sminibuffer_contents);
defsubr (&Sminibuffer_contents_no_properties);
diff --git a/src/pdumper.c b/src/pdumper.c
index 116cc28..c1388eb 100644
--- a/src/pdumper.c
+++ b/src/pdumper.c
@@ -5273,7 +5273,7 @@ pdumper_load (const char *dump_filename)
eassert (!dump_loaded_p ());
int err;
- int dump_fd = emacs_open (dump_filename, O_RDONLY, 0);
+ int dump_fd = emacs_open_noquit (dump_filename, O_RDONLY, 0);
if (dump_fd < 0)
{
err = (errno == ENOENT || errno == ENOTDIR
diff --git a/src/process.c b/src/process.c
index 06d750d..dac7d04 100644
--- a/src/process.c
+++ b/src/process.c
@@ -692,8 +692,7 @@ status_convert (int w)
if (WIFSTOPPED (w))
return Fcons (Qstop, Fcons (make_fixnum (WSTOPSIG (w)), Qnil));
else if (WIFEXITED (w))
- return Fcons (Qexit, Fcons (make_fixnum (WEXITSTATUS (w)),
- WCOREDUMP (w) ? Qt : Qnil));
+ return Fcons (Qexit, Fcons (make_fixnum (WEXITSTATUS (w)), Qnil));
else if (WIFSIGNALED (w))
return Fcons (Qsignal, Fcons (make_fixnum (WTERMSIG (w)),
WCOREDUMP (w) ? Qt : Qnil));
@@ -2059,6 +2058,7 @@ create_process (Lisp_Object process, char **new_argv,
Lisp_Object current_dir)
bool pty_flag = 0;
char pty_name[PTY_NAME_SIZE];
Lisp_Object lisp_pty_name = Qnil;
+ sigset_t oldset;
inchannel = outchannel = -1;
@@ -2139,13 +2139,16 @@ create_process (Lisp_Object process, char **new_argv,
Lisp_Object current_dir)
setup_process_coding_systems (process);
char **env = make_environment_block (current_dir);
+ block_input ();
+ block_child_signal (&oldset);
+
pty_flag = p->pty_flag;
eassert (pty_flag == ! NILP (lisp_pty_name));
vfork_errno
= emacs_spawn (&pid, forkin, forkout, forkerr, new_argv, env,
SSDATA (current_dir),
- pty_flag ? SSDATA (lisp_pty_name) : NULL);
+ pty_flag ? SSDATA (lisp_pty_name) : NULL, &oldset);
eassert ((vfork_errno == 0) == (0 < pid));
@@ -2153,6 +2156,10 @@ create_process (Lisp_Object process, char **new_argv,
Lisp_Object current_dir)
if (pid >= 0)
p->alive = 1;
+ /* Stop blocking in the parent. */
+ unblock_child_signal (&oldset);
+ unblock_input ();
+
/* Environment block no longer needed. */
unbind_to (count, Qnil);
diff --git a/src/sysdep.c b/src/sysdep.c
index 6ede06b..941b4e2 100644
--- a/src/sysdep.c
+++ b/src/sysdep.c
@@ -53,6 +53,10 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
# include <sys/sysctl.h>
#endif
+#if defined __OpenBSD__
+# include <sys/proc.h>
+#endif
+
#ifdef DARWIN_OS
# include <libproc.h>
#endif
@@ -2316,6 +2320,28 @@ emacs_open (char const *file, int oflags, int mode)
return emacs_openat (AT_FDCWD, file, oflags, mode);
}
+/* Same as above, but doesn't allow the user to quit. */
+
+static int
+emacs_openat_noquit (int dirfd, const char *file, int oflags,
+ int mode)
+{
+ int fd;
+ if (! (oflags & O_TEXT))
+ oflags |= O_BINARY;
+ oflags |= O_CLOEXEC;
+ do
+ fd = openat (dirfd, file, oflags, mode);
+ while (fd < 0 && errno == EINTR);
+ return fd;
+}
+
+int
+emacs_open_noquit (char const *file, int oflags, int mode)
+{
+ return emacs_openat_noquit (AT_FDCWD, file, oflags, mode);
+}
+
/* Open FILE as a stream for Emacs use, with mode MODE.
Act like emacs_open with respect to threads, signals, and quits. */
@@ -2972,6 +2998,14 @@ make_lisp_timeval (struct timeval t)
return make_lisp_time (timeval_to_timespec (t));
}
+#elif defined __OpenBSD__
+
+static Lisp_Object
+make_lisp_timeval (long sec, long usec)
+{
+ return make_lisp_time(make_timespec(sec, usec * 1000));
+}
+
#endif
#ifdef GNU_LINUX
@@ -3661,6 +3695,189 @@ system_process_attributes (Lisp_Object pid)
return attrs;
}
+#elif defined __OpenBSD__
+
+Lisp_Object
+system_process_attributes (Lisp_Object pid)
+{
+ int proc_id, nentries, fscale, i;
+ int pagesize = getpagesize ();
+ int mib[6];
+ size_t len;
+ double pct;
+ char *ttyname, args[ARG_MAX];
+ struct kinfo_proc proc;
+ struct passwd *pw;
+ struct group *gr;
+ struct timespec t;
+ struct uvmexp uvmexp;
+
+ Lisp_Object attrs = Qnil;
+ Lisp_Object decoded_comm;
+
+ CHECK_NUMBER (pid);
+ CONS_TO_INTEGER (pid, int, proc_id);
+
+ len = sizeof proc;
+ mib[0] = CTL_KERN;
+ mib[1] = KERN_PROC;
+ mib[2] = KERN_PROC_PID;
+ mib[3] = proc_id;
+ mib[4] = len;
+ mib[5] = 1;
+ if (sysctl (mib, 6, &proc, &len, NULL, 0) != 0)
+ return attrs;
+
+ attrs = Fcons (Fcons (Qeuid, INT_TO_INTEGER (proc.p_uid)), attrs);
+
+ block_input ();
+ pw = getpwuid (proc.p_uid);
+ unblock_input ();
+ if (pw)
+ attrs = Fcons (Fcons (Quser, build_string(pw->pw_name)), attrs);
+
+ attrs = Fcons (Fcons (Qegid, INT_TO_INTEGER(proc.p_svgid)), attrs);
+
+ block_input ();
+ gr = getgrgid (proc.p_svgid);
+ unblock_input ();
+ if (gr)
+ attrs = Fcons (Fcons (Qgroup, build_string (gr->gr_name)), attrs);
+
+ AUTO_STRING (comm, proc.p_comm);
+ decoded_comm = code_convert_string_norecord (comm, Vlocale_coding_system, 0);
+ attrs = Fcons (Fcons (Qcomm, decoded_comm), attrs);
+
+ {
+ char state[2] = {'\0', '\0'};
+ switch (proc.p_stat) {
+ case SIDL:
+ state[0] = 'I';
+ break;
+ case SRUN:
+ state[0] = 'R';
+ break;
+ case SSLEEP:
+ state[0] = 'S';
+ break;
+ case SSTOP:
+ state[0] = 'T';
+ break;
+ case SZOMB:
+ state[0] = 'Z';
+ break;
+ case SDEAD:
+ state[0] = 'D';
+ break;
+ }
+ attrs = Fcons (Fcons (Qstate, build_string (state)), attrs);
+ }
+
+ attrs = Fcons (Fcons (Qppid, INT_TO_INTEGER (proc.p_ppid)), attrs);
+ attrs = Fcons (Fcons (Qpgrp, INT_TO_INTEGER (proc.p_gid)), attrs);
+ attrs = Fcons (Fcons (Qsess, INT_TO_INTEGER (proc.p_sid)), attrs);
+
+ block_input ();
+ ttyname = proc.p_tdev == NODEV ? NULL : devname (proc.p_tdev, S_IFCHR);
+ unblock_input ();
+ if (ttyname)
+ attrs = Fcons (Fcons (Qttname, build_string (ttyname)), attrs);
+
+ attrs = Fcons (Fcons (Qtpgid, INT_TO_INTEGER (proc.p_tpgid)), attrs);
+ attrs = Fcons (Fcons (Qminflt, INT_TO_INTEGER (proc.p_uru_minflt)),
+ attrs);
+ attrs = Fcons (Fcons (Qmajflt, INT_TO_INTEGER (proc.p_uru_majflt)),
+ attrs);
+
+ /* FIXME: missing cminflt, cmajflt. */
+
+ attrs = Fcons (Fcons (Qutime, make_lisp_timeval (proc.p_uutime_sec,
+ proc.p_uutime_usec)),
+ attrs);
+ attrs = Fcons (Fcons (Qstime, make_lisp_timeval (proc.p_ustime_sec,
+ proc.p_ustime_usec)),
+ attrs);
+ t = timespec_add (make_timespec (proc.p_uutime_sec,
+ proc.p_uutime_usec * 1000),
+ make_timespec (proc.p_ustime_sec,
+ proc.p_ustime_usec * 1000));
+ attrs = Fcons (Fcons (Qtime, make_lisp_time (t)), attrs);
+
+ attrs = Fcons (Fcons (Qcutime, make_lisp_timeval (proc.p_uctime_sec,
+ proc.p_uctime_usec)),
+ attrs);
+
+ /* FIXME: missing cstime and thus ctime. */
+
+ attrs = Fcons (Fcons (Qpri, make_fixnum (proc.p_priority)), attrs);
+ attrs = Fcons (Fcons (Qnice, make_fixnum (proc.p_nice)), attrs);
+
+ /* FIXME: missing thcount (thread count) */
+
+ attrs = Fcons (Fcons (Qstart, make_lisp_timeval (proc.p_ustart_sec,
+ proc.p_ustart_usec)),
+ attrs);
+
+ len = (proc.p_vm_tsize + proc.p_vm_dsize + proc.p_vm_ssize) * pagesize >> 10;
+ attrs = Fcons (Fcons (Qvsize, make_fixnum (len)), attrs);
+
+ attrs = Fcons (Fcons (Qrss, make_fixnum (proc.p_vm_rssize * pagesize >>
10)),
+ attrs);
+
+ t = make_timespec (proc.p_ustart_sec,
+ proc.p_ustart_usec * 1000);
+ t = timespec_sub (current_timespec (), t);
+ attrs = Fcons (Fcons (Qetime, make_lisp_time (t)), attrs);
+
+ len = sizeof (fscale);
+ mib[0] = CTL_KERN;
+ mib[1] = KERN_FSCALE;
+ if (sysctl (mib, 2, &fscale, &len, NULL, 0) != -1)
+ {
+ pct = (double)proc.p_pctcpu / fscale * 100.0;
+ attrs = Fcons (Fcons (Qpcpu, make_float (pct)), attrs);
+ }
+
+ len = sizeof (uvmexp);
+ mib[0] = CTL_VM;
+ mib[1] = VM_UVMEXP;
+ if (sysctl (mib, 2, &uvmexp, &len, NULL, 0) != -1)
+ {
+ pct = (100.0 * (double)proc.p_vm_rssize / uvmexp.npages);
+ attrs = Fcons (Fcons (Qpmem, make_float (pct)), attrs);
+ }
+
+ len = sizeof args;
+ mib[0] = CTL_KERN;
+ mib[1] = KERN_PROC_ARGS;
+ mib[2] = proc_id;
+ mib[3] = KERN_PROC_ARGV;
+ if (sysctl (mib, 4, &args, &len, NULL, 0) == 0 && len != 0)
+ {
+ char **argv = (char**)args;
+
+ /* concatenate argv reusing the existing storage storage.
+ sysctl(8) guarantees that "the buffer pointed to by oldp is
+ filled with an array of char pointers followed by the strings
+ themselves." */
+ for (i = 0; argv[i] != NULL; ++i)
+ {
+ if (argv[i+1] != NULL)
+ {
+ len = strlen (argv[i]);
+ argv[i][len] = ' ';
+ }
+ }
+
+ AUTO_STRING (comm, *argv);
+ decoded_comm = code_convert_string_norecord (comm,
+ Vlocale_coding_system, 0);
+ attrs = Fcons (Fcons (Qargs, decoded_comm), attrs);
+ }
+
+ return attrs;
+}
+
#elif defined DARWIN_OS
Lisp_Object
diff --git a/src/w32term.c b/src/w32term.c
index e5a8a82..109aa58 100644
--- a/src/w32term.c
+++ b/src/w32term.c
@@ -7507,7 +7507,8 @@ w32_initialize (void)
}
#ifdef CYGWIN
- if ((w32_message_fd = emacs_open ("/dev/windows", O_RDWR, 0)) == -1)
+ if ((w32_message_fd = emacs_open_noquit ("/dev/windows", O_RDWR, 0))
+ == -1)
fatal ("opening /dev/windows: %s", strerror (errno));
#endif /* CYGWIN */
diff --git a/src/window.c b/src/window.c
index 58204c1..e025e0b 100644
--- a/src/window.c
+++ b/src/window.c
@@ -2663,12 +2663,15 @@ static void
decode_next_window_args (Lisp_Object *window, Lisp_Object *minibuf,
Lisp_Object *all_frames)
{
struct window *w = decode_live_window (*window);
+ Lisp_Object miniwin = XFRAME (w->frame)->minibuffer_window;
XSETWINDOW (*window, w);
/* MINIBUF nil may or may not include minibuffers. Decide if it
does. */
if (NILP (*minibuf))
- *minibuf = minibuf_level ? minibuf_window : Qlambda;
+ *minibuf = this_minibuffer_depth (XWINDOW (miniwin)->contents)
+ ? miniwin
+ : Qlambda;
else if (!EQ (*minibuf, Qt))
*minibuf = Qlambda;
@@ -8100,6 +8103,18 @@ and scrolling positions. */)
return Qt;
return Qnil;
}
+
+DEFUN ("window-bump-use-time", Fwindow_bump_use_time,
+ Swindow_bump_use_time, 1, 1, 0,
+ doc: /* Mark WINDOW as having been recently used. */)
+ (Lisp_Object window)
+{
+ struct window *w = decode_valid_window (window);
+
+ w->use_time = ++window_select_count;
+ return Qnil;
+}
+
static void init_window_once_for_pdumper (void);
@@ -8573,6 +8588,7 @@ displayed after a scrolling operation to be somewhat
inaccurate. */);
defsubr (&Swindow_vscroll);
defsubr (&Sset_window_vscroll);
defsubr (&Scompare_window_configurations);
+ defsubr (&Swindow_bump_use_time);
defsubr (&Swindow_list);
defsubr (&Swindow_list_1);
defsubr (&Swindow_prev_buffers);
diff --git a/src/window.h b/src/window.h
index 332cb30..79eb44e 100644
--- a/src/window.h
+++ b/src/window.h
@@ -1124,10 +1124,6 @@ extern Lisp_Object echo_area_window;
extern EMACS_INT command_loop_level;
-/* Depth in minibuffer invocations. */
-
-extern EMACS_INT minibuf_level;
-
/* Non-zero if we should redraw the mode lines on the next redisplay.
Usually set to a unique small integer so we can track the main causes of
full redisplays in `redisplay--mode-lines-cause'. */
diff --git a/src/xfaces.c b/src/xfaces.c
index b3b19a9..258b365 100644
--- a/src/xfaces.c
+++ b/src/xfaces.c
@@ -3293,7 +3293,8 @@ FRAME 0 means change the face on all frames, and change
the default
}
else if (EQ (k, QCstyle))
{
- if (!EQ (v, Qpressed_button) && !EQ (v, Qreleased_button))
+ if (!EQ (v, Qpressed_button) && !EQ (v, Qreleased_button)
+ && !EQ(v, Qflat_button))
break;
}
else
@@ -6031,6 +6032,10 @@ realize_gui_face (struct face_cache *cache, Lisp_Object
attrs[LFACE_VECTOR_SIZE]
face->box = FACE_RAISED_BOX;
else if (EQ (value, Qpressed_button))
face->box = FACE_SUNKEN_BOX;
+ else if (EQ (value, Qflat_button)) {
+ face->box = FACE_SIMPLE_BOX;
+ face->box_color = face->background;
+ }
}
}
}
@@ -6919,6 +6924,7 @@ syms_of_xfaces (void)
DEFSYM (Qwave, "wave");
DEFSYM (Qreleased_button, "released-button");
DEFSYM (Qpressed_button, "pressed-button");
+ DEFSYM (Qflat_button, "flat-button");
DEFSYM (Qnormal, "normal");
DEFSYM (Qextra_light, "extra-light");
DEFSYM (Qlight, "light");
diff --git a/test/Makefile.in b/test/Makefile.in
index 8aa37ca..fc40dad 100644
--- a/test/Makefile.in
+++ b/test/Makefile.in
@@ -161,11 +161,15 @@ endif
## Save logs, and show logs for failed tests.
WRITE_LOG = > $@ 2>&1 || { STAT=$$?; cat $@; exit $$STAT; }
+## On Hydra or Emba, always show logs for certain problematic tests.
ifdef EMACS_HYDRA_CI
-## On Hydra, always show logs for certain problematic tests.
lisp/net/tramp-tests.log \
: WRITE_LOG = 2>&1 | tee $@
endif
+ifdef EMACS_EMBA_CI
+lisp/filenotify-tests.log lisp/net/tramp-tests.log \
+: WRITE_LOG = 2>&1 | tee $@
+endif
ifeq ($(TEST_LOAD_EL), yes)
testloadfile = $*.el
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el
b/test/lisp/emacs-lisp/cl-macs-tests.el
index 446983c..bcd63f7 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -610,4 +610,27 @@ collection clause."
;; Just make sure the function can be instrumented.
(edebug-defun)))
+;;; cl-labels
+
+(ert-deftest cl-macs--labels ()
+ ;; Simple recursive function.
+ (cl-labels ((len (xs) (if xs (1+ (len (cdr xs))) 0)))
+ (should (equal (len (make-list 42 t)) 42)))
+
+ ;; Simple tail-recursive function.
+ (cl-labels ((len (xs n) (if xs (len (cdr xs) (1+ n)) n)))
+ (should (equal (len (make-list 42 t) 0) 42))
+ ;; Should not bump into stack depth limits.
+ (should (equal (len (make-list 42000 t) 0) 42000)))
+
+ ;; Check that non-recursive functions are handled more efficiently.
+ (should (pcase (macroexpand '(cl-labels ((f (x) (+ x 1))) (f 5)))
+ (`(let* ,_ (funcall ,_ 5)) t)))
+
+ ;; Case of "tail-recursive lambdas".
+ (should (pcase (macroexpand
+ '(cl-labels ((len (xs n) (if xs (len (cdr xs) (1+ n)) n)))
+ #'len))
+ (`(function (lambda (,_ ,_) . ,_)) t))))
+
;;; cl-macs-tests.el ends here
diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el
index 047109a..d73b072 100644
--- a/test/lisp/filenotify-tests.el
+++ b/test/lisp/filenotify-tests.el
@@ -1265,7 +1265,7 @@ delivered."
;; Unpredictable failures, eg https://hydra.nixos.org/build/86016286
(file-notify--deftest-remote file-notify-test07-many-events
"Check that events are not dropped for remote directories."
- (getenv "EMACS_HYDRA_CI"))
+ (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI")))
(ert-deftest file-notify-test08-backup ()
"Check that backup keeps file notification."
diff --git a/test/lisp/gnus/mm-decode-resources/8bit-multipart.bin
b/test/lisp/gnus/mm-decode-resources/8bit-multipart.bin
new file mode 100644
index 0000000..0b193a2
--- /dev/null
+++ b/test/lisp/gnus/mm-decode-resources/8bit-multipart.bin
@@ -0,0 +1,20 @@
+From: example <example@example.org>
+To: example <example@example.org>
+Content-Type: multipart/alternative;
boundary="===============2877195075946974246=="
+Date: Thu, 29 Oct 2020 14:47:55 +0100
+MIME-Version: 1.0
+Subject: test
+
+--===============2877195075946974246==
+Content-Type: text/plain; charset="utf-8"
+Content-Transfer-Encoding: 8bit
+
+ääää
+
+--===============2877195075946974246==
+Content-Type: text/html; charset="utf-8"
+Content-Transfer-Encoding: 8bit
+
+<!doctype html><html><head><meta http-equiv="content-type" content="text/html;
charset=UTF-8"></head><body>ääää</body></html>
+
+--===============2877195075946974246==--
diff --git a/test/lisp/gnus/mm-decode-resources/win1252-multipart.bin
b/test/lisp/gnus/mm-decode-resources/win1252-multipart.bin
new file mode 100644
index 0000000..d3c5026
--- /dev/null
+++ b/test/lisp/gnus/mm-decode-resources/win1252-multipart.bin
@@ -0,0 +1,44 @@
+To: example <example@example.org>
+From: example <example@example.org>
+Date: Tue, 5 Jan 2021 10:30:34 +0100
+MIME-Version: 1.0
+Content-Type: multipart/mixed; boundary="------------FB569A4368539497CC91D1DC"
+Content-Language: fr
+Subject: test
+
+--------------FB569A4368539497CC91D1DC
+Content-Type: multipart/alternative;
+ boundary="------------61C81A7DC7592E4C6F856A85"
+
+
+--------------61C81A7DC7592E4C6F856A85
+Content-Type: text/plain; charset=windows-1252; format=flowed
+Content-Transfer-Encoding: 8bit
+
+d�j� rat�
+
+--------------61C81A7DC7592E4C6F856A85
+Content-Type: text/html; charset=windows-1252
+Content-Transfer-Encoding: 8bit
+
+<html>
+ <head>
+ <meta http-equiv="content-type" content="text/html; charset=windows-1252">
+ </head>
+ <body>
+ d�j� rat�
+ </body>
+</html>
+
+--------------61C81A7DC7592E4C6F856A85--
+
+--------------FB569A4368539497CC91D1DC
+Content-Type: text/plain; charset="us-ascii"
+MIME-Version: 1.0
+Content-Transfer-Encoding: 7bit
+Content-Disposition: inline
+
+mailing list signature
+
+--------------FB569A4368539497CC91D1DC--
+
diff --git a/test/lisp/gnus/mm-decode-tests.el
b/test/lisp/gnus/mm-decode-tests.el
new file mode 100644
index 0000000..7d059cb
--- /dev/null
+++ b/test/lisp/gnus/mm-decode-tests.el
@@ -0,0 +1,102 @@
+;;; mm-decode-tests.el --- -*- lexical-binding:t -*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, 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 'ert-x)
+(require 'mm-decode)
+
+(ert-deftest test-mm-dissect-buffer ()
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert-file-contents-literally (ert-resource-file "8bit-multipart.bin"))
+ (while (search-forward "\r\n" nil t)
+ (replace-match "\n"))
+ (let ((handle (mm-dissect-buffer)))
+ (should (equal (mm-handle-media-type handle) "multipart/alternative"))
+ ;; Skip multipart type.
+ (pop handle)
+ (let ((part (pop handle)))
+ (should (equal (mm-handle-media-type part) "text/plain"))
+ (should (eq (mm-handle-encoding part) '8bit))
+ (with-current-buffer (mm-handle-buffer part)
+ (should (equal (decode-coding-string
+ (buffer-string)
+ (intern (mail-content-type-get (mm-handle-type part)
+ 'charset)))
+ "ääää\n"))))
+ (let ((part (pop handle)))
+ (should (equal (mm-handle-media-type part) "text/html"))
+ (should (eq (mm-handle-encoding part) '8bit))
+ (with-current-buffer (mm-handle-buffer part)
+ (should (equal (decode-coding-string
+ (buffer-string)
+ (intern (mail-content-type-get (mm-handle-type part)
+ 'charset)))
+ "<!doctype html><html><head><meta
http-equiv=\"content-type\" content=\"text/html;
charset=UTF-8\"></head><body>ääää</body></html>\n")))))))
+
+(ert-deftest test-mm-with-part-unibyte ()
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert-file-contents-literally (ert-resource-file "8bit-multipart.bin"))
+ (while (search-forward "\r\n" nil t)
+ (replace-match "\n"))
+ (let ((handle (mm-dissect-buffer)))
+ (pop handle)
+ (let ((part (pop handle)))
+ (should (equal (decode-coding-string
+ (mm-with-part part
+ (buffer-string))
+ (intern (mail-content-type-get (mm-handle-type part)
+ 'charset)))
+ "ääää\n"))))))
+
+(ert-deftest test-mm-dissect-buffer-win1252 ()
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert-file-contents-literally (ert-resource-file
"win1252-multipart.bin"))
+ (let ((handle (mm-dissect-buffer)))
+ (should (equal (mm-handle-media-type handle) "multipart/mixed"))
+ ;; Skip multipart type.
+ (pop handle)
+ (setq handle (car handle))
+ (pop handle)
+ (let ((part (pop handle)))
+ (should (equal (mm-handle-media-type part) "text/plain"))
+ (should (eq (mm-handle-encoding part) '8bit))
+ (with-current-buffer (mm-handle-buffer part)
+ (should (equal (decode-coding-string
+ (buffer-string)
+ (intern (mail-content-type-get (mm-handle-type part)
+ 'charset)))
+ "déjà raté\n"))))
+ (let ((part (pop handle)))
+ (should (equal (mm-handle-media-type part) "text/html"))
+ (should (eq (mm-handle-encoding part) '8bit))
+ (with-current-buffer (mm-handle-buffer part)
+ (should (equal (decode-coding-string
+ (buffer-string)
+ (intern (mail-content-type-get (mm-handle-type part)
+ 'charset)))
+ "<html>\n <head>\n <meta
http-equiv=\"content-type\" content=\"text/html; charset=windows-1252\">\n
</head>\n <body>\n déjà raté\n </body>\n</html>\n")))))))
+
+;;; mm-decode-tests.el ends here
diff --git a/test/lisp/help-mode-tests.el b/test/lisp/help-mode-tests.el
index e0e82c9..43db59d 100644
--- a/test/lisp/help-mode-tests.el
+++ b/test/lisp/help-mode-tests.el
@@ -72,14 +72,19 @@ Lisp concepts such as car, cdr, cons cell and list.")
#'info)))))
(ert-deftest help-mode-tests-xref-button ()
- (with-temp-buffer
- (insert "See also the function ‘interactive’.")
- (string-match help-xref-symbol-regexp (buffer-string))
- (help-xref-button 8 'help-function)
- (should-not (button-at 22))
- (should-not (button-at 35))
- (let ((button (button-at 30)))
- (should (eq (button-type button) 'help-function)))))
+ (let* ((fmt "See also the function ‘%s’.")
+ ;; 1+ translates string index to buffer position.
+ (beg (1+ (string-search "%" fmt))))
+ (with-temp-buffer
+ (dolist (fn '(interactive \` = + - * / %))
+ (erase-buffer)
+ (insert (format fmt fn))
+ (goto-char (point-min))
+ (re-search-forward help-xref-symbol-regexp)
+ (help-xref-button 8 'help-function)
+ (should-not (button-at (1- beg)))
+ (should-not (button-at (+ beg (length (symbol-name fn)))))
+ (should (eq (button-type (button-at beg)) 'help-function))))))
(ert-deftest help-mode-tests-insert-xref-button ()
(with-temp-buffer
diff --git a/test/lisp/help-tests.el b/test/lisp/help-tests.el
index 95557c95..835d9fe 100644
--- a/test/lisp/help-tests.el
+++ b/test/lisp/help-tests.el
@@ -102,7 +102,7 @@ RET minibuffer-complete-and-exit
ESC Prefix Command
SPC minibuffer-complete-word
? minibuffer-completion-help
-<C-tab> file-cache-minibuffer-complete
+C-<tab> file-cache-minibuffer-complete
<XF86Back> previous-history-element
<XF86Forward> next-history-element
<down> next-line-or-history-element
diff --git a/test/lisp/net/socks-tests.el b/test/lisp/net/socks-tests.el
new file mode 100644
index 0000000..b378ed2
--- /dev/null
+++ b/test/lisp/net/socks-tests.el
@@ -0,0 +1,103 @@
+;;; socks-tests.el --- tests for SOCKS -*- coding: utf-8; lexical-binding: t;
-*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'socks)
+(require 'url-http)
+
+(defvar socks-tests-canned-server-port nil)
+
+(defun socks-tests-canned-server-create (verbatim patterns)
+ "Create a fake SOCKS server and return the process.
+
+`VERBATIM' and `PATTERNS' are dotted alists containing responses.
+Requests are tried in order. On failure, an error is raised."
+ (let* ((buf (generate-new-buffer "*canned-socks-server*"))
+ (filt (lambda (proc line)
+ (let ((resp (or (assoc-default line verbatim
+ (lambda (k s) ; s is line
+ (string= (concat k) s)))
+ (assoc-default line patterns
+ (lambda (p s)
+ (string-match-p p s))))))
+ (unless resp
+ (error "Unknown request: %s" line))
+ (let ((print-escape-control-characters t))
+ (princ (format "<- %s\n" (prin1-to-string line)) buf)
+ (princ (format "-> %s\n" (prin1-to-string resp)) buf))
+ (process-send-string proc (concat resp)))))
+ (srv (make-network-process :server 1
+ :buffer buf
+ :filter filt
+ :name "server"
+ :family 'ipv4
+ :host 'local
+ :service socks-tests-canned-server-port)))
+ (set-process-query-on-exit-flag srv nil)
+ (princ (format "[%s] Listening on localhost:10080\n" srv) buf)
+ srv))
+
+;; Add ([5 3 0 1 2] . [5 2]) to the `verbatim' list below to validate
+;; against curl 7.71 with the following options:
+;; $ curl --verbose -U foo:bar --proxy socks5h://127.0.0.1:10080 example.com
+;;
+;; If later implementing version 4a, try these:
+;; [4 1 0 80 0 0 0 1 0 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0] . [0 90 0 0 0 0 0 0]
+;; $ curl --verbose --proxy socks4a://127.0.0.1:10080 example.com
+
+(ert-deftest socks-tests-auth-filter-url-http ()
+ "Verify correct handling of SOCKS5 user/pass authentication."
+ (let* ((socks-server '("server" "127.0.0.1" 10080 5))
+ (socks-username "foo")
+ (socks-password "bar")
+ (url-gateway-method 'socks)
+ (url (url-generic-parse-url "http://example.com";))
+ (verbatim '(([5 2 0 2] . [5 2])
+ ([1 3 ?f ?o ?o 3 ?b ?a ?r] . [1 0])
+ ([5 1 0 3 11 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0 80]
+ . [5 0 0 1 0 0 0 0 0 0])))
+ (patterns
+ `(("^GET /" . ,(concat "HTTP/1.1 200 OK\r\n"
+ "Content-Type: text/plain; charset=UTF-8\r\n"
+ "Content-Length: 13\r\n\r\n"
+ "Hello World!\n"))))
+ (socks-tests-canned-server-port 10080)
+ (server (socks-tests-canned-server-create verbatim patterns))
+ (tries 10)
+ ;;
+ done
+ ;;
+ (cb (lambda (&rest _r)
+ (goto-char (point-min))
+ (should (search-forward "Hello World" nil t))
+ (setq done t)))
+ (buf (url-http url cb '(nil))))
+ (ert-info ("Connect to HTTP endpoint over SOCKS5 with USER/PASS method")
+ (while (and (not done) (< 0 (cl-decf tries))) ; cl-lib via url-http
+ (sleep-for 0.1)))
+ (should done)
+ (delete-process server)
+ (kill-buffer (process-buffer server))
+ (kill-buffer buf)
+ (ignore url-gateway-method)))
+
+;;; socks-tests.el ends here
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index 819d69b..3995006 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -3067,9 +3067,7 @@ This tests also `file-directory-p' and
`file-accessible-directory-p'."
(regexp-opt (directory-files tmp-name1))
(length (directory-files tmp-name1)))))))
- ;; Check error case. We do not check for the error type,
- ;; because ls-lisp returns `file-error', and native Tramp
- ;; returns `file-missing'.
+ ;; Check error case.
(delete-directory tmp-name1 'recursive)
(with-temp-buffer
(should-error
@@ -3188,6 +3186,59 @@ This tests also `file-directory-p' and
`file-accessible-directory-p'."
(ignore-errors (delete-directory tmp-name1 'recursive))
(ignore-errors (delete-directory tmp-name2 'recursive))))))
+;; The following test is inspired by Bug#45691.
+(ert-deftest tramp-test17-insert-directory-one-file ()
+ "Check `insert-directory' inside directory listing."
+ (skip-unless (tramp--test-enabled))
+
+ (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil)))
+ (let* ((tmp-name1
+ (expand-file-name (tramp--test-make-temp-name nil quoted)))
+ (tmp-name2 (expand-file-name "foo" tmp-name1))
+ (tmp-name3 (expand-file-name "bar" tmp-name1))
+ (dired-copy-preserve-time t)
+ (dired-recursive-copies 'top)
+ dired-copy-dereference
+ buffer)
+ (unwind-protect
+ (progn
+ (make-directory tmp-name1)
+ (write-region "foo" nil tmp-name2)
+ (should (file-directory-p tmp-name1))
+ (should (file-exists-p tmp-name2))
+
+ ;; Check, that `insert-directory' works properly.
+ (with-current-buffer
+ (setq buffer (dired-noselect tmp-name1 "--dired -al"))
+ (read-only-mode -1)
+ (goto-char (point-min))
+ (while (not (or (eobp)
+ (string-equal
+ (dired-get-filename 'localp 'no-error)
+ (file-name-nondirectory tmp-name2))))
+ (forward-line 1))
+ (should-not (eobp))
+ (copy-file tmp-name2 tmp-name3)
+ (insert-directory
+ (file-name-nondirectory tmp-name3) "--dired -al -d")
+ ;; Point shall still be the recent file.
+ (should
+ (string-equal
+ (dired-get-filename 'localp 'no-error)
+ (file-name-nondirectory tmp-name2)))
+ (should-not (re-search-forward "dired" nil t))
+ ;; The copied file has been inserted the line before.
+ (forward-line -1)
+ (should
+ (string-equal
+ (dired-get-filename 'localp 'no-error)
+ (file-name-nondirectory tmp-name3))))
+ (kill-buffer buffer))
+
+ ;; Cleanup.
+ (ignore-errors (kill-buffer buffer))
+ (ignore-errors (delete-directory tmp-name1 'recursive))))))
+
;; Method "smb" supports `make-symbolic-link' only if the remote host
;; has CIFS capabilities. tramp-adb.el, tramp-gvfs.el and
;; tramp-rclone.el do not support symbolic links at all.
@@ -4670,7 +4721,7 @@ If UNSTABLE is non-nil, the test is tagged as
`:unstable'."
(ert-deftest tramp-test31-interrupt-process ()
"Check `interrupt-process'."
- :tags (if (getenv "EMACS_EMBA_CI")
+ :tags (if (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI"))
'(:expensive-test :unstable) '(:expensive-test))
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-sh-p))
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index 8d19a26..e082620 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -61,6 +61,35 @@
(quote
(0 font-lock-keyword-face))))))))
+
+;;;; Keymap support.
+
+(ert-deftest subr-test-kbd ()
+ (should (equal (kbd "f") "f"))
+ (should (equal (kbd "<f1>") [f1]))
+ (should (equal (kbd "RET") "\C-m"))
+ (should (equal (kbd "C-x a") "\C-xa"))
+ ;; Check that kbd handles both new and old style key descriptions
+ ;; (bug#45536).
+ (should (equal (kbd "s-<return>") [s-return]))
+ (should (equal (kbd "<s-return>") [s-return]))
+ (should (equal (kbd "C-M-<return>") [C-M-return]))
+ (should (equal (kbd "<C-M-return>") [C-M-return])))
+
+(ert-deftest subr-test-define-prefix-command ()
+ (define-prefix-command 'foo-prefix-map)
+ (should (keymapp foo-prefix-map))
+ (should (fboundp #'foo-prefix-map))
+ ;; With optional argument.
+ (define-prefix-command 'bar-prefix 'bar-prefix-map)
+ (should (keymapp bar-prefix-map))
+ (should (fboundp #'bar-prefix))
+ ;; Returns the symbol.
+ (should (eq (define-prefix-command 'foo-bar) 'foo-bar)))
+
+
+;;;; Mode hooks.
+
(defalias 'subr-tests--parent-mode
(if (fboundp 'prog-mode) 'prog-mode 'fundamental-mode))
@@ -404,6 +433,15 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350.";
(should (equal (flatten-tree '(1 ("foo" "bar") 2))
'(1 "foo" "bar" 2))))
+(ert-deftest subr--tests-letrec ()
+ ;; Test that simple cases of `letrec' get optimized back to `let*'.
+ (should (equal (macroexpand '(letrec ((subr-tests-var1 1)
+ (subr-tests-var2 subr-tests-var1))
+ (+ subr-tests-var1 subr-tests-var2)))
+ '(let* ((subr-tests-var1 1)
+ (subr-tests-var2 subr-tests-var1))
+ (+ subr-tests-var1 subr-tests-var2)))))
+
(defvar subr-tests--hook nil)
(ert-deftest subr-tests-add-hook-depth ()
@@ -630,13 +668,5 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350.";
(should (>= (length (apropos-internal "^help" #'commandp)) 15))
(should-not (apropos-internal "^next-line$" #'keymapp)))
-(ert-deftest subr--kbd ()
- ;; Check that kbd handles both new and old style key descriptions
- ;; (bug#45536).
- (should (equal (kbd "s-<return>") [s-return]))
- (should (equal (kbd "<s-return>") [s-return]))
- (should (equal (kbd "C-M-<return>") [C-M-return]))
- (should (equal (kbd "<C-M-return>") [C-M-return])))
-
(provide 'subr-tests)
;;; subr-tests.el ends here
diff --git a/test/lisp/textmodes/fill-tests.el
b/test/lisp/textmodes/fill-tests.el
index f2c63a9..21efe62 100644
--- a/test/lisp/textmodes/fill-tests.el
+++ b/test/lisp/textmodes/fill-tests.el
@@ -44,6 +44,37 @@
(fill-paragraph)
(should (string= (buffer-string) "Abc\nd efg\n(h ijk)."))))
+(ert-deftest fill-test-unbreakable-paragraph ()
+ (with-temp-buffer
+ (let ((string "aaa = baaaaaaaaaaaaaaaaaaaaaaaaaaaa\n"))
+ (insert string)
+ (goto-char (point-min))
+ (search-forward "b")
+ (let* ((pos (point))
+ (beg (line-beginning-position))
+ (end (line-end-position))
+ (fill-prefix (make-string (- pos beg) ?\s))
+ ;; `fill-column' is too small to accomodate the current line
+ (fill-column (- end beg 10)))
+ (fill-region-as-paragraph beg end nil nil pos))
+ (should (equal (buffer-string) string)))))
+
+(ert-deftest fill-test-breakable-paragraph ()
+ (with-temp-buffer
+ (let ((string "aaa = baaaaaaaa aaaaaaaaaa aaaaaaaaaa\n"))
+ (insert string)
+ (goto-char (point-min))
+ (search-forward "b")
+ (let* ((pos (point))
+ (beg (line-beginning-position))
+ (end (line-end-position))
+ (fill-prefix (make-string (- pos beg) ?\s))
+ ;; `fill-column' is too small to accomodate the current line
+ (fill-column (- end beg 10)))
+ (fill-region-as-paragraph beg end nil nil pos))
+ (should (equal
+ (buffer-string)
+ "aaa = baaaaaaaa aaaaaaaaaa\n aaaaaaaaaa\n")))))
(provide 'fill-tests)
diff --git a/test/lisp/textmodes/paragraphs-resources/mark-paragraph.bin
b/test/lisp/textmodes/paragraphs-resources/mark-paragraph.bin
new file mode 100644
index 0000000..1905477
--- /dev/null
+++ b/test/lisp/textmodes/paragraphs-resources/mark-paragraph.bin
@@ -0,0 +1,9 @@
+First
+paragraph
+
+Second
+
+Third
+paragraph
+
+No line end
\ No newline at end of file
diff --git a/test/lisp/textmodes/paragraphs-tests.el
b/test/lisp/textmodes/paragraphs-tests.el
index bf7f370..7121690 100644
--- a/test/lisp/textmodes/paragraphs-tests.el
+++ b/test/lisp/textmodes/paragraphs-tests.el
@@ -24,6 +24,7 @@
;;; Code:
(require 'ert)
+(require 'ert-x)
;; (require 'paragraphs) ; loaded by default
(ert-deftest paragraphs-tests-sentence-end ()
@@ -161,5 +162,27 @@
(should (equal (buffer-string)
"First sentence. Third sentence. Second sentence."))))
+(ert-deftest test-mark-paragraphs ()
+ (with-current-buffer
+ (find-file-noselect (ert-resource-file "mark-paragraph.bin"))
+ (goto-char (point-max))
+ ;; Just a sanity check that the file hasn't changed.
+ (should (= (point) 54))
+ (mark-paragraph)
+ (should (= (point) 42))
+ (should (= (mark) 54))
+ ;; Doesn't move.
+ (mark-paragraph)
+ (should (= (point) 42))
+ (should (= (mark) 54))
+ (forward-line -1)
+ (mark-paragraph)
+ (should (= (point) 25))
+ (should (= (mark) 42))
+ (goto-char (point-min))
+ (mark-paragraph)
+ (should (= (point) 1))
+ (should (= (mark) 17))))
+
(provide 'paragraphs-tests)
;;; paragraphs-tests.el ends here
diff --git a/test/src/process-tests.el b/test/src/process-tests.el
index ca98f54..921bcd5 100644
--- a/test/src/process-tests.el
+++ b/test/src/process-tests.el
@@ -565,6 +565,11 @@ FD_SETSIZE file descriptors (Bug#24325)."
(should (memq (process-status process) '(run exit)))
(when (process-live-p process)
(process-send-eof process))
+ ;; FIXME: This `sleep-for' shouldn't be needed. It
+ ;; indicates a bug in Emacs; perhaps SIGCHLD is
+ ;; received in parallel with `accept-process-output',
+ ;; causing the latter to hang.
+ (sleep-for 0.1)
(while (accept-process-output process))
(should (eq (process-status process) 'exit))
;; If there's an error between fork and exec, Emacs