[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] comment-cache 441e3b7 1/2: Merge branch 'master' into comm
|
From: |
Alan Mackenzie |
|
Subject: |
[Emacs-diffs] comment-cache 441e3b7 1/2: Merge branch 'master' into comment-cache |
|
Date: |
Fri, 23 Dec 2016 20:44:40 +0000 (UTC) |
branch: comment-cache
commit 441e3b78c7b4a874e98bbc436f2b8d9771ca9d4e
Merge: de077da eff901b
Author: Alan Mackenzie <address@hidden>
Commit: Alan Mackenzie <address@hidden>
Merge branch 'master' into comment-cache
---
.gitignore | 1 +
ChangeLog.2 | 2 +-
Makefile.in | 23 +-
admin/gitmerge.el | 2 +-
admin/ldefs-clean.el | 63 ++
admin/make-tarball.txt | 4 +-
admin/notes/copyright | 6 +-
admin/update_autogen | 19 +-
build-aux/git-hooks/pre-commit | 8 +
configure.ac | 22 +-
doc/lispref/Makefile.in | 1 +
doc/lispref/debugging.texi | 23 +-
doc/lispref/display.texi | 32 +-
doc/lispref/elisp.texi | 12 +-
doc/lispref/objects.texi | 89 +-
doc/lispref/processes.texi | 30 +
doc/lispref/streams.texi | 2 +-
doc/lispref/threads.texi | 253 +++++
doc/lispref/variables.texi | 2 +-
doc/misc/tramp.texi | 139 ++-
etc/DEBUG | 2 +-
etc/NEWS | 84 ++
.../hicolor/scalable/mimetypes/emacs-document.svg | 2 +-
lib/fpending.c | 32 +-
lib/gnulib.mk | 2 +-
lib/stdio-impl.h | 140 +++
lib/xalloc-oversized.h | 33 +-
lisp/Makefile.in | 6 +-
lisp/bookmark.el | 2 +-
lisp/cedet/mode-local.el | 2 +-
lisp/cedet/semantic/db-global.el | 2 +-
lisp/cus-dep.el | 2 +-
lisp/emacs-lisp/advice.el | 2 +-
lisp/emacs-lisp/byte-run.el | 5 +
lisp/emacs-lisp/debug.el | 11 +-
lisp/emacs-lisp/derived.el | 11 +-
lisp/emacs-lisp/edebug.el | 3 +-
lisp/emacs-lisp/elint.el | 2 +-
lisp/emacs-lisp/rx.el | 2 +-
lisp/emacs-lisp/seq.el | 27 +-
lisp/finder.el | 4 +-
lisp/gnus/message.el | 8 +-
lisp/help-fns.el | 2 -
lisp/ibuf-ext.el | 347 +++++--
lisp/ibuf-macs.el | 2 +-
lisp/ibuffer.el | 55 +-
lisp/ido.el | 2 +-
lisp/image-dired.el | 796 ++++++++-------
lisp/image-mode.el | 49 +-
lisp/ldefs-boot-auto.el | 125 +++
lisp/ldefs-boot-manual.el | 19 +
lisp/loadup.el | 25 +-
lisp/minibuffer.el | 25 +-
lisp/net/tramp-adb.el | 105 +-
lisp/net/tramp-gvfs.el | 7 +-
lisp/net/tramp-gw.el | 339 -------
lisp/net/tramp-sh.el | 138 +--
lisp/net/tramp-smb.el | 6 +-
lisp/net/tramp.el | 50 +-
lisp/{ => obsolete}/gs.el | 5 +-
lisp/progmodes/compile.el | 9 +-
lisp/progmodes/cperl-mode.el | 48 +-
lisp/progmodes/verilog-mode.el | 73 +-
lisp/shell.el | 1 +
lisp/subr.el | 62 +-
lisp/textmodes/flyspell.el | 121 +--
lisp/textmodes/ispell.el | 513 ++--------
lisp/textmodes/tex-mode.el | 14 +-
lisp/vc/diff-mode.el | 2 +-
lisp/vc/ediff-init.el | 2 +-
lisp/vc/ediff-ptch.el | 8 +-
lisp/window.el | 4 +-
m4/fpending.m4 | 67 +-
m4/gnulib-comp.m4 | 2 +-
msdos/mainmake.v2 | 2 +-
nt/gnulib.mk | 2 +-
nt/inc/sys/socket.h | 1 +
src/.gdbinit | 15 +
src/ChangeLog.13 | 2 +-
src/ChangeLog.3 | 2 +-
src/Makefile.in | 5 +
src/alloc.c | 116 ++-
src/buffer.c | 19 +-
src/buffer.h | 5 +-
src/bytecode.c | 203 +++-
src/charset.c | 2 +-
src/coding.c | 6 +-
src/data.c | 221 ++---
src/emacs.c | 21 +-
src/eval.c | 434 +++++----
src/frame.c | 32 +-
src/ftcrfont.c | 36 +-
src/ftfont.c | 34 +-
src/ftxfont.c | 38 +-
src/indent.c | 32 +-
src/keyboard.c | 6 +-
src/keyboard.h | 3 -
src/lisp.h | 189 ++--
src/lread.c | 8 +-
src/macfont.m | 30 +-
src/nsfont.m | 24 +-
src/print.c | 36 +
src/process.c | 552 +++++++----
src/process.h | 5 +
src/regex.c | 6 -
src/regex.h | 8 +-
src/search.c | 22 +-
src/sysdep.c | 39 +-
src/syssignal.h | 2 +
src/systhread.c | 417 ++++++++
src/systhread.h | 112 +++
src/thread.c | 1012 ++++++++++++++++++++
src/thread.h | 250 +++++
src/unexw32.c | 1 +
src/w32.c | 2 +-
src/w32proc.c | 8 +-
src/w32select.c | 1 -
src/widget.c | 10 -
src/window.c | 10 +-
src/xdisp.c | 11 +
src/xfont.c | 26 +-
src/xftfont.c | 46 +-
src/xgselect.c | 14 +-
test/lisp/buff-menu-tests.el | 2 +-
.../{buff-menu-tests.el => emacs-lisp/rx-tests.el} | 38 +-
test/lisp/emacs-lisp/seq-tests.el | 13 +
test/lisp/files-tests.el | 23 +
test/lisp/ibuffer-tests.el | 667 ++++++++++++-
test/lisp/net/tramp-tests.el | 126 ++-
test/lisp/progmodes/compile-tests.el | 71 +-
test/lisp/progmodes/etags-tests.el | 14 +-
test/lisp/subr-tests.el | 47 +
test/lisp/vc/vc-tests.el | 2 +-
test/src/data-tests.el | 80 ++
test/src/lread-tests.el | 8 +
test/src/regex-resources/PTESTS | 542 +++++------
test/src/thread-tests.el | 247 +++++
137 files changed, 7043 insertions(+), 3055 deletions(-)
diff --git a/.gitignore b/.gitignore
index 15f9c56..1de15a1 100644
--- a/.gitignore
+++ b/.gitignore
@@ -71,6 +71,7 @@ lib/limits.h
lib/signal.h
lib/std*.h
!lib/std*.in.h
+!lib/stdio-impl.h
lib/string.h
lib/sys/
lib/time.h
diff --git a/ChangeLog.2 b/ChangeLog.2
index 0b73dc2..de67bbf 100644
--- a/ChangeLog.2
+++ b/ChangeLog.2
@@ -26205,7 +26205,7 @@
2015-08-07 Phillip Lord <address@hidden>
- Improve error signalling for seq-subseq
+ Improve error signaling for seq-subseq
* lisp/emacs-lisp/seq.el (seq-subseq): The existing behavior is to error
when indexes are too large, but to silently ignore numbers which
are too negative for lists. String and vector handling errors in
diff --git a/Makefile.in b/Makefile.in
index 1d06d17..d7e30a8 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -735,8 +735,8 @@ install-etc:
client_name=`echo emacsclient | sed '$(TRANSFORM)'`${EXEEXT}; \
sed -e '/^##/d' \
-e "/^Documentation/ s/emacs(1)/$${emacs_name}(1)/" \
- -e "/^ExecStart/ s|emacs|$(DESTDIR)${bindir}/$${exe_name}|" \
- -e "/^ExecStop/ s|emacsclient|$(DESTDIR)${bindir}/$${client_name}|" \
+ -e "/^ExecStart/ s|emacs|${bindir}/$${exe_name}|" \
+ -e "/^ExecStop/ s|emacsclient|${bindir}/$${client_name}|" \
${srcdir}/etc/emacs.service > $${tmp}; \
$(INSTALL_DATA) $${tmp}
"$(DESTDIR)$(systemdunitdir)/${EMACS_NAME}.service"; \
rm -f $${tmp}
@@ -1117,7 +1117,9 @@ check-info: info
# * Run autogen.sh.
# * Rebuild Makefile, to update the build procedure itself.
# * Do the actual build.
-bootstrap: bootstrap-clean
+bootstrap: | bootstrap-clean bootstrap-build
+
+bootstrap-build:
cd $(srcdir) && ./autogen.sh
$(MAKE) MAKEFILE_NAME=force-Makefile force-Makefile
$(MAKE) all
@@ -1180,3 +1182,18 @@ check-declare:
exit 1; \
fi
$(MAKE) -C lisp $@
+
+## Generating ldefs-boot-auto.el requires a completely clean build so
+## that we can see which autoloads are actually called. The build has
+## to complete because we use Emacs to clean the results up! We use
+## loaddefs.el in place of ldefs-boot-auto, because if we are running
+## this there is the possibility that ldefs-boot-auto is not
+## sufficient for bootstrap.
+generate-ldefs-boot: all
+ echo "Generating Bootstrap ldefs"
+ cp lisp/loaddefs.el lisp/ldefs-boot-auto.el
+ $(MAKE) -j 1 bootstrap \
+ GENERATE_LDEFS_BOOT="generate-ldefs-boot" \
+ 2>&1 | tee lisp/ldefs-boot-auto.temp
+ $(EMACS) -batch --load admin/ldefs-clean.el --funcall ldefs-clean
+ rm lisp/ldefs-boot-auto.temp
diff --git a/admin/gitmerge.el b/admin/gitmerge.el
index d2cb1e8..ca28863 100644
--- a/admin/gitmerge.el
+++ b/admin/gitmerge.el
@@ -292,7 +292,7 @@ Returns non-nil if conflicts remain."
))
;; Try to resolve the conflicts.
(cond
- ((member file '("configure" "lisp/ldefs-boot.el"
+ ((member file '("configure" "lisp/ldefs-boot-auto.el"
"lisp/emacs-lisp/cl-loaddefs.el"))
;; We are in the file's buffer, so names are relative.
(call-process "git" nil t nil "checkout" "--"
diff --git a/admin/ldefs-clean.el b/admin/ldefs-clean.el
new file mode 100644
index 0000000..89c77a7
--- /dev/null
+++ b/admin/ldefs-clean.el
@@ -0,0 +1,63 @@
+;; Copyright (C) 2016 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file takes the output from the "generate-ldefs-boot" make
+;; target, takes the relevant autoload forms, removes everything else
+;; and adds some comments.
+
+(defun ldefs-clean-uniquify-region-lines (beg end)
+ "Remove duplicate adjacent lines in region."
+ (save-excursion
+ (goto-char beg)
+ (while (re-search-forward "^\\(.*\n\\)\\1+" end t)
+ (replace-match "\\1"))))
+
+(defun ldefs-clean-uniquify-buffer-lines ()
+ "Remove duplicate adjacent lines in the current buffer."
+ (interactive)
+ (ldefs-clean-uniquify-region-lines (point-min) (point-max)))
+
+(defun ldefs-clean-up ()
+ "Clean up output from build and turn it into ldefs-boot-auto.el."
+ (interactive)
+ (goto-char (point-max))
+ ;; We only need the autoloads up till loaddefs.el is
+ ;; generated. After this, ldefs-boot.el is not needed
+ (search-backward " GEN loaddefs.el")
+ (delete-region (point) (point-max))
+ (keep-lines "(autoload" (point-min) (point-max))
+ (sort-lines nil (point-min) (point-max))
+ (ldefs-clean-uniquify-buffer-lines)
+ (goto-char (point-min))
+ (insert
+ ";; This file is autogenerated by admin/ldefs-clean.el
+;; Do not edit
+")
+ (goto-char (point-max))
+ (insert
+ ";; Local Variables:
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; End:"))
+
+
+(defun ldefs-clean ()
+ (find-file "lisp/ldefs-boot-auto.temp")
+ (ldefs-clean-up)
+ (write-file "ldefs-boot-auto.el"))
diff --git a/admin/make-tarball.txt b/admin/make-tarball.txt
index 77486cc..369d169 100644
--- a/admin/make-tarball.txt
+++ b/admin/make-tarball.txt
@@ -84,9 +84,7 @@ General steps (for each step, check for possible errors):
make -C etc/refcards
make -C etc/refcards clean
-5. Copy lisp/loaddefs.el to lisp/ldefs-boot.el.
-
- Commit ChangeLog.N, etc/AUTHORS, lisp/ldefs-boot.el, and the
+5. Commit ChangeLog.N, etc/AUTHORS, lisp/ldefs-boot.el, and the
files changed by M-x set-version.
If someone else made a commit between step 1 and now,
diff --git a/admin/notes/copyright b/admin/notes/copyright
index 2dc33c1..6cfc331 100644
--- a/admin/notes/copyright
+++ b/admin/notes/copyright
@@ -45,9 +45,9 @@ available.
The definition of triviality is a little vague, but a rule of thumb is
that any file with less than 15 lines of actual content is trivial. If
-a file is auto-generated (eg ldefs-boot.el) from another one in the
-repository, then it does not really matter about adding a copyright
-statement to the generated file.
+a file is auto-generated from another one in the repository, then it
+does not really matter about adding a copyright statement to the
+generated file.
Legal advice says that we could, if we wished, put a license notice
even in trivial files, because copyright law in general looks at the
diff --git a/admin/update_autogen b/admin/update_autogen
index f27bfe0..98be4ed 100755
--- a/admin/update_autogen
+++ b/admin/update_autogen
@@ -92,7 +92,7 @@ changelog_flag=
## Parameters.
ldefs_in=lisp/loaddefs.el
-ldefs_out=lisp/ldefs-boot.el
+ldefs_boot=lisp/ldefs-boot.el
changelog_n=$(sed -n 's/CHANGELOG_HISTORY_INDEX_MAX *= *//p' Makefile.in)
changelog_files="ChangeLog.$changelog_n"
sources="configure.ac lib/Makefile.am"
@@ -370,19 +370,12 @@ echo "Running lisp/ make..."
make -C lisp "$@" autoloads EMACS=../src/bootstrap-emacs || die "make src
error"
-
-## Ignore comment differences.
-[ ! "$lboot_flag" ] || \
- diff -q -I '^;' $ldefs_in $ldefs_out || \
- cp $ldefs_in $ldefs_out || die "cp ldefs_boot error"
-
-
echo "Checking status of loaddef files..."
## It probably would be fine to just check+commit lisp/, since
## making autoloads should not effect any other files. But better
## safe than sorry.
-modified=$(status $genfiles $ldefs_out) || die
+modified=$(status $genfiles) || die
commit "loaddefs" $modified || die "commit error"
@@ -396,6 +389,14 @@ commit "loaddefs" $modified || die "commit error"
}
+
+## Regenerate ldefs-boot if we are told to
+[ ! "$lboot_flag" ] || {
+ make generate-ldefs-boot || die
+ modified=$(status $ldefs_boot) || die
+ commit $ldefs_boot $modified || die "commit error"
+}
+
exit 0
### update_autogen ends here
diff --git a/build-aux/git-hooks/pre-commit b/build-aux/git-hooks/pre-commit
index 5a51244..3709784 100755
--- a/build-aux/git-hooks/pre-commit
+++ b/build-aux/git-hooks/pre-commit
@@ -45,4 +45,12 @@ for new_name in `$git_diff HEAD`; do
esac
done
+# The '--check' option of git diff-index makes Git complain if changes
+# introduce whitespace errors. This can be a pain when editing test
+# files that deliberately contain lines with trailing whitespace.
+# To work around the problem you can run a command like 'git config
+# core.whitespace -trailing-space'. It may be better to revamp the
+# tests so that trailing spaces are generated on the fly rather than
+# being committed as source.
+
exec git diff-index --check --cached HEAD --
diff --git a/configure.ac b/configure.ac
index 2d116de..5aaf006 100644
--- a/configure.ac
+++ b/configure.ac
@@ -355,6 +355,7 @@ OPTION_DEFAULT_ON([selinux],[don't compile with SELinux
support])
OPTION_DEFAULT_ON([gnutls],[don't use -lgnutls for SSL/TLS support])
OPTION_DEFAULT_ON([zlib],[don't compile with zlib decompression support])
OPTION_DEFAULT_OFF([modules],[compile with dynamic modules support])
+OPTION_DEFAULT_ON([threads],[don't compile with elisp threading support])
AC_ARG_WITH([file-notification],[AS_HELP_STRING([--with-file-notification=LIB],
[use a file notification library (LIB one of: yes, inotify, kqueue, gfile,
w32, no)])],
@@ -1643,7 +1644,7 @@ AC_CHECK_HEADERS_ONCE(
sys/sysinfo.h
coff.h pty.h
sys/resource.h
- sys/utsname.h pwd.h utmp.h util.h)
+ sys/utsname.h pwd.h utmp.h util.h sys/prctl.h)
AC_CACHE_CHECK([for ADDR_NO_RANDOMIZE],
[emacs_cv_personality_addr_no_randomize],
@@ -2305,6 +2306,22 @@ if test "$ac_cv_header_pthread_h" && test "$opsys" !=
"mingw32"; then
fi
AC_SUBST([LIB_PTHREAD])
+AC_MSG_CHECKING([for thread support])
+threads_enabled=no
+if test "$with_threads" = yes; then
+ if test "$emacs_cv_pthread_lib" != no; then
+ AC_DEFINE(THREADS_ENABLED, 1,
+ [Define to 1 if you want elisp thread support.])
+ threads_enabled=yes
+ elif test "${opsys}" = "mingw32"; then
+ dnl MinGW can do native Windows threads even without pthreads
+ AC_DEFINE(THREADS_ENABLED, 1,
+ [Define to 1 if you want elisp thread support.])
+ threads_enabled=yes
+ fi
+fi
+AC_MSG_RESULT([$threads_enabled])
+
dnl Check for need for bigtoc support on IBM AIX
case ${host_os} in
@@ -3871,7 +3888,7 @@ pthread_sigmask strsignal setitimer \
sendto recvfrom getsockname getifaddrs freeifaddrs \
gai_strerror sync \
getpwent endpwent getgrent endgrent \
-cfmakeraw cfsetspeed copysign __executable_start log2)
+cfmakeraw cfsetspeed copysign __executable_start log2 prctl)
LIBS=$OLD_LIBS
dnl No need to check for posix_memalign if aligned_alloc works.
@@ -5314,6 +5331,7 @@ AS_ECHO([" Does Emacs use -lXaw3d?
${HAVE_XAW3D
Does Emacs have dynamic modules support? ${HAVE_MODULES}
Does Emacs use toolkit scroll bars?
${USE_TOOLKIT_SCROLL_BARS}
Does Emacs support Xwidgets (requires gtk3)? ${HAVE_XWIDGETS}
+ Does Emacs have threading support in lisp? ${threads_enabled}
"])
if test -n "${EMACSDATA}"; then
diff --git a/doc/lispref/Makefile.in b/doc/lispref/Makefile.in
index 7aadee7..5bf6e99 100644
--- a/doc/lispref/Makefile.in
+++ b/doc/lispref/Makefile.in
@@ -125,6 +125,7 @@ srcs = \
$(srcdir)/symbols.texi \
$(srcdir)/syntax.texi \
$(srcdir)/text.texi \
+ $(srcdir)/threads.texi \
$(srcdir)/tips.texi \
$(srcdir)/variables.texi \
$(srcdir)/windows.texi \
diff --git a/doc/lispref/debugging.texi b/doc/lispref/debugging.texi
index c80b0f9..8fb663d 100644
--- a/doc/lispref/debugging.texi
+++ b/doc/lispref/debugging.texi
@@ -727,7 +727,7 @@ invocation.
This variable is obsolete and will be removed in future versions.
@end defvar
address@hidden backtrace-frame frame-number
address@hidden backtrace-frame frame-number &optional base
The function @code{backtrace-frame} is intended for use in Lisp
debuggers. It returns information about what computation is happening
in the stack frame @var{frame-number} levels down.
@@ -744,10 +744,31 @@ In the return value, @var{function} is whatever was
supplied as the
case of a macro call. If the function has a @code{&rest} argument, that
is represented as the tail of the list @var{arg-values}.
+If @var{base} is specified, @var{frame-number} counts relative to
+the topmost frame whose @var{function} is @var{base}.
+
If @var{frame-number} is out of range, @code{backtrace-frame} returns
@code{nil}.
@end defun
address@hidden mapbacktrace function &optional base
+The function @code{mapbacktrace} calls @var{function} once for each
+frame in the backtrace, starting at the first frame whose function is
address@hidden (or from the top if @var{base} is omitted or @code{nil}).
+
address@hidden is called with four arguments: @var{evald}, @var{func},
address@hidden, and @var{flags}.
+
+If a frame has not evaluated its arguments yet or is a special form,
address@hidden is @code{nil} and @var{args} is a list of forms.
+
+If a frame has evaluated its arguments and called its function
+already, @var{evald} is @code{t} and @var{args} is a list of values.
address@hidden is a plist of properties of the current frame: currently,
+the only supported property is @code{:debug-on-exit}, which is
address@hidden if the stack frame's @code{debug-on-exit} flag is set.
address@hidden defun
+
@include edebug.texi
@node Syntax Errors
diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi
index 851baa3..945a701 100644
--- a/doc/lispref/display.texi
+++ b/doc/lispref/display.texi
@@ -4779,7 +4779,6 @@ displayed (@pxref{Display Feature Testing}).
* Image Descriptors:: How to specify an image for use in @code{:display}.
* XBM Images:: Special features for XBM format.
* XPM Images:: Special features for XPM format.
-* PostScript Images:: Special features for PostScript format.
* ImageMagick Images:: Special features available through ImageMagick.
* SVG Images:: Creating and manipulating SVG images.
* Other Image Types:: Various other formats are supported.
@@ -4804,12 +4803,12 @@ to modify the set of known names for these dynamic
libraries.
Supported image formats (and the required support libraries) include
PBM and XBM (which do not depend on support libraries and are always
available), XPM (@code{libXpm}), GIF (@code{libgif} or
address@hidden), PostScript (@code{gs}), JPEG (@code{libjpeg}), TIFF
address@hidden), JPEG (@code{libjpeg}), TIFF
(@code{libtiff}), PNG (@code{libpng}), and SVG (@code{librsvg}).
Each of these image formats is associated with an @dfn{image type
symbol}. The symbols for the above formats are, respectively,
address@hidden, @code{xbm}, @code{xpm}, @code{gif}, @code{postscript},
address@hidden, @code{xbm}, @code{xpm}, @code{gif},
@code{jpeg}, @code{tiff}, @code{png}, and @code{svg}.
Furthermore, if you build Emacs with ImageMagick
@@ -5122,33 +5121,6 @@ the name of a color as it appears in the image file, and
@var{color}
specifies the actual color to use for displaying that name.
@end table
address@hidden PostScript Images
address@hidden PostScript Images
address@hidden postscript images
-
- To use PostScript for an image, specify image type @code{postscript}.
-This works only if you have Ghostscript installed. You must always use
-these three properties:
-
address@hidden @code
address@hidden :pt-width @var{width}
-The value, @var{width}, specifies the width of the image measured in
-points (1/72 inch). @var{width} must be an integer.
-
address@hidden :pt-height @var{height}
-The value, @var{height}, specifies the height of the image in points
-(1/72 inch). @var{height} must be an integer.
-
address@hidden :bounding-box @var{box}
-The value, @var{box}, must be a list or vector of four integers, which
-specifying the bounding box of the PostScript image, analogous to the
address@hidden comment found in PostScript files.
-
address@hidden
-%%BoundingBox: 22 171 567 738
address@hidden example
address@hidden table
-
@node ImageMagick Images
@subsection ImageMagick Images
@cindex ImageMagick images
diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi
index 6983ab7..494e8fc 100644
--- a/doc/lispref/elisp.texi
+++ b/doc/lispref/elisp.texi
@@ -219,6 +219,7 @@ To view this manual in other formats, click
* Syntax Tables:: The syntax table controls word and list parsing.
* Abbrevs:: How Abbrev mode works, and its data structures.
+* Threads:: Concurrency in Emacs Lisp.
* Processes:: Running and communicating with subprocesses.
* Display:: Features for controlling the screen display.
* System Interface:: Getting the user id, system type, environment
@@ -348,6 +349,9 @@ Editing Types
* Window Configuration Type:: Recording the way a frame is subdivided.
* Frame Configuration Type:: Recording the status of all frames.
* Process Type:: A subprocess of Emacs running on the underlying OS.
+* Thread Type:: A thread of Emacs Lisp execution.
+* Mutex Type:: An exclusive lock for thread synchronization.
+* Condition Variable Type:: Condition variable for thread synchronization.
* Stream Type:: Receive or send characters.
* Keymap Type:: What function a keystroke invokes.
* Overlay Type:: How an overlay is represented.
@@ -1322,6 +1326,12 @@ Abbrevs and Abbrev Expansion
* Abbrev Table Properties:: How to read and set abbrev table properties.
Which properties have which effect.
+Threads
+
+* Basic Thread Functions:: Basic thread functions.
+* Mutexes:: Mutexes allow exclusive access to data.
+* Condition Variables:: Inter-thread events.
+
Processes
* Subprocess Creation:: Functions that start subprocesses.
@@ -1462,7 +1472,6 @@ Images
* Image Descriptors:: How to specify an image for use in @code{:display}.
* XBM Images:: Special features for XBM format.
* XPM Images:: Special features for XPM format.
-* PostScript Images:: Special features for PostScript format.
* ImageMagick Images:: Special features available through ImageMagick.
* Other Image Types:: Various other formats are supported.
* Defining Images:: Convenient ways to define an image for later use.
@@ -1628,6 +1637,7 @@ Object Internals
@include searching.texi
@include syntax.texi
@include abbrevs.texi
address@hidden threads.texi
@include processes.texi
@include display.texi
diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi
index 54894b8..5e608bc 100644
--- a/doc/lispref/objects.texi
+++ b/doc/lispref/objects.texi
@@ -1410,6 +1410,9 @@ editing.
* Window Configuration Type:: Recording the way a frame is subdivided.
* Frame Configuration Type:: Recording the status of all frames.
* Process Type:: A subprocess of Emacs running on the underlying OS.
+* Thread Type:: A thread of Emacs Lisp execution.
+* Mutex Type:: An exclusive lock for thread synchronization.
+* Condition Variable Type:: Condition variable for thread synchronization.
* Stream Type:: Receive or send characters.
* Keymap Type:: What function a keystroke invokes.
* Overlay Type:: How an overlay is represented.
@@ -1625,6 +1628,63 @@ giving the name of the process:
return information about, send input or signals to, and receive output
from processes.
address@hidden Thread Type
address@hidden Thread Type
+
+ A @dfn{thread} in Emacs represents a separate thread of Emacs Lisp
+execution. It runs its own Lisp program, has its own current buffer,
+and can have subprocesses locked to it, i.e.@: subprocesses whose
+output only this thread can accept. @xref{Threads}.
+
+ Thread objects have no read syntax. They print in hash notation,
+giving the name of the thread (if it has been given a name) or its
+address in core:
+
address@hidden
address@hidden
+(all-threads)
+ @result{} (#<thread 0176fc40>)
address@hidden group
address@hidden example
+
address@hidden Mutex Type
address@hidden Mutex Type
+
+ A @dfn{mutex} is an exclusive lock that threads can own and disown,
+in order to synchronize between them. @xref{Mutexes}.
+
+ Mutex objects have no read syntax. They print in hash notation,
+giving the name of the mutex (if it has been given a name) or its
+address in core:
+
address@hidden
address@hidden
+(make-mutex "my-mutex")
+ @result{} #<mutex my-mutex>
+(make-mutex)
+ @result{} #<mutex 01c7e4e0>
address@hidden group
address@hidden example
+
address@hidden Condition Variable Type
address@hidden Condition Variable Type
+
+ A @dfn{condition variable} is a device for a more complex thread
+synchronization than the one supported by a mutex. A thread can wait
+on a condition variable, to be woken up when some other thread
+notifies the condition.
+
+ Condition variable objects have no read syntax. They print in hash
+notation, giving the name of the condition variable (if it has been
+given a name) or its address in core:
+
address@hidden
address@hidden
+(make-condition-variable (make-mutex))
+ @result{} #<condvar 01c45ae8>
address@hidden group
address@hidden example
+
@node Stream Type
@subsection Stream Type
@@ -1830,6 +1890,9 @@ with references to further information.
@item commandp
@xref{Interactive Call, commandp}.
address@hidden condition-variable-p
address@hidden Variables, condition-variable-p}.
+
@item consp
@xref{List-related Predicates, consp}.
@@ -1875,6 +1938,9 @@ with references to further information.
@item markerp
@xref{Predicates on Markers, markerp}.
address@hidden mutexp
address@hidden, mutexp}.
+
@item wholenump
@xref{Predicates on Numbers, wholenump}.
@@ -1908,6 +1974,9 @@ with references to further information.
@item syntax-table-p
@xref{Syntax Tables, syntax-table-p}.
address@hidden threadp
address@hidden Thread Functions, threadp}.
+
@item vectorp
@xref{Vectors, vectorp}.
@@ -1925,6 +1994,15 @@ with references to further information.
@item string-or-null-p
@xref{Predicates for Strings, string-or-null-p}.
+
address@hidden threadp
address@hidden Thread Functions, threadp}.
+
address@hidden mutexp
address@hidden, mutexp}.
+
address@hidden condition-variable-p
address@hidden Variables, condition-variable-p}.
@end table
The most general way to check the type of an object is to call the
@@ -1938,11 +2016,12 @@ types. In most cases, it is more convenient to use
type predicates than
This function returns a symbol naming the primitive type of
@var{object}. The value is one of the symbols @code{bool-vector},
@code{buffer}, @code{char-table}, @code{compiled-function},
address@hidden, @code{finalizer}, @code{float}, @code{font-entity},
address@hidden, @code{font-spec}, @code{frame}, @code{hash-table},
address@hidden, @code{marker}, @code{overlay}, @code{process},
address@hidden, @code{subr}, @code{symbol}, @code{vector},
address@hidden, or @code{window-configuration}.
address@hidden, @code{cons}, @code{finalizer},
address@hidden, @code{font-entity}, @code{font-object},
address@hidden, @code{frame}, @code{hash-table}, @code{integer},
address@hidden, @code{mutex}, @code{overlay}, @code{process},
address@hidden, @code{subr}, @code{symbol}, @code{thread},
address@hidden, @code{window}, or @code{window-configuration}.
@example
(type-of 1)
diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi
index 21e1429..064934c 100644
--- a/doc/lispref/processes.texi
+++ b/doc/lispref/processes.texi
@@ -1400,6 +1400,7 @@ Emacs tries to read it.
* Filter Functions:: Filter functions accept output from the process.
* Decoding Output:: Filters can get unibyte or multibyte strings.
* Accepting Output:: How to wait until process output arrives.
+* Processes and Threads:: How processes and threads interact.
@end menu
@node Process Buffers
@@ -1791,6 +1792,35 @@ got output from @var{process}, or from any process if
@var{process} is
arrived.
@end defun
address@hidden Processes and Threads
address@hidden Processes and Threads
address@hidden processes, threads
+
+ Because threads were a relatively late addition to Emacs Lisp, and
+due to the way dynamic binding was sometimes used in conjunction with
address@hidden, by default a process is locked to the
+thread that created it. When a process is locked to a thread, output
+from the process can only be accepted by that thread.
+
+ A Lisp program can specify to which thread a process is to be
+locked, or instruct Emacs to unlock a process, in which case its
+output can be processed by any thread. Only a single thread will wait
+for output from a given process at one time---once one thread begins
+waiting for output, the process is temporarily locked until
address@hidden or @code{sit-for} returns.
+
+ If the thread exits, all the processes locked to it are unlocked.
+
address@hidden process-thread process
+Return the thread to which @var{process} is locked. If @var{process}
+is unlocked, return @code{nil}.
address@hidden defun
+
address@hidden set-process-thread process thread
+Set the locking thread of @var{process} to @var{thread}. @var{thread}
+may be @code{nil}, in which case the process is unlocked.
address@hidden defun
+
@node Sentinels
@section Sentinels: Detecting Process Status Changes
@cindex process sentinel
diff --git a/doc/lispref/streams.texi b/doc/lispref/streams.texi
index 41bc71e..757e0e8 100644
--- a/doc/lispref/streams.texi
+++ b/doc/lispref/streams.texi
@@ -639,7 +639,7 @@ spacing between calls.
This function outputs a newline to @var{stream}. The name stands for
``terminate print''. If @var{ensure} is address@hidden no newline is printed
if @var{stream} is already at the beginning of a line. Note in this
-case @var{stream} can not be a function and an error is signalled if
+case @var{stream} can not be a function and an error is signaled if
it is. This function returns @code{t} if a newline is printed.
@end defun
diff --git a/doc/lispref/threads.texi b/doc/lispref/threads.texi
new file mode 100644
index 0000000..de1c27b
--- /dev/null
+++ b/doc/lispref/threads.texi
@@ -0,0 +1,253 @@
address@hidden -*-texinfo-*-
address@hidden This is part of the GNU Emacs Lisp Reference Manual.
address@hidden Copyright (C) 2012-2016 Free Software Foundation, Inc.
address@hidden See the file elisp.texi for copying conditions.
address@hidden Threads
address@hidden Threads
address@hidden threads
address@hidden concurrency
+
+ Emacs Lisp provides a limited form of concurrency, called
address@hidden All the threads in a given instance of Emacs share the
+same memory. Concurrency in Emacs Lisp is ``mostly cooperative'',
+meaning that Emacs will only switch execution between threads at
+well-defined times. However, the Emacs thread support has been
+designed in a way to later allow more fine-grained concurrency, and
+correct programs should not rely on cooperative threading.
+
+ Currently, thread switching will occur upon explicit request via
address@hidden, when waiting for keyboard input or for process
+output (e.g., during @code{accept-process-output}), or during blocking
+operations relating to threads, such as mutex locking or
address@hidden
+
+ Emacs Lisp provides primitives to create and control threads, and
+also to create and control mutexes and condition variables, useful for
+thread synchronization.
+
+ While global variables are shared among all Emacs Lisp threads,
+local variables are not---a dynamic @code{let} binding is local. Each
+thread also has its own current buffer (@pxref{Current Buffer}) and
+its own match data (@pxref{Match Data}).
+
+ Note that @code{let} bindings are treated specially by the Emacs
+Lisp implementation. There is no way to duplicate this unwinding and
+rewinding behavior other than by using @code{let}. For example, a
+manual implementation of @code{let} written using
address@hidden cannot arrange for variable values to be
+thread-specific.
+
+ In the case of lexical bindings (@pxref{Variable Scoping}), a
+closure is an object like any other in Emacs Lisp, and bindings in a
+closure are shared by any threads invoking the closure.
+
address@hidden
+* Basic Thread Functions:: Basic thread functions.
+* Mutexes:: Mutexes allow exclusive access to data.
+* Condition Variables:: Inter-thread events.
address@hidden menu
+
address@hidden Basic Thread Functions
address@hidden Basic Thread Functions
+
+ Threads can be created and waited for. A thread cannot be exited
+directly, but the current thread can be exited implicitly, and other
+threads can be signaled.
+
address@hidden make-thread function &optional name
+Create a new thread of execution which invokes @var{function}. When
address@hidden returns, the thread exits.
+
+The new thread is created with no local variable bindings in effect.
+The new thread's current buffer is inherited from the current thread.
+
address@hidden can be supplied to give a name to the thread. The name is
+used for debugging and informational purposes only; it has no meaning
+to Emacs. If @var{name} is provided, it must be a string.
+
+This function returns the new thread.
address@hidden defun
+
address@hidden threadp object
+This function returns @code{t} if @var{object} represents an Emacs
+thread, @code{nil} otherwise.
address@hidden defun
+
address@hidden thread-join thread
+Block until @var{thread} exits, or until the current thread is
+signaled. If @var{thread} has already exited, this returns
+immediately.
address@hidden defun
+
address@hidden thread-signal thread error-symbol data
+Like @code{signal} (@pxref{Signaling Errors}), but the signal is
+delivered in the thread @var{thread}. If @var{thread} is the current
+thread, then this just calls @code{signal} immediately. Otherwise,
address@hidden will receive the signal as soon as it becomes current.
+If @var{thread} was blocked by a call to @code{mutex-lock},
address@hidden, or @code{thread-join}; @code{thread-signal}
+will unblock it.
address@hidden defun
+
address@hidden thread-yield
+Yield execution to the next runnable thread.
address@hidden defun
+
address@hidden thread-name thread
+Return the name of @var{thread}, as specified to @code{make-thread}.
address@hidden defun
+
address@hidden thread-alive-p thread
+Return @code{t} if @var{thread} is alive, or @code{nil} if it is not.
+A thread is alive as long as its function is still executing.
address@hidden defun
+
address@hidden thread--blocker thread
+Return the object that @var{thread} is waiting on. This function is
+primarily intended for debugging, and is given a ``double hyphen''
+name to indicate that.
+
+If @var{thread} is blocked in @code{thread-join}, this returns the
+thread for which it is waiting.
+
+If @var{thread} is blocked in @code{mutex-lock}, this returns the mutex.
+
+If @var{thread} is blocked in @code{condition-wait}, this returns the
+condition variable.
+
+Otherwise, this returns @code{nil}.
address@hidden defun
+
address@hidden current-thread
+Return the current thread.
address@hidden defun
+
address@hidden all-threads
+Return a list of all the live thread objects. A new list is returned
+by each invocation.
address@hidden defun
+
address@hidden Mutexes
address@hidden Mutexes
+
+ A @dfn{mutex} is an exclusive lock. At any moment, zero or one
+threads may own a mutex. If a thread attempts to acquire a mutex, and
+the mutex is already owned by some other thread, then the acquiring
+thread will block until the mutex becomes available.
+
+ Emacs Lisp mutexes are of a type called @dfn{recursive}, which means
+that a thread can re-acquire a mutex it owns any number of times. A
+mutex keeps a count of how many times it has been acquired, and each
+acquisition of a mutex must be paired with a release. The last
+release by a thread of a mutex reverts it to the unowned state,
+potentially allowing another thread to acquire the mutex.
+
address@hidden mutexp object
+This function returns @code{t} if @var{object} represents an Emacs
+mutex, @code{nil} otherwise.
address@hidden defun
+
address@hidden make-mutex &optional name
+Create a new mutex and return it. If @var{name} is specified, it is a
+name given to the mutex. It must be a string. The name is for
+debugging purposes only; it has no meaning to Emacs.
address@hidden defun
+
address@hidden mutex-name mutex
+Return the name of @var{mutex}, as specified to @code{make-mutex}.
address@hidden defun
+
address@hidden mutex-lock mutex
+This will block until this thread acquires @var{mutex}, or until this
+thread is signaled using @code{thread-signal}. If @var{mutex} is
+already owned by this thread, this simply returns.
address@hidden defun
+
address@hidden mutex-unlock mutex
+Release @var{mutex}. If @var{mutex} is not owned by this thread, this
+will signal an error.
address@hidden defun
+
address@hidden with-mutex mutex address@hidden
+This macro is the simplest and safest way to evaluate forms while
+holding a mutex. It acquires @var{mutex}, invokes @var{body}, and
+then releases @var{mutex}. It returns the result of @var{body}.
address@hidden defmac
+
address@hidden Condition Variables
address@hidden Condition Variables
+
+ A @dfn{condition variable} is a way for a thread to block until some
+event occurs. A thread can wait on a condition variable, to be woken
+up when some other thread notifies the condition.
+
+ A condition variable is associated with a mutex and, conceptually,
+with some condition. For proper operation, the mutex must be
+acquired, and then a waiting thread must loop, testing the condition
+and waiting on the condition variable. For example:
+
address@hidden
+(with-mutex mutex
+ (while (not global-variable)
+ (condition-wait cond-var)))
address@hidden example
+
+ The mutex ensures atomicity, and the loop is for robustness---there
+may be spurious notifications.
+
+ Similarly, the mutex must be held before notifying the condition.
+The typical, and best, approach is to acquire the mutex, make the
+changes associated with this condition, and then notify it:
+
address@hidden
+(with-mutex mutex
+ (setq global-variable (some-computation))
+ (condition-notify cond-var))
address@hidden example
+
address@hidden make-condition-variable mutex &optional name
+Make a new condition variable associated with @var{mutex}. If
address@hidden is specified, it is a name given to the condition variable.
+It must be a string. The name is for debugging purposes only; it has
+no meaning to Emacs.
address@hidden defun
+
address@hidden condition-variable-p object
+This function returns @code{t} if @var{object} represents a condition
+variable, @code{nil} otherwise.
address@hidden defun
+
address@hidden condition-wait cond
+Wait for another thread to notify @var{cond}, a condition variable.
+This function will block until the condition is notified, or until a
+signal is delivered to this thread using @code{thread-signal}.
+
+It is an error to call @code{condition-wait} without holding the
+condition's associated mutex.
+
address@hidden releases the associated mutex while waiting.
+This allows other threads to acquire the mutex in order to notify the
+condition.
address@hidden defun
+
address@hidden condition-notify cond &optional all
+Notify @var{cond}. The mutex with @var{cond} must be held before
+calling this. Ordinarily a single waiting thread is woken by
address@hidden; but if @var{all} is not @code{nil}, then all
+threads waiting on @var{cond} are notified.
+
address@hidden releases the associated mutex while waiting.
+This allows other threads to acquire the mutex in order to wait on the
+condition.
address@hidden why bother?
address@hidden defun
+
address@hidden condition-name cond
+Return the name of @var{cond}, as passed to
address@hidden
address@hidden defun
+
address@hidden condition-mutex cond
+Return the mutex associated with @var{cond}. Note that the associated
+mutex cannot be changed.
address@hidden defun
diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi
index 40738e6..d9096da 100644
--- a/doc/lispref/variables.texi
+++ b/doc/lispref/variables.texi
@@ -809,7 +809,7 @@ functions.
@subsection Limitations
-There are a couple of ways in which a variable could be modifed (or at
+There are a couple of ways in which a variable could be modified (or at
least appear to be modified) without triggering a watchpoint.
Since watchpoints are attached to symbols, modification to the
diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi
index 955a13e..1ba22e0 100644
--- a/doc/misc/tramp.texi
+++ b/doc/misc/tramp.texi
@@ -143,11 +143,11 @@ Configuring @value{tramp} for use
* Inline methods:: Inline methods.
* External methods:: External methods.
* GVFS based methods:: GVFS based external methods.
-* Gateway methods:: Gateway methods.
* Default Method:: Selecting a default method.
* Default User:: Selecting a default user.
* Default Host:: Selecting a default host.
* Multi-hops:: Connecting to a remote host using multiple
hops.
+* Firewalls:: Passing firewalls.
* Customizing Methods:: Using Non-Standard Methods.
* Customizing Completion:: Selecting config files for user/host name
completion.
* Password handling:: Reusing passwords for several connections.
@@ -406,10 +406,11 @@ April 2000 was the first time when multi-hop methods were
added. In
July 2002, @value{tramp} unified file names with address@hidden In July
2004, proxy hosts replaced multi-hop methods. Running commands on
remote hosts was introduced in December 2005. Support for gateways
-since April 2007. GVFS integration started in February 2009. Remote
-commands on Windows hosts since September 2011. Ad-hoc multi-hop
-methods (with a changed syntax) re-enabled in November 2011. In
-November 2012, added Juergen Hoetzel's @file{tramp-adb.el}.
+since April 2007 (and removed in December 2016). GVFS integration
+started in February 2009. Remote commands on Windows hosts since
+September 2011. Ad-hoc multi-hop methods (with a changed syntax)
+re-enabled in November 2011. In November 2012, added Juergen
+Hoetzel's @file{tramp-adb.el}.
XEmacs support has been stopped in January 2016.
@@ -453,7 +454,6 @@ installed and loaded:
* Inline methods:: Inline methods.
* External methods:: External methods.
* GVFS based methods:: GVFS based external methods.
-* Gateway methods:: Gateway methods.
* Default Method:: Selecting a default method.
Here we also try to help those who
don't have the foggiest which method
@@ -461,6 +461,7 @@ installed and loaded:
* Default User:: Selecting a default user.
* Default Host:: Selecting a default host.
* Multi-hops:: Connecting to a remote host using multiple
hops.
+* Firewalls:: Passing firewalls.
* Customizing Methods:: Using Non-Standard Methods.
* Customizing Completion:: Selecting config files for user/host name
completion.
* Password handling:: Reusing passwords for several connections.
@@ -997,51 +998,6 @@ Other methods to include are: @option{ftp} and
@option{smb}.
@end defopt
address@hidden Gateway methods
address@hidden Gateway methods
address@hidden methods, gateway
address@hidden gateway methods
-
-Gateway methods are for proxy host declarations (@pxref{Multi-hops})
-so as to pass through firewalls and proxy servers. They are not like
-the other methods that declare direct connections to a remote host.
-
-A gateway method always comes with a port setting. @value{tramp}
-targets the port number with the gateway method
address@hidden from where the firewall or proxy server
-is accessed.
-
-Gateway methods support user name and password declarations for
-authenticating the corresponding firewall or proxy server. Such
-authentication can be passed through only if granted access by system
-administrators.
-
address@hidden @asis
address@hidden @option{tunnel}
address@hidden method tunnel
address@hidden tunnel method
-
-This method implements an HTTP tunnel via the @command{CONNECT}
-command (conforming to RFC 2616, 2817 specifications). Proxy servers
-using HTTP version 1.1 or later protocol support this command.
-
-For authentication, this protocol uses only @option{Basic
-Authentication} (see RFC 2617). When no port number is specified, this
-protocol defaults to @option{8080}.
-
address@hidden @option{socks}
address@hidden method socks
address@hidden socks method
-
-The @option{socks} method connects to SOCKSv5 servers (see RFC 1928)
-and supports @option{Username/Password Authentication}.
-
-The default port number for the socks server is @option{1080}, if not
-specified otherwise.
-
address@hidden table
-
-
@node Default Method
@section Selecting a default method
@cindex default method
@@ -1244,9 +1200,8 @@ regular expression which always matches.
@var{proxy} is a literal @value{tramp} file name whose local name part
is ignored, and the method and user name parts are optional.
-The method must be an inline or gateway method (@pxref{Inline
-methods}, @pxref{Gateway methods}).
-If @var{proxy} is @code{nil}, no additional hop is required reaching
+The method must be an inline method (@pxref{Inline methods}). If
address@hidden is @code{nil}, no additional hop is required reaching
@var{user}@@@var{host}.
For example, to pass through the host @samp{bastion.your.domain} as
@@ -1313,32 +1268,6 @@ local one, first connect via @command{ssh}, and then
apply
'((regexp-quote (system-name)) nil nil))
@end group
@end lisp
-
-The above configuration allows @value{tramp} connection as @samp{root}
-to remote Ubuntu hosts.
-
address@hidden is also used for passing through
-firewalls or proxy servers.
-
-For example, the local host @samp{proxy.your.domain} on port 3128
-serves as HTTP proxy to the outer world. User has access rights to
-another proxy server on @address@hidden tunnels
-are intended for secure SSL/TLS communication. Therefore, many proxy
-servers restrict the tunnels to related target ports. You might need
-to run your ssh server on your target host @samp{host.other.domain} on
-such a port, like 443 (https). See
address@hidden://savannah.gnu.org/maintenance/CvsFromBehindFirewall} for
-discussion of ethical issues.} Then the configuration is:
-
address@hidden
address@hidden
-(add-to-list 'tramp-default-proxies-alist
- '("\\`host\\.other\\.domain\\'" nil
- "@trampfn{tunnel,proxy.your.domain#3128,}"))
address@hidden group
address@hidden lisp
-
-Gateway methods in a multiple hop chain can be declared only as the first hop.
@end defopt
Passing through hops involves dealing with restricted shells, such as
@@ -1362,6 +1291,50 @@ restricted shell:
@end defopt
address@hidden Firewalls
address@hidden Passing firewalls
address@hidden HTTP tunnel
address@hidden proxy hosts, HTTP tunnel
+
+Sometimes, it is not possible to reach a remote host directly. A
+firewall might be in the way, which could be passed via a proxy
+server.
+
+Both ssh and PuTTY support such proxy settings, using an HTTP tunnel
+via the @command{CONNECT} command (conforming to RFC 2616, 2817
+specifications). Proxy servers using HTTP version 1.1 or later
+protocol support this command.
+
address@hidden Tunneling with ssh
+
+With ssh, you could use the @code{ProxyCommand} entry in the
address@hidden/.ssh/config}:
+
address@hidden
address@hidden
+Host host.other.domain
+ ProxyCommand nc -X connect -x proxy.your.domain:3128 %h %p
address@hidden group
address@hidden example
+
address@hidden is BSD's netcat program, which establishes HTTP tunnels. Any
+other program with such a feature could be used as well.
+
+In the example, opening @address@hidden,host.your.domain,}} passes
+the HTTP proxy server @samp{proxy.your.domain} on port 3128.
+
address@hidden Tunneling with PuTTY
+
+PuTTY does not need an external program, HTTP tunnel support is
+built-in. In the PuTTY config program, create a session for
address@hidden In the @option{Connection/Data} entry,
+select the @option{HTTP} option, and add @samp{proxy.your.domain} as
address@hidden hostname}, and 3128 as @option{Port}.
+
+Opening @address@hidden,host.your.domain,}} passes the HTTP
+proxy server @samp{proxy.your.domain} on port 3128.
+
+
@node Customizing Methods
@section Using Non-Standard Methods
@cindex customizing methods
@@ -3618,14 +3591,12 @@ have to be specifically enabled as shown in this code:
(dolist (elt (all-completions "tramp-" obarray 'functionp))
(trace-function-background (intern elt)))
(untrace-function 'tramp-read-passwd)
-(untrace-function 'tramp-gw-basic-authentication)
@end group
@end lisp
The buffer @file{*trace-output*} contains the output from the function
-call traces. Disable @code{tramp-read-passwd} and
address@hidden to stop password strings from
-being written to @file{*trace-output*}.
+call traces. Disable @code{tramp-read-passwd} to stop password
+strings from being written to @file{*trace-output*}.
@node GNU Free Documentation License
diff --git a/etc/DEBUG b/etc/DEBUG
index 03efa3b..ddec7b4 100644
--- a/etc/DEBUG
+++ b/etc/DEBUG
@@ -313,7 +313,7 @@ type. Here are these commands:
xbufobjfwd xkbobjfwd xbuflocal xbuffer xsymbol xstring xvector xframe
xwinconfig xcompiled xcons xcar xcdr xsubr xprocess xfloat xscrollbar
xchartable xsubchartable xboolvector xhashtable xlist xcoding
- xcharset xfontset xfont
+ xcharset xfontset xfont xbytecode
Each one of them applies to a certain type or class of types.
(Some of these types are not visible in Lisp, because they exist only
diff --git a/etc/NEWS b/etc/NEWS
index 614b614..e2ada7c 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -74,6 +74,23 @@ for '--daemon'.
* Changes in Emacs 26.1
+++
+** The new function 'mapbacktrace' applies a function to all frames of
+the current stack trace.
+
++++
+** Emacs now provides a limited form of concurrency with Lisp threads.
+Concurrency in Emacs Lisp is "mostly cooperative", meaning that
+Emacs will only switch execution between threads at well-defined
+times: when Emacs waits for input, during blocking operations related
+to threads (such as mutex locking), or when the current thread
+explicitly yields. Global variables are shared among all threads, but
+a 'let' binding is thread-local. Each thread also has its own current
+buffer and its own match data.
+
+See the chapter "Threads" in the ELisp manual for full documentation
+of these facilities.
+
++++
** The new function 'file-name-case-insensitive-p' tests whether a
given file is on a case-insensitive filesystem.
@@ -295,6 +312,8 @@ the file's actual content before prompting the user.
* Changes in Specialized Modes and Packages in Emacs 26.1
+** TeX: Add luatex and xetex as alternatives to pdftex
+
** Electric-Buffer-menu
+++
@@ -316,6 +335,27 @@ bound to 'Buffer-menu-unmark-all-buffers'.
** Ibuffer
---
+*** New filter commands `ibuffer-filter-by-basename',
+`ibuffer-filter-by-file-extension', `ibuffer-filter-by-directory',
+`ibuffer-filter-by-starred-name', `ibuffer-filter-by-modified'
+and `ibuffer-filter-by-visiting-file'; bound respectively
+to '/b', '/.', '//', '/*', '/i' and '/v'.
+
+---
+*** Two new commands 'ibuffer-filter-chosen-by-completion'
+and `ibuffer-and-filter', the second bound to '/&'.
+
+---
+*** The commands `ibuffer-pop-filter', `ibuffer-pop-filter-group',
+`ibuffer-or-filter' and `ibuffer-filter-disable' have the alternative
+bindings '/<up>', '/S-<up>', '/|' and '/DEL', respectively.
+
+---
+*** The data format specifying filters has been extended to allow
+explicit logical 'and', and a more flexible form for logical 'not'.
+See 'ibuffer-filtering-qualifiers' doc string for full details.
+
+---
*** A new command 'ibuffer-copy-buffername-as-kill'; bound
to 'B'.
@@ -440,6 +480,45 @@ details.
provided: 'image-property'.
---
+*** New commands 'image-scroll-left' and 'image-scroll-right'
+for 'image-mode' that complement 'image-scroll-up' and
+'image-scroll-down': they have the same prefix arg behavior and stop
+at image boundaries.
+
+** Image-Dired
+
+*** Now provides a minor mode 'image-dired-minor-mode' which replaces
+the function 'image-dired-setup-dired-keybindings'.
+
+*** Thumbnail generation is now asynchronous
+The number of concurrent processes is limited by the variable
+'image-dired-thumb-job-limit'.
+
+*** 'image-dired-thumbnail-storage' has a new option 'standard-large'
+for generating 256x256 thumbnails according to the Thumbnail Managing
+Standard.
+
+*** Inherits movement keys from 'image-mode' for viewing full images.
+This includes the usual char, line, and page movement commands.
+
+*** All the -options types have been changed to argument lists
+instead of shell command strings. This change affects
+'image-dired-cmd-create-thumbnail-options',
+'image-dired-cmd-create-temp-image-options',
+'image-dired-cmd-rotate-thumbnail-options',
+'image-dired-cmd-rotate-original-options',
+'image-dired-cmd-write-exif-data-options',
+'image-dired-cmd-read-exif-data-options', and introduces
+'image-dired-cmd-pngnq-options', 'image-dired-cmd-pngcrush-options',
+'image-dired-cmd-create-standard-thumbnail-options'
+
+*** Recognizes more tools by default, including pngnq-s9 and OptiPNG
+
+*** 'find-file' and related commands now work on thumbnails and
+displayed images, providing a default argument of the original file name
+via an addition to 'file-name-at-point-functions'.
+
+---
** The default 'Info-default-directory-list' no longer checks some obsolete
directory suffixes (gnu, gnu/lib, gnu/lib/emacs, emacs, lib, lib/emacs)
when searching for info directories.
@@ -490,6 +569,10 @@ different group ID.
Drive onsite repositories.
+++
+*** Gateway methods in Tramp have been removed. Instead, the Tramp
+manual documents how to configure ssh and PuTTY accordingly.
+
++++
Setting the "ENV" environment variable in 'tramp-remote-process-environment'
enables reading of shell initialization files.
@@ -588,6 +671,7 @@ before running. This is controlled by the
'grep-save-buffers'
variable.
** Some obsolete functions, variables, and faces have been removed:
+*** make-variable-frame-local. Variables cannot be frame-local any more.
*** From subr.el: window-dot, set-window-dot, read-input, show-buffer,
eval-current-buffer, string-to-int
*** All the default-FOO variables that hold the default value of the
diff --git a/etc/images/icons/hicolor/scalable/mimetypes/emacs-document.svg
b/etc/images/icons/hicolor/scalable/mimetypes/emacs-document.svg
index fde79a2..2f5fde0 100644
--- a/etc/images/icons/hicolor/scalable/mimetypes/emacs-document.svg
+++ b/etc/images/icons/hicolor/scalable/mimetypes/emacs-document.svg
@@ -244,4 +244,4 @@
d="M 343.70805,92.437911 L 340.45142,163.9826 L 407.92401,146.89664 L
343.70805,92.437911 z" /><path
style="fill:url(#linearGradient3597);fill-opacity:1;fill-rule:evenodd;stroke:url(#linearGradient3257);stroke-width:0.40000001;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
id="path3587"
- d="M 345.72328,141.21214 C 369.54719,142.1578 408.63612,148.57658
423.38894,158.82173 C 429.63156,163.15694 437.02426,166.82736
436.86644,192.2301 C 436.05863,170.15935 433.76569,159.25553
422.20901,147.67024 C 365.34657,90.667114 353.06631,78.680195
332.88312,59.270019 C 316.59252,41.730605 308.6525,39.564301 299.86845,39.1 C
326.8119,41.20075 339.80786,67.674693 345.72328,141.21214 z" /></svg>
\ No newline at end of file
+ d="M 345.72328,141.21214 C 369.54719,142.1578 408.63612,148.57658
423.38894,158.82173 C 429.63156,163.15694 437.02426,166.82736
436.86644,192.2301 C 436.05863,170.15935 433.76569,159.25553
422.20901,147.67024 C 365.34657,90.667114 353.06631,78.680195
332.88312,59.270019 C 316.59252,41.730605 308.6525,39.564301 299.86845,39.1 C
326.8119,41.20075 339.80786,67.674693 345.72328,141.21214 z" /></svg>
diff --git a/lib/fpending.c b/lib/fpending.c
index a503b9f..ce93604 100644
--- a/lib/fpending.c
+++ b/lib/fpending.c
@@ -19,12 +19,42 @@
#include <config.h>
+/* Specification. */
#include "fpending.h"
+#include "stdio-impl.h"
+
/* Return the number of pending (aka buffered, unflushed)
bytes on the stream, FP, that is open for writing. */
size_t
__fpending (FILE *fp)
{
- return PENDING_OUTPUT_N_BYTES;
+ /* Most systems provide FILE as a struct and the necessary bitmask in
+ <stdio.h>, because they need it for implementing getc() and putc() as
+ fast macros. */
+#if defined _IO_ftrylockfile || __GNU_LIBRARY__ == 1 /* GNU libc, BeOS, Haiku,
Linux libc5 */
+ return fp->_IO_write_ptr - fp->_IO_write_base;
+#elif defined __sferror || defined __DragonFly__ || defined __ANDROID__
+ /* FreeBSD, NetBSD, OpenBSD, DragonFly, Mac OS X, Cygwin, Android */
+ return fp->_p - fp->_bf._base;
+#elif defined __EMX__ /* emx+gcc */
+ return fp->_ptr - fp->_buffer;
+#elif defined __minix /* Minix */
+ return fp_->_ptr - fp_->_buf;
+#elif defined _IOERR /* AIX, HP-UX, IRIX, OSF/1, Solaris,
OpenServer, mingw, MSVC, NonStop Kernel */
+ return (fp_->_ptr ? fp_->_ptr - fp_->_base : 0);
+#elif defined __UCLIBC__ /* uClibc */
+ return (fp->__modeflags & __FLAG_WRITING ? fp->__bufpos - fp->__bufstart :
0);
+#elif defined __QNX__ /* QNX */
+ return (fp->_Mode & 0x2000 /*_MWRITE*/ ? fp->_Next - fp->_Buf : 0);
+#elif defined __MINT__ /* Atari FreeMiNT */
+ return fp->__bufp - fp->__buffer;
+#elif defined EPLAN9 /* Plan9 */
+ return fp->wp - fp->buf;
+#elif defined __VMS /* VMS */
+ return (*fp)->_ptr - (*fp)->_base;
+#else
+# error "Please port gnulib fpending.c to your platform!"
+ return 1;
+#endif
}
diff --git a/lib/gnulib.mk b/lib/gnulib.mk
index 56c2109..0399abc 100644
--- a/lib/gnulib.mk
+++ b/lib/gnulib.mk
@@ -459,7 +459,7 @@ EXTRA_DIST += flexmember.h
## begin gnulib module fpending
-EXTRA_DIST += fpending.c fpending.h
+EXTRA_DIST += fpending.c fpending.h stdio-impl.h
EXTRA_libgnu_a_SOURCES += fpending.c
diff --git a/lib/stdio-impl.h b/lib/stdio-impl.h
new file mode 100644
index 0000000..766d693
--- /dev/null
+++ b/lib/stdio-impl.h
@@ -0,0 +1,140 @@
+/* Implementation details of FILE streams.
+ Copyright (C) 2007-2008, 2010-2016 Free Software Foundation, Inc.
+
+ This program 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.
+
+ This program 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 this program. If not, see <http://www.gnu.org/licenses/>. */
+
+/* Many stdio implementations have the same logic and therefore can share
+ the same implementation of stdio extension API, except that some fields
+ have different naming conventions, or their access requires some casts. */
+
+
+/* BSD stdio derived implementations. */
+
+#if defined __NetBSD__ /* NetBSD */
+/* Get __NetBSD_Version__. */
+# include <sys/param.h>
+#endif
+
+#include <errno.h> /* For detecting Plan9. */
+
+#if defined __sferror || defined __DragonFly__ || defined __ANDROID__
+ /* FreeBSD, NetBSD, OpenBSD, DragonFly, Mac OS X, Cygwin, Android */
+
+# if defined __DragonFly__ /* DragonFly */
+ /* See
<http://www.dragonflybsd.org/cvsweb/src/lib/libc/stdio/priv_stdio.h?rev=HEAD&content-type=text/x-cvsweb-markup>.
*/
+# define fp_ ((struct { struct __FILE_public pub; \
+ struct { unsigned char *_base; int _size; } _bf; \
+ void *cookie; \
+ void *_close; \
+ void *_read; \
+ void *_seek; \
+ void *_write; \
+ struct { unsigned char *_base; int _size; } _ub; \
+ int _ur; \
+ unsigned char _ubuf[3]; \
+ unsigned char _nbuf[1]; \
+ struct { unsigned char *_base; int _size; } _lb; \
+ int _blksize; \
+ fpos_t _offset; \
+ /* More fields, not relevant here. */ \
+ } *) fp)
+ /* See
<http://www.dragonflybsd.org/cvsweb/src/include/stdio.h?rev=HEAD&content-type=text/x-cvsweb-markup>.
*/
+# define _p pub._p
+# define _flags pub._flags
+# define _r pub._r
+# define _w pub._w
+# else
+# define fp_ fp
+# endif
+
+# if (defined __NetBSD__ && __NetBSD_Version__ >= 105270000) || defined
__OpenBSD__ || defined __ANDROID__ /* NetBSD >= 1.5ZA, OpenBSD, Android */
+ /* See
<http://cvsweb.netbsd.org/bsdweb.cgi/src/lib/libc/stdio/fileext.h?rev=HEAD&content-type=text/x-cvsweb-markup>
+ and
<http://www.openbsd.org/cgi-bin/cvsweb/src/lib/libc/stdio/fileext.h?rev=HEAD&content-type=text/x-cvsweb-markup>
*/
+ struct __sfileext
+ {
+ struct __sbuf _ub; /* ungetc buffer */
+ /* More fields, not relevant here. */
+ };
+# define fp_ub ((struct __sfileext *) fp->_ext._base)->_ub
+# else /* FreeBSD, NetBSD <= 1.5Z,
DragonFly, Mac OS X, Cygwin, Android */
+# define fp_ub fp_->_ub
+# endif
+
+# define HASUB(fp) (fp_ub._base != NULL)
+
+#endif
+
+
+/* SystemV derived implementations. */
+
+#ifdef __TANDEM /* NonStop Kernel */
+# ifndef _IOERR
+/* These values were determined by the program 'stdioext-flags' at
+ <http://lists.gnu.org/archive/html/bug-gnulib/2010-12/msg00165.html>. */
+# define _IOERR 0x40
+# define _IOREAD 0x80
+# define _IOWRT 0x4
+# define _IORW 0x100
+# endif
+#endif
+
+#if defined _IOERR
+
+# if defined __sun && defined _LP64 /* Solaris/{SPARC,AMD64} 64-bit */
+# define fp_ ((struct { unsigned char *_ptr; \
+ unsigned char *_base; \
+ unsigned char *_end; \
+ long _cnt; \
+ int _file; \
+ unsigned int _flag; \
+ } *) fp)
+# else
+# define fp_ fp
+# endif
+
+# if defined _SCO_DS /* OpenServer */
+# define _cnt __cnt
+# define _ptr __ptr
+# define _base __base
+# define _flag __flag
+# endif
+
+#elif (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ /* newer
Windows with MSVC */
+
+/* <stdio.h> does not define the innards of FILE any more. */
+# define WINDOWS_OPAQUE_FILE
+
+struct _gl_real_FILE
+{
+ /* Note: Compared to older Windows and to mingw, it has the fields
+ _base and _cnt swapped. */
+ unsigned char *_ptr;
+ unsigned char *_base;
+ int _cnt;
+ int _flag;
+ int _file;
+ int _charbuf;
+ int _bufsiz;
+};
+# define fp_ ((struct _gl_real_FILE *) fp)
+
+/* These values were determined by a program similar to the one at
+ <http://lists.gnu.org/archive/html/bug-gnulib/2010-12/msg00165.html>. */
+# define _IOREAD 0x1
+# define _IOWRT 0x2
+# define _IORW 0x4
+# define _IOEOF 0x8
+# define _IOERR 0x10
+
+#endif
diff --git a/lib/xalloc-oversized.h b/lib/xalloc-oversized.h
index 53e6556..503bb37 100644
--- a/lib/xalloc-oversized.h
+++ b/lib/xalloc-oversized.h
@@ -19,32 +19,36 @@
#define XALLOC_OVERSIZED_H_
#include <stddef.h>
+#include <stdint.h>
/* Default for (non-Clang) compilers that lack __has_builtin. */
#ifndef __has_builtin
# define __has_builtin(x) 0
#endif
-/* True if N * S would overflow in a size calculation.
+/* True if N * S would overflow in a size_t calculation,
+ or would generate a value larger than PTRDIFF_MAX.
This expands to a constant expression if N and S are both constants.
By gnulib convention, SIZE_MAX represents overflow in size
- calculations, so the conservative dividend to use here is
- SIZE_MAX - 1, since SIZE_MAX might represent an overflowed value.
- However, malloc (SIZE_MAX) fails on all known hosts where
- sizeof (ptrdiff_t) <= sizeof (size_t), so do not bother to test for
- exactly-SIZE_MAX allocations on such hosts; this avoids a test and
- branch when S is known to be 1. */
+ calculations, so the conservative size_t-based dividend to use here
+ is SIZE_MAX - 1. */
#define __xalloc_oversized(n, s) \
- ((size_t) (sizeof (ptrdiff_t) <= sizeof (size_t) ? -1 : -2) / (s) < (n))
+ ((size_t) (PTRDIFF_MAX < SIZE_MAX ? PTRDIFF_MAX : SIZE_MAX - 1) / (s) < (n))
+#if PTRDIFF_MAX < SIZE_MAX
+typedef ptrdiff_t __xalloc_count_type;
+#else
+typedef size_t __xalloc_count_type;
+#endif
-/* Return 1 if an array of N objects, each of size S, cannot exist due
- to size arithmetic overflow. S must be positive and N must be
- nonnegative. This is a macro, not a function, so that it
- works correctly even when SIZE_MAX < N. */
+/* Return 1 if an array of N objects, each of size S, cannot exist
+ reliably due to size or ptrdiff_t arithmetic overflow. S must be
+ positive and N must be nonnegative. This is a macro, not a
+ function, so that it works correctly even when SIZE_MAX < N. */
#if 7 <= __GNUC__ || __has_builtin (__builtin_add_overflow_p)
-# define xalloc_oversized(n, s) __builtin_mul_overflow_p (n, s, (size_t) 1)
+# define xalloc_oversized(n, s) \
+ __builtin_mul_overflow_p (n, s, (__xalloc_count_type) 1)
#elif ((5 <= __GNUC__ \
|| (__has_builtin (__builtin_mul_overflow) \
&& __has_builtin (__builtin_constant_p))) \
@@ -52,7 +56,8 @@
# define xalloc_oversized(n, s) \
(__builtin_constant_p (n) && __builtin_constant_p (s) \
? __xalloc_oversized (n, s) \
- : ({ size_t __xalloc_size; __builtin_mul_overflow (n, s, &__xalloc_size);
}))
+ : ({ __xalloc_count_type __xalloc_count; \
+ __builtin_mul_overflow (n, s, &__xalloc_count); }))
/* Other compilers use integer division; this may be slower but is
more portable. */
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index 12bb9c7..34f2b2c 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -230,7 +230,7 @@ FORCE:
tagsfiles = $(shell find ${srcdir} -name '*.el')
tagsfiles := $(filter-out ${srcdir}/%loaddefs.el,${tagsfiles})
-tagsfiles := $(filter-out ${srcdir}/ldefs-boot.el,${tagsfiles})
+tagsfiles := $(filter-out ${srcdir}/ldefs-boot%.el,${tagsfiles})
tagsfiles := $(filter-out ${srcdir}/eshell/esh-groups.el,${tagsfiles})
ETAGS = ../lib-src/etags${EXEEXT}
@@ -283,7 +283,7 @@ $(THEFILE)c:
.PHONY: compile-first compile-main compile compile-always
-compile-first: $(COMPILE_FIRST)
+compile-first: loaddefs.el $(COMPILE_FIRST)
# In 'compile-main' we could directly do
# ... | xargs $(MAKE)
@@ -450,7 +450,7 @@ check-declare:
check-defun-dups:
sed -n -e '/^(defun /s/\(.\)(.*/\1/p' \
$$(find . -name '*.el' -print | \
- grep -Ev '(loaddefs|ldefs-boot)\.el') | sort | uniq -d
+ grep -Ev '(loaddefs|ldefs-boot*)\.el') | sort | uniq -d
# Dependencies
diff --git a/lisp/bookmark.el b/lisp/bookmark.el
index f3c8b2a..7d45832 100644
--- a/lisp/bookmark.el
+++ b/lisp/bookmark.el
@@ -2123,7 +2123,7 @@ To carry out the deletions that you've marked, use
\\<bookmark-bmenu-mode-map>\\
(current-buffer))))
(read-string "Pattern: ")
(when timer (cancel-timer timer) (setq timer nil)))
- (when timer ;; Signalled an error or a `quit'.
+ (when timer ;; Signaled an error or a `quit'.
(cancel-timer timer)
(bookmark-bmenu-list)
(bookmark-bmenu-goto-bookmark bmk)))))
diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el
index 4f42431..71e1468 100644
--- a/lisp/cedet/mode-local.el
+++ b/lisp/cedet/mode-local.el
@@ -31,7 +31,7 @@
;; This library permits the setting of override functions for tasks of
;; that nature, and also provides reasonable defaults.
;;
-;; There are buffer local variables, and frame local variables.
+;; There are buffer local variables (and there were frame local variables).
;; This library gives the illusion of mode specific variables.
;;
;; You should use a mode-local variable or override to allow extension
diff --git a/lisp/cedet/semantic/db-global.el b/lisp/cedet/semantic/db-global.el
index 03a21b0..4793c53 100644
--- a/lisp/cedet/semantic/db-global.el
+++ b/lisp/cedet/semantic/db-global.el
@@ -47,7 +47,7 @@ in a GNU Global supported hierarchy.
Two sanity checks are performed to assure (a) that GNU global program exists
and (b) that the GNU global program version is compatibility with the database
-version. If optional NOERROR is nil, then an error may be signalled on version
+version. If optional NOERROR is nil, then an error may be signaled on version
mismatch. If NOERROR is not nil, then no error will be signaled. Instead
return value will indicate success or failure with non-nil or nil respective
values."
diff --git a/lisp/cus-dep.el b/lisp/cus-dep.el
index b31c60f..90da4a8 100644
--- a/lisp/cus-dep.el
+++ b/lisp/cus-dep.el
@@ -33,7 +33,7 @@
;; See finder-no-scan-regexp in finder.el.
(defvar custom-dependencies-no-scan-regexp "\\(^\\.#\\|\\(loaddefs\\|\
-ldefs-boot\\|cus-load\\|finder-inf\\|esh-groups\\|subdirs\\)\\.el$\\)"
+ldefs-boot.*\\|cus-load\\|finder-inf\\|esh-groups\\|subdirs\\)\\.el$\\)"
"Regexp matching file names not to scan for `custom-make-dependencies'.")
(require 'autoload)
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el
index c0da59c..b621ac5 100644
--- a/lisp/emacs-lisp/advice.el
+++ b/lisp/emacs-lisp/advice.el
@@ -2830,7 +2830,7 @@ advised definition from scratch."
(ad-get-cache-id function))))
(ad-set-advice-info function old-advice-info)
(advice-remove function advicefunname)
- (fset advicefunname old-advice)
+ (if advicefunname (fset advicefunname old-advice))
(if old-advice (advice-add function :around advicefunname)))))
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 818c268..9d2a048 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -240,6 +240,11 @@ The return value is undefined.
;; from
;; (defun foo (arg) (toto)).
(declare (doc-string 3) (indent 2))
+ (or name (error "Cannot define '%s' as a function" name))
+ (if (null
+ (and (listp arglist)
+ (null (delq t (mapcar #'symbolp arglist)))))
+ (error "Malformed arglist: %s" arglist))
(let ((decls (cond
((eq (car-safe docstring) 'declare)
(prog1 (cdr docstring) (setq docstring nil)))
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el
index 5430b72..5a4b097 100644
--- a/lisp/emacs-lisp/debug.el
+++ b/lisp/emacs-lisp/debug.el
@@ -274,15 +274,14 @@ That buffer should be current already."
(let ((standard-output (current-buffer))
(print-escape-newlines t)
(print-level 8)
- (print-length 50))
- (backtrace))
+ (print-length 50))
+ ;; FIXME the debugger could pass a custom callback to mapbacktrace
+ ;; instead of manipulating printed results.
+ (mapbacktrace #'backtrace--print-frame 'debug))
(goto-char (point-min))
(delete-region (point)
(progn
- (search-forward (if debugger-stack-frame-as-list
- "\n (debug "
- "\n debug("))
- (forward-line (if (eq (car args) 'debug)
+ (forward-line (if (eq (car args) 'debug)
;; Remove debug--implement-debug-on-entry
;; and the advice's `apply' frame.
3
diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el
index 0f7691a..3117027 100644
--- a/lisp/emacs-lisp/derived.el
+++ b/lisp/emacs-lisp/derived.el
@@ -217,16 +217,17 @@ No problems result if this variable is not bound.
,(if declare-syntax
`(progn
(unless (boundp ',syntax)
- (put ',syntax 'definition-name ',child))
- (defvar ,syntax (make-syntax-table))
+ (put ',syntax 'definition-name ',child)
+ (defvar ,syntax (make-syntax-table)))
(unless (get ',syntax 'variable-documentation)
(put ',syntax 'variable-documentation
(purecopy ,(format "Syntax table for `%s'." child))))))
,(if declare-abbrev
`(progn
- (put ',abbrev 'definition-name ',child)
- (defvar ,abbrev
- (progn (define-abbrev-table ',abbrev nil) ,abbrev))
+ (unless (boundp ',abbrev)
+ (put ',abbrev 'definition-name ',child)
+ (defvar ,abbrev
+ (progn (define-abbrev-table ',abbrev nil) ,abbrev)))
(unless (get ',abbrev 'variable-documentation)
(put ',abbrev 'variable-documentation
(purecopy ,(format "Abbrev table for `%s'." child))))))
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index 66117b8..04a493c 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -2170,8 +2170,7 @@ The purpose of this function is so you can properly undo
subsequent changes to the same binding, by passing the status
cons cell to `edebug-restore-status'. The status cons cell
has the form (LOCUS . VALUE), where LOCUS can be a buffer
-\(for a buffer-local binding), a frame (for a frame-local binding),
-or nil (if the default binding is current)."
+\(for a buffer-local binding), or nil (if the default binding is current)."
(cons (variable-binding-locus var)
(symbol-value var)))
diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el
index 7f0f947..ab0a54c 100644
--- a/lisp/emacs-lisp/elint.el
+++ b/lisp/emacs-lisp/elint.el
@@ -105,7 +105,7 @@ are as follows, and suppress messages about the indicated
features:
:version "23.2"
:group 'elint)
-(defcustom elint-directory-skip-re "\\(ldefs-boot\\|loaddefs\\)\\.el\\'"
+(defcustom elint-directory-skip-re "\\(ldefs-boot.*\\|loaddefs\\)\\.el\\'"
"If nil, a regexp matching files to skip when linting a directory."
:type '(choice (const :tag "Lint all files" nil)
(regexp :tag "Regexp to skip"))
diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el
index 66d295e..d305597 100644
--- a/lisp/emacs-lisp/rx.el
+++ b/lisp/emacs-lisp/rx.el
@@ -521,7 +521,7 @@ ARG is optional."
(setq args (nconc (delq ?- args) (list ?-))))
((setq m (assq ?- args))
;; next to the bracket's range, make the second range
- (setcdr args (cons m (delq m args))))))
+ (setcdr args (cons m (delq m (cdr args)))))))
;; bracket in the end range
;; => "[]...-]"
((setq m (rassq ?\] args))
diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el
index 5ddc5a5..7451024 100644
--- a/lisp/emacs-lisp/seq.el
+++ b/lisp/emacs-lisp/seq.el
@@ -178,7 +178,8 @@ Return a list of the results.
\(fn FUNCTION SEQUENCES...)"
(let ((result nil)
- (sequences (seq-map (lambda (s) (seq-into s 'list))
+ (sequences (seq-map (lambda (s)
+ (seq-into s 'list))
(cons sequence sequences))))
(while (not (memq nil sequences))
(push (apply function (seq-map #'car sequences)) result)
@@ -272,9 +273,9 @@ of sequence."
TYPE can be one of the following symbols: vector, string or
list."
(pcase type
- (`vector (vconcat sequence))
- (`string (concat sequence))
- (`list (append sequence nil))
+ (`vector (seq--into-vector sequence))
+ (`string (seq--into-string sequence))
+ (`list (seq--into-list sequence))
(_ (error "Not a sequence type name: %S" type))))
(cl-defgeneric seq-filter (pred sequence)
@@ -511,6 +512,24 @@ Signal an error if SEQUENCE is empty."
(null list))
+(defun seq--into-list (sequence)
+ "Concatenate the elements of SEQUENCE into a list."
+ (if (listp sequence)
+ sequence
+ (append sequence nil)))
+
+(defun seq--into-vector (sequence)
+ "Concatenate the elements of SEQUENCE into a vector."
+ (if (vectorp sequence)
+ sequence
+ (vconcat sequence)))
+
+(defun seq--into-string (sequence)
+ "Concatenate the elements of SEQUENCE into a string."
+ (if (stringp sequence)
+ sequence
+ (concat sequence)))
+
(defun seq--activate-font-lock-keywords ()
"Activate font-lock keywords for some symbols defined in seq."
(font-lock-add-keywords 'emacs-lisp-mode
diff --git a/lisp/finder.el b/lisp/finder.el
index da537a5..e6d666a 100644
--- a/lisp/finder.el
+++ b/lisp/finder.el
@@ -130,8 +130,8 @@ Keywords and package names both should be symbols.")
;; useful, and because in parallel builds of Emacs they may get
;; modified while we are trying to read them.
;; http://lists.gnu.org/archive/html/emacs-pretest-bug/2007-01/msg00469.html
-;; ldefs-boot is not auto-generated, but has nothing useful.
-(defvar finder-no-scan-regexp "\\(^\\.#\\|\\(loaddefs\\|ldefs-boot\\|\
+;; ldefs-boot-* are not auto-generated during build, but has nothing useful.
+(defvar finder-no-scan-regexp "\\(^\\.#\\|\\(loaddefs\\|ldefs-boot-.*\\|\
cus-load\\|finder-inf\\|esh-groups\\|subdirs\\|leim-list\\)\\.el$\\)"
"Regexp matching file names not to scan for keywords.")
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index 448ba7b..5446aa2 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -4206,14 +4206,14 @@ not have PROP."
(nreverse regions)))
(defcustom message-bogus-addresses
- '("noreply" "nospam" "invalid" "@@" "[^[:ascii:]].*@" "[ \t]")
+ '("noreply" "nospam" "invalid" "@.*@" "[^[:ascii:]].*@" "[ \t]")
"List of regexps of potentially bogus mail addresses.
See `message-check-recipients' how to setup checking.
This list should make it possible to catch typos or warn about
spam-trap addresses. It doesn't aim to verify strict RFC
conformance."
- :version "23.1" ;; No Gnus
+ :version "26.1" ; @@ -> @.*@
:group 'message-headers
:type '(choice
(const :tag "None" nil)
@@ -4222,7 +4222,7 @@ conformance."
(const "noreply")
(const "nospam")
(const "invalid")
- (const :tag "duplicate @" "@@")
+ (const :tag "duplicate @" "@.*@")
(const :tag "non-ascii local part" "[^[:ascii:]].*@")
(const :tag "`_' in domain part" "@.*_")
(const :tag "whitespace" "[ \t]"))
@@ -4339,8 +4339,6 @@ An address might be bogus if if there's a matching entry
in
(mapc (lambda (address)
(setq address (or (cadr address) ""))
(when (or (string= "" address)
- (not (string-match "@" address))
- (string-match "@.*@" address)
(and message-bogus-addresses
(let ((re
(if (listp message-bogus-addresses)
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index 23dec89..6402f77 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -863,8 +863,6 @@ it is displayed along with the global value."
((bufferp locus)
(princ (format "Local in buffer %s; "
(buffer-name buffer))))
- ((framep locus)
- (princ (format "It is a frame-local variable; ")))
((terminal-live-p locus)
(princ (format "It is a terminal-local variable; ")))
(t
diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el
index 9ce7b5a..7ebfecd 100644
--- a/lisp/ibuf-ext.el
+++ b/lisp/ibuf-ext.el
@@ -28,6 +28,13 @@
;; These functions should be automatically loaded when called, but you
;; can explicitly (require 'ibuf-ext) in your ~/.emacs to have them
;; preloaded.
+;;
+;; For details on the structure of ibuffer filters and filter groups,
+;; see the documentation for variables `ibuffer-filtering-qualifiers',
+;; `ibuffer-filter-groups', and `ibuffer-saved-filters' in that order.
+;; The variable `ibuffer-filtering-alist' contains names and
+;; descriptions of the currently defined filters; also see the macro
+;; `define-ibuffer-filter'.
;;; Code:
@@ -139,19 +146,33 @@ Returns (OLD-FORMAT-DETECTED .
UPDATED-SAVED-FILTERS-LIST)."
(fixed (mapcar fix-filter filters)))
(cons old-format-detected fixed))))
-(defcustom ibuffer-saved-filters '(("gnus"
+(defcustom ibuffer-saved-filters '(("programming"
+ (or (derived-mode . prog-mode)
+ (mode . ess-mode)
+ (mode . compilation-mode)))
+ ("text document"
+ (and (derived-mode . text-mode)
+ (not (starred-name))))
+ ("TeX"
+ (or (derived-mode . tex-mode)
+ (mode . latex-mode)
+ (mode . context-mode)
+ (mode . ams-tex-mode)
+ (mode . bibtex-mode)))
+ ("web"
+ (or (derived-mode . sgml-mode)
+ (derived-mode . css-mode)
+ (mode . javascript-mode)
+ (mode . js2-mode)
+ (mode . scss-mode)
+ (derived-mode . haml-mode)
+ (mode . sass-mode)))
+ ("gnus"
(or (mode . message-mode)
(mode . mail-mode)
(mode . gnus-group-mode)
(mode . gnus-summary-mode)
- (mode . gnus-article-mode)))
- ("programming"
- (or (mode . emacs-lisp-mode)
- (mode . cperl-mode)
- (mode . c-mode)
- (mode . java-mode)
- (mode . idl-mode)
- (mode . lisp-mode))))
+ (mode . gnus-article-mode))))
"An alist mapping saved filter names to filter specifications.
@@ -214,8 +235,48 @@ Alternative ways to save the repaired value:
"))
(defvar ibuffer-filtering-qualifiers nil
- "A list like (SYMBOL . QUALIFIER) which filters the current buffer list.
-See also `ibuffer-filtering-alist'.")
+ "A list specifying the filters currently acting on the buffer list.
+
+If this list is nil, then no filters are currently in
+effect. Otherwise, each element of this list specifies a single
+filter, and all of the specified filters in the list are applied
+successively to the buffer list.
+
+Each filter specification can be of two types: simple or compound.
+
+A simple filter specification has the form (SYMBOL . QUALIFIER),
+where SYMBOL is a key in the alist `ibuffer-filtering-alist' that
+determines the filter function to use and QUALIFIER is the data
+passed to that function (along with the buffer being considered).
+
+A compound filter specification can have one of four forms:
+
+-- (not FILTER-SPEC)
+
+ Represents the logical complement of FILTER-SPEC, which
+ is any single filter specification, simple or compound.
+ The form (not . FILTER-SPEC) is also accepted here.
+
+-- (and FILTER-SPECS...)
+
+ Represents the logical-and of the filters defined by one or
+ more filter specifications FILTER-SPECS..., where each
+ specification can be simple or compound. Note that and is
+ implicitly applied to the filters in the top-level list.
+
+-- (or FILTER-SPECS...)
+
+ Represents the logical-or of the filters defined by one or
+ more filter specifications FILTER-SPECS..., where each
+ specification can be simple or compound.
+
+-- (saved . \"NAME\")
+
+ Represents the filter saved under the string NAME
+ in the alist `ibuffer-saved-filters'. It is an
+ error to name a filter that has not been saved.
+
+This variable is local to each ibuffer buffer.")
;; This is now frobbed by `define-ibuffer-filter'.
(defvar ibuffer-filtering-alist nil
@@ -247,10 +308,18 @@ to this variable."
(defvar ibuffer-compiled-filter-formats nil)
(defvar ibuffer-filter-groups nil
- "A list like ((\"NAME\" ((SYMBOL . QUALIFIER) ...) ...) which groups buffers.
-The SYMBOL should be one from `ibuffer-filtering-alist'.
-The QUALIFIER should be the same as QUALIFIER in
-`ibuffer-filtering-qualifiers'.")
+ "An alist giving this buffer's active filter groups, or nil if none.
+
+This alist maps filter group labels to filter specification
+lists. Each element has the form (\"LABEL\" FILTER-SPECS...),
+where FILTER-SPECS... represents one or more filter
+specifications of the same form as allowed as elements of
+`ibuffer-filtering-qualifiers'.
+
+Each filter group is displayed as a separate section in the
+ibuffer list, headed by LABEL and displaying only the buffers
+that pass through all the filters associated with NAME in this
+list.")
(defcustom ibuffer-show-empty-filter-groups t
"If non-nil, then show the names of filter groups which are empty."
@@ -260,20 +329,21 @@ The QUALIFIER should be the same as QUALIFIER in
(defcustom ibuffer-saved-filter-groups nil
"An alist of filtering groups to switch between.
-This variable should look like ((\"STRING\" QUALIFIERS)
- (\"STRING\" QUALIFIERS) ...), where
-QUALIFIERS is a list of the same form as
-`ibuffer-filtering-qualifiers'.
+Each element is of the form (\"NAME\" . FILTER-GROUP-LIST),
+where NAME is a unique but arbitrary name and FILTER-GROUP-LIST
+is a list of filter groups with the same structure as
+allowed for `ibuffer-filter-groups'.
-See also the variables `ibuffer-filter-groups',
-`ibuffer-filtering-qualifiers', `ibuffer-filtering-alist', and the
-functions `ibuffer-switch-to-saved-filter-groups',
-`ibuffer-save-filter-groups'."
+See also the functions `ibuffer-save-filter-groups' and
+`ibuffer-switch-to-saved-filter-groups' for saving and switching
+between sets of filter groups, and the variable
+`ibuffer-save-with-custom' that affects how this information is
+saved."
:type '(repeat sexp)
:group 'ibuffer)
(defvar ibuffer-hidden-filter-groups nil
- "A list of filtering groups which are currently hidden.")
+ "The list of filter groups that are currently hidden.")
(defvar ibuffer-filter-group-kill-ring nil)
@@ -602,18 +672,38 @@ To evaluate a form without viewing the buffer, see
`ibuffer-do-eval'."
;;;###autoload
(defun ibuffer-included-in-filters-p (buf filters)
+ "Return non-nil if BUF passes all FILTERS.
+
+BUF is a lisp buffer object, and FILTERS is a list of filter
+specifications with the same structure as
+`ibuffer-filtering-qualifiers'."
(not
(memq nil ;; a filter will return nil if it failed
- (mapcar
- ;; filter should be like (TYPE . QUALIFIER), or
- ;; (or (TYPE . QUALIFIER) (TYPE . QUALIFIER) ...)
- #'(lambda (qual)
- (ibuffer-included-in-filter-p buf qual))
- filters))))
+ (mapcar #'(lambda (filter)
+ (ibuffer-included-in-filter-p buf filter))
+ filters))))
+
+(defun ibuffer-unary-operand (filter)
+ "Extracts operand from a unary compound FILTER specification.
+
+FILTER should be a cons cell of either form (f . d) or (f d),
+where operand d is itself a cons cell, or nil. Returns d."
+ (let* ((tail (cdr filter))
+ (maybe-q (car-safe tail)))
+ (if (consp maybe-q) maybe-q tail)))
(defun ibuffer-included-in-filter-p (buf filter)
+ "Return non-nil if BUF pass FILTER.
+
+BUF is a lisp buffer object, and FILTER is a filter
+specification, with the same structure as an element of the list
+`ibuffer-filtering-qualifiers'."
(if (eq (car filter) 'not)
- (not (ibuffer-included-in-filter-p-1 buf (cdr filter)))
+ (let ((inner (ibuffer-unary-operand filter)))
+ ;; Allows (not (not ...)) etc, which may be overkill
+ (if (eq (car inner) 'not)
+ (ibuffer-included-in-filter-p buf (ibuffer-unary-operand inner))
+ (not (ibuffer-included-in-filter-p-1 buf inner))))
(ibuffer-included-in-filter-p-1 buf filter)))
(defun ibuffer-included-in-filter-p-1 (buf filter)
@@ -621,9 +711,19 @@ To evaluate a form without viewing the buffer, see
`ibuffer-do-eval'."
(not
(pcase (car filter)
(`or
+ ;;; ATTN: Short-circuiting alternative with parallel structure w/`and
+ ;;(catch 'has-match
+ ;; (dolist (filter-spec (cdr filter) nil)
+ ;; (when (ibuffer-included-in-filter-p buf filter-spec)
+ ;; (throw 'has-match t))))
(memq t (mapcar #'(lambda (x)
- (ibuffer-included-in-filter-p buf x))
- (cdr filter))))
+ (ibuffer-included-in-filter-p buf x))
+ (cdr filter))))
+ (`and
+ (catch 'no-match
+ (dolist (filter-spec (cdr filter) t)
+ (unless (ibuffer-included-in-filter-p buf filter-spec)
+ (throw 'no-match nil)))))
(`saved
(let ((data (assoc (cdr filter) ibuffer-saved-filters)))
(unless data
@@ -916,17 +1016,17 @@ group definitions by setting `ibuffer-filter-groups' to
nil."
(when buf
(ibuffer-jump-to-buffer (buffer-name buf)))))
-(defun ibuffer-push-filter (qualifier)
- "Add QUALIFIER to `ibuffer-filtering-qualifiers'."
- (push qualifier ibuffer-filtering-qualifiers))
+(defun ibuffer-push-filter (filter-specification)
+ "Add FILTER-SPECIFICATION to `ibuffer-filtering-qualifiers'."
+ (push filter-specification ibuffer-filtering-qualifiers))
;;;###autoload
(defun ibuffer-decompose-filter ()
- "Separate the top compound filter (OR, NOT, or SAVED) in this buffer.
+ "Separate this buffer's top compound filter (AND, OR, NOT, or SAVED).
This means that the topmost filter on the filtering stack, which must
be a complex filter like (OR [name: foo] [mode: bar-mode]), will be
-turned into two separate filters [name: foo] and [mode: bar-mode]."
+turned into separate filters, like [name: foo] and [mode: bar-mode]."
(interactive)
(unless ibuffer-filtering-qualifiers
(error "No filters in effect"))
@@ -935,14 +1035,14 @@ turned into two separate filters [name: foo] and [mode:
bar-mode]."
(tail (cdr filters))
(value
(pcase (caar filters)
- (`or (nconc head tail))
+ ((or `or 'and) (nconc head tail))
(`saved
(let ((data (assoc head ibuffer-saved-filters)))
(unless data
(ibuffer-filter-disable)
(error "Unknown saved filter %s" head))
(append (cdr data) tail)))
- (`not (cons head tail))
+ (`not (cons (ibuffer-unary-operand (car filters)) tail))
(_
(error "Filter type %s is not compound" (caar filters))))))
(setq ibuffer-filtering-qualifiers value))
@@ -971,31 +1071,36 @@ turned into two separate filters [name: foo] and [mode:
bar-mode]."
ibuffer-filtering-qualifiers))
(ibuffer-update nil t))
+(defun ibuffer--or-and-filter (op decompose)
+ (if decompose
+ (if (eq op (caar ibuffer-filtering-qualifiers))
+ (ibuffer-decompose-filter)
+ (error "Top filter is not an %s" (upcase (symbol-name op))))
+ (when (< (length ibuffer-filtering-qualifiers) 2)
+ (error "Need two filters to %s" (upcase (symbol-name op))))
+ ;; If either filter is an op, eliminate unnecessary nesting.
+ (let ((first (pop ibuffer-filtering-qualifiers))
+ (second (pop ibuffer-filtering-qualifiers)))
+ (push (nconc (if (eq op (car first)) first (list op first))
+ (if (eq op (car second)) (cdr second) (list second)))
+ ibuffer-filtering-qualifiers)))
+ (ibuffer-update nil t))
+
;;;###autoload
-(defun ibuffer-or-filter (&optional reverse)
+(defun ibuffer-or-filter (&optional decompose)
"Replace the top two filters in this buffer with their logical OR.
-If optional argument REVERSE is non-nil, instead break the top OR
+If optional argument DECOMPOSE is non-nil, instead break the top OR
filter into parts."
(interactive "P")
- (if reverse
- (progn
- (when (or (null ibuffer-filtering-qualifiers)
- (not (eq 'or (caar ibuffer-filtering-qualifiers))))
- (error "Top filter is not an OR"))
- (let ((lim (pop ibuffer-filtering-qualifiers)))
- (setq ibuffer-filtering-qualifiers
- (nconc (cdr lim) ibuffer-filtering-qualifiers))))
- (when (< (length ibuffer-filtering-qualifiers) 2)
- (error "Need two filters to OR"))
- ;; If the second filter is an OR, just add to it.
- (let ((first (pop ibuffer-filtering-qualifiers))
- (second (pop ibuffer-filtering-qualifiers)))
- (if (eq 'or (car second))
- (push (nconc (list 'or first) (cdr second))
- ibuffer-filtering-qualifiers)
- (push (list 'or first second)
- ibuffer-filtering-qualifiers))))
- (ibuffer-update nil t))
+ (ibuffer--or-and-filter 'or decompose))
+
+;;;###autoload
+(defun ibuffer-and-filter (&optional decompose)
+ "Replace the top two filters in this buffer with their logical AND.
+If optional argument DECOMPOSE is non-nil, instead break the top AND
+filter into parts."
+ (interactive "P")
+ (ibuffer--or-and-filter 'and decompose))
(defun ibuffer-maybe-save-stuff ()
(when ibuffer-save-with-custom
@@ -1069,7 +1174,9 @@ Interactively, prompt for NAME, and use the current
filters."
(defun ibuffer-format-qualifier (qualifier)
(if (eq (car-safe qualifier) 'not)
- (concat " [NOT" (ibuffer-format-qualifier-1 (cdr qualifier)) "]")
+ (concat " [NOT"
+ (ibuffer-format-qualifier-1 (ibuffer-unary-operand qualifier))
+ "]")
(ibuffer-format-qualifier-1 qualifier)))
(defun ibuffer-format-qualifier-1 (qualifier)
@@ -1078,14 +1185,16 @@ Interactively, prompt for NAME, and use the current
filters."
(concat " [filter: " (cdr qualifier) "]"))
(`or
(concat " [OR" (mapconcat #'ibuffer-format-qualifier
- (cdr qualifier) "") "]"))
+ (cdr qualifier) "") "]"))
+ (`and
+ (concat " [AND" (mapconcat #'ibuffer-format-qualifier
+ (cdr qualifier) "") "]"))
(_
(let ((type (assq (car qualifier) ibuffer-filtering-alist)))
(unless qualifier
- (error "Ibuffer: bad qualifier %s" qualifier))
+ (error "Ibuffer: bad qualifier %s" qualifier))
(concat " [" (cadr type) ": " (format "%s]" (cdr qualifier)))))))
-
(defun ibuffer-list-buffer-modes (&optional include-parents)
"Create a completion table of buffer modes currently in use.
If INCLUDE-PARENTS is non-nil then include parent modes."
@@ -1103,7 +1212,7 @@ If INCLUDE-PARENTS is non-nil then include parent modes."
;;;###autoload (autoload 'ibuffer-filter-by-mode "ibuf-ext")
(define-ibuffer-filter mode
- "Toggle current view to buffers with major mode QUALIFIER."
+ "Limit current view to buffers with major mode QUALIFIER."
(:description "major mode"
:reader
(let* ((buf (ibuffer-current-buffer))
@@ -1123,7 +1232,7 @@ If INCLUDE-PARENTS is non-nil then include parent modes."
;;;###autoload (autoload 'ibuffer-filter-by-used-mode "ibuf-ext")
(define-ibuffer-filter used-mode
- "Toggle current view to buffers with major mode QUALIFIER.
+ "Limit current view to buffers with major mode QUALIFIER.
Called interactively, this function allows selection of modes
currently used by buffers."
(:description "major mode in use"
@@ -1142,7 +1251,7 @@ currently used by buffers."
;;;###autoload (autoload 'ibuffer-filter-by-derived-mode "ibuf-ext")
(define-ibuffer-filter derived-mode
- "Toggle current view to buffers whose major mode inherits from QUALIFIER."
+ "Limit current view to buffers whose major mode inherits from QUALIFIER."
(:description "derived mode"
:reader
(intern
@@ -1153,22 +1262,73 @@ currently used by buffers."
;;;###autoload (autoload 'ibuffer-filter-by-name "ibuf-ext")
(define-ibuffer-filter name
- "Toggle current view to buffers with name matching QUALIFIER."
+ "Limit current view to buffers with name matching QUALIFIER."
(:description "buffer name"
:reader (read-from-minibuffer "Filter by name (regexp): "))
(string-match qualifier (buffer-name buf)))
+;;;###autoload (autoload 'ibuffer-filter-by-starred-name "ibuf-ext")
+(define-ibuffer-filter starred-name
+ "Limit current view to buffers with name beginning and ending
+with *, along with an optional suffix of the form digits or
+<digits>."
+ (:description "starred buffer name"
+ :reader nil)
+ (string-match "\\`\\*[^*]+\\*\\(?:<[[:digit:]]+>\\)?\\'" (buffer-name buf)))
+
;;;###autoload (autoload 'ibuffer-filter-by-filename "ibuf-ext")
(define-ibuffer-filter filename
- "Toggle current view to buffers with filename matching QUALIFIER."
- (:description "filename"
- :reader (read-from-minibuffer "Filter by filename (regexp): "))
+ "Limit current view to buffers with full file name matching QUALIFIER.
+
+For example, for a buffer associated with file '/a/b/c.d', this
+matches against '/a/b/c.d'."
+ (:description "full file name"
+ :reader (read-from-minibuffer "Filter by full file name (regexp): "))
(ibuffer-awhen (with-current-buffer buf (ibuffer-buffer-file-name))
(string-match qualifier it)))
+;;;###autoload (autoload 'ibuffer-filter-by-basename "ibuf-ext")
+(define-ibuffer-filter basename
+ "Limit current view to buffers with file basename matching QUALIFIER.
+
+For example, for a buffer associated with file '/a/b/c.d', this
+matches against 'c.d'."
+ (:description "file basename"
+ :reader (read-from-minibuffer
+ "Filter by file name, without directory part (regex): "))
+ (ibuffer-awhen (with-current-buffer buf (ibuffer-buffer-file-name))
+ (string-match qualifier (file-name-nondirectory it))))
+
+;;;###autoload (autoload 'ibuffer-filter-by-file-extension "ibuf-ext")
+(define-ibuffer-filter file-extension
+ "Limit current view to buffers with filename extension matching QUALIFIER.
+
+The separator character (typically `.') is not part of the
+pattern. For example, for a buffer associated with file
+'/a/b/c.d', this matches against 'd'."
+ (:description "filename extension"
+ :reader (read-from-minibuffer
+ "Filter by filename extension without separator (regex): "))
+ (ibuffer-awhen (with-current-buffer buf (ibuffer-buffer-file-name))
+ (string-match qualifier (or (file-name-extension it) ""))))
+
+;;;###autoload (autoload 'ibuffer-filter-by-directory "ibuf-ext")
+(define-ibuffer-filter directory
+ "Limit current view to buffers with directory matching QUALIFIER.
+
+For a buffer associated with file '/a/b/c.d', this matches
+against '/a/b'. For a buffer not associated with a file, this
+matches against the value of `default-directory' in that buffer."
+ (:description "directory name"
+ :reader (read-from-minibuffer "Filter by directory name (regex): "))
+ (ibuffer-aif (with-current-buffer buf (ibuffer-buffer-file-name))
+ (let ((dirname (file-name-directory it)))
+ (when dirname (string-match qualifier dirname)))
+ (when default-directory (string-match qualifier default-directory))))
+
;;;###autoload (autoload 'ibuffer-filter-by-size-gt "ibuf-ext")
(define-ibuffer-filter size-gt
- "Toggle current view to buffers with size greater than QUALIFIER."
+ "Limit current view to buffers with size greater than QUALIFIER."
(:description "size greater than"
:reader
(string-to-number (read-from-minibuffer "Filter by size greater than: ")))
@@ -1177,16 +1337,30 @@ currently used by buffers."
;;;###autoload (autoload 'ibuffer-filter-by-size-lt "ibuf-ext")
(define-ibuffer-filter size-lt
- "Toggle current view to buffers with size less than QUALIFIER."
+ "Limit current view to buffers with size less than QUALIFIER."
(:description "size less than"
:reader
(string-to-number (read-from-minibuffer "Filter by size less than: ")))
(< (with-current-buffer buf (buffer-size))
qualifier))
+;;;###autoload (autoload 'ibuffer-filter-by-modified "ibuf-ext")
+(define-ibuffer-filter modified
+ "Limit current view to buffers that are marked as modified."
+ (:description "modified"
+ :reader nil)
+ (buffer-modified-p buf))
+
+;;;###autoload (autoload 'ibuffer-filter-by-visiting-file "ibuf-ext")
+(define-ibuffer-filter visiting-file
+ "Limit current view to buffers that are visiting a file."
+ (:description "visiting a file"
+ :reader nil)
+ (with-current-buffer buf (buffer-file-name)))
+
;;;###autoload (autoload 'ibuffer-filter-by-content "ibuf-ext")
(define-ibuffer-filter content
- "Toggle current view to buffers whose contents match QUALIFIER."
+ "Limit current view to buffers whose contents match QUALIFIER."
(:description "content"
:reader (read-from-minibuffer "Filter by content (regexp): "))
(with-current-buffer buf
@@ -1196,12 +1370,33 @@ currently used by buffers."
;;;###autoload (autoload 'ibuffer-filter-by-predicate "ibuf-ext")
(define-ibuffer-filter predicate
- "Toggle current view to buffers for which QUALIFIER returns non-nil."
+ "Limit current view to buffers for which QUALIFIER returns non-nil."
(:description "predicate"
:reader (read-minibuffer "Filter by predicate (form): "))
(with-current-buffer buf
(eval qualifier)))
+;;;###autoload (autoload 'ibuffer-filter-chosen-by-completion "ibuf-ext")
+(defun ibuffer-filter-chosen-by-completion ()
+ "Select and apply filter chosen by completion against available filters.
+Indicates corresponding key sequences in echo area after filtering.
+
+The completion matches against the filter description text of
+each filter in `ibuffer-filtering-alist'."
+ (interactive)
+ (let* ((filters (mapcar (lambda (x) (cons (cadr x) (car x)))
+ ibuffer-filtering-alist))
+ (match (completing-read "Filter by: " filters nil t))
+ (filter (cdr (assoc match filters)))
+ (command (intern (concat "ibuffer-filter-by-" (symbol-name filter)))))
+ (call-interactively command)
+ (message "%s can be run with key sequences: %s"
+ command
+ (mapconcat #'key-description
+ (where-is-internal command ibuffer-mode-map nil t)
+ "or "))))
+
+
;;; Sorting
;;;###autoload
diff --git a/lisp/ibuf-macs.el b/lisp/ibuf-macs.el
index 3c95f4c..fc8c127 100644
--- a/lisp/ibuf-macs.el
+++ b/lisp/ibuf-macs.el
@@ -304,7 +304,7 @@ bound to the current value of the filter.
(push (list ',name ,description
(lambda (buf qualifier)
(condition-case nil
- ,@body
+ (progn ,@body)
(error (ibuffer-pop-filter)
(when (eq ',name 'predicate)
(error "Wrong filter predicate: %S"
diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el
index 94cee32..5a74084 100644
--- a/lisp/ibuffer.el
+++ b/lisp/ibuffer.el
@@ -518,26 +518,37 @@ directory, like `default-directory'."
(define-key map (kbd "s f") 'ibuffer-do-sort-by-filename/process)
(define-key map (kbd "s m") 'ibuffer-do-sort-by-major-mode)
+ (define-key map (kbd "/ RET") 'ibuffer-filter-by-mode)
(define-key map (kbd "/ m") 'ibuffer-filter-by-used-mode)
(define-key map (kbd "/ M") 'ibuffer-filter-by-derived-mode)
(define-key map (kbd "/ n") 'ibuffer-filter-by-name)
- (define-key map (kbd "/ c") 'ibuffer-filter-by-content)
- (define-key map (kbd "/ e") 'ibuffer-filter-by-predicate)
+ (define-key map (kbd "/ *") 'ibuffer-filter-by-starred-name)
(define-key map (kbd "/ f") 'ibuffer-filter-by-filename)
- (define-key map (kbd "/ >") 'ibuffer-filter-by-size-gt)
+ (define-key map (kbd "/ b") 'ibuffer-filter-by-basename)
+ (define-key map (kbd "/ .") 'ibuffer-filter-by-file-extension)
(define-key map (kbd "/ <") 'ibuffer-filter-by-size-lt)
+ (define-key map (kbd "/ >") 'ibuffer-filter-by-size-gt)
+ (define-key map (kbd "/ i") 'ibuffer-filter-by-modified)
+ (define-key map (kbd "/ v") 'ibuffer-filter-by-visiting-file)
+ (define-key map (kbd "/ c") 'ibuffer-filter-by-content)
+ (define-key map (kbd "/ e") 'ibuffer-filter-by-predicate)
+
(define-key map (kbd "/ r") 'ibuffer-switch-to-saved-filters)
(define-key map (kbd "/ a") 'ibuffer-add-saved-filters)
(define-key map (kbd "/ x") 'ibuffer-delete-saved-filters)
(define-key map (kbd "/ d") 'ibuffer-decompose-filter)
(define-key map (kbd "/ s") 'ibuffer-save-filters)
(define-key map (kbd "/ p") 'ibuffer-pop-filter)
+ (define-key map (kbd "/ <up>") 'ibuffer-pop-filter)
(define-key map (kbd "/ !") 'ibuffer-negate-filter)
(define-key map (kbd "/ t") 'ibuffer-exchange-filters)
(define-key map (kbd "/ TAB") 'ibuffer-exchange-filters)
(define-key map (kbd "/ o") 'ibuffer-or-filter)
+ (define-key map (kbd "/ |") 'ibuffer-or-filter)
+ (define-key map (kbd "/ &") 'ibuffer-and-filter)
(define-key map (kbd "/ g") 'ibuffer-filters-to-filter-group)
(define-key map (kbd "/ P") 'ibuffer-pop-filter-group)
+ (define-key map (kbd "/ S-<up>") 'ibuffer-pop-filter-group)
(define-key map (kbd "/ D") 'ibuffer-decompose-filter-group)
(define-key map (kbd "/ /") 'ibuffer-filter-disable)
@@ -657,13 +668,43 @@ directory, like `default-directory'."
ibuffer-filter-by-derived-mode))
(define-key-after map [menu-bar view filter filter-by-name]
'(menu-item "Add filter by buffer name..." ibuffer-filter-by-name))
+ (define-key-after map [menu-bar view filter filter-by-starred-name]
+ '(menu-item "Add filter by starred buffer name..."
+ ibuffer-filter-by-starred-name
+ :help "List buffers whose names begin with a star"))
(define-key-after map [menu-bar view filter filter-by-filename]
- '(menu-item "Add filter by filename..." ibuffer-filter-by-filename))
+ '(menu-item "Add filter by full filename..." ibuffer-filter-by-filename
+ :help
+ (concat "For a buffer associated with file '/a/b/c.d', "
+ "list buffer if a given pattern matches
'/a/b/c.d'")))
+ (define-key-after map [menu-bar view filter filter-by-basename]
+ '(menu-item "Add filter by file basename..."
+ ibuffer-filter-by-basename
+ :help (concat "For a buffer associated with file '/a/b/c.d',
"
+ "list buffer if a given pattern matches
'c.d'")))
+ (define-key-after map [menu-bar view filter filter-by-file-extension]
+ '(menu-item "Add filter by file name extension..."
+ ibuffer-filter-by-file-extension
+ :help (concat "For a buffer associated with file '/a/b/c.d',
"
+ "list buffer if a given pattern matches 'd'")))
+ (define-key-after map [menu-bar view filter filter-by-directory]
+ '(menu-item "Add filter by filename's directory..."
+ ibuffer-filter-by-directory
+ :help
+ (concat "For a buffer associated with file '/a/b/c.d', "
+ "list buffer if a given pattern matches '/a/b'")))
(define-key-after map [menu-bar view filter filter-by-size-lt]
'(menu-item "Add filter by size less than..." ibuffer-filter-by-size-lt))
(define-key-after map [menu-bar view filter filter-by-size-gt]
'(menu-item "Add filter by size greater than..."
ibuffer-filter-by-size-gt))
+ (define-key-after map [menu-bar view filter filter-by-modified]
+ '(menu-item "Add filter by modified buffer" ibuffer-filter-by-modified
+ :help "List buffers that are marked as modified"))
+ (define-key-after map [menu-bar view filter filter-by-visiting-file]
+ '(menu-item "Add filter by buffer visiting a file"
+ ibuffer-filter-by-visiting-file
+ :help "List buffers that are visiting files"))
(define-key-after map [menu-bar view filter filter-by-content]
'(menu-item "Add filter by content (regexp)..."
ibuffer-filter-by-content))
@@ -673,6 +714,12 @@ directory, like `default-directory'."
(define-key-after map [menu-bar view filter pop-filter]
'(menu-item "Remove top filter" ibuffer-pop-filter
:enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers)))
+ (define-key-after map [menu-bar view filter and-filter]
+ '(menu-item "AND top two filters" ibuffer-and-filter
+ :enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers
+ (cdr ibuffer-filtering-qualifiers))
+ :help
+ "Create a new filter which is the logical AND of the top two filters"))
(define-key-after map [menu-bar view filter or-filter]
'(menu-item "OR top two filters" ibuffer-or-filter
:enable (and (featurep 'ibuf-ext) ibuffer-filtering-qualifiers
diff --git a/lisp/ido.el b/lisp/ido.el
index 9df89c9..7b9cf07 100644
--- a/lisp/ido.el
+++ b/lisp/ido.el
@@ -3505,7 +3505,7 @@ This is to make them appear as if they were \"virtual
buffers\"."
(when (equal name "")
(setq name head))
(and (not (equal name ""))
- (null (get-file-buffer head))
+ (null (let (file-name-handler-alist) (get-file-buffer head)))
(not (assoc name ido-virtual-buffers))
(not (member name ido-temp-list))
(not (ido-ignore-item-p name ido-ignore-buffers))
diff --git a/lisp/image-dired.el b/lisp/image-dired.el
index 7978f07..2af72fc 100644
--- a/lisp/image-dired.el
+++ b/lisp/image-dired.el
@@ -1,4 +1,4 @@
-;;; image-dired.el --- use dired to browse and manipulate your images
+;;; image-dired.el --- use dired to browse and manipulate your images -*-
lexical-binding: t -*-
;;
;; Copyright (C) 2005-2016 Free Software Foundation, Inc.
;;
@@ -79,7 +79,7 @@
;;
;; This information has been moved to the manual. Type `C-h r' to open
;; the Emacs manual and go to the node Thumbnails by typing `g
-;; Thumbnails RET'.
+;; Image-Dired RET'.
;;
;; Quickstart: M-x image-dired RET DIRNAME RET
;;
@@ -118,8 +118,6 @@
;; * From thumbs.el: Add the "modify" commands (emboss, negate,
;; monochrome etc).
;;
-;; * Asynchronous creation of thumbnails.
-;;
;; * Add `image-dired-display-thumbs-ring' and functions to cycle that. Find
;; out which is best, saving old batch just before inserting new, or
;; saving the current batch in the ring when inserting it. Adding it
@@ -151,6 +149,7 @@
(require 'dired)
(require 'format-spec)
+(require 'image-mode)
(require 'widget)
(eval-when-compile
@@ -160,11 +159,12 @@
(defgroup image-dired nil
"Use dired to browse your images as thumbnails, and more."
:prefix "image-dired-"
+ :link '(info-link "(emacs) Image-Dired")
:group 'multimedia)
(defcustom image-dired-dir (locate-user-emacs-file "image-dired/")
"Directory where thumbnail images are stored."
- :type 'string
+ :type 'directory
:group 'image-dired)
(defcustom image-dired-thumbnail-storage 'use-image-dired-dir
@@ -178,21 +178,22 @@ means that each thumbnail is stored in a subdirectory
called
stored and generated according to the Thumbnail Managing Standard
that allows sharing of thumbnails across different programs."
:type '(choice :tag "How to store thumbnail files"
- (const :tag "Thumbnail Managing Standard" standard)
(const :tag "Use image-dired-dir" use-image-dired-dir)
+ (const :tag "Thumbnail Managing Standard (normal 128x128)"
standard)
+ (const :tag "Thumbnail Managing Standard (large 256x256)"
standard-large)
(const :tag "Per-directory" per-directory))
:group 'image-dired)
(defcustom image-dired-db-file
(expand-file-name ".image-dired_db" image-dired-dir)
"Database file where file names and their associated tags are stored."
- :type 'string
+ :type 'file
:group 'image-dired)
(defcustom image-dired-temp-image-file
(expand-file-name ".image-dired_temp" image-dired-dir)
"Name of temporary image file used by various commands."
- :type 'string
+ :type 'file
:group 'image-dired)
(defcustom image-dired-gallery-dir
@@ -200,7 +201,7 @@ that allows sharing of thumbnails across different
programs."
"Directory to store generated gallery html pages.
This path needs to be \"shared\" to the public so that it can access
the index.html page that image-dired creates."
- :type 'string
+ :type 'directory
:group 'image-dired)
(defcustom image-dired-gallery-image-root-url
@@ -223,127 +224,157 @@ expects to find pictures in this directory."
"convert"
"Executable used to create thumbnail.
Used together with `image-dired-cmd-create-thumbnail-options'."
- :type 'string
+ :type 'file
:group 'image-dired)
(defcustom image-dired-cmd-create-thumbnail-options
- "%p -size %wx%h \"%f\" -resize \"%wx%h>\" -strip jpeg:\"%t\""
- "Format of command used to create thumbnail image.
-Available options are %p which is replaced by
-`image-dired-cmd-create-thumbnail-program', %w which is replaced by
+ '("-size" "%wx%h" "%f" "-resize" "%wx%h>" "-strip" "jpeg:%t")
+ "Options of command used to create thumbnail image.
+Used with `image-dired-cmd-create-thumbnail-program'.
+Available format specifiers are: %w which is replaced by
`image-dired-thumb-width', %h which is replaced by `image-dired-thumb-height',
%f which is replaced by the file name of the original image and %t
which is replaced by the file name of the thumbnail file."
- :type 'string
+ :version "26.1"
+ :type '(repeat (string :tag "Argument"))
:group 'image-dired)
-(defcustom image-dired-cmd-create-temp-image-program
- "convert"
+(defcustom image-dired-cmd-create-temp-image-program "convert"
"Executable used to create temporary image.
Used together with `image-dired-cmd-create-temp-image-options'."
- :type 'string
+ :type 'file
:group 'image-dired)
(defcustom image-dired-cmd-create-temp-image-options
- "%p -size %wx%h \"%f\" -resize \"%wx%h>\" -strip jpeg:\"%t\""
- "Format of command used to create temporary image for display window.
-Available options are %p which is replaced by
-`image-dired-cmd-create-temp-image-program', %w and %h which is replaced by
+ '("-size" "%wx%h" "%f" "-resize" "%wx%h>" "-strip" "jpeg:%t")
+ "Options of command used to create temporary image for display window.
+Used together with `image-dired-cmd-create-temp-image-program',
+Available format specifiers are: %w and %h which are replaced by
the calculated max size for width and height in the image display window,
%f which is replaced by the file name of the original image and %t which
is replaced by the file name of the temporary file."
- :type 'string
+ :version "26.1"
+ :type '(repeat (string :tag "Argument"))
:group 'image-dired)
-(defcustom image-dired-cmd-pngnq-program (executable-find "pngnq")
+(defcustom image-dired-cmd-pngnq-program
+ (or (executable-find "pngnq")
+ (executable-find "pngnq-s9"))
"The file name of the `pngnq' program.
-It quantizes colors of PNG images down to 256 colors."
- :type '(choice (const :tag "Not Set" nil) string)
+It quantizes colors of PNG images down to 256 colors or fewer
+using the NeuQuant algorithm."
+ :version "26.1"
+ :type '(choice (const :tag "Not Set" nil) file)
+ :group 'image-dired)
+
+(defcustom image-dired-cmd-pngnq-options
+ '("-f" "%t")
+ "Arguments to pass `image-dired-cmd-pngnq-program'.
+Available format specifiers are the same as in
+`image-dired-cmd-create-thumbnail-options'."
+ :version "26.1"
+ :type '(repeat (string :tag "Argument"))
:group 'image-dired)
(defcustom image-dired-cmd-pngcrush-program (executable-find "pngcrush")
"The file name of the `pngcrush' program.
It optimizes the compression of PNG images. Also it adds PNG textual chunks
with the information required by the Thumbnail Managing Standard."
- :type '(choice (const :tag "Not Set" nil) string)
+ :type '(choice (const :tag "Not Set" nil) file)
:group 'image-dired)
-(defcustom image-dired-cmd-create-standard-thumbnail-command
- (concat
- "%p -size %wx%h \"%f\" "
- (unless (or image-dired-cmd-pngcrush-program image-dired-cmd-pngnq-program)
- (concat
- "-set \"Thumb::MTime\" \"%m\" "
- "-set \"Thumb::URI\" \"file://%f\" "
- "-set \"Description\" \"Thumbnail of file://%f\" "
- "-set \"Software\" \"" (emacs-version) "\" "))
- "-thumbnail \"%wx%h>\" png:\"%t\""
- (if image-dired-cmd-pngnq-program
- (concat
- " ; " image-dired-cmd-pngnq-program " -f \"%t\""
- (unless image-dired-cmd-pngcrush-program
- " ; mv %q %t")))
- (if image-dired-cmd-pngcrush-program
- (concat
- (unless image-dired-cmd-pngcrush-program
- " ; cp %t %q")
- " ; " image-dired-cmd-pngcrush-program " -q "
- "-text b \"Description\" \"Thumbnail of file://%f\" "
- "-text b \"Software\" \"" (emacs-version) "\" "
- ;; "-text b \"Thumb::Image::Height\" \"%oh\" "
- ;; "-text b \"Thumb::Image::Mimetype\" \"%mime\" "
- ;; "-text b \"Thumb::Image::Width\" \"%ow\" "
- "-text b \"Thumb::MTime\" \"%m\" "
- ;; "-text b \"Thumb::Size\" \"%b\" "
- "-text b \"Thumb::URI\" \"file://%f\" "
- "%q %t"
- " ; rm %q")))
- "Command to create thumbnails according to the Thumbnail Managing Standard."
+(defcustom image-dired-cmd-pngcrush-options
+ `("-q"
+ "-text" "b" "Description" "Thumbnail of file://%f"
+ "-text" "b" "Software" ,(emacs-version)
+ ;; "-text b \"Thumb::Image::Height\" \"%oh\" "
+ ;; "-text b \"Thumb::Image::Mimetype\" \"%mime\" "
+ ;; "-text b \"Thumb::Image::Width\" \"%ow\" "
+ "-text" "b" "Thumb::MTime" "%m"
+ ;; "-text b \"Thumb::Size\" \"%b\" "
+ "-text" "b" "Thumb::URI" "file://%f"
+ "%q" "%t")
+ "Arguments for `image-dired-cmd-pngcrush-program'.
+Available format specifiers are the same as in
+`image-dired-cmd-create-thumbnail-options', with %q for a
+temporary file name (typically generated by pnqnq)"
:version "26.1"
- :type 'string
+ :type '(repeat (string :tag "Argument"))
+ :group 'image-dired)
+
+(defcustom image-dired-cmd-optipng-program (executable-find "optipng")
+ "The file name of the `optipng' program."
+ :type '(choice (const :tag "Not Set" nil) file)
+ :group 'image-dired)
+
+(defcustom image-dired-cmd-optipng-options '("-o5" "%t")
+ "Arguments passed to `image-dired-optipng-program'.
+Available format specifiers are described in
+`image-dired-cmd-create-thumbnail-options'."
+ :type '(repeat (string :tag "Argument"))
+ :link '(url-link "man:optipng(1)")
+ :group 'image-dired)
+
+(defcustom image-dired-cmd-create-standard-thumbnail-options
+ (append '("-size" "%wx%h" "%f")
+ (unless (or image-dired-cmd-pngcrush-program
+ image-dired-cmd-pngnq-program)
+ (list
+ "-set" "Thumb::MTime" "%m"
+ "-set" "Thumb::URI" "file://%f"
+ "-set" "Description" "Thumbnail of file://%f"
+ "-set" "Software" (emacs-version)))
+ '("-thumbnail" "%wx%h>" "png:%t"))
+ "Options for creating thumbnails according to the Thumbnail Managing
Standard.
+Available format specifiers are the same as in
+`image-dired-cmd-create-thumbnail-options', with %m for file modification
time."
+ :version "26.1"
+ :type '(repeat (string :tag "Argument"))
:group 'image-dired)
(defcustom image-dired-cmd-rotate-thumbnail-program
"mogrify"
"Executable used to rotate thumbnail.
Used together with `image-dired-cmd-rotate-thumbnail-options'."
- :type 'string
+ :type 'file
:group 'image-dired)
(defcustom image-dired-cmd-rotate-thumbnail-options
- "%p -rotate %d \"%t\""
- "Format of command used to rotate thumbnail image.
-Available options are %p which is replaced by
-`image-dired-cmd-rotate-thumbnail-program', %d which is replaced by the
+ '("-rotate" "%d" "%t")
+ "Arguments of command used to rotate thumbnail image.
+Used with `image-dired-cmd-rotate-thumbnail-program'.
+Available format specifiers are: %d which is replaced by the
number of (positive) degrees to rotate the image, normally 90 or 270
\(for 90 degrees right and left), %t which is replaced by the file name
of the thumbnail file."
- :type 'string
+ :version "26.1"
+ :type '(repeat (string :tag "Argument"))
:group 'image-dired)
(defcustom image-dired-cmd-rotate-original-program
"jpegtran"
"Executable used to rotate original image.
Used together with `image-dired-cmd-rotate-original-options'."
- :type 'string
+ :type 'file
:group 'image-dired)
(defcustom image-dired-cmd-rotate-original-options
- "%p -rotate %d -copy all -outfile %t \"%o\""
- "Format of command used to rotate original image.
-Available options are %p which is replaced by
-`image-dired-cmd-rotate-original-program', %d which is replaced by the
+ '("-rotate" "%d" "-copy" "all" "-outfile" "%t" "%o")
+ "Arguments of command used to rotate original image.
+Used with `image-dired-cmd-rotate-original-program'.
+Available format specifiers are: %d which is replaced by the
number of (positive) degrees to rotate the image, normally 90 or
270 \(for 90 degrees right and left), %o which is replaced by the
original image file name and %t which is replaced by
`image-dired-temp-image-file'."
- :type 'string
+ :version "26.1"
+ :type '(repeat (string :tag "Argument"))
:group 'image-dired)
(defcustom image-dired-temp-rotate-image-file
(expand-file-name ".image-dired_rotate_temp" image-dired-dir)
"Temporary file for rotate operations."
- :type 'string
+ :type 'file
:group 'image-dired)
(defcustom image-dired-rotate-original-ask-before-overwrite t
@@ -357,33 +388,35 @@ original file with `image-dired-temp-rotate-image-file'."
"exiftool"
"Program used to write EXIF data to image.
Used together with `image-dired-cmd-write-exif-data-options'."
- :type 'string
+ :type 'file
:group 'image-dired)
(defcustom image-dired-cmd-write-exif-data-options
- "%p -%t=\"%v\" \"%f\""
- "Format of command used to write EXIF data.
-Available options are %p which is replaced by
-`image-dired-cmd-write-exif-data-program', %f which is replaced by
+ '("-%t=%v" "%f")
+ "Arguments of command used to write EXIF data.
+Used with `image-dired-cmd-write-exif-data-program'.
+Available format specifiers are: %f which is replaced by
the image file name, %t which is replaced by the tag name and %v
which is replaced by the tag value."
- :type 'string
+ :version "26.1"
+ :type '(repeat (string :tag "Argument"))
:group 'image-dired)
(defcustom image-dired-cmd-read-exif-data-program
"exiftool"
"Program used to read EXIF data to image.
-Used together with `image-dired-cmd-read-exif-data-program-options'."
- :type 'string
+Used together with `image-dired-cmd-read-exif-data-options'."
+ :type 'file
:group 'image-dired)
(defcustom image-dired-cmd-read-exif-data-options
- "%p -s -s -s -%t \"%f\""
- "Format of command used to read EXIF data.
-Available options are %p which is replaced by
-`image-dired-cmd-write-exif-data-program', %f which is replaced
+ '("-s" "-s" "-s" "-%t" "%f")
+ "Arguments of command used to read EXIF data.
+Used with `image-dired-cmd-read-exif-data-program'.
+Available format specifiers are: %f which is replaced
by the image file name and %t which is replaced by the tag name."
- :type 'string
+ :version "26.1"
+ :type '(repeat (string :tag "Argument"))
:group 'image-dired)
(defcustom image-dired-gallery-hidden-tags
@@ -393,7 +426,11 @@ Used by `image-dired-gallery-generate' to leave out
\"hidden\" images."
:type '(repeat string)
:group 'image-dired)
-(defcustom image-dired-thumb-size (if (eq 'standard
image-dired-thumbnail-storage) 128 100)
+(defcustom image-dired-thumb-size
+ (cond
+ ((eq 'standard image-dired-thumbnail-storage) 128)
+ ((eq 'standard-large image-dired-thumbnail-storage) 256)
+ (t 100))
"Size of thumbnails, in pixels.
This is the default size for both `image-dired-thumb-width'
and `image-dired-thumb-height'."
@@ -516,6 +553,7 @@ before warning the user."
(defmacro image-dired--with-db-file (&rest body)
"Run BODY in a temp buffer containing `image-dired-db-file'.
Return the last form in BODY."
+ (declare (indent 0) (debug t))
`(with-temp-buffer
(if (file-exists-p image-dired-db-file)
(insert-file-contents image-dired-db-file))
@@ -533,7 +571,6 @@ Create the thumbnails directory if it does not exist."
(defun image-dired-insert-image (file type relief margin)
"Insert image FILE of image TYPE, using RELIEF and MARGIN, at point."
-
(let ((i `(image :type ,type
:file ,file
:relief ,relief
@@ -563,7 +600,8 @@ Add text properties ORIGINAL-FILE-NAME and
ASSOCIATED-DIRED-BUFFER."
(setq beg (point))
(image-dired-insert-image file
;; TODO: this should depend on the real file type
- (if (eq 'standard image-dired-thumbnail-storage)
+ (if (memq image-dired-thumbnail-storage
+ '(standard standard-large))
'png 'jpeg)
image-dired-thumb-relief
image-dired-thumb-margin)
@@ -585,10 +623,16 @@ MD5-hash of the image file's directory name and add that
to make
the thumbnail file name unique. For per-directory storage, just
add a subdirectory. For standard storage, produce the file name
according to the Thumbnail Managing Standard."
- (cond ((eq 'standard image-dired-thumbnail-storage)
- (expand-file-name
- (concat "~/.thumbnails/normal/"
- (md5 (concat "file://" (expand-file-name file))) ".png")))
+ (cond ((memq image-dired-thumbnail-storage '(standard standard-large))
+ (let* ((xdg (getenv "XDG_CACHE_HOME"))
+ (dir (if (and xdg (file-name-absolute-p xdg))
+ xdg "~/.cache"))
+ (thumbdir (cl-case image-dired-thumbnail-storage
+ (standard "thumbnails/normal")
+ (standard-large "thumbnails/large"))))
+ (expand-file-name
+ (concat (md5 (concat "file://" (expand-file-name file))) ".png")
+ (expand-file-name thumbdir dir))))
((eq 'use-image-dired-dir image-dired-thumbnail-storage)
(let* ((f (expand-file-name file))
(md5-hash
@@ -613,35 +657,169 @@ according to the Thumbnail Managing Standard."
(unless (executable-find (symbol-value executable))
(error "Executable %S not found" executable)))
-(defun image-dired-create-thumb (original-file thumbnail-file)
+(defun image-dired-thumb-size (dimension)
+ "Return thumb size depending on `image-dired-thumbnail-storage'.
+DIMENSION should be either the symbol 'width or 'height."
+ (cond
+ ((eq 'standard image-dired-thumbnail-storage) 128)
+ ((eq 'standard-large image-dired-thumbnail-storage) 256)
+ (t (cl-ecase dimension
+ (width image-dired-thumb-width)
+ (height image-dired-thumb-height)))))
+
+(defvar image-dired-queue nil
+ "List of items in the queue.
+Each item has the form (ORIGINAL-FILE TARGET-FILE).")
+
+(defvar image-dired-queue-active-jobs 0
+ "Number of active jobs in `image-dired-queue'.")
+
+(defvar image-dired-queue-active-limit 2
+ "Maximum number of concurrent jobs permitted for generating images.
+Increase at own risk.")
+
+(defun image-dired-pngnq-thumb (spec)
+ "Quantize thumbnail described by format SPEC with pngnq(1)."
+ (let ((process
+ (apply #'start-process "image-dired-pngnq" nil
+ image-dired-cmd-pngnq-program
+ (mapcar (lambda (arg) (format-spec arg spec))
+ image-dired-cmd-pngnq-options))))
+ (setf (process-sentinel process)
+ (lambda (process status)
+ (if (and (eq (process-status process) 'exit)
+ (zerop (process-exit-status process)))
+ ;; Pass off to pngcrush, or just rename the
+ ;; THUMB-nq8.png file back to THUMB.png
+ (if (and image-dired-cmd-pngcrush-program
+ (executable-find image-dired-cmd-pngcrush-program))
+ (image-dired-pngcrush-thumb spec)
+ (let ((nq8 (cdr (assq ?q spec)))
+ (thumb (cdr (assq ?t spec))))
+ (rename-file nq8 thumb t)))
+ (message "command %S %s" (process-command process)
+ (replace-regexp-in-string "\n" "" status)))))
+ process))
+
+(defun image-dired-pngcrush-thumb (spec)
+ "Optimize thumbnail described by format SPEC with pngcrush(1)."
+ ;; If pngnq wasn't run, then the THUMB-nq8.png file does not exist.
+ ;; pngcrush needs an infile and outfile, so we just copy THUMB to
+ ;; THUMB-nq8.png and use the latter as a temp file.
+ (when (not image-dired-cmd-pngnq-program)
+ (let ((temp (cdr (assq ?q spec)))
+ (thumb (cdr (assq ?t spec))))
+ (copy-file thumb temp)))
+ (let ((process
+ (apply #'start-process "image-dired-pngcrush" nil
+ image-dired-cmd-pngcrush-program
+ (mapcar (lambda (arg) (format-spec arg spec))
+ image-dired-cmd-pngcrush-options))))
+ (setf (process-sentinel process)
+ (lambda (process status)
+ (unless (and (eq (process-status process) 'exit)
+ (zerop (process-exit-status process)))
+ (message "command %S %s" (process-command process)
+ (replace-regexp-in-string "\n" "" status)))
+ (when (memq (process-status process) '(exit signal))
+ (let ((temp (cdr (assq ?q spec))))
+ (delete-file temp)))))
+ process))
+
+(defun image-dired-optipng-thumb (spec)
+ "Optimize thumbnail described by format SPEC with optipng(1)."
+ (let ((process
+ (apply #'start-process "image-dired-optipng" nil
+ image-dired-cmd-optipng-program
+ (mapcar (lambda (arg) (format-spec arg spec))
+ image-dired-cmd-optipng-options))))
+ (setf (process-sentinel process)
+ (lambda (process status)
+ (unless (and (eq (process-status process) 'exit)
+ (zerop (process-exit-status process)))
+ (message "command %S %s" (process-command process)
+ (replace-regexp-in-string "\n" "" status)))))
+ process))
+
+(defun image-dired-create-thumb-1 (original-file thumbnail-file)
"For ORIGINAL-FILE, create thumbnail image named THUMBNAIL-FILE."
(image-dired--check-executable-exists
'image-dired-cmd-create-thumbnail-program)
- (let* ((width (int-to-string image-dired-thumb-width))
- (height (int-to-string image-dired-thumb-height))
- (modif-time (format "%.0f" (float-time (nth 5 (file-attributes
- original-file)))))
+ (let* ((width (int-to-string (image-dired-thumb-size 'width)))
+ (height (int-to-string (image-dired-thumb-size 'height)))
+ (modif-time (floor (float-time (nth 5 (file-attributes
original-file)))))
(thumbnail-nq8-file (replace-regexp-in-string ".png\\'" "-nq8.png"
thumbnail-file))
- (command
- (format-spec
- (if (eq 'standard image-dired-thumbnail-storage)
- image-dired-cmd-create-standard-thumbnail-command
- image-dired-cmd-create-thumbnail-options)
- (list
- (cons ?p image-dired-cmd-create-thumbnail-program)
- (cons ?w width)
- (cons ?h height)
- (cons ?m modif-time)
- (cons ?f original-file)
- (cons ?q thumbnail-nq8-file)
- (cons ?t thumbnail-file))))
- thumbnail-dir)
- (when (not (file-exists-p
- (setq thumbnail-dir (file-name-directory thumbnail-file))))
- (message "Creating thumbnail directory.")
- (make-directory thumbnail-dir))
- (call-process shell-file-name nil nil nil shell-command-switch command)))
+ (spec
+ (list
+ (cons ?w width)
+ (cons ?h height)
+ (cons ?m modif-time)
+ (cons ?f original-file)
+ (cons ?q thumbnail-nq8-file)
+ (cons ?t thumbnail-file)))
+ (thumbnail-dir (file-name-directory thumbnail-file))
+ process)
+ (when (not (file-exists-p thumbnail-dir))
+ (message "Creating thumbnail directory")
+ (make-directory thumbnail-dir t)
+ (set-file-modes thumbnail-dir #o700))
+
+ ;; Thumbnail file creation processes begin here and are marshaled
+ ;; in a queue by `image-dired-create-thumb'.
+ (setq process
+ (apply #'start-process "image-dired-create-thumbnail" nil
+ image-dired-cmd-create-thumbnail-program
+ (mapcar
+ (lambda (arg) (format-spec arg spec))
+ (if (memq image-dired-thumbnail-storage
+ '(standard standard-large))
+ image-dired-cmd-create-standard-thumbnail-options
+ image-dired-cmd-create-thumbnail-options))))
+
+ (setf (process-sentinel process)
+ (lambda (process status)
+ ;; Trigger next in queue once a thumbnail has been created
+ (cl-decf image-dired-queue-active-jobs)
+ (image-dired-thumb-queue-run)
+ (if (not (and (eq (process-status process) 'exit)
+ (zerop (process-exit-status process))))
+ (message "Thumb could not be created for %s: %s"
+ (abbreviate-file-name original-file)
+ (replace-regexp-in-string "\n" "" status))
+ (set-file-modes thumbnail-file #o600)
+ (clear-image-cache thumbnail-file)
+ ;; PNG thumbnail has been created since we are
+ ;; following the XDG thumbnail spec, so try to optimize
+ (when (memq image-dired-thumbnail-storage
+ '(standard standard-large))
+ (cond
+ ((and image-dired-cmd-pngnq-program
+ (executable-find image-dired-cmd-pngnq-program))
+ (image-dired-pngnq-thumb spec))
+ ((and image-dired-cmd-pngcrush-program
+ (executable-find image-dired-cmd-pngcrush-program))
+ (image-dired-pngcrush-thumb spec))
+ ((and image-dired-cmd-optipng-program
+ (executable-find image-dired-cmd-optipng-program))
+ (image-dired-optipng-thumb spec)))))))
+ process))
+
+(defun image-dired-thumb-queue-run ()
+ "Run a queued job if one exists and not too many jobs are running.
+Queued items live in `image-dired-queue'."
+ (while (and image-dired-queue
+ (< image-dired-queue-active-jobs
+ image-dired-queue-active-limit))
+ (cl-incf image-dired-queue-active-jobs)
+ (apply #'image-dired-create-thumb-1 (pop image-dired-queue))))
+
+(defun image-dired-create-thumb (original-file thumbnail-file)
+ "Add a job for generating thumbnail to `image-dired-queue'."
+ (setq image-dired-queue
+ (nconc image-dired-queue
+ (list (list original-file thumbnail-file))))
+ (run-at-time 0 nil #'image-dired-thumb-queue-run))
;;;###autoload
(defun image-dired-dired-toggle-marked-thumbs (&optional arg)
@@ -841,10 +1019,9 @@ thumbnail buffer to be selected."
(goto-char (point-max)))
(dolist (curr-file files)
(setq thumb-name (image-dired-thumb-name curr-file))
- (if (and (not (file-exists-p thumb-name))
- (not (= 0 (image-dired-create-thumb curr-file thumb-name))))
- (message "Thumb could not be created for file %s" curr-file)
- (image-dired-insert-thumbnail thumb-name curr-file dired-buf))))
+ (when (not (file-exists-p thumb-name))
+ (image-dired-create-thumb curr-file thumb-name))
+ (image-dired-insert-thumbnail thumb-name curr-file dired-buf)))
(if do-not-pop
(display-buffer buf)
(pop-to-buffer buf))
@@ -1020,6 +1197,12 @@ With prefix argument ARG, remove tag from file at point."
"Get original file name for thumbnail or display image at point."
(get-text-property (point) 'original-file-name))
+(defun image-dired-file-name-at-point ()
+ "Get abbreviated file name for thumbnail or display image at point."
+ (let ((f (image-dired-original-file-name)))
+ (when f
+ (abbreviate-file-name f))))
+
(defun image-dired-associated-dired-buffer ()
"Get associated dired buffer at point."
(get-text-property (point) 'associated-dired-buffer))
@@ -1170,14 +1353,14 @@ image."
(defun image-dired-format-properties-string (buf file props comment)
"Format display properties.
BUF is the associated dired buffer, FILE is the original image file
-name, PROPS is a list of tags and COMMENT is the image file's
+name, PROPS is a stringified list of tags and COMMENT is the image file's
comment."
(format-spec
image-dired-display-properties-format
(list
(cons ?b (or buf ""))
(cons ?f file)
- (cons ?t (or (princ props) ""))
+ (cons ?t (or props ""))
(cons ?c (or comment "")))))
(defun image-dired-display-thumb-properties ()
@@ -1185,11 +1368,9 @@ comment."
(if (not (eobp))
(let ((file-name (file-name-nondirectory
(image-dired-original-file-name)))
(dired-buf (buffer-name (image-dired-associated-dired-buffer)))
- (props (mapconcat
- 'princ
- (get-text-property (point) 'tags)
- ", "))
- (comment (get-text-property (point) 'comment)))
+ (props (mapconcat #'identity (get-text-property (point) 'tags) ",
"))
+ (comment (get-text-property (point) 'comment))
+ (message-log-max nil))
(if file-name
(message "%s"
(image-dired-format-properties-string
@@ -1331,7 +1512,6 @@ You probably want to use this together with
(define-key map " " 'image-dired-display-next-thumbnail-original)
(define-key map (kbd "DEL")
'image-dired-display-previous-thumbnail-original)
(define-key map "c" 'image-dired-comment-thumbnail)
- (define-key map "q" 'image-dired-kill-buffer-and-window)
;; Mouse
(define-key map [mouse-2] 'image-dired-mouse-display-image)
@@ -1348,7 +1528,7 @@ You probably want to use this together with
(easy-menu-define nil map
"Menu for `image-dired-thumbnail-mode'."
'("Image-Dired"
- ["Quit" image-dired-kill-buffer-and-window]
+ ["Quit" quit-window]
["Delete thumbnail from buffer" image-dired-delete-char]
["Remove tag from thumbnail" image-dired-tag-thumbnail-remove]
["Tag thumbnail" image-dired-tag-thumbnail]
@@ -1378,14 +1558,34 @@ You probably want to use this together with
(defvar image-dired-display-image-mode-map
(let ((map (make-sparse-keymap)))
- (define-key map "q" 'image-dired-kill-buffer-and-window)
+ ;; `image-mode-map' has bindings that do not make sense in image-dired
+ ;; (set-keymap-parent map image-mode-map)
(define-key map "f" 'image-dired-display-current-image-full)
(define-key map "s" 'image-dired-display-current-image-sized)
+ (define-key map "g" nil)
+
+ ;; Useful bindings from `image-mode-map'
+ (define-key map [remap forward-char] 'image-forward-hscroll)
+ (define-key map [remap backward-char] 'image-backward-hscroll)
+ (define-key map [remap right-char] 'image-forward-hscroll)
+ (define-key map [remap left-char] 'image-backward-hscroll)
+ (define-key map [remap previous-line] 'image-previous-line)
+ (define-key map [remap next-line] 'image-next-line)
+ (define-key map [remap scroll-up] 'image-scroll-up)
+ (define-key map [remap scroll-down] 'image-scroll-down)
+ (define-key map [remap scroll-up-command] 'image-scroll-up)
+ (define-key map [remap scroll-down-command] 'image-scroll-down)
+ (define-key map [remap scroll-left] 'image-scroll-left)
+ (define-key map [remap scroll-right] 'image-scroll-right)
+ (define-key map [remap move-beginning-of-line] 'image-bol)
+ (define-key map [remap move-end-of-line] 'image-eol)
+ (define-key map [remap beginning-of-buffer] 'image-bob)
+ (define-key map [remap end-of-buffer] 'image-eob)
(easy-menu-define nil map
"Menu for `image-dired-display-image-mode-map'."
'("Image-Dired"
- ["Quit" image-dired-kill-buffer-and-window]
+ ["Quit" quit-window]
["Display original, sized to fit"
image-dired-display-current-image-sized]
["Display original, full size"
image-dired-display-current-image-full]))
map)
@@ -1412,110 +1612,81 @@ You probably want to use this together with
(error "No original file name at point"))))
(define-derived-mode image-dired-thumbnail-mode
- fundamental-mode "image-dired-thumbnail"
+ special-mode "image-dired-thumbnail"
"Browse and manipulate thumbnail images using dired.
-Use `image-dired-dired' and `image-dired-setup-dired-keybindings' to get a
-nice setup to start with."
- (message "image-dired-thumbnail-mode enabled"))
+Use `image-dired-minor-mode' to get a nice setup."
+ :group 'image-dired
+ (buffer-disable-undo)
+ (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil
t))
(define-derived-mode image-dired-display-image-mode
- fundamental-mode "image-dired-image-display"
+ special-mode "image-dired-image-display"
"Mode for displaying and manipulating original image.
Resized or in full-size."
- (message "image-dired-display-image-mode enabled"))
+ :group 'image-dired
+ (buffer-disable-undo)
+ (image-mode-setup-winprops)
+ (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil
t))
+
+(defvar image-dired-minor-mode-map
+ (let ((map (make-sparse-keymap)))
+ ;; (set-keymap-parent map dired-mode-map)
+ ;; Hijack previous and next line movement. Let C-p and C-b be
+ ;; though...
+ (define-key map "p" 'image-dired-dired-previous-line)
+ (define-key map "n" 'image-dired-dired-next-line)
+ (define-key map [up] 'image-dired-dired-previous-line)
+ (define-key map [down] 'image-dired-dired-next-line)
+
+ (define-key map (kbd "C-S-n") 'image-dired-next-line-and-display)
+ (define-key map (kbd "C-S-p") 'image-dired-previous-line-and-display)
+ (define-key map (kbd "C-S-m") 'image-dired-mark-and-display-next)
+
+ (define-key map "\C-td" 'image-dired-display-thumbs)
+ (define-key map [tab] 'image-dired-jump-thumbnail-buffer)
+ (define-key map "\C-ti" 'image-dired-dired-display-image)
+ (define-key map "\C-tx" 'image-dired-dired-display-external)
+ (define-key map "\C-ta" 'image-dired-display-thumbs-append)
+ (define-key map "\C-t." 'image-dired-display-thumb)
+ (define-key map "\C-tc" 'image-dired-dired-comment-files)
+ (define-key map "\C-tf" 'image-dired-mark-tagged-files)
+
+ ;; Menu for dired
+ (easy-menu-define nil map
+ "Menu for `image-dired-minor-mode'."
+ '("Image-dired"
+ ["Copy with EXIF file name" image-dired-copy-with-exif-file-name]
+ ["Comment files" image-dired-dired-comment-files]
+ ["Mark tagged files" image-dired-mark-tagged-files]
+ ["Jump to thumbnail buffer" image-dired-jump-thumbnail-buffer]
+
+ ["Toggle movement tracking" image-dired-toggle-movement-tracking]
+ ["Toggle append browsing" image-dired-toggle-append-browsing]
+ ["Toggle display properties"
image-dired-toggle-dired-display-properties]
+
+ ["Display in external viewer" image-dired-dired-display-external]
+ ["Display image" image-dired-dired-display-image]
+ ["Display this thumbnail" image-dired-display-thumb]
+ ["Display thumbnails append" image-dired-display-thumbs-append]
+
+ ["Create thumbnails for marked files" image-dired-create-thumbs]
+
+ ["Mark and display next" image-dired-mark-and-display-next]
+ ["Display thumb for previous file"
image-dired-previous-line-and-display]
+ ["Display thumb for next file" image-dired-next-line-and-display]))
+ map)
+ "Keymap for `image-dired-minor-mode'.")
;;;###autoload
-(defun image-dired-setup-dired-keybindings ()
+(define-minor-mode image-dired-minor-mode
"Setup easy-to-use keybindings for the commands to be used in dired mode.
Note that n, p and <down> and <up> will be hijacked and bound to
`image-dired-dired-x-line'."
- (interactive)
+ :keymap image-dired-minor-mode-map)
- ;; Hijack previous and next line movement. Let C-p and C-b be
- ;; though...
-
- (define-key dired-mode-map "p" 'image-dired-dired-previous-line)
- (define-key dired-mode-map "n" 'image-dired-dired-next-line)
- (define-key dired-mode-map [up] 'image-dired-dired-previous-line)
- (define-key dired-mode-map [down] 'image-dired-dired-next-line)
-
- (define-key dired-mode-map (kbd "C-S-n") 'image-dired-next-line-and-display)
- (define-key dired-mode-map (kbd "C-S-p")
'image-dired-previous-line-and-display)
- (define-key dired-mode-map (kbd "C-S-m") 'image-dired-mark-and-display-next)
-
- (define-key dired-mode-map "\C-td" 'image-dired-display-thumbs)
- (define-key dired-mode-map "\C-tt" 'image-dired-tag-files)
- (define-key dired-mode-map "\C-tr" 'image-dired-delete-tag)
- (define-key dired-mode-map [tab] 'image-dired-jump-thumbnail-buffer)
- (define-key dired-mode-map "\C-ti" 'image-dired-dired-display-image)
- (define-key dired-mode-map "\C-tx" 'image-dired-dired-display-external)
- (define-key dired-mode-map "\C-ta" 'image-dired-display-thumbs-append)
- (define-key dired-mode-map "\C-t." 'image-dired-display-thumb)
- (define-key dired-mode-map "\C-tc" 'image-dired-dired-comment-files)
- (define-key dired-mode-map "\C-tf" 'image-dired-mark-tagged-files)
-
- ;; Menu for dired
- (define-key dired-mode-map [menu-bar image-dired]
- (cons "Image-Dired" (make-sparse-keymap "Image-Dired")))
-
- (define-key dired-mode-map [menu-bar image-dired
image-dired-copy-with-exif-file-name]
- '("Copy with EXIF file name" . image-dired-copy-with-exif-file-name))
-
- (define-key dired-mode-map [menu-bar image-dired
image-dired-dired-comment-files]
- '("Comment files" . image-dired-dired-comment-files))
-
- (define-key dired-mode-map [menu-bar image-dired
image-dired-mark-tagged-files]
- '("Mark tagged files" . image-dired-mark-tagged-files))
-
- (define-key dired-mode-map [menu-bar image-dired image-dired-delete-tag]
- '("Remove tag from files" . image-dired-delete-tag))
-
- (define-key dired-mode-map [menu-bar image-dired image-dired-tag-files]
- '("Tag files" . image-dired-tag-files))
-
- (define-key dired-mode-map [menu-bar image-dired
image-dired-jump-thumbnail-buffer]
- '("Jump to thumbnail buffer" . image-dired-jump-thumbnail-buffer))
-
- (define-key dired-mode-map [menu-bar image-dired
image-dired-toggle-movement-tracking]
- '("Toggle movement tracking" . image-dired-toggle-movement-tracking))
-
- (define-key dired-mode-map
- [menu-bar image-dired image-dired-toggle-append-browsing]
- '("Toggle append browsing" . image-dired-toggle-append-browsing))
-
- (define-key dired-mode-map
- [menu-bar image-dired image-dired-toggle-disp-props]
- '("Toggle display properties" .
image-dired-toggle-dired-display-properties))
-
- (define-key dired-mode-map
- [menu-bar image-dired image-dired-dired-display-external]
- '("Display in external viewer" . image-dired-dired-display-external))
- (define-key dired-mode-map
- [menu-bar image-dired image-dired-dired-display-image]
- '("Display image" . image-dired-dired-display-image))
- (define-key dired-mode-map
- [menu-bar image-dired image-dired-display-thumb]
- '("Display this thumbnail" . image-dired-display-thumb))
- (define-key dired-mode-map
- [menu-bar image-dired image-dired-display-thumbs-append]
- '("Display thumbnails append" . image-dired-display-thumbs-append))
- (define-key dired-mode-map
- [menu-bar image-dired image-dired-display-thumbs]
- '("Display thumbnails" . image-dired-display-thumbs))
-
- (define-key dired-mode-map
- [menu-bar image-dired image-dired-create-thumbs]
- '("Create thumbnails for marked files" . image-dired-create-thumbs))
-
- (define-key dired-mode-map
- [menu-bar image-dired image-dired-mark-and-display-next]
- '("Mark and display next" . image-dired-mark-and-display-next))
- (define-key dired-mode-map
- [menu-bar image-dired image-dired-previous-line-and-display]
- '("Display thumb for previous file" .
image-dired-previous-line-and-display))
- (define-key dired-mode-map
- [menu-bar image-dired image-dired-next-line-and-display]
- '("Display thumb for next file" . image-dired-next-line-and-display)))
+;;;###autoload
+(define-obsolete-function-alias 'image-dired-setup-dired-keybindings
'image-dired-minor-mode
+ "26.1")
(declare-function clear-image-cache "image.c" (&optional filter))
@@ -1530,12 +1701,11 @@ With prefix argument ARG, create thumbnails even if
they already exist
;; If the user overrides the exist check, we must clear the
;; image cache so that if the user wants to display the
;; thumbnail, it is not fetched from cache.
- (if arg
- (clear-image-cache))
+ (when arg
+ (clear-image-cache (expand-file-name thumb-name)))
(when (or (not (file-exists-p thumb-name))
arg)
- (when (not (= 0 (image-dired-create-thumb curr-file thumb-name)))
- (error "Thumb could not be created"))))))
+ (image-dired-create-thumb curr-file thumb-name)))))
(defvar image-dired-slideshow-timer nil
"Slideshow timer.")
@@ -1633,7 +1803,8 @@ Calculate how many thumbnails fit."
(/ width
(+ (* 2 image-dired-thumb-relief)
(* 2 image-dired-thumb-margin)
- image-dired-thumb-width char-width))))
+ (image-dired-thumb-size 'width)
+ char-width))))
(image-dired-line-up)))
(defun image-dired-line-up-interactive ()
@@ -1654,16 +1825,16 @@ Ask user how many thumbnails should be displayed per
row."
(message "No thumbnail at point")
(if (not file)
(message "No original file name found")
- (call-process shell-file-name nil nil nil shell-command-switch
- (format "%s \"%s\"" image-dired-external-viewer file))))))
+ (start-process "image-dired-thumb-external" nil
+ image-dired-external-viewer file)))))
;;;###autoload
(defun image-dired-dired-display-external ()
"Display file at point using an external viewer."
(interactive)
(let ((file (dired-get-filename)))
- (call-process shell-file-name nil nil nil shell-command-switch
- (format "%s \"%s\"" image-dired-external-viewer file))))
+ (start-process "image-dired-external" nil
+ image-dired-external-viewer file)))
(defun image-dired-window-width-pixels (window)
"Calculate WINDOW width in pixels."
@@ -1699,14 +1870,14 @@ Ask user how many thumbnails should be displayed per
row."
(equal (window-buffer window) buf))))
(error "No thumbnail image at point"))))
-(defun image-dired-display-window-width ()
- "Return width, in pixels, of image-dired's image display window."
- (- (image-dired-window-width-pixels (image-dired-display-window))
+(defun image-dired-display-window-width (window)
+ "Return width, in pixels, of WINDOW."
+ (- (image-dired-window-width-pixels window)
image-dired-display-window-width-correction))
-(defun image-dired-display-window-height ()
- "Return height, in pixels, of image-dired's image display window."
- (- (image-dired-window-height-pixels (image-dired-display-window))
+(defun image-dired-display-window-height (window)
+ "Return height, in pixels, of WINDOW."
+ (- (image-dired-window-height-pixels window)
image-dired-display-window-height-correction))
(defun image-dired-display-image (file &optional original-size)
@@ -1722,26 +1893,25 @@ original size."
(image-dired--check-executable-exists
'image-dired-cmd-create-temp-image-program)
(let ((new-file (expand-file-name image-dired-temp-image-file))
- width height command ret
+ (window (image-dired-display-window))
(image-type 'jpeg))
(setq file (expand-file-name file))
(if (not original-size)
- (progn
- (setq width (image-dired-display-window-width))
- (setq height (image-dired-display-window-height))
- (setq command
- (format-spec
- image-dired-cmd-create-temp-image-options
- (list
- (cons ?p image-dired-cmd-create-temp-image-program)
- (cons ?w width)
- (cons ?h height)
- (cons ?f file)
- (cons ?t new-file))))
- (setq ret (call-process shell-file-name nil nil nil
- shell-command-switch command))
- (if (not (= 0 ret))
- (error "Could not resize image")))
+ (let* ((spec
+ (list
+ (cons ?p image-dired-cmd-create-temp-image-program)
+ (cons ?w (image-dired-display-window-width window))
+ (cons ?h (image-dired-display-window-height window))
+ (cons ?f file)
+ (cons ?t new-file)))
+ (ret
+ (apply #'call-process
+ image-dired-cmd-create-temp-image-program nil nil nil
+ (mapcar
+ (lambda (arg) (format-spec arg spec))
+ image-dired-cmd-create-temp-image-options))))
+ (when (not (zerop ret))
+ (error "Could not resize image")))
(setq image-type (image-type-from-file-name file))
(copy-file file new-file t))
(with-current-buffer (image-dired-create-display-image-buffer)
@@ -1750,6 +1920,8 @@ original size."
(clear-image-cache)
(image-dired-insert-image image-dired-temp-image-file image-type 0 0)
(goto-char (point-min))
+ (set-window-vscroll window 0)
+ (set-window-hscroll window 0)
(image-dired-update-property 'original-file-name file)))))
(defun image-dired-display-thumbnail-original-image (&optional arg)
@@ -1789,18 +1961,13 @@ With prefix argument ARG, display image in its original
size."
'image-dired-cmd-rotate-thumbnail-program)
(if (not (image-dired-image-at-point-p))
(message "No thumbnail at point")
- (let ((file (image-dired-thumb-name (image-dired-original-file-name)))
- command)
- (setq command (format-spec
- image-dired-cmd-rotate-thumbnail-options
- (list
- (cons ?p image-dired-cmd-rotate-thumbnail-program)
- (cons ?d degrees)
- (cons ?t (expand-file-name file)))))
- (call-process shell-file-name nil nil nil shell-command-switch command)
- ;; Clear the cache to refresh image. I wish I could just refresh
- ;; the current file but I do not know how to do that. Yet...
- (clear-image-cache))))
+ (let* ((file (image-dired-thumb-name (image-dired-original-file-name)))
+ (thumb (expand-file-name file))
+ (spec (list (cons ?d degrees) (cons ?t thumb))))
+ (apply #'call-process image-dired-cmd-rotate-thumbnail-program nil nil
nil
+ (mapcar (lambda (arg) (format-spec arg spec))
+ image-dired-cmd-rotate-thumbnail-options))
+ (clear-image-cache thumb))))
(defun image-dired-rotate-thumbnail-left ()
"Rotate thumbnail left (counter clockwise) 90 degrees.
@@ -1823,9 +1990,10 @@ overwritten. This confirmation can be turned off using
(defun image-dired-refresh-thumb ()
"Force creation of new image for current thumbnail."
(interactive)
- (let ((file (image-dired-original-file-name)))
- (clear-image-cache)
- (image-dired-create-thumb file (image-dired-thumb-name file))))
+ (let* ((file (image-dired-original-file-name))
+ (thumb (expand-file-name (image-dired-thumb-name file))))
+ (clear-image-cache (expand-file-name thumb))
+ (image-dired-create-thumb file thumb)))
(defun image-dired-rotate-original (degrees)
"Rotate original image DEGREES degrees."
@@ -1833,19 +2001,18 @@ overwritten. This confirmation can be turned off using
'image-dired-cmd-rotate-original-program)
(if (not (image-dired-image-at-point-p))
(message "No image at point")
- (let ((file (image-dired-original-file-name))
- command)
+ (let* ((file (image-dired-original-file-name))
+ (spec
+ (list
+ (cons ?d degrees)
+ (cons ?o (expand-file-name file))
+ (cons ?t image-dired-temp-rotate-image-file))))
(unless (eq 'jpeg (image-type file))
(error "Only JPEG images can be rotated!"))
- (setq command (format-spec
- image-dired-cmd-rotate-original-options
- (list
- (cons ?p image-dired-cmd-rotate-original-program)
- (cons ?d degrees)
- (cons ?o (expand-file-name file))
- (cons ?t image-dired-temp-rotate-image-file))))
- (if (not (= 0 (call-process shell-file-name nil nil nil
- shell-command-switch command)))
+ (if (not (= 0 (apply #'call-process
image-dired-cmd-rotate-original-program
+ nil nil nil
+ (mapcar (lambda (arg) (format-spec arg spec))
+ image-dired-cmd-rotate-original-options))))
(error "Could not rotate image")
(image-dired-display-image image-dired-temp-rotate-image-file)
(if (or (and image-dired-rotate-original-ask-before-overwrite
@@ -1911,32 +2078,30 @@ default value at the prompt."
"In FILE, set EXIF tag TAG-NAME to value TAG-VALUE."
(image-dired--check-executable-exists
'image-dired-cmd-write-exif-data-program)
- (let (command)
- (setq command (format-spec
- image-dired-cmd-write-exif-data-options
- (list
- (cons ?p image-dired-cmd-write-exif-data-program)
- (cons ?f (expand-file-name file))
- (cons ?t tag-name)
- (cons ?v tag-value))))
- (call-process shell-file-name nil nil nil shell-command-switch command)))
+ (let ((spec
+ (list
+ (cons ?f (expand-file-name file))
+ (cons ?t tag-name)
+ (cons ?v tag-value))))
+ (apply #'call-process image-dired-cmd-write-exif-data-program nil nil nil
+ (mapcar (lambda (arg) (format-spec arg spec))
+ image-dired-cmd-write-exif-data-options))))
(defun image-dired-get-exif-data (file tag-name)
"From FILE, return EXIF tag TAG-NAME."
(image-dired--check-executable-exists
'image-dired-cmd-read-exif-data-program)
(let ((buf (get-buffer-create "*image-dired-get-exif-data*"))
- command tag-value)
- (setq command (format-spec
- image-dired-cmd-read-exif-data-options
- (list
- (cons ?p image-dired-cmd-read-exif-data-program)
- (cons ?f file)
- (cons ?t tag-name))))
+ (spec (list (cons ?f file) (cons ?t tag-name)))
+ tag-value)
(with-current-buffer buf
(delete-region (point-min) (point-max))
- (if (not (eq (call-process shell-file-name nil t nil
- shell-command-switch command) 0))
+ (if (not (eq (apply #'call-process image-dired-cmd-read-exif-data-program
+ nil t nil
+ (mapcar
+ (lambda (arg) (format-spec arg spec))
+ image-dired-cmd-read-exif-data-options))
+ 0))
(error "Could not get EXIF tag")
(goto-char (point-min))
;; Clean buffer from newlines and carriage returns before
@@ -1962,7 +2127,7 @@ function. The result is a couple of new files in
(interactive)
(let (new-name
(files (dired-get-marked-files)))
- (mapcar
+ (mapc
(lambda (curr-file)
(setq new-name
(format "%s/%s"
@@ -2154,11 +2319,9 @@ non-nil."
(let* ((file (dired-get-filename))
(file-name (file-name-nondirectory file))
(dired-buf (buffer-name (current-buffer)))
- (props (mapconcat
- 'princ
- (image-dired-list-tags file)
- ", "))
- (comment (image-dired-get-comment file)))
+ (props (mapconcat #'identity (image-dired-list-tags file) ", "))
+ (comment (image-dired-get-comment file))
+ (message-log-max nil))
(if file-name
(message "%s"
(image-dired-format-properties-string
@@ -2272,13 +2435,8 @@ image-dired-file-comment-list:
(defun image-dired-hidden-p (file)
"Return t if image FILE has a \"hidden\" tag."
- (let (hidden)
- (mapc
- (lambda (tag)
- (if (member tag image-dired-gallery-hidden-tags)
- (setq hidden t)))
- (cdr (assoc file image-dired-file-tag-list)))
- hidden))
+ (cl-loop for tag in (cdr (assoc file image-dired-file-tag-list))
+ if (member tag image-dired-gallery-hidden-tags) return t))
(defun image-dired-gallery-generate ()
"Generate gallery pages.
@@ -2370,15 +2528,6 @@ when using per-directory thumbnail file storage"))
(insert " </body>\n")
(insert "</html>"))))
-(defun image-dired-kill-buffer-and-window ()
- "Kill the current buffer and, if possible, also the window."
- (interactive)
- (let ((buffer (current-buffer)))
- (condition-case nil
- (delete-window (selected-window))
- (error nil))
- (kill-buffer buffer)))
-
(defvar image-dired-widget-list nil
"List to keep track of meta data in edit buffer.")
@@ -2428,8 +2577,7 @@ the operation by activating the Cancel button.\n\n")
:size 60
:format "%v "
:value (or (mapconcat
- (lambda (tag)
- tag)
+ #'identity
(image-dired-list-tags file)
",") "")))
;; Save information in all widgets so that we can use it when
diff --git a/lisp/image-mode.el b/lisp/image-mode.el
index f526685..4a7178d 100644
--- a/lisp/image-mode.el
+++ b/lisp/image-mode.el
@@ -43,7 +43,10 @@
;;; Image mode window-info management.
-(defvar-local image-mode-winprops-alist t)
+(defvar-local image-mode-winprops-alist t
+ "Alist of windows to window properties.
+Each element has the form (WINDOW . ALIST).
+See `image-mode-winprops'.")
(defvar image-mode-new-window-functions nil
"Special hook run when image data is requested in a new window.
@@ -270,6 +273,48 @@ When calling from a program, supply as argument a number,
nil, or `-'."
(max 0 (- win-height next-screen-context-lines)))))
(t (image-next-line (- (prefix-numeric-value n))))))
+(defun image-scroll-left (&optional n)
+ "Scroll image in current window leftward by N character widths.
+Stop if the right edge of the image is reached.
+If ARG is omitted or nil, scroll leftward by a near full screen.
+A near full screen is 2 columns less than a full screen.
+Negative ARG means scroll rightward.
+If ARG is the atom `-', scroll rightward by nearly full screen.
+When calling from a program, supply as argument a number, nil, or `-'."
+ (interactive "P")
+ (cond ((null n)
+ (let* ((edges (window-inside-edges))
+ (win-width (- (nth 2 edges) (nth 0 edges))))
+ (image-forward-hscroll
+ (max 0 (- win-width 2)))))
+ ((eq n '-)
+ (let* ((edges (window-inside-edges))
+ (win-width (- (nth 2 edges) (nth 0 edges))))
+ (image-forward-hscroll
+ (min 0 (- 2 win-width)))))
+ (t (image-forward-hscroll (prefix-numeric-value n)))))
+
+(defun image-scroll-right (&optional n)
+ "Scroll image in current window rightward by N character widths.
+Stop if the left edge of the image is reached.
+If ARG is omitted or nil, scroll downward by a near full screen.
+A near full screen is 2 less than a full screen.
+Negative ARG means scroll leftward.
+If ARG is the atom `-', scroll leftward by nearly full screen.
+When calling from a program, supply as argument a number, nil, or `-'."
+ (interactive "P")
+ (cond ((null n)
+ (let* ((edges (window-inside-edges))
+ (win-width (- (nth 2 edges) (nth 0 edges))))
+ (image-forward-hscroll
+ (min 0 (- 2 win-width)))))
+ ((eq n '-)
+ (let* ((edges (window-inside-edges))
+ (win-width (- (nth 2 edges) (nth 0 edges))))
+ (image-forward-hscroll
+ (max 0 (- win-width 2)))))
+ (t (image-forward-hscroll (- (prefix-numeric-value n))))))
+
(defun image-bol (arg)
"Scroll horizontally to the left edge of the image in the current window.
With argument ARG not nil or 1, move forward ARG - 1 lines first,
@@ -398,6 +443,8 @@ call."
(define-key map [remap scroll-down] 'image-scroll-down)
(define-key map [remap scroll-up-command] 'image-scroll-up)
(define-key map [remap scroll-down-command] 'image-scroll-down)
+ (define-key map [remap scroll-left] 'image-scroll-left)
+ (define-key map [remap scroll-right] 'image-scroll-right)
(define-key map [remap move-beginning-of-line] 'image-bol)
(define-key map [remap move-end-of-line] 'image-eol)
(define-key map [remap beginning-of-buffer] 'image-bob)
diff --git a/lisp/ldefs-boot-auto.el b/lisp/ldefs-boot-auto.el
new file mode 100644
index 0000000..914fec8
--- /dev/null
+++ b/lisp/ldefs-boot-auto.el
@@ -0,0 +1,125 @@
+;; This file is autogenerated by admin/ldefs-clean.el
+;; Do not edit
+(autoload 'Info-directory "info" nil nil nil)
+(autoload 'Info-index "info" nil nil nil)
+(autoload 'View-exit-and-edit "view" nil nil nil)
+(autoload 'add-change-log-entry "add-log" nil nil nil)
+(autoload 'add-log-current-defun "add-log" nil nil nil)
+(autoload 'batch-byte-compile "bytecomp" nil nil nil)
+(autoload 'browse-url "browse-url" nil nil nil)
+(autoload 'buffer-face-mode "face-remap" nil nil nil)
+(autoload 'byte-compile "bytecomp" nil nil nil)
+(autoload 'byte-compile-disable-warning "bytecomp" nil nil nil)
+(autoload 'byte-compile-enable-warning "bytecomp" nil nil nil)
+(autoload 'byte-compile-file "bytecomp" nil nil nil)
+(autoload 'byte-compile-inline-expand "byte-opt" nil nil nil)
+(autoload 'byte-compile-unfold-lambda "byte-opt" nil nil nil)
+(autoload 'byte-optimize-form "byte-opt" nil nil nil)
+(autoload 'byte-optimize-lapcode "byte-opt" nil nil nil)
+(autoload 'byte-recompile-directory "bytecomp" nil nil nil)
+(autoload 'char-displayable-p "mule-util" nil nil nil)
+(autoload 'color-name-to-rgb "color" nil nil nil)
+(autoload 'comint-redirect-results-list-from-process "comint" nil nil nil)
+(autoload 'comint-redirect-send-command-to-process "comint" nil nil nil)
+(autoload 'compilation-mode "compile" nil nil nil)
+(autoload 'compilation-shell-minor-mode "compile" nil nil nil)
+(autoload 'compilation-start "compile" nil nil nil)
+(autoload 'create-image "image" nil nil nil)
+(autoload 'custom-save-all "cus-edit" nil nil nil)
+(autoload 'customize-face "cus-edit" nil nil nil)
+(autoload 'customize-group "cus-edit" nil nil nil)
+(autoload 'customize-option "cus-edit" nil nil nil)
+(autoload 'customize-set-variable "cus-edit" nil nil nil)
+(autoload 'debug "debug" nil nil nil)
+(autoload 'define-ccl-program "ccl" nil nil t)
+(autoload 'define-derived-mode "derived" nil nil t)
+(autoload 'define-minor-mode "easy-mmode" nil nil t)
+(autoload 'delete-extract-rectangle "rect" nil nil nil)
+(autoload 'describe-char "descr-text" nil nil nil)
+(autoload 'describe-function "help-fns" nil nil nil)
+(autoload 'describe-function-1 "help-fns" nil nil nil)
+(autoload 'describe-package "package" nil nil nil)
+(autoload 'describe-variable "help-fns" nil nil nil)
+(autoload 'desktop-save "desktop" nil nil nil)
+(autoload 'diff-mode "diff-mode" nil nil nil)
+(autoload 'dired "dired" nil nil nil)
+(autoload 'dired-mode "dired" nil nil nil)
+(autoload 'dired-noselect "dired" nil nil nil)
+(autoload 'display-call-tree "bytecomp" nil nil nil)
+(autoload 'display-warning "warnings" nil nil nil)
+(autoload 'easy-menu-create-menu "easymenu" nil nil nil)
+(autoload 'ediff-patch-file "ediff" nil nil nil)
+(autoload 'edit-kbd-macro "edmacro" nil nil nil)
+(autoload 'extract-rectangle "rect" nil nil nil)
+(autoload 'find-definition-noselect "find-func" nil nil nil)
+(autoload 'find-function-search-for-symbol "find-func" nil nil nil)
+(autoload 'find-lisp-object-file-name "help-fns" nil nil nil)
+(autoload 'find-variable-noselect "find-func" nil nil nil)
+(autoload 'format-kbd-macro "edmacro" nil nil nil)
+(autoload 'goto-address-mode "goto-addr" nil nil nil)
+(autoload 'grep-compute-defaults "grep" nil nil nil)
+(autoload 'help-C-file-name "help-fns" nil nil nil)
+(autoload 'help-buffer "help-mode" nil nil nil)
+(autoload 'help-insert-xref-button "help-mode" nil nil nil)
+(autoload 'help-make-xrefs "help-mode" nil nil nil)
+(autoload 'help-mode "help-mode" nil nil nil)
+(autoload 'help-setup-xref "help-mode" nil nil nil)
+(autoload 'help-with-tutorial "tutorial" nil nil nil)
+(autoload 'help-xref-button "help-mode" nil nil nil)
+(autoload 'hi-lock-face-buffer "hi-lock" nil nil nil)
+(autoload 'image-type-available-p "image" nil nil nil)
+(autoload 'info "info" nil nil nil)
+(autoload 'info-emacs-manual "info" nil nil nil)
+(autoload 'insert-image "image" nil nil nil)
+(autoload 'insert-rectangle "rect" nil nil nil)
+(autoload 'isearch-process-search-multibyte-characters "isearch-x" nil nil nil)
+(autoload 'jka-compr-uninstall "jka-compr" nil nil nil)
+(autoload 'log-edit "log-edit" nil nil nil)
+(autoload 'log-view-mode "log-view" nil nil nil)
+(autoload 'lookup-nested-alist "mule-util" nil nil nil)
+(autoload 'make-display-table "disp-table" nil nil nil)
+(autoload 'make-glyph-code "disp-table" nil nil nil)
+(autoload 'multi-isearch-buffers "misearch" nil nil nil)
+(autoload 'multi-isearch-buffers-regexp "misearch" nil nil nil)
+(autoload 'multi-isearch-files "misearch" nil nil nil)
+(autoload 'multi-isearch-files-regexp "misearch" nil nil nil)
+(autoload 'open-network-stream "network-stream" nil nil nil)
+(autoload 'package-initialize "package" nil nil nil)
+(autoload 'parse-time-string "parse-time" nil nil nil)
+(autoload 'pp "pp" nil nil nil)
+(autoload 'pp-buffer "pp" nil nil nil)
+(autoload 'read-kbd-macro "edmacro" nil nil nil)
+(autoload 'regexp-opt "regexp-opt" nil nil nil)
+(autoload 'rx "rx" nil nil t)
+(autoload 'seconds-to-string "time-date" nil nil nil)
+(autoload 'seconds-to-time "time-date" nil nil nil)
+(autoload 'server-start "server" nil nil nil)
+(autoload 'set-nested-alist "mule-util" nil nil nil)
+(autoload 'smerge-mode "smerge-mode" nil nil nil)
+(autoload 'smerge-start-session "smerge-mode" nil nil nil)
+(autoload 'standard-display-8bit "disp-table" nil nil nil)
+(autoload 'tags-query-replace "etags" nil nil nil)
+(autoload 'tags-search "etags" nil nil nil)
+(autoload 'text-scale-increase "face-remap" nil nil nil)
+(autoload 'thing-at-point "thingatpt" nil nil nil)
+(autoload 'time-to-days "time-date" nil nil nil)
+(autoload 'timezone-make-date-arpa-standard "timezone" nil nil nil)
+(autoload 'tmm-menubar "tmm" nil nil nil)
+(autoload 'truncate-string-to-width "mule-util" nil nil nil)
+(autoload 'url-handler-mode "url-handlers" nil nil nil)
+(autoload 'variable-at-point "help-fns" nil nil nil)
+(autoload 'vc-register "vc" nil nil nil)
+(autoload 'vc-responsible-backend "vc" nil nil nil)
+(autoload 'vc-transfer-file "vc" nil nil nil)
+(autoload 'view-buffer "view" nil nil nil)
+(autoload 'view-buffer-other-window "view" nil nil nil)
+(autoload 'view-file "view" nil nil nil)
+(autoload 'view-mode-enter "view" nil nil nil)
+(autoload 'visit-tags-table "etags" nil nil nil)
+(autoload 'warn "warnings" nil nil nil)
+(autoload 'wdired-change-to-wdired-mode "wdired" nil nil nil)
+(autoload 'widget-value "wid-edit" nil nil nil)
+;; Local Variables:
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; End:
diff --git a/lisp/ldefs-boot-manual.el b/lisp/ldefs-boot-manual.el
new file mode 100644
index 0000000..183703d
--- /dev/null
+++ b/lisp/ldefs-boot-manual.el
@@ -0,0 +1,19 @@
+;; These appear to be necessary as they are used elsewhere in macro
definitions.
+(load "emacs-lisp/gv.el")
+(load "emacs-lisp/nadvice.el")
+(load "emacs-lisp/inline.el")
+
+;; This variable is used by bytecomp.el
+(defvar warning-series nil)
+
+;; This variable is used by emacs-lisp-mode which is used heavily
+;; during the byte-compile phase
+(defvar electric-pair-text-pairs '((34 . 34)))
+
+
+(load "ldefs-boot-auto.el")
+
+;; Local Variables:
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; End:
diff --git a/lisp/loadup.el b/lisp/loadup.el
index 5c16464..5350024 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -143,19 +143,21 @@
(load "button")
;; We don't want to store loaddefs.el in the repository because it is
-;; a generated file; but it is required in order to compile the lisp files.
-;; When bootstrapping, we cannot generate loaddefs.el until an
-;; emacs binary has been built. We therefore compromise and keep
-;; ldefs-boot.el in the repository. This does not need to be updated
-;; as often as the real loaddefs.el would. Bootstrap should always
-;; work with ldefs-boot.el. Therefore, Whenever a new autoload cookie
-;; gets added that is necessary during bootstrapping, ldefs-boot.el
-;; should be updated by overwriting it with an up-to-date copy of
-;; loaddefs.el that is uncorrupted by local changes.
-;; autogen/update_autogen can be used to periodically update ldefs-boot.
+;; a generated file; but it is required in order to compile the lisp
+;; files. When bootstrapping, we cannot generate loaddefs.el until an
+;; emacs binary has been built. We therefore support the build with
+;; two files, ldefs-boot-manual.el and ldefs-boot-auto.el, which
+;; contain the autoloads that are actually called during bootstrap.
+;; These do not need to be updated as often as the real loaddefs.el
+;; would. Bootstrap should always work with ldefs-boot-manual.el.
+;; Therefore, Whenever a new autoload cookie gets added that is
+;; necessary during bootstrapping, ldefs-boot-auto.el should be
+;; updated using the "generate-ldefs-boot" make target.
+;; autogen/update_autogen can be used to periodically update
+;; ldefs-boot.
(condition-case nil (load "loaddefs.el")
;; In case loaddefs hasn't been generated yet.
- (file-error (load "ldefs-boot.el")))
+ (file-error (load "ldefs-boot-manual.el")))
(let ((new (make-hash-table :test 'equal)))
;; Now that loaddefs has populated definition-prefixes, purify its contents.
@@ -299,6 +301,7 @@
;; already produced, because it needs uni-*.el files that might
;; not be built early enough during bootstrap.
(when (load-history-filename-element "charprop\\.el")
+ (load "international/mule-util")
(load "international/ucs-normalize")
(load "term/ns-win"))))
(if (fboundp 'x-create-frame)
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 175189c..576b804 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -2251,6 +2251,17 @@ This is only used when the minibuffer area has no active
minibuffer.")
(replace-regexp-in-string "\\$" (lambda (dollar) (concat dollar dollar))
str))
+(defun minibuffer-maybe-quote-filename (filename)
+ "Protect FILENAME from `substitute-in-file-name', as needed.
+Useful to give the user default values that won't be substituted."
+ (if (and (not (file-name-quoted-p filename))
+ (file-name-absolute-p filename)
+ (string-match-p (if (memq system-type '(windows-nt ms-dos))
+ "[/\\\\]~" "/~")
+ (file-local-name filename)))
+ (file-name-quote filename)
+ (minibuffer--double-dollars filename)))
+
(defun completion--make-envvar-table ()
(mapcar (lambda (enventry)
(substring enventry 0 (string-match-p "=" enventry)))
@@ -2420,7 +2431,7 @@ same as `substitute-in-file-name'."
(substitute-in-file-name
(substring qstr 0 (1- qpos)))))
(setq qpos (1- qpos)))
- (cons qpos #'minibuffer--double-dollars))))
+ (cons qpos #'minibuffer-maybe-quote-filename))))
(defalias 'completion--file-name-table
(completion-table-with-quoting #'completion-file-name-table
@@ -2596,10 +2607,10 @@ See `read-file-name' for the meaning of the arguments."
(let ((insdef (cond
((and insert-default-directory (stringp dir))
(if initial
- (cons (minibuffer--double-dollars (concat dir initial))
- (length (minibuffer--double-dollars dir)))
- (minibuffer--double-dollars dir)))
- (initial (cons (minibuffer--double-dollars initial) 0)))))
+ (cons (minibuffer-maybe-quote-filename (concat dir
initial))
+ (length (minibuffer-maybe-quote-filename dir)))
+ (minibuffer-maybe-quote-filename dir)))
+ (initial (cons (minibuffer-maybe-quote-filename initial)
0)))))
(let ((completion-ignore-case read-file-name-completion-ignore-case)
(minibuffer-completing-file-name t)
@@ -2693,7 +2704,7 @@ See `read-file-name' for the meaning of the arguments."
;; with what we will actually return. As an exception,
;; if that's the same as the second item in
;; file-name-history, it's really a repeat (Bug#4657).
- (let ((val1 (minibuffer--double-dollars val)))
+ (let ((val1 (minibuffer-maybe-quote-filename val)))
(if history-delete-duplicates
(setcdr file-name-history
(delete val1 (cdr file-name-history))))
@@ -2703,7 +2714,7 @@ See `read-file-name' for the meaning of the arguments."
(if add-to-history
;; Add the value to the history--but not if it matches
;; the last value already there.
- (let ((val1 (minibuffer--double-dollars val)))
+ (let ((val1 (minibuffer-maybe-quote-filename val)))
(unless (and (consp file-name-history)
(equal (car file-name-history) val1))
(setq file-name-history
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index f03f50b..a4218c2 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -523,6 +523,9 @@ Emacs dired can't find files."
(defun tramp-adb-handle-delete-directory (directory &optional recursive)
"Like `delete-directory' for Tramp files."
(setq directory (expand-file-name directory))
+ (with-parsed-tramp-file-name (file-truename directory) nil
+ (tramp-flush-file-property v (file-name-directory localname))
+ (tramp-flush-directory-property v localname))
(with-parsed-tramp-file-name directory nil
(tramp-flush-file-property v (file-name-directory localname))
(tramp-flush-directory-property v localname)
@@ -578,7 +581,8 @@ Emacs dired can't find files."
(with-tramp-progress-reporter
v 3 (format "Fetching %s to tmp file %s" filename tmpfile)
;; "adb pull ..." does not always return an error code.
- (when (or (tramp-adb-execute-adb-command v "pull" localname tmpfile)
+ (when (or (tramp-adb-execute-adb-command
+ v "pull" (tramp-compat-file-name-unquote localname) tmpfile)
(not (file-exists-p tmpfile)))
(ignore-errors (delete-file tmpfile))
(tramp-error
@@ -638,7 +642,8 @@ But handle the case, if the \"test\" command is not
available."
v 3 (format-message
"Moving tmp file `%s' to `%s'" tmpfile filename)
(unwind-protect
- (when (tramp-adb-execute-adb-command v "push" tmpfile localname)
+ (when (tramp-adb-execute-adb-command
+ v "push" tmpfile (tramp-compat-file-name-unquote localname))
(tramp-error v 'file-error "Cannot write: `%s'" filename))
(delete-file tmpfile)))
@@ -681,38 +686,65 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are
completely ignored."
(if (file-directory-p filename)
(tramp-file-name-handler 'copy-directory filename newname keep-date t)
- (with-tramp-progress-reporter
- (tramp-dissect-file-name
- (if (tramp-tramp-file-p filename) filename newname))
- 0 (format "Copying %s to %s" filename newname)
-
- (let ((tmpfile (file-local-copy filename)))
-
- (if tmpfile
- ;; Remote filename.
- (condition-case err
- (rename-file tmpfile newname ok-if-already-exists)
- ((error quit)
- (delete-file tmpfile)
- (signal (car err) (cdr err))))
-
- ;; Remote newname.
- (when (file-directory-p newname)
- (setq newname
- (expand-file-name (file-name-nondirectory filename) newname)))
-
- (with-parsed-tramp-file-name newname nil
- (when (and (not ok-if-already-exists)
- (file-exists-p newname))
- (tramp-error v 'file-already-exists newname))
-
- ;; We must also flush the cache of the directory, because
- ;; `file-attributes' reads the values from there.
- (tramp-flush-file-property v (file-name-directory localname))
- (tramp-flush-file-property v localname)
- (when (tramp-adb-execute-adb-command v "push" filename localname)
- (tramp-error
- v 'file-error "Cannot copy `%s' `%s'" filename newname))))))
+
+ (let ((t1 (tramp-tramp-file-p filename))
+ (t2 (tramp-tramp-file-p newname)))
+ (with-parsed-tramp-file-name (if t1 filename newname) nil
+ (with-tramp-progress-reporter
+ v 0 (format "Copying %s to %s" filename newname)
+
+ (if (and t1 t2 (tramp-equal-remote filename newname))
+ (let ((l1 (file-remote-p filename 'localname))
+ (l2 (file-remote-p newname 'localname)))
+ (when (and (not ok-if-already-exists)
+ (file-exists-p newname))
+ (tramp-error v 'file-already-exists newname))
+ ;; We must also flush the cache of the directory,
+ ;; because `file-attributes' reads the values from
+ ;; there.
+ (tramp-flush-file-property v (file-name-directory l2))
+ (tramp-flush-file-property v l2)
+ ;; Short track.
+ (tramp-adb-barf-unless-okay
+ v (format
+ "cp -f %s %s"
+ (tramp-shell-quote-argument l1)
+ (tramp-shell-quote-argument l2))
+ "Error copying %s to %s" filename newname))
+
+ (let ((tmpfile (file-local-copy filename)))
+
+ (if tmpfile
+ ;; Remote filename.
+ (condition-case err
+ (rename-file tmpfile newname ok-if-already-exists)
+ ((error quit)
+ (delete-file tmpfile)
+ (signal (car err) (cdr err))))
+
+ ;; Remote newname.
+ (when (file-directory-p newname)
+ (setq newname
+ (expand-file-name
+ (file-name-nondirectory filename) newname)))
+
+ (with-parsed-tramp-file-name newname nil
+ (when (and (not ok-if-already-exists)
+ (file-exists-p newname))
+ (tramp-error v 'file-already-exists newname))
+
+ ;; We must also flush the cache of the directory,
+ ;; because `file-attributes' reads the values from
+ ;; there.
+ (tramp-flush-file-property v (file-name-directory localname))
+ (tramp-flush-file-property v localname)
+ (when (tramp-adb-execute-adb-command
+ v "push"
+ (tramp-compat-file-name-unquote filename)
+ (tramp-compat-file-name-unquote localname))
+ (tramp-error
+ v 'file-error
+ "Cannot copy `%s' `%s'" filename newname)))))))))
;; KEEP-DATE handling.
(when keep-date
@@ -749,7 +781,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are
completely ignored."
(tramp-flush-file-property v l2)
;; Short track.
(tramp-adb-barf-unless-okay
- v (format "mv %s %s" l1 l2)
+ v (format
+ "mv -f %s %s"
+ (tramp-shell-quote-argument l1)
+ (tramp-shell-quote-argument l2))
"Error renaming %s to %s" filename newname))
;; Rename by copy.
diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index 46f2523..37aba59 100644
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -901,6 +901,7 @@ file names."
"Return GVFS attributes association list of FILENAME."
(setq filename (directory-file-name (expand-file-name filename)))
(with-parsed-tramp-file-name filename nil
+ (setq localname (tramp-compat-file-name-unquote localname))
(if (or
(and (string-match "^\\(afp\\|smb\\)$" method)
(string-match "^/?\\([^/]+\\)$" localname))
@@ -1511,7 +1512,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or
\"[xx:xx:xx:xx:xx:xx]\"."
(string-equal user (or (tramp-file-name-user vec) ""))
(string-equal host (tramp-file-name-host vec))
(string-match (concat "^" (regexp-quote prefix))
- (tramp-file-name-localname vec)))
+ (tramp-file-name-unquote-localname vec)))
;; Set prefix, mountpoint and location.
(unless (string-equal prefix "/")
(tramp-set-file-property vec "/" "prefix" prefix))
@@ -1535,7 +1536,7 @@ It was \"a(say)\", but has changed to \"a{sv})\"."
(domain (tramp-file-name-domain vec))
(host (tramp-file-name-real-host vec))
(port (tramp-file-name-port vec))
- (localname (tramp-file-name-localname vec))
+ (localname (tramp-file-name-unquote-localname vec))
(share (when (string-match "^/?\\([^/]+\\)" localname)
(match-string 1 localname)))
(ssl (if (string-match "^davs" method) "true" "false"))
@@ -1645,7 +1646,7 @@ connection if a previous connection has died for some
reason."
(let* ((method (tramp-file-name-method vec))
(user (tramp-file-name-user vec))
(host (tramp-file-name-host vec))
- (localname (tramp-file-name-localname vec))
+ (localname (tramp-file-name-unquote-localname vec))
(object-path
(tramp-gvfs-object-path
(tramp-make-tramp-file-name method user host ""))))
diff --git a/lisp/net/tramp-gw.el b/lisp/net/tramp-gw.el
deleted file mode 100644
index 8f8f107..0000000
--- a/lisp/net/tramp-gw.el
+++ /dev/null
@@ -1,339 +0,0 @@
-;;; tramp-gw.el --- Tramp utility functions for HTTP tunnels and SOCKS gateways
-
-;; Copyright (C) 2007-2016 Free Software Foundation, Inc.
-
-;; Author: Michael Albinus <address@hidden>
-;; Keywords: comm, processes
-;; Package: tramp
-
-;; 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 <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Access functions for HTTP tunnels and SOCKS gateways from Tramp.
-;; SOCKS functionality is implemented by socks.el from the w3 package.
-;; HTTP tunnels are partly implemented in socks.el and url-http.el;
-;; both implementations are not complete. Therefore, it is
-;; implemented in this package.
-
-;;; Code:
-
-(require 'tramp)
-
-;; Pacify byte-compiler.
-(eval-when-compile
- (require 'cl)
- (require 'custom))
-(defvar socks-noproxy)
-
-;; We don't add the following methods to `tramp-methods', in order to
-;; exclude them from file name completion.
-
-;; Define HTTP tunnel method ...
-;;;###tramp-autoload
-(defconst tramp-gw-tunnel-method "tunnel"
- "Method to connect HTTP gateways.")
-
-;; ... and port.
-(defconst tramp-gw-default-tunnel-port 8080
- "Default port for HTTP gateways.")
-
-;; Define SOCKS method ...
-;;;###tramp-autoload
-(defconst tramp-gw-socks-method "socks"
- "Method to connect SOCKS servers.")
-
-;; ... and port.
-(defconst tramp-gw-default-socks-port 1080
- "Default port for SOCKS servers.")
-
-;; Autoload the socks library. It is used only when we access a SOCKS server.
-(autoload 'socks-open-network-stream "socks")
-(defvar socks-username (user-login-name))
-(defvar socks-server
- (list "Default server" "socks" tramp-gw-default-socks-port 5))
-
-;; Add a default for `tramp-default-user-alist'. Default is the local user.
-;;;###tramp-autoload
-(add-to-list
- 'tramp-default-user-alist
- (list (concat "\\`"
- (regexp-opt (list tramp-gw-tunnel-method tramp-gw-socks-method))
- "\\'")
- nil (user-login-name)))
-
-;; Internal file name functions and variables.
-
-(defvar tramp-gw-vector nil
- "Keeps the remote host identification. Needed for Tramp messages.")
-
-(defvar tramp-gw-gw-vector nil
- "Current gateway identification vector.")
-
-(defvar tramp-gw-gw-proc nil
- "Current gateway process.")
-
-;; This variable keeps the listening process, in order to reuse it for
-;; new processes.
-(defvar tramp-gw-aux-proc nil
- "Process listening on local port, as mediation between SSH and the gateway.")
-
-(defun tramp-gw-gw-proc-sentinel (proc _event)
- "Delete auxiliary process when we are deleted."
- (unless (tramp-compat-process-live-p proc)
- (tramp-message
- tramp-gw-vector 4 "Deleting auxiliary process `%s'" tramp-gw-gw-proc)
- (let* ((tramp-verbose 0)
- (p (tramp-get-connection-property proc "process" nil)))
- (when (processp p) (delete-process p)))))
-
-(defun tramp-gw-aux-proc-sentinel (proc _event)
- "Activate the different filters for involved gateway and auxiliary
processes."
- (when (tramp-compat-process-live-p proc)
- ;; A new process has been spawned from `tramp-gw-aux-proc'.
- (tramp-message
- tramp-gw-vector 4
- "Opening auxiliary process `%s', speaking with process `%s'"
- proc tramp-gw-gw-proc)
- (set-process-query-on-exit-flag proc nil)
- ;; We don't want debug messages, because the corresponding debug
- ;; buffer might be undecided.
- (let ((tramp-verbose 0))
- (tramp-set-connection-property tramp-gw-gw-proc "process" proc)
- (tramp-set-connection-property proc "process" tramp-gw-gw-proc))
- ;; Set the process-filter functions for both processes.
- (set-process-filter proc 'tramp-gw-process-filter)
- (set-process-filter tramp-gw-gw-proc 'tramp-gw-process-filter)
- ;; There might be already some output from the gateway process.
- (with-current-buffer (process-buffer tramp-gw-gw-proc)
- (unless (= (point-min) (point-max))
- (let ((s (buffer-string)))
- (delete-region (point) (point-max))
- (tramp-gw-process-filter tramp-gw-gw-proc s))))))
-
-(defun tramp-gw-process-filter (proc string)
- "Resend the string to the other process."
- (let ((tramp-verbose 0))
- ;; The other process might have been stopped already. We don't
- ;; want to be interrupted then.
- (ignore-errors
- (process-send-string
- (tramp-get-connection-property proc "process" nil) string))))
-
-;;;###tramp-autoload
-(defun tramp-gw-open-connection (vec gw-vec target-vec)
- "Open a remote connection to VEC (see `tramp-file-name' structure).
-Take GW-VEC as SOCKS or HTTP gateway, i.e. its method must be a
-gateway method. TARGET-VEC identifies where to connect to via
-the gateway, it can be different from VEC when there are more
-hops to be applied.
-
-It returns a string like \"localhost#port\", which must be used
-instead of the host name declared in TARGET-VEC."
-
- ;; Remember vectors for property retrieval.
- (setq tramp-gw-vector vec
- tramp-gw-gw-vector gw-vec)
-
- ;; Start listening auxiliary process.
- (unless (tramp-compat-process-live-p tramp-gw-aux-proc)
- (let ((aux-vec
- (vector "aux" (tramp-file-name-user gw-vec)
- (tramp-file-name-host gw-vec) nil nil)))
- (setq tramp-gw-aux-proc
- (make-network-process
- :name (tramp-buffer-name aux-vec) :buffer nil :host 'local
- :server t :noquery t :service t :coding 'binary))
- (set-process-sentinel tramp-gw-aux-proc 'tramp-gw-aux-proc-sentinel)
- (set-process-query-on-exit-flag tramp-gw-aux-proc nil)
- (tramp-message
- vec 4 "Opening auxiliary process `%s', listening on port %d"
- tramp-gw-aux-proc (process-contact tramp-gw-aux-proc :service))))
-
- (let* ((gw-method
- (intern
- (tramp-find-method
- (tramp-file-name-method gw-vec)
- (tramp-file-name-user gw-vec)
- (tramp-file-name-host gw-vec))))
- (socks-username
- (tramp-find-user
- (tramp-file-name-method gw-vec)
- (tramp-file-name-user gw-vec)
- (tramp-file-name-host gw-vec)))
- ;; Declare the SOCKS server to be used.
- (socks-server
- (list "Tramp temporary socks server list"
- ;; Host name.
- (tramp-file-name-real-host gw-vec)
- ;; Port number.
- (or (tramp-file-name-port gw-vec)
- (case gw-method
- (tunnel tramp-gw-default-tunnel-port)
- (socks tramp-gw-default-socks-port)))
- ;; Type. We support only http and socks5, NO socks4.
- ;; 'http could be used when HTTP tunnel works in socks.el.
- 5))
- ;; The function to be called.
- (socks-function
- (case gw-method
- (tunnel 'tramp-gw-open-network-stream)
- (socks 'socks-open-network-stream)))
- socks-noproxy)
-
- ;; Open SOCKS process.
- (setq tramp-gw-gw-proc
- (funcall
- socks-function
- (let ((tramp-verbose 0)) (tramp-get-connection-name gw-vec))
- (let ((tramp-verbose 0)) (tramp-get-connection-buffer gw-vec))
- (tramp-file-name-real-host target-vec)
- (tramp-file-name-port target-vec)))
- (set-process-sentinel tramp-gw-gw-proc 'tramp-gw-gw-proc-sentinel)
- (set-process-coding-system tramp-gw-gw-proc 'binary 'binary)
- (set-process-query-on-exit-flag tramp-gw-gw-proc nil)
- (tramp-message
- vec 4 "Opened %s process `%s'"
- (case gw-method ('tunnel "HTTP tunnel") ('socks "SOCKS"))
- tramp-gw-gw-proc)
-
- ;; Return the new host for gateway access.
- (format "localhost#%d" (process-contact tramp-gw-aux-proc :service))))
-
-(defun tramp-gw-open-network-stream (name buffer host service)
- "Open stream to proxy server HOST:SERVICE.
-Resulting process has name NAME and buffer BUFFER. If
-authentication is requested from proxy server, provide it."
- (let ((command (format (concat
- "CONNECT %s:%d HTTP/1.1\r\n"
- "Host: %s:%d\r\n"
- "Connection: keep-alive\r\n"
- "User-Agent: Tramp/%s\r\n")
- host service host service tramp-version))
- (authentication "")
- (first t)
- found proc)
-
- (while (not found)
- ;; Clean up.
- (when (processp proc) (delete-process proc))
- (with-current-buffer buffer (erase-buffer))
- ;; Open network stream.
- (setq proc (open-network-stream
- name buffer (nth 1 socks-server) (nth 2 socks-server)))
- (set-process-coding-system proc 'binary 'binary)
- (set-process-query-on-exit-flag proc nil)
- ;; Send CONNECT command.
- (process-send-string proc (format "%s%s\r\n" command authentication))
- (tramp-message
- tramp-gw-vector 6 "\n%s"
- (format
- "%s%s\r\n" command
- (replace-regexp-in-string ;; no password in trace!
- "Basic [^\r\n]+" "Basic xxxxx" authentication t)))
- (with-current-buffer buffer
- ;; Trap errors to be traced in the right trace buffer. Often,
- ;; proxies have a timeout of 60". We wait 65" in order to
- ;; receive an answer this case.
- (ignore-errors
- (let ((tramp-verbose 0))
- (tramp-wait-for-regexp proc 65 "\r?\n\r?\n")))
- ;; Check return code.
- (goto-char (point-min))
- (narrow-to-region
- (point-min)
- (or (search-forward-regexp "\r?\n\r?\n" nil t) (point-max)))
- (tramp-message tramp-gw-vector 6 "\n%s" (buffer-string))
- (goto-char (point-min))
- (search-forward-regexp "^HTTP/[1-9]\\.[0-9]" nil t)
- (case (condition-case nil (read (current-buffer)) (error))
- ;; Connected.
- (200 (setq found t))
- ;; We need basic authentication.
- (401 (setq authentication (tramp-gw-basic-authentication nil first)))
- ;; Access forbidden.
- (403 (tramp-error-with-buffer
- (current-buffer) tramp-gw-vector 'file-error
- "Connection to %s:%d forbidden." host service))
- ;; Target host not found.
- (404 (tramp-error-with-buffer
- (current-buffer) tramp-gw-vector 'file-error
- "Host %s not found." host))
- ;; We need basic proxy authentication.
- (407 (setq authentication (tramp-gw-basic-authentication t first)))
- ;; Connection failed.
- (503 (tramp-error-with-buffer
- (current-buffer) tramp-gw-vector 'file-error
- "Connection to %s:%d failed." host service))
- ;; That doesn't work at all.
- (t (tramp-error-with-buffer
- (current-buffer) tramp-gw-vector 'file-error
- "Access to HTTP server %s:%d failed."
- (nth 1 socks-server) (nth 2 socks-server))))
- ;; Remove HTTP headers.
- (delete-region (point-min) (point-max))
- (widen)
- (setq first nil)))
- ;; Return the process.
- proc))
-
-(defun tramp-gw-basic-authentication (proxy pw-cache)
- "Return authentication header for CONNECT, based on server request.
-PROXY is an indication whether we need a Proxy-Authorization header
-or an Authorization header. If PW-CACHE is non-nil, check for
-password in password cache. This is done for the first try only."
-
- ;; `tramp-current-*' must be set for `tramp-read-passwd'.
- (let ((tramp-current-method (tramp-file-name-method tramp-gw-gw-vector))
- (tramp-current-user (tramp-file-name-user tramp-gw-gw-vector))
- (tramp-current-host (tramp-file-name-host tramp-gw-gw-vector)))
- (unless pw-cache (tramp-clear-passwd tramp-gw-gw-vector))
- ;; We are already in the right buffer.
- (tramp-message
- tramp-gw-vector 5 "%s required"
- (if proxy "Proxy authentication" "Authentication"))
- ;; Search for request header. We accept only basic authentication.
- (goto-char (point-min))
- (search-forward-regexp
- "^\\(Proxy\\|WWW\\)-Authenticate:\\s-*Basic\\s-+realm=")
- ;; Return authentication string.
- (format
- "%s: Basic %s\r\n"
- (if proxy "Proxy-Authorization" "Authorization")
- (base64-encode-string
- (format
- "%s:%s"
- socks-username
- (tramp-read-passwd
- nil
- (format
- "Password for address@hidden: " socks-username (read
(current-buffer)))))))))
-
-(add-hook 'tramp-unload-hook
- (lambda ()
- (unload-feature 'tramp-gw 'force)))
-
-(provide 'tramp-gw)
-
-;;; TODO:
-
-;; * Provide descriptive Commentary.
-;;
-;; * Enable it for several gateway processes in parallel.
-;;
-;; * Use `url-https-proxy-connect' as of Emacs 26.
-
-;;; tramp-gw.el ends here
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index 52746f6..57cb6e1 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -32,8 +32,6 @@
(eval-when-compile
(require 'cl)
(require 'dired))
-(defvar tramp-gw-tunnel-method)
-(defvar tramp-gw-socks-method)
(defvar vc-handled-backends)
(defvar vc-bzr-program)
(defvar vc-git-program)
@@ -172,11 +170,7 @@ The string is used in `tramp-methods'.")
(tramp-copy-program "scp")
(tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q") ("-r") ("%c")))
(tramp-copy-keep-date t)
- (tramp-copy-recursive t)
- (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
- ("-o" "UserKnownHostsFile=/dev/null")
- ("-o" "StrictHostKeyChecking=no")))
- (tramp-default-port 22)))
+ (tramp-copy-recursive t)))
;;;###tramp-autoload
(add-to-list 'tramp-methods
'("scpx"
@@ -191,11 +185,7 @@ The string is used in `tramp-methods'.")
(tramp-copy-args (("-P" "%p") ("-p" "%k")
("-q") ("-r") ("%c")))
(tramp-copy-keep-date t)
- (tramp-copy-recursive t)
- (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
- ("-o" "UserKnownHostsFile=/dev/null")
- ("-o" "StrictHostKeyChecking=no")))
- (tramp-default-port 22)))
+ (tramp-copy-recursive t)))
;;;###tramp-autoload
(add-to-list 'tramp-methods
'("rsync"
@@ -237,11 +227,7 @@ The string is used in `tramp-methods'.")
(tramp-async-args (("-q")))
(tramp-remote-shell "/bin/sh")
(tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))
- (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
- ("-o" "UserKnownHostsFile=/dev/null")
- ("-o" "StrictHostKeyChecking=no")))
- (tramp-default-port 22)))
+ (tramp-remote-shell-args ("-c"))))
;;;###tramp-autoload
(add-to-list 'tramp-methods
'("sshx"
@@ -251,11 +237,7 @@ The string is used in `tramp-methods'.")
(tramp-async-args (("-q")))
(tramp-remote-shell "/bin/sh")
(tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))
- (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null")
- ("-o" "UserKnownHostsFile=/dev/null")
- ("-o" "StrictHostKeyChecking=no")))
- (tramp-default-port 22)))
+ (tramp-remote-shell-args ("-c"))))
;;;###tramp-autoload
(add-to-list 'tramp-methods
'("telnet"
@@ -263,8 +245,7 @@ The string is used in `tramp-methods'.")
(tramp-login-args (("%h") ("%p") ("2>/dev/null")))
(tramp-remote-shell "/bin/sh")
(tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))
- (tramp-default-port 23)))
+ (tramp-remote-shell-args ("-c"))))
;;;###tramp-autoload
(add-to-list 'tramp-methods
'("nc"
@@ -280,8 +261,7 @@ The string is used in `tramp-methods'.")
;; We use "-p" as required for newer busyboxes. For older
;; busybox/nc versions, the value must be (("-l") ("%r")). This
;; can be achieved by tweaking `tramp-connection-properties'.
- (tramp-remote-copy-args (("-l") ("-p" "%r") ("2>/dev/null")))
- (tramp-default-port 23)))
+ (tramp-remote-copy-args (("-l") ("-p" "%r") ("2>/dev/null")))))
;;;###tramp-autoload
(add-to-list 'tramp-methods
'("su"
@@ -353,8 +333,7 @@ The string is used in `tramp-methods'.")
("/bin/sh") ("\"")))
(tramp-remote-shell "/bin/sh")
(tramp-remote-shell-login ("-l"))
- (tramp-remote-shell-args ("-c"))
- (tramp-default-port 22)))
+ (tramp-remote-shell-args ("-c"))))
;;;###tramp-autoload
(add-to-list 'tramp-methods
`("plinkx"
@@ -386,8 +365,7 @@ The string is used in `tramp-methods'.")
(tramp-copy-args (("-l" "%u") ("-P" "%p") ("-scp") ("-p" "%k")
("-q") ("-r")))
(tramp-copy-keep-date t)
- (tramp-copy-recursive t)
- (tramp-default-port 22)))
+ (tramp-copy-recursive t)))
;;;###tramp-autoload
(add-to-list 'tramp-methods
`("psftp"
@@ -2227,14 +2205,8 @@ the uid and gid from FILENAME."
v 'file-error
"Unknown operation `%s', must be `copy' or `rename'"
op))))
- (localname1
- (if t1
- (file-remote-p filename 'localname)
- filename))
- (localname2
- (if t2
- (file-remote-p newname 'localname)
- newname))
+ (localname1 (if t1 (file-remote-p filename 'localname) filename))
+ (localname2 (if t2 (file-remote-p newname 'localname) newname))
(prefix (file-remote-p (if t1 filename newname)))
cmd-result)
@@ -2324,11 +2296,9 @@ the uid and gid from FILENAME."
(t2
(if (eq op 'copy)
(copy-file
- localname1 tmpfile t
- keep-date preserve-uid-gid)
+ localname1 tmpfile t keep-date preserve-uid-gid)
(tramp-run-real-handler
- 'rename-file
- (list localname1 tmpfile t)))
+ 'rename-file (list localname1 tmpfile t)))
;; We must change the ownership as local user.
;; Since this does not work reliable, we also
;; give read permissions.
@@ -2403,10 +2373,6 @@ The method used must be an out-of-band method."
v "login-as" nil))
tramp-current-host (tramp-file-name-real-host v))
- ;; Expand hops. Might be necessary for gateway methods.
- (setq v (car (tramp-compute-multi-hops v)))
- (aset v 3 localname)
-
;; Check which ones of source and target are Tramp files.
(setq source (funcall
(if (and (file-directory-p filename)
@@ -2420,15 +2386,9 @@ The method used must be an out-of-band method."
(tramp-make-copy-program-file-name v)
(tramp-unquote-shell-quote-argument newname)))
- ;; Check for host and port number. We cannot use
- ;; `tramp-file-name-port', because this returns also
- ;; `tramp-default-port', which might clash with settings in
- ;; "~/.ssh/config".
- (setq host (tramp-file-name-host v)
- port "")
- (when (string-match tramp-host-with-port-regexp host)
- (setq port (string-to-number (match-string 2 host))
- host (string-to-number (match-string 1 host))))
+ ;; Check for host and port number.
+ (setq host (tramp-file-name-real-host v)
+ port (tramp-file-name-port v))
;; Check for user. There might be an interactive setting.
(setq user (or (tramp-file-name-user v)
@@ -4209,10 +4169,11 @@ process to set up. VEC specifies the connection."
(when vars
(tramp-send-command
vec
- (format "while read var val; do export $var=$val; done <<'%s'\n%s\n%s"
- tramp-end-of-heredoc
- (mapconcat 'identity vars "\n")
- tramp-end-of-heredoc)
+ (format
+ "while read var val; do export $var=\"$val\"; done <<'%s'\n%s\n%s"
+ tramp-end-of-heredoc
+ (mapconcat 'identity vars "\n")
+ tramp-end-of-heredoc)
t))
(when unset
(tramp-send-command
@@ -4511,8 +4472,7 @@ Goes through the list `tramp-inline-compress-commands'."
vec 2 "Couldn't find an inline transfer compress command")))))
(defun tramp-compute-multi-hops (vec)
- "Expands VEC according to `tramp-default-proxies-alist'.
-Gateway hops are already opened."
+ "Expands VEC according to `tramp-default-proxies-alist'."
(let ((target-alist `(,vec))
(hops (or (tramp-file-name-hop vec) ""))
(item vec)
@@ -4569,32 +4529,6 @@ Gateway hops are already opened."
;; Start next search.
(setq choices tramp-default-proxies-alist)))))
- ;; Handle gateways.
- (when (and (boundp 'tramp-gw-tunnel-method) (boundp 'tramp-gw-socks-method)
- (string-match
- (format
- "^\\(%s\\|%s\\)$" tramp-gw-tunnel-method tramp-gw-socks-method)
- (tramp-file-name-method (car target-alist))))
- (let ((gw (pop target-alist))
- (hop (pop target-alist)))
- ;; Is the method prepared for gateways?
- (unless (tramp-file-name-port hop)
- (tramp-error
- vec 'file-error
- "Connection `%s' is not supported for gateway access." hop))
- ;; Open the gateway connection.
- (push
- (vector
- (tramp-file-name-method hop) (tramp-file-name-user hop)
- (tramp-gw-open-connection vec gw hop) nil nil)
- target-alist)
- ;; For the password prompt, we need the correct values.
- ;; Therefore, we must remember the gateway vector. But we
- ;; cannot do it as connection property, because it shouldn't
- ;; be persistent. And we have no started process yet either.
- (let ((tramp-verbose 0))
- (tramp-set-file-property (car target-alist) "" "gateway" hop))))
-
;; Foreign and out-of-band methods are not supported for multi-hops.
(when (cdr target-alist)
(setq choices target-alist)
@@ -4809,13 +4743,6 @@ connection if a previous connection has died for some
reason."
(connection-timeout
(tramp-get-method-parameter
hop 'tramp-connection-timeout))
- (gw-args
- (tramp-get-method-parameter hop 'tramp-gw-args))
- (gw (let ((tramp-verbose 0))
- (tramp-get-file-property hop "" "gateway" nil)))
- (g-method (and gw (tramp-file-name-method gw)))
- (g-user (and gw (tramp-file-name-user gw)))
- (g-host (and gw (tramp-file-name-real-host gw)))
(command login-program)
;; We don't create the temporary file. In
;; fact, it is just a prefix for the
@@ -4839,12 +4766,6 @@ connection if a previous connection has died for some
reason."
(when (and process-name async-args)
(setq login-args (append async-args login-args)))
- ;; Add gateway arguments if necessary.
- (when gw
- (tramp-set-connection-property p "gateway" t)
- (when gw-args
- (setq login-args (append gw-args login-args))))
-
;; Check for port number. Until now, there's no
;; need for handling like method, user, host.
(when (string-match tramp-host-with-port-regexp l-host)
@@ -4857,11 +4778,10 @@ connection if a previous connection has died for some
reason."
(setq r-shell t)))
;; Set variables for computing the prompt for
- ;; reading password. They can also be derived
- ;; from a gateway.
- (setq tramp-current-method (or g-method l-method)
- tramp-current-user (or g-user l-user)
- tramp-current-host (or g-host l-host))
+ ;; reading password.
+ (setq tramp-current-method l-method
+ tramp-current-user l-user
+ tramp-current-host l-host)
;; Add login environment.
(when login-env
@@ -5166,8 +5086,8 @@ Return ATTR."
(let ((method (tramp-file-name-method vec))
(user (tramp-file-name-user vec))
(host (tramp-file-name-real-host vec))
- (localname (tramp-compat-file-name-unquote
- (directory-file-name (tramp-file-name-localname vec)))))
+ (localname
+ (directory-file-name (tramp-file-name-unquote-localname vec))))
(when (string-match tramp-ipv6-regexp host)
(setq host (format "[%s]" host)))
(unless (string-match "ftp$" method)
@@ -5176,8 +5096,8 @@ Return ATTR."
((tramp-get-method-parameter vec 'tramp-remote-copy-program)
localname)
((not (zerop (length user)))
- (tramp-shell-quote-argument (format "address@hidden:%s" user host
localname)))
- (t (tramp-shell-quote-argument (format "%s:%s" host localname))))))
+ (format "address@hidden:%s" user host (shell-quote-argument localname)))
+ (t (format "%s:%s" host (shell-quote-argument localname))))))
(defun tramp-method-out-of-band-p (vec size)
"Return t if this is an out-of-band method, nil otherwise."
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index 7d0dc66..70b72d8 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -1525,8 +1525,7 @@ errors for shares like \"C$/\", which are common in
Microsoft Windows."
(defun tramp-smb-get-share (vec)
"Returns the share name of LOCALNAME."
(save-match-data
- (let ((localname
- (tramp-compat-file-name-unquote (tramp-file-name-localname vec))))
+ (let ((localname (tramp-file-name-unquote-localname vec)))
(when (string-match "^/?\\([^/]+\\)/" localname)
(match-string 1 localname)))))
@@ -1534,8 +1533,7 @@ errors for shares like \"C$/\", which are common in
Microsoft Windows."
"Returns the file name of LOCALNAME.
If VEC has no cifs capabilities, exchange \"/\" by \"\\\\\"."
(save-match-data
- (let ((localname
- (tramp-compat-file-name-unquote (tramp-file-name-localname vec))))
+ (let ((localname (tramp-file-name-unquote-localname vec)))
(setq
localname
(if (string-match "^/?[^/]+\\(/.*\\)" localname)
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 100be3a..4103a6e 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -241,12 +241,7 @@ pair of the form (KEY VALUE). The following KEYs are
defined:
* `tramp-copy-recursive'
Whether the operation copies directories recursively.
* `tramp-default-port'
- The default port of a method is needed in case of gateway connections.
- Additionally, it is used as indication which method is prepared for
- passing gateways.
- * `tramp-gw-args'
- As the attribute name says, additional arguments are specified here
- when a method is applied via a gateway.
+ The default port of a method.
* `tramp-tmpdir'
A directory on the remote host for temporary files. If not
specified, \"/tmp\" is taken as default.
@@ -277,8 +272,7 @@ See the variables `tramp-local-coding-commands' and
So, to summarize: if the method is an out-of-band method, then you
must specify `tramp-copy-program' and `tramp-copy-args'. If it is an
-inline method, then these two parameters should be nil. Methods which
-are fit for gateways must have `tramp-default-port' at least.
+inline method, then these two parameters should be nil.
Notes:
@@ -1139,13 +1133,17 @@ entry does not exist, return nil."
(defun tramp-file-name-port (vec)
"Return the port number of VEC."
(save-match-data
- (let ((method (tramp-file-name-method vec))
- (host (tramp-file-name-host vec)))
+ (let ((host (tramp-file-name-host vec)))
(or (and (stringp host)
(string-match tramp-host-with-port-regexp host)
(string-to-number (match-string 2 host)))
(tramp-get-method-parameter vec 'tramp-default-port)))))
+;; The localname can be quoted with "/:". Extract this.
+(defun tramp-file-name-unquote-localname (vec)
+ "Return unquoted localname component of VEC."
+ (tramp-compat-file-name-unquote (tramp-file-name-localname vec)))
+
;;;###tramp-autoload
(defun tramp-tramp-file-p (name)
"Return t if NAME is a string with Tramp file name syntax."
@@ -1262,9 +1260,6 @@ values."
(defun tramp-buffer-name (vec)
"A name for the connection buffer VEC."
- ;; We must use `tramp-file-name-real-host', because for gateway
- ;; methods the default port will be expanded later on, which would
- ;; tamper the name.
(let ((method (tramp-file-name-method vec))
(user (tramp-file-name-user vec))
(host (tramp-file-name-real-host vec)))
@@ -1354,9 +1349,6 @@ version, the function does nothing."
(defun tramp-debug-buffer-name (vec)
"A name for the debug buffer for VEC."
- ;; We must use `tramp-file-name-real-host', because for gateway
- ;; methods the default port will be expanded later on, which would
- ;; tamper the name.
(let ((method (tramp-file-name-method vec))
(user (tramp-file-name-user vec))
(host (tramp-file-name-real-host vec)))
@@ -1686,9 +1678,13 @@ locally on a remote file name. When the local system is
a W32 system
but the remote system is Unix, this introduces a superfluous drive
letter into the file name. This function removes it."
(save-match-data
- (if (string-match "\\`[a-zA-Z]:/" name)
- (replace-match "/" nil t name)
- name)))
+ (funcall
+ (if (tramp-compat-file-name-quoted-p name)
+ 'tramp-compat-file-name-quote 'identity)
+ (let ((name (tramp-compat-file-name-unquote name)))
+ (if (string-match "\\`[a-zA-Z]:/" name)
+ (replace-match "/" nil t name)
+ name)))))
;;; Config Manipulation Functions:
@@ -2910,7 +2906,9 @@ User is always nil."
(with-tramp-connection-property v "case-insensitive"
;; The idea is to compare a file with lower case letters
;; with the same file with upper case letters.
- (let ((candidate (directory-file-name filename))
+ (let ((candidate
+ (tramp-compat-file-name-unquote
+ (directory-file-name filename)))
tmpfile)
;; Check, whether we find an existing file with lower case
;; letters. This avoids us to create a temporary file.
@@ -3621,17 +3619,13 @@ connection buffer."
This is needed in order to hide `last-coding-system-used', which is set
for process communication also."
(with-current-buffer (process-buffer proc)
- ;; FIXME: If there is a gateway process, we need communication
- ;; between several processes. Too complicate to implement, so we
- ;; read output from all processes.
- (let ((p (if (tramp-get-connection-property proc "gateway" nil) nil proc))
- buffer-read-only last-coding-system-used)
+ (let (buffer-read-only last-coding-system-used)
;; Under Windows XP, accept-process-output doesn't return
;; sometimes. So we add an additional timeout.
(with-timeout ((or timeout 1))
- (accept-process-output p timeout timeout-msecs (and proc t)))
- (tramp-message proc 10 "%s %s %s\n%s"
- proc (process-status proc) p (buffer-string)))))
+ (accept-process-output proc timeout timeout-msecs (and proc t)))
+ (tramp-message proc 10 "%s %s\n%s"
+ proc (process-status proc) (buffer-string)))))
(defun tramp-check-for-regexp (proc regexp)
"Check, whether REGEXP is contained in process buffer of PROC.
diff --git a/lisp/gs.el b/lisp/obsolete/gs.el
similarity index 97%
rename from lisp/gs.el
rename to lisp/obsolete/gs.el
index 7ab3d8b..c4cdceb 100644
--- a/lisp/gs.el
+++ b/lisp/obsolete/gs.el
@@ -4,6 +4,7 @@
;; Maintainer: address@hidden
;; Keywords: internal
+;; Obsolete-since: 26.1
;; This file is part of GNU Emacs.
@@ -22,7 +23,9 @@
;;; Commentary:
-;; This code is experimental. Don't use it.
+;; This code is experimental. Don't use it. Try imagemagick images instead.
+;; When this file is removed from Emacs, associated code in image.c
+;; can be removed too (HAVE_GHOSTSCRIPT).
;;; Code:
diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el
index f2e397a..7f20e79 100644
--- a/lisp/progmodes/compile.el
+++ b/lisp/progmodes/compile.el
@@ -130,7 +130,7 @@ and a string describing how the process finished.")
(defvar compilation-num-errors-found)
;; If you make any changes to `compilation-error-regexp-alist-alist',
-;; be sure to run the ERT test in test/automated/compile-tests.el.
+;; be sure to run the ERT test in test/lisp/progmodes/compile-tests.el.
;; emacs -batch -l compile-tests.el -f ert-run-tests-batch-and-exit
(defvar compilation-error-regexp-alist-alist
@@ -230,6 +230,13 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
nil 1 nil 2 0
(2 (compilation-face '(3))))
+ (clang-include
+ ,(rx bol "In file included from "
+ (group (+ (not (any ?\n ?:)))) ?:
+ (group (+ (any (?0 . ?9)))) ?:
+ eol)
+ 1 2 nil 0)
+
(gcc-include
"^\\(?:In file included \\| \\|\t\\)from \
\\([0-9]*[^0-9\n]\\(?:[^\n :]\\| [^-/\n]\\|:[^ \n]\\)*?\\):\
diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el
index 9658b8b..1138b4d 100644
--- a/lisp/progmodes/cperl-mode.el
+++ b/lisp/progmodes/cperl-mode.el
@@ -4,7 +4,7 @@
;; Author: Ilya Zakharevich
;; Bob Olson
-;; Maintainer: Ilya Zakharevich <address@hidden>
+;; Maintainer: address@hidden
;; Keywords: languages, Perl
;; This file is part of GNU Emacs.
@@ -1126,7 +1126,28 @@ versions of Emacs."
;; expansion manually. Any other suggestions?
(require 'cl))
-(defvar cperl-mode-abbrev-table nil
+(define-abbrev-table 'cperl-mode-abbrev-table
+ '(
+ ("if" "if" cperl-electric-keyword :system t)
+ ("elsif" "elsif" cperl-electric-keyword :system t)
+ ("while" "while" cperl-electric-keyword :system t)
+ ("until" "until" cperl-electric-keyword :system t)
+ ("unless" "unless" cperl-electric-keyword :system t)
+ ("else" "else" cperl-electric-else :system t)
+ ("continue" "continue" cperl-electric-else :system t)
+ ("for" "for" cperl-electric-keyword :system t)
+ ("foreach" "foreach" cperl-electric-keyword :system t)
+ ("formy" "formy" cperl-electric-keyword :system t)
+ ("foreachmy" "foreachmy" cperl-electric-keyword :system t)
+ ("do" "do" cperl-electric-keyword :system t)
+ ("=pod" "=pod" cperl-electric-pod :system t)
+ ("=over" "=over" cperl-electric-pod :system t)
+ ("=head1" "=head1" cperl-electric-pod :system t)
+ ("=head2" "=head2" cperl-electric-pod :system t)
+ ("pod" "pod" cperl-electric-pod :system t)
+ ("over" "over" cperl-electric-pod :system t)
+ ("head1" "head1" cperl-electric-pod :system t)
+ ("head2" "head2" cperl-electric-pod :system t))
"Abbrev table in use in CPerl mode buffers.")
(add-hook 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-")))
@@ -1708,29 +1729,6 @@ or as help on variables `cperl-tips', `cperl-problems',
(cperl-define-key "\C-hf" 'cperl-info-on-current-command [(control h)
f])
(cperl-define-key "\C-c\C-hf" 'cperl-info-on-command
[(control c) (control h) f])))
- (let ((prev-a-c abbrevs-changed))
- (define-abbrev-table 'cperl-mode-abbrev-table '(
- ("if" "if" cperl-electric-keyword 0)
- ("elsif" "elsif" cperl-electric-keyword 0)
- ("while" "while" cperl-electric-keyword 0)
- ("until" "until" cperl-electric-keyword 0)
- ("unless" "unless" cperl-electric-keyword 0)
- ("else" "else" cperl-electric-else 0)
- ("continue" "continue" cperl-electric-else 0)
- ("for" "for" cperl-electric-keyword 0)
- ("foreach" "foreach" cperl-electric-keyword 0)
- ("formy" "formy" cperl-electric-keyword 0)
- ("foreachmy" "foreachmy" cperl-electric-keyword 0)
- ("do" "do" cperl-electric-keyword 0)
- ("=pod" "=pod" cperl-electric-pod 0)
- ("=over" "=over" cperl-electric-pod 0)
- ("=head1" "=head1" cperl-electric-pod 0)
- ("=head2" "=head2" cperl-electric-pod 0)
- ("pod" "pod" cperl-electric-pod 0)
- ("over" "over" cperl-electric-pod 0)
- ("head1" "head1" cperl-electric-pod 0)
- ("head2" "head2" cperl-electric-pod 0)))
- (setq abbrevs-changed prev-a-c))
(setq local-abbrev-table cperl-mode-abbrev-table)
(if (cperl-val 'cperl-electric-keywords)
(abbrev-mode 1))
diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el
index 5368b61..4e9b43b 100644
--- a/lisp/progmodes/verilog-mode.el
+++ b/lisp/progmodes/verilog-mode.el
@@ -1416,8 +1416,10 @@ If set will become buffer local.")
(define-key map "\M-\C-b" 'electric-verilog-backward-sexp)
(define-key map "\M-\C-f" 'electric-verilog-forward-sexp)
(define-key map "\M-\r" `electric-verilog-terminate-and-indent)
- (define-key map "\M-\t" 'verilog-complete-word)
- (define-key map "\M-?" 'verilog-show-completions)
+ (define-key map "\M-\t" (if (fboundp 'completion-at-point)
+ 'completion-at-point
'verilog-complete-word))
+ (define-key map "\M-?" (if (fboundp 'completion-help-at-point)
+ 'completion-help-at-point
'verilog-show-completions))
;; Note \C-c and letter are reserved for users
(define-key map "\C-c`" 'verilog-lint-off)
(define-key map "\C-c*" 'verilog-delete-auto-star-implicit)
@@ -1448,7 +1450,7 @@ If set will become buffer local.")
(easy-menu-define
verilog-menu verilog-mode-map "Menu for Verilog mode"
(verilog-easy-menu-filter
- '("Verilog"
+ `("Verilog"
("Choose Compilation Action"
["None"
(progn
@@ -1540,7 +1542,8 @@ If set will become buffer local.")
:help "Take a signal vector on the current line and expand it
to multiple lines"]
["Insert begin-end block" verilog-insert-block
:help "Insert begin ... end"]
- ["Complete word" verilog-complete-word
+ ["Complete word" ,(if (fboundp 'completion-at-point)
+ 'completion-at-point 'verilog-complete-word)
:help "Complete word at point"]
"----"
["Recompute AUTOs" verilog-auto
@@ -3806,7 +3809,7 @@ AUTO expansion functions are, in part:
Some other functions are:
- \\[verilog-complete-word] Complete word with appropriate possibilities.
+ \\[completion-at-point] Complete word with appropriate possibilities.
\\[verilog-mark-defun] Mark function.
\\[verilog-beg-of-defun] Move to beginning of current function.
\\[verilog-end-of-defun] Move to end of current function.
@@ -3920,6 +3923,9 @@ Key bindings specific to `verilog-mode-map' are:
verilog-forward-sexp-function)
hs-special-modes-alist))))
+ (add-hook 'completion-at-point-functions
+ #'verilog-completion-at-point nil 'local)
+
;; Stuff for autos
(add-hook 'write-contents-hooks 'verilog-auto-save-check nil 'local)
;; verilog-mode-hook call added by define-derived-mode
@@ -7198,6 +7204,9 @@ Region is defined by B and EDPOS."
Repeated use of \\[verilog-complete-word] will show you all of them.
Normally, when there is more than one possible completion,
it displays a list of all possible completions.")
+(when (boundp 'completion-cycle-threshold)
+ (make-obsolete-variable
+ 'verilog-toggle-completions 'completion-cycle-threshold "26.1"))
(defvar verilog-type-keywords
@@ -7480,21 +7489,33 @@ exact match, nil otherwise."
(defvar verilog-last-word-shown nil)
(defvar verilog-last-completions nil)
+(defun verilog-completion-at-point ()
+ "Used as an element of `completion-at-point-functions'.
+\(See also `verilog-type-keywords' and
+`verilog-separator-keywords'.)"
+ (let* ((b (save-excursion (skip-chars-backward "a-zA-Z0-9_") (point)))
+ (e (save-excursion (skip-chars-forward "a-zA-Z0-9_") (point)))
+ (verilog-str (buffer-substring b e))
+ ;; The following variable is used in verilog-completion
+ (verilog-buffer-to-use (current-buffer))
+ (allcomp (if (and verilog-toggle-completions
+ (string= verilog-last-word-shown verilog-str))
+ verilog-last-completions
+ (all-completions verilog-str 'verilog-completion))))
+ (list b e allcomp)))
+
(defun verilog-complete-word ()
"Complete word at current point.
\(See also `verilog-toggle-completions', `verilog-type-keywords',
and `verilog-separator-keywords'.)"
- ;; FIXME: Provide completion-at-point-function.
+ ;; NOTE: This is just a fallback for Emacs versions lacking
+ ;; `completion-at-point'.
(interactive)
- (let* ((b (save-excursion (skip-chars-backward "a-zA-Z0-9_") (point)))
- (e (save-excursion (skip-chars-forward "a-zA-Z0-9_") (point)))
+ (let* ((comp-info (verilog-completion-at-point))
+ (b (nth 0 comp-info))
+ (e (nth 1 comp-info))
(verilog-str (buffer-substring b e))
- ;; The following variable is used in verilog-completion
- (verilog-buffer-to-use (current-buffer))
- (allcomp (if (and verilog-toggle-completions
- (string= verilog-last-word-shown verilog-str))
- verilog-last-completions
- (all-completions verilog-str 'verilog-completion)))
+ (allcomp (nth 2 comp-info))
(match (if verilog-toggle-completions
"" (try-completion
verilog-str (mapcar (lambda (elm)
@@ -7542,23 +7563,15 @@ and `verilog-separator-keywords'.)"
(defun verilog-show-completions ()
"Show all possible completions at current point."
+ ;; NOTE: This is just a fallback for Emacs versions lacking
+ ;; `completion-help-at-point'.
(interactive)
- (let* ((b (save-excursion (skip-chars-backward "a-zA-Z0-9_") (point)))
- (e (save-excursion (skip-chars-forward "a-zA-Z0-9_") (point)))
- (verilog-str (buffer-substring b e))
- ;; The following variable is used in verilog-completion
- (verilog-buffer-to-use (current-buffer))
- (allcomp (if (and verilog-toggle-completions
- (string= verilog-last-word-shown verilog-str))
- verilog-last-completions
- (all-completions verilog-str 'verilog-completion))))
- ;; Show possible completions in a temporary buffer.
- (with-output-to-temp-buffer "*Completions*"
- (display-completion-list allcomp))
- ;; Wait for a key press. Then delete *Completion* window
- (momentary-string-display "" (point))
- (delete-window (get-buffer-window (get-buffer "*Completions*")))))
-
+ ;; Show possible completions in a temporary buffer.
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list (nth 2 (verilog-completion-at-point))))
+ ;; Wait for a key press. Then delete *Completion* window
+ (momentary-string-display "" (point))
+ (delete-window (get-buffer-window (get-buffer "*Completions*"))))
(defun verilog-get-default-symbol ()
"Return symbol around current point as a string."
diff --git a/lisp/shell.el b/lisp/shell.el
index d1b2e87..cabd1e5 100644
--- a/lisp/shell.el
+++ b/lisp/shell.el
@@ -590,6 +590,7 @@ buffer."
((string-equal shell "ksh") "echo $PWD ~-")
;; Bypass any aliases. TODO all shells could use this.
((string-equal shell "bash") "command dirs")
+ ((string-equal shell "zsh") "dirs -l")
(t "dirs")))
;; Bypass a bug in certain versions of bash.
(when (string-equal shell "bash")
diff --git a/lisp/subr.el b/lisp/subr.el
index 7d4409e..89ceb9b 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -1310,8 +1310,7 @@ be a list of the form returned by `event-start' and
`event-end'."
(make-obsolete 'focus-frame "it does nothing." "22.1")
(defalias 'unfocus-frame 'ignore "")
(make-obsolete 'unfocus-frame "it does nothing." "22.1")
-(make-obsolete 'make-variable-frame-local
- "explicitly check for a frame-parameter instead." "22.2")
+
(set-advertised-calling-convention
'all-completions '(string collection &optional predicate) "23.1")
(set-advertised-calling-convention 'unintern '(name obarray) "23.3")
@@ -4334,6 +4333,51 @@ The properties used on SYMBOL are `composefunc',
`sendfunc',
(put symbol 'sendfunc sendfunc)
(put symbol 'abortfunc (or abortfunc 'kill-buffer))
(put symbol 'hookvar (or hookvar 'mail-send-hook)))
+
+
+(defun backtrace--print-frame (evald func args flags)
+ "Print a trace of a single stack frame to `standard-output'.
+EVALD, FUNC, ARGS, FLAGS are as in `mapbacktrace'."
+ (princ (if (plist-get flags :debug-on-exit) "* " " "))
+ (cond
+ ((and evald (not debugger-stack-frame-as-list))
+ (prin1 func)
+ (if args (prin1 args) (princ "()")))
+ (t
+ (prin1 (cons func args))))
+ (princ "\n"))
+
+(defun backtrace ()
+ "Print a trace of Lisp function calls currently active.
+Output stream used is value of `standard-output'."
+ (let ((print-level (or print-level 8)))
+ (mapbacktrace #'backtrace--print-frame 'backtrace)))
+
+(defun backtrace-frames (&optional base)
+ "Collect all frames of current backtrace into a list.
+If non-nil, BASE should be a function, and frames before its
+nearest activation frames are discarded."
+ (let ((frames nil))
+ (mapbacktrace (lambda (&rest frame) (push frame frames))
+ (or base 'backtrace-frames))
+ (nreverse frames)))
+
+(defun backtrace-frame (nframes &optional base)
+ "Return the function and arguments NFRAMES up from current execution point.
+If non-nil, BASE should be a function, and NFRAMES counts from its
+nearest activation frame.
+If the frame has not evaluated the arguments yet (or is a special form),
+the value is (nil FUNCTION ARG-FORMS...).
+If the frame has evaluated its arguments and called its function already,
+the value is (t FUNCTION ARG-VALUES...).
+A &rest arg is represented as the tail of the list ARG-VALUES.
+FUNCTION is whatever was supplied as car of evaluated list,
+or a lambda expression for macro calls.
+If NFRAMES is more than the number of frames, the value is nil."
+ (backtrace-frame--internal
+ (lambda (evald func args _) `(,evald ,func ,@args))
+ nframes (or base 'backtrace-frame)))
+
(defvar called-interactively-p-functions nil
"Special hook called to skip special frames in `called-interactively-p'.
@@ -4953,6 +4997,20 @@ as a list.")
"-pkg.el"))
+;;; Thread support.
+
+(defmacro with-mutex (mutex &rest body)
+ "Invoke BODY with MUTEX held, releasing MUTEX when done.
+This is the simplest safe way to acquire and release a mutex."
+ (declare (indent 1) (debug t))
+ (let ((sym (make-symbol "mutex")))
+ `(let ((,sym ,mutex))
+ (mutex-lock ,sym)
+ (unwind-protect
+ (progn ,@body)
+ (mutex-unlock ,sym)))))
+
+
;;; Misc.
(defvar definition-prefixes (make-hash-table :test 'equal)
diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el
index 29aa231..bfe839a 100644
--- a/lisp/textmodes/flyspell.el
+++ b/lisp/textmodes/flyspell.el
@@ -447,12 +447,7 @@ like <img alt=\"Some thing.\">."
;;* The minor mode declaration. */
;;*---------------------------------------------------------------------*/
(defvar flyspell-mouse-map
- (let ((map (make-sparse-keymap)))
- (if (featurep 'xemacs)
- (define-key map [button2] #'flyspell-correct-word)
- (define-key map [down-mouse-2] #'flyspell-correct-word)
- (define-key map [mouse-2] 'undefined))
- map)
+ (make-sparse-keymap)
"Keymap for Flyspell to put on erroneous words.")
(defvar flyspell-mode-map
@@ -652,9 +647,7 @@ in your init file.
;; the welcome message
(if (and flyspell-issue-message-flag
flyspell-issue-welcome-flag
- (if (featurep 'xemacs)
- (interactive-p) ;; XEmacs does not have (called-interactively-p)
- (called-interactively-p 'interactive)))
+ (called-interactively-p 'interactive))
(let ((binding (where-is-internal 'flyspell-auto-correct-word
nil 'non-ascii)))
(message "%s"
@@ -1179,9 +1172,7 @@ misspelling and skips redundant spell-checking step."
(ispell-send-string (concat "^" word "\n"))
;; we mark the ispell process so it can be killed
;; when emacs is exited without query
- (if (featurep 'xemacs)
- (process-kill-without-query ispell-process)
- (set-process-query-on-exit-flag ispell-process nil))
+ (set-process-query-on-exit-flag ispell-process nil)
;; Wait until ispell has processed word.
(while (progn
(accept-process-output ispell-process)
@@ -1716,15 +1707,7 @@ FLYSPELL-BUFFER."
;;*---------------------------------------------------------------------*/
(defun flyspell-delete-region-overlays (beg end)
"Delete overlays used by flyspell in a given region."
- (if (featurep 'emacs)
- (remove-overlays beg end 'flyspell-overlay t)
- ;; XEmacs does not have `remove-overlays'
- (let ((l (overlays-in beg end)))
- (while (consp l)
- (progn
- (if (flyspell-overlay-p (car l))
- (delete-overlay (car l)))
- (setq l (cdr l)))))))
+ (remove-overlays beg end 'flyspell-overlay t))
(defun flyspell-delete-all-overlays ()
"Delete all the overlays used by flyspell."
@@ -1966,7 +1949,7 @@ This command proposes various successive corrections for
the current word."
(funcall flyspell-insert-function word)
(flyspell-word)
(flyspell-display-next-corrections flyspell-auto-correct-ring))
- (flyspell-ajust-cursor-point pos (point) old-max)
+ (flyspell-adjust-cursor-point pos (point) old-max)
(setq flyspell-auto-correct-pos (point)))
;; Fetch the word to be checked.
(let ((word (flyspell-get-word)))
@@ -2033,7 +2016,7 @@ This command proposes various successive corrections for
the current word."
(flyspell-word)
(flyspell-display-next-corrections
(cons new-word
flyspell-auto-correct-ring))
- (flyspell-ajust-cursor-point pos
+ (flyspell-adjust-cursor-point pos
(point)
old-max))))))))))
(setq flyspell-auto-correct-pos (point))
@@ -2156,10 +2139,7 @@ If OPOINT is non-nil, restore point there after
adjusting it for replacement."
((null poss)
;; ispell error
(error "Ispell: error in Ispell process"))
- ((featurep 'xemacs)
- (flyspell-xemacs-popup
- poss word cursor-location start end opoint))
- (t
+ (t
;; The word is incorrect, we have to propose a replacement.
(flyspell-do-correct (flyspell-emacs-popup event poss word)
poss word cursor-location start end opoint)))
@@ -2170,17 +2150,12 @@ If OPOINT is non-nil, restore point there after
adjusting it for replacement."
;;*---------------------------------------------------------------------*/
(defun flyspell-do-correct (replace poss word cursor-location start end save)
"The popup menu callback."
- ;; Originally, the XEmacs code didn't do the (goto-char save) here and did
- ;; it instead right after calling the function.
(cond ((eq replace 'ignore)
(goto-char save)
nil)
((eq replace 'save)
(goto-char save)
(ispell-send-string (concat "*" word "\n"))
- ;; This was added only to the XEmacs side in revision 1.18 of
- ;; flyspell. I assume its absence on the Emacs side was an
- ;; oversight. --Stef
(ispell-send-string "#\n")
(flyspell-unhighlight-at cursor-location)
(setq ispell-pdict-modified-p '(t)))
@@ -2197,8 +2172,6 @@ If OPOINT is non-nil, restore point there after adjusting
it for replacement."
(if (eq replace 'buffer)
(ispell-add-per-file-word-list word)))
(replace
- ;; This was added only to the Emacs side. I assume its absence on
- ;; the XEmacs side was an oversight. --Stef
(flyspell-unhighlight-at cursor-location)
(let ((old-max (point-max))
(new-word (if (atom replace)
@@ -2212,17 +2185,15 @@ If OPOINT is non-nil, restore point there after
adjusting it for replacement."
(funcall flyspell-insert-function new-word)
(if flyspell-abbrev-p
(flyspell-define-abbrev word new-word)))
- ;; In the original Emacs code, this was only called in the body
- ;; of the if. I arbitrarily kept the XEmacs behavior instead.
- (flyspell-ajust-cursor-point save cursor-location old-max)))
+ (flyspell-adjust-cursor-point save cursor-location old-max)))
(t
(goto-char save)
nil)))
;;*---------------------------------------------------------------------*/
-;;* flyspell-ajust-cursor-point ... */
+;;* flyspell-adjust-cursor-point ... */
;;*---------------------------------------------------------------------*/
-(defun flyspell-ajust-cursor-point (save cursor-location old-max)
+(defun flyspell-adjust-cursor-point (save cursor-location old-max)
(if (>= save cursor-location)
(let ((new-pos (+ save (- (point-max) old-max))))
(goto-char (cond
@@ -2276,78 +2247,6 @@ If OPOINT is non-nil, restore point there after
adjusting it for replacement."
menu)))))
;;*---------------------------------------------------------------------*/
-;;* flyspell-xemacs-popup ... */
-;;*---------------------------------------------------------------------*/
-(defun flyspell-xemacs-popup (poss word cursor-location start end save)
- "The XEmacs popup menu."
- (let* ((corrects (flyspell-sort (car (cdr (cdr poss))) word))
- (cor-menu (if (consp corrects)
- (mapcar (lambda (correct)
- (vector correct
- (list 'flyspell-do-correct
- correct
- (list 'quote poss)
- word
- cursor-location
- start
- end
- save)
- t))
- corrects)
- '()))
- (affix (car (cdr (cdr (cdr poss)))))
- show-affix-info
- (menu (let ((save (if (and (consp affix) show-affix-info)
- (vector
- (concat "Save affix: " (car affix))
- (list 'flyspell-do-correct
- ''save
- (list 'quote poss)
- word
- cursor-location
- start
- end
- save)
- t)
- (vector
- "Save word"
- (list 'flyspell-do-correct
- ''save
- (list 'quote poss)
- word
- cursor-location
- start
- end
- save)
- t)))
- (session (vector "Accept (session)"
- (list 'flyspell-do-correct
- ''session
- (list 'quote poss)
- word
- cursor-location
- start
- end
- save)
- t))
- (buffer (vector "Accept (buffer)"
- (list 'flyspell-do-correct
- ''buffer
- (list 'quote poss)
- word
- cursor-location
- start
- end
- save)
- t)))
- (if (consp cor-menu)
- (append cor-menu (list "-" save session buffer))
- (list save session buffer)))))
- (popup-menu (cons (format "%s [%s]" word (or ispell-local-dictionary
- ispell-dictionary))
- menu))))
-
-;;*---------------------------------------------------------------------*/
;;* Some example functions for real autocorrecting */
;;*---------------------------------------------------------------------*/
(defun flyspell-maybe-correct-transposition (beg end poss)
diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el
index 5d5d422..7551d2f 100644
--- a/lisp/textmodes/ispell.el
+++ b/lisp/textmodes/ispell.el
@@ -3,12 +3,7 @@
;; Copyright (C) 1994-1995, 1997-2016 Free Software Foundation, Inc.
;; Author: Ken Stevens <address@hidden>
-;; Maintainer: Ken Stevens <address@hidden>
-;; Stevens Mod Date: Mon Jan 7 12:32:44 PST 2003
-;; Stevens Revision: 3.6
;; Status : Release with 3.1.12+ and 3.2.0+ ispell.
-;; Bug Reports : address@hidden
-;; Web Site : http://kdstevens.com/~stevens/ispell-page.html
;; Keywords: unix wp
;; This file is part of GNU Emacs.
@@ -123,133 +118,6 @@
;; Recursive edits (?C-r or ?R) inside a keyboard text replacement check (?r)
;; can cause misalignment errors.
-;; HISTORY
-
-;; Modifications made in latest versions:
-
-;; Revision 3.6 2003/01/07 12:32:44 kss
-;; Removed extra -d LIB in dictionary defs. (Pavel Janik)
-;; Filtered process calls with duplicate dictionary entries.
-;; Fixed bug where message-text-end is inside a mime skipped region.
-;; Minor fixes to get ispell menus right in XEmacs
-;; Fixed skip regexp so it doesn't match stuff like `/.\w'.
-;; Detecting dictionary change not working. Fixed. kss
-;; function `ispell-change-dictionary' now only completes valid dicts.
-
-;; Revision 3.5 2001/7/11 18:43:57 kss
-;; Added fix for aspell to work in XEmacs (ispell-check-version).
-;; Added Portuguese dictionary definition.
-;; New feature: MIME mail message support, Fcc support.
-;; Bug fix: retain comment syntax on lines with region skipping. (TeX $ bug...)
-;; Improved allocation for graphic mode lines. (Miles Bader)
-;; Support -v flag for old versions of aspell. (Eli Zaretskii)
-;; Clear minibuffer on ^G from ispell-help (Tak Ota)
-
-;; Revision 3.4 2000/8/4 09:41:50 kss
-;; Support new color display functions.
-;; Fixed misalignment offset bug when replacing a string after a shift made.
-;; Set to standard Author/Maintainer heading,
-;; ensure localwords lists are separated from the text by newline. (Dave Love)
-;; Added dictionary definition for Italian (William Deakin)
-;; HTML region skipping greatly improved. (Chuck D. Phillips)
-;; improved menus. Fixed regexp matching http/email addresses.
-;; one arg always for XEmacs sleep-for (gunnar Evermann)
-;; support for synchronous processes (Eli Zaretskii)
-
-;; Revision 3.3 1999/11/29 11:38:34 kss
-;; Only word replacements entered in from the keyboard are rechecked.
-;; This fixes a bug in tex parsing and misalignment.
-;; Exceptions exist for recursive edit and query-replace, with tex error
-;; condition tested. Recursive editing improved.
-;; XEmacs repair for when `enable-multibyte-characters' defined - Didier Verna.
-;; ispell-help fixed for XEmacs. Choices minibuffer now displayed in XEmacs.
-;; Only list valid dictionaries in Spell menu. Russian dictionary doesn't
allow
-;; run-together words, and uses koi8-r font. Don't skip text in html <TT>
-;; fonts.
-
-;; Revision 3.2 1999/5/7 14:25:14 kss
-;; Accept ispell versions 3.X.Y where X>=1
-;; fine tuned latex region skipping. Fixed bug in ispell-word that did not
-;; point in right place on words < 2 chars. Simplified ispell-minor-mode.
-;; Fixed bug in TeX parsing when math commands are in the comments.
-;; Removed calls to `when' macro.
-
-;; Revision 3.1 1998/12/1 13:21:52 kss
-;; Improved and fixed customize support.
-;; Improved and fixed comments in variables and messages.
-;; A coding system is now required for all languages.
-;; casechars improved for castellano, castellano8, and norsk dictionaries.
-;; Dictionary norsk7-tex removed. Dictionary polish added.
-;; Dictionaries redefined at load-time to support dictionary changes.
-;; Menu redefined at load time to support dictionary changes.
-;; ispell-check-version added as an alias for `check-ispell-version'.
-;; Spelling suggestions returned in order generated by ispell.
-;; Small bug fixed in matching ispell error messages.
-;; Robustness added to ensure `case-fold-search' doesn't get redefined.
-;; Fixed bug that didn't respect case of word in `ispell-complete-word'.
-;; Multibyte character coding support added for process interactions.
-;; Ensure ispell process has terminated before starting new process.
-;; This can otherwise confuse process filters and hang ispell.
-;; Improved skipping support for SGML.
-;; Fixed bug using ^M rather than \r in `ispell-minor-check'.
-;; Improved message reference matching in `ispell-message'.
-;; Fixed bug in returning to nroff mode from tex mode.
-
-;;; Compatibility code for XEmacs and (not too) older emacsen:
-(defalias 'ispell-check-minver
- (if (fboundp 'version<=) 'version<=
- (lambda (minver version)
- "Check if string VERSION is at least string MINVER.
-Both must be in [0-9]+.[0-9]+... format. This is a fallback
-compatibility function in case `version<=' is not available."
- (let ((pending t)
- (return t)
- start-ver start-mver)
- ;; Loop until an absolute greater or smaller condition is reached
- ;; or until no elements are left in any of version and minver. In
- ;; this case version is exactly the minimal, so return OK.
- (while pending
- (let (ver mver)
- (if (string-match "[0-9]+" version start-ver)
- (setq start-ver (match-end 0)
- ver (string-to-number (match-string 0 version))))
- (if (string-match "[0-9]+" minver start-mver)
- (setq start-mver (match-end 0)
- mver (string-to-number (match-string 0 minver))))
-
- (if (or ver mver)
- (progn
- (or ver (setq ver 0))
- (or mver (setq mver 0))
- ;; If none of below conditions match, this element is the
- ;; same. Go checking next element.
- (if (> ver mver)
- (setq pending nil)
- (if (< ver mver)
- (setq pending nil
- return nil))))
- (setq pending nil))))
- return))))
-
-;; XEmacs does not have looking-back
-(defalias 'ispell-looking-back
- (if (fboundp 'looking-back) 'looking-back
- (lambda (regexp &optional limit &rest ignored)
- "Return non-nil if text before point matches regular expression REGEXP.
-Like `looking-at' except matches before point, and is slower.
-LIMIT if non-nil speeds up the search by specifying a minimum
-starting position, to avoid checking matches that would start
-before LIMIT.
-
-This is a stripped down compatibility function for use when
-full featured `looking-back' function is missing."
- (save-excursion
- (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t)))))
-
-;;; XEmacs21 does not have `with-no-warnings'. Taken from org mode.
-(defmacro ispell-with-no-warnings (&rest body)
- (cons (if (fboundp 'with-no-warnings) 'with-no-warnings 'progn) body))
-
;;; Code:
(eval-when-compile (require 'cl-lib))
@@ -260,10 +128,6 @@ full featured `looking-back' function is missing."
"User variables for Emacs ispell interface."
:group 'applications)
-(if (not (fboundp 'buffer-substring-no-properties))
- (defun buffer-substring-no-properties (start end)
- (buffer-substring start end)))
-
(defalias 'check-ispell-version 'ispell-check-version)
;;; **********************************************************************
@@ -481,9 +345,7 @@ window system by evaluating the following on startup to set
this variable:
;;;###autoload
(defcustom ispell-personal-dictionary nil
"File name of your personal spelling dictionary, or nil.
-If nil, the default personal dictionary, (\"~/.ispell_DICTNAME\" for ispell or
-\"~/.aspell.LANG.pws\" for Aspell) is used, where DICTNAME is the name of your
-default dictionary and LANG the two letter language code."
+If nil, the default personal dictionary for your spelling checker is used."
:type '(choice file
(const :tag "default" nil))
:group 'ispell)
@@ -800,29 +662,11 @@ here just for backwards compatibility.")
"Alist with known matching locales for standard dict names in
`ispell-dictionary-base-alist'.")
-(defvar ispell-emacs-alpha-regexp
- (if (string-match "^[[:alpha:]]+$" "abcde")
- "[[:alpha:]]"
- nil)
- "[[:alpha:]] if Emacs supports [:alpha:] regexp, nil
-otherwise (current XEmacs does not support it).")
;;; **********************************************************************
;;; The following are used by ispell, and should not be changed.
;;; **********************************************************************
-
-
-;; The version must be 3.1 or greater for this version of ispell.el
-;; There is an incompatibility between version 3.1.12 and lower versions.
-(defconst ispell-required-version '(3 1 12)
- "Ispell versions with which this version of ispell.el is known to work.")
-(defvar ispell-offset -1
- "Offset that maps protocol differences between ispell 3.1 versions.")
-
-(defconst ispell-version "ispell.el 3.6 - 7-Jan-2003")
-
-
(defun ispell-check-version (&optional interactivep)
"Ensure that `ispell-program-name' is valid and has the correct version.
Returns version number if called interactively.
@@ -857,13 +701,11 @@ Otherwise returns the library directory name, if that is
defined."
(if (string-match "\\`aspell" speller) "-v" "-vv"))))
(goto-char (point-min))
(if interactivep
- ;; Report version information of ispell and ispell.el
+ ;; Report version information of ispell
(progn
(end-of-line)
- (setq result (concat (buffer-substring-no-properties (point-min)
- (point))
- ", "
- ispell-version))
+ (setq result (buffer-substring-no-properties (point-min)
+ (point)))
(message "%s" result))
;; return LIBDIR or LIBRARYVAR (overrides LIBDIR) env.
(progn
@@ -885,8 +727,7 @@ Otherwise returns the library directory name, if that is
defined."
;; Make sure these variables are (re-)initialized to the default value
(setq ispell-really-aspell nil
- ispell-aspell-supports-utf8 nil
- ispell-really-hunspell nil
+ ispell-really-hunspell nil
ispell-encoding8-command nil)
(goto-char (point-min))
@@ -900,29 +741,26 @@ Otherwise returns the library directory name, if that is
defined."
nil t)
(match-string 1)))))
- (let ((aspell-minver "0.50")
- (aspell8-minver "0.60")
- (ispell0-minver "3.1.0")
- (ispell-minver "3.1.12")
- (hunspell8-minver "1.1.6"))
-
- (if (ispell-check-minver ispell0-minver ispell-program-version)
- (or (ispell-check-minver ispell-minver ispell-program-version)
- (setq ispell-offset 0))
- (error "%s release %s or greater is required"
- ispell-program-name
- ispell-minver))
+ (let* ((aspell8-minver "0.60")
+ (ispell-minver "3.1.12")
+ (hunspell8-minver "1.1.6")
+ (minver (cond
+ ((not (version<= ispell-minver ispell-program-version))
+ ispell-minver)
+ ((and ispell-really-aspell
+ (not (version<= aspell8-minver
ispell-really-aspell)))
+ aspell8-minver))))
+
+ (if minver
+ (error "%s release %s or greater is required"
+ ispell-program-name
+ minver))
(cond
(ispell-really-aspell
- (if (ispell-check-minver aspell-minver ispell-really-aspell)
- (if (ispell-check-minver aspell8-minver ispell-really-aspell)
- (progn
- (setq ispell-aspell-supports-utf8 t)
- (setq ispell-encoding8-command "--encoding=")))
- (setq ispell-really-aspell nil)))
+ (setq ispell-encoding8-command "--encoding="))
(ispell-really-hunspell
- (if (ispell-check-minver hunspell8-minver ispell-really-hunspell)
+ (if (version<= hunspell8-minver ispell-really-hunspell)
(setq ispell-encoding8-command "-i")
(setq ispell-really-hunspell nil))))))
result))
@@ -973,22 +811,10 @@ See `ispell-buffer-with-debug' for an example of use."
;; Redo menu when loading ispell to get dictionary modifications
(setq ispell-menu-map nil)
-;;;###autoload
-(defvar ispell-menu-xemacs nil
- "Spelling menu for XEmacs.
-If nil when package is loaded, a standard menu will be set,
-and added as a submenu of the \"Edit\" menu.")
-
-;; Break out XEmacs menu and split into several calls to avoid having
-;; long lines in loaddefs.el. Detect need off following constant.
-
;;; Set up dictionary
;;;###autoload
(defvar ispell-menu-map-needed
- ;; only needed when not version 18 and not XEmacs.
- (and (not ispell-menu-map)
- (not (featurep 'xemacs))
- 'reload))
+ (unless ispell-menu-map 'reload))
(defvar ispell-library-directory (condition-case ()
(ispell-check-version)
@@ -1000,11 +826,7 @@ and added as a submenu of the \"Edit\" menu.")
(defvar ispell-async-processp (and (fboundp 'delete-process)
(fboundp 'process-send-string)
- (fboundp 'accept-process-output)
- ;;(fboundp 'make-process)
- ;;(fboundp 'set-process-filter)
- ;;(fboundp 'process-kill-without-query)
- )
+ (fboundp 'accept-process-output))
"Non-nil means that the OS supports asynchronous processes.")
;; Make ispell.el work better with aspell.
@@ -1014,9 +836,7 @@ and added as a submenu of the \"Edit\" menu.")
Internal use.")
(defun ispell-find-aspell-dictionaries ()
- "Find Aspell's dictionaries, and record in `ispell-dictionary-alist'."
- (unless (and ispell-really-aspell ispell-encoding8-command)
- (error "This function only works with Aspell >= 0.60"))
+ "Find Aspell's dictionaries, and record in `ispell-aspell-dictionary-alist'."
(let* ((dictionaries
(split-string
(with-temp-buffer
@@ -1378,11 +1198,9 @@ aspell is used along with Emacs).")
(setq ispell-library-directory (ispell-check-version))
t)
(error nil))
- ispell-encoding8-command
- ispell-emacs-alpha-regexp)
+ ispell-encoding8-command)
;; auto-detection will only be used if spellchecker is not
- ;; ispell, supports a way to set communication to UTF-8 and
- ;; Emacs flavor supports [:alpha:]
+ ;; ispell and supports a way to set communication to UTF-8.
(if ispell-really-aspell
(or ispell-aspell-dictionary-alist
(ispell-find-aspell-dictionaries))
@@ -1396,9 +1214,8 @@ aspell is used along with Emacs).")
;; installed dictionaries and add to it elements of the original
;; list that are not present there. Allow distro info.
(let ((found-dicts-alist
- (if (and ispell-encoding8-command
- ispell-emacs-alpha-regexp)
- (if ispell-really-aspell
+ (if ispell-encoding8-command
+ (if ispell-really-aspell
ispell-aspell-dictionary-alist
(if ispell-really-hunspell
ispell-hunspell-dictionary-alist))
@@ -1457,7 +1274,7 @@ aspell is used along with Emacs).")
(run-hooks 'ispell-initialize-spellchecker-hook)
- ;; Add dicts to ``ispell-dictionary-alist'' unless already present.
+ ;; Add dicts to `ispell-dictionary-alist' unless already present.
(dolist (dict (append found-dicts-alist
ispell-base-dicts-override-alist
ispell-dictionary-base-alist))
@@ -1465,35 +1282,32 @@ aspell is used along with Emacs).")
(push dict all-dicts-alist)))
(setq ispell-dictionary-alist all-dicts-alist))
- ;; If Emacs flavor supports [:alpha:] use it for global dicts. If
- ;; spellchecker also supports UTF-8 via command-line option use it
+ ;; If spellchecker supports UTF-8 via command-line option, use it
;; in communication. This does not affect definitions in your
;; init file.
- (if ispell-emacs-alpha-regexp
- (let (tmp-dicts-alist)
- (dolist (adict ispell-dictionary-alist)
- (cl-pushnew (if (cadr adict) ;; Do not touch hunspell uninitialized
entries
- (list
- (nth 0 adict) ; dict name
- "[[:alpha:]]" ; casechars
- "[^[:alpha:]]" ; not-casechars
- (nth 3 adict) ; otherchars
- (nth 4 adict) ; many-otherchars-p
- (nth 5 adict) ; ispell-args
- (nth 6 adict) ; extended-character-mode
- (if ispell-encoding8-command
- 'utf-8
- (nth 7 adict)))
- adict)
- tmp-dicts-alist :test #'equal))
- (setq ispell-dictionary-alist tmp-dicts-alist)))))
+ (let (tmp-dicts-alist)
+ (dolist (adict ispell-dictionary-alist)
+ (cl-pushnew (if (cadr adict) ;; Do not touch hunspell uninitialized
entries
+ (list
+ (nth 0 adict) ; dict name
+ (nth 1 adict) ; casechars
+ (nth 2 adict) ; not-casechars
+ (nth 3 adict) ; otherchars
+ (nth 4 adict) ; many-otherchars-p
+ (nth 5 adict) ; ispell-args
+ (nth 6 adict) ; extended-character-mode
+ (if ispell-encoding8-command
+ 'utf-8
+ (nth 7 adict)))
+ adict)
+ tmp-dicts-alist :test #'equal))
+ (setq ispell-dictionary-alist tmp-dicts-alist))))
(defun ispell-valid-dictionary-list ()
"Return a list of valid dictionaries.
The variable `ispell-library-directory' defines their location."
;; Initialize variables and dictionaries alists for desired spellchecker.
- ;; Make sure ispell.el is loaded to avoid some autoload loops in XEmacs
- ;; (and may be others)
+ ;; Make sure ispell.el is loaded to avoid some autoload loops.
(if (featurep 'ispell)
(ispell-set-spellchecker-params))
@@ -1597,65 +1411,8 @@ The variable `ispell-library-directory' defines their
location."
(define-key ispell-menu-map [ispell-buffer]
`(menu-item ,(purecopy "Spell-Check Buffer") ispell-buffer
:help ,(purecopy "Check spelling of selected buffer")))
- ;;(put 'ispell-region 'menu-enable 'mark-active)
(fset 'ispell-menu-map (symbol-value 'ispell-menu-map))))
-;;; XEmacs versions 19 & 20
-(if (and (featurep 'xemacs)
- (featurep 'menubar)
- ;;(null ispell-menu-xemacs)
- (not (and (boundp 'infodock-version) infodock-version)))
- (let ((dicts (if (fboundp 'ispell-valid-dictionary-list)
- (reverse (ispell-valid-dictionary-list))))
- (current-menubar (or current-menubar default-menubar))
- (menu
- '(["Help" (describe-function 'ispell-help) t]
- ;;["Help" (popup-menu ispell-help-list) t]
- ["Check Message" ispell-message t]
- ["Check Buffer" ispell-buffer t]
- ["Check Comments" ispell-comments-and-strings t]
- ["Check Word" ispell-word t]
- ["Check Region" ispell-region (or (not zmacs-regions) (mark))]
- ["Continue Check" ispell-continue t]
- ["Complete Word Frag"ispell-complete-word-interior-frag t]
- ["Complete Word" ispell-complete-word t]
- ["Kill Process" (ispell-kill-ispell nil 'clear) t]
- ["Customize..." (customize-group 'ispell) t]
- ;; flyspell-mode may not be bound...
- ;;["flyspell" flyspell-mode
- ;; :style toggle :selected flyspell-mode ]
- "-"
- ["Save Personal Dict"(ispell-pdict-save t t) t]
- ["Change Dictionary" ispell-change-dictionary t])))
- (if (null dicts)
- (setq dicts (cons "default" nil)))
- (dolist (name dicts)
- (setq menu (append menu
- (list
- (vector
- (concat "Select " (capitalize name))
- (list 'ispell-change-dictionary name)
- t)))))
- (setq ispell-menu-xemacs menu)
- (if current-menubar
- (progn
- (if (car (find-menu-item current-menubar '("Cmds")))
- (progn
- ;; XEmacs 21.2
- (delete-menu-item '("Cmds" "Spell-Check"))
- (add-menu '("Cmds") "Spell-Check" ispell-menu-xemacs))
- ;; previous
- (delete-menu-item '("Edit" "Spell")) ; in case already defined
- (add-menu '("Edit") "Spell" ispell-menu-xemacs))))))
-
-(defalias 'ispell-int-char
- ;; Allow incrementing characters as integers in XEmacs 20
- (if (and (featurep 'xemacs)
- (fboundp 'int-char))
- 'int-char
- ;; Emacs and XEmacs 19 or earlier
- 'identity))
-
;;; **********************************************************************
@@ -1669,17 +1426,8 @@ used as key in `ispell-local-dictionary-alist' and
`ispell-dictionary-alist'.")
This is passed to the Ispell process using the `-p' switch.")
(defun ispell-decode-string (str)
- "Decodes multibyte character strings.
-Protects against bogus binding of `enable-multibyte-characters' in XEmacs."
- ;; FIXME: enable-multibyte-characters is read-only, so bogus bindings are
- ;; really nasty (they signal an error in Emacs): Who does that? --Stef
- (if (and (or (featurep 'xemacs)
- (and (boundp 'enable-multibyte-characters)
- enable-multibyte-characters))
- (fboundp 'decode-coding-string)
- (ispell-get-coding-system))
- (decode-coding-string str (ispell-get-coding-system))
- str))
+ "Decodes multibyte character strings."
+ (decode-coding-string str (ispell-get-coding-system)))
;; Return a string decoded from Nth element of the current dictionary.
(defun ispell-get-decoded-string (n)
@@ -2138,32 +1886,20 @@ quit spell session exited."
(cond ((eq poss t)
(or quietly
(message "%s is correct"
- (funcall ispell-format-word-function word)))
- (and (featurep 'xemacs)
- (extent-at start)
- (and (fboundp 'delete-extent)
- (delete-extent (extent-at start)))))
+ (funcall ispell-format-word-function word))))
((stringp poss)
(or quietly
(message "%s is correct because of root %s"
(funcall ispell-format-word-function word)
- (funcall ispell-format-word-function poss)))
- (and (featurep 'xemacs)
- (extent-at start)
- (and (fboundp 'delete-extent)
- (delete-extent (extent-at start)))))
+ (funcall ispell-format-word-function poss))))
((null poss)
(message "Error checking word %s using %s with %s dictionary"
(funcall ispell-format-word-function word)
(file-name-nondirectory ispell-program-name)
(or ispell-current-dictionary "default")))
(ispell-check-only ; called from ispell minor mode.
- (if (fboundp 'make-extent)
- (if (fboundp 'set-extent-property)
- (let ((ext (make-extent start end)))
- (set-extent-property ext 'face ispell-highlight-face)
- (set-extent-property ext 'priority 2000)))
- (beep)
+ (progn
+ (beep)
(message "%s is incorrect"
(funcall ispell-format-word-function word))))
(t ; prompt for correct word.
@@ -2333,15 +2069,9 @@ Global `ispell-quit' set to start location to continue
spell session."
"-- %b -- word: " word
" -- dict: " (or ispell-current-dictionary "default")
" -- prog: " (file-name-nondirectory ispell-program-name)))
- ;; XEmacs: no need for horizontal scrollbar in choices window
- (ispell-with-no-warnings
- (and (fboundp 'set-specifier)
- (boundp 'horizontal-scrollbar-visible-p)
- (set-specifier horizontal-scrollbar-visible-p nil
- (cons (current-buffer) nil))))
- (ispell-with-no-warnings
- (and (boundp 'horizontal-scroll-bar)
- (setq horizontal-scroll-bar nil)))
+ ;; No need for horizontal scrollbar in choices window
+ (with-no-warnings
+ (setq horizontal-scroll-bar nil))
(erase-buffer)
(if guess
(progn
@@ -2364,12 +2094,12 @@ Global `ispell-quit' set to start location to continue
spell session."
;; not so good if there are over 20 or 30 options, but then, if
;; there are that many you don't want to scan them all anyway...
(while (memq count command-characters) ; skip command characters.
- (setq count (ispell-int-char (1+ count))
+ (setq count (1+ count)
skipped (1+ skipped)))
(insert "(" count ") " (car choices) " ")
(setq choices (cdr choices)
- count (ispell-int-char (1+ count))))
- (setq count (ispell-int-char (- count ?0 skipped))))
+ count (1+ count)))
+ (setq count (- count ?0 skipped)))
(run-hooks 'ispell-update-post-hook)
@@ -2428,15 +2158,15 @@ Global `ispell-quit' set to start location to continue
spell session."
((= char ?i) ; accept and insert word into pers dict
(ispell-send-string (concat "*" word "\n"))
(setq ispell-pdict-modified-p '(t)) ; dictionary modified!
- (and (fboundp 'flyspell-unhighlight-at)
- (flyspell-unhighlight-at start))
+ (when (fboundp 'flyspell-unhighlight-at)
+ (flyspell-unhighlight-at start))
nil)
((or (= char ?a) (= char ?A)) ; accept word without insert
(ispell-send-string (concat "@" word "\n"))
(cl-pushnew word ispell-buffer-session-localwords
:test #'equal)
- (and (fboundp 'flyspell-unhighlight-at)
- (flyspell-unhighlight-at start))
+ (when (fboundp 'flyspell-unhighlight-at)
+ (flyspell-unhighlight-at start))
(or ispell-buffer-local-name ; session localwords might
conflict
(setq ispell-buffer-local-name (buffer-name)))
(if (null ispell-pdict-modified-p)
@@ -2516,13 +2246,12 @@ Global `ispell-quit' set to start location to continue
spell session."
(window-width))
(insert "\n"))
(while (memq count command-characters)
- (setq count (ispell-int-char (1+ count))
+ (setq count (1+ count)
skipped (1+ skipped)))
(insert "(" count ") " (car choices) " ")
(setq choices (cdr choices)
- count (ispell-int-char (1+ count))))
- (setq count (ispell-int-char
- (- count ?0 skipped))))
+ count (1+ count)))
+ (setq count (- count ?0 skipped)))
(setq textwin (selected-window))
(ispell-show-choices)
(select-window textwin))))
@@ -2835,17 +2564,6 @@ Optional REFRESH will unhighlighted then highlight,
using block cursor
(if (eq 'block refresh) start (- start 2)) end t))))
-(defun ispell-highlight-spelling-error-xemacs (start end &optional highlight)
- "Highlight the word from START to END using `isearch-highlight'.
-When the optional third arg HIGHLIGHT is set, the word is highlighted,
-otherwise it is displayed normally."
- (if highlight
- (isearch-highlight start end)
- (isearch-dehighlight))
- ;;(sit-for 0)
- )
-
-
(defun ispell-highlight-spelling-error-overlay (start end &optional highlight)
"Highlight the word from START to END using overlays.
When the optional third arg HIGHLIGHT is set, the word is highlighted
@@ -2881,14 +2599,9 @@ The variable `ispell-highlight-face' selects the face to
use for highlighting."
(defun ispell-highlight-spelling-error (start end &optional highlight refresh)
- (cond
- ((featurep 'xemacs)
- (ispell-highlight-spelling-error-xemacs start end highlight))
- ((and (featurep 'faces)
- (or (and (fboundp 'display-color-p) (display-color-p))
- window-system))
- (ispell-highlight-spelling-error-overlay start end highlight))
- (t (ispell-highlight-spelling-error-generic start end highlight refresh))))
+ (if (display-color-p)
+ (ispell-highlight-spelling-error-overlay start end highlight)
+ (ispell-highlight-spelling-error-generic start end highlight refresh)))
(defun ispell-display-buffer (buffer)
"Show BUFFER in new window above selected one.
@@ -3052,11 +2765,9 @@ Keeps argument list for future Ispell invocations for no
async support."
(let* (;; Basename of dictionary used by the spell-checker
(dict-bname (or (car (cdr (member "-d" (ispell-get-ispell-args))))
ispell-current-dictionary))
- ;; The directory where process was started.
- (current-ispell-directory default-directory) ;FIXME: Unused?
;; The default directory for the process.
;; Use "~/" as default-directory unless using Ispell with per-dir
- ;; personal dictionaries and not in a minibuffer under XEmacs
+ ;; personal dictionaries
(default-directory
(if (or ispell-really-aspell
ispell-really-hunspell
@@ -3069,9 +2780,8 @@ Keeps argument list for future Ispell invocations for no
async support."
".ispell_"
(or dict-bname
"default")))))
- ;; Ispell, in a minibuffer, and XEmacs
- (and (window-minibuffer-p)
- (not (fboundp 'minibuffer-selected-window))))
+ ;; Ispell, in a minibuffer
+ (window-minibuffer-p))
(expand-file-name "~/")
(expand-file-name default-directory))))
;; Check if process needs restart
@@ -3103,29 +2813,21 @@ Keeps argument list for future Ispell invocations for
no async support."
(unless (equal ispell-process-directory (expand-file-name "~/"))
;; At this point, `ispell-process-directory' will be "~/" unless using
- ;; Ispell with directory-specific dicts and not in XEmacs minibuffer.
+ ;; Ispell with directory-specific dicts.
;; If not, kill ispell process when killing buffer. It may be in a
;; removable device that would otherwise become un-mountable.
(with-current-buffer
- (if (and (window-minibuffer-p) ;; In minibuffer
- (fboundp 'minibuffer-selected-window)) ;; Not XEmacs.
+ (if (window-minibuffer-p) ;; In minibuffer
;; In this case kill ispell only when parent buffer is killed
;; to avoid over and over ispell kill.
(window-buffer (minibuffer-selected-window))
(current-buffer))
- ;; 'local does not automatically make hook buffer-local in XEmacs.
- (if (featurep 'xemacs)
- (make-local-hook 'kill-buffer-hook))
- (add-hook 'kill-buffer-hook
+ (add-hook 'kill-buffer-hook
(lambda () (ispell-kill-ispell t)) nil 'local)))
(if ispell-async-processp
(set-process-filter ispell-process 'ispell-filter))
- ;; Protect against XEmacs bogus binding of `enable-multibyte-characters'.
- (if (and (or (featurep 'xemacs)
- (and (boundp 'enable-multibyte-characters)
- enable-multibyte-characters))
- (fboundp 'set-process-coding-system)
+ (if (and enable-multibyte-characters
;; Evidently, some people use the synchronous mode even
;; when async subprocesses are supported, in which case
;; set-process-coding-system is bound, but
@@ -3161,12 +2863,8 @@ Keeps argument list for future Ispell invocations for no
async support."
(let ((extended-char-mode (ispell-get-extended-character-mode)))
(if extended-char-mode ; ~ extended character mode
(ispell-send-string (concat extended-char-mode "\n"))))
- (if ispell-async-processp
- (if (featurep 'emacs)
- (set-process-query-on-exit-flag ispell-process nil)
- (if (fboundp 'set-process-query-on-exit-flag)
- (set-process-query-on-exit-flag ispell-process nil)
- (process-kill-without-query ispell-process)))))))
+ (when ispell-async-processp
+ (set-process-query-on-exit-flag ispell-process nil)))))
;;;###autoload
(defun ispell-kill-ispell (&optional no-error clear)
@@ -3178,9 +2876,7 @@ With CLEAR, buffer session localwords are cleaned."
;; to optimize the common cases.
(run-hooks 'ispell-kill-ispell-hook)
(if (or clear
- (if (featurep 'xemacs)
- (interactive-p)
- (called-interactively-p 'interactive)))
+ (called-interactively-p 'interactive))
(setq ispell-buffer-session-localwords nil))
(if (not (and ispell-process
(eq (ispell-process-status) 'run)))
@@ -3229,9 +2925,7 @@ By just answering RET you can find out what the current
dictionary is."
;; Specified dictionary is the default already. Could reload
;; the dictionaries if needed.
(ispell-internal-change-dictionary)
- (and (if (featurep 'xemacs)
- (interactive-p)
- (called-interactively-p 'interactive))
+ (when (called-interactively-p 'interactive)
(message "No change, using %s dictionary" dict)))
(t ; reset dictionary!
(if (or (assoc dict ispell-local-dictionary-alist)
@@ -3644,7 +3338,10 @@ Returns the sum SHIFT due to changes in word
replacements."
;; Markers can move with highlighting! This destroys
;; end of region markers line-end and ispell-region-end
(let ((word-start
- (copy-marker (+ ispell-start ispell-offset (car (cdr poss)))))
+ ;; There is a -1 offset here as the string is escaped
+ ;; with '^' to prevent us accidentally sending any
+ ;; ispell commands.
+ (copy-marker (+ ispell-start -1 (car (cdr poss)))))
(word-len (length (car poss)))
(line-end (copy-marker ispell-end))
(line-start (copy-marker ispell-start))
@@ -4141,29 +3838,23 @@ You can bind this to the key C-c i in GNUS or mail by
adding to
(point-max)))
(t (min (point-max) (funcall ispell-message-text-end))))))
(default-prefix ; Vanilla cite prefix (just used for cite-regexp)
- (if (and (boundp 'mail-yank-prefix) mail-yank-prefix)
- (ispell-non-empty-string mail-yank-prefix)
+ (if (ispell-non-empty-string mail-yank-prefix)
" \\|\t"))
(cite-regexp ;Prefix of quoted text
(cond
- ((functionp 'sc-cite-regexp) ; sc 3.0
- (ispell-with-no-warnings
+ ((functionp 'sc-cite-regexp) ; supercite >= 3.0
+ (with-no-warnings
(concat "\\(" (sc-cite-regexp) "\\)" "\\|"
(ispell-non-empty-string sc-reference-tag-string))))
- ((boundp 'sc-cite-regexp) ; sc 2.3
- (concat "\\(" sc-cite-regexp "\\)" "\\|"
- (ispell-with-no-warnings
- (ispell-non-empty-string sc-reference-tag-string))))
- ((or (equal major-mode 'news-reply-mode) ;GNUS 4 & below
- (equal major-mode 'message-mode)) ;GNUS 5
+ ((equal major-mode 'message-mode) ; GNUS >= 5
(concat "In article <" "\\|"
"[^,;&+=\n]+ <[^,;&+=]+> writes:" "\\|"
- (ispell-with-no-warnings message-cite-prefix-regexp)
+ (with-no-warnings message-cite-prefix-regexp)
"\\|"
default-prefix))
((equal major-mode 'mh-letter-mode) ; mh mail message
(concat "[^,;&+=\n]+ writes:" "\\|"
- (ispell-with-no-warnings
+ (with-no-warnings
(ispell-non-empty-string mh-ins-buf-prefix))))
((not internal-messagep) ; Assume nn sent us this message.
(concat "In [a-zA-Z.]+ you write:" "\\|"
@@ -4387,8 +4078,8 @@ Both should not be used to define a buffer-local
dictionary."
;; Returns optionally adjusted region-end-point.
-;; If comment-padright is defined, newcomment must be loaded.
-(declare-function comment-add "newcomment" (arg))
+;; If comment-normalize-vars is defined, newcomment must be loaded.
+(declare-function comment-normalize-vars "newcomment" (&optional noerror))
(defun ispell-add-per-file-word-list (word)
"Add WORD to the per-file word list."
@@ -4414,16 +4105,12 @@ Both should not be used to define a buffer-local
dictionary."
(unless found (newline))
(insert (if comment-start
(concat
- (if (fboundp 'comment-padright)
- ;; Try and use the proper comment marker,
- ;; e.g. ";;" rather than ";".
- (progn
- ;; XEmacs: comment-normalize-vars
- ;; (newcomment.el) only in >= 21.5
- (and (fboundp 'comment-normalize-vars)
- (comment-normalize-vars))
- (comment-padright comment-start
- (comment-add nil)))
+ (progn
+ ;; Try and use the proper comment marker,
+ ;; e.g. ";;" rather than ";".
+ (comment-normalize-vars)
+ (comment-padright comment-start
+ (comment-add nil))
comment-start)
" ")
"")
@@ -4472,6 +4159,6 @@ Both should not be used to define a buffer-local
dictionary."
; LocalWords: minipage pers dict unhighlight buf grep sync prev inc
; LocalWords: fn oldot NB AIX msg init read's bufs pt cmd Quinlan eg
; LocalWords: uuencoded unidiff sc nn VM SGML eval IspellPersDict
-; LocalWords: lns XEmacs HTML casechars Multibyte
+; LocalWords: lns HTML casechars Multibyte
;;; ispell.el ends here
diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el
index 1363efe..25d6745 100644
--- a/lisp/textmodes/tex-mode.el
+++ b/lisp/textmodes/tex-mode.el
@@ -2113,13 +2113,17 @@ If NOT-ALL is non-nil, save the `.dvi' file."
:group 'tex)
(defvar tex-compile-commands
- '(((concat "pdf" tex-command
- " " (if (< 0 (length tex-start-commands))
- (shell-quote-argument tex-start-commands)) " %f")
- t "%r.pdf")
+ `(,@(mapcar (lambda (prefix)
+ `((concat ,prefix tex-command
+ " " (if (< 0 (length tex-start-commands))
+ (shell-quote-argument tex-start-commands))
+ " %f")
+ t "%r.pdf"))
+ '("pdf" "xe" "lua"))
((concat tex-command
" " (if (< 0 (length tex-start-commands))
- (shell-quote-argument tex-start-commands)) " %f")
+ (shell-quote-argument tex-start-commands))
+ " %f")
t "%r.dvi")
("xdvi %r &" "%r.dvi")
("\\doc-view \"%r.pdf\"" "%r.pdf")
diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el
index 5b48c8d..d5ea002 100644
--- a/lisp/vc/diff-mode.el
+++ b/lisp/vc/diff-mode.el
@@ -1884,7 +1884,7 @@ With a prefix argument, REVERSE the hunk."
;; Advance to the next hunk with skip-hunk-start set to t
;; because we want the behavior of moving to the next logical
;; hunk, not the original behavior where were would sometimes
- ;; stay on the curent hunk. This is the behavior we get when
+ ;; stay on the current hunk. This is the behavior we get when
;; navigating through hunks interactively, and we want it when
;; applying hunks too (see http://debbugs.gnu.org/17544).
(when diff-advance-after-apply-hunk
diff --git a/lisp/vc/ediff-init.el b/lisp/vc/ediff-init.el
index b0d5d2f..c96a968 100644
--- a/lisp/vc/ediff-init.el
+++ b/lisp/vc/ediff-init.el
@@ -318,7 +318,7 @@ It needs to be killed when we quit the session.")
(defsubst ediff-patch-metajob (&optional metajob)
(memq (or metajob ediff-metajob-name)
'(ediff-multifile-patch)))
-;; metajob involving only one group of files, such as multipatch or directory
+;; metajob involving only one group of files, such as multi-patch or directory
;; revision
(defsubst ediff-one-filegroup-metajob (&optional metajob)
(or (ediff-revision-metajob metajob)
diff --git a/lisp/vc/ediff-ptch.el b/lisp/vc/ediff-ptch.el
index 3effd9b..9f0e1dc 100644
--- a/lisp/vc/ediff-ptch.el
+++ b/lisp/vc/ediff-ptch.el
@@ -431,15 +431,15 @@ Please advise:
(f2-exists (setcar session-file-object file2))
(f1-exists (setcar session-file-object file1))
(t
- ;; TODO: Often for multipaches the file doesn't exist
because the
- ;; directory part is wrong; for instance, if the patch need
to
- ;; be applied into
+ ;; TODO: Often for multi-patches the file doesn't exist
+ ;; because the directory part is wrong; for instance, if the
+ ;; patch needs to be applied into
;; (expand-file-name "lisp/vc/ediff-ptch.el"
source-directory)
;; and default-directory is
;; (expand-file-name "lisp" source-directory)
;; then Ediff assumes the wrong file:
;; (expand-file-name "lisp/ediff-ptch.el" source-directory).
- ;; We might identify these common failoures and suggest
+ ;; We might identify these common failures and suggest
;; in the prompt the possible corrected file. --Tino
(with-output-to-temp-buffer ediff-msg-buffer
(ediff-with-current-buffer standard-output
diff --git a/lisp/window.el b/lisp/window.el
index 5255905..fdb67ed 100644
--- a/lisp/window.el
+++ b/lisp/window.el
@@ -2797,7 +2797,7 @@ instead."
window delta horizontal ignore nil nil nil t)))
(window--resize-reset frame horizontal)
(window--resize-this-window window delta horizontal ignore t)
- (if (and (not window-combination-resize)
+ (if (and (not (eq window-combination-resize t))
(window-combined-p window horizontal)
(setq sibling (or (window-right window) (window-left window)))
(window-sizable-p
@@ -4049,7 +4049,7 @@ that is its frame's root window."
(sibling (or (window-left window) (window-right window))))
(window--resize-reset frame horizontal)
(cond
- ((and (not window-combination-resize)
+ ((and (not (eq window-combination-resize t))
sibling (window-sizable-p sibling size horizontal nil t))
;; Resize WINDOW's sibling.
(window--resize-this-window sibling size horizontal nil t)
diff --git a/m4/fpending.m4 b/m4/fpending.m4
index a446156..f6776a8 100644
--- a/m4/fpending.m4
+++ b/m4/fpending.m4
@@ -1,4 +1,4 @@
-# serial 21
+# serial 22
# Copyright (C) 2000-2001, 2004-2016 Free Software Foundation, Inc.
# This file is free software; the Free Software Foundation
@@ -11,7 +11,7 @@ dnl and Ulrich Drepper.
dnl Find out how to determine the number of pending output bytes on a stream.
dnl glibc (2.1.93 and newer) and Solaris provide __fpending. On other systems,
-dnl we have to grub around in the FILE struct.
+dnl we have to grub around in the (possibly opaque) FILE struct.
AC_DEFUN([gl_FUNC_FPENDING],
[
@@ -34,66 +34,3 @@ AC_DEFUN([gl_FUNC_FPENDING],
AC_CHECK_DECLS([__fpending], [], [], [$fp_headers])
fi
])
-
-AC_DEFUN([gl_PREREQ_FPENDING],
-[
- AC_CACHE_CHECK(
- [how to determine the number of pending output bytes on a
stream],
- ac_cv_sys_pending_output_n_bytes,
- [
- for ac_expr in \
- \
- '# glibc2' \
- 'fp->_IO_write_ptr - fp->_IO_write_base' \
- \
- '# traditional Unix' \
- 'fp->_ptr - fp->_base' \
- \
- '# BSD' \
- 'fp->_p - fp->_bf._base' \
- \
- '# SCO, Unixware' \
- '(fp->__ptr ? fp->__ptr - fp->__base : 0)' \
- \
- '# QNX' \
- '(fp->_Mode & 0x2000 /*_MWRITE*/ ? fp->_Next - fp->_Buf : 0)' \
- \
- '# old glibc?' \
- 'fp->__bufp - fp->__buffer' \
- \
- '# old glibc iostream?' \
- 'fp->_pptr - fp->_pbase' \
- \
- '# emx+gcc' \
- 'fp->_ptr - fp->_buffer' \
- \
- '# Minix' \
- 'fp->_ptr - fp->_buf' \
- \
- '# Plan9' \
- 'fp->wp - fp->buf' \
- \
- '# VMS' \
- '(*fp)->_ptr - (*fp)->_base' \
- \
- '# e.g., DGUX R4.11; the info is not available' \
- 1 \
- ; do
-
- # Skip each embedded comment.
- case "$ac_expr" in '#'*) continue;; esac
-
- AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <stdio.h>]],
- [[FILE *fp = stdin; (void) ($ac_expr);]])],
- [fp_done=yes]
- )
- test "$fp_done" = yes && break
- done
-
- ac_cv_sys_pending_output_n_bytes=$ac_expr
- ]
- )
- AC_DEFINE_UNQUOTED([PENDING_OUTPUT_N_BYTES],
- $ac_cv_sys_pending_output_n_bytes,
- [the number of pending output bytes on stream 'fp'])
-])
diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4
index 592543b..171a3ef 100644
--- a/m4/gnulib-comp.m4
+++ b/m4/gnulib-comp.m4
@@ -238,7 +238,6 @@ AC_DEFUN([gl_INIT],
gl_FUNC_FPENDING
if test $gl_cv_func___fpending = no; then
AC_LIBOBJ([fpending])
- gl_PREREQ_FPENDING
fi
gl_FUNC_FSTATAT
if test $HAVE_FSTATAT = 0 || test $REPLACE_FSTATAT = 1; then
@@ -956,6 +955,7 @@ AC_DEFUN([gl_FILE_LIST], [
lib/stdalign.in.h
lib/stddef.in.h
lib/stdint.in.h
+ lib/stdio-impl.h
lib/stdio.in.h
lib/stdlib.in.h
lib/stpcpy.c
diff --git a/msdos/mainmake.v2 b/msdos/mainmake.v2
index 98716ac..f89caf9 100644
--- a/msdos/mainmake.v2
+++ b/msdos/mainmake.v2
@@ -156,7 +156,7 @@ TAGS tags: lib-src FRC
cd lib-src
if exist etags.exe mv -f etags.exe ../bin
cd ..
- - find $(CURDIR)/lisp -iname "*.el" -a -! -( -iname "*loaddefs.el" -o
-iname "ldefs-boot.el" -) | ./bin/etags -o lisp/TAGS -
+ - find $(CURDIR)/lisp -iname "*.el" -a -! -( -iname "*loaddefs.el" -o
-iname "ldefs-boot-auto.el" -) | ./bin/etags -o lisp/TAGS -
cd $(CURDIR)
cd src
../bin/etags --include=../lisp/TAGS \
diff --git a/nt/gnulib.mk b/nt/gnulib.mk
index 65b206e..6d9fbcf 100644
--- a/nt/gnulib.mk
+++ b/nt/gnulib.mk
@@ -345,7 +345,7 @@ EXTRA_DIST += filevercmp.h
## begin gnulib module fpending
-EXTRA_DIST += fpending.c fpending.h
+EXTRA_DIST += fpending.c fpending.h stdio-impl.h
EXTRA_libgnu_a_SOURCES += fpending.c
diff --git a/nt/inc/sys/socket.h b/nt/inc/sys/socket.h
index 6b9f56f..e9a021a 100644
--- a/nt/inc/sys/socket.h
+++ b/nt/inc/sys/socket.h
@@ -53,6 +53,7 @@ along with GNU Emacs. If not, see
<http://www.gnu.org/licenses/>. */
#include <ws2tcpip.h>
/* process.c uses uint16_t (from C99) for IPv6, but
apparently it is not defined in some versions of mingw and msvc. */
+#include <stdint.h>
#ifndef UINT16_C
typedef unsigned short uint16_t;
#endif
diff --git a/src/.gdbinit b/src/.gdbinit
index b0c0dfd..9160ffa 100644
--- a/src/.gdbinit
+++ b/src/.gdbinit
@@ -1215,6 +1215,21 @@ document xwhichsymbols
maximum number of symbols referencing it to produce.
end
+define xbytecode
+ set $bt = byte_stack_list
+ while $bt
+ xgetptr $bt->byte_string
+ set $ptr = (struct Lisp_String *) $ptr
+ xprintbytestr $ptr
+ printf "\n0x%x => ", $bt->byte_string
+ xwhichsymbols $bt->byte_string 5
+ set $bt = $bt->next
+ end
+end
+document xbytecode
+ Print a backtrace of the byte code stack.
+end
+
# Show Lisp backtrace after normal backtrace.
define hookpost-backtrace
set $bt = backtrace_top ()
diff --git a/src/ChangeLog.13 b/src/ChangeLog.13
index 9e99895..e8ab5e0 100644
--- a/src/ChangeLog.13
+++ b/src/ChangeLog.13
@@ -17073,7 +17073,7 @@
2013-05-04 Stefan Monnier <address@hidden>
* minibuf.c (Fread_minibuffer, Feval_minibuffer): Move to Elisp.
- (syms_of_minibuf): Adjust accodingly.
+ (syms_of_minibuf): Adjust accordingly.
* lread.c (Fread):
* callint.c (Fcall_interactively): Adjust calls accordingly.
diff --git a/src/ChangeLog.3 b/src/ChangeLog.3
index a62aee7..256e4b7 100644
--- a/src/ChangeLog.3
+++ b/src/ChangeLog.3
@@ -11648,7 +11648,7 @@
* fileio.c (Fcopy_file): Always close descriptors.
- * s-sunos4.h: read, write, open and close are interruptable.
+ * s-sunos4.h: read, write, open and close are interruptible.
1991-01-09 Jim Blandy (address@hidden)
diff --git a/src/Makefile.in b/src/Makefile.in
index 7ca147f..9703768 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -409,6 +409,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o
$(XMENU_OBJ) window.o \
doprnt.o intervals.o textprop.o composite.o xml.o $(NOTIFY_OBJ) \
$(XWIDGETS_OBJ) \
profiler.o decompress.o \
+ thread.o systhread.o \
$(if $(HYBRID_MALLOC),sheap.o) \
$(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \
$(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ)
@@ -763,6 +764,10 @@ endif
@: Compile some files earlier to speed up further compilation.
$(MAKE) -C ../lisp compile-first EMACS="$(bootstrap_exe)"
+
+generate-ldefs-boot: bootstrap-emacs$(EXEEXT)
+ $(RUN_TEMACS) --batch $(BUILD_DETAILS) --load loadup bootstrap
+
ifeq ($(AUTO_DEPEND),yes)
-include $(ALLOBJS:%.o=${DEPDIR}/%.d)
else
diff --git a/src/alloc.c b/src/alloc.c
index 6eced7b..93ea286 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -438,10 +438,6 @@ struct mem_node
enum mem_type type;
};
-/* Base address of stack. Set in main. */
-
-Lisp_Object *stack_base;
-
/* Root of the tree describing allocated Lisp memory. */
static struct mem_node *mem_root;
@@ -3190,8 +3186,7 @@ vector_nbytes (struct Lisp_Vector *v)
}
/* Release extra resources still in use by VECTOR, which may be any
- vector-like object. For now, this is used just to free data in
- font objects. */
+ vector-like object. */
static void
cleanup_vector (struct Lisp_Vector *vector)
@@ -3212,6 +3207,13 @@ cleanup_vector (struct Lisp_Vector *vector)
drv->close ((struct font *) vector);
}
}
+
+ if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD))
+ finalize_one_thread ((struct thread_state *) vector);
+ else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX))
+ finalize_one_mutex ((struct Lisp_Mutex *) vector);
+ else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CONDVAR))
+ finalize_one_condvar ((struct Lisp_CondVar *) vector);
}
/* Reclaim space used by unmarked vectors. */
@@ -5047,14 +5049,13 @@ test_setjmp (void)
would be necessary, each one starting with one byte more offset
from the stack start. */
-static void
-mark_stack (void *end)
+void
+mark_stack (char *bottom, char *end)
{
-
/* This assumes that the stack is a contiguous region in memory. If
that's not the case, something has to be done here to iterate
over the stack segments. */
- mark_memory (stack_base, end);
+ mark_memory (bottom, end);
/* Allow for marking a secondary stack, like the register stack on the
ia64. */
@@ -5063,6 +5064,81 @@ mark_stack (void *end)
#endif
}
+/* This is a trampoline function that flushes registers to the stack,
+ and then calls FUNC. ARG is passed through to FUNC verbatim.
+
+ This function must be called whenever Emacs is about to release the
+ global interpreter lock. This lets the garbage collector easily
+ find roots in registers on threads that are not actively running
+ Lisp.
+
+ It is invalid to run any Lisp code or to allocate any GC memory
+ from FUNC. */
+
+void
+flush_stack_call_func (void (*func) (void *arg), void *arg)
+{
+ void *end;
+ struct thread_state *self = current_thread;
+
+#ifdef HAVE___BUILTIN_UNWIND_INIT
+ /* Force callee-saved registers and register windows onto the stack.
+ This is the preferred method if available, obviating the need for
+ machine dependent methods. */
+ __builtin_unwind_init ();
+ end = &end;
+#else /* not HAVE___BUILTIN_UNWIND_INIT */
+#ifndef GC_SAVE_REGISTERS_ON_STACK
+ /* jmp_buf may not be aligned enough on darwin-ppc64 */
+ union aligned_jmpbuf {
+ Lisp_Object o;
+ sys_jmp_buf j;
+ } j;
+ volatile bool stack_grows_down_p = (char *) &j > (char *) stack_bottom;
+#endif
+ /* This trick flushes the register windows so that all the state of
+ the process is contained in the stack. */
+ /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
+ needed on ia64 too. See mach_dep.c, where it also says inline
+ assembler doesn't work with relevant proprietary compilers. */
+#ifdef __sparc__
+#if defined (__sparc64__) && defined (__FreeBSD__)
+ /* FreeBSD does not have a ta 3 handler. */
+ asm ("flushw");
+#else
+ asm ("ta 3");
+#endif
+#endif
+
+ /* Save registers that we need to see on the stack. We need to see
+ registers used to hold register variables and registers used to
+ pass parameters. */
+#ifdef GC_SAVE_REGISTERS_ON_STACK
+ GC_SAVE_REGISTERS_ON_STACK (end);
+#else /* not GC_SAVE_REGISTERS_ON_STACK */
+
+#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
+ setjmp will definitely work, test it
+ and print a message with the result
+ of the test. */
+ if (!setjmp_tested_p)
+ {
+ setjmp_tested_p = 1;
+ test_setjmp ();
+ }
+#endif /* GC_SETJMP_WORKS */
+
+ sys_setjmp (j.j);
+ end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
+#endif /* not GC_SAVE_REGISTERS_ON_STACK */
+#endif /* not HAVE___BUILTIN_UNWIND_INIT */
+
+ self->stack_top = end;
+ (*func) (arg);
+
+ eassert (current_thread == self);
+}
+
static bool
c_symbol_p (struct Lisp_Symbol *sym)
{
@@ -5768,24 +5844,14 @@ garbage_collect_1 (void *end)
mark_object (*staticvec[i]);
mark_pinned_symbols ();
- mark_specpdl ();
mark_terminals ();
mark_kboards ();
+ mark_threads ();
#ifdef USE_GTK
xg_mark_data ();
#endif
- mark_stack (end);
-
- {
- struct handler *handler;
- for (handler = handlerlist; handler; handler = handler->next)
- {
- mark_object (handler->tag_or_ch);
- mark_object (handler->val);
- }
- }
#ifdef HAVE_WINDOW_SYSTEM
mark_fringe_data ();
#endif
@@ -5817,6 +5883,8 @@ garbage_collect_1 (void *end)
gc_sweep ();
+ unmark_threads ();
+
/* Clear the mark bits that we set in certain root slots. */
VECTOR_UNMARK (&buffer_defaults);
VECTOR_UNMARK (&buffer_local_symbols);
@@ -6338,7 +6406,7 @@ mark_object (Lisp_Object arg)
#ifdef GC_CHECK_MARKED_OBJECTS
m = mem_find (po);
- if (m == MEM_NIL && !SUBRP (obj))
+ if (m == MEM_NIL && !SUBRP (obj) && !primary_thread_p (po))
emacs_abort ();
#endif /* GC_CHECK_MARKED_OBJECTS */
@@ -6348,7 +6416,9 @@ mark_object (Lisp_Object arg)
else
pvectype = PVEC_NORMAL_VECTOR;
- if (pvectype != PVEC_SUBR && pvectype != PVEC_BUFFER)
+ if (pvectype != PVEC_SUBR
+ && pvectype != PVEC_BUFFER
+ && !primary_thread_p (po))
CHECK_LIVE (live_vector_p);
switch (pvectype)
diff --git a/src/buffer.c b/src/buffer.c
index b8e0a61..cad28f2 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -48,8 +48,6 @@ along with GNU Emacs. If not, see
<http://www.gnu.org/licenses/>. */
#include "w32heap.h" /* for mmap_* */
#endif
-struct buffer *current_buffer; /* The current buffer. */
-
/* First buffer in chain of all buffers (in reverse order of creation).
Threaded through ->header.next.buffer. */
@@ -1659,6 +1657,9 @@ cleaning up all windows currently displaying the buffer
to be killed. */)
if (!BUFFER_LIVE_P (b))
return Qnil;
+ if (thread_check_current_buffer (b))
+ return Qnil;
+
/* Run hooks with the buffer to be killed the current buffer. */
{
ptrdiff_t count = SPECPDL_INDEX ();
@@ -2037,9 +2038,6 @@ DEFUN ("current-buffer", Fcurrent_buffer,
Scurrent_buffer, 0, 0, 0,
void
set_buffer_internal_1 (register struct buffer *b)
{
- register struct buffer *old_buf;
- register Lisp_Object tail;
-
#ifdef USE_MMAP_FOR_BUFFERS
if (b->text->beg == NULL)
enlarge_buffer_text (b, 0);
@@ -2048,6 +2046,17 @@ set_buffer_internal_1 (register struct buffer *b)
if (current_buffer == b)
return;
+ set_buffer_internal_2 (b);
+}
+
+/* Like set_buffer_internal_1, but doesn't check whether B is already
+ the current buffer. Called upon switch of the current thread, see
+ post_acquire_global_lock. */
+void set_buffer_internal_2 (register struct buffer *b)
+{
+ register struct buffer *old_buf;
+ register Lisp_Object tail;
+
BUFFER_CHECK_INDIRECTION (b);
old_buf = current_buffer;
diff --git a/src/buffer.h b/src/buffer.h
index 8264bbb..08be478 100644
--- a/src/buffer.h
+++ b/src/buffer.h
@@ -1043,10 +1043,6 @@ extern struct buffer *all_buffers;
#define FOR_EACH_BUFFER(b) \
for ((b) = all_buffers; (b); (b) = (b)->next)
-/* This points to the current buffer. */
-
-extern struct buffer *current_buffer;
-
/* This structure holds the default values of the buffer-local variables
that have special slots in each buffer.
The default value occupies the same slot in this structure
@@ -1089,6 +1085,7 @@ extern void recenter_overlay_lists (struct buffer *,
ptrdiff_t);
extern ptrdiff_t overlay_strings (ptrdiff_t, struct window *, unsigned char
**);
extern void validate_region (Lisp_Object *, Lisp_Object *);
extern void set_buffer_internal_1 (struct buffer *);
+extern void set_buffer_internal_2 (struct buffer *);
extern void set_buffer_temp (struct buffer *);
extern Lisp_Object buffer_local_value (Lisp_Object, Lisp_Object);
extern void record_buffer (Lisp_Object);
diff --git a/src/bytecode.c b/src/bytecode.c
index 71ecdbf..c581ed6 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -280,10 +280,68 @@ enum byte_code_op
Bset_mark = 0163, /* this loser is no longer generated as of v18 */
#endif
};
+
+/* Whether to maintain a `top' and `bottom' field in the stack frame. */
+#define BYTE_MAINTAIN_TOP BYTE_CODE_SAFE
-/* Fetch the next byte from the bytecode stream. */
+/* Structure describing a value stack used during byte-code execution
+ in Fbyte_code. */
+
+struct byte_stack
+{
+ /* Program counter. This points into the byte_string below
+ and is relocated when that string is relocated. */
+ const unsigned char *pc;
+
+ /* Top and bottom of stack. The bottom points to an area of memory
+ allocated with alloca in Fbyte_code. */
+#if BYTE_MAINTAIN_TOP
+ Lisp_Object *top, *bottom;
+#endif
+
+ /* The string containing the byte-code, and its current address.
+ Storing this here protects it from GC because mark_byte_stack
+ marks it. */
+ Lisp_Object byte_string;
+ const unsigned char *byte_string_start;
+
+ /* Next entry in byte_stack_list. */
+ struct byte_stack *next;
+};
+
+/* A list of currently active byte-code execution value stacks.
+ Fbyte_code adds an entry to the head of this list before it starts
+ processing byte-code, and it removes the entry again when it is
+ done. Signaling an error truncates the list.
+
+ byte_stack_list is a macro defined in thread.h. */
+/* struct byte_stack *byte_stack_list; */
+
+
+/* Relocate program counters in the stacks on byte_stack_list. Called
+ when GC has completed. */
+
+void
+relocate_byte_stack (struct byte_stack *stack)
+{
+ for (; stack; stack = stack->next)
+ {
+ if (stack->byte_string_start != SDATA (stack->byte_string))
+ {
+ ptrdiff_t offset = stack->pc - stack->byte_string_start;
+ stack->byte_string_start = SDATA (stack->byte_string);
+ stack->pc = stack->byte_string_start + offset;
+ }
+ }
+}
-#define FETCH (*pc++)
+
+/* Fetch the next byte from the bytecode stream. */
+#ifdef BYTE_CODE_SAFE
+#define FETCH (eassert (stack.byte_string_start == SDATA (stack.byte_string)),
*stack.pc++)
+#else
+#define FETCH *stack.pc++
+#endif
/* Fetch two bytes from the bytecode stream and make a 16-bit number
out of them. */
@@ -308,6 +366,29 @@ enum byte_code_op
#define TOP (*top)
+#define CHECK_RANGE(ARG) \
+ (BYTE_CODE_SAFE && bytestr_length <= (ARG) ? emacs_abort () : (void) 0)
+
+/* A version of the QUIT macro which makes sure that the stack top is
+ set before signaling `quit'. */
+#define BYTE_CODE_QUIT \
+ do { \
+ if (quitcounter++) \
+ break; \
+ maybe_gc (); \
+ if (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) \
+ { \
+ Lisp_Object flag = Vquit_flag; \
+ Vquit_flag = Qnil; \
+ if (EQ (Vthrow_on_input, flag)) \
+ Fthrow (Vthrow_on_input, Qt); \
+ quit (); \
+ } \
+ else if (pending_signals) \
+ process_pending_signals (); \
+ } while (0)
+
+
DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
doc: /* Function used internally in byte-compiled code.
The first argument, BYTESTR, is a string of byte code;
@@ -357,18 +438,19 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector,
Lisp_Object maxdepth,
ptrdiff_t bytestr_length = SBYTES (bytestr);
Lisp_Object *vectorp = XVECTOR (vector)->contents;
+ struct byte_stack stack;
- unsigned char quitcounter = 1;
+ stack.byte_string = bytestr;
+ stack.pc = stack.byte_string_start = SDATA (bytestr);
+ unsigned char quitcounter = 0;
EMACS_INT stack_items = XFASTINT (maxdepth) + 1;
USE_SAFE_ALLOCA;
Lisp_Object *stack_base;
- SAFE_ALLOCA_LISP_EXTRA (stack_base, stack_items, bytestr_length);
+ SAFE_ALLOCA_LISP (stack_base, stack_items);
Lisp_Object *stack_lim = stack_base + stack_items;
Lisp_Object *top = stack_base;
- memcpy (stack_lim, SDATA (bytestr), bytestr_length);
- void *void_stack_lim = stack_lim;
- unsigned char const *bytestr_data = void_stack_lim;
- unsigned char const *pc = bytestr_data;
+ stack.next = byte_stack_list;
+ byte_stack_list = &stack;
ptrdiff_t count = SPECPDL_INDEX ();
if (!NILP (args_template))
@@ -508,10 +590,15 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector,
Lisp_Object maxdepth,
CASE (Bgotoifnil):
{
- Lisp_Object v1 = POP;
+ Lisp_Object v1;
op = FETCH2;
+ v1 = POP;
if (NILP (v1))
- goto op_branch;
+ {
+ BYTE_CODE_QUIT;
+ CHECK_RANGE (op);
+ stack.pc = stack.byte_string_start + op;
+ }
NEXT;
}
@@ -569,7 +656,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector,
Lisp_Object maxdepth,
if (SYMBOLP (sym)
&& !EQ (val, Qunbound)
&& !XSYMBOL (sym)->redirect
- && !SYMBOL_TRAPPED_WRITE_P (sym))
+ && !SYMBOL_TRAPPED_WRITE_P (sym))
SET_SYMBOL_VAL (XSYMBOL (sym), val);
else
set_internal (sym, val, Qnil, SET_INTERNAL_SET);
@@ -666,72 +753,86 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector,
Lisp_Object maxdepth,
NEXT;
CASE (Bgoto):
- op = FETCH2;
- op_branch:
- op -= pc - bytestr_data;
- op_relative_branch:
- if (BYTE_CODE_SAFE
- && ! (bytestr_data - pc <= op
- && op < bytestr_data + bytestr_length - pc))
- emacs_abort ();
- quitcounter += op < 0;
- if (!quitcounter)
- {
- quitcounter = 1;
- maybe_gc ();
- QUIT;
- }
- pc += op;
+ BYTE_CODE_QUIT;
+ op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */
+ CHECK_RANGE (op);
+ stack.pc = stack.byte_string_start + op;
NEXT;
CASE (Bgotoifnonnil):
op = FETCH2;
- if (!NILP (POP))
- goto op_branch;
+ Lisp_Object v1 = POP;
+ if (!NILP (v1))
+ {
+ BYTE_CODE_QUIT;
+ CHECK_RANGE (op);
+ stack.pc = stack.byte_string_start + op;
+ }
NEXT;
CASE (Bgotoifnilelsepop):
op = FETCH2;
if (NILP (TOP))
- goto op_branch;
- DISCARD (1);
+ {
+ BYTE_CODE_QUIT;
+ CHECK_RANGE (op);
+ stack.pc = stack.byte_string_start + op;
+ }
+ else DISCARD (1);
NEXT;
CASE (Bgotoifnonnilelsepop):
op = FETCH2;
if (!NILP (TOP))
- goto op_branch;
- DISCARD (1);
+ {
+ BYTE_CODE_QUIT;
+ CHECK_RANGE (op);
+ stack.pc = stack.byte_string_start + op;
+ }
+ else DISCARD (1);
NEXT;
CASE (BRgoto):
- op = FETCH - 128;
- goto op_relative_branch;
+ BYTE_CODE_QUIT;
+ stack.pc += (int) *stack.pc - 127;
+ NEXT;
CASE (BRgotoifnil):
- op = FETCH - 128;
if (NILP (POP))
- goto op_relative_branch;
+ {
+ BYTE_CODE_QUIT;
+ stack.pc += (int) *stack.pc - 128;
+ }
+ stack.pc++;
NEXT;
CASE (BRgotoifnonnil):
- op = FETCH - 128;
if (!NILP (POP))
- goto op_relative_branch;
+ {
+ BYTE_CODE_QUIT;
+ stack.pc += (int) *stack.pc - 128;
+ }
+ stack.pc++;
NEXT;
CASE (BRgotoifnilelsepop):
- op = FETCH - 128;
+ op = *stack.pc++;
if (NILP (TOP))
- goto op_relative_branch;
- DISCARD (1);
+ {
+ BYTE_CODE_QUIT;
+ stack.pc += op - 128;
+ }
+ else DISCARD (1);
NEXT;
CASE (BRgotoifnonnilelsepop):
- op = FETCH - 128;
+ op = *stack.pc++;
if (!NILP (TOP))
- goto op_relative_branch;
- DISCARD (1);
+ {
+ BYTE_CODE_QUIT;
+ stack.pc += op - 128;
+ }
+ else DISCARD (1);
NEXT;
CASE (Breturn):
@@ -791,11 +892,15 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector,
Lisp_Object maxdepth,
if (sys_setjmp (c->jmp))
{
struct handler *c = handlerlist;
+ int dest;
top = c->bytecode_top;
- op = c->bytecode_dest;
+ dest = c->bytecode_dest;
handlerlist = c->next;
PUSH (c->val);
- goto op_branch;
+ CHECK_RANGE (dest);
+ /* Might have been re-set by longjmp! */
+ stack.byte_string_start = SDATA (stack.byte_string);
+ stack.pc = stack.byte_string_start + dest;
}
NEXT;
@@ -1363,7 +1468,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector,
Lisp_Object maxdepth,
call3 (Qerror,
build_string ("Invalid byte opcode: op=%s, ptr=%d"),
make_number (op),
- make_number (pc - 1 - bytestr_data));
+ make_number (stack.pc - 1 - stack.byte_string_start));
/* Handy byte-codes for lexical binding. */
CASE (Bstack_ref1):
@@ -1423,6 +1528,8 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector,
Lisp_Object maxdepth,
exit:
+ byte_stack_list = byte_stack_list->next;
+
/* Binds and unbinds are supposed to be compiled balanced. */
if (SPECPDL_INDEX () != count)
{
diff --git a/src/charset.c b/src/charset.c
index ff937bc..09520cc 100644
--- a/src/charset.c
+++ b/src/charset.c
@@ -241,7 +241,7 @@ struct charset_map_entries
static void
load_charset_map (struct charset *charset, struct charset_map_entries
*entries, int n_entries, int control_flag)
{
- Lisp_Object vec;
+ Lisp_Object vec UNINIT;
Lisp_Object table UNINIT;
unsigned max_code = CHARSET_MAX_CODE (charset);
bool ascii_compatible_p = charset->ascii_compatible_p;
diff --git a/src/coding.c b/src/coding.c
index feed9c8..f2a92c9 100644
--- a/src/coding.c
+++ b/src/coding.c
@@ -8028,12 +8028,12 @@ decode_coding_object (struct coding_system *coding,
Lisp_Object dst_object)
{
ptrdiff_t count = SPECPDL_INDEX ();
- unsigned char *destination;
- ptrdiff_t dst_bytes;
+ unsigned char *destination UNINIT;
+ ptrdiff_t dst_bytes UNINIT;
ptrdiff_t chars = to - from;
ptrdiff_t bytes = to_byte - from_byte;
Lisp_Object attrs;
- ptrdiff_t saved_pt = -1, saved_pt_byte;
+ ptrdiff_t saved_pt = -1, saved_pt_byte UNINIT;
bool need_marker_adjustment = 0;
Lisp_Object old_deactivate_mark;
diff --git a/src/data.c b/src/data.c
index 64cd8b2..821fc37 100644
--- a/src/data.c
+++ b/src/data.c
@@ -258,6 +258,12 @@ for example, (type-of 1) returns `integer'. */)
return Qfont_entity;
if (FONT_OBJECT_P (object))
return Qfont_object;
+ if (THREADP (object))
+ return Qthread;
+ if (MUTEXP (object))
+ return Qmutex;
+ if (CONDVARP (object))
+ return Qcondition_variable;
return Qvector;
case Lisp_Float:
@@ -528,6 +534,33 @@ DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
return Qnil;
}
+DEFUN ("threadp", Fthreadp, Sthreadp, 1, 1, 0,
+ doc: /* Return t if OBJECT is a thread. */)
+ (Lisp_Object object)
+{
+ if (THREADP (object))
+ return Qt;
+ return Qnil;
+}
+
+DEFUN ("mutexp", Fmutexp, Smutexp, 1, 1, 0,
+ doc: /* Return t if OBJECT is a mutex. */)
+ (Lisp_Object object)
+{
+ if (MUTEXP (object))
+ return Qt;
+ return Qnil;
+}
+
+DEFUN ("condition-variable-p", Fcondition_variable_p, Scondition_variable_p,
+ 1, 1, 0,
+ doc: /* Return t if OBJECT is a condition variable. */)
+ (Lisp_Object object)
+{
+ if (CONDVARP (object))
+ return Qt;
+ return Qnil;
+}
/* Extract and set components of lists. */
@@ -700,6 +733,9 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
{
register Lisp_Object function;
CHECK_SYMBOL (symbol);
+ /* Perhaps not quite the right error signal, but seems good enough. */
+ if (NILP (symbol))
+ xsignal1 (Qsetting_constant, symbol);
function = XSYMBOL (symbol)->function;
@@ -1140,9 +1176,7 @@ swap_in_symval_forwarding (struct Lisp_Symbol *symbol,
struct Lisp_Buffer_Local_
tem1 = blv->where;
if (NILP (tem1)
- || (blv->frame_local
- ? !EQ (selected_frame, tem1)
- : current_buffer != XBUFFER (tem1)))
+ || current_buffer != XBUFFER (tem1))
{
/* Unload the previously loaded binding. */
@@ -1153,16 +1187,8 @@ swap_in_symval_forwarding (struct Lisp_Symbol *symbol,
struct Lisp_Buffer_Local_
{
Lisp_Object var;
XSETSYMBOL (var, symbol);
- if (blv->frame_local)
- {
- tem1 = assq_no_quit (var, XFRAME (selected_frame)->param_alist);
- set_blv_where (blv, selected_frame);
- }
- else
- {
- tem1 = assq_no_quit (var, BVAR (current_buffer, local_var_alist));
- set_blv_where (blv, Fcurrent_buffer ());
- }
+ tem1 = assq_no_quit (var, BVAR (current_buffer, local_var_alist));
+ set_blv_where (blv, Fcurrent_buffer ());
}
if (!(blv->found = !NILP (tem1)))
tem1 = blv->defcell;
@@ -1230,7 +1256,7 @@ DEFUN ("set", Fset, Sset, 2, 2, 0,
}
/* Store the value NEWVAL into SYMBOL.
- If buffer/frame-locality is an issue, WHERE specifies which context to use.
+ If buffer-locality is an issue, WHERE specifies which context to use.
(nil stands for the current buffer/frame).
If BINDFLAG is SET_INTERNAL_SET, then if this symbol is supposed to
@@ -1263,11 +1289,13 @@ set_internal (Lisp_Object symbol, Lisp_Object newval,
Lisp_Object where,
return;
case SYMBOL_TRAPPED_WRITE:
- notify_variable_watchers (symbol, voide? Qnil : newval,
- (bindflag == SET_INTERNAL_BIND? Qlet :
- bindflag == SET_INTERNAL_UNBIND? Qunlet :
- voide? Qmakunbound : Qset),
- where);
+ /* Setting due to thread-switching doesn't count. */
+ if (bindflag != SET_INTERNAL_THREAD_SWITCH)
+ notify_variable_watchers (symbol, voide? Qnil : newval,
+ (bindflag == SET_INTERNAL_BIND? Qlet :
+ bindflag == SET_INTERNAL_UNBIND? Qunlet :
+ voide? Qmakunbound : Qset),
+ where);
/* FALLTHROUGH! */
case SYMBOL_UNTRAPPED_WRITE:
break;
@@ -1284,15 +1312,10 @@ set_internal (Lisp_Object symbol, Lisp_Object newval,
Lisp_Object where,
{
struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
if (NILP (where))
- {
- if (blv->frame_local)
- where = selected_frame;
- else
- XSETBUFFER (where, current_buffer);
- }
+ XSETBUFFER (where, current_buffer);
+
/* If the current buffer is not the buffer whose binding is
- loaded, or if there may be frame-local bindings and the frame
- isn't the right one, or if it's a Lisp_Buffer_Local_Value and
+ loaded, or if it's a Lisp_Buffer_Local_Value and
the default binding is loaded, the loaded binding may be the
wrong one. */
if (!EQ (blv->where, where)
@@ -1309,9 +1332,7 @@ set_internal (Lisp_Object symbol, Lisp_Object newval,
Lisp_Object where,
/* Find the new binding. */
XSETSYMBOL (symbol, sym); /* May have changed via aliasing. */
tem1 = assq_no_quit (symbol,
- (blv->frame_local
- ? XFRAME (where)->param_alist
- : BVAR (XBUFFER (where), local_var_alist)));
+ BVAR (XBUFFER (where), local_var_alist));
set_blv_where (blv, where);
blv->found = 1;
@@ -1338,9 +1359,6 @@ set_internal (Lisp_Object symbol, Lisp_Object newval,
Lisp_Object where,
and load that binding. */
else
{
- /* local_if_set is only supported for buffer-local
- bindings, not for frame-local bindings. */
- eassert (!blv->frame_local);
tem1 = Fcons (symbol, XCDR (blv->defcell));
bset_local_var_alist
(XBUFFER (where),
@@ -1378,7 +1396,7 @@ set_internal (Lisp_Object symbol, Lisp_Object newval,
Lisp_Object where,
int offset = XBUFFER_OBJFWD (innercontents)->offset;
int idx = PER_BUFFER_IDX (offset);
if (idx > 0
- && !bindflag
+ && bindflag == SET_INTERNAL_SET
&& !let_shadows_buffer_binding_p (sym))
SET_PER_BUFFER_VALUE_P (buf, idx, 1);
}
@@ -1404,9 +1422,6 @@ set_symbol_trapped_write (Lisp_Object symbol, enum
symbol_trapped_write trap)
struct Lisp_Symbol* sym = XSYMBOL (symbol);
if (sym->trapped_write == SYMBOL_NOWRITE)
xsignal1 (Qtrapping_constant, symbol);
- else if (sym->redirect == SYMBOL_LOCALIZED
- && SYMBOL_BLV (sym)->frame_local)
- xsignal1 (Qtrapping_frame_local, symbol);
sym->trapped_write = trap;
}
@@ -1598,11 +1613,9 @@ local bindings in certain buffers. */)
xsignal1 (Qvoid_variable, symbol);
}
-DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0,
- doc: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are
evaluated.
-The default value is seen in buffers that do not have their own values
-for this variable. */)
- (Lisp_Object symbol, Lisp_Object value)
+void
+set_default_internal (Lisp_Object symbol, Lisp_Object value,
+ enum Set_Internal_Bind bindflag)
{
struct Lisp_Symbol *sym;
@@ -1616,11 +1629,13 @@ for this variable. */)
xsignal1 (Qsetting_constant, symbol);
else
/* Allow setting keywords to their own value. */
- return value;
+ return;
case SYMBOL_TRAPPED_WRITE:
/* Don't notify here if we're going to call Fset anyway. */
- if (sym->redirect != SYMBOL_PLAINVAL)
+ if (sym->redirect != SYMBOL_PLAINVAL
+ /* Setting due to thread switching doesn't count. */
+ && bindflag != SET_INTERNAL_THREAD_SWITCH)
notify_variable_watchers (symbol, value, Qset_default, Qnil);
/* FALLTHROUGH! */
case SYMBOL_UNTRAPPED_WRITE:
@@ -1633,7 +1648,7 @@ for this variable. */)
switch (sym->redirect)
{
case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
- case SYMBOL_PLAINVAL: return Fset (symbol, value);
+ case SYMBOL_PLAINVAL: set_internal (symbol, value, Qnil, bindflag); return;
case SYMBOL_LOCALIZED:
{
struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
@@ -1644,7 +1659,7 @@ for this variable. */)
/* If the default binding is now loaded, set the REALVALUE slot too. */
if (blv->fwd && EQ (blv->defcell, blv->valcell))
store_symval_forwarding (blv->fwd, value, NULL);
- return value;
+ return;
}
case SYMBOL_FORWARDED:
{
@@ -1670,15 +1685,25 @@ for this variable. */)
if (!PER_BUFFER_VALUE_P (b, idx))
set_per_buffer_value (b, offset, value);
}
- return value;
}
else
- return Fset (symbol, value);
+ set_internal (symbol, value, Qnil, bindflag);
+ return;
}
default: emacs_abort ();
}
}
+DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0,
+ doc: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are
evaluated.
+The default value is seen in buffers that do not have their own values
+for this variable. */)
+ (Lisp_Object symbol, Lisp_Object value)
+{
+ set_default_internal (symbol, value, SET_INTERNAL_SET);
+ return value;
+}
+
DEFUN ("setq-default", Fsetq_default, Ssetq_default, 0, UNEVALLED, 0,
doc: /* Set the default value of variable VAR to VALUE.
VAR, the variable name, is literal (not evaluated);
@@ -1736,7 +1761,6 @@ make_blv (struct Lisp_Symbol *sym, bool forwarded,
eassert (!(forwarded && KBOARD_OBJFWDP (valcontents.fwd)));
blv->fwd = forwarded ? valcontents.fwd : NULL;
set_blv_where (blv, Qnil);
- blv->frame_local = 0;
blv->local_if_set = 0;
set_blv_defcell (blv, tem);
set_blv_valcell (blv, tem);
@@ -1783,9 +1807,6 @@ The function `default-value' gets the default value and
`set-default' sets it.
break;
case SYMBOL_LOCALIZED:
blv = SYMBOL_BLV (sym);
- if (blv->frame_local)
- error ("Symbol %s may not be buffer-local",
- SDATA (SYMBOL_NAME (variable)));
break;
case SYMBOL_FORWARDED:
forwarded = 1; valcontents.fwd = SYMBOL_FWD (sym);
@@ -1860,9 +1881,6 @@ Instead, use `add-hook' and specify t for the LOCAL
argument. */)
forwarded = 0; valcontents.value = SYMBOL_VAL (sym); break;
case SYMBOL_LOCALIZED:
blv = SYMBOL_BLV (sym);
- if (blv->frame_local)
- error ("Symbol %s may not be buffer-local",
- SDATA (SYMBOL_NAME (variable)));
break;
case SYMBOL_FORWARDED:
forwarded = 1; valcontents.fwd = SYMBOL_FWD (sym);
@@ -1979,8 +1997,6 @@ From now on the default value will apply in this buffer.
Return VARIABLE. */)
}
case SYMBOL_LOCALIZED:
blv = SYMBOL_BLV (sym);
- if (blv->frame_local)
- return variable;
break;
default: emacs_abort ();
}
@@ -2014,81 +2030,6 @@ From now on the default value will apply in this buffer.
Return VARIABLE. */)
/* Lisp functions for creating and removing buffer-local variables. */
-/* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
- when/if this is removed. */
-
-DEFUN ("make-variable-frame-local", Fmake_variable_frame_local,
Smake_variable_frame_local,
- 1, 1, "vMake Variable Frame Local: ",
- doc: /* Enable VARIABLE to have frame-local bindings.
-This does not create any frame-local bindings for VARIABLE,
-it just makes them possible.
-
-A frame-local binding is actually a frame parameter value.
-If a frame F has a value for the frame parameter named VARIABLE,
-that also acts as a frame-local binding for VARIABLE in F--
-provided this function has been called to enable VARIABLE
-to have frame-local bindings at all.
-
-The only way to create a frame-local binding for VARIABLE in a frame
-is to set the VARIABLE frame parameter of that frame. See
-`modify-frame-parameters' for how to set frame parameters.
-
-Note that since Emacs 23.1, variables cannot be both buffer-local and
-frame-local any more (buffer-local bindings used to take precedence over
-frame-local bindings). */)
- (Lisp_Object variable)
-{
- bool forwarded;
- union Lisp_Val_Fwd valcontents;
- struct Lisp_Symbol *sym;
- struct Lisp_Buffer_Local_Value *blv = NULL;
-
- CHECK_SYMBOL (variable);
- sym = XSYMBOL (variable);
-
- start:
- switch (sym->redirect)
- {
- case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
- case SYMBOL_PLAINVAL:
- forwarded = 0; valcontents.value = SYMBOL_VAL (sym);
- if (EQ (valcontents.value, Qunbound))
- valcontents.value = Qnil;
- break;
- case SYMBOL_LOCALIZED:
- if (SYMBOL_BLV (sym)->frame_local)
- return variable;
- else
- error ("Symbol %s may not be frame-local",
- SDATA (SYMBOL_NAME (variable)));
- case SYMBOL_FORWARDED:
- forwarded = 1; valcontents.fwd = SYMBOL_FWD (sym);
- if (KBOARD_OBJFWDP (valcontents.fwd) || BUFFER_OBJFWDP (valcontents.fwd))
- error ("Symbol %s may not be frame-local",
- SDATA (SYMBOL_NAME (variable)));
- break;
- default: emacs_abort ();
- }
-
- if (SYMBOL_TRAPPED_WRITE_P (variable))
- error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable)));
-
- blv = make_blv (sym, forwarded, valcontents);
- blv->frame_local = 1;
- sym->redirect = SYMBOL_LOCALIZED;
- SET_SYMBOL_BLV (sym, blv);
- {
- Lisp_Object symbol;
- XSETSYMBOL (symbol, sym); /* In case `variable' is aliased. */
- if (let_shadows_global_binding_p (symbol))
- {
- AUTO_STRING (format, "Making %s frame-local while let-bound!");
- CALLN (Fmessage, format, SYMBOL_NAME (variable));
- }
- }
- return variable;
-}
-
DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p,
1, 2, 0,
doc: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
@@ -2120,10 +2061,7 @@ BUFFER defaults to the current buffer. */)
{
elt = XCAR (tail);
if (EQ (variable, XCAR (elt)))
- {
- eassert (!blv->frame_local);
- return Qt;
- }
+ return Qt;
}
return Qnil;
}
@@ -2182,7 +2120,6 @@ DEFUN ("variable-binding-locus", Fvariable_binding_locus,
Svariable_binding_locu
1, 1, 0,
doc: /* Return a value indicating where VARIABLE's current binding
comes from.
If the current binding is buffer-local, the value is the current buffer.
-If the current binding is frame-local, the value is the selected frame.
If the current binding is global (the default), the value is nil. */)
(register Lisp_Object variable)
{
@@ -3616,7 +3553,6 @@ syms_of_data (void)
DEFSYM (Qvoid_variable, "void-variable");
DEFSYM (Qsetting_constant, "setting-constant");
DEFSYM (Qtrapping_constant, "trapping-constant");
- DEFSYM (Qtrapping_frame_local, "trapping-frame-local");
DEFSYM (Qinvalid_read_syntax, "invalid-read-syntax");
DEFSYM (Qinvalid_function, "invalid-function");
@@ -3697,8 +3633,6 @@ syms_of_data (void)
"Attempt to set a constant symbol");
PUT_ERROR (Qtrapping_constant, error_tail,
"Attempt to trap writes to a constant symbol");
- PUT_ERROR (Qtrapping_frame_local, error_tail,
- "Attempt to trap writes to a frame local variable");
PUT_ERROR (Qinvalid_read_syntax, error_tail, "Invalid read syntax");
PUT_ERROR (Qinvalid_function, error_tail, "Invalid function");
PUT_ERROR (Qwrong_number_of_arguments, error_tail,
@@ -3756,6 +3690,9 @@ syms_of_data (void)
DEFSYM (Qchar_table, "char-table");
DEFSYM (Qbool_vector, "bool-vector");
DEFSYM (Qhash_table, "hash-table");
+ DEFSYM (Qthread, "thread");
+ DEFSYM (Qmutex, "mutex");
+ DEFSYM (Qcondition_variable, "condition-variable");
DEFSYM (Qdefun, "defun");
@@ -3796,6 +3733,9 @@ syms_of_data (void)
defsubr (&Ssubrp);
defsubr (&Sbyte_code_function_p);
defsubr (&Schar_or_string_p);
+ defsubr (&Sthreadp);
+ defsubr (&Smutexp);
+ defsubr (&Scondition_variable_p);
defsubr (&Scar);
defsubr (&Scdr);
defsubr (&Scar_safe);
@@ -3822,7 +3762,6 @@ syms_of_data (void)
defsubr (&Smake_variable_buffer_local);
defsubr (&Smake_local_variable);
defsubr (&Skill_local_variable);
- defsubr (&Smake_variable_frame_local);
defsubr (&Slocal_variable_p);
defsubr (&Slocal_variable_if_set_p);
defsubr (&Svariable_binding_locus);
diff --git a/src/emacs.c b/src/emacs.c
index 75b2d6e..dc13b15 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -130,6 +130,8 @@ Lisp_Object Vlibrary_cache;
on subsequent starts. */
bool initialized;
+bool generating_ldefs_boot;
+
#ifndef CANNOT_DUMP
/* Set to true if this instance of Emacs might dump. */
# ifndef DOUG_LEA_MALLOC
@@ -155,10 +157,6 @@ bool running_asynch_code;
bool display_arg;
#endif
-/* An address near the bottom of the stack.
- Tells GC how to save a copy of the stack. */
-char *stack_bottom;
-
#if defined GNU_LINUX && !defined CANNOT_DUMP
/* The gap between BSS end and heap start as far as we can tell. */
static uprintmax_t heap_bss_diff;
@@ -670,7 +668,6 @@ close_output_streams (void)
int
main (int argc, char **argv)
{
- Lisp_Object dummy;
char stack_bottom_variable;
bool do_initial_setlocale;
bool dumping;
@@ -686,10 +683,14 @@ main (int argc, char **argv)
/* If we use --chdir, this records the original directory. */
char *original_pwd = 0;
- stack_base = &dummy;
+ /* Record (approximately) where the stack begins. */
+ stack_bottom = &stack_bottom_variable;
dumping = !initialized && (strcmp (argv[argc - 1], "dump") == 0
- || strcmp (argv[argc - 1], "bootstrap") == 0);
+ || strcmp (argv[argc - 1], "bootstrap") == 0 );
+
+ generating_ldefs_boot = getenv ("GENERATE_LDEFS_BOOT");
+
/* True if address randomization interferes with memory allocation. */
# ifdef __PPC64__
@@ -881,9 +882,6 @@ main (int argc, char **argv)
}
#endif /* HAVE_SETRLIMIT and RLIMIT_STACK and not CYGWIN */
- /* Record (approximately) where the stack begins. */
- stack_bottom = &stack_bottom_variable;
-
clearerr (stdin);
emacs_backtrace (-1);
@@ -1197,6 +1195,7 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
if (!initialized)
{
init_alloc_once ();
+ init_threads_once ();
init_obarray ();
init_eval_once ();
init_charset_once ();
@@ -1243,6 +1242,7 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
}
init_alloc ();
+ init_threads ();
if (do_initial_setlocale)
{
@@ -1585,6 +1585,7 @@ Using an Emacs configured with --with-x-toolkit=lucid
does not have this problem
#endif /* HAVE_W32NOTIFY */
#endif /* WINDOWSNT */
+ syms_of_threads ();
syms_of_profiler ();
keys_of_casefiddle ();
diff --git a/src/eval.c b/src/eval.c
index 8ad06dd..1313093 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -32,7 +32,7 @@ along with GNU Emacs. If not, see
<http://www.gnu.org/licenses/>. */
/* Chain of condition and catch handlers currently in effect. */
-struct handler *handlerlist;
+/* struct handler *handlerlist; */
/* Non-nil means record all fset's and provide's, to be undone
if the file being autoloaded is not fully loaded.
@@ -46,23 +46,25 @@ Lisp_Object Vautoload_queue;
is shutting down. */
Lisp_Object Vrun_hooks;
+/* The commented-out variables below are macros defined in thread.h. */
+
/* Current number of specbindings allocated in specpdl, not counting
the dummy entry specpdl[-1]. */
-ptrdiff_t specpdl_size;
+/* ptrdiff_t specpdl_size; */
/* Pointer to beginning of specpdl. A dummy entry specpdl[-1] exists
only so that its address can be taken. */
-union specbinding *specpdl;
+/* union specbinding *specpdl; */
/* Pointer to first unused element in specpdl. */
-union specbinding *specpdl_ptr;
+/* union specbinding *specpdl_ptr; */
/* Depth in Lisp evaluations and function calls. */
-static EMACS_INT lisp_eval_depth;
+/* static EMACS_INT lisp_eval_depth; */
/* The value of num_nonmacro_input_events as of the last time we
started to enter the debugger. If we decide to enter the debugger
@@ -100,6 +102,13 @@ specpdl_symbol (union specbinding *pdl)
return pdl->let.symbol;
}
+static enum specbind_tag
+specpdl_kind (union specbinding *pdl)
+{
+ eassert (pdl->kind >= SPECPDL_LET);
+ return pdl->let.kind;
+}
+
static Lisp_Object
specpdl_old_value (union specbinding *pdl)
{
@@ -122,6 +131,13 @@ specpdl_where (union specbinding *pdl)
}
static Lisp_Object
+specpdl_saved_value (union specbinding *pdl)
+{
+ eassert (pdl->kind >= SPECPDL_LET);
+ return pdl->let.saved_value;
+}
+
+static Lisp_Object
specpdl_arg (union specbinding *pdl)
{
eassert (pdl->kind == SPECPDL_UNWIND);
@@ -218,20 +234,22 @@ init_eval_once (void)
Vrun_hooks = Qnil;
}
-static struct handler handlerlist_sentinel;
+/* static struct handler handlerlist_sentinel; */
void
init_eval (void)
{
+ byte_stack_list = 0;
specpdl_ptr = specpdl;
{ /* Put a dummy catcher at top-level so that handlerlist is never NULL.
This is important since handlerlist->nextfree holds the freelist
which would otherwise leak every time we unwind back to top-level. */
- handlerlist = handlerlist_sentinel.nextfree = &handlerlist_sentinel;
+ handlerlist_sentinel = xzalloc (sizeof (struct handler));
+ handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
struct handler *c = push_handler (Qunbound, CATCHER);
- eassert (c == &handlerlist_sentinel);
- handlerlist_sentinel.nextfree = NULL;
- handlerlist_sentinel.next = NULL;
+ eassert (c == handlerlist_sentinel);
+ handlerlist_sentinel->nextfree = NULL;
+ handlerlist_sentinel->next = NULL;
}
Vquit_flag = Qnil;
debug_on_next_call = 0;
@@ -1138,7 +1156,8 @@ unwind_to_catch (struct handler *catch, Lisp_Object value)
eassert (handlerlist == catch);
- lisp_eval_depth = catch->lisp_eval_depth;
+ byte_stack_list = catch->byte_stack;
+ lisp_eval_depth = catch->f_lisp_eval_depth;
sys_longjmp (catch->jmp, 1);
}
@@ -1428,10 +1447,11 @@ push_handler_nosignal (Lisp_Object tag_ch_val, enum
handlertype handlertype)
c->tag_or_ch = tag_ch_val;
c->val = Qnil;
c->next = handlerlist;
- c->lisp_eval_depth = lisp_eval_depth;
+ c->f_lisp_eval_depth = lisp_eval_depth;
c->pdlcount = SPECPDL_INDEX ();
c->poll_suppress_count = poll_suppress_count;
c->interrupt_input_blocked = interrupt_input_blocked;
+ c->byte_stack = byte_stack_list;
handlerlist = c;
return c;
}
@@ -1581,7 +1601,7 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object
data, bool keyboard_quit)
}
else
{
- if (handlerlist != &handlerlist_sentinel)
+ if (handlerlist != handlerlist_sentinel)
/* FIXME: This will come right back here if there's no `top-level'
catcher. A better solution would be to abort here, and instead
add a catch-all condition handler so we never come here. */
@@ -1948,6 +1968,28 @@ it defines a macro. */)
if (!CONSP (fundef) || !EQ (Qautoload, XCAR (fundef)))
return fundef;
+ /* In the special case that we are generating ldefs-boot-auto.el,
+ then be noisy about the autoload. */
+ if( generating_ldefs_boot )
+ {
+ fprintf(stderr, "(autoload '");
+ Fprin1(funname,Qexternal_debugging_output);
+ fprintf(stderr, " ");
+ Fprin1(Fcar (Fcdr (fundef)),Qexternal_debugging_output);
+ fprintf(stderr, " nil nil ");
+
+ Lisp_Object kind = Fnth (make_number (4), fundef);
+ if (! (EQ (kind, Qt) || EQ (kind, Qmacro)))
+ {
+ fprintf(stderr, "nil");
+ }
+ else
+ {
+ fprintf(stderr, "t");
+ }
+ fprintf(stderr, ")\n");
+ }
+
if (EQ (macro_only, Qmacro))
{
Lisp_Object kind = Fnth (make_number (4), fundef);
@@ -3175,6 +3217,36 @@ let_shadows_global_binding_p (Lisp_Object symbol)
return 0;
}
+static void
+do_specbind (struct Lisp_Symbol *sym, union specbinding *bind,
+ Lisp_Object value, enum Set_Internal_Bind bindflag)
+{
+ switch (sym->redirect)
+ {
+ case SYMBOL_PLAINVAL:
+ if (!sym->trapped_write)
+ SET_SYMBOL_VAL (sym, value);
+ else
+ set_internal (specpdl_symbol (bind), value, Qnil, bindflag);
+ break;
+
+ case SYMBOL_FORWARDED:
+ if (BUFFER_OBJFWDP (SYMBOL_FWD (sym))
+ && specpdl_kind (bind) == SPECPDL_LET_DEFAULT)
+ {
+ set_default_internal (specpdl_symbol (bind), value, bindflag);
+ return;
+ }
+ /* FALLTHROUGH */
+ case SYMBOL_LOCALIZED:
+ set_internal (specpdl_symbol (bind), value, Qnil, bindflag);
+ break;
+
+ default:
+ emacs_abort ();
+ }
+}
+
/* `specpdl_ptr' describes which variable is
let-bound, so it can be properly undone when we unbind_to.
It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT.
@@ -3206,15 +3278,11 @@ specbind (Lisp_Object symbol, Lisp_Object value)
specpdl_ptr->let.kind = SPECPDL_LET;
specpdl_ptr->let.symbol = symbol;
specpdl_ptr->let.old_value = SYMBOL_VAL (sym);
+ specpdl_ptr->let.saved_value = Qnil;
grow_specpdl ();
- if (!sym->trapped_write)
- SET_SYMBOL_VAL (sym, value);
- else
- set_internal (symbol, value, Qnil, SET_INTERNAL_BIND);
+ do_specbind (sym, specpdl_ptr - 1, value, SET_INTERNAL_BIND);
break;
case SYMBOL_LOCALIZED:
- if (SYMBOL_BLV (sym)->frame_local)
- error ("Frame-local vars cannot be let-bound");
case SYMBOL_FORWARDED:
{
Lisp_Object ovalue = find_symbol_value (symbol);
@@ -3222,6 +3290,7 @@ specbind (Lisp_Object symbol, Lisp_Object value)
specpdl_ptr->let.symbol = symbol;
specpdl_ptr->let.old_value = ovalue;
specpdl_ptr->let.where = Fcurrent_buffer ();
+ specpdl_ptr->let.saved_value = Qnil;
eassert (sym->redirect != SYMBOL_LOCALIZED
|| (EQ (SYMBOL_BLV (sym)->where, Fcurrent_buffer ())));
@@ -3242,7 +3311,7 @@ specbind (Lisp_Object symbol, Lisp_Object value)
{
specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT;
grow_specpdl ();
- Fset_default (symbol, value);
+ do_specbind (sym, specpdl_ptr - 1, value, SET_INTERNAL_BIND);
return;
}
}
@@ -3250,7 +3319,7 @@ specbind (Lisp_Object symbol, Lisp_Object value)
specpdl_ptr->let.kind = SPECPDL_LET;
grow_specpdl ();
- set_internal (symbol, value, Qnil, SET_INTERNAL_BIND);
+ do_specbind (sym, specpdl_ptr - 1, value, SET_INTERNAL_BIND);
break;
}
default: emacs_abort ();
@@ -3294,6 +3363,85 @@ record_unwind_protect_void (void (*function) (void))
grow_specpdl ();
}
+void
+rebind_for_thread_switch (void)
+{
+ union specbinding *bind;
+
+ for (bind = specpdl; bind != specpdl_ptr; ++bind)
+ {
+ if (bind->kind >= SPECPDL_LET)
+ {
+ Lisp_Object value = specpdl_saved_value (bind);
+ Lisp_Object sym = specpdl_symbol (bind);
+ bind->let.saved_value = Qnil;
+ do_specbind (XSYMBOL (sym), bind, value,
+ SET_INTERNAL_THREAD_SWITCH);
+ }
+ }
+}
+
+static void
+do_one_unbind (union specbinding *this_binding, bool unwinding,
+ enum Set_Internal_Bind bindflag)
+{
+ eassert (unwinding || this_binding->kind >= SPECPDL_LET);
+ switch (this_binding->kind)
+ {
+ case SPECPDL_UNWIND:
+ this_binding->unwind.func (this_binding->unwind.arg);
+ break;
+ case SPECPDL_UNWIND_PTR:
+ this_binding->unwind_ptr.func (this_binding->unwind_ptr.arg);
+ break;
+ case SPECPDL_UNWIND_INT:
+ this_binding->unwind_int.func (this_binding->unwind_int.arg);
+ break;
+ case SPECPDL_UNWIND_VOID:
+ this_binding->unwind_void.func ();
+ break;
+ case SPECPDL_BACKTRACE:
+ break;
+ case SPECPDL_LET:
+ { /* If variable has a trivial value (no forwarding), and isn't
+ trapped, we can just set it. */
+ Lisp_Object sym = specpdl_symbol (this_binding);
+ if (SYMBOLP (sym) && XSYMBOL (sym)->redirect == SYMBOL_PLAINVAL)
+ {
+ if (XSYMBOL (sym)->trapped_write == SYMBOL_UNTRAPPED_WRITE)
+ SET_SYMBOL_VAL (XSYMBOL (sym), specpdl_old_value (this_binding));
+ else
+ set_internal (sym, specpdl_old_value (this_binding),
+ Qnil, bindflag);
+ break;
+ }
+ else
+ { /* FALLTHROUGH!!
+ NOTE: we only ever come here if make_local_foo was used for
+ the first time on this var within this let. */
+ }
+ }
+ case SPECPDL_LET_DEFAULT:
+ set_default_internal (specpdl_symbol (this_binding),
+ specpdl_old_value (this_binding),
+ bindflag);
+ break;
+ case SPECPDL_LET_LOCAL:
+ {
+ Lisp_Object symbol = specpdl_symbol (this_binding);
+ Lisp_Object where = specpdl_where (this_binding);
+ Lisp_Object old_value = specpdl_old_value (this_binding);
+ eassert (BUFFERP (where));
+
+ /* If this was a local binding, reset the value in the appropriate
+ buffer, but only if that buffer's binding still exists. */
+ if (!NILP (Flocal_variable_p (symbol, where)))
+ set_internal (symbol, old_value, where, bindflag);
+ }
+ break;
+ }
+}
+
static void
do_nothing (void)
{}
@@ -3353,66 +3501,16 @@ unbind_to (ptrdiff_t count, Lisp_Object value)
while (specpdl_ptr != specpdl + count)
{
- /* Decrement specpdl_ptr before we do the work to unbind it, so
- that an error in unbinding won't try to unbind the same entry
- again. Take care to copy any parts of the binding needed
- before invoking any code that can make more bindings. */
-
- specpdl_ptr--;
+ /* Copy the binding, and decrement specpdl_ptr, before we do
+ the work to unbind it. We decrement first
+ so that an error in unbinding won't try to unbind
+ the same entry again, and we copy the binding first
+ in case more bindings are made during some of the code we run. */
- switch (specpdl_ptr->kind)
- {
- case SPECPDL_UNWIND:
- specpdl_ptr->unwind.func (specpdl_ptr->unwind.arg);
- break;
- case SPECPDL_UNWIND_PTR:
- specpdl_ptr->unwind_ptr.func (specpdl_ptr->unwind_ptr.arg);
- break;
- case SPECPDL_UNWIND_INT:
- specpdl_ptr->unwind_int.func (specpdl_ptr->unwind_int.arg);
- break;
- case SPECPDL_UNWIND_VOID:
- specpdl_ptr->unwind_void.func ();
- break;
- case SPECPDL_BACKTRACE:
- break;
- case SPECPDL_LET:
- { /* If variable has a trivial value (no forwarding), and
- isn't trapped, we can just set it. */
- Lisp_Object sym = specpdl_symbol (specpdl_ptr);
- if (SYMBOLP (sym) && XSYMBOL (sym)->redirect == SYMBOL_PLAINVAL)
- {
- if (XSYMBOL (sym)->trapped_write == SYMBOL_UNTRAPPED_WRITE)
- SET_SYMBOL_VAL (XSYMBOL (sym), specpdl_old_value
(specpdl_ptr));
- else
- set_internal (sym, specpdl_old_value (specpdl_ptr),
- Qnil, SET_INTERNAL_UNBIND);
- break;
- }
- else
- { /* FALLTHROUGH!!
- NOTE: we only ever come here if make_local_foo was used for
- the first time on this var within this let. */
- }
- }
- case SPECPDL_LET_DEFAULT:
- Fset_default (specpdl_symbol (specpdl_ptr),
- specpdl_old_value (specpdl_ptr));
- break;
- case SPECPDL_LET_LOCAL:
- {
- Lisp_Object symbol = specpdl_symbol (specpdl_ptr);
- Lisp_Object where = specpdl_where (specpdl_ptr);
- Lisp_Object old_value = specpdl_old_value (specpdl_ptr);
- eassert (BUFFERP (where));
+ union specbinding this_binding;
+ this_binding = *--specpdl_ptr;
- /* If this was a local binding, reset the value in the appropriate
- buffer, but only if that buffer's binding still exists. */
- if (!NILP (Flocal_variable_p (symbol, where)))
- set_internal (symbol, old_value, where, SET_INTERNAL_UNBIND);
- }
- break;
- }
+ do_one_unbind (&this_binding, true, SET_INTERNAL_UNBIND);
}
if (NILP (Vquit_flag) && !NILP (quitf))
@@ -3421,6 +3519,22 @@ unbind_to (ptrdiff_t count, Lisp_Object value)
return value;
}
+void
+unbind_for_thread_switch (struct thread_state *thr)
+{
+ union specbinding *bind;
+
+ for (bind = thr->m_specpdl_ptr; bind > thr->m_specpdl;)
+ {
+ if ((--bind)->kind >= SPECPDL_LET)
+ {
+ Lisp_Object sym = specpdl_symbol (bind);
+ bind->let.saved_value = find_symbol_value (sym);
+ do_one_unbind (bind, false, SET_INTERNAL_THREAD_SWITCH);
+ }
+ }
+}
+
DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0,
doc: /* Return non-nil if SYMBOL's global binding has been declared
special.
A special variable is one that will be bound dynamically, even in a
@@ -3432,87 +3546,29 @@ context where binding is lexical by default. */)
}
-DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
- doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to
FLAG.
-The debugger is entered when that frame exits, if the flag is non-nil. */)
- (Lisp_Object level, Lisp_Object flag)
-{
- union specbinding *pdl = backtrace_top ();
- register EMACS_INT i;
-
- CHECK_NUMBER (level);
-
- for (i = 0; backtrace_p (pdl) && i < XINT (level); i++)
- pdl = backtrace_next (pdl);
-
- if (backtrace_p (pdl))
- set_backtrace_debug_on_exit (pdl, !NILP (flag));
-
- return flag;
-}
-
-DEFUN ("backtrace", Fbacktrace, Sbacktrace, 0, 0, "",
- doc: /* Print a trace of Lisp function calls currently active.
-Output stream used is value of `standard-output'. */)
- (void)
+static union specbinding *
+get_backtrace_starting_at (Lisp_Object base)
{
union specbinding *pdl = backtrace_top ();
- Lisp_Object tem;
- Lisp_Object old_print_level = Vprint_level;
- if (NILP (Vprint_level))
- XSETFASTINT (Vprint_level, 8);
-
- while (backtrace_p (pdl))
- {
- write_string (backtrace_debug_on_exit (pdl) ? "* " : " ");
- if (backtrace_nargs (pdl) == UNEVALLED)
- {
- Fprin1 (Fcons (backtrace_function (pdl), *backtrace_args (pdl)),
- Qnil);
- write_string ("\n");
- }
- else
- {
- tem = backtrace_function (pdl);
- if (debugger_stack_frame_as_list)
- write_string ("(");
- Fprin1 (tem, Qnil); /* This can QUIT. */
- if (!debugger_stack_frame_as_list)
- write_string ("(");
- {
- ptrdiff_t i;
- for (i = 0; i < backtrace_nargs (pdl); i++)
- {
- if (i || debugger_stack_frame_as_list)
- write_string(" ");
- Fprin1 (backtrace_args (pdl)[i], Qnil);
- }
- }
- write_string (")\n");
- }
- pdl = backtrace_next (pdl);
+ if (!NILP (base))
+ { /* Skip up to `base'. */
+ base = Findirect_function (base, Qt);
+ while (backtrace_p (pdl)
+ && !EQ (base, Findirect_function (backtrace_function (pdl), Qt)))
+ pdl = backtrace_next (pdl);
}
- Vprint_level = old_print_level;
- return Qnil;
+ return pdl;
}
static union specbinding *
get_backtrace_frame (Lisp_Object nframes, Lisp_Object base)
{
- union specbinding *pdl = backtrace_top ();
register EMACS_INT i;
CHECK_NATNUM (nframes);
-
- if (!NILP (base))
- { /* Skip up to `base'. */
- base = Findirect_function (base, Qt);
- while (backtrace_p (pdl)
- && !EQ (base, Findirect_function (backtrace_function (pdl), Qt)))
- pdl = backtrace_next (pdl);
- }
+ union specbinding *pdl = get_backtrace_starting_at (base);
/* Find the frame requested. */
for (i = XFASTINT (nframes); i > 0 && backtrace_p (pdl); i--)
@@ -3521,33 +3577,71 @@ get_backtrace_frame (Lisp_Object nframes, Lisp_Object
base)
return pdl;
}
-DEFUN ("backtrace-frame", Fbacktrace_frame, Sbacktrace_frame, 1, 2, NULL,
- doc: /* Return the function and arguments NFRAMES up from current
execution point.
-If that frame has not evaluated the arguments yet (or is a special form),
-the value is (nil FUNCTION ARG-FORMS...).
-If that frame has evaluated its arguments and called its function already,
-the value is (t FUNCTION ARG-VALUES...).
-A &rest arg is represented as the tail of the list ARG-VALUES.
-FUNCTION is whatever was supplied as car of evaluated list,
-or a lambda expression for macro calls.
-If NFRAMES is more than the number of frames, the value is nil.
-If BASE is non-nil, it should be a function and NFRAMES counts from its
-nearest activation frame. */)
- (Lisp_Object nframes, Lisp_Object base)
+static Lisp_Object
+backtrace_frame_apply (Lisp_Object function, union specbinding *pdl)
{
- union specbinding *pdl = get_backtrace_frame (nframes, base);
-
if (!backtrace_p (pdl))
return Qnil;
+
+ Lisp_Object flags = Qnil;
+ if (backtrace_debug_on_exit (pdl))
+ flags = Fcons (QCdebug_on_exit, Fcons (Qt, Qnil));
+
if (backtrace_nargs (pdl) == UNEVALLED)
- return Fcons (Qnil,
- Fcons (backtrace_function (pdl), *backtrace_args (pdl)));
+ return call4 (function, Qnil, backtrace_function (pdl), *backtrace_args
(pdl), flags);
else
{
Lisp_Object tem = Flist (backtrace_nargs (pdl), backtrace_args (pdl));
+ return call4 (function, Qt, backtrace_function (pdl), tem, flags);
+ }
+}
+
+DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
+ doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to
FLAG.
+The debugger is entered when that frame exits, if the flag is non-nil. */)
+ (Lisp_Object level, Lisp_Object flag)
+{
+ CHECK_NUMBER (level);
+ union specbinding *pdl = get_backtrace_frame(level, Qnil);
+
+ if (backtrace_p (pdl))
+ set_backtrace_debug_on_exit (pdl, !NILP (flag));
+
+ return flag;
+}
+
+DEFUN ("mapbacktrace", Fmapbacktrace, Smapbacktrace, 1, 2, 0,
+ doc: /* Call FUNCTION for each frame in backtrace.
+If BASE is non-nil, it should be a function and iteration will start
+from its nearest activation frame.
+FUNCTION is called with 4 arguments: EVALD, FUNC, ARGS, and FLAGS. If
+a frame has not evaluated its arguments yet or is a special form,
+EVALD is nil and ARGS is a list of forms. If a frame has evaluated
+its arguments and called its function already, EVALD is t and ARGS is
+a list of values.
+FLAGS is a plist of properties of the current frame: currently, the
+only supported property is :debug-on-exit. `mapbacktrace' always
+returns nil. */)
+ (Lisp_Object function, Lisp_Object base)
+{
+ union specbinding *pdl = get_backtrace_starting_at (base);
- return Fcons (Qt, Fcons (backtrace_function (pdl), tem));
+ while (backtrace_p (pdl))
+ {
+ backtrace_frame_apply (function, pdl);
+ pdl = backtrace_next (pdl);
}
+
+ return Qnil;
+}
+
+DEFUN ("backtrace-frame--internal", Fbacktrace_frame_internal,
+ Sbacktrace_frame_internal, 3, 3, NULL,
+ doc: /* Call FUNCTION on stack frame NFRAMES away from BASE.
+Return the result of FUNCTION, or nil if no matching frame could be found. */)
+ (Lisp_Object function, Lisp_Object nframes, Lisp_Object base)
+{
+ return backtrace_frame_apply (function, get_backtrace_frame (nframes, base));
}
/* For backtrace-eval, we want to temporarily unwind the last few elements of
@@ -3743,10 +3837,10 @@ NFRAMES and BASE specify the activation frame to use,
as in `backtrace-frame'.
void
-mark_specpdl (void)
+mark_specpdl (union specbinding *first, union specbinding *ptr)
{
union specbinding *pdl;
- for (pdl = specpdl; pdl != specpdl_ptr; pdl++)
+ for (pdl = first; pdl != ptr; pdl++)
{
switch (pdl->kind)
{
@@ -3772,6 +3866,7 @@ mark_specpdl (void)
case SPECPDL_LET:
mark_object (specpdl_symbol (pdl));
mark_object (specpdl_old_value (pdl));
+ mark_object (specpdl_saved_value (pdl));
break;
case SPECPDL_UNWIND_PTR:
@@ -4004,8 +4099,9 @@ alist of active lexical bindings. */);
defsubr (&Srun_hook_wrapped);
defsubr (&Sfetch_bytecode);
defsubr (&Sbacktrace_debug);
- defsubr (&Sbacktrace);
- defsubr (&Sbacktrace_frame);
+ DEFSYM (QCdebug_on_exit, ":debug-on-exit");
+ defsubr (&Smapbacktrace);
+ defsubr (&Sbacktrace_frame_internal);
defsubr (&Sbacktrace_eval);
defsubr (&Sbacktrace__locals);
defsubr (&Sspecial_variable_p);
diff --git a/src/frame.c b/src/frame.c
index b1d89f3..70ae309 100644
--- a/src/frame.c
+++ b/src/frame.c
@@ -611,7 +611,7 @@ make_frame (bool mini_p)
{
Lisp_Object frame;
struct frame *f;
- struct window *rw, *mw;
+ struct window *rw, *mw UNINIT;
Lisp_Object root_window;
Lisp_Object mini_window;
@@ -2478,28 +2478,6 @@ store_frame_param (struct frame *f, Lisp_Object prop,
Lisp_Object val)
return;
}
- /* If PROP is a symbol which is supposed to have frame-local values,
- and it is set up based on this frame, switch to the global
- binding. That way, we can create or alter the frame-local binding
- without messing up the symbol's status. */
- if (SYMBOLP (prop))
- {
- struct Lisp_Symbol *sym = XSYMBOL (prop);
- start:
- switch (sym->redirect)
- {
- case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
- case SYMBOL_PLAINVAL: case SYMBOL_FORWARDED: break;
- case SYMBOL_LOCALIZED:
- { struct Lisp_Buffer_Local_Value *blv = sym->val.blv;
- if (blv->frame_local && blv_found (blv) && XFRAME (blv->where) == f)
- swap_in_global_binding (sym);
- break;
- }
- default: emacs_abort ();
- }
- }
-
/* The tty color needed to be set before the frame's parameter
alist was updated with the new value. This is not true any more,
but we still do this test early on. */
@@ -2709,13 +2687,7 @@ The meaningful parameters are acted upon, i.e. the frame
is changed
according to their new values, and are also stored in the frame's
parameter list so that `frame-parameters' will return them.
PARMs that are not meaningful are still stored in the frame's parameter
-list, but are otherwise ignored.
-
-The value of frame parameter FOO can also be accessed
-as a frame-local binding for the variable FOO, if you have
-enabled such bindings for that variable with `make-variable-frame-local'.
-Note that this functionality is obsolete as of Emacs 22.2, and its
-use is not recommended. Explicitly check for a frame-parameter instead. */)
+list, but are otherwise ignored. */)
(Lisp_Object frame, Lisp_Object alist)
{
struct frame *f = decode_live_frame (frame);
diff --git a/src/ftcrfont.c b/src/ftcrfont.c
index f62b40f..67b43b6 100644
--- a/src/ftcrfont.c
+++ b/src/ftcrfont.c
@@ -280,30 +280,30 @@ ftcrfont_draw (struct glyph_string *s,
struct font_driver const ftcrfont_driver =
{
- type: LISPSYM_INITIALLY (Qftcr),
- get_cache: ftfont_get_cache,
- list: ftcrfont_list,
- match: ftcrfont_match,
- list_family: ftfont_list_family,
- open: ftcrfont_open,
- close: ftcrfont_close,
- has_char: ftfont_has_char,
- encode_char: ftfont_encode_char,
- text_extents: ftcrfont_text_extents,
- draw: ftcrfont_draw,
- get_bitmap: ftfont_get_bitmap,
- anchor_point: ftfont_anchor_point,
+ .type = LISPSYM_INITIALLY (Qftcr),
+ .get_cache = ftfont_get_cache,
+ .list = ftcrfont_list,
+ .match = ftcrfont_match,
+ .list_family = ftfont_list_family,
+ .open = ftcrfont_open,
+ .close = ftcrfont_close,
+ .has_char = ftfont_has_char,
+ .encode_char = ftfont_encode_char,
+ .text_extents = ftcrfont_text_extents,
+ .draw = ftcrfont_draw,
+ .get_bitmap = ftfont_get_bitmap,
+ .anchor_point = ftfont_anchor_point,
#ifdef HAVE_LIBOTF
- otf_capability: ftfont_otf_capability,
+ .otf_capability = ftfont_otf_capability,
#endif
#if defined HAVE_M17N_FLT && defined HAVE_LIBOTF
- shape: ftfont_shape,
+ .shape = ftfont_shape,
#endif
#ifdef HAVE_OTF_GET_VARIATION_GLYPHS
- get_variation_glyphs: ftfont_variation_glyphs,
+ .get_variation_glyphs = ftfont_variation_glyphs,
#endif
- filter_properties: ftfont_filter_properties,
- combining_capability: ftfont_combining_capability,
+ .filter_properties = ftfont_filter_properties,
+ .combining_capability = ftfont_combining_capability,
};
void
diff --git a/src/ftfont.c b/src/ftfont.c
index 768b524..bcc10c4 100644
--- a/src/ftfont.c
+++ b/src/ftfont.c
@@ -2697,29 +2697,29 @@ ftfont_combining_capability (struct font *font)
static struct font_driver const ftfont_driver =
{
/* We can't draw a text without device dependent functions. */
- type: LISPSYM_INITIALLY (Qfreetype),
- get_cache: ftfont_get_cache,
- list: ftfont_list,
- match: ftfont_match,
- list_family: ftfont_list_family,
- open: ftfont_open,
- close: ftfont_close,
- has_char: ftfont_has_char,
- encode_char: ftfont_encode_char,
- text_extents: ftfont_text_extents,
- get_bitmap: ftfont_get_bitmap,
- anchor_point: ftfont_anchor_point,
+ .type = LISPSYM_INITIALLY (Qfreetype),
+ .get_cache = ftfont_get_cache,
+ .list = ftfont_list,
+ .match = ftfont_match,
+ .list_family = ftfont_list_family,
+ .open = ftfont_open,
+ .close = ftfont_close,
+ .has_char = ftfont_has_char,
+ .encode_char = ftfont_encode_char,
+ .text_extents = ftfont_text_extents,
+ .get_bitmap = ftfont_get_bitmap,
+ .anchor_point = ftfont_anchor_point,
#ifdef HAVE_LIBOTF
- otf_capability: ftfont_otf_capability,
+ .otf_capability = ftfont_otf_capability,
#endif
#if defined HAVE_M17N_FLT && defined HAVE_LIBOTF
- shape: ftfont_shape,
+ .shape = ftfont_shape,
#endif
#ifdef HAVE_OTF_GET_VARIATION_GLYPHS
- get_variation_glyphs: ftfont_variation_glyphs,
+ .get_variation_glyphs = ftfont_variation_glyphs,
#endif
- filter_properties: ftfont_filter_properties,
- combining_capability: ftfont_combining_capability,
+ .filter_properties = ftfont_filter_properties,
+ .combining_capability = ftfont_combining_capability,
};
void
diff --git a/src/ftxfont.c b/src/ftxfont.c
index d8792ac..d1632e3 100644
--- a/src/ftxfont.c
+++ b/src/ftxfont.c
@@ -342,31 +342,31 @@ ftxfont_end_for_frame (struct frame *f)
struct font_driver const ftxfont_driver =
{
/* We can't draw a text without device dependent functions. */
- type: LISPSYM_INITIALLY (Qftx),
- get_cache: ftfont_get_cache,
- list: ftxfont_list,
- match: ftxfont_match,
- list_family: ftfont_list_family,
- open: ftxfont_open,
- close: ftxfont_close,
- has_char: ftfont_has_char,
- encode_char: ftfont_encode_char,
- text_extents: ftfont_text_extents,
- draw: ftxfont_draw,
- get_bitmap: ftfont_get_bitmap,
- anchor_point: ftfont_anchor_point,
+ .type = LISPSYM_INITIALLY (Qftx),
+ .get_cache = ftfont_get_cache,
+ .list = ftxfont_list,
+ .match = ftxfont_match,
+ .list_family = ftfont_list_family,
+ .open = ftxfont_open,
+ .close = ftxfont_close,
+ .has_char = ftfont_has_char,
+ .encode_char = ftfont_encode_char,
+ .text_extents = ftfont_text_extents,
+ .draw = ftxfont_draw,
+ .get_bitmap = ftfont_get_bitmap,
+ .anchor_point = ftfont_anchor_point,
#ifdef HAVE_LIBOTF
- otf_capability: ftfont_otf_capability,
+ .otf_capability = ftfont_otf_capability,
#endif
- end_for_frame: ftxfont_end_for_frame,
+ .end_for_frame = ftxfont_end_for_frame,
#if defined HAVE_M17N_FLT && defined HAVE_LIBOTF
- shape: ftfont_shape,
+ .shape = ftfont_shape,
#endif
#ifdef HAVE_OTF_GET_VARIATION_GLYPHS
- get_variation_glyphs: ftfont_variation_glyphs,
+ .get_variation_glyphs = ftfont_variation_glyphs,
#endif
- filter_properties: ftfont_filter_properties,
- combining_capability: ftfont_combining_capability,
+ .filter_properties = ftfont_filter_properties,
+ .combining_capability = ftfont_combining_capability,
};
void
diff --git a/src/indent.c b/src/indent.c
index b68b602..29c9ffd 100644
--- a/src/indent.c
+++ b/src/indent.c
@@ -1958,6 +1958,20 @@ window_column_x (struct window *w, Lisp_Object window,
return x;
}
+/* Restore window's buffer and point. */
+
+static void
+restore_window_buffer (Lisp_Object list)
+{
+ struct window *w = decode_live_window (XCAR (list));
+ list = XCDR (list);
+ wset_buffer (w, XCAR (list));
+ list = XCDR (list);
+ set_marker_both (w->pointm, w->contents,
+ XFASTINT (XCAR (list)),
+ XFASTINT (XCAR (XCDR (list))));
+}
+
DEFUN ("vertical-motion", Fvertical_motion, Svertical_motion, 1, 3, 0,
doc: /* Move point to start of the screen line LINES lines down.
If LINES is negative, this means moving up.
@@ -1997,10 +2011,9 @@ whether or not it is currently displayed in some window.
*/)
struct it it;
struct text_pos pt;
struct window *w;
- Lisp_Object old_buffer;
- EMACS_INT old_charpos UNINIT, old_bytepos UNINIT;
Lisp_Object lcols;
void *itdata = NULL;
+ ptrdiff_t count = SPECPDL_INDEX ();
/* Allow LINES to be of the form (HPOS . VPOS) aka (COLUMNS . LINES). */
bool lcols_given = CONSP (lines);
@@ -2013,13 +2026,13 @@ whether or not it is currently displayed in some
window. */)
CHECK_NUMBER (lines);
w = decode_live_window (window);
- old_buffer = Qnil;
if (XBUFFER (w->contents) != current_buffer)
{
/* Set the window's buffer temporarily to the current buffer. */
- old_buffer = w->contents;
- old_charpos = marker_position (w->pointm);
- old_bytepos = marker_byte_position (w->pointm);
+ Lisp_Object old = list4 (window, w->contents,
+ make_number (marker_position (w->pointm)),
+ make_number (marker_byte_position (w->pointm)));
+ record_unwind_protect (restore_window_buffer, old);
wset_buffer (w, Fcurrent_buffer ());
set_marker_both (w->pointm, w->contents,
BUF_PT (current_buffer), BUF_PT_BYTE (current_buffer));
@@ -2255,12 +2268,7 @@ whether or not it is currently displayed in some window.
*/)
bidi_unshelve_cache (itdata, 0);
}
- if (BUFFERP (old_buffer))
- {
- wset_buffer (w, old_buffer);
- set_marker_both (w->pointm, w->contents,
- old_charpos, old_bytepos);
- }
+ unbind_to (count, Qnil);
return make_number (it.vpos);
}
diff --git a/src/keyboard.c b/src/keyboard.c
index 01b9b3c..f2ee313 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -148,9 +148,6 @@ static Lisp_Object regular_top_level_message;
static sys_jmp_buf getcjmp;
-/* True while doing kbd input. */
-bool waiting_for_input;
-
/* True while displaying for echoing. Delays C-g throwing. */
static bool echoing;
@@ -2574,6 +2571,9 @@ read_char (int commandflag, Lisp_Object map,
so restore it now. */
restore_getcjmp (save_jump);
pthread_sigmask (SIG_SETMASK, &empty_mask, 0);
+#if THREADS_ENABLED
+ maybe_reacquire_global_lock ();
+#endif
unbind_to (jmpcount, Qnil);
XSETINT (c, quit_char);
internal_last_event_frame = selected_frame;
diff --git a/src/keyboard.h b/src/keyboard.h
index a5ed5e1..435851f 100644
--- a/src/keyboard.h
+++ b/src/keyboard.h
@@ -415,9 +415,6 @@ extern void unuse_menu_items (void);
#define EVENT_HEAD_KIND(event_head) \
(Fget ((event_head), Qevent_kind))
-/* True while doing kbd input. */
-extern bool waiting_for_input;
-
/* Address (if not 0) of struct timespec to zero out if a SIGIO interrupt
happens. */
extern struct timespec *input_available_clear_time;
diff --git a/src/lisp.h b/src/lisp.h
index 11e49b6..79b208a 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -34,6 +34,8 @@ along with GNU Emacs. If not, see
<http://www.gnu.org/licenses/>. */
#include <intprops.h>
#include <verify.h>
+#include "systhread.h"
+
INLINE_HEADER_BEGIN
/* Define a TYPE constant ID as an externally visible name. Use like this:
@@ -588,6 +590,9 @@ INLINE bool (SYMBOLP) (Lisp_Object);
INLINE bool (VECTORLIKEP) (Lisp_Object);
INLINE bool WINDOWP (Lisp_Object);
INLINE bool TERMINALP (Lisp_Object);
+INLINE bool THREADP (Lisp_Object);
+INLINE bool MUTEXP (Lisp_Object);
+INLINE bool CONDVARP (Lisp_Object);
INLINE struct Lisp_Save_Value *XSAVE_VALUE (Lisp_Object);
INLINE struct Lisp_Finalizer *XFINALIZER (Lisp_Object);
INLINE struct Lisp_Symbol *(XSYMBOL) (Lisp_Object);
@@ -614,6 +619,8 @@ extern bool might_dump;
Used during startup to detect startup of dumped Emacs. */
extern bool initialized;
+extern bool generating_ldefs_boot;
+
/* Defined in floatfns.c. */
extern double extract_float (Lisp_Object);
@@ -756,6 +763,39 @@ struct Lisp_Symbol
#include "globals.h"
+/* Header of vector-like objects. This documents the layout constraints on
+ vectors and pseudovectors (objects of PVEC_xxx subtype). It also prevents
+ compilers from being fooled by Emacs's type punning: XSETPSEUDOVECTOR
+ and PSEUDOVECTORP cast their pointers to struct vectorlike_header *,
+ because when two such pointers potentially alias, a compiler won't
+ incorrectly reorder loads and stores to their size fields. See
+ Bug#8546. */
+struct vectorlike_header
+ {
+ /* The only field contains various pieces of information:
+ - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit.
+ - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain
+ vector (0) or a pseudovector (1).
+ - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number
+ of slots) of the vector.
+ - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields:
+ - a) pseudovector subtype held in PVEC_TYPE_MASK field;
+ - b) number of Lisp_Objects slots at the beginning of the object
+ held in PSEUDOVECTOR_SIZE_MASK field. These objects are always
+ traced by the GC;
+ - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and
+ measured in word_size units. Rest fields may also include
+ Lisp_Objects, but these objects usually needs some special treatment
+ during GC.
+ There are some exceptions. For PVEC_FREE, b) is always zero. For
+ PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero.
+ Current layout limits the pseudovectors to 63 PVEC_xxx subtypes,
+ 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */
+ ptrdiff_t size;
+ };
+
+#include "thread.h"
+
/* Convert a Lisp_Object to the corresponding EMACS_INT and vice versa.
At the machine level, these operations are no-ops. */
@@ -802,6 +842,9 @@ enum pvec_type
PVEC_OTHER,
PVEC_XWIDGET,
PVEC_XWIDGET_VIEW,
+ PVEC_THREAD,
+ PVEC_MUTEX,
+ PVEC_CONDVAR,
/* These should be last, check internal_equal to see why. */
PVEC_COMPILED,
@@ -1105,6 +1148,27 @@ XBOOL_VECTOR (Lisp_Object a)
return XUNTAG (a, Lisp_Vectorlike);
}
+INLINE struct thread_state *
+XTHREAD (Lisp_Object a)
+{
+ eassert (THREADP (a));
+ return XUNTAG (a, Lisp_Vectorlike);
+}
+
+INLINE struct Lisp_Mutex *
+XMUTEX (Lisp_Object a)
+{
+ eassert (MUTEXP (a));
+ return XUNTAG (a, Lisp_Vectorlike);
+}
+
+INLINE struct Lisp_CondVar *
+XCONDVAR (Lisp_Object a)
+{
+ eassert (CONDVARP (a));
+ return XUNTAG (a, Lisp_Vectorlike);
+}
+
/* Construct a Lisp_Object from a value or address. */
INLINE Lisp_Object
@@ -1171,6 +1235,9 @@ builtin_lisp_symbol (int index)
#define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE))
#define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR))
#define XSETSUB_CHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUB_CHAR_TABLE))
+#define XSETTHREAD(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_THREAD))
+#define XSETMUTEX(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_MUTEX))
+#define XSETCONDVAR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CONDVAR))
/* Efficiently convert a pointer to a Lisp object and back. The
pointer is represented as a Lisp integer, so the garbage collector
@@ -1402,37 +1469,6 @@ STRING_SET_CHARS (Lisp_Object string, ptrdiff_t newsize)
XSTRING (string)->size = newsize;
}
-/* Header of vector-like objects. This documents the layout constraints on
- vectors and pseudovectors (objects of PVEC_xxx subtype). It also prevents
- compilers from being fooled by Emacs's type punning: XSETPSEUDOVECTOR
- and PSEUDOVECTORP cast their pointers to struct vectorlike_header *,
- because when two such pointers potentially alias, a compiler won't
- incorrectly reorder loads and stores to their size fields. See
- Bug#8546. */
-struct vectorlike_header
- {
- /* The only field contains various pieces of information:
- - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit.
- - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain
- vector (0) or a pseudovector (1).
- - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number
- of slots) of the vector.
- - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields:
- - a) pseudovector subtype held in PVEC_TYPE_MASK field;
- - b) number of Lisp_Objects slots at the beginning of the object
- held in PSEUDOVECTOR_SIZE_MASK field. These objects are always
- traced by the GC;
- - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and
- measured in word_size units. Rest fields may also include
- Lisp_Objects, but these objects usually needs some special treatment
- during GC.
- There are some exceptions. For PVEC_FREE, b) is always zero. For
- PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero.
- Current layout limits the pseudovectors to 63 PVEC_xxx subtypes,
- 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots. */
- ptrdiff_t size;
- };
-
/* A regular vector is just a header plus an array of Lisp_Objects. */
struct Lisp_Vector
@@ -1801,19 +1837,19 @@ INLINE Lisp_Object
INLINE struct Lisp_Symbol *
SYMBOL_ALIAS (struct Lisp_Symbol *sym)
{
- eassert (sym->redirect == SYMBOL_VARALIAS);
+ eassume (sym->redirect == SYMBOL_VARALIAS && sym->val.alias);
return sym->val.alias;
}
INLINE struct Lisp_Buffer_Local_Value *
SYMBOL_BLV (struct Lisp_Symbol *sym)
{
- eassert (sym->redirect == SYMBOL_LOCALIZED);
+ eassume (sym->redirect == SYMBOL_LOCALIZED && sym->val.blv);
return sym->val.blv;
}
INLINE union Lisp_Fwd *
SYMBOL_FWD (struct Lisp_Symbol *sym)
{
- eassert (sym->redirect == SYMBOL_FORWARDED);
+ eassume (sym->redirect == SYMBOL_FORWARDED && sym->val.fwd);
return sym->val.fwd;
}
@@ -1826,19 +1862,19 @@ INLINE void
INLINE void
SET_SYMBOL_ALIAS (struct Lisp_Symbol *sym, struct Lisp_Symbol *v)
{
- eassert (sym->redirect == SYMBOL_VARALIAS);
+ eassume (sym->redirect == SYMBOL_VARALIAS && v);
sym->val.alias = v;
}
INLINE void
SET_SYMBOL_BLV (struct Lisp_Symbol *sym, struct Lisp_Buffer_Local_Value *v)
{
- eassert (sym->redirect == SYMBOL_LOCALIZED);
+ eassume (sym->redirect == SYMBOL_LOCALIZED && v);
sym->val.blv = v;
}
INLINE void
SET_SYMBOL_FWD (struct Lisp_Symbol *sym, union Lisp_Fwd *v)
{
- eassert (sym->redirect == SYMBOL_FORWARDED);
+ eassume (sym->redirect == SYMBOL_FORWARDED && v);
sym->val.fwd = v;
}
@@ -2430,7 +2466,7 @@ struct Lisp_Buffer_Objfwd
};
/* struct Lisp_Buffer_Local_Value is used in a symbol value cell when
- the symbol has buffer-local or frame-local bindings. (Exception:
+ the symbol has buffer-local bindings. (Exception:
some buffer-local variables are built-in, with their values stored
in the buffer structure itself. They are handled differently,
using struct Lisp_Buffer_Objfwd.)
@@ -2458,9 +2494,6 @@ struct Lisp_Buffer_Local_Value
/* True means that merely setting the variable creates a local
binding for the current buffer. */
bool_bf local_if_set : 1;
- /* True means this variable can have frame-local bindings, otherwise, it is
- can have buffer-local bindings. The two cannot be combined. */
- bool_bf frame_local : 1;
/* True means that the binding now loaded was found.
Presumably equivalent to (defcell!=valcell). */
bool_bf found : 1;
@@ -2782,6 +2815,24 @@ FRAMEP (Lisp_Object a)
return PSEUDOVECTORP (a, PVEC_FRAME);
}
+INLINE bool
+THREADP (Lisp_Object a)
+{
+ return PSEUDOVECTORP (a, PVEC_THREAD);
+}
+
+INLINE bool
+MUTEXP (Lisp_Object a)
+{
+ return PSEUDOVECTORP (a, PVEC_MUTEX);
+}
+
+INLINE bool
+CONDVARP (Lisp_Object a)
+{
+ return PSEUDOVECTORP (a, PVEC_CONDVAR);
+}
+
/* Test for image (image . spec) */
INLINE bool
IMAGEP (Lisp_Object x)
@@ -2930,6 +2981,25 @@ CHECK_NUMBER_OR_FLOAT (Lisp_Object x)
CHECK_TYPE (NUMBERP (x), Qnumber_or_marker_p, x);
\
} while (false)
+
+INLINE void
+CHECK_THREAD (Lisp_Object x)
+{
+ CHECK_TYPE (THREADP (x), Qthreadp, x);
+}
+
+INLINE void
+CHECK_MUTEX (Lisp_Object x)
+{
+ CHECK_TYPE (MUTEXP (x), Qmutexp, x);
+}
+
+INLINE void
+CHECK_CONDVAR (Lisp_Object x)
+{
+ CHECK_TYPE (CONDVARP (x), Qcondition_variable_p, x);
+}
+
/* Since we can't assign directly to the CAR or CDR fields of a cons
cell, use these when checking that those fields contain numbers. */
INLINE void
@@ -3141,6 +3211,9 @@ union specbinding
ENUM_BF (specbind_tag) kind : CHAR_BIT;
/* `where' is not used in the case of SPECPDL_LET. */
Lisp_Object symbol, old_value, where;
+ /* Normally this is unused; but it is set to the symbol's
+ current value when a thread is swapped out. */
+ Lisp_Object saved_value;
} let;
struct {
ENUM_BF (specbind_tag) kind : CHAR_BIT;
@@ -3151,9 +3224,10 @@ union specbinding
} bt;
};
-extern union specbinding *specpdl;
-extern union specbinding *specpdl_ptr;
-extern ptrdiff_t specpdl_size;
+/* These 3 are defined as macros in thread.h. */
+/* extern union specbinding *specpdl; */
+/* extern union specbinding *specpdl_ptr; */
+/* extern ptrdiff_t specpdl_size; */
INLINE ptrdiff_t
SPECPDL_INDEX (void)
@@ -3204,18 +3278,15 @@ struct handler
/* Most global vars are reset to their value via the specpdl mechanism,
but a few others are handled by storing their value here. */
sys_jmp_buf jmp;
- EMACS_INT lisp_eval_depth;
+ EMACS_INT f_lisp_eval_depth;
ptrdiff_t pdlcount;
int poll_suppress_count;
int interrupt_input_blocked;
+ struct byte_stack *byte_stack;
};
extern Lisp_Object memory_signal_data;
-/* An address near the bottom of the stack.
- Tells GC how to save a copy of the stack. */
-extern char *stack_bottom;
-
/* Check quit-flag and quit if it is non-nil.
Typing C-g does not directly cause a quit; it only sets Vquit_flag.
So the program needs to do QUIT at times when it is safe to quit.
@@ -3310,7 +3381,7 @@ make_symbol_constant (Lisp_Object sym)
XSYMBOL (sym)->trapped_write = SYMBOL_NOWRITE;
}
-/* Buffer-local (also frame-local) variable access functions. */
+/* Buffer-local variable access functions. */
INLINE int
blv_found (struct Lisp_Buffer_Local_Value *blv)
@@ -3421,10 +3492,14 @@ extern Lisp_Object do_symval_forwarding (union Lisp_Fwd
*);
enum Set_Internal_Bind {
SET_INTERNAL_SET,
SET_INTERNAL_BIND,
- SET_INTERNAL_UNBIND
+ SET_INTERNAL_UNBIND,
+ SET_INTERNAL_THREAD_SWITCH
};
extern void set_internal (Lisp_Object, Lisp_Object, Lisp_Object,
enum Set_Internal_Bind);
+extern void set_default_internal (Lisp_Object, Lisp_Object,
+ enum Set_Internal_Bind bindflag);
+
extern void syms_of_data (void);
extern void swap_in_global_binding (struct Lisp_Symbol *);
@@ -3617,9 +3692,10 @@ extern void refill_memory_reserve (void);
#endif
extern void alloc_unexec_pre (void);
extern void alloc_unexec_post (void);
+extern void mark_stack (char *, char *);
+extern void flush_stack_call_func (void (*func) (void *arg), void *arg);
extern const char *pending_malloc_warning;
extern Lisp_Object zero_vector;
-extern Lisp_Object *stack_base;
extern EMACS_INT consing_since_gc;
extern EMACS_INT gc_relative_threshold;
extern EMACS_INT memory_full_cons_threshold;
@@ -3881,7 +3957,6 @@ extern Lisp_Object Vautoload_queue;
extern Lisp_Object Vrun_hooks;
extern Lisp_Object Vsignaling_function;
extern Lisp_Object inhibit_lisp_code;
-extern struct handler *handlerlist;
/* To run a normal hook, use the appropriate function from the list below.
The calling convention:
@@ -3939,6 +4014,8 @@ extern void clear_unwind_protect (ptrdiff_t);
extern void set_unwind_protect (ptrdiff_t, void (*) (Lisp_Object),
Lisp_Object);
extern void set_unwind_protect_ptr (ptrdiff_t, void (*) (void *), void *);
extern Lisp_Object unbind_to (ptrdiff_t, Lisp_Object);
+extern void rebind_for_thread_switch (void);
+extern void unbind_for_thread_switch (struct thread_state *);
extern _Noreturn void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2);
extern _Noreturn void verror (const char *, va_list)
ATTRIBUTE_FORMAT_PRINTF (1, 0);
@@ -3955,7 +4032,7 @@ extern void init_eval (void);
extern void syms_of_eval (void);
extern void unwind_body (Lisp_Object);
extern ptrdiff_t record_in_backtrace (Lisp_Object, Lisp_Object *, ptrdiff_t);
-extern void mark_specpdl (void);
+extern void mark_specpdl (union specbinding *first, union specbinding *ptr);
extern void get_backtrace (Lisp_Object array);
Lisp_Object backtrace_top_function (void);
extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol);
@@ -3970,6 +4047,9 @@ extern void module_init (void);
extern void syms_of_module (void);
#endif
+/* Defined in thread.c. */
+extern void mark_threads (void);
+
/* Defined in editfns.c. */
extern void insert1 (Lisp_Object);
extern Lisp_Object save_excursion_save (void);
@@ -4250,6 +4330,7 @@ extern int read_bytecode_char (bool);
/* Defined in bytecode.c. */
extern void syms_of_bytecode (void);
+extern void relocate_byte_stack (struct byte_stack *);
extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object, ptrdiff_t, Lisp_Object *);
extern Lisp_Object get_byte_code_arity (Lisp_Object);
diff --git a/src/lread.c b/src/lread.c
index 157a392..35348f1 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -2536,7 +2536,7 @@ read_integer (Lisp_Object readcharfun, EMACS_INT radix)
*p = '\0';
}
- if (! valid)
+ if (valid != 1)
{
sprintf (buf, "integer, radix %"pI"d", radix);
invalid_syntax (buf);
@@ -4271,7 +4271,9 @@ load_path_check (Lisp_Object lpath)
are running uninstalled.
Uses the following logic:
- If CANNOT_DUMP: Use PATH_LOADSEARCH.
+ If CANNOT_DUMP:
+ If Vinstallation_directory is not nil (ie, running uninstalled),
+ use PATH_DUMPLOADSEARCH (ie, build path). Else use PATH_LOADSEARCH.
The remainder is what happens when dumping works:
If purify-flag (ie dumping) just use PATH_DUMPLOADSEARCH.
Otherwise use PATH_LOADSEARCH.
@@ -4305,6 +4307,8 @@ load_path_default (void)
#endif
normal = PATH_LOADSEARCH;
+ if (!NILP (Vinstallation_directory)) normal = PATH_DUMPLOADSEARCH;
+
#ifdef HAVE_NS
lpath = decode_env_path (0, loadpath ? loadpath : normal, 0);
#else
diff --git a/src/macfont.m b/src/macfont.m
index b2f3dff..855b3fe 100644
--- a/src/macfont.m
+++ b/src/macfont.m
@@ -1663,21 +1663,21 @@ static void macfont_filter_properties (Lisp_Object,
Lisp_Object);
static struct font_driver const macfont_driver =
{
- type: LISPSYM_INITIALLY (Qmac_ct),
- get_cache: macfont_get_cache,
- list: macfont_list,
- match: macfont_match,
- list_family: macfont_list_family,
- free_entity: macfont_free_entity,
- open: macfont_open,
- close: macfont_close,
- has_char: macfont_has_char,
- encode_char: macfont_encode_char,
- text_extents: macfont_text_extents,
- draw: macfont_draw,
- shape: macfont_shape,
- get_variation_glyphs: macfont_variation_glyphs,
- filter_properties: macfont_filter_properties,
+ .type = LISPSYM_INITIALLY (Qmac_ct),
+ .get_cache = macfont_get_cache,
+ .list = macfont_list,
+ .match = macfont_match,
+ .list_family = macfont_list_family,
+ .free_entity = macfont_free_entity,
+ .open = macfont_open,
+ .close = macfont_close,
+ .has_char = macfont_has_char,
+ .encode_char = macfont_encode_char,
+ .text_extents = macfont_text_extents,
+ .draw = macfont_draw,
+ .shape = macfont_shape,
+ .get_variation_glyphs = macfont_variation_glyphs,
+ .filter_properties = macfont_filter_properties,
};
static Lisp_Object
diff --git a/src/nsfont.m b/src/nsfont.m
index d14c362..757b217 100644
--- a/src/nsfont.m
+++ b/src/nsfont.m
@@ -1485,18 +1485,18 @@ ns_dump_glyphstring (struct glyph_string *s)
struct font_driver const nsfont_driver =
{
- type: LISPSYM_INITIALLY (Qns),
- case_sensitive: true,
- get_cache: nsfont_get_cache,
- list: nsfont_list,
- match: nsfont_match,
- list_family: nsfont_list_family,
- open: nsfont_open,
- close: nsfont_close,
- has_char: nsfont_has_char,
- encode_char: nsfont_encode_char,
- text_extents: nsfont_text_extents,
- draw: nsfont_draw,
+ .type = LISPSYM_INITIALLY (Qns),
+ .case_sensitive = true,
+ .get_cache = nsfont_get_cache,
+ .list = nsfont_list,
+ .match = nsfont_match,
+ .list_family = nsfont_list_family,
+ .open = nsfont_open,
+ .close = nsfont_close,
+ .has_char = nsfont_has_char,
+ .encode_char = nsfont_encode_char,
+ .text_extents = nsfont_text_extents,
+ .draw = nsfont_draw,
};
void
diff --git a/src/print.c b/src/print.c
index f3db674..6c350fc 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1911,6 +1911,42 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun,
bool escapeflag)
}
printchar ('>', printcharfun);
}
+ else if (THREADP (obj))
+ {
+ print_c_string ("#<thread ", printcharfun);
+ if (STRINGP (XTHREAD (obj)->name))
+ print_string (XTHREAD (obj)->name, printcharfun);
+ else
+ {
+ int len = sprintf (buf, "%p", XTHREAD (obj));
+ strout (buf, len, len, printcharfun);
+ }
+ printchar ('>', printcharfun);
+ }
+ else if (MUTEXP (obj))
+ {
+ print_c_string ("#<mutex ", printcharfun);
+ if (STRINGP (XMUTEX (obj)->name))
+ print_string (XMUTEX (obj)->name, printcharfun);
+ else
+ {
+ int len = sprintf (buf, "%p", XMUTEX (obj));
+ strout (buf, len, len, printcharfun);
+ }
+ printchar ('>', printcharfun);
+ }
+ else if (CONDVARP (obj))
+ {
+ print_c_string ("#<condvar ", printcharfun);
+ if (STRINGP (XCONDVAR (obj)->name))
+ print_string (XCONDVAR (obj)->name, printcharfun);
+ else
+ {
+ int len = sprintf (buf, "%p", XCONDVAR (obj));
+ strout (buf, len, len, printcharfun);
+ }
+ printchar ('>', printcharfun);
+ }
else
{
ptrdiff_t size = ASIZE (obj);
diff --git a/src/process.c b/src/process.c
index 8ab73bd..c5a46f9 100644
--- a/src/process.c
+++ b/src/process.c
@@ -138,7 +138,7 @@ static struct rlimit nofile_limit;
#ifdef WINDOWSNT
extern int sys_select (int, fd_set *, fd_set *, fd_set *,
- struct timespec *, void *);
+ const struct timespec *, const sigset_t *);
#endif
/* Work around GCC 4.3.0 bug with strict overflow checking; see
@@ -260,36 +260,11 @@ static int read_process_output (Lisp_Object, int);
static void create_pty (Lisp_Object);
static void exec_sentinel (Lisp_Object, Lisp_Object);
-/* Mask of bits indicating the descriptors that we wait for input on. */
-
-static fd_set input_wait_mask;
-
-/* Mask that excludes keyboard input descriptor(s). */
-
-static fd_set non_keyboard_wait_mask;
-
-/* Mask that excludes process input descriptor(s). */
-
-static fd_set non_process_wait_mask;
-
-/* Mask for selecting for write. */
-
-static fd_set write_mask;
-
-/* Mask of bits indicating the descriptors that we wait for connect to
- complete on. Once they complete, they are removed from this mask
- and added to the input_wait_mask and non_keyboard_wait_mask. */
-
-static fd_set connect_wait_mask;
-
/* Number of bits set in connect_wait_mask. */
static int num_pending_connects;
-/* The largest descriptor currently in use for a process object; -1 if none.
*/
-static int max_process_desc;
-
-/* The largest descriptor currently in use for input; -1 if none. */
-static int max_input_desc;
+/* The largest descriptor currently in use; -1 if none. */
+static int max_desc;
/* Set the external socket descriptor for Emacs to use when
`make-network-process' is called with a non-nil
@@ -384,6 +359,11 @@ pset_mark (struct Lisp_Process *p, Lisp_Object val)
p->mark = val;
}
static void
+pset_thread (struct Lisp_Process *p, Lisp_Object val)
+{
+ p->thread = val;
+}
+static void
pset_name (struct Lisp_Process *p, Lisp_Object val)
{
p->name = val;
@@ -426,13 +406,34 @@ make_lisp_proc (struct Lisp_Process *p)
return make_lisp_ptr (p, Lisp_Vectorlike);
}
+enum fd_bits
+{
+ /* Read from file descriptor. */
+ FOR_READ = 1,
+ /* Write to file descriptor. */
+ FOR_WRITE = 2,
+ /* This descriptor refers to a keyboard. Only valid if FOR_READ is
+ set. */
+ KEYBOARD_FD = 4,
+ /* This descriptor refers to a process. */
+ PROCESS_FD = 8,
+ /* A non-blocking connect. Only valid if FOR_WRITE is set. */
+ NON_BLOCKING_CONNECT_FD = 16
+};
+
static struct fd_callback_data
{
fd_callback func;
void *data;
-#define FOR_READ 1
-#define FOR_WRITE 2
- int condition; /* Mask of the defines above. */
+ /* Flags from enum fd_bits. */
+ int flags;
+ /* If this fd is locked to a certain thread, this points to it.
+ Otherwise, this is NULL. If an fd is locked to a thread, then
+ only that thread is permitted to wait on it. */
+ struct thread_state *thread;
+ /* If this fd is currently being selected on by a thread, this
+ points to the thread. Otherwise it is NULL. */
+ struct thread_state *waiting_thread;
} fd_callback_info[FD_SETSIZE];
@@ -446,7 +447,25 @@ add_read_fd (int fd, fd_callback func, void *data)
fd_callback_info[fd].func = func;
fd_callback_info[fd].data = data;
- fd_callback_info[fd].condition |= FOR_READ;
+}
+
+static void
+add_non_keyboard_read_fd (int fd)
+{
+ eassert (fd >= 0 && fd < FD_SETSIZE);
+ eassert (fd_callback_info[fd].func == NULL);
+
+ fd_callback_info[fd].flags &= ~KEYBOARD_FD;
+ fd_callback_info[fd].flags |= FOR_READ;
+ if (fd > max_desc)
+ max_desc = fd;
+}
+
+static void
+add_process_read_fd (int fd)
+{
+ add_non_keyboard_read_fd (fd);
+ fd_callback_info[fd].flags |= PROCESS_FD;
}
/* Stop monitoring file descriptor FD for when read is possible. */
@@ -456,8 +475,7 @@ delete_read_fd (int fd)
{
delete_keyboard_wait_descriptor (fd);
- fd_callback_info[fd].condition &= ~FOR_READ;
- if (fd_callback_info[fd].condition == 0)
+ if (fd_callback_info[fd].flags == 0)
{
fd_callback_info[fd].func = 0;
fd_callback_info[fd].data = 0;
@@ -470,28 +488,39 @@ delete_read_fd (int fd)
void
add_write_fd (int fd, fd_callback func, void *data)
{
- FD_SET (fd, &write_mask);
- if (fd > max_input_desc)
- max_input_desc = fd;
+ eassert (fd >= 0 && fd < FD_SETSIZE);
fd_callback_info[fd].func = func;
fd_callback_info[fd].data = data;
- fd_callback_info[fd].condition |= FOR_WRITE;
+ fd_callback_info[fd].flags |= FOR_WRITE;
+ if (fd > max_desc)
+ max_desc = fd;
}
-/* FD is no longer an input descriptor; update max_input_desc accordingly. */
+static void
+add_non_blocking_write_fd (int fd)
+{
+ eassert (fd >= 0 && fd < FD_SETSIZE);
+ eassert (fd_callback_info[fd].func == NULL);
+
+ fd_callback_info[fd].flags |= FOR_WRITE | NON_BLOCKING_CONNECT_FD;
+ if (fd > max_desc)
+ max_desc = fd;
+ ++num_pending_connects;
+}
static void
-delete_input_desc (int fd)
+recompute_max_desc (void)
{
- if (fd == max_input_desc)
- {
- do
- fd--;
- while (0 <= fd && ! (FD_ISSET (fd, &input_wait_mask)
- || FD_ISSET (fd, &write_mask)));
+ int fd;
- max_input_desc = fd;
+ for (fd = max_desc; fd >= 0; --fd)
+ {
+ if (fd_callback_info[fd].flags != 0)
+ {
+ max_desc = fd;
+ break;
+ }
}
}
@@ -500,13 +529,121 @@ delete_input_desc (int fd)
void
delete_write_fd (int fd)
{
- FD_CLR (fd, &write_mask);
- fd_callback_info[fd].condition &= ~FOR_WRITE;
- if (fd_callback_info[fd].condition == 0)
+ if ((fd_callback_info[fd].flags & NON_BLOCKING_CONNECT_FD) != 0)
+ {
+ if (--num_pending_connects < 0)
+ emacs_abort ();
+ }
+ fd_callback_info[fd].flags &= ~(FOR_WRITE | NON_BLOCKING_CONNECT_FD);
+ if (fd_callback_info[fd].flags == 0)
{
fd_callback_info[fd].func = 0;
fd_callback_info[fd].data = 0;
- delete_input_desc (fd);
+
+ if (fd == max_desc)
+ recompute_max_desc ();
+ }
+}
+
+static void
+compute_input_wait_mask (fd_set *mask)
+{
+ int fd;
+
+ FD_ZERO (mask);
+ for (fd = 0; fd <= max_desc; ++fd)
+ {
+ if (fd_callback_info[fd].thread != NULL
+ && fd_callback_info[fd].thread != current_thread)
+ continue;
+ if (fd_callback_info[fd].waiting_thread != NULL
+ && fd_callback_info[fd].waiting_thread != current_thread)
+ continue;
+ if ((fd_callback_info[fd].flags & FOR_READ) != 0)
+ {
+ FD_SET (fd, mask);
+ fd_callback_info[fd].waiting_thread = current_thread;
+ }
+ }
+}
+
+static void
+compute_non_process_wait_mask (fd_set *mask)
+{
+ int fd;
+
+ FD_ZERO (mask);
+ for (fd = 0; fd <= max_desc; ++fd)
+ {
+ if (fd_callback_info[fd].thread != NULL
+ && fd_callback_info[fd].thread != current_thread)
+ continue;
+ if (fd_callback_info[fd].waiting_thread != NULL
+ && fd_callback_info[fd].waiting_thread != current_thread)
+ continue;
+ if ((fd_callback_info[fd].flags & FOR_READ) != 0
+ && (fd_callback_info[fd].flags & PROCESS_FD) == 0)
+ {
+ FD_SET (fd, mask);
+ fd_callback_info[fd].waiting_thread = current_thread;
+ }
+ }
+}
+
+static void
+compute_non_keyboard_wait_mask (fd_set *mask)
+{
+ int fd;
+
+ FD_ZERO (mask);
+ for (fd = 0; fd <= max_desc; ++fd)
+ {
+ if (fd_callback_info[fd].thread != NULL
+ && fd_callback_info[fd].thread != current_thread)
+ continue;
+ if (fd_callback_info[fd].waiting_thread != NULL
+ && fd_callback_info[fd].waiting_thread != current_thread)
+ continue;
+ if ((fd_callback_info[fd].flags & FOR_READ) != 0
+ && (fd_callback_info[fd].flags & KEYBOARD_FD) == 0)
+ {
+ FD_SET (fd, mask);
+ fd_callback_info[fd].waiting_thread = current_thread;
+ }
+ }
+}
+
+static void
+compute_write_mask (fd_set *mask)
+{
+ int fd;
+
+ FD_ZERO (mask);
+ for (fd = 0; fd <= max_desc; ++fd)
+ {
+ if (fd_callback_info[fd].thread != NULL
+ && fd_callback_info[fd].thread != current_thread)
+ continue;
+ if (fd_callback_info[fd].waiting_thread != NULL
+ && fd_callback_info[fd].waiting_thread != current_thread)
+ continue;
+ if ((fd_callback_info[fd].flags & FOR_WRITE) != 0)
+ {
+ FD_SET (fd, mask);
+ fd_callback_info[fd].waiting_thread = current_thread;
+ }
+ }
+}
+
+static void
+clear_waiting_thread_info (void)
+{
+ int fd;
+
+ for (fd = 0; fd <= max_desc; ++fd)
+ {
+ if (fd_callback_info[fd].waiting_thread == current_thread)
+ fd_callback_info[fd].waiting_thread = NULL;
}
}
@@ -716,6 +853,7 @@ make_process (Lisp_Object name)
Lisp data to nil, so do it only for slots which should not be nil. */
pset_status (p, Qrun);
pset_mark (p, Fmake_marker ());
+ pset_thread (p, Fcurrent_thread ());
/* Initialize non-Lisp data. Note that allocate_process zeroes out all
non-Lisp data, so do it only for slots which should not be zero. */
@@ -764,6 +902,27 @@ remove_process (register Lisp_Object proc)
deactivate_process (proc);
}
+void
+update_processes_for_thread_death (Lisp_Object dying_thread)
+{
+ Lisp_Object pair;
+
+ for (pair = Vprocess_alist; !NILP (pair); pair = XCDR (pair))
+ {
+ Lisp_Object process = XCDR (XCAR (pair));
+ if (EQ (XPROCESS (process)->thread, dying_thread))
+ {
+ struct Lisp_Process *proc = XPROCESS (process);
+
+ pset_thread (proc, Qnil);
+ if (proc->infd >= 0)
+ fd_callback_info[proc->infd].thread = NULL;
+ if (proc->outfd >= 0)
+ fd_callback_info[proc->outfd].thread = NULL;
+ }
+ }
+}
+
#ifdef HAVE_GETADDRINFO_A
static void
free_dns_request (Lisp_Object proc)
@@ -1066,17 +1225,11 @@ static void
set_process_filter_masks (struct Lisp_Process *p)
{
if (EQ (p->filter, Qt) && !EQ (p->status, Qlisten))
- {
- FD_CLR (p->infd, &input_wait_mask);
- FD_CLR (p->infd, &non_keyboard_wait_mask);
- }
+ delete_read_fd (p->infd);
else if (EQ (p->filter, Qt)
/* Network or serial process not stopped: */
&& !EQ (p->command, Qt))
- {
- FD_SET (p->infd, &input_wait_mask);
- FD_SET (p->infd, &non_keyboard_wait_mask);
- }
+ add_process_read_fd (p->infd);
}
DEFUN ("set-process-filter", Fset_process_filter, Sset_process_filter,
@@ -1163,6 +1316,44 @@ See `set-process-sentinel' for more info on sentinels.
*/)
return XPROCESS (process)->sentinel;
}
+DEFUN ("set-process-thread", Fset_process_thread, Sset_process_thread,
+ 2, 2, 0,
+ doc: /* Set the locking thread of PROCESS to be THREAD.
+If THREAD is nil, the process is unlocked. */)
+ (Lisp_Object process, Lisp_Object thread)
+{
+ struct Lisp_Process *proc;
+ struct thread_state *tstate;
+
+ CHECK_PROCESS (process);
+ if (NILP (thread))
+ tstate = NULL;
+ else
+ {
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+ }
+
+ proc = XPROCESS (process);
+ pset_thread (proc, thread);
+ if (proc->infd >= 0)
+ fd_callback_info[proc->infd].thread = tstate;
+ if (proc->outfd >= 0)
+ fd_callback_info[proc->outfd].thread = tstate;
+
+ return thread;
+}
+
+DEFUN ("process-thread", Fprocess_thread, Sprocess_thread,
+ 1, 1, 0,
+ doc: /* Ret the locking thread of PROCESS.
+If PROCESS is unlocked, this function returns nil. */)
+ (Lisp_Object process)
+{
+ CHECK_PROCESS (process);
+ return XPROCESS (process)->thread;
+}
+
DEFUN ("set-process-window-size", Fset_process_window_size,
Sset_process_window_size, 3, 3, 0,
doc: /* Tell PROCESS that it has logical window size WIDTH by HEIGHT.
@@ -1840,13 +2031,7 @@ create_process (Lisp_Object process, char **new_argv,
Lisp_Object current_dir)
pset_status (p, Qrun);
if (!EQ (p->command, Qt))
- {
- FD_SET (inchannel, &input_wait_mask);
- FD_SET (inchannel, &non_keyboard_wait_mask);
- }
-
- if (inchannel > max_process_desc)
- max_process_desc = inchannel;
+ add_process_read_fd (inchannel);
/* This may signal an error. */
setup_process_coding_systems (process);
@@ -2079,10 +2264,7 @@ create_pty (Lisp_Object process)
pset_status (p, Qrun);
setup_process_coding_systems (process);
- FD_SET (pty_fd, &input_wait_mask);
- FD_SET (pty_fd, &non_keyboard_wait_mask);
- if (pty_fd > max_process_desc)
- max_process_desc = pty_fd;
+ add_process_read_fd (pty_fd);
pset_tty_name (p, build_string (pty_name));
}
@@ -2166,8 +2348,8 @@ usage: (make-pipe-process &rest ARGS) */)
p->infd = inchannel;
p->outfd = outchannel;
- if (inchannel > max_process_desc)
- max_process_desc = inchannel;
+ if (inchannel > max_desc)
+ max_desc = inchannel;
buffer = Fplist_get (contact, QCbuffer);
if (NILP (buffer))
@@ -2188,10 +2370,7 @@ usage: (make-pipe-process &rest ARGS) */)
eassert (! p->pty_flag);
if (!EQ (p->command, Qt))
- {
- FD_SET (inchannel, &input_wait_mask);
- FD_SET (inchannel, &non_keyboard_wait_mask);
- }
+ add_process_read_fd (inchannel);
p->adaptive_read_buffering
= (NILP (Vprocess_adaptive_read_buffering) ? 0
: EQ (Vprocess_adaptive_read_buffering, Qt) ? 1 : 2);
@@ -2904,8 +3083,8 @@ usage: (make-serial-process &rest ARGS) */)
p->open_fd[SUBPROCESS_STDIN] = fd;
p->infd = fd;
p->outfd = fd;
- if (fd > max_process_desc)
- max_process_desc = fd;
+ if (fd > max_desc)
+ max_desc = fd;
chan_process[fd] = proc;
buffer = Fplist_get (contact, QCbuffer);
@@ -2927,10 +3106,7 @@ usage: (make-serial-process &rest ARGS) */)
eassert (! p->pty_flag);
if (!EQ (p->command, Qt))
- {
- FD_SET (fd, &input_wait_mask);
- FD_SET (fd, &non_keyboard_wait_mask);
- }
+ add_process_read_fd (fd);
if (BUFFERP (buffer))
{
@@ -3102,7 +3278,7 @@ finish_after_tls_connection (Lisp_Object proc)
pset_status (p, Qfailed);
deactivate_process (proc);
}
- else if (! FD_ISSET (p->outfd, &connect_wait_mask))
+ else if ((fd_callback_info[p->outfd].flags & NON_BLOCKING_CONNECT_FD) == 0)
{
/* If we cleared the connection wait mask before we did the TLS
setup, then we have to say that the process is finally "open"
@@ -3412,25 +3588,18 @@ connect_network_socket (Lisp_Object proc, Lisp_Object
addrinfos,
if (! (connecting_status (p->status)
&& EQ (XCDR (p->status), addrinfos)))
pset_status (p, Fcons (Qconnect, addrinfos));
- if (!FD_ISSET (inch, &connect_wait_mask))
- {
- FD_SET (inch, &connect_wait_mask);
- FD_SET (inch, &write_mask);
- num_pending_connects++;
- }
+ if ((fd_callback_info[inch].flags & NON_BLOCKING_CONNECT_FD) == 0)
+ add_non_blocking_write_fd (inch);
}
else
/* A server may have a client filter setting of Qt, but it must
still listen for incoming connects unless it is stopped. */
if ((!EQ (p->filter, Qt) && !EQ (p->command, Qt))
|| (EQ (p->status, Qlisten) && NILP (p->command)))
- {
- FD_SET (inch, &input_wait_mask);
- FD_SET (inch, &non_keyboard_wait_mask);
- }
+ add_process_read_fd (inch);
- if (inch > max_process_desc)
- max_process_desc = inch;
+ if (inch > max_desc)
+ max_desc = inch;
/* Set up the masks based on the process filter. */
set_process_filter_masks (p);
@@ -4361,26 +4530,11 @@ deactivate_process (Lisp_Object proc)
}
#endif
chan_process[inchannel] = Qnil;
- FD_CLR (inchannel, &input_wait_mask);
- FD_CLR (inchannel, &non_keyboard_wait_mask);
- if (FD_ISSET (inchannel, &connect_wait_mask))
- {
- FD_CLR (inchannel, &connect_wait_mask);
- FD_CLR (inchannel, &write_mask);
- if (--num_pending_connects < 0)
- emacs_abort ();
- }
- if (inchannel == max_process_desc)
- {
- /* We just closed the highest-numbered process input descriptor,
- so recompute the highest-numbered one now. */
- int i = inchannel;
- do
- i--;
- while (0 <= i && NILP (chan_process[i]));
-
- max_process_desc = i;
- }
+ delete_read_fd (inchannel);
+ if ((fd_callback_info[inchannel].flags & NON_BLOCKING_CONNECT_FD) != 0)
+ delete_write_fd (inchannel);
+ if (inchannel == max_desc)
+ recompute_max_desc ();
}
}
@@ -4403,13 +4557,23 @@ from PROCESS only, suspending reading output from other
processes.
If JUST-THIS-ONE is an integer, don't run any timers either.
Return non-nil if we received any output from PROCESS (or, if PROCESS
is nil, from any process) before the timeout expired. */)
- (register Lisp_Object process, Lisp_Object seconds, Lisp_Object millisec,
Lisp_Object just_this_one)
+ (Lisp_Object process, Lisp_Object seconds, Lisp_Object millisec,
+ Lisp_Object just_this_one)
{
intmax_t secs;
int nsecs;
if (! NILP (process))
- CHECK_PROCESS (process);
+ {
+ CHECK_PROCESS (process);
+ struct Lisp_Process *proc = XPROCESS (process);
+
+ /* Can't wait for a process that is dedicated to a different
+ thread. */
+ if (!EQ (proc->thread, Qnil) && !EQ (proc->thread, Fcurrent_thread ()))
+ error ("Attempt to accept output from process %s locked to thread %s",
+ SDATA (proc->name), SDATA (XTHREAD (proc->thread)->name));
+ }
else
just_this_one = Qnil;
@@ -4627,13 +4791,9 @@ server_accept_connection (Lisp_Object server, int
channel)
/* Client processes for accepted connections are not stopped initially. */
if (!EQ (p->filter, Qt))
- {
- FD_SET (s, &input_wait_mask);
- FD_SET (s, &non_keyboard_wait_mask);
- }
-
- if (s > max_process_desc)
- max_process_desc = s;
+ add_process_read_fd (s);
+ if (s > max_desc)
+ max_desc = s;
/* Setup coding system for new process based on server process.
This seems to be the proper thing to do, as the coding system
@@ -4746,20 +4906,10 @@ wait_for_tls_negotiation (Lisp_Object process)
#endif
}
-/* This variable is different from waiting_for_input in keyboard.c.
- It is used to communicate to a lisp process-filter/sentinel (via the
- function Fwaiting_for_user_input_p below) whether Emacs was waiting
- for user-input when that process-filter was called.
- waiting_for_input cannot be used as that is by definition 0 when
- lisp code is being evalled.
- This is also used in record_asynch_buffer_change.
- For that purpose, this must be 0
- when not inside wait_reading_process_output. */
-static int waiting_for_user_input_p;
-
static void
wait_reading_process_output_unwind (int data)
{
+ clear_waiting_thread_info ();
waiting_for_user_input_p = data;
}
@@ -4786,8 +4936,8 @@ wait_reading_process_output_1 (void)
READ_KBD is:
0 to ignore keyboard input, or
1 to return when input is available, or
- -1 meaning caller will actually read the input, so don't throw to
- the quit handler, or
+ -1 meaning caller will actually read the input, so don't throw to
+ the quit handler
DO_DISPLAY means redisplay should be done to show subprocess
output that arrives.
@@ -4832,6 +4982,10 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
/* Close to the current time if known, an invalid timespec otherwise. */
struct timespec now = invalid_timespec ();
+ eassert (wait_proc == NULL
+ || EQ (wait_proc->thread, Qnil)
+ || XTHREAD (wait_proc->thread) == current_thread);
+
FD_ZERO (&Available);
FD_ZERO (&Writeok);
@@ -5004,14 +5158,14 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
if (kbd_on_hold_p ())
FD_ZERO (&Atemp);
else
- Atemp = input_wait_mask;
- Ctemp = write_mask;
+ compute_input_wait_mask (&Atemp);
+ compute_write_mask (&Ctemp);
timeout = make_timespec (0, 0);
- if ((pselect (max (max_process_desc, max_input_desc) + 1,
- &Atemp,
- (num_pending_connects > 0 ? &Ctemp : NULL),
- NULL, &timeout, NULL)
+ if ((thread_select (pselect, max_desc + 1,
+ &Atemp,
+ (num_pending_connects > 0 ? &Ctemp : NULL),
+ NULL, &timeout, NULL)
<= 0))
{
/* It's okay for us to do this and then continue with
@@ -5076,17 +5230,17 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
}
else if (!NILP (wait_for_cell))
{
- Available = non_process_wait_mask;
+ compute_non_process_wait_mask (&Available);
check_delay = 0;
check_write = 0;
}
else
{
if (! read_kbd)
- Available = non_keyboard_wait_mask;
+ compute_non_keyboard_wait_mask (&Available);
else
- Available = input_wait_mask;
- Writeok = write_mask;
+ compute_input_wait_mask (&Available);
+ compute_write_mask (&Writeok);
check_delay = wait_proc ? 0 : process_output_delay_count;
check_write = true;
}
@@ -5128,7 +5282,7 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
int adaptive_nsecs = timeout.tv_nsec;
if (timeout.tv_sec > 0 || adaptive_nsecs > READ_OUTPUT_DELAY_MAX)
adaptive_nsecs = READ_OUTPUT_DELAY_MAX;
- for (channel = 0; check_delay > 0 && channel <= max_process_desc;
channel++)
+ for (channel = 0; check_delay > 0 && channel <= max_desc;
channel++)
{
proc = chan_process[channel];
if (NILP (proc))
@@ -5187,17 +5341,18 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
}
#endif
+ nfds = thread_select (
#if defined (HAVE_NS)
- nfds = ns_select
+ ns_select
#elif defined (HAVE_GLIB)
- nfds = xg_select
+ xg_select
#else
- nfds = pselect
+ pselect
#endif
- (max (max_process_desc, max_input_desc) + 1,
- &Available,
- (check_write ? &Writeok : 0),
- NULL, &timeout, NULL);
+ , max_desc + 1,
+ &Available,
+ (check_write ? &Writeok : 0),
+ NULL, &timeout, NULL);
#ifdef HAVE_GNUTLS
/* GnuTLS buffers data internally. In lowat mode it leaves
@@ -5381,22 +5536,22 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
if (no_avail || nfds == 0)
continue;
- for (channel = 0; channel <= max_input_desc; ++channel)
+ for (channel = 0; channel <= max_desc; ++channel)
{
struct fd_callback_data *d = &fd_callback_info[channel];
if (d->func
- && ((d->condition & FOR_READ
+ && ((d->flags & FOR_READ
&& FD_ISSET (channel, &Available))
- || (d->condition & FOR_WRITE
- && FD_ISSET (channel, &write_mask))))
+ || ((d->flags & FOR_WRITE)
+ && FD_ISSET (channel, &Writeok))))
d->func (channel, d->data);
}
- for (channel = 0; channel <= max_process_desc; channel++)
+ for (channel = 0; channel <= max_desc; channel++)
{
if (FD_ISSET (channel, &Available)
- && FD_ISSET (channel, &non_keyboard_wait_mask)
- && !FD_ISSET (channel, &non_process_wait_mask))
+ && ((fd_callback_info[channel].flags & (KEYBOARD_FD | PROCESS_FD))
+ == PROCESS_FD))
{
int nread;
@@ -5461,8 +5616,7 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
/* Clear the descriptor now, so we only raise the
signal once. */
- FD_CLR (channel, &input_wait_mask);
- FD_CLR (channel, &non_keyboard_wait_mask);
+ delete_read_fd (channel);
if (p->pid == -2)
{
@@ -5501,14 +5655,12 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
}
}
if (FD_ISSET (channel, &Writeok)
- && FD_ISSET (channel, &connect_wait_mask))
+ && (fd_callback_info[channel].flags
+ & NON_BLOCKING_CONNECT_FD) != 0)
{
struct Lisp_Process *p;
- FD_CLR (channel, &connect_wait_mask);
- FD_CLR (channel, &write_mask);
- if (--num_pending_connects < 0)
- emacs_abort ();
+ delete_write_fd (channel);
proc = chan_process[channel];
if (NILP (proc))
@@ -5576,10 +5728,7 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
if (0 <= p->infd && !EQ (p->filter, Qt)
&& !EQ (p->command, Qt))
- {
- FD_SET (p->infd, &input_wait_mask);
- FD_SET (p->infd, &non_keyboard_wait_mask);
- }
+ add_process_read_fd (p->infd);
}
}
} /* End for each file descriptor. */
@@ -6550,10 +6699,7 @@ of incoming traffic. */)
p = XPROCESS (process);
if (NILP (p->command)
&& p->infd >= 0)
- {
- FD_CLR (p->infd, &input_wait_mask);
- FD_CLR (p->infd, &non_keyboard_wait_mask);
- }
+ delete_read_fd (p->infd);
pset_command (p, Qt);
return process;
}
@@ -6582,8 +6728,7 @@ traffic. */)
&& p->infd >= 0
&& (!EQ (p->filter, Qt) || EQ (p->status, Qlisten)))
{
- FD_SET (p->infd, &input_wait_mask);
- FD_SET (p->infd, &non_keyboard_wait_mask);
+ add_process_read_fd (p->infd);
#ifdef WINDOWSNT
if (fd_info[ p->infd ].flags & FILE_SERIAL)
PurgeComm (fd_info[ p->infd ].hnd, PURGE_RXABORT | PURGE_RXCLEAR);
@@ -6890,10 +7035,7 @@ handle_child_signal (int sig)
/* clear_desc_flag avoids a compiler bug in Microsoft C. */
if (clear_desc_flag)
- {
- FD_CLR (p->infd, &input_wait_mask);
- FD_CLR (p->infd, &non_keyboard_wait_mask);
- }
+ delete_read_fd (p->infd);
}
}
}
@@ -7253,9 +7395,10 @@ keyboard_bit_set (fd_set *mask)
{
int fd;
- for (fd = 0; fd <= max_input_desc; fd++)
- if (FD_ISSET (fd, mask) && FD_ISSET (fd, &input_wait_mask)
- && !FD_ISSET (fd, &non_keyboard_wait_mask))
+ for (fd = 0; fd <= max_desc; fd++)
+ if (FD_ISSET (fd, mask)
+ && ((fd_callback_info[fd].flags & (FOR_READ | KEYBOARD_FD))
+ == (FOR_READ | KEYBOARD_FD)))
return 1;
return 0;
@@ -7492,14 +7635,8 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
void
add_timer_wait_descriptor (int fd)
{
- FD_SET (fd, &input_wait_mask);
- FD_SET (fd, &non_keyboard_wait_mask);
- FD_SET (fd, &non_process_wait_mask);
- fd_callback_info[fd].func = timerfd_callback;
- fd_callback_info[fd].data = NULL;
- fd_callback_info[fd].condition |= FOR_READ;
- if (fd > max_input_desc)
- max_input_desc = fd;
+ add_read_fd (fd, timerfd_callback, NULL);
+ fd_callback_info[fd].flags &= ~KEYBOARD_FD;
}
#endif /* HAVE_TIMERFD */
@@ -7523,10 +7660,11 @@ void
add_keyboard_wait_descriptor (int desc)
{
#ifdef subprocesses /* Actually means "not MSDOS". */
- FD_SET (desc, &input_wait_mask);
- FD_SET (desc, &non_process_wait_mask);
- if (desc > max_input_desc)
- max_input_desc = desc;
+ eassert (desc >= 0 && desc < FD_SETSIZE);
+ fd_callback_info[desc].flags &= ~PROCESS_FD;
+ fd_callback_info[desc].flags |= (FOR_READ | KEYBOARD_FD);
+ if (desc > max_desc)
+ max_desc = desc;
#endif
}
@@ -7536,9 +7674,12 @@ void
delete_keyboard_wait_descriptor (int desc)
{
#ifdef subprocesses
- FD_CLR (desc, &input_wait_mask);
- FD_CLR (desc, &non_process_wait_mask);
- delete_input_desc (desc);
+ eassert (desc >= 0 && desc < FD_SETSIZE);
+
+ fd_callback_info[desc].flags &= ~(FOR_READ | KEYBOARD_FD | PROCESS_FD);
+
+ if (desc == max_desc)
+ recompute_max_desc ();
#endif
}
@@ -7819,15 +7960,10 @@ init_process_emacs (int sockfd)
}
#endif
- FD_ZERO (&input_wait_mask);
- FD_ZERO (&non_keyboard_wait_mask);
- FD_ZERO (&non_process_wait_mask);
- FD_ZERO (&write_mask);
- max_process_desc = max_input_desc = -1;
external_sock_fd = sockfd;
+ max_desc = -1;
memset (fd_callback_info, 0, sizeof (fd_callback_info));
- FD_ZERO (&connect_wait_mask);
num_pending_connects = 0;
process_output_delay_count = 0;
@@ -8027,6 +8163,8 @@ The variable takes effect when `start-process' is called.
*/);
defsubr (&Sprocess_filter);
defsubr (&Sset_process_sentinel);
defsubr (&Sprocess_sentinel);
+ defsubr (&Sset_process_thread);
+ defsubr (&Sprocess_thread);
defsubr (&Sset_process_window_size);
defsubr (&Sset_process_inherit_coding_system_flag);
defsubr (&Sset_process_query_on_exit_flag);
diff --git a/src/process.h b/src/process.h
index 24c6282..e497ebc 100644
--- a/src/process.h
+++ b/src/process.h
@@ -115,6 +115,9 @@ struct Lisp_Process
/* Pipe process attached to the standard error of this process. */
Lisp_Object stderrproc;
+ /* The thread a process is linked to, or nil for any thread. */
+ Lisp_Object thread;
+
/* After this point, there are no Lisp_Objects any more. */
/* alloc.c assumes that `pid' is the first such non-Lisp slot. */
@@ -274,6 +277,8 @@ extern Lisp_Object network_interface_info (Lisp_Object);
extern Lisp_Object remove_slash_colon (Lisp_Object);
+extern void update_processes_for_thread_death (Lisp_Object);
+
INLINE_HEADER_END
#endif /* EMACS_PROCESS_H */
diff --git a/src/regex.c b/src/regex.c
index afd0d18..f1686cf 100644
--- a/src/regex.c
+++ b/src/regex.c
@@ -4885,12 +4885,6 @@ re_match (struct re_pattern_buffer *bufp, const char
*string,
WEAK_ALIAS (__re_match, re_match)
#endif /* not emacs */
-#ifdef emacs
-/* In Emacs, this is the string or buffer in which we are matching.
- See the declaration in regex.h for details. */
-Lisp_Object re_match_object;
-#endif
-
/* re_match_2 matches the compiled pattern in BUFP against the
the (virtual) concatenation of STRING1 and STRING2 (of length SIZE1
and SIZE2, respectively). We start matching at POS, and stop
diff --git a/src/regex.h b/src/regex.h
index 4922440..2d720e6 100644
--- a/src/regex.h
+++ b/src/regex.h
@@ -171,7 +171,7 @@ typedef unsigned long reg_syntax_t;
some interfaces). When a regexp is compiled, the syntax used is
stored in the pattern buffer, so changing this does not affect
already-compiled regexps. */
-extern reg_syntax_t re_syntax_options;
+/* extern reg_syntax_t re_syntax_options; */
#ifdef emacs
# include "lisp.h"
@@ -180,8 +180,10 @@ extern reg_syntax_t re_syntax_options;
If the value is a Lisp string object, we are matching text in that
string; if it's nil, we are matching text in the current buffer; if
- it's t, we are matching text in a C string. */
-extern Lisp_Object re_match_object;
+ it's t, we are matching text in a C string.
+
+ This is defined as a macro in thread.h, which see. */
+/* extern Lisp_Object re_match_object; */
#endif
/* Roughly the maximum number of failure points on the stack. */
diff --git a/src/search.c b/src/search.c
index e597c33..9d2c8cb 100644
--- a/src/search.c
+++ b/src/search.c
@@ -40,7 +40,7 @@ along with GNU Emacs. If not, see
<http://www.gnu.org/licenses/>. */
struct regexp_cache
{
struct regexp_cache *next;
- Lisp_Object regexp, whitespace_regexp;
+ Lisp_Object regexp, f_whitespace_regexp;
/* Syntax table for which the regexp applies. We need this because
of character classes. If this is t, then the compiled pattern is valid
for any syntax-table. */
@@ -75,12 +75,12 @@ static struct regexp_cache *searchbuf_head;
to call re_set_registers after compiling a new pattern or after
setting the match registers, so that the regex functions will be
able to free or re-allocate it properly. */
-static struct re_registers search_regs;
+/* static struct re_registers search_regs; */
/* The buffer in which the last search was performed, or
Qt if the last search was done in a string;
Qnil if no searching has been done yet. */
-static Lisp_Object last_thing_searched;
+/* static Lisp_Object last_thing_searched; */
static void set_search_regs (ptrdiff_t, ptrdiff_t);
static void save_search_regs (void);
@@ -122,9 +122,9 @@ compile_pattern_1 (struct regexp_cache *cp, Lisp_Object
pattern,
cp->buf.multibyte = STRING_MULTIBYTE (pattern);
cp->buf.charset_unibyte = charset_unibyte;
if (STRINGP (Vsearch_spaces_regexp))
- cp->whitespace_regexp = Vsearch_spaces_regexp;
+ cp->f_whitespace_regexp = Vsearch_spaces_regexp;
else
- cp->whitespace_regexp = Qnil;
+ cp->f_whitespace_regexp = Qnil;
/* rms: I think BLOCK_INPUT is not needed here any more,
because regex.c defines malloc to call xmalloc.
@@ -217,7 +217,7 @@ compile_pattern (Lisp_Object pattern, struct re_registers
*regp,
&& cp->posix == posix
&& (EQ (cp->syntax_table, Qt)
|| EQ (cp->syntax_table, BVAR (current_buffer, syntax_table)))
- && !NILP (Fequal (cp->whitespace_regexp, Vsearch_spaces_regexp))
+ && !NILP (Fequal (cp->f_whitespace_regexp, Vsearch_spaces_regexp))
&& cp->buf.charset_unibyte == charset_unibyte)
break;
@@ -3089,9 +3089,9 @@ If optional arg RESEAT is non-nil, make markers on LIST
point nowhere. */)
/* If true the match data have been saved in saved_search_regs
during the execution of a sentinel or filter. */
-static bool search_regs_saved;
-static struct re_registers saved_search_regs;
-static Lisp_Object saved_last_thing_searched;
+/* static bool search_regs_saved; */
+/* static struct re_registers saved_search_regs; */
+/* static Lisp_Object saved_last_thing_searched; */
/* Called from Flooking_at, Fstring_match, search_buffer, Fstore_match_data
if asynchronous code (filter or sentinel) is running. */
@@ -3401,10 +3401,10 @@ syms_of_search (void)
searchbufs[i].buf.buffer = xmalloc (100);
searchbufs[i].buf.fastmap = searchbufs[i].fastmap;
searchbufs[i].regexp = Qnil;
- searchbufs[i].whitespace_regexp = Qnil;
+ searchbufs[i].f_whitespace_regexp = Qnil;
searchbufs[i].syntax_table = Qnil;
staticpro (&searchbufs[i].regexp);
- staticpro (&searchbufs[i].whitespace_regexp);
+ staticpro (&searchbufs[i].f_whitespace_regexp);
staticpro (&searchbufs[i].syntax_table);
searchbufs[i].next = (i == REGEXP_CACHE_SIZE-1 ? 0 : &searchbufs[i+1]);
}
diff --git a/src/sysdep.c b/src/sysdep.c
index 2576342..86d420f 100644
--- a/src/sysdep.c
+++ b/src/sysdep.c
@@ -51,14 +51,19 @@ along with GNU Emacs. If not, see
<http://www.gnu.org/licenses/>. */
# include <math.h>
#endif
+#ifdef HAVE_SOCKETS
+#include <sys/socket.h>
+#include <netdb.h>
+#endif /* HAVE_SOCKETS */
+
#ifdef WINDOWSNT
#define read sys_read
#define write sys_write
#ifndef STDERR_FILENO
#define STDERR_FILENO fileno(GetStdHandle(STD_ERROR_HANDLE))
#endif
-#include <windows.h>
-#endif /* not WINDOWSNT */
+#include "w32.h"
+#endif /* WINDOWSNT */
#include <sys/types.h>
#include <sys/stat.h>
@@ -139,11 +144,16 @@ static const int baud_convert[] =
bool
disable_address_randomization (void)
{
- bool disabled = false;
int pers = personality (0xffffffff);
- disabled = (! (pers & ADDR_NO_RANDOMIZE)
- && 0 <= personality (pers | ADDR_NO_RANDOMIZE));
- return disabled;
+ if (pers < 0)
+ return false;
+ int desired_pers = pers | ADDR_NO_RANDOMIZE;
+
+ /* Call 'personality' twice, to detect buggy platforms like WSL
+ where 'personality' always returns 0. */
+ return (pers != desired_pers
+ && personality (desired_pers) == pers
+ && personality (0xffffffff) == desired_pers);
}
#endif
@@ -760,6 +770,23 @@ unblock_child_signal (sigset_t const *oldset)
pthread_sigmask (SIG_SETMASK, oldset, 0);
}
+/* Block SIGINT. */
+void
+block_interrupt_signal (sigset_t *oldset)
+{
+ sigset_t blocked;
+ sigemptyset (&blocked);
+ sigaddset (&blocked, SIGINT);
+ pthread_sigmask (SIG_BLOCK, &blocked, oldset);
+}
+
+/* Restore previously saved signal mask. */
+void
+restore_signal_mask (sigset_t const *oldset)
+{
+ pthread_sigmask (SIG_SETMASK, oldset, 0);
+}
+
#endif /* !MSDOS */
/* Saving and restoring the process group of Emacs's terminal. */
diff --git a/src/syssignal.h b/src/syssignal.h
index 3de83c7..62704fc 100644
--- a/src/syssignal.h
+++ b/src/syssignal.h
@@ -25,6 +25,8 @@ along with GNU Emacs. If not, see
<http://www.gnu.org/licenses/>. */
extern void init_signals (bool);
extern void block_child_signal (sigset_t *);
extern void unblock_child_signal (sigset_t const *);
+extern void block_interrupt_signal (sigset_t *);
+extern void restore_signal_mask (sigset_t const *);
extern void block_tty_out_signal (sigset_t *);
extern void unblock_tty_out_signal (sigset_t const *);
diff --git a/src/systhread.c b/src/systhread.c
new file mode 100644
index 0000000..a2c556f
--- /dev/null
+++ b/src/systhread.c
@@ -0,0 +1,417 @@
+/* System thread definitions
+Copyright (C) 2012-2016 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 <http://www.gnu.org/licenses/>. */
+
+#include <config.h>
+#include <setjmp.h>
+#include "lisp.h"
+
+#ifndef THREADS_ENABLED
+
+void
+sys_mutex_init (sys_mutex_t *m)
+{
+ *m = 0;
+}
+
+void
+sys_mutex_lock (sys_mutex_t *m)
+{
+}
+
+void
+sys_mutex_unlock (sys_mutex_t *m)
+{
+}
+
+void
+sys_mutex_destroy (sys_mutex_t *m)
+{
+}
+
+void
+sys_cond_init (sys_cond_t *c)
+{
+ *c = 0;
+}
+
+void
+sys_cond_wait (sys_cond_t *c, sys_mutex_t *m)
+{
+}
+
+void
+sys_cond_signal (sys_cond_t *c)
+{
+}
+
+void
+sys_cond_broadcast (sys_cond_t *c)
+{
+}
+
+void
+sys_cond_destroy (sys_cond_t *c)
+{
+}
+
+sys_thread_t
+sys_thread_self (void)
+{
+ return 0;
+}
+
+int
+sys_thread_equal (sys_thread_t x, sys_thread_t y)
+{
+ return x == y;
+}
+
+int
+sys_thread_create (sys_thread_t *t, const char *name,
+ thread_creation_function *func, void *datum)
+{
+ return 0;
+}
+
+void
+sys_thread_yield (void)
+{
+}
+
+#elif defined (HAVE_PTHREAD)
+
+#include <sched.h>
+
+#ifdef HAVE_SYS_PRCTL_H
+#include <sys/prctl.h>
+#endif
+
+void
+sys_mutex_init (sys_mutex_t *mutex)
+{
+ pthread_mutex_init (mutex, NULL);
+}
+
+void
+sys_mutex_lock (sys_mutex_t *mutex)
+{
+ pthread_mutex_lock (mutex);
+}
+
+void
+sys_mutex_unlock (sys_mutex_t *mutex)
+{
+ pthread_mutex_unlock (mutex);
+}
+
+void
+sys_mutex_destroy (sys_mutex_t *mutex)
+{
+ pthread_mutex_destroy (mutex);
+}
+
+void
+sys_cond_init (sys_cond_t *cond)
+{
+ pthread_cond_init (cond, NULL);
+}
+
+void
+sys_cond_wait (sys_cond_t *cond, sys_mutex_t *mutex)
+{
+ pthread_cond_wait (cond, mutex);
+}
+
+void
+sys_cond_signal (sys_cond_t *cond)
+{
+ pthread_cond_signal (cond);
+}
+
+void
+sys_cond_broadcast (sys_cond_t *cond)
+{
+ pthread_cond_broadcast (cond);
+}
+
+void
+sys_cond_destroy (sys_cond_t *cond)
+{
+ pthread_cond_destroy (cond);
+}
+
+sys_thread_t
+sys_thread_self (void)
+{
+ return pthread_self ();
+}
+
+int
+sys_thread_equal (sys_thread_t one, sys_thread_t two)
+{
+ return pthread_equal (one, two);
+}
+
+int
+sys_thread_create (sys_thread_t *thread_ptr, const char *name,
+ thread_creation_function *func, void *arg)
+{
+ pthread_attr_t attr;
+ int result = 0;
+
+ if (pthread_attr_init (&attr))
+ return 0;
+
+ if (!pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED))
+ {
+ result = pthread_create (thread_ptr, &attr, func, arg) == 0;
+#if defined (HAVE_SYS_PRCTL_H) && defined (HAVE_PRCTL) && defined (PR_SET_NAME)
+ if (result && name != NULL)
+ prctl (PR_SET_NAME, name);
+#endif
+ }
+
+ pthread_attr_destroy (&attr);
+
+ return result;
+}
+
+void
+sys_thread_yield (void)
+{
+ sched_yield ();
+}
+
+#elif defined (WINDOWSNT)
+
+#include <windows.h>
+
+/* Cannot include <process.h> because of the local header by the same
+ name, sigh. */
+uintptr_t _beginthread (void (__cdecl *)(void *), unsigned, void *);
+
+/* Mutexes are implemented as critical sections, because they are
+ faster than Windows mutex objects (implemented in userspace), and
+ satisfy the requirements, since we only need to synchronize within a
+ single process. */
+void
+sys_mutex_init (sys_mutex_t *mutex)
+{
+ InitializeCriticalSection ((LPCRITICAL_SECTION)mutex);
+}
+
+void
+sys_mutex_lock (sys_mutex_t *mutex)
+{
+ /* FIXME: What happens if the owning thread exits without releasing
+ the mutex? According to MSDN, the result is undefined behavior. */
+ EnterCriticalSection ((LPCRITICAL_SECTION)mutex);
+}
+
+void
+sys_mutex_unlock (sys_mutex_t *mutex)
+{
+ LeaveCriticalSection ((LPCRITICAL_SECTION)mutex);
+}
+
+void
+sys_mutex_destroy (sys_mutex_t *mutex)
+{
+ /* FIXME: According to MSDN, deleting a critical session that is
+ owned by a thread leaves the other threads waiting for the
+ critical session in an undefined state. Posix docs seem to say
+ the same about pthread_mutex_destroy. Do we need to protect
+ against such calamities? */
+ DeleteCriticalSection ((LPCRITICAL_SECTION)mutex);
+}
+
+void
+sys_cond_init (sys_cond_t *cond)
+{
+ cond->initialized = false;
+ cond->wait_count = 0;
+ /* Auto-reset event for signal. */
+ cond->events[CONDV_SIGNAL] = CreateEvent (NULL, FALSE, FALSE, NULL);
+ /* Manual-reset event for broadcast. */
+ cond->events[CONDV_BROADCAST] = CreateEvent (NULL, TRUE, FALSE, NULL);
+ if (!cond->events[CONDV_SIGNAL] || !cond->events[CONDV_BROADCAST])
+ return;
+ InitializeCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
+ cond->initialized = true;
+}
+
+void
+sys_cond_wait (sys_cond_t *cond, sys_mutex_t *mutex)
+{
+ DWORD wait_result;
+ bool last_thread_waiting;
+
+ if (!cond->initialized)
+ return;
+
+ /* Increment the wait count avoiding race conditions. */
+ EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
+ cond->wait_count++;
+ LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
+
+ /* Release the mutex and wait for either the signal or the broadcast
+ event. */
+ LeaveCriticalSection ((LPCRITICAL_SECTION)mutex);
+ wait_result = WaitForMultipleObjects (2, cond->events, FALSE, INFINITE);
+
+ /* Decrement the wait count and see if we are the last thread
+ waiting on the condition variable. */
+ EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
+ cond->wait_count--;
+ last_thread_waiting =
+ wait_result == WAIT_OBJECT_0 + CONDV_BROADCAST
+ && cond->wait_count == 0;
+ LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
+
+ /* Broadcast uses a manual-reset event, so when the last thread is
+ released, we must manually reset that event. */
+ if (last_thread_waiting)
+ ResetEvent (cond->events[CONDV_BROADCAST]);
+
+ /* Per the API, re-acquire the mutex. */
+ EnterCriticalSection ((LPCRITICAL_SECTION)mutex);
+}
+
+void
+sys_cond_signal (sys_cond_t *cond)
+{
+ bool threads_waiting;
+
+ if (!cond->initialized)
+ return;
+
+ EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
+ threads_waiting = cond->wait_count > 0;
+ LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
+
+ if (threads_waiting)
+ SetEvent (cond->events[CONDV_SIGNAL]);
+}
+
+void
+sys_cond_broadcast (sys_cond_t *cond)
+{
+ bool threads_waiting;
+
+ if (!cond->initialized)
+ return;
+
+ EnterCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
+ threads_waiting = cond->wait_count > 0;
+ LeaveCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
+
+ if (threads_waiting)
+ SetEvent (cond->events[CONDV_BROADCAST]);
+}
+
+void
+sys_cond_destroy (sys_cond_t *cond)
+{
+ if (cond->events[CONDV_SIGNAL])
+ CloseHandle (cond->events[CONDV_SIGNAL]);
+ if (cond->events[CONDV_BROADCAST])
+ CloseHandle (cond->events[CONDV_BROADCAST]);
+
+ if (!cond->initialized)
+ return;
+
+ /* FIXME: What if wait_count is non-zero, i.e. there are still
+ threads waiting on this condition variable? */
+ DeleteCriticalSection ((LPCRITICAL_SECTION)&cond->wait_count_lock);
+}
+
+sys_thread_t
+sys_thread_self (void)
+{
+ return (sys_thread_t) GetCurrentThreadId ();
+}
+
+int
+sys_thread_equal (sys_thread_t one, sys_thread_t two)
+{
+ return one == two;
+}
+
+static thread_creation_function *thread_start_address;
+
+/* _beginthread wants a void function, while we are passed a function
+ that returns a pointer. So we use a wrapper. */
+static void
+w32_beginthread_wrapper (void *arg)
+{
+ (void)thread_start_address (arg);
+}
+
+int
+sys_thread_create (sys_thread_t *thread_ptr, const char *name,
+ thread_creation_function *func, void *arg)
+{
+ /* FIXME: Do threads that run Lisp require some minimum amount of
+ stack? Zero here means each thread will get the same amount as
+ the main program. On GNU/Linux, it seems like the stack is 2MB
+ by default, overridden by RLIMIT_STACK at program start time.
+ Not sure what to do with this. See also the comment in
+ w32proc.c:new_child. */
+ const unsigned stack_size = 0;
+ uintptr_t thandle;
+
+ thread_start_address = func;
+
+ /* We use _beginthread rather than CreateThread because the former
+ arranges for the thread handle to be automatically closed when
+ the thread exits, thus preventing handle leaks and/or the need to
+ track all the threads and close their handles when they exit.
+ Also, MSDN seems to imply that code which uses CRT _must_ call
+ _beginthread, although if that is true, we already violate that
+ rule in many places... */
+ thandle = _beginthread (w32_beginthread_wrapper, stack_size, arg);
+ if (thandle == (uintptr_t)-1L)
+ return 0;
+
+ /* Kludge alert! We use the Windows thread ID, an unsigned 32-bit
+ number, as the sys_thread_t type, because that ID is the only
+ unique identifier of a thread on Windows. But _beginthread
+ returns a handle of the thread, and there's no easy way of
+ getting the thread ID given a handle (GetThreadId is available
+ only since Vista, so we cannot use it portably). Fortunately,
+ the value returned by sys_thread_create is not used by its
+ callers; instead, run_thread, which runs in the context of the
+ new thread, calls sys_thread_self and uses its return value;
+ sys_thread_self in this implementation calls GetCurrentThreadId.
+ Therefore, we return some more or less arbitrary value of the
+ thread ID from this function. */
+ *thread_ptr = thandle & 0xFFFFFFFF;
+ return 1;
+}
+
+void
+sys_thread_yield (void)
+{
+ Sleep (0);
+}
+
+#else
+
+#error port me
+
+#endif
diff --git a/src/systhread.h b/src/systhread.h
new file mode 100644
index 0000000..ffe2998
--- /dev/null
+++ b/src/systhread.h
@@ -0,0 +1,112 @@
+/* System thread definitions
+Copyright (C) 2012-2016 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 <http://www.gnu.org/licenses/>. */
+
+#ifndef SYSTHREAD_H
+#define SYSTHREAD_H
+
+#ifdef THREADS_ENABLED
+
+#ifdef HAVE_PTHREAD
+
+#include <pthread.h>
+
+/* A system mutex is just a pthread mutex. This is only used for the
+ GIL. */
+typedef pthread_mutex_t sys_mutex_t;
+
+typedef pthread_cond_t sys_cond_t;
+
+/* A system thread. */
+typedef pthread_t sys_thread_t;
+
+#else /* HAVE_PTHREAD */
+
+#ifdef WINDOWSNT
+
+/* This header is indirectly included in every source file. We don't
+ want to include windows.h in every source file, so we repeat
+ declarations of the few necessary data types here (under different
+ names, to avoid conflicts with files that do include
+ windows.h). */
+
+typedef struct {
+ struct _CRITICAL_SECTION_DEBUG *DebugInfo;
+ long LockCount;
+ long RecursionCount;
+ void *OwningThread;
+ void *LockSemaphore;
+ unsigned long SpinCount;
+} w32thread_critsect;
+
+enum { CONDV_SIGNAL = 0, CONDV_BROADCAST = 1, CONDV_MAX = 2 };
+
+typedef struct {
+ /* Count of threads that are waiting for this condition variable. */
+ unsigned wait_count;
+ /* Critical section to protect changes to the count above. */
+ w32thread_critsect wait_count_lock;
+ /* Handles of events used for signal and broadcast. */
+ void *events[CONDV_MAX];
+ bool initialized;
+} w32thread_cond_t;
+
+typedef w32thread_critsect sys_mutex_t;
+
+typedef w32thread_cond_t sys_cond_t;
+
+typedef unsigned long sys_thread_t;
+
+#else /* !WINDOWSNT */
+
+#error port me
+
+#endif /* WINDOWSNT */
+#endif /* HAVE_PTHREAD */
+
+#else /* THREADS_ENABLED */
+
+/* For the no-threads case we can simply use dummy definitions. */
+typedef int sys_mutex_t;
+typedef int sys_cond_t;
+typedef int sys_thread_t;
+
+#endif /* THREADS_ENABLED */
+
+typedef void *(thread_creation_function) (void *);
+
+extern void sys_mutex_init (sys_mutex_t *);
+extern void sys_mutex_lock (sys_mutex_t *);
+extern void sys_mutex_unlock (sys_mutex_t *);
+extern void sys_mutex_destroy (sys_mutex_t *);
+
+extern void sys_cond_init (sys_cond_t *);
+extern void sys_cond_wait (sys_cond_t *, sys_mutex_t *);
+extern void sys_cond_signal (sys_cond_t *);
+extern void sys_cond_broadcast (sys_cond_t *);
+extern void sys_cond_destroy (sys_cond_t *);
+
+extern sys_thread_t sys_thread_self (void);
+extern int sys_thread_equal (sys_thread_t, sys_thread_t);
+
+extern int sys_thread_create (sys_thread_t *, const char *,
+ thread_creation_function *,
+ void *);
+
+extern void sys_thread_yield (void);
+
+#endif /* SYSTHREAD_H */
diff --git a/src/thread.c b/src/thread.c
new file mode 100644
index 0000000..3f95952
--- /dev/null
+++ b/src/thread.c
@@ -0,0 +1,1012 @@
+/* Threading code.
+Copyright (C) 2012-2016 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 <http://www.gnu.org/licenses/>. */
+
+
+#include <config.h>
+#include <setjmp.h>
+#include "lisp.h"
+#include "character.h"
+#include "buffer.h"
+#include "process.h"
+#include "coding.h"
+#include "syssignal.h"
+
+static struct thread_state primary_thread;
+
+struct thread_state *current_thread = &primary_thread;
+
+static struct thread_state *all_threads = &primary_thread;
+
+static sys_mutex_t global_lock;
+
+extern int poll_suppress_count;
+extern volatile int interrupt_input_blocked;
+
+
+
+/* m_specpdl is set when the thread is created and cleared when the
+ thread dies. */
+#define thread_alive_p(STATE) ((STATE)->m_specpdl != NULL)
+
+
+
+static void
+release_global_lock (void)
+{
+ sys_mutex_unlock (&global_lock);
+}
+
+/* You must call this after acquiring the global lock.
+ acquire_global_lock does it for you. */
+static void
+post_acquire_global_lock (struct thread_state *self)
+{
+ struct thread_state *prev_thread = current_thread;
+
+ /* Do this early on, so that code below could signal errors (e.g.,
+ unbind_for_thread_switch might) correctly, because we are already
+ running in the context of the thread pointed by SELF. */
+ current_thread = self;
+
+ if (prev_thread != current_thread)
+ {
+ /* PREV_THREAD is NULL if the previously current thread
+ exited. In this case, there is no reason to unbind, and
+ trying will crash. */
+ if (prev_thread != NULL)
+ unbind_for_thread_switch (prev_thread);
+ rebind_for_thread_switch ();
+
+ /* Set the new thread's current buffer. This needs to be done
+ even if it is the same buffer as that of the previous thread,
+ because of thread-local bindings. */
+ set_buffer_internal_2 (current_buffer);
+ }
+
+ /* We could have been signaled while waiting to grab the global lock
+ for the first time since this thread was created, in which case
+ we didn't yet have the opportunity to set up the handlers. Delay
+ raising the signal in that case (it will be actually raised when
+ the thread comes here after acquiring the lock the next time). */
+ if (!NILP (current_thread->error_symbol) && handlerlist)
+ {
+ Lisp_Object sym = current_thread->error_symbol;
+ Lisp_Object data = current_thread->error_data;
+
+ current_thread->error_symbol = Qnil;
+ current_thread->error_data = Qnil;
+ Fsignal (sym, data);
+ }
+}
+
+static void
+acquire_global_lock (struct thread_state *self)
+{
+ sys_mutex_lock (&global_lock);
+ post_acquire_global_lock (self);
+}
+
+/* This is called from keyboard.c when it detects that SIGINT
+ interrupted thread_select before the current thread could acquire
+ the lock. We must acquire the lock to prevent a thread from
+ running without holding the global lock, and to avoid repeated
+ calls to sys_mutex_unlock, which invokes undefined behavior. */
+void
+maybe_reacquire_global_lock (void)
+{
+ if (current_thread->not_holding_lock)
+ {
+ struct thread_state *self = current_thread;
+
+ acquire_global_lock (self);
+ current_thread->not_holding_lock = 0;
+ }
+}
+
+
+
+static void
+lisp_mutex_init (lisp_mutex_t *mutex)
+{
+ mutex->owner = NULL;
+ mutex->count = 0;
+ sys_cond_init (&mutex->condition);
+}
+
+static int
+lisp_mutex_lock (lisp_mutex_t *mutex, int new_count)
+{
+ struct thread_state *self;
+
+ if (mutex->owner == NULL)
+ {
+ mutex->owner = current_thread;
+ mutex->count = new_count == 0 ? 1 : new_count;
+ return 0;
+ }
+ if (mutex->owner == current_thread)
+ {
+ eassert (new_count == 0);
+ ++mutex->count;
+ return 0;
+ }
+
+ self = current_thread;
+ self->wait_condvar = &mutex->condition;
+ while (mutex->owner != NULL && (new_count != 0
+ || NILP (self->error_symbol)))
+ sys_cond_wait (&mutex->condition, &global_lock);
+ self->wait_condvar = NULL;
+
+ if (new_count == 0 && !NILP (self->error_symbol))
+ return 1;
+
+ mutex->owner = self;
+ mutex->count = new_count == 0 ? 1 : new_count;
+
+ return 1;
+}
+
+static int
+lisp_mutex_unlock (lisp_mutex_t *mutex)
+{
+ if (mutex->owner != current_thread)
+ error ("Cannot unlock mutex owned by another thread");
+
+ if (--mutex->count > 0)
+ return 0;
+
+ mutex->owner = NULL;
+ sys_cond_broadcast (&mutex->condition);
+
+ return 1;
+}
+
+static unsigned int
+lisp_mutex_unlock_for_wait (lisp_mutex_t *mutex)
+{
+ unsigned int result = mutex->count;
+
+ /* Ensured by condvar code. */
+ eassert (mutex->owner == current_thread);
+
+ mutex->count = 0;
+ mutex->owner = NULL;
+ sys_cond_broadcast (&mutex->condition);
+
+ return result;
+}
+
+static void
+lisp_mutex_destroy (lisp_mutex_t *mutex)
+{
+ sys_cond_destroy (&mutex->condition);
+}
+
+static int
+lisp_mutex_owned_p (lisp_mutex_t *mutex)
+{
+ return mutex->owner == current_thread;
+}
+
+
+
+DEFUN ("make-mutex", Fmake_mutex, Smake_mutex, 0, 1, 0,
+ doc: /* Create a mutex.
+A mutex provides a synchronization point for threads.
+Only one thread at a time can hold a mutex. Other threads attempting
+to acquire it will block until the mutex is available.
+
+A thread can acquire a mutex any number of times.
+
+NAME, if given, is used as the name of the mutex. The name is
+informational only. */)
+ (Lisp_Object name)
+{
+ struct Lisp_Mutex *mutex;
+ Lisp_Object result;
+
+ if (!NILP (name))
+ CHECK_STRING (name);
+
+ mutex = ALLOCATE_PSEUDOVECTOR (struct Lisp_Mutex, mutex, PVEC_MUTEX);
+ memset ((char *) mutex + offsetof (struct Lisp_Mutex, mutex),
+ 0, sizeof (struct Lisp_Mutex) - offsetof (struct Lisp_Mutex,
+ mutex));
+ mutex->name = name;
+ lisp_mutex_init (&mutex->mutex);
+
+ XSETMUTEX (result, mutex);
+ return result;
+}
+
+static void
+mutex_lock_callback (void *arg)
+{
+ struct Lisp_Mutex *mutex = arg;
+ struct thread_state *self = current_thread;
+
+ if (lisp_mutex_lock (&mutex->mutex, 0))
+ post_acquire_global_lock (self);
+}
+
+static void
+do_unwind_mutex_lock (void)
+{
+ current_thread->event_object = Qnil;
+}
+
+DEFUN ("mutex-lock", Fmutex_lock, Smutex_lock, 1, 1, 0,
+ doc: /* Acquire a mutex.
+If the current thread already owns MUTEX, increment the count and
+return.
+Otherwise, if no thread owns MUTEX, make the current thread own it.
+Otherwise, block until MUTEX is available, or until the current thread
+is signaled using `thread-signal'.
+Note that calls to `mutex-lock' and `mutex-unlock' must be paired. */)
+ (Lisp_Object mutex)
+{
+ struct Lisp_Mutex *lmutex;
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+ CHECK_MUTEX (mutex);
+ lmutex = XMUTEX (mutex);
+
+ current_thread->event_object = mutex;
+ record_unwind_protect_void (do_unwind_mutex_lock);
+ flush_stack_call_func (mutex_lock_callback, lmutex);
+ return unbind_to (count, Qnil);
+}
+
+static void
+mutex_unlock_callback (void *arg)
+{
+ struct Lisp_Mutex *mutex = arg;
+ struct thread_state *self = current_thread;
+
+ if (lisp_mutex_unlock (&mutex->mutex))
+ post_acquire_global_lock (self);
+}
+
+DEFUN ("mutex-unlock", Fmutex_unlock, Smutex_unlock, 1, 1, 0,
+ doc: /* Release the mutex.
+If this thread does not own MUTEX, signal an error.
+Otherwise, decrement the mutex's count. If the count is zero,
+release MUTEX. */)
+ (Lisp_Object mutex)
+{
+ struct Lisp_Mutex *lmutex;
+
+ CHECK_MUTEX (mutex);
+ lmutex = XMUTEX (mutex);
+
+ flush_stack_call_func (mutex_unlock_callback, lmutex);
+ return Qnil;
+}
+
+DEFUN ("mutex-name", Fmutex_name, Smutex_name, 1, 1, 0,
+ doc: /* Return the name of MUTEX.
+If no name was given when MUTEX was created, return nil. */)
+ (Lisp_Object mutex)
+{
+ struct Lisp_Mutex *lmutex;
+
+ CHECK_MUTEX (mutex);
+ lmutex = XMUTEX (mutex);
+
+ return lmutex->name;
+}
+
+void
+finalize_one_mutex (struct Lisp_Mutex *mutex)
+{
+ lisp_mutex_destroy (&mutex->mutex);
+}
+
+
+
+DEFUN ("make-condition-variable",
+ Fmake_condition_variable, Smake_condition_variable,
+ 1, 2, 0,
+ doc: /* Make a condition variable associated with MUTEX.
+A condition variable provides a way for a thread to sleep while
+waiting for a state change.
+
+MUTEX is the mutex associated with this condition variable.
+NAME, if given, is the name of this condition variable. The name is
+informational only. */)
+ (Lisp_Object mutex, Lisp_Object name)
+{
+ struct Lisp_CondVar *condvar;
+ Lisp_Object result;
+
+ CHECK_MUTEX (mutex);
+ if (!NILP (name))
+ CHECK_STRING (name);
+
+ condvar = ALLOCATE_PSEUDOVECTOR (struct Lisp_CondVar, cond, PVEC_CONDVAR);
+ memset ((char *) condvar + offsetof (struct Lisp_CondVar, cond),
+ 0, sizeof (struct Lisp_CondVar) - offsetof (struct Lisp_CondVar,
+ cond));
+ condvar->mutex = mutex;
+ condvar->name = name;
+ sys_cond_init (&condvar->cond);
+
+ XSETCONDVAR (result, condvar);
+ return result;
+}
+
+static void
+condition_wait_callback (void *arg)
+{
+ struct Lisp_CondVar *cvar = arg;
+ struct Lisp_Mutex *mutex = XMUTEX (cvar->mutex);
+ struct thread_state *self = current_thread;
+ unsigned int saved_count;
+ Lisp_Object cond;
+
+ XSETCONDVAR (cond, cvar);
+ self->event_object = cond;
+ saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
+ /* If signaled while unlocking, skip the wait but reacquire the lock. */
+ if (NILP (self->error_symbol))
+ {
+ self->wait_condvar = &cvar->cond;
+ sys_cond_wait (&cvar->cond, &global_lock);
+ self->wait_condvar = NULL;
+ }
+ lisp_mutex_lock (&mutex->mutex, saved_count);
+ self->event_object = Qnil;
+ post_acquire_global_lock (self);
+}
+
+DEFUN ("condition-wait", Fcondition_wait, Scondition_wait, 1, 1, 0,
+ doc: /* Wait for the condition variable COND to be notified.
+COND is the condition variable to wait on.
+
+The mutex associated with COND must be held when this is called.
+It is an error if it is not held.
+
+This releases the mutex and waits for COND to be notified or for
+this thread to be signaled with `thread-signal'. When
+`condition-wait' returns, COND's mutex will again be locked by
+this thread. */)
+ (Lisp_Object cond)
+{
+ struct Lisp_CondVar *cvar;
+ struct Lisp_Mutex *mutex;
+
+ CHECK_CONDVAR (cond);
+ cvar = XCONDVAR (cond);
+
+ mutex = XMUTEX (cvar->mutex);
+ if (!lisp_mutex_owned_p (&mutex->mutex))
+ error ("Condition variable's mutex is not held by current thread");
+
+ flush_stack_call_func (condition_wait_callback, cvar);
+
+ return Qnil;
+}
+
+/* Used to communicate arguments to condition_notify_callback. */
+struct notify_args
+{
+ struct Lisp_CondVar *cvar;
+ int all;
+};
+
+static void
+condition_notify_callback (void *arg)
+{
+ struct notify_args *na = arg;
+ struct Lisp_Mutex *mutex = XMUTEX (na->cvar->mutex);
+ struct thread_state *self = current_thread;
+ unsigned int saved_count;
+ Lisp_Object cond;
+
+ XSETCONDVAR (cond, na->cvar);
+ saved_count = lisp_mutex_unlock_for_wait (&mutex->mutex);
+ if (na->all)
+ sys_cond_broadcast (&na->cvar->cond);
+ else
+ sys_cond_signal (&na->cvar->cond);
+ lisp_mutex_lock (&mutex->mutex, saved_count);
+ post_acquire_global_lock (self);
+}
+
+DEFUN ("condition-notify", Fcondition_notify, Scondition_notify, 1, 2, 0,
+ doc: /* Notify COND, a condition variable.
+This wakes a thread waiting on COND.
+If ALL is non-nil, all waiting threads are awoken.
+
+The mutex associated with COND must be held when this is called.
+It is an error if it is not held.
+
+This releases COND's mutex when notifying COND. When
+`condition-notify' returns, the mutex will again be locked by this
+thread. */)
+ (Lisp_Object cond, Lisp_Object all)
+{
+ struct Lisp_CondVar *cvar;
+ struct Lisp_Mutex *mutex;
+ struct notify_args args;
+
+ CHECK_CONDVAR (cond);
+ cvar = XCONDVAR (cond);
+
+ mutex = XMUTEX (cvar->mutex);
+ if (!lisp_mutex_owned_p (&mutex->mutex))
+ error ("Condition variable's mutex is not held by current thread");
+
+ args.cvar = cvar;
+ args.all = !NILP (all);
+ flush_stack_call_func (condition_notify_callback, &args);
+
+ return Qnil;
+}
+
+DEFUN ("condition-mutex", Fcondition_mutex, Scondition_mutex, 1, 1, 0,
+ doc: /* Return the mutex associated with condition variable COND. */)
+ (Lisp_Object cond)
+{
+ struct Lisp_CondVar *cvar;
+
+ CHECK_CONDVAR (cond);
+ cvar = XCONDVAR (cond);
+
+ return cvar->mutex;
+}
+
+DEFUN ("condition-name", Fcondition_name, Scondition_name, 1, 1, 0,
+ doc: /* Return the name of condition variable COND.
+If no name was given when COND was created, return nil. */)
+ (Lisp_Object cond)
+{
+ struct Lisp_CondVar *cvar;
+
+ CHECK_CONDVAR (cond);
+ cvar = XCONDVAR (cond);
+
+ return cvar->name;
+}
+
+void
+finalize_one_condvar (struct Lisp_CondVar *condvar)
+{
+ sys_cond_destroy (&condvar->cond);
+}
+
+
+
+struct select_args
+{
+ select_func *func;
+ int max_fds;
+ fd_set *rfds;
+ fd_set *wfds;
+ fd_set *efds;
+ struct timespec *timeout;
+ sigset_t *sigmask;
+ int result;
+};
+
+static void
+really_call_select (void *arg)
+{
+ struct select_args *sa = arg;
+ struct thread_state *self = current_thread;
+ sigset_t oldset;
+
+ block_interrupt_signal (&oldset);
+ self->not_holding_lock = 1;
+ release_global_lock ();
+ restore_signal_mask (&oldset);
+
+ sa->result = (sa->func) (sa->max_fds, sa->rfds, sa->wfds, sa->efds,
+ sa->timeout, sa->sigmask);
+
+ block_interrupt_signal (&oldset);
+ acquire_global_lock (self);
+ self->not_holding_lock = 0;
+ restore_signal_mask (&oldset);
+}
+
+int
+thread_select (select_func *func, int max_fds, fd_set *rfds,
+ fd_set *wfds, fd_set *efds, struct timespec *timeout,
+ sigset_t *sigmask)
+{
+ struct select_args sa;
+
+ sa.func = func;
+ sa.max_fds = max_fds;
+ sa.rfds = rfds;
+ sa.wfds = wfds;
+ sa.efds = efds;
+ sa.timeout = timeout;
+ sa.sigmask = sigmask;
+ flush_stack_call_func (really_call_select, &sa);
+ return sa.result;
+}
+
+
+
+static void
+mark_one_thread (struct thread_state *thread)
+{
+ struct handler *handler;
+ Lisp_Object tem;
+
+ mark_specpdl (thread->m_specpdl, thread->m_specpdl_ptr);
+
+ mark_stack (thread->m_stack_bottom, thread->stack_top);
+
+ for (handler = thread->m_handlerlist; handler; handler = handler->next)
+ {
+ mark_object (handler->tag_or_ch);
+ mark_object (handler->val);
+ }
+
+ if (thread->m_current_buffer)
+ {
+ XSETBUFFER (tem, thread->m_current_buffer);
+ mark_object (tem);
+ }
+
+ mark_object (thread->m_last_thing_searched);
+
+ if (!NILP (thread->m_saved_last_thing_searched))
+ mark_object (thread->m_saved_last_thing_searched);
+}
+
+static void
+mark_threads_callback (void *ignore)
+{
+ struct thread_state *iter;
+
+ for (iter = all_threads; iter; iter = iter->next_thread)
+ {
+ Lisp_Object thread_obj;
+
+ XSETTHREAD (thread_obj, iter);
+ mark_object (thread_obj);
+ mark_one_thread (iter);
+ }
+}
+
+void
+mark_threads (void)
+{
+ flush_stack_call_func (mark_threads_callback, NULL);
+}
+
+void
+unmark_threads (void)
+{
+ struct thread_state *iter;
+
+ for (iter = all_threads; iter; iter = iter->next_thread)
+ if (iter->m_byte_stack_list)
+ relocate_byte_stack (iter->m_byte_stack_list);
+}
+
+
+
+static void
+yield_callback (void *ignore)
+{
+ struct thread_state *self = current_thread;
+
+ release_global_lock ();
+ sys_thread_yield ();
+ acquire_global_lock (self);
+}
+
+DEFUN ("thread-yield", Fthread_yield, Sthread_yield, 0, 0, 0,
+ doc: /* Yield the CPU to another thread. */)
+ (void)
+{
+ flush_stack_call_func (yield_callback, NULL);
+ return Qnil;
+}
+
+static Lisp_Object
+invoke_thread_function (void)
+{
+ int count = SPECPDL_INDEX ();
+
+ Ffuncall (1, ¤t_thread->function);
+ return unbind_to (count, Qnil);
+}
+
+static Lisp_Object
+do_nothing (Lisp_Object whatever)
+{
+ return whatever;
+}
+
+static void *
+run_thread (void *state)
+{
+ /* Make sure stack_top and m_stack_bottom are properly aligned as GC
+ expects. */
+ union
+ {
+ void *p;
+ char c;
+ } stack_pos;
+
+ struct thread_state *self = state;
+ struct thread_state **iter;
+
+ self->m_stack_bottom = &stack_pos.c;
+ self->stack_top = &stack_pos.c;
+ self->thread_id = sys_thread_self ();
+
+ acquire_global_lock (self);
+
+ /* Put a dummy catcher at top-level so that handlerlist is never NULL.
+ This is important since handlerlist->nextfree holds the freelist
+ which would otherwise leak every time we unwind back to top-level. */
+ handlerlist_sentinel = xzalloc (sizeof (struct handler));
+ handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
+ struct handler *c = push_handler (Qunbound, CATCHER);
+ eassert (c == handlerlist_sentinel);
+ handlerlist_sentinel->nextfree = NULL;
+ handlerlist_sentinel->next = NULL;
+
+ /* It might be nice to do something with errors here. */
+ internal_condition_case (invoke_thread_function, Qt, do_nothing);
+
+ update_processes_for_thread_death (Fcurrent_thread ());
+
+ xfree (self->m_specpdl - 1);
+ self->m_specpdl = NULL;
+ self->m_specpdl_ptr = NULL;
+ self->m_specpdl_size = 0;
+
+ {
+ struct handler *c, *c_next;
+ for (c = handlerlist_sentinel; c; c = c_next)
+ {
+ c_next = c->nextfree;
+ xfree (c);
+ }
+ }
+
+ current_thread = NULL;
+ sys_cond_broadcast (&self->thread_condvar);
+
+ /* Unlink this thread from the list of all threads. Note that we
+ have to do this very late, after broadcasting our death.
+ Otherwise the GC may decide to reap the thread_state object,
+ leading to crashes. */
+ for (iter = &all_threads; *iter != self; iter = &(*iter)->next_thread)
+ ;
+ *iter = (*iter)->next_thread;
+
+ release_global_lock ();
+
+ return NULL;
+}
+
+void
+finalize_one_thread (struct thread_state *state)
+{
+ sys_cond_destroy (&state->thread_condvar);
+}
+
+DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0,
+ doc: /* Start a new thread and run FUNCTION in it.
+When the function exits, the thread dies.
+If NAME is given, it must be a string; it names the new thread. */)
+ (Lisp_Object function, Lisp_Object name)
+{
+ sys_thread_t thr;
+ struct thread_state *new_thread;
+ Lisp_Object result;
+ const char *c_name = NULL;
+ size_t offset = offsetof (struct thread_state, m_byte_stack_list);
+
+ /* Can't start a thread in temacs. */
+ if (!initialized)
+ emacs_abort ();
+
+ if (!NILP (name))
+ CHECK_STRING (name);
+
+ new_thread = ALLOCATE_PSEUDOVECTOR (struct thread_state, m_byte_stack_list,
+ PVEC_THREAD);
+ memset ((char *) new_thread + offset, 0,
+ sizeof (struct thread_state) - offset);
+
+ new_thread->function = function;
+ new_thread->name = name;
+ new_thread->m_last_thing_searched = Qnil; /* copy from parent? */
+ new_thread->m_saved_last_thing_searched = Qnil;
+ new_thread->m_current_buffer = current_thread->m_current_buffer;
+ new_thread->error_symbol = Qnil;
+ new_thread->error_data = Qnil;
+ new_thread->event_object = Qnil;
+
+ new_thread->m_specpdl_size = 50;
+ new_thread->m_specpdl = xmalloc ((1 + new_thread->m_specpdl_size)
+ * sizeof (union specbinding));
+ /* Skip the dummy entry. */
+ ++new_thread->m_specpdl;
+ new_thread->m_specpdl_ptr = new_thread->m_specpdl;
+
+ sys_cond_init (&new_thread->thread_condvar);
+
+ /* We'll need locking here eventually. */
+ new_thread->next_thread = all_threads;
+ all_threads = new_thread;
+
+ if (!NILP (name))
+ c_name = SSDATA (ENCODE_UTF_8 (name));
+
+ if (! sys_thread_create (&thr, c_name, run_thread, new_thread))
+ {
+ /* Restore the previous situation. */
+ all_threads = all_threads->next_thread;
+ error ("Could not start a new thread");
+ }
+
+ /* FIXME: race here where new thread might not be filled in? */
+ XSETTHREAD (result, new_thread);
+ return result;
+}
+
+DEFUN ("current-thread", Fcurrent_thread, Scurrent_thread, 0, 0, 0,
+ doc: /* Return the current thread. */)
+ (void)
+{
+ Lisp_Object result;
+ XSETTHREAD (result, current_thread);
+ return result;
+}
+
+DEFUN ("thread-name", Fthread_name, Sthread_name, 1, 1, 0,
+ doc: /* Return the name of the THREAD.
+The name is the same object that was passed to `make-thread'. */)
+ (Lisp_Object thread)
+{
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ return tstate->name;
+}
+
+static void
+thread_signal_callback (void *arg)
+{
+ struct thread_state *tstate = arg;
+ struct thread_state *self = current_thread;
+
+ sys_cond_broadcast (tstate->wait_condvar);
+ post_acquire_global_lock (self);
+}
+
+DEFUN ("thread-signal", Fthread_signal, Sthread_signal, 3, 3, 0,
+ doc: /* Signal an error in a thread.
+This acts like `signal', but arranges for the signal to be raised
+in THREAD. If THREAD is the current thread, acts just like `signal'.
+This will interrupt a blocked call to `mutex-lock', `condition-wait',
+or `thread-join' in the target thread. */)
+ (Lisp_Object thread, Lisp_Object error_symbol, Lisp_Object data)
+{
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ if (tstate == current_thread)
+ Fsignal (error_symbol, data);
+
+ /* What to do if thread is already signaled? */
+ /* What if error_symbol is Qnil? */
+ tstate->error_symbol = error_symbol;
+ tstate->error_data = data;
+
+ if (tstate->wait_condvar)
+ flush_stack_call_func (thread_signal_callback, tstate);
+
+ return Qnil;
+}
+
+DEFUN ("thread-alive-p", Fthread_alive_p, Sthread_alive_p, 1, 1, 0,
+ doc: /* Return t if THREAD is alive, or nil if it has exited. */)
+ (Lisp_Object thread)
+{
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ return thread_alive_p (tstate) ? Qt : Qnil;
+}
+
+DEFUN ("thread--blocker", Fthread_blocker, Sthread_blocker, 1, 1, 0,
+ doc: /* Return the object that THREAD is blocking on.
+If THREAD is blocked in `thread-join' on a second thread, return that
+thread.
+If THREAD is blocked in `mutex-lock', return the mutex.
+If THREAD is blocked in `condition-wait', return the condition variable.
+Otherwise, if THREAD is not blocked, return nil. */)
+ (Lisp_Object thread)
+{
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ return tstate->event_object;
+}
+
+static void
+thread_join_callback (void *arg)
+{
+ struct thread_state *tstate = arg;
+ struct thread_state *self = current_thread;
+ Lisp_Object thread;
+
+ XSETTHREAD (thread, tstate);
+ self->event_object = thread;
+ self->wait_condvar = &tstate->thread_condvar;
+ while (thread_alive_p (tstate) && NILP (self->error_symbol))
+ sys_cond_wait (self->wait_condvar, &global_lock);
+
+ self->wait_condvar = NULL;
+ self->event_object = Qnil;
+ post_acquire_global_lock (self);
+}
+
+DEFUN ("thread-join", Fthread_join, Sthread_join, 1, 1, 0,
+ doc: /* Wait for THREAD to exit.
+This blocks the current thread until THREAD exits or until
+the current thread is signaled.
+It is an error for a thread to try to join itself. */)
+ (Lisp_Object thread)
+{
+ struct thread_state *tstate;
+
+ CHECK_THREAD (thread);
+ tstate = XTHREAD (thread);
+
+ if (tstate == current_thread)
+ error ("Cannot join current thread");
+
+ if (thread_alive_p (tstate))
+ flush_stack_call_func (thread_join_callback, tstate);
+
+ return Qnil;
+}
+
+DEFUN ("all-threads", Fall_threads, Sall_threads, 0, 0, 0,
+ doc: /* Return a list of all the live threads. */)
+ (void)
+{
+ Lisp_Object result = Qnil;
+ struct thread_state *iter;
+
+ for (iter = all_threads; iter; iter = iter->next_thread)
+ {
+ if (thread_alive_p (iter))
+ {
+ Lisp_Object thread;
+
+ XSETTHREAD (thread, iter);
+ result = Fcons (thread, result);
+ }
+ }
+
+ return result;
+}
+
+
+
+bool
+thread_check_current_buffer (struct buffer *buffer)
+{
+ struct thread_state *iter;
+
+ for (iter = all_threads; iter; iter = iter->next_thread)
+ {
+ if (iter == current_thread)
+ continue;
+
+ if (iter->m_current_buffer == buffer)
+ return true;
+ }
+
+ return false;
+}
+
+
+
+static void
+init_primary_thread (void)
+{
+ primary_thread.header.size
+ = PSEUDOVECSIZE (struct thread_state, m_byte_stack_list);
+ XSETPVECTYPE (&primary_thread, PVEC_THREAD);
+ primary_thread.m_last_thing_searched = Qnil;
+ primary_thread.m_saved_last_thing_searched = Qnil;
+ primary_thread.name = Qnil;
+ primary_thread.function = Qnil;
+ primary_thread.error_symbol = Qnil;
+ primary_thread.error_data = Qnil;
+ primary_thread.event_object = Qnil;
+}
+
+bool
+primary_thread_p (void *ptr)
+{
+ return (ptr == &primary_thread) ? true : false;
+}
+
+void
+init_threads_once (void)
+{
+ init_primary_thread ();
+}
+
+void
+init_threads (void)
+{
+ init_primary_thread ();
+ sys_cond_init (&primary_thread.thread_condvar);
+ sys_mutex_init (&global_lock);
+ sys_mutex_lock (&global_lock);
+ current_thread = &primary_thread;
+ primary_thread.thread_id = sys_thread_self ();
+}
+
+void
+syms_of_threads (void)
+{
+#ifndef THREADS_ENABLED
+ if (0)
+#endif
+ {
+ defsubr (&Sthread_yield);
+ defsubr (&Smake_thread);
+ defsubr (&Scurrent_thread);
+ defsubr (&Sthread_name);
+ defsubr (&Sthread_signal);
+ defsubr (&Sthread_alive_p);
+ defsubr (&Sthread_join);
+ defsubr (&Sthread_blocker);
+ defsubr (&Sall_threads);
+ defsubr (&Smake_mutex);
+ defsubr (&Smutex_lock);
+ defsubr (&Smutex_unlock);
+ defsubr (&Smutex_name);
+ defsubr (&Smake_condition_variable);
+ defsubr (&Scondition_wait);
+ defsubr (&Scondition_notify);
+ defsubr (&Scondition_mutex);
+ defsubr (&Scondition_name);
+ }
+
+ DEFSYM (Qthreadp, "threadp");
+ DEFSYM (Qmutexp, "mutexp");
+ DEFSYM (Qcondition_variable_p, "condition-variable-p");
+}
diff --git a/src/thread.h b/src/thread.h
new file mode 100644
index 0000000..33f8ea7
--- /dev/null
+++ b/src/thread.h
@@ -0,0 +1,250 @@
+/* Thread definitions
+Copyright (C) 2012-2016 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 <http://www.gnu.org/licenses/>. */
+
+#ifndef THREAD_H
+#define THREAD_H
+
+#include <sys/types.h> /* for ssize_t used by regex.h */
+#include "regex.h"
+
+#ifdef WINDOWSNT
+#include <sys/socket.h>
+#endif
+
+#include "sysselect.h" /* FIXME */
+#include "systime.h" /* FIXME */
+
+struct thread_state
+{
+ struct vectorlike_header header;
+
+ /* The buffer in which the last search was performed, or
+ Qt if the last search was done in a string;
+ Qnil if no searching has been done yet. */
+ Lisp_Object m_last_thing_searched;
+#define last_thing_searched (current_thread->m_last_thing_searched)
+
+ Lisp_Object m_saved_last_thing_searched;
+#define saved_last_thing_searched (current_thread->m_saved_last_thing_searched)
+
+ /* The thread's name. */
+ Lisp_Object name;
+
+ /* The thread's function. */
+ Lisp_Object function;
+
+ /* If non-nil, this thread has been signaled. */
+ Lisp_Object error_symbol;
+ Lisp_Object error_data;
+
+ /* If we are waiting for some event, this holds the object we are
+ waiting on. */
+ Lisp_Object event_object;
+
+ /* m_byte_stack_list must be the first non-lisp field. */
+ /* A list of currently active byte-code execution value stacks.
+ Fbyte_code adds an entry to the head of this list before it starts
+ processing byte-code, and it removed the entry again when it is
+ done. Signaling an error truncates the list. */
+ struct byte_stack *m_byte_stack_list;
+#define byte_stack_list (current_thread->m_byte_stack_list)
+
+ /* An address near the bottom of the stack.
+ Tells GC how to save a copy of the stack. */
+ char *m_stack_bottom;
+#define stack_bottom (current_thread->m_stack_bottom)
+
+ /* An address near the top of the stack. */
+ char *stack_top;
+
+ struct catchtag *m_catchlist;
+#define catchlist (current_thread->m_catchlist)
+
+ /* Chain of condition handlers currently in effect.
+ The elements of this chain are contained in the stack frames
+ of Fcondition_case and internal_condition_case.
+ When an error is signaled (by calling Fsignal),
+ this chain is searched for an element that applies. */
+ struct handler *m_handlerlist;
+#define handlerlist (current_thread->m_handlerlist)
+
+ struct handler *m_handlerlist_sentinel;
+#define handlerlist_sentinel (current_thread->m_handlerlist_sentinel)
+
+ /* Current number of specbindings allocated in specpdl. */
+ ptrdiff_t m_specpdl_size;
+#define specpdl_size (current_thread->m_specpdl_size)
+
+ /* Pointer to beginning of specpdl. */
+ union specbinding *m_specpdl;
+#define specpdl (current_thread->m_specpdl)
+
+ /* Pointer to first unused element in specpdl. */
+ union specbinding *m_specpdl_ptr;
+#define specpdl_ptr (current_thread->m_specpdl_ptr)
+
+ /* Depth in Lisp evaluations and function calls. */
+ EMACS_INT m_lisp_eval_depth;
+#define lisp_eval_depth (current_thread->m_lisp_eval_depth)
+
+ /* This points to the current buffer. */
+ struct buffer *m_current_buffer;
+#define current_buffer (current_thread->m_current_buffer)
+
+ /* Every call to re_match, etc., must pass &search_regs as the regs
+ argument unless you can show it is unnecessary (i.e., if re_match
+ is certainly going to be called again before region-around-match
+ can be called).
+
+ Since the registers are now dynamically allocated, we need to make
+ sure not to refer to the Nth register before checking that it has
+ been allocated by checking search_regs.num_regs.
+
+ The regex code keeps track of whether it has allocated the search
+ buffer using bits in the re_pattern_buffer. This means that whenever
+ you compile a new pattern, it completely forgets whether it has
+ allocated any registers, and will allocate new registers the next
+ time you call a searching or matching function. Therefore, we need
+ to call re_set_registers after compiling a new pattern or after
+ setting the match registers, so that the regex functions will be
+ able to free or re-allocate it properly. */
+ struct re_registers m_search_regs;
+#define search_regs (current_thread->m_search_regs)
+
+ /* If non-zero the match data have been saved in saved_search_regs
+ during the execution of a sentinel or filter. */
+ bool m_search_regs_saved;
+#define search_regs_saved (current_thread->m_search_regs_saved)
+
+ struct re_registers m_saved_search_regs;
+#define saved_search_regs (current_thread->m_saved_search_regs)
+
+ /* This is the string or buffer in which we
+ are matching. It is used for looking up syntax properties.
+
+ If the value is a Lisp string object, we are matching text in that
+ string; if it's nil, we are matching text in the current buffer; if
+ it's t, we are matching text in a C string. */
+ Lisp_Object m_re_match_object;
+#define re_match_object (current_thread->m_re_match_object)
+
+ /* This member is different from waiting_for_input.
+ It is used to communicate to a lisp process-filter/sentinel (via the
+ function Fwaiting_for_user_input_p) whether Emacs was waiting
+ for user-input when that process-filter was called.
+ waiting_for_input cannot be used as that is by definition 0 when
+ lisp code is being evalled.
+ This is also used in record_asynch_buffer_change.
+ For that purpose, this must be 0
+ when not inside wait_reading_process_output. */
+ int m_waiting_for_user_input_p;
+#define waiting_for_user_input_p (current_thread->m_waiting_for_user_input_p)
+
+ /* True while doing kbd input. */
+ bool m_waiting_for_input;
+#define waiting_for_input (current_thread->m_waiting_for_input)
+
+ /* The OS identifier for this thread. */
+ sys_thread_t thread_id;
+
+ /* The condition variable for this thread. This is associated with
+ the global lock. This thread broadcasts to it when it exits. */
+ sys_cond_t thread_condvar;
+
+ /* This thread might be waiting for some condition. If so, this
+ points to the condition. If the thread is interrupted, the
+ interrupter should broadcast to this condition. */
+ sys_cond_t *wait_condvar;
+
+ /* This thread might have released the global lock. If so, this is
+ non-zero. When a thread runs outside thread_select with this
+ flag non-zero, it means it has been interrupted by SIGINT while
+ in thread_select, and didn't have a chance of acquiring the lock.
+ It must do so ASAP. */
+ int not_holding_lock;
+
+ /* Threads are kept on a linked list. */
+ struct thread_state *next_thread;
+};
+
+/* A mutex in lisp is represented by a system condition variable.
+ The system mutex associated with this condition variable is the
+ global lock.
+
+ Using a condition variable lets us implement interruptibility for
+ lisp mutexes. */
+typedef struct
+{
+ /* The owning thread, or NULL if unlocked. */
+ struct thread_state *owner;
+ /* The lock count. */
+ unsigned int count;
+ /* The underlying system condition variable. */
+ sys_cond_t condition;
+} lisp_mutex_t;
+
+/* A mutex as a lisp object. */
+struct Lisp_Mutex
+{
+ struct vectorlike_header header;
+
+ /* The name of the mutex, or nil. */
+ Lisp_Object name;
+
+ /* The lower-level mutex object. */
+ lisp_mutex_t mutex;
+};
+
+/* A condition variable as a lisp object. */
+struct Lisp_CondVar
+{
+ struct vectorlike_header header;
+
+ /* The associated mutex. */
+ Lisp_Object mutex;
+
+ /* The name of the condition variable, or nil. */
+ Lisp_Object name;
+
+ /* The lower-level condition variable object. */
+ sys_cond_t cond;
+};
+
+extern struct thread_state *current_thread;
+
+extern void unmark_threads (void);
+extern void finalize_one_thread (struct thread_state *state);
+extern void finalize_one_mutex (struct Lisp_Mutex *);
+extern void finalize_one_condvar (struct Lisp_CondVar *);
+extern void maybe_reacquire_global_lock (void);
+
+extern void init_threads_once (void);
+extern void init_threads (void);
+extern void syms_of_threads (void);
+extern bool primary_thread_p (void *);
+
+typedef int select_func (int, fd_set *, fd_set *, fd_set *,
+ const struct timespec *, const sigset_t *);
+
+int thread_select (select_func *func, int max_fds, fd_set *rfds,
+ fd_set *wfds, fd_set *efds, struct timespec *timeout,
+ sigset_t *sigmask);
+
+bool thread_check_current_buffer (struct buffer *);
+
+#endif /* THREAD_H */
diff --git a/src/unexw32.c b/src/unexw32.c
index f4183dc..5422485 100644
--- a/src/unexw32.c
+++ b/src/unexw32.c
@@ -465,6 +465,7 @@ get_section_info (file_data *p_infile)
bss_start = min (bss_start, bss_start_static);
bss_size = max (my_endbss, my_endbss_static) - bss_start;
bss_section_static = 0;
+ extra_bss_size = max (extra_bss_size, extra_bss_size_static);
extra_bss_size_static = 0;
}
}
diff --git a/src/w32.c b/src/w32.c
index fa7fec7..e96f297 100644
--- a/src/w32.c
+++ b/src/w32.c
@@ -272,7 +272,7 @@ static BOOL WINAPI revert_to_self (void);
static int sys_access (const char *, int);
extern void *e_malloc (size_t);
extern int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *,
- struct timespec *, void *);
+ const struct timespec *, const sigset_t *);
extern int sys_dup (int);
diff --git a/src/w32proc.c b/src/w32proc.c
index 189034c..6f3a6e0 100644
--- a/src/w32proc.c
+++ b/src/w32proc.c
@@ -72,7 +72,7 @@ extern BOOL g_b_init_compare_string_w;
extern BOOL g_b_init_debug_break_process;
int sys_select (int, SELECT_TYPE *, SELECT_TYPE *, SELECT_TYPE *,
- struct timespec *, void *);
+ const struct timespec *, const sigset_t *);
/* Signal handlers...SIG_DFL == 0 so this is initialized correctly. */
static signal_handler sig_handlers[NSIG];
@@ -849,8 +849,8 @@ alarm (int seconds)
stream is terminated, terminates the reader thread as part of
deleting the child_process object.
- The sys_select function emulates the Posix 'pselect' function; it
- is needed because the Windows 'select' function supports only
+ The sys_select function emulates the Posix 'pselect' functionality;
+ it is needed because the Windows 'select' function supports only
network sockets, while Emacs expects 'pselect' to work for any file
descriptor, including pipes and serial streams.
@@ -2096,7 +2096,7 @@ extern int proc_buffered_char[];
int
sys_select (int nfds, SELECT_TYPE *rfds, SELECT_TYPE *wfds, SELECT_TYPE *efds,
- struct timespec *timeout, void *ignored)
+ const struct timespec *timeout, const sigset_t *ignored)
{
SELECT_TYPE orfds, owfds;
DWORD timeout_ms, start_time;
diff --git a/src/w32select.c b/src/w32select.c
index 1754534..36908f9 100644
--- a/src/w32select.c
+++ b/src/w32select.c
@@ -77,7 +77,6 @@ along with GNU Emacs. If not, see
<http://www.gnu.org/licenses/>. */
#include "w32common.h" /* os_subtype */
#include "w32term.h" /* for all of the w32 includes */
#include "w32select.h"
-#include "keyboard.h" /* for waiting_for_input */
#include "blockinput.h"
#include "coding.h"
diff --git a/src/widget.c b/src/widget.c
index 59ed431..97b4196 100644
--- a/src/widget.c
+++ b/src/widget.c
@@ -212,16 +212,6 @@ mark_shell_size_user_specified (Widget wmshell)
#endif
-/* Can't have static frame locals because of some broken compilers.
- Normally, initializing a variable like this doesn't work in emacs,
- but it's ok in this file because it must come after lastfile (and
- thus have its data not go into text space) because Xt needs to
- write to initialized data objects too.
- */
-#if 0
-static Boolean first_frame_p = True;
-#endif
-
static void
set_frame_size (EmacsFrame ew)
{
diff --git a/src/window.c b/src/window.c
index e8798f1..6cfba08 100644
--- a/src/window.c
+++ b/src/window.c
@@ -5683,7 +5683,7 @@ and redisplay normally--don't erase and redraw the frame.
*/)
struct buffer *buf = XBUFFER (w->contents);
bool center_p = false;
ptrdiff_t charpos, bytepos;
- EMACS_INT iarg;
+ EMACS_INT iarg UNINIT;
int this_scroll_margin;
if (buf != current_buffer)
@@ -6008,7 +6008,7 @@ struct save_window_data
struct vectorlike_header header;
Lisp_Object selected_frame;
Lisp_Object current_window;
- Lisp_Object current_buffer;
+ Lisp_Object f_current_buffer;
Lisp_Object minibuf_scroll_window;
Lisp_Object minibuf_selected_window;
Lisp_Object root_window;
@@ -6098,7 +6098,7 @@ the return value is nil. Otherwise the value is t. */)
data = (struct save_window_data *) XVECTOR (configuration);
saved_windows = XVECTOR (data->saved_windows);
- new_current_buffer = data->current_buffer;
+ new_current_buffer = data->f_current_buffer;
if (!BUFFER_LIVE_P (XBUFFER (new_current_buffer)))
new_current_buffer = Qnil;
else
@@ -6750,7 +6750,7 @@ saved by this function. */)
data->frame_tool_bar_height = FRAME_TOOL_BAR_HEIGHT (f);
data->selected_frame = selected_frame;
data->current_window = FRAME_SELECTED_WINDOW (f);
- XSETBUFFER (data->current_buffer, current_buffer);
+ XSETBUFFER (data->f_current_buffer, current_buffer);
data->minibuf_scroll_window = minibuf_level > 0 ? Vminibuf_scroll_window :
Qnil;
data->minibuf_selected_window = minibuf_level > 0 ? minibuf_selected_window
: Qnil;
data->root_window = FRAME_ROOT_WINDOW (f);
@@ -7205,7 +7205,7 @@ compare_window_configurations (Lisp_Object configuration1,
|| d1->frame_lines != d2->frame_lines
|| d1->frame_menu_bar_lines != d2->frame_menu_bar_lines
|| !EQ (d1->selected_frame, d2->selected_frame)
- || !EQ (d1->current_buffer, d2->current_buffer)
+ || !EQ (d1->f_current_buffer, d2->f_current_buffer)
|| (!ignore_positions
&& (!EQ (d1->minibuf_scroll_window, d2->minibuf_scroll_window)
|| !EQ (d1->minibuf_selected_window,
d2->minibuf_selected_window)))
diff --git a/src/xdisp.c b/src/xdisp.c
index ad0b968..5de5eca 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -13049,6 +13049,17 @@ hscroll_window_tree (Lisp_Object window)
init_to_row_start (&it, w, cursor_row);
it.last_visible_x = INFINITY;
move_it_in_display_line_to (&it, pt, -1, MOVE_TO_POS);
+ /* If the line ends in an overlay string with a newline,
+ we might infloop, because displaying the window will
+ want to put the cursor after the overlay, i.e. at X
+ coordinate of zero on the next screen line. So we
+ use the buffer position prior to the overlay string
+ instead. */
+ if (it.method == GET_FROM_STRING && pt > 1)
+ {
+ init_to_row_start (&it, w, cursor_row);
+ move_it_in_display_line_to (&it, pt - 1, -1, MOVE_TO_POS);
+ }
current_buffer = saved_current_buffer;
/* Position cursor in window. */
diff --git a/src/xfont.c b/src/xfont.c
index 5999f67..09ca628 100644
--- a/src/xfont.c
+++ b/src/xfont.c
@@ -1079,19 +1079,19 @@ xfont_check (struct frame *f, struct font *font)
struct font_driver const xfont_driver =
{
- type: LISPSYM_INITIALLY (Qx),
- get_cache: xfont_get_cache,
- list: xfont_list,
- match: xfont_match,
- list_family: xfont_list_family,
- open: xfont_open,
- close: xfont_close,
- prepare_face: xfont_prepare_face,
- has_char: xfont_has_char,
- encode_char: xfont_encode_char,
- text_extents: xfont_text_extents,
- draw: xfont_draw,
- check: xfont_check,
+ .type = LISPSYM_INITIALLY (Qx),
+ .get_cache = xfont_get_cache,
+ .list = xfont_list,
+ .match = xfont_match,
+ .list_family = xfont_list_family,
+ .open = xfont_open,
+ .close = xfont_close,
+ .prepare_face = xfont_prepare_face,
+ .has_char = xfont_has_char,
+ .encode_char = xfont_encode_char,
+ .text_extents = xfont_text_extents,
+ .draw = xfont_draw,
+ .check = xfont_check,
};
void
diff --git a/src/xftfont.c b/src/xftfont.c
index 74f5ec6..7f0e3c6 100644
--- a/src/xftfont.c
+++ b/src/xftfont.c
@@ -752,35 +752,35 @@ xftfont_cached_font_ok (struct frame *f, Lisp_Object
font_object,
struct font_driver const xftfont_driver =
{
/* We can't draw a text without device dependent functions. */
- type: LISPSYM_INITIALLY (Qxft),
- get_cache: xfont_get_cache,
- list: xftfont_list,
- match: xftfont_match,
- list_family: ftfont_list_family,
- open: xftfont_open,
- close: xftfont_close,
- prepare_face: xftfont_prepare_face,
- done_face: xftfont_done_face,
- has_char: xftfont_has_char,
- encode_char: xftfont_encode_char,
- text_extents: xftfont_text_extents,
- draw: xftfont_draw,
- get_bitmap: ftfont_get_bitmap,
- anchor_point: ftfont_anchor_point,
+ .type = LISPSYM_INITIALLY (Qxft),
+ .get_cache = xfont_get_cache,
+ .list = xftfont_list,
+ .match = xftfont_match,
+ .list_family = ftfont_list_family,
+ .open = xftfont_open,
+ .close = xftfont_close,
+ .prepare_face = xftfont_prepare_face,
+ .done_face = xftfont_done_face,
+ .has_char = xftfont_has_char,
+ .encode_char = xftfont_encode_char,
+ .text_extents = xftfont_text_extents,
+ .draw = xftfont_draw,
+ .get_bitmap = ftfont_get_bitmap,
+ .anchor_point = ftfont_anchor_point,
#ifdef HAVE_LIBOTF
- otf_capability: ftfont_otf_capability,
+ .otf_capability = ftfont_otf_capability,
#endif
- end_for_frame: xftfont_end_for_frame,
+ .end_for_frame = xftfont_end_for_frame,
#if defined HAVE_M17N_FLT && defined HAVE_LIBOTF
- shape: xftfont_shape,
+ .shape = xftfont_shape,
#endif
#ifdef HAVE_OTF_GET_VARIATION_GLYPHS
- get_variation_glyphs: ftfont_variation_glyphs,
+ .get_variation_glyphs = ftfont_variation_glyphs,
#endif
- filter_properties: ftfont_filter_properties,
- cached_font_ok: xftfont_cached_font_ok,
- combining_capability: ftfont_combining_capability,
- drop_xrender_surfaces: xftfont_drop_xrender_surfaces,
+ .filter_properties = ftfont_filter_properties,
+ .cached_font_ok = xftfont_cached_font_ok,
+ .combining_capability = ftfont_combining_capability,
+ .drop_xrender_surfaces = xftfont_drop_xrender_surfaces,
};
void
diff --git a/src/xgselect.c b/src/xgselect.c
index 7850a16..a9461a5 100644
--- a/src/xgselect.c
+++ b/src/xgselect.c
@@ -54,9 +54,8 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set
*efds,
int gfds_size = ARRAYELTS (gfds_buf);
int n_gfds, retval = 0, our_fds = 0, max_fds = fds_lim - 1;
bool context_acquired = false;
- int i, nfds, tmo_in_millisec;
+ int i, nfds, tmo_in_millisec, must_free = 0;
bool need_to_dispatch;
- USE_SAFE_ALLOCA;
context = g_main_context_default ();
context_acquired = g_main_context_acquire (context);
@@ -77,7 +76,11 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set
*efds,
if (gfds_size < n_gfds)
{
- SAFE_NALLOCA (gfds, sizeof *gfds, n_gfds);
+ /* Avoid using SAFE_NALLOCA, as that implicitly refers to the
+ current thread. Using xnmalloc avoids thread-switching
+ problems here. */
+ gfds = xnmalloc (n_gfds, sizeof *gfds);
+ must_free = 1;
gfds_size = n_gfds;
n_gfds = g_main_context_query (context, G_PRIORITY_LOW, &tmo_in_millisec,
gfds, gfds_size);
@@ -98,7 +101,8 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set
*efds,
}
}
- SAFE_FREE ();
+ if (must_free)
+ xfree (gfds);
if (n_gfds >= 0 && tmo_in_millisec >= 0)
{
@@ -146,7 +150,7 @@ xg_select (int fds_lim, fd_set *rfds, fd_set *wfds, fd_set
*efds,
#else
need_to_dispatch = true;
#endif
- if (need_to_dispatch)
+ if (need_to_dispatch && context_acquired)
{
int pselect_errno = errno;
/* Prevent g_main_dispatch recursion, that would occur without
diff --git a/test/lisp/buff-menu-tests.el b/test/lisp/buff-menu-tests.el
index 133a4f6..5bfdfba 100644
--- a/test/lisp/buff-menu-tests.el
+++ b/test/lisp/buff-menu-tests.el
@@ -1,4 +1,4 @@
-;;; buff-menu-tests.el --- Test suite for buff-menu-tests.el -*-
lexical-binding: t -*-
+;;; buff-menu-tests.el --- Test suite for buff-menu.el -*- lexical-binding: t
-*-
;; Copyright (C) 2016 Free Software Foundation, Inc.
diff --git a/test/lisp/buff-menu-tests.el b/test/lisp/emacs-lisp/rx-tests.el
similarity index 50%
copy from test/lisp/buff-menu-tests.el
copy to test/lisp/emacs-lisp/rx-tests.el
index 133a4f6..7ff45f6 100644
--- a/test/lisp/buff-menu-tests.el
+++ b/test/lisp/emacs-lisp/rx-tests.el
@@ -1,9 +1,7 @@
-;;; buff-menu-tests.el --- Test suite for buff-menu-tests.el -*-
lexical-binding: t -*-
+;;; rx-tests.el --- test for rx.el functions -*- lexical-binding: t -*-
;; Copyright (C) 2016 Free Software Foundation, Inc.
-;; Author: Tino Calancha <address@hidden>
-
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
@@ -21,25 +19,19 @@
;;; Commentary:
-;;; Code:
-
(require 'ert)
+(require 'rx)
+
+;;; Code:
-(ert-deftest buff-menu-24962 ()
- "Test for http://debbugs.gnu.org/24962 ."
- (let ((file (expand-file-name "foo" temporary-file-directory))
- buf)
- (unwind-protect
- (progn
- (write-region "foo" nil file)
- (setq buf (find-file file))
- (rename-buffer " foo")
- (list-buffers)
- (with-current-buffer "*Buffer List*"
- (should (string= " foo" (buffer-name (Buffer-menu-buffer))))))
- (and (buffer-live-p buf) (kill-buffer buf))
- (and (file-exists-p file) (delete-file file)))))
-
-(provide 'buff-menu-tests)
-
-;;; buff-menu-tests.el ends here
+(ert-deftest rx-char-any ()
+ "Test character alternatives with `\]' and `-' (Bug#25123)."
+ (should (string-match
+ (rx string-start (1+ (char (?\] . ?\{) (?< . ?\]) (?- . ?:)))
+ string-end)
+ (apply #'string (nconc (number-sequence ?\] ?\{)
+ (number-sequence ?< ?\])
+ (number-sequence ?- ?:))))))
+
+(provide 'rx-tests)
+;; rx-tests.el ends here.
diff --git a/test/lisp/emacs-lisp/seq-tests.el
b/test/lisp/emacs-lisp/seq-tests.el
index 2e533ac..a7a4347 100644
--- a/test/lisp/emacs-lisp/seq-tests.el
+++ b/test/lisp/emacs-lisp/seq-tests.el
@@ -386,5 +386,18 @@ Evaluate BODY for each created sequence.
(should-error (seq-random-elt []))
(should-error (seq-random-elt "")))
+(ert-deftest test-seq-mapn-circular-lists ()
+ (let ((l1 '#1=(1 . #1#)))
+ (should (equal (seq-mapn #'+ '(3 4 5 7) l1)
+ '(4 5 6 8)))))
+
+(ert-deftest test-seq-into-and-identity ()
+ (let ((lst '(1 2 3))
+ (vec [1 2 3])
+ (str "foo bar"))
+ (should (eq (seq-into lst 'list) lst))
+ (should (eq (seq-into vec 'vector) vec))
+ (should (eq (seq-into str 'string) str))))
+
(provide 'seq-tests)
;;; seq-tests.el ends here
diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el
index 80d5e5b..6fbe993 100644
--- a/test/lisp/files-tests.el
+++ b/test/lisp/files-tests.el
@@ -220,5 +220,28 @@ form.")
(should-not yes-or-no-p-prompts)
(should (equal kill-emacs-args '(nil)))))
+(ert-deftest files-test-read-file-in-~ ()
+ "Test file prompting in directory named '~'.
+If we are in a directory named '~', the default value should not
+be $HOME."
+ (cl-letf (((symbol-function 'completing-read)
+ (lambda (_prompt _coll &optional _pred _req init _hist def _)
+ (or def init)))
+ (dir (make-temp-file "read-file-name-test" t)))
+ (unwind-protect
+ (let ((subdir (expand-file-name "./~/" dir)))
+ (make-directory subdir t)
+ (with-temp-buffer
+ (setq default-directory subdir)
+ (should-not (equal
+ (expand-file-name (read-file-name "File: "))
+ (expand-file-name "~/")))
+ ;; Don't overquote either!
+ (setq default-directory (concat "/:" subdir))
+ (should-not (equal
+ (expand-file-name (read-file-name "File: "))
+ (concat "/:/:" subdir)))))
+ (delete-directory dir 'recursive))))
+
(provide 'files-tests)
;;; files-tests.el ends here
diff --git a/test/lisp/ibuffer-tests.el b/test/lisp/ibuffer-tests.el
index 92ed101..40760ab 100644
--- a/test/lisp/ibuffer-tests.el
+++ b/test/lisp/ibuffer-tests.el
@@ -24,7 +24,8 @@
(require 'ibuf-macs))
(ert-deftest ibuffer-autoload ()
- "Tests to see whether reftex-auc has been autoloaded"
+ "Tests to see whether ibuffer has been autoloaded"
+ (skip-unless (not (featurep 'ibuf-ext)))
(should
(fboundp 'ibuffer-mark-unsaved-buffers))
(should
@@ -138,5 +139,669 @@
(should-not ibuffer-filtering-qualifiers))
(setq ibuffer-filtering-qualifiers filters))))
+;; Test Filter Inclusion
+(let* (test-buffer-list ; accumulated buffers to clean up
+ ;; Utility functions without polluting the environment
+ (set-buffer-mode
+ (lambda (buffer mode)
+ "Set BUFFER's major mode to MODE, a mode function, or fundamental."
+ (with-current-buffer buffer
+ (funcall (or mode #'fundamental-mode)))))
+ (set-buffer-contents
+ (lambda (buffer size include-content)
+ "Add exactly SIZE bytes to BUFFER, including INCLUDE-CONTENT."
+ (when (or size include-content)
+ (let* ((unit "\n")
+ (chunk "ccccccccccccccccccccccccccccccc\n")
+ (chunk-size (length chunk))
+ (size (if (and size include-content (stringp
include-content))
+ (- size (length include-content))
+ size)))
+ (unless (or (null size) (> size 0))
+ (error "size argument must be nil or positive"))
+ (with-current-buffer buffer
+ (when include-content
+ (insert include-content))
+ (when size
+ (dotimes (_ (floor size chunk-size))
+ (insert chunk))
+ (dotimes (_ (mod size chunk-size))
+ (insert unit)))
+ ;; prevent query on cleanup
+ (set-buffer-modified-p nil))))))
+ (create-file-buffer
+ (lambda (prefix &rest args-plist)
+ "Create a file and buffer with designated properties.
+ PREFIX is a string giving the beginning of the name, and ARGS-PLIST
+ is a series of keyword-value pairs, with allowed keywords
+ :suffix STRING, :size NUMBER, :mode MODE-FUNC, :include-content STRING.
+ Returns the created buffer."
+ (let* ((suffix (plist-get args-plist :suffix))
+ (size (plist-get args-plist :size))
+ (include (plist-get args-plist :include-content))
+ (mode (plist-get args-plist :mode))
+ (file (make-temp-file prefix nil suffix))
+ (buf (find-file-noselect file t)))
+ (push buf test-buffer-list) ; record for cleanup
+ (funcall set-buffer-mode buf mode)
+ (funcall set-buffer-contents buf size include)
+ buf)))
+ (create-non-file-buffer
+ (lambda (prefix &rest args-plist)
+ "Create a non-file and buffer with designated properties.
+ PREFIX is a string giving the beginning of the name, and ARGS-PLIST
+ is a series of keyword-value pairs, with allowed keywords
+ :size NUMBER, :mode MODE-FUNC, :include-content STRING.
+ Returns the created buffer."
+ (let* ((size (plist-get args-plist :size))
+ (include (plist-get args-plist :include-content))
+ (mode (plist-get args-plist :mode))
+ (buf (generate-new-buffer prefix)))
+ (push buf test-buffer-list) ; record for cleanup
+ (funcall set-buffer-mode buf mode)
+ (funcall set-buffer-contents buf size include)
+ buf)))
+ (clean-up
+ (lambda ()
+ "Restore all emacs state modified during the tests"
+ (while test-buffer-list ; created temporary buffers
+ (let ((buf (pop test-buffer-list)))
+ (with-current-buffer buf (bury-buffer)) ; ensure not selected
+ (kill-buffer buf))))))
+ ;; Tests
+ (ert-deftest ibuffer-filter-inclusion-1 ()
+ "Tests inclusion using basic filter combinators with a single buffer."
+ (skip-unless (featurep 'ibuf-ext))
+ (unwind-protect
+ (let ((buf
+ (funcall create-file-buffer "ibuf-test-1" :size 100
+ :include-content "One ring to rule them all\n")))
+ (should (ibuffer-included-in-filters-p buf '((size-gt . 99))))
+ (should (ibuffer-included-in-filters-p buf '((size-lt . 101))))
+ (should (ibuffer-included-in-filters-p
+ buf '((mode . fundamental-mode))))
+ (should (ibuffer-included-in-filters-p
+ buf '((content . "ring to rule them all"))))
+ (should (ibuffer-included-in-filters-p
+ buf '((and (content . "ring to rule them all")))))
+ (should (ibuffer-included-in-filters-p
+ buf '((and (and (content . "ring to rule them all"))))))
+ (should (ibuffer-included-in-filters-p
+ buf '((and (and (and (content . "ring to rule them
all")))))))
+ (should (ibuffer-included-in-filters-p
+ buf '((or (content . "ring to rule them all")))))
+ (should (ibuffer-included-in-filters-p
+ buf '((not (not (content . "ring to rule them all"))))))
+ (should (ibuffer-included-in-filters-p
+ buf '((and (size-gt . 99)
+ (content . "ring to rule them all")
+ (mode . fundamental-mode)
+ (basename . "\\`ibuf-test-1")))))
+ (should (ibuffer-included-in-filters-p
+ buf '((not (or (not (size-gt . 99))
+ (not (content . "ring to rule them all"))
+ (not (mode . fundamental-mode))
+ (not (basename . "\\`ibuf-test-1")))))))
+ (should (ibuffer-included-in-filters-p
+ buf '((and (or (size-gt . 99) (size-lt . 10))
+ (and (content . "ring.*all")
+ (content . "rule")
+ (content . "them all")
+ (content . "One"))
+ (not (mode . text-mode))
+ (basename . "\\`ibuf-test-1"))))))
+ (funcall clean-up)))
+
+ (ert-deftest ibuffer-filter-inclusion-2 ()
+ "Tests inclusion of basic filters in combination on a single buffer."
+ (skip-unless (featurep 'ibuf-ext))
+ (unwind-protect
+ (let ((buf
+ (funcall create-file-buffer "ibuf-test-2" :size 200
+ :mode #'text-mode
+ :include-content "and in the darkness find them\n")))
+ (should (ibuffer-included-in-filters-p buf '((size-gt . 199))))
+ (should (ibuffer-included-in-filters-p buf '((size-lt . 201))))
+ (should (ibuffer-included-in-filters-p buf '((not size-gt . 200))))
+ (should (ibuffer-included-in-filters-p buf '((not (size-gt . 200)))))
+ (should (ibuffer-included-in-filters-p
+ buf '((and (size-gt . 199) (size-lt . 201)))))
+ (should (ibuffer-included-in-filters-p
+ buf '((or (size-gt . 199) (size-gt . 201)))))
+ (should (ibuffer-included-in-filters-p
+ buf '((or (size-gt . 201) (size-gt . 199)))))
+ (should (ibuffer-included-in-filters-p
+ buf '((size-gt . 199) (mode . text-mode)
+ (content . "darkness find them"))))
+ (should (ibuffer-included-in-filters-p
+ buf '((and (size-gt . 199) (mode . text-mode)
+ (content . "darkness find them")))))
+ (should (ibuffer-included-in-filters-p
+ buf '((not (or (not (size-gt . 199)) (not (mode .
text-mode))
+ (not (content . "darkness find them")))))))
+ (should (ibuffer-included-in-filters-p
+ buf '((or (size-gt . 200) (content . "darkness find them")
+ (derived-mode . emacs-lisp-mode)))))
+ (should-not (ibuffer-included-in-filters-p
+ buf '((or (size-gt . 200) (content . "rule them all")
+ (derived-mode . emacs-lisp-mode))))))
+ (funcall clean-up)))
+
+ (ert-deftest ibuffer-filter-inclusion-3 ()
+ "Tests inclusion with filename filters on specified buffers."
+ (skip-unless (featurep 'ibuf-ext))
+ (unwind-protect
+ (let* ((bufA
+ (funcall create-file-buffer "ibuf-test-3.a" :size 50
+ :mode #'text-mode
+ :include-content "...but a multitude of drops?\n"))
+ (bufB
+ (funcall create-non-file-buffer "ibuf-test-3.b" :size 50
+ :mode #'text-mode
+ :include-content "...but a multitude of drops?\n"))
+ (dirA (with-current-buffer bufA default-directory))
+ (dirB (with-current-buffer bufB default-directory)))
+ (should (ibuffer-included-in-filters-p
+ bufA '((basename . "ibuf-test-3"))))
+ (should (ibuffer-included-in-filters-p
+ bufA '((basename . "test-3\\.a"))))
+ (should (ibuffer-included-in-filters-p
+ bufA '((file-extension . "a"))))
+ (should (ibuffer-included-in-filters-p
+ bufA (list (cons 'directory dirA))))
+ (should-not (ibuffer-included-in-filters-p
+ bufB '((basename . "ibuf-test-3"))))
+ (should-not (ibuffer-included-in-filters-p
+ bufB '((file-extension . "b"))))
+ (should (ibuffer-included-in-filters-p
+ bufB (list (cons 'directory dirB))))
+ (should (ibuffer-included-in-filters-p
+ bufA '((name . "ibuf-test-3"))))
+ (should (ibuffer-included-in-filters-p
+ bufB '((name . "ibuf-test-3")))))
+ (funcall clean-up)))
+
+ (ert-deftest ibuffer-filter-inclusion-4 ()
+ "Tests inclusion with various filters on a single buffer."
+ (skip-unless (featurep 'ibuf-ext))
+ (unwind-protect
+ (let ((buf
+ (funcall create-file-buffer "ibuf-test-4"
+ :mode #'emacs-lisp-mode :suffix ".el"
+ :include-content "(message \"--%s--\"
'emacs-rocks)\n")))
+ (should (ibuffer-included-in-filters-p
+ buf '((file-extension . "el"))))
+ (should (ibuffer-included-in-filters-p
+ buf '((derived-mode . prog-mode))))
+ (should (ibuffer-included-in-filters-p
+ buf '((used-mode . emacs-lisp-mode))))
+ (should (ibuffer-included-in-filters-p
+ buf '((mode . emacs-lisp-mode))))
+ (with-current-buffer buf (set-buffer-modified-p t))
+ (should (ibuffer-included-in-filters-p buf '((modified))))
+ (with-current-buffer buf (set-buffer-modified-p nil))
+ (should (ibuffer-included-in-filters-p buf '((not modified))))
+ (should (ibuffer-included-in-filters-p
+ buf '((and (file-extension . "el")
+ (derived-mode . prog-mode)
+ (not modified)))))
+ (should (ibuffer-included-in-filters-p
+ buf '((or (file-extension . "tex")
+ (derived-mode . prog-mode)
+ (modified)))))
+ (should (ibuffer-included-in-filters-p
+ buf '((file-extension . "el")
+ (derived-mode . prog-mode)
+ (not modified)))))
+ (funcall clean-up)))
+
+ (ert-deftest ibuffer-filter-inclusion-5 ()
+ "Tests inclusion with various filters on a single buffer."
+ (skip-unless (featurep 'ibuf-ext))
+ (unwind-protect
+ (let ((buf
+ (funcall create-non-file-buffer "ibuf-test-5.el"
+ :mode #'emacs-lisp-mode
+ :include-content
+ "(message \"--%s--\" \"It really does!\")\n")))
+ (should-not (ibuffer-included-in-filters-p
+ buf '((file-extension . "el"))))
+ (should (ibuffer-included-in-filters-p
+ buf '((size-gt . 18))))
+ (should (ibuffer-included-in-filters-p
+ buf '((predicate . (lambda ()
+ (> (- (point-max) (point-min)) 18))))))
+ (should (ibuffer-included-in-filters-p
+ buf '((and (mode . emacs-lisp-mode)
+ (or (starred-name)
+ (size-gt . 18))
+ (and (not (size-gt . 100))
+ (content . "[Ii]t *really does!")
+ (or (name . "test-5")
+ (not (filename . "test-5")))))))))
+ (funcall clean-up)))
+
+ (ert-deftest ibuffer-filter-inclusion-6 ()
+ "Tests inclusion using saved filters and DeMorgan's laws."
+ (skip-unless (featurep 'ibuf-ext))
+ (unwind-protect
+ (let ((buf
+ (funcall create-non-file-buffer "*ibuf-test-6*" :size 65
+ :mode #'text-mode))
+ (buf2
+ (funcall create-file-buffer "ibuf-test-6a" :suffix ".html"
+ :mode #'html-mode
+ :include-content
+ "<HTML><BODY><H1>Hello, World!</H1></BODY></HTML>")))
+ (should (ibuffer-included-in-filters-p buf '((starred-name))))
+ (should-not (ibuffer-included-in-filters-p
+ buf '((saved . "text document"))))
+ (should (ibuffer-included-in-filters-p buf2 '((saved . "web"))))
+ (should (ibuffer-included-in-filters-p
+ buf2 '((not (and (not (derived-mode . sgml-mode))
+ (not (derived-mode . css-mode))
+ (not (mode . javascript-mode))
+ (not (mode . js2-mode))
+ (not (mode . scss-mode))
+ (not (derived-mode . haml-mode))
+ (not (mode . sass-mode)))))))
+ (should (ibuffer-included-in-filters-p
+ buf '((and (starred-name)
+ (or (size-gt . 50) (filename . "foo"))))))
+ (should (ibuffer-included-in-filters-p
+ buf '((not (or (not starred-name)
+ (and (size-lt . 51)
+ (not (filename . "foo")))))))))
+ (funcall clean-up)))
+
+ (ert-deftest ibuffer-filter-inclusion-7 ()
+ "Tests inclusion with various filters on a single buffer."
+ (skip-unless (featurep 'ibuf-ext))
+ (unwind-protect
+ (let ((buf
+ (funcall create-non-file-buffer "ibuf-test-7"
+ :mode #'artist-mode)))
+ (should (ibuffer-included-in-filters-p
+ buf '((not (starred-name)))))
+ (should (ibuffer-included-in-filters-p
+ buf '((not starred-name))))
+ (should (ibuffer-included-in-filters-p
+ buf '((not (not (not starred-name))))))
+ (should (ibuffer-included-in-filters-p
+ buf '((not (modified)))))
+ (should (ibuffer-included-in-filters-p
+ buf '((not modified))))
+ (should (ibuffer-included-in-filters-p
+ buf '((not (not (not modified)))))))
+ (funcall clean-up)))
+
+ (ert-deftest ibuffer-filter-inclusion-8 ()
+ "Tests inclusion with various filters."
+ (skip-unless (featurep 'ibuf-ext))
+ (unwind-protect
+ (let ((bufA
+ (funcall create-non-file-buffer "ibuf-test-8a"
+ :mode #'artist-mode))
+ (bufB (funcall create-non-file-buffer "*ibuf-test-8b*" :size 32))
+ (bufC (funcall create-file-buffer "ibuf-test8c" :suffix "*"
+ :size 64))
+ (bufD (funcall create-file-buffer "*ibuf-test8d" :size 128))
+ (bufE (funcall create-file-buffer "*ibuf-test8e" :suffix "*<2>"
+ :size 16))
+ (bufF (and (funcall create-non-file-buffer "*ibuf-test8f*")
+ (funcall create-non-file-buffer "*ibuf-test8f*"
+ :size 8))))
+ (with-current-buffer bufA (set-buffer-modified-p t))
+ (should (ibuffer-included-in-filters-p
+ bufA '((and (not starred-name)
+ (modified)
+ (name . "test-8")
+ (not (size-gt . 100))
+ (mode . picture-mode)))))
+ (with-current-buffer bufA (set-buffer-modified-p nil))
+ (should-not (ibuffer-included-in-filters-p
+ bufA '((or (starred-name) (visiting-file) (modified)))))
+ (should (ibuffer-included-in-filters-p
+ bufB '((and (starred-name)
+ (name . "test.*8b")
+ (size-gt . 31)
+ (not visiting-file)))))
+ (should (ibuffer-included-in-filters-p
+ bufC '((and (not (starred-name))
+ (visiting-file)
+ (name . "8c[^*]*\\*")
+ (size-lt . 65)))))
+ (should (ibuffer-included-in-filters-p
+ bufD '((and (not (starred-name))
+ (visiting-file)
+ (name . "\\`\\*.*test8d")
+ (size-lt . 129)
+ (size-gt . 127)))))
+ (should (ibuffer-included-in-filters-p
+ bufE '((and (starred-name)
+ (visiting-file)
+ (name . "8e.*?\\*<[[:digit:]]+>")
+ (size-gt . 10)))))
+ (should (ibuffer-included-in-filters-p
+ bufF '((and (starred-name)
+ (not (visiting-file))
+ (name . "8f\\*<[[:digit:]]>")
+ (size-lt . 10))))))
+ (funcall clean-up))))
+
+;; Test Filter Combination and Decomposition
+(let* (ibuffer-to-kill ; if non-nil, kill this buffer at cleanup
+ (ibuffer-already 'check) ; existing ibuffer buffer to use but not kill
+ ;; Utility functions without polluting the environment
+ (get-test-ibuffer
+ (lambda ()
+ "Returns a test ibuffer-mode buffer, creating one if necessary.
+ If a new buffer is created, it is named \"*Test-Ibuffer*\" and is
+ saved to `ibuffer-to-kill' for later cleanup."
+ (when (eq ibuffer-already 'check)
+ (setq ibuffer-already
+ (catch 'found-buf
+ (dolist (buf (buffer-list) nil)
+ (when (with-current-buffer buf
+ (derived-mode-p 'ibuffer-mode))
+ (throw 'found-buf buf))))))
+ (or ibuffer-already
+ ibuffer-to-kill
+ (let ((test-ibuf-name "*Test-Ibuffer*"))
+ (ibuffer nil test-ibuf-name nil t)
+ (setq ibuffer-to-kill (get-buffer test-ibuf-name))))))
+ (clean-up
+ (lambda ()
+ "Restore all emacs state modified during the tests"
+ (when ibuffer-to-kill ; created ibuffer
+ (with-current-buffer ibuffer-to-kill
+ (set-buffer-modified-p nil)
+ (bury-buffer))
+ (kill-buffer ibuffer-to-kill)
+ (setq ibuffer-to-kill nil))
+ (when (and ibuffer-already (not (eq ibuffer-already 'check)))
+ ;; restore existing ibuffer state
+ (ibuffer-update nil t)))))
+ ;; Tests
+ (ert-deftest ibuffer-decompose-filter ()
+ "Tests `ibuffer-decompose-filter' for and, or, not, and saved."
+ (skip-unless (featurep 'ibuf-ext))
+ (unwind-protect
+ (let ((ibuf (funcall get-test-ibuffer)))
+ (with-current-buffer ibuf
+ (let ((ibuffer-filtering-qualifiers nil)
+ (ibuffer-filter-groups nil)
+ (filters '((size-gt . 100) (not (starred-name))
+ (name . "foo"))))
+ (progn
+ (push (cons 'or filters) ibuffer-filtering-qualifiers)
+ (ibuffer-decompose-filter)
+ (should (equal filters ibuffer-filtering-qualifiers))
+ (setq ibuffer-filtering-qualifiers nil))
+ (progn
+ (push (cons 'and filters) ibuffer-filtering-qualifiers)
+ (ibuffer-decompose-filter)
+ (should (equal filters ibuffer-filtering-qualifiers))
+ (setq ibuffer-filtering-qualifiers nil))
+ (progn
+ (push (list 'not (car filters)) ibuffer-filtering-qualifiers)
+ (ibuffer-decompose-filter)
+ (should (equal (list (car filters))
+ ibuffer-filtering-qualifiers))
+ (setq ibuffer-filtering-qualifiers nil))
+ (progn
+ (push (cons 'not (car filters)) ibuffer-filtering-qualifiers)
+ (ibuffer-decompose-filter)
+ (should (equal (list (car filters))
+ ibuffer-filtering-qualifiers))
+ (setq ibuffer-filtering-qualifiers nil))
+ (let ((gnus (assoc "gnus" ibuffer-saved-filters)))
+ (push '(saved . "gnus") ibuffer-filtering-qualifiers)
+ (ibuffer-decompose-filter)
+ (should (equal (cdr gnus) ibuffer-filtering-qualifiers))
+ (ibuffer-decompose-filter)
+ (should (equal (cdr (cadr gnus)) ibuffer-filtering-qualifiers))
+ (setq ibuffer-filtering-qualifiers nil))
+ (when (not (assoc "__unknown__" ibuffer-saved-filters))
+ (push '(saved . "__uknown__") ibuffer-filtering-qualifiers)
+ (should-error (ibuffer-decompose-filter) :type 'error)
+ (setq ibuffer-filtering-qualifiers nil))
+ (progn
+ (push (car filters) ibuffer-filtering-qualifiers)
+ (should-error (ibuffer-decompose-filter) :type 'error)
+ (setq ibuffer-filtering-qualifiers nil)))))
+ (funcall clean-up)))
+
+ (ert-deftest ibuffer-and-filter ()
+ "Tests `ibuffer-and-filter' in an Ibuffer buffer."
+ (skip-unless (featurep 'ibuf-ext))
+ (unwind-protect
+ (let ((ibuf (funcall get-test-ibuffer)))
+ (with-current-buffer ibuf
+ (let ((ibuffer-filtering-qualifiers nil)
+ (ibuffer-filter-groups nil)
+ (filters [(size-gt . 100) (not (starred-name))
+ (filename . "A") (mode . text-mode)]))
+ (should-error (ibuffer-and-filter) :type 'error)
+ (progn
+ (push (aref filters 1) ibuffer-filtering-qualifiers)
+ (should-error (ibuffer-and-filter) :type 'error))
+ (should (progn
+ (push (aref filters 0) ibuffer-filtering-qualifiers)
+ (ibuffer-and-filter)
+ (and (equal (list 'and (aref filters 0) (aref filters
1))
+ (car ibuffer-filtering-qualifiers))
+ (null (cdr ibuffer-filtering-qualifiers)))))
+ (should (progn
+ (ibuffer-and-filter 'decompose)
+ (and (equal (aref filters 0)
+ (pop ibuffer-filtering-qualifiers))
+ (equal (aref filters 1)
+ (pop ibuffer-filtering-qualifiers))
+ (null ibuffer-filtering-qualifiers))))
+ (should (progn
+ (push (list 'and (aref filters 2) (aref filters 3))
+ ibuffer-filtering-qualifiers)
+ (push (list 'and (aref filters 0) (aref filters 1))
+ ibuffer-filtering-qualifiers)
+ (ibuffer-and-filter)
+ (and (equal (list 'and (aref filters 0) (aref filters
1)
+ (aref filters 2) (aref filters 3))
+ (car ibuffer-filtering-qualifiers))
+ (null (cdr ibuffer-filtering-qualifiers)))))
+ (pop ibuffer-filtering-qualifiers)
+ (should (progn
+ (push (list 'or (aref filters 2) (aref filters 3))
+ ibuffer-filtering-qualifiers)
+ (push (list 'and (aref filters 0) (aref filters 1))
+ ibuffer-filtering-qualifiers)
+ (ibuffer-and-filter)
+ (and (equal (list 'and (aref filters 0) (aref filters
1)
+ (list 'or (aref filters 2)
+ (aref filters 3)))
+ (car ibuffer-filtering-qualifiers))
+ (null (cdr ibuffer-filtering-qualifiers)))))
+ (pop ibuffer-filtering-qualifiers)
+ (should (progn
+ (push (list 'and (aref filters 2) (aref filters 3))
+ ibuffer-filtering-qualifiers)
+ (push (list 'or (aref filters 0) (aref filters 1))
+ ibuffer-filtering-qualifiers)
+ (ibuffer-and-filter)
+ (and (equal (list 'and (list 'or (aref filters 0)
+ (aref filters 1))
+ (aref filters 2) (aref filters 3))
+ (car ibuffer-filtering-qualifiers))
+ (null (cdr ibuffer-filtering-qualifiers)))))
+ (pop ibuffer-filtering-qualifiers)
+ (should (progn
+ (push (list 'or (aref filters 2) (aref filters 3))
+ ibuffer-filtering-qualifiers)
+ (push (list 'or (aref filters 0) (aref filters 1))
+ ibuffer-filtering-qualifiers)
+ (ibuffer-and-filter)
+ (and (equal (list 'and
+ (list 'or (aref filters 0)
+ (aref filters 1))
+ (list 'or (aref filters 2)
+ (aref filters 3)))
+ (car ibuffer-filtering-qualifiers))
+ (null (cdr ibuffer-filtering-qualifiers))))))))
+ (funcall clean-up)))
+
+ (ert-deftest ibuffer-or-filter ()
+ "Tests `ibuffer-or-filter' in an Ibuffer buffer."
+ (skip-unless (featurep 'ibuf-ext))
+ (unwind-protect
+ (let ((ibuf (funcall get-test-ibuffer)))
+ (with-current-buffer ibuf
+ (let ((ibuffer-filtering-qualifiers nil)
+ (ibuffer-filter-groups nil)
+ (filters [(size-gt . 100) (not (starred-name))
+ (filename . "A") (mode . text-mode)]))
+ (should-error (ibuffer-or-filter) :type 'error)
+ (progn
+ (push (aref filters 1) ibuffer-filtering-qualifiers)
+ (should-error (ibuffer-or-filter) :type 'error))
+ (should (progn
+ (push (aref filters 0) ibuffer-filtering-qualifiers)
+ (ibuffer-or-filter)
+ (and (equal (list 'or (aref filters 0) (aref filters
1))
+ (car ibuffer-filtering-qualifiers))
+ (null (cdr ibuffer-filtering-qualifiers)))))
+ (should (progn
+ (ibuffer-or-filter 'decompose)
+ (and (equal (aref filters 0)
+ (pop ibuffer-filtering-qualifiers))
+ (equal (aref filters 1)
+ (pop ibuffer-filtering-qualifiers))
+ (null ibuffer-filtering-qualifiers))))
+ (should (progn
+ (push (list 'or (aref filters 2) (aref filters 3))
+ ibuffer-filtering-qualifiers)
+ (push (list 'or (aref filters 0) (aref filters 1))
+ ibuffer-filtering-qualifiers)
+ (ibuffer-or-filter)
+ (and (equal (list 'or (aref filters 0) (aref filters 1)
+ (aref filters 2) (aref filters 3))
+ (car ibuffer-filtering-qualifiers))
+ (null (cdr ibuffer-filtering-qualifiers)))))
+ (pop ibuffer-filtering-qualifiers)
+ (should (progn
+ (push (list 'and (aref filters 2) (aref filters 3))
+ ibuffer-filtering-qualifiers)
+ (push (list 'or (aref filters 0) (aref filters 1))
+ ibuffer-filtering-qualifiers)
+ (ibuffer-or-filter)
+ (and (equal (list 'or (aref filters 0) (aref filters 1)
+ (list 'and (aref filters 2)
+ (aref filters 3)))
+ (car ibuffer-filtering-qualifiers))
+ (null (cdr ibuffer-filtering-qualifiers)))))
+ (pop ibuffer-filtering-qualifiers)
+ (should (progn
+ (push (list 'or (aref filters 2) (aref filters 3))
+ ibuffer-filtering-qualifiers)
+ (push (list 'and (aref filters 0) (aref filters 1))
+ ibuffer-filtering-qualifiers)
+ (ibuffer-or-filter)
+ (and (equal (list 'or (list 'and (aref filters 0)
+ (aref filters 1))
+ (aref filters 2) (aref filters 3))
+ (car ibuffer-filtering-qualifiers))
+ (null (cdr ibuffer-filtering-qualifiers)))))
+ (pop ibuffer-filtering-qualifiers)
+ (should (progn
+ (push (list 'and (aref filters 2) (aref filters 3))
+ ibuffer-filtering-qualifiers)
+ (push (list 'and (aref filters 0) (aref filters 1))
+ ibuffer-filtering-qualifiers)
+ (ibuffer-or-filter)
+ (and (equal (list 'or
+ (list 'and (aref filters 0)
+ (aref filters 1))
+ (list 'and (aref filters 2)
+ (aref filters 3)))
+ (car ibuffer-filtering-qualifiers))
+ (null (cdr ibuffer-filtering-qualifiers))))))))
+ (funcall clean-up))))
+
+(ert-deftest ibuffer-format-qualifier ()
+ "Tests string recommendation of filter from `ibuffer-format-qualifier'."
+ (skip-unless (featurep 'ibuf-ext))
+ (let ((test1 '(mode . org-mode))
+ (test2 '(size-lt . 100))
+ (test3 '(derived-mode . prog-mode))
+ (test4 '(or (size-gt . 10000)
+ (and (not (starred-name))
+ (directory . "\\<org\\>"))))
+ (test5 '(or (filename . "scratch")
+ (filename . "bonz")
+ (filename . "temp")))
+ (test6 '(or (mode . emacs-lisp-mode) (file-extension . "elc?")
+ (and (starred-name) (name . "elisp"))
+ (mode . lisp-interaction-mode)))
+ (description (lambda (q)
+ (cadr (assq q ibuffer-filtering-alist))))
+ (tag (lambda (&rest args )
+ (concat " [" (apply #'concat args) "]"))))
+ (should (equal (ibuffer-format-qualifier test1)
+ (funcall tag (funcall description 'mode)
+ ": " "org-mode")))
+ (should (equal (ibuffer-format-qualifier test2)
+ (funcall tag (funcall description 'size-lt)
+ ": " "100")))
+ (should (equal (ibuffer-format-qualifier test3)
+ (funcall tag (funcall description 'derived-mode)
+ ": " "prog-mode")))
+ (should (equal (ibuffer-format-qualifier test4)
+ (funcall tag "OR"
+ (funcall tag (funcall description 'size-gt)
+ ": " (format "%s" 10000))
+ (funcall tag "AND"
+ (funcall tag "NOT"
+ (funcall tag
+ (funcall description
+ 'starred-name)
+ ": " "nil"))
+ (funcall tag
+ (funcall description 'directory)
+ ": " "\\<org\\>")))))
+ (should (equal (ibuffer-format-qualifier test5)
+ (funcall tag "OR"
+ (funcall tag (funcall description 'filename)
+ ": " "scratch")
+ (funcall tag (funcall description 'filename)
+ ": " "bonz")
+ (funcall tag (funcall description 'filename)
+ ": " "temp"))))
+ (should (equal (ibuffer-format-qualifier test6)
+ (funcall tag "OR"
+ (funcall tag (funcall description 'mode)
+ ": " "emacs-lisp-mode")
+ (funcall tag (funcall description 'file-extension)
+ ": " "elc?")
+ (funcall tag "AND"
+ (funcall tag
+ (funcall description
'starred-name)
+ ": " "nil")
+ (funcall tag
+ (funcall description 'name)
+ ": " "elisp"))
+ (funcall tag (funcall description 'mode)
+ ": " "lisp-interaction-mode"))))))
+
+(ert-deftest ibuffer-unary-operand ()
+ "Tests `ibuffer-unary-operand': (not cell) or (not . cell) -> cell."
+ (skip-unless (featurep 'ibuf-ext))
+ (should (equal (ibuffer-unary-operand '(not . (mode "foo")))
+ '(mode "foo")))
+ (should (equal (ibuffer-unary-operand '(not (mode "foo")))
+ '(mode "foo")))
+ (should (equal (ibuffer-unary-operand '(not "cdr"))
+ '("cdr")))
+ (should (equal (ibuffer-unary-operand '(not)) nil))
+ (should (equal (ibuffer-unary-operand '(not . a)) 'a)))
+
(provide 'ibuffer-tests)
;; ibuffer-tests.el ends here
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index 2d17fa0..22b60db 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -583,10 +583,6 @@ handled properly. BODY shall not contain a timeout."
(when (and (load "tramp-gvfs" 'noerror 'nomessage)
(symbol-value 'tramp-gvfs-enabled))
(should (string-equal (file-remote-p "/synce::" 'user) nil)))
- ;; Default values in tramp-gw.el.
- (dolist (m '("tunnel" "socks"))
- (should
- (string-equal (file-remote-p (format "/%s::" m) 'user)
(user-login-name))))
;; Default values in tramp-sh.el.
(dolist (h `("127.0.0.1" "[::1]" "localhost" "localhost6" ,(system-name)))
(should (string-equal (file-remote-p (format "/address@hidden:" h)
'method) "su")))
@@ -682,8 +678,8 @@ handled properly. BODY shall not contain a timeout."
(expand-file-name "/method:host:/:/path/../file") "/method:host:/:/file"))
(should
(string-equal
- (expand-file-name "/method:host:/:~/path/./file")
- "/method:host:/:~/path/file")))
+ (expand-file-name "/method:host:/:/~/path/./file")
+ "/method:host:/:/~/path/file")))
(ert-deftest tramp-test06-directory-file-name ()
"Check `directory-file-name'.
@@ -2102,6 +2098,12 @@ This tests also `make-symbolic-link', `file-truename'
and `add-name-to-file'."
This requires restrictions of file name syntax."
(tramp-adb-file-name-p tramp-test-temporary-file-directory))
+(defun tramp--test-docker-p ()
+ "Check, whether the docker method is used.
+This does not support some special file names."
+ (string-equal
+ "docker" (file-remote-p tramp-test-temporary-file-directory 'method)))
+
(defun tramp--test-ftp-p ()
"Check, whether an FTP-like method is used.
This does not support globbing characters in file names (yet)."
@@ -2114,6 +2116,14 @@ This does not support globbing characters in file names
(yet)."
This requires restrictions of file name syntax."
(tramp-gvfs-file-name-p tramp-test-temporary-file-directory))
+(defun tramp--test-hpux-p ()
+ "Check, whether the remote host runs HP-UX.
+Several special characters do not work properly there."
+ ;; We must refill the cache. `file-truename' does it.
+ (with-parsed-tramp-file-name
+ (file-truename tramp-test-temporary-file-directory) nil
+ (string-match "^HP-UX" (tramp-get-connection-property v "uname" ""))))
+
(defun tramp--test-rsync-p ()
"Check, whether the rsync method is used.
This does not support special file names."
@@ -2126,23 +2136,28 @@ This does not support special file names."
(tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory)
'tramp-sh-file-name-handler))
-(defun tramp--test-smb-or-windows-nt-p ()
+(defun tramp--test-windows-nt-and-batch ()
+ "Check, whether the locale host runs MS Windows in batch mode.
+This does not support special characters."
+ (and (eq system-type 'windows-nt) noninteractive))
+
+(defun tramp--test-windows-nt-and-pscp-psftp-p ()
+ "Check, whether the locale host runs MS Windows, and ps{cp,ftp} is used.
+This does not support utf8 based file transfer."
+ (and (eq system-type 'windows-nt)
+ (string-match
+ (regexp-opt '("pscp" "psftp"))
+ (file-remote-p tramp-test-temporary-file-directory 'method))))
+
+(defun tramp--test-windows-nt-or-smb-p ()
"Check, whether the locale or remote host runs MS Windows.
This requires restrictions of file name syntax."
(or (eq system-type 'windows-nt)
(tramp-smb-file-name-p tramp-test-temporary-file-directory)))
-(defun tramp--test-hpux-p ()
- "Check, whether the remote host runs HP-UX.
-Several special characters do not work properly there."
- ;; We must refill the cache. `file-truename' does it.
- (with-parsed-tramp-file-name
- (file-truename tramp-test-temporary-file-directory) nil
- (string-match "^HP-UX" (tramp-get-connection-property v "uname" ""))))
-
(defun tramp--test-check-files (&rest files)
"Run a simple but comprehensive test over every file in FILES."
- (dolist (quoted '(if tramp--test-expensive-test '(nil t) '(nil)))
+ (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil)))
;; We must use `file-truename' for the temporary directory,
;; because it could be located on a symlinked directory. This
;; would let the test fail.
@@ -2150,11 +2165,13 @@ Several special characters do not work properly there."
(file-truename tramp-test-temporary-file-directory))
(tmp-name1 (tramp--test-make-temp-name nil quoted))
(tmp-name2 (tramp--test-make-temp-name 'local quoted))
- (files (delq nil files)))
+ (files (delq nil files))
+ (process-environment process-environment))
(unwind-protect
(progn
(make-directory tmp-name1)
(make-directory tmp-name2)
+
(dolist (elt files)
(let* ((file1 (expand-file-name elt tmp-name1))
(file2 (expand-file-name elt tmp-name2))
@@ -2277,7 +2294,27 @@ Several special characters do not work properly there."
(delete-file file2)
(should-not (file-exists-p file2))
(delete-directory file1)
- (should-not (file-exists-p file1)))))
+ (should-not (file-exists-p file1))))
+
+ ;; Check, that environment variables are set correctly.
+ (when (and tramp--test-expensive-test (tramp--test-sh-p))
+ (dolist (elt files)
+ (let ((envvar (concat "VAR_" (upcase (md5 elt))))
+ (default-directory tramp-test-temporary-file-directory)
+ (process-environment process-environment))
+ (setenv envvar elt)
+ ;; The value of PS1 could confuse Tramp's detection
+ ;; of process output. So we unset it temporarily.
+ (setenv "PS1")
+ (with-temp-buffer
+ (should (zerop (process-file "env" nil t nil)))
+ (goto-char (point-min))
+ (should
+ (re-search-forward
+ (format
+ "^%s=%s$"
+ (regexp-quote envvar)
+ (regexp-quote (getenv envvar))))))))))
;; Cleanup.
(ignore-errors (delete-directory tmp-name1 'recursive))
@@ -2291,9 +2328,11 @@ Several special characters do not work properly there."
;; interpreted as a path separator, preventing "\t" from being
;; expanded to <TAB>.
(tramp--test-check-files
- (if (or (tramp--test-gvfs-p) (tramp--test-smb-or-windows-nt-p))
+ (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p))
"foo bar baz"
- (if (or (tramp--test-adb-p) (eq system-type 'cygwin))
+ (if (or (tramp--test-adb-p)
+ (tramp--test-docker-p)
+ (eq system-type 'cygwin))
" foo bar baz "
" foo\tbar baz\t"))
"$foo$bar$$baz$"
@@ -2302,23 +2341,23 @@ Several special characters do not work properly there."
"&foo&bar&baz&"
(unless (or (tramp--test-ftp-p)
(tramp--test-gvfs-p)
- (tramp--test-smb-or-windows-nt-p))
+ (tramp--test-windows-nt-or-smb-p))
"?foo?bar?baz?")
(unless (or (tramp--test-ftp-p)
(tramp--test-gvfs-p)
- (tramp--test-smb-or-windows-nt-p))
+ (tramp--test-windows-nt-or-smb-p))
"*foo*bar*baz*")
- (if (or (tramp--test-gvfs-p) (tramp--test-smb-or-windows-nt-p))
+ (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p))
"'foo'bar'baz'"
"'foo\"bar'baz\"")
"#foo~bar#baz~"
- (if (or (tramp--test-gvfs-p) (tramp--test-smb-or-windows-nt-p))
+ (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p))
"!foo!bar!baz!"
"!foo|bar!baz|")
- (if (or (tramp--test-gvfs-p) (tramp--test-smb-or-windows-nt-p))
+ (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p))
";foo;bar;baz;"
":foo;bar:baz;")
- (unless (or (tramp--test-gvfs-p) (tramp--test-smb-or-windows-nt-p))
+ (unless (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p))
"<foo>bar<baz>")
"(foo)bar(baz)"
(unless (or (tramp--test-ftp-p) (tramp--test-gvfs-p)) "[foo]bar[baz]")
@@ -2329,6 +2368,7 @@ Several special characters do not work properly there."
"Check special characters in file names."
(skip-unless (tramp--test-enabled))
(skip-unless (not (tramp--test-rsync-p)))
+ (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p)))
(tramp--test-special-characters))
@@ -2337,7 +2377,9 @@ Several special characters do not work properly there."
Use the `stat' command."
:tags '(:expensive-test)
(skip-unless (tramp--test-enabled))
- (skip-unless (and (tramp--test-sh-p) (not (tramp--test-rsync-p))))
+ (skip-unless (tramp--test-sh-p))
+ (skip-unless (not (tramp--test-rsync-p)))
+ (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p)))
(with-parsed-tramp-file-name tramp-test-temporary-file-directory nil
(skip-unless (tramp-get-remote-stat v)))
@@ -2353,7 +2395,9 @@ Use the `stat' command."
Use the `perl' command."
:tags '(:expensive-test)
(skip-unless (tramp--test-enabled))
- (skip-unless (and (tramp--test-sh-p) (not (tramp--test-rsync-p))))
+ (skip-unless (tramp--test-sh-p))
+ (skip-unless (not (tramp--test-rsync-p)))
+ (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p)))
(with-parsed-tramp-file-name tramp-test-temporary-file-directory nil
(skip-unless (tramp-get-remote-perl v)))
@@ -2372,7 +2416,10 @@ Use the `perl' command."
Use the `ls' command."
:tags '(:expensive-test)
(skip-unless (tramp--test-enabled))
- (skip-unless (and (tramp--test-sh-p) (not (tramp--test-rsync-p))))
+ (skip-unless (tramp--test-sh-p))
+ (skip-unless (not (tramp--test-rsync-p)))
+ (skip-unless (not (tramp--test-windows-nt-and-batch)))
+ (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p)))
(let ((tramp-connection-properties
(append
@@ -2404,7 +2451,10 @@ Use the `ls' command."
(ert-deftest tramp-test34-utf8 ()
"Check UTF8 encoding in file names and file contents."
(skip-unless (tramp--test-enabled))
+ (skip-unless (not (tramp--test-docker-p)))
(skip-unless (not (tramp--test-rsync-p)))
+ (skip-unless (not (tramp--test-windows-nt-and-batch)))
+ (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p)))
(tramp--test-utf8))
@@ -2413,7 +2463,11 @@ Use the `ls' command."
Use the `stat' command."
:tags '(:expensive-test)
(skip-unless (tramp--test-enabled))
- (skip-unless (and (tramp--test-sh-p) (not (tramp--test-rsync-p))))
+ (skip-unless (tramp--test-sh-p))
+ (skip-unless (not (tramp--test-docker-p)))
+ (skip-unless (not (tramp--test-rsync-p)))
+ (skip-unless (not (tramp--test-windows-nt-and-batch)))
+ (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p)))
(with-parsed-tramp-file-name tramp-test-temporary-file-directory nil
(skip-unless (tramp-get-remote-stat v)))
@@ -2429,7 +2483,11 @@ Use the `stat' command."
Use the `perl' command."
:tags '(:expensive-test)
(skip-unless (tramp--test-enabled))
- (skip-unless (and (tramp--test-sh-p) (not (tramp--test-rsync-p))))
+ (skip-unless (tramp--test-sh-p))
+ (skip-unless (not (tramp--test-docker-p)))
+ (skip-unless (not (tramp--test-rsync-p)))
+ (skip-unless (not (tramp--test-windows-nt-and-batch)))
+ (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p)))
(with-parsed-tramp-file-name tramp-test-temporary-file-directory nil
(skip-unless (tramp-get-remote-perl v)))
@@ -2448,7 +2506,11 @@ Use the `perl' command."
Use the `ls' command."
:tags '(:expensive-test)
(skip-unless (tramp--test-enabled))
- (skip-unless (and (tramp--test-sh-p) (not (tramp--test-rsync-p))))
+ (skip-unless (tramp--test-sh-p))
+ (skip-unless (not (tramp--test-docker-p)))
+ (skip-unless (not (tramp--test-rsync-p)))
+ (skip-unless (not (tramp--test-windows-nt-and-batch)))
+ (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p)))
(let ((tramp-connection-properties
(append
diff --git a/test/lisp/progmodes/compile-tests.el
b/test/lisp/progmodes/compile-tests.el
index 265baf2..9f61c20 100644
--- a/test/lisp/progmodes/compile-tests.el
+++ b/test/lisp/progmodes/compile-tests.el
@@ -1,4 +1,4 @@
-;;; compile-tests.el --- Test suite for compile.el.
+;;; compile-tests.el --- Test suite for compile.el. -*- lexical-binding: t;
-*-
;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
@@ -21,6 +21,10 @@
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+;;; Commentary:
+
+;; Unit tests for lisp/progmodes/compile.el.
+
;;; Code:
(require 'ert)
@@ -79,6 +83,9 @@
1 nil 302 "\\lib\\python\\Products\\PythonScripts\\PythonScript.py")
("File \"/tmp/foo.py\", line 10"
1 nil 10 "/tmp/foo.py")
+ ;; clang-include
+ ("In file included from foo.cpp:2:"
+ 1 nil 2 "foo.cpp" 0)
;; cmake cmake-info
("CMake Error at CMakeLists.txt:23 (hurz):"
1 nil 23 "CMakeLists.txt")
@@ -323,15 +330,18 @@
("index.html (13:1) Unknown element <fdjsk>"
1 1 13 "index.html"))
"List of tests for `compilation-error-regexp-alist'.
-Each element has the form (STR POS COLUMN LINE FILENAME), where
-STR is an error string, POS is the position of the error in STR,
-COLUMN and LINE are the reported column and line numbers (or nil)
-for that error, and FILENAME is the reported filename.
+Each element has the form (STR POS COLUMN LINE FILENAME [TYPE]),
+where STR is an error string, POS is the position of the error in
+STR, COLUMN and LINE are the reported column and line numbers (or
+nil) for that error, FILENAME is the reported filename, and TYPE
+is 0 for an information message, 1 for a warning, and 2 for an
+error.
LINE can also be of the form (LINE . END-LINE) meaning a range of
lines. COLUMN can also be of the form (COLUMN . END-COLUMN)
meaning a range of columns starting on LINE and ending on
-END-LINE, if that matched.")
+END-LINE, if that matched. TYPE can be left out, in which case
+any message type is accepted.")
(defun compile--test-error-line (test)
(erase-buffer)
@@ -339,35 +349,34 @@ END-LINE, if that matched.")
(insert (car test))
(compilation-parse-errors (point-min) (point-max))
(let ((msg (get-text-property (nth 1 test) 'compilation-message)))
- (when msg
- (let ((loc (compilation--message->loc msg))
- (col (nth 2 test))
- (line (nth 3 test))
- (file (nth 4 test))
- (type (nth 5 test))
- end-col end-line)
- (if (consp col)
- (setq end-col (cdr col) col (car col)))
- (if (consp line)
- (setq end-line (cdr line) line (car line)))
- (and (equal (compilation--loc->col loc) col)
- (equal (compilation--loc->line loc) line)
- (or (not file)
- (equal (caar (compilation--loc->file-struct loc)) file))
- (or (null end-col)
- (equal (car (cadr (nth 2 (compilation--loc->file-struct loc))))
- end-col))
- (equal (car (nth 2 (compilation--loc->file-struct loc)))
- (or end-line line))
- (or (null type)
- (equal type (compilation--message->type msg))))))))
+ (should msg)
+ (let ((loc (compilation--message->loc msg))
+ (col (nth 2 test))
+ (line (nth 3 test))
+ (file (nth 4 test))
+ (type (nth 5 test))
+ end-col end-line)
+ (if (consp col)
+ (setq end-col (cdr col) col (car col)))
+ (if (consp line)
+ (setq end-line (cdr line) line (car line)))
+ (should (equal (compilation--loc->col loc) col))
+ (should (equal (compilation--loc->line loc) line))
+ (when file
+ (should (equal (caar (compilation--loc->file-struct loc)) file)))
+ (when end-col
+ (should (equal (car (cadr (nth 2 (compilation--loc->file-struct loc))))
+ end-col)))
+ (should (equal (car (nth 2 (compilation--loc->file-struct loc)))
+ (or end-line line)))
+ (when type
+ (should (equal type (compilation--message->type msg)))))))
(ert-deftest compile-test-error-regexps ()
"Test the `compilation-error-regexp-alist' regexps.
The test data is in `compile-tests--test-regexps-data'."
(with-temp-buffer
(font-lock-mode -1)
- (dolist (test compile-tests--test-regexps-data)
- (should (compile--test-error-line test)))))
+ (mapc #'compile--test-error-line compile-tests--test-regexps-data)))
-;;; compile-tests.el ends here.
+;;; compile-tests.el ends here
diff --git a/test/lisp/progmodes/etags-tests.el
b/test/lisp/progmodes/etags-tests.el
index a715bba..a992a17 100644
--- a/test/lisp/progmodes/etags-tests.el
+++ b/test/lisp/progmodes/etags-tests.el
@@ -37,7 +37,9 @@
xref-buf)
(set-buffer buf-with-global-tags)
(setq default-directory (expand-file-name "."))
- (visit-tags-table "./manual/etags/ETAGS.good_1")
+ (visit-tags-table
+ (expand-file-name "manual/etags/ETAGS.good_1"
+ (getenv "EMACS_TEST_DIRECTORY")))
;; Check that tags in ETAGS.good_1 are recognized.
(setq xref-buf (xref-find-definitions "LL_Task_Procedure_Access/t"))
(should (bufferp xref-buf))
@@ -52,7 +54,10 @@
(set-buffer buf-with-local-tags)
(setq default-directory (expand-file-name "."))
(let (his-masters-voice)
- (visit-tags-table "./manual/etags/ETAGS.good_3" t))
+ (visit-tags-table
+ (expand-file-name "manual/etags/ETAGS.good_3"
+ (getenv "EMACS_TEST_DIRECTORY"))
+ t))
;; Check that tags in ETAGS.good_1 are recognized.
(setq xref-buf (xref-find-definitions "LL_Task_Procedure_Access/t"))
(should (bufferp xref-buf))
@@ -78,6 +83,9 @@
"Test that setting a local value of tags table doesn't signal errors."
(set-buffer (get-buffer-create "*foobar*"))
(fundamental-mode)
- (visit-tags-table "./manual/etags/ETAGS.good_3" t)
+ (visit-tags-table
+ (expand-file-name "manual/etags/ETAGS.good_3"
+ (getenv "EMACS_TEST_DIRECTORY"))
+ t)
(should (equal (should-error (xref-find-definitions "foobar123"))
'(user-error "No definitions found for: foobar123"))))
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index ce21290..82a70ca 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -224,5 +224,52 @@
(error-message-string (should-error (version-to-list
"beta22_8alpha3")))
"Invalid version syntax: `beta22_8alpha3' (must start with a
number)"))))
+(defun subr-test--backtrace-frames-with-backtrace-frame (base)
+ "Reference implementation of `backtrace-frames'."
+ (let ((idx 0)
+ (frame nil)
+ (frames nil))
+ (while (setq frame (backtrace-frame idx base))
+ (push frame frames)
+ (setq idx (1+ idx)))
+ (nreverse frames)))
+
+(defun subr-test--frames-2 (base)
+ (let ((_dummy nil))
+ (progn ;; Add a few frames to top of stack
+ (unwind-protect
+ (cons (mapcar (pcase-lambda (`(,evald ,func ,args ,_))
+ `(,evald ,func ,@args))
+ (backtrace-frames base))
+ (subr-test--backtrace-frames-with-backtrace-frame base))))))
+
+(defun subr-test--frames-1 (base)
+ (subr-test--frames-2 base))
+
+(ert-deftest subr-test-backtrace-simple-tests ()
+ "Test backtrace-related functions (simple tests).
+This exercises `backtrace-frame', and indirectly `mapbacktrace'."
+ ;; `mapbacktrace' returns nil
+ (should (equal (mapbacktrace #'ignore) nil))
+ ;; Unbound BASE is silently ignored
+ (let ((unbound (make-symbol "ub")))
+ (should (equal (backtrace-frame 0 unbound) nil))
+ (should (equal (mapbacktrace #'error unbound) nil)))
+ ;; First frame is backtrace-related function
+ (should (equal (backtrace-frame 0) '(t backtrace-frame 0)))
+ (should (equal (catch 'ret
+ (mapbacktrace (lambda (&rest args) (throw 'ret args))))
+ '(t mapbacktrace ((lambda (&rest args) (throw 'ret args)))
nil)))
+ ;; Past-end NFRAMES is silently ignored
+ (should (equal (backtrace-frame most-positive-fixnum) nil)))
+
+(ert-deftest subr-test-backtrace-integration-test ()
+ "Test backtrace-related functions (integration test).
+This exercises `backtrace-frame', `backtrace-frames', and
+indirectly `mapbacktrace'."
+ ;; Compare two implementations of backtrace-frames
+ (let ((frame-lists (subr-test--frames-1 'subr-test--frames-2)))
+ (should (equal (car frame-lists) (cdr frame-lists)))))
+
(provide 'subr-tests)
;;; subr-tests.el ends here
diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el
index 8dc72cd..b54a45d 100644
--- a/test/lisp/vc/vc-tests.el
+++ b/test/lisp/vc/vc-tests.el
@@ -206,7 +206,7 @@ For backends which dont support it, it is emulated."
;; FIXME: Why isn't there `vc-unregister'?
(defun vc-test--unregister-function (backend file)
"Run the `vc-unregister' backend function.
-For backends which don't support it, `vc-not-supported' is signalled."
+For backends which don't support it, `vc-not-supported' is signaled."
;; CVS, SVN, SCCS, SRC and Mtn are not supported, and will signal
;; `vc-not-supported'.
(prog1
diff --git a/test/src/data-tests.el b/test/src/data-tests.el
index 4c2ea54..757522e 100644
--- a/test/src/data-tests.el
+++ b/test/src/data-tests.el
@@ -256,6 +256,86 @@ comparing the subr with a much slower lisp implementation."
(v3 (bool-vector-not v1)))
(should (equal v2 v3))))
+;; Tests for variable bindings
+
+(defvar binding-test-buffer-A (get-buffer-create "A"))
+(defvar binding-test-buffer-B (get-buffer-create "B"))
+
+(defvar binding-test-always-local 'always)
+(make-variable-buffer-local 'binding-test-always-local)
+
+(defvar binding-test-some-local 'some)
+(with-current-buffer binding-test-buffer-A
+ (set (make-local-variable 'binding-test-some-local) 'local))
+
+(ert-deftest binding-test-manual ()
+ "A test case from the elisp manual."
+ (save-excursion
+ (set-buffer binding-test-buffer-A)
+ (let ((binding-test-some-local 'something-else))
+ (should (eq binding-test-some-local 'something-else))
+ (set-buffer binding-test-buffer-B)
+ (should (eq binding-test-some-local 'some)))
+ (should (eq binding-test-some-local 'some))
+ (set-buffer binding-test-buffer-A)
+ (should (eq binding-test-some-local 'local))))
+
+(ert-deftest binding-test-setq-default ()
+ "Test that a setq-default has no effect when there is a local binding."
+ (save-excursion
+ (set-buffer binding-test-buffer-B)
+ ;; This variable is not local in this buffer.
+ (let ((binding-test-some-local 'something-else))
+ (setq-default binding-test-some-local 'new-default))
+ (should (eq binding-test-some-local 'some))))
+
+(ert-deftest binding-test-makunbound ()
+ "Tests of makunbound, from the manual."
+ (save-excursion
+ (set-buffer binding-test-buffer-B)
+ (should (boundp 'binding-test-some-local))
+ (let ((binding-test-some-local 'outer))
+ (let ((binding-test-some-local 'inner))
+ (makunbound 'binding-test-some-local)
+ (should (not (boundp 'binding-test-some-local))))
+ (should (and (boundp 'binding-test-some-local)
+ (eq binding-test-some-local 'outer))))))
+
+(ert-deftest binding-test-defvar-bool ()
+ "Test DEFVAR_BOOL"
+ (let ((display-hourglass 5))
+ (should (eq display-hourglass t))))
+
+(ert-deftest binding-test-defvar-int ()
+ "Test DEFVAR_INT"
+ (should-error (setq gc-cons-threshold 5.0) :type 'wrong-type-argument))
+
+(ert-deftest binding-test-set-constant-t ()
+ "Test setting the constant t"
+ (should-error (setq t 'bob) :type 'setting-constant))
+
+(ert-deftest binding-test-set-constant-nil ()
+ "Test setting the constant nil"
+ (should-error (setq nil 'bob) :type 'setting-constant))
+
+(ert-deftest binding-test-set-constant-keyword ()
+ "Test setting a keyword constant"
+ (should-error (setq :keyword 'bob) :type 'setting-constant))
+
+(ert-deftest binding-test-set-constant-nil ()
+ "Test setting a keyword to itself"
+ (should (setq :keyword :keyword)))
+
+;; More tests to write -
+;; kill-local-variable
+;; defconst; can modify
+;; defvar and defconst modify the local binding [ doesn't matter for us ]
+;; various kinds of special internal forwarding objects
+;; a couple examples in manual, not enough
+;; variable aliases
+
+;; Tests for watchpoints
+
(ert-deftest data-tests-variable-watchers ()
(defvar data-tests-var 0)
(let* ((watch-data nil)
diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el
index 1a82d13..609f82e 100644
--- a/test/src/lread-tests.el
+++ b/test/src/lread-tests.el
@@ -104,4 +104,12 @@
(ert-deftest lread-string-char-name ()
(should (equal (read "\"a\\N{SYLOTI NAGRI LETTER DHO}b\"") "a\uA817b")))
+(ert-deftest lread-empty-int-literal ()
+ "Check that Bug#25120 is fixed."
+ (should-error (read "#b") :type 'invalid-read-syntax)
+ (should-error (read "#o") :type 'invalid-read-syntax)
+ (should-error (read "#x") :type 'invalid-read-syntax)
+ (should-error (read "#24r") :type 'invalid-read-syntax)
+ (should-error (read "#") :type 'invalid-read-syntax))
+
;;; lread-tests.el ends here
diff --git a/test/src/regex-resources/PTESTS b/test/src/regex-resources/PTESTS
index 02b357c..68acc31 100644
--- a/test/src/regex-resources/PTESTS
+++ b/test/src/regex-resources/PTESTS
@@ -1,341 +1,341 @@
# 2.8.2 Regular Expression General Requirement
-2�4�bb*�abbbc�
-2�2�bb*�ababbbc�
-7�9�A#*::�A:A#:qA::qA#::qA##::q�
-1�5�A#*::�A##::A#::qA::qA#:q�
+2¦4¦bb*¦abbbc¦
+2¦2¦bb*¦ababbbc¦
+7¦9¦A#*::¦A:A#:qA::qA#::qA##::q¦
+1¦5¦A#*::¦A##::A#::qA::qA#:q¦
# 2.8.3.1.2 BRE Special Characters
# GA108
-2�2�\.�a.c�
-2�2�\[�a[c�
-2�2�\\�a\c�
-2�2�\*�a*c�
-2�2�\^�a^c�
-2�2�\$�a$c�
-7�11�X\*Y\*8�Y*8X*8X*Y*8�
+2¦2¦\.¦a.c¦
+2¦2¦\[¦a[c¦
+2¦2¦\\¦a\c¦
+2¦2¦\*¦a*c¦
+2¦2¦\^¦a^c¦
+2¦2¦\$¦a$c¦
+7¦11¦X\*Y\*8¦Y*8X*8X*Y*8¦
# GA109
-2�2�[.]�a.c�
-2�2�[[]�a[c�
--1�-1�[[]�ac�
-2�2�[\]�a\c�
-1�1�[\a]�abc�
-2�2�[\.]�a\.c�
-2�2�[\.]�a.\c�
-2�2�[*]�a*c�
-2�2�[$]�a$c�
-2�2�[X*Y8]�7*8YX�
+2¦2¦[.]¦a.c¦
+2¦2¦[[]¦a[c¦
+-1¦-1¦[[]¦ac¦
+2¦2¦[\]¦a\c¦
+1¦1¦[\a]¦abc¦
+2¦2¦[\.]¦a\.c¦
+2¦2¦[\.]¦a.\c¦
+2¦2¦[*]¦a*c¦
+2¦2¦[$]¦a$c¦
+2¦2¦[X*Y8]¦7*8YX¦
# GA110
-2�2�*�a*c�
-3�4�*a�*b*a*c�
-1�5�**9=�***9=9�
+2¦2¦*¦a*c¦
+3¦4¦*a¦*b*a*c¦
+1¦5¦**9=¦***9=9¦
# GA111
-1�1�^*�*bc�
--1�-1�^*�a*c�
--1�-1�^*�^*ab�
-1�5�^**9=�***9=�
--1�-1�^*5<*9�5<9*5<*9�
+1¦1¦^*¦*bc¦
+-1¦-1¦^*¦a*c¦
+-1¦-1¦^*¦^*ab¦
+1¦5¦^**9=¦***9=¦
+-1¦-1¦^*5<*9¦5<9*5<*9¦
# GA112
-2�3�\(*b\)�a*b�
--1�-1�\(*b\)�ac�
-1�6�A\(**9\)=�A***9=79�
+2¦3¦\(*b\)¦a*b¦
+-1¦-1¦\(*b\)¦ac¦
+1¦6¦A\(**9\)=¦A***9=79¦
# GA113(1)
-1�3�\(^*ab\)�*ab�
--1�-1�\(^*ab\)�^*ab�
--1�-1�\(^*b\)�a*b�
--1�-1�\(^*b\)�^*b�
+1¦3¦\(^*ab\)¦*ab¦
+-1¦-1¦\(^*ab\)¦^*ab¦
+-1¦-1¦\(^*b\)¦a*b¦
+-1¦-1¦\(^*b\)¦^*b¦
### GA113(2) GNU regex implements GA113(1)
-##-1�-1�\(^*ab\)�*ab�
-##-1�-1�\(^*ab\)�^*ab�
-##1�1�\(^*b\)�b�
-##1�3�\(^*b\)�^^b�
+##-1¦-1¦\(^*ab\)¦*ab¦
+##-1¦-1¦\(^*ab\)¦^*ab¦
+##1¦1¦\(^*b\)¦b¦
+##1¦3¦\(^*b\)¦^^b¦
# GA114
-1�3�a^b�a^b�
-1�3�a\^b�a^b�
-1�1�^^�^bc�
-2�2�\^�a^c�
-1�1�[c^b]�^abc�
-1�1�[\^ab]�^ab�
-2�2�[\^ab]�c\d�
--1�-1�[^^]�^�
-1�3�\(a^b\)�a^b�
-1�3�\(a\^b\)�a^b�
-2�2�\(\^\)�a^b�
+1¦3¦a^b¦a^b¦
+1¦3¦a\^b¦a^b¦
+1¦1¦^^¦^bc¦
+2¦2¦\^¦a^c¦
+1¦1¦[c^b]¦^abc¦
+1¦1¦[\^ab]¦^ab¦
+2¦2¦[\^ab]¦c\d¦
+-1¦-1¦[^^]¦^¦
+1¦3¦\(a^b\)¦a^b¦
+1¦3¦\(a\^b\)¦a^b¦
+2¦2¦\(\^\)¦a^b¦
# GA115
-3�3�$$�ab$�
--1�-1�$$�$ab�
-2�3�$c�a$c�
-2�2�[$]�a$c�
-1�2�\$a�$a�
-3�3�\$$�ab$�
-2�6�A\([34]$[34]\)B�XA4$3BY�
+3¦3¦$$¦ab$¦
+-1¦-1¦$$¦$ab¦
+2¦3¦$c¦a$c¦
+2¦2¦[$]¦a$c¦
+1¦2¦\$a¦$a¦
+3¦3¦\$$¦ab$¦
+2¦6¦A\([34]$[34]\)B¦XA4$3BY¦
# 2.8.3.1.3 Periods in BREs
# GA116
-1�1�.�abc�
--1�-1�.ab�abc�
-1�3�ab.�abc�
-1�3�a.b�a,b�
--1�-1�.......�PqRs6�
-1�7�.......�PqRs6T8�
+1¦1¦.¦abc¦
+-1¦-1¦.ab¦abc¦
+1¦3¦ab.¦abc¦
+1¦3¦a.b¦a,b¦
+-1¦-1¦.......¦PqRs6¦
+1¦7¦.......¦PqRs6T8¦
# 2.8.3.2 RE Bracket Expression
# GA118
-2�2�[abc]�xbyz�
--1�-1�[abc]�xyz�
-2�2�[abc]�xbay�
+2¦2¦[abc]¦xbyz¦
+-1¦-1¦[abc]¦xyz¦
+2¦2¦[abc]¦xbay¦
# GA119
-2�2�[^a]�abc�
-4�4�[^]cd]�cd]ef�
-2�2�[^abc]�axyz�
--1�-1�[^abc]�abc�
-3�3�[^[.a.]b]�abc�
-3�3�[^[=a=]b]�abc�
-2�2�[^-ac]�abcde-�
-2�2�[^ac-]�abcde-�
-3�3�[^a-b]�abcde�
-3�3�[^a-bd-e]�dec�
-2�2�[^---]�-ab�
-16�16�[^a-zA-Z0-9]�pqrstVWXYZ23579#�
+2¦2¦[^a]¦abc¦
+4¦4¦[^]cd]¦cd]ef¦
+2¦2¦[^abc]¦axyz¦
+-1¦-1¦[^abc]¦abc¦
+3¦3¦[^[.a.]b]¦abc¦
+3¦3¦[^[=a=]b]¦abc¦
+2¦2¦[^-ac]¦abcde-¦
+2¦2¦[^ac-]¦abcde-¦
+3¦3¦[^a-b]¦abcde¦
+3¦3¦[^a-bd-e]¦dec¦
+2¦2¦[^---]¦-ab¦
+16¦16¦[^a-zA-Z0-9]¦pqrstVWXYZ23579#¦
# GA120(1)
-3�3�[]a]�cd]ef�
-1�1�[]-a]�a_b�
-3�3�[][.-.]-0]�ab0-]�
-1�1�[]^a-z]�string�
+3¦3¦[]a]¦cd]ef¦
+1¦1¦[]-a]¦a_b¦
+3¦3¦[][.-.]-0]¦ab0-]¦
+1¦1¦[]^a-z]¦string¦
# GA120(2)
-4�4�[^]cd]�cd]ef�
-0�0�[^]]*�]]]]]]]]X�
-0�0�[^]]*�]]]]]]]]�
-9�9�[^]]\{1,\}�]]]]]]]]X�
--1�-1�[^]]\{1,\}�]]]]]]]]�
+4¦4¦[^]cd]¦cd]ef¦
+0¦0¦[^]]*¦]]]]]]]]X¦
+0¦0¦[^]]*¦]]]]]]]]¦
+9¦9¦[^]]\{1,\}¦]]]]]]]]X¦
+-1¦-1¦[^]]\{1,\}¦]]]]]]]]¦
# GA120(3)
-3�3�[c[.].]d]�ab]cd�
-2�8�[a-z]*[[.].]][A-Z]*�Abcd]DEFg�
+3¦3¦[c[.].]d]¦ab]cd¦
+2¦8¦[a-z]*[[.].]][A-Z]*¦Abcd]DEFg¦
# GA121
-2�2�[[.a.]b]�Abc�
-1�1�[[.a.]b]�aBc�
--1�-1�[[.a.]b]�ABc�
-3�3�[^[.a.]b]�abc�
-3�3�[][.-.]-0]�ab0-]�
-3�3�[A-[.].]c]�ab]!�
+2¦2¦[[.a.]b]¦Abc¦
+1¦1¦[[.a.]b]¦aBc¦
+-1¦-1¦[[.a.]b]¦ABc¦
+3¦3¦[^[.a.]b]¦abc¦
+3¦3¦[][.-.]-0]¦ab0-]¦
+3¦3¦[A-[.].]c]¦ab]!¦
# GA122
--2�-2�[[.ch.]]�abc�
--2�-2�[[.ab.][.CD.][.EF.]]�yZabCDEFQ9�
+-2¦-2¦[[.ch.]]¦abc¦
+-2¦-2¦[[.ab.][.CD.][.EF.]]¦yZabCDEFQ9¦
# GA125
-2�2�[[=a=]b]�Abc�
-1�1�[[=a=]b]�aBc�
--1�-1�[[=a=]b]�ABc�
-3�3�[^[=a=]b]�abc�
+2¦2¦[[=a=]b]¦Abc¦
+1¦1¦[[=a=]b]¦aBc¦
+-1¦-1¦[[=a=]b]¦ABc¦
+3¦3¦[^[=a=]b]¦abc¦
# GA126
#W the expected result for [[:alnum:]]* is 2-7 which is wrong
-0�0�[[:alnum:]]*� aB28gH�
-2�7�[[:alnum:]][[:alnum:]]*� aB28gH�
+0¦0¦[[:alnum:]]*¦ aB28gH¦
+2¦7¦[[:alnum:]][[:alnum:]]*¦ aB28gH¦
#W the expected result for [^[:alnum:]]* is 2-5 which is wrong
-0�0�[^[:alnum:]]*�2 ,a�
-2�5�[^[:alnum:]][^[:alnum:]]*�2 ,a�
+0¦0¦[^[:alnum:]]*¦2 ,a¦
+2¦5¦[^[:alnum:]][^[:alnum:]]*¦2 ,a¦
#W the expected result for [[:alpha:]]* is 2-5 which is wrong
-0�0�[[:alpha:]]*� aBgH2�
-2�5�[[:alpha:]][[:alpha:]]*� aBgH2�
-1�6�[^[:alpha:]]*�2 8,a�
-1�2�[[:blank:]]*�
�
-1�8�[^[:blank:]]*�aB28gH, �
-1�2�[[:cntrl:]]*� �
-1�8�[^[:cntrl:]]*�aB2 8gh,�
+0¦0¦[[:alpha:]]*¦ aBgH2¦
+2¦5¦[[:alpha:]][[:alpha:]]*¦ aBgH2¦
+1¦6¦[^[:alpha:]]*¦2 8,a¦
+1¦2¦[[:blank:]]*¦
¦
+1¦8¦[^[:blank:]]*¦aB28gH, ¦
+1¦2¦[[:cntrl:]]*¦ ¦
+1¦8¦[^[:cntrl:]]*¦aB2 8gh,¦
#W the expected result for [[:digit:]]* is 2-3 which is wrong
-0�0�[[:digit:]]*�a28�
-2�3�[[:digit:]][[:digit:]]*�a28�
-1�8�[^[:digit:]]*�aB gH,�
-1�7�[[:graph:]]*�aB28gH, �
-1�3�[^[:graph:]]*� ,�
-1�2�[[:lower:]]*�agB�
-1�8�[^[:lower:]]*�B2 8H,a�
-1�8�[[:print:]]*�aB2 8gH, �
-1�2�[^[:print:]]*� �
+0¦0¦[[:digit:]]*¦a28¦
+2¦3¦[[:digit:]][[:digit:]]*¦a28¦
+1¦8¦[^[:digit:]]*¦aB gH,¦
+1¦7¦[[:graph:]]*¦aB28gH, ¦
+1¦3¦[^[:graph:]]*¦ ,¦
+1¦2¦[[:lower:]]*¦agB¦
+1¦8¦[^[:lower:]]*¦B2 8H,a¦
+1¦8¦[[:print:]]*¦aB2 8gH, ¦
+1¦2¦[^[:print:]]*¦ ¦
#W the expected result for [[:punct:]]* is 2-2 which is wrong
-0�0�[[:punct:]]*�a,2�
-2�3�[[:punct:]][[:punct:]]*�a,,2�
-1�9�[^[:punct:]]*�aB2 8gH�
-1�3�[[:space:]]*�
�
+0¦0¦[[:punct:]]*¦a,2¦
+2¦3¦[[:punct:]][[:punct:]]*¦a,,2¦
+1¦9¦[^[:punct:]]*¦aB2 8gH¦
+1¦3¦[[:space:]]*¦
¦
#W the expected result for [^[:space:]]* is 2-9 which is wrong
-0�0�[^[:space:]]*� aB28gH, �
-2�9�[^[:space:]][^[:space:]]*� aB28gH, �
+0¦0¦[^[:space:]]*¦ aB28gH, ¦
+2¦9¦[^[:space:]][^[:space:]]*¦ aB28gH, ¦
#W the expected result for [[:upper:]]* is 2-3 which is wrong
-0�0�[[:upper:]]*�aBH2�
-2�3�[[:upper:]][[:upper:]]*�aBH2�
-1�8�[^[:upper:]]*�a2 8g,B�
+0¦0¦[[:upper:]]*¦aBH2¦
+2¦3¦[[:upper:]][[:upper:]]*¦aBH2¦
+1¦8¦[^[:upper:]]*¦a2 8g,B¦
#W the expected result for [[:xdigit:]]* is 2-5 which is wrong
-0�0�[[:xdigit:]]*�gaB28h�
-2�5�[[:xdigit:]][[:xdigit:]]*�gaB28h�
+0¦0¦[[:xdigit:]]*¦gaB28h¦
+2¦5¦[[:xdigit:]][[:xdigit:]]*¦gaB28h¦
#W the expected result for [^[:xdigit:]]* is 2-7 which is wrong
-2�7�[^[:xdigit:]][^[:xdigit:]]*�a gH,2�
+2¦7¦[^[:xdigit:]][^[:xdigit:]]*¦a gH,2¦
# GA127
--2�-2�[b-a]�abc�
-1�1�[a-c]�bbccde�
-2�2�[a-b]�-bc�
-3�3�[a-z0-9]�AB0�
-3�3�[^a-b]�abcde�
-3�3�[^a-bd-e]�dec�
-1�1�[]-a]�a_b�
-2�2�[+--]�a,b�
-2�2�[--/]�a.b�
-2�2�[^---]�-ab�
-3�3�[][.-.]-0]�ab0-]�
-3�3�[A-[.].]c]�ab]!�
-2�6�bc[d-w]xy�abchxyz�
+-2¦-2¦[b-a]¦abc¦
+1¦1¦[a-c]¦bbccde¦
+2¦2¦[a-b]¦-bc¦
+3¦3¦[a-z0-9]¦AB0¦
+3¦3¦[^a-b]¦abcde¦
+3¦3¦[^a-bd-e]¦dec¦
+1¦1¦[]-a]¦a_b¦
+2¦2¦[+--]¦a,b¦
+2¦2¦[--/]¦a.b¦
+2¦2¦[^---]¦-ab¦
+3¦3¦[][.-.]-0]¦ab0-]¦
+3¦3¦[A-[.].]c]¦ab]!¦
+2¦6¦bc[d-w]xy¦abchxyz¦
# GA129
-1�1�[a-cd-f]�dbccde�
--1�-1�[a-ce-f]�dBCCdE�
-2�4�b[n-zA-M]Y�absY9Z�
-2�4�b[n-zA-M]Y�abGY9Z�
+1¦1¦[a-cd-f]¦dbccde¦
+-1¦-1¦[a-ce-f]¦dBCCdE¦
+2¦4¦b[n-zA-M]Y¦absY9Z¦
+2¦4¦b[n-zA-M]Y¦abGY9Z¦
# GA130
-3�3�[-xy]�ac-�
-2�4�c[-xy]D�ac-D+�
-2�2�[--/]�a.b�
-2�4�c[--/]D�ac.D+b�
-2�2�[^-ac]�abcde-�
-1�3�a[^-ac]c�abcde-�
-3�3�[xy-]�zc-�
-2�4�c[xy-]7�zc-786�
-2�2�[^ac-]�abcde-�
-2�4�a[^ac-]c�5abcde-�
-2�2�[+--]�a,b�
-2�4�a[+--]B�Xa,By�
-2�2�[^---]�-ab�
-4�6�X[^---]Y�X-YXaYXbY�
+3¦3¦[-xy]¦ac-¦
+2¦4¦c[-xy]D¦ac-D+¦
+2¦2¦[--/]¦a.b¦
+2¦4¦c[--/]D¦ac.D+b¦
+2¦2¦[^-ac]¦abcde-¦
+1¦3¦a[^-ac]c¦abcde-¦
+3¦3¦[xy-]¦zc-¦
+2¦4¦c[xy-]7¦zc-786¦
+2¦2¦[^ac-]¦abcde-¦
+2¦4¦a[^ac-]c¦5abcde-¦
+2¦2¦[+--]¦a,b¦
+2¦4¦a[+--]B¦Xa,By¦
+2¦2¦[^---]¦-ab¦
+4¦6¦X[^---]Y¦X-YXaYXbY¦
# 2.8.3.3 BREs Matching Multiple Characters
# GA131
-3�4�cd�abcdeabcde�
-1�2�ag*b�abcde�
--1�-1�[a-c][e-f]�abcdef�
-3�4�[a-c][e-f]�acbedf�
-4�8�abc*XYZ�890abXYZ#*�
-4�9�abc*XYZ�890abcXYZ#*�
-4�15�abc*XYZ�890abcccccccXYZ#*�
--1�-1�abc*XYZ�890abc*XYZ#*�
+3¦4¦cd¦abcdeabcde¦
+1¦2¦ag*b¦abcde¦
+-1¦-1¦[a-c][e-f]¦abcdef¦
+3¦4¦[a-c][e-f]¦acbedf¦
+4¦8¦abc*XYZ¦890abXYZ#*¦
+4¦9¦abc*XYZ¦890abcXYZ#*¦
+4¦15¦abc*XYZ¦890abcccccccXYZ#*¦
+-1¦-1¦abc*XYZ¦890abc*XYZ#*¦
# GA132
-2�4�\(*bc\)�a*bc�
-1�2�\(ab\)�abcde�
-1�10�\(a\(b\(c\(d\(e\(f\(g\)h\(i\(j\)\)\)\)\)\)\)\)�abcdefghijk�
-3�8�43\(2\(6\)*0\)AB�654320ABCD�
-3�9�43\(2\(7\)*0\)AB�6543270ABCD�
-3�12�43\(2\(7\)*0\)AB�6543277770ABCD�
+2¦4¦\(*bc\)¦a*bc¦
+1¦2¦\(ab\)¦abcde¦
+1¦10¦\(a\(b\(c\(d\(e\(f\(g\)h\(i\(j\)\)\)\)\)\)\)\)¦abcdefghijk¦
+3¦8¦43\(2\(6\)*0\)AB¦654320ABCD¦
+3¦9¦43\(2\(7\)*0\)AB¦6543270ABCD¦
+3¦12¦43\(2\(7\)*0\)AB¦6543277770ABCD¦
# GA133
-1�10�\(a\(b\(c\(d\(e\(f\(g\)h\(i\(j\)\)\)\)\)\)\)\)�abcdefghijk�
--1�-1�\(a\(b\(c\(d\(e\(f\(g\)h\(i\(k\)\)\)\)\)\)\)\)�abcdefghijk�
+1¦10¦\(a\(b\(c\(d\(e\(f\(g\)h\(i\(j\)\)\)\)\)\)\)\)¦abcdefghijk¦
+-1¦-1¦\(a\(b\(c\(d\(e\(f\(g\)h\(i\(k\)\)\)\)\)\)\)\)¦abcdefghijk¦
# GA134
-2�4�\(bb*\)�abbbc�
-2�2�\(bb*\)�ababbbc�
-1�6�a\(.*b\)�ababbbc�
-1�2�a\(b*\)�ababbbc�
-1�20�a\(.*b\)c�axcaxbbbcsxbbbbbbbbc�
+2¦4¦\(bb*\)¦abbbc¦
+2¦2¦\(bb*\)¦ababbbc¦
+1¦6¦a\(.*b\)¦ababbbc¦
+1¦2¦a\(b*\)¦ababbbc¦
+1¦20¦a\(.*b\)c¦axcaxbbbcsxbbbbbbbbc¦
# GA135
-1�7�\(a\(b\(c\(d\(e\)\)\)\)\)\4�abcdededede�
+1¦7¦\(a\(b\(c\(d\(e\)\)\)\)\)\4¦abcdededede¦
#W POSIX does not really specify whether a\(b\)*c\1 matches acb.
#W back references are supposed to expand to the last match, but what
#W if there never was a match as in this case?
--1�-1�a\(b\)*c\1�acb�
-1�11�\(a\(b\(c\(d\(e\(f\(g\)h\(i\(j\)\)\)\)\)\)\)\)\9�abcdefghijjk�
+-1¦-1¦a\(b\)*c\1¦acb¦
+1¦11¦\(a\(b\(c\(d\(e\(f\(g\)h\(i\(j\)\)\)\)\)\)\)\)\9¦abcdefghijjk¦
# GA136
#W These two tests have the same problem as the test in GA135. No match
#W of a subexpression, why should the back reference be usable?
#W 1 2 a\(b\)*c\1 acb
-#W 4 7 a\(b\(c\(d\(f\)*\)\)\)\4�xYzabcdePQRST
--1�-1�a\(b\)*c\1�acb�
--1�-1�a\(b\(c\(d\(f\)*\)\)\)\4�xYzabcdePQRST�
+#W 4 7 a\(b\(c\(d\(f\)*\)\)\)\4¦xYzabcdePQRST
+-1¦-1¦a\(b\)*c\1¦acb¦
+-1¦-1¦a\(b\(c\(d\(f\)*\)\)\)\4¦xYzabcdePQRST¦
# GA137
--2�-2�\(a\(b\)\)\3�foo�
--2�-2�\(a\(b\)\)\(a\(b\)\)\5�foo�
+-2¦-2¦\(a\(b\)\)\3¦foo¦
+-2¦-2¦\(a\(b\)\)\(a\(b\)\)\5¦foo¦
# GA138
-1�2�ag*b�abcde�
-1�10�a.*b�abababvbabc�
-2�5�b*c�abbbcdeabbbbbbcde�
-2�5�bbb*c�abbbcdeabbbbbbcde�
-1�5�a\(b\)*c\1�abbcbbb�
--1�-1�a\(b\)*c\1�abbdbd�
-0�0�\([a-c]*\)\1�abcacdef�
-1�6�\([a-c]*\)\1�abcabcabcd�
-1�2�a^*b�ab�
-1�5�a^*b�a^^^b�
+1¦2¦ag*b¦abcde¦
+1¦10¦a.*b¦abababvbabc¦
+2¦5¦b*c¦abbbcdeabbbbbbcde¦
+2¦5¦bbb*c¦abbbcdeabbbbbbcde¦
+1¦5¦a\(b\)*c\1¦abbcbbb¦
+-1¦-1¦a\(b\)*c\1¦abbdbd¦
+0¦0¦\([a-c]*\)\1¦abcacdef¦
+1¦6¦\([a-c]*\)\1¦abcabcabcd¦
+1¦2¦a^*b¦ab¦
+1¦5¦a^*b¦a^^^b¦
# GA139
-1�2�a\{2\}�aaaa�
-1�7�\([a-c]*\)\{0,\}�aabcaab�
-1�2�\(a\)\1\{1,2\}�aabc�
-1�3�\(a\)\1\{1,2\}�aaaabc�
+1¦2¦a\{2\}¦aaaa¦
+1¦7¦\([a-c]*\)\{0,\}¦aabcaab¦
+1¦2¦\(a\)\1\{1,2\}¦aabc¦
+1¦3¦\(a\)\1\{1,2\}¦aaaabc¦
#W the expression \(\(a\)\1\)\{1,2\} is ill-formed, using \2
-1�4�\(\(a\)\2\)\{1,2\}�aaaabc�
+1¦4¦\(\(a\)\2\)\{1,2\}¦aaaabc¦
# GA140
-1�2�a\{2\}�aaaa�
--1�-1�a\{2\}�abcd�
-0�0�a\{0\}�aaaa�
-1�64�a\{64\}�aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa�
+1¦2¦a\{2\}¦aaaa¦
+-1¦-1¦a\{2\}¦abcd¦
+0¦0¦a\{0\}¦aaaa¦
+1¦64¦a\{64\}¦aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa¦
# GA141
-1�7�\([a-c]*\)\{0,\}�aabcaab�
+1¦7¦\([a-c]*\)\{0,\}¦aabcaab¦
#W the expected result for \([a-c]*\)\{2,\} is failure which isn't correct
-1�3�\([a-c]*\)\{2,\}�abcdefg�
-1�3�\([a-c]*\)\{1,\}�abcdefg�
--1�-1�a\{64,\}�aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa�
+1¦3¦\([a-c]*\)\{2,\}¦abcdefg¦
+1¦3¦\([a-c]*\)\{1,\}¦abcdefg¦
+-1¦-1¦a\{64,\}¦aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa¦
# GA142
-1�3�a\{2,3\}�aaaa�
--1�-1�a\{2,3\}�abcd�
-0�0�\([a-c]*\)\{0,0\}�foo�
-1�63�a\{1,63\}�aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa�
+1¦3¦a\{2,3\}¦aaaa¦
+-1¦-1¦a\{2,3\}¦abcd¦
+0¦0¦\([a-c]*\)\{0,0\}¦foo¦
+1¦63¦a\{1,63\}¦aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa¦
# 2.8.3.4 BRE Precedence
# GA143
#W There are numerous bugs in the original version.
-2�19�\^\[[[.].]]\\(\\1\\)\*\\{1,2\\}\$�a^[]\(\1\)*\{1,2\}$b�
-1�6�[[=*=]][[=\=]][[=]=]][[===]][[...]][[:punct:]]�*\]=.;�
-1�6�[$\(*\)^]*�$\()*^�
-1�1�[\1]�1�
-1�1�[\{1,2\}]�{�
+2¦19¦\^\[[[.].]]\\(\\1\\)\*\\{1,2\\}\$¦a^[]\(\1\)*\{1,2\}$b¦
+1¦6¦[[=*=]][[=\=]][[=]=]][[===]][[...]][[:punct:]]¦*\]=.;¦
+1¦6¦[$\(*\)^]*¦$\()*^¦
+1¦1¦[\1]¦1¦
+1¦1¦[\{1,2\}]¦{¦
#W the expected result for \(*\)*\1* is 2-2 which isn't correct
-0�0�\(*\)*\1*�a*b*11�
-2�3�\(*\)*\1*b�a*b*11�
+0¦0¦\(*\)*\1*¦a*b*11¦
+2¦3¦\(*\)*\1*b¦a*b*11¦
#W the expected result for \(a\(b\{1,2\}\)\{1,2\}\) is 1-5 which isn't correct
-1�3�\(a\(b\{1,2\}\)\{1,2\}\)�abbab�
-1�5�\(a\(b\{1,2\}\)\)\{1,2\}�abbab�
-1�1�^\(^\(^a$\)$\)$�a�
-1�2�\(a\)\1$�aa�
-1�3�ab*�abb�
-1�4�ab\{2,4\}�abbbc�
+1¦3¦\(a\(b\{1,2\}\)\{1,2\}\)¦abbab¦
+1¦5¦\(a\(b\{1,2\}\)\)\{1,2\}¦abbab¦
+1¦1¦^\(^\(^a$\)$\)$¦a¦
+1¦2¦\(a\)\1$¦aa¦
+1¦3¦ab*¦abb¦
+1¦4¦ab\{2,4\}¦abbbc¦
# 2.8.3.5 BRE Expression Anchoring
# GA144
-1�1�^a�abc�
--1�-1�^b�abc�
--1�-1�^[a-zA-Z]�99Nine�
-1�4�^[a-zA-Z]*�Nine99�
+1¦1¦^a¦abc¦
+-1¦-1¦^b¦abc¦
+-1¦-1¦^[a-zA-Z]¦99Nine¦
+1¦4¦^[a-zA-Z]*¦Nine99¦
# GA145(1)
-1�2�\(^a\)\1�aabc�
--1�-1�\(^a\)\1�^a^abc�
-1�2�\(^^a\)�^a�
-1�1�\(^^\)�^^�
-1�3�\(^abc\)�abcdef�
--1�-1�\(^def\)�abcdef�
+1¦2¦\(^a\)\1¦aabc¦
+-1¦-1¦\(^a\)\1¦^a^abc¦
+1¦2¦\(^^a\)¦^a¦
+1¦1¦\(^^\)¦^^¦
+1¦3¦\(^abc\)¦abcdef¦
+-1¦-1¦\(^def\)¦abcdef¦
### GA145(2) GNU regex implements GA145(1)
-##-1�-1�\(^a\)\1�aabc�
-##1�4�\(^a\)\1�^a^abc�
-##-1�-1�\(^^a\)�^a�
-##1�2�\(^^\)�^^�
+##-1¦-1¦\(^a\)\1¦aabc¦
+##1¦4¦\(^a\)\1¦^a^abc¦
+##-1¦-1¦\(^^a\)¦^a¦
+##1¦2¦\(^^\)¦^^¦
# GA146
-3�3�a$�cba�
--1�-1�a$�abc�
-5�7�[a-z]*$�99ZZxyz�
+3¦3¦a$¦cba¦
+-1¦-1¦a$¦abc¦
+5¦7¦[a-z]*$¦99ZZxyz¦
#W the expected result for [a-z]*$ is failure which isn't correct
-10�9�[a-z]*$�99ZZxyz99�
-3�3�$$�ab$�
--1�-1�$$�$ab�
-3�3�\$$�ab$�
+10¦9¦[a-z]*$¦99ZZxyz99¦
+3¦3¦$$¦ab$¦
+-1¦-1¦$$¦$ab¦
+3¦3¦\$$¦ab$¦
# GA147(1)
--1�-1�\(a$\)\1�bcaa�
--1�-1�\(a$\)\1�ba$�
--1�-1�\(ab$\)�ab$�
-1�2�\(ab$\)�ab�
-4�6�\(def$\)�abcdef�
--1�-1�\(abc$\)�abcdef�
+-1¦-1¦\(a$\)\1¦bcaa¦
+-1¦-1¦\(a$\)\1¦ba$¦
+-1¦-1¦\(ab$\)¦ab$¦
+1¦2¦\(ab$\)¦ab¦
+4¦6¦\(def$\)¦abcdef¦
+-1¦-1¦\(abc$\)¦abcdef¦
### GA147(2) GNU regex implements GA147(1)
-##-1�-1�\(a$\)\1�bcaa�
-##2�5�\(a$\)\1�ba$a$�
-##-1�-1�\(ab$\)�ab�
-##1�3�\(ab$\)�ab$�
+##-1¦-1¦\(a$\)\1¦bcaa¦
+##2¦5¦\(a$\)\1¦ba$a$¦
+##-1¦-1¦\(ab$\)¦ab¦
+##1¦3¦\(ab$\)¦ab$¦
# GA148
-0�0�^$��
-1�3�^abc$�abc�
--1�-1�^xyz$�^xyz^�
--1�-1�^234$�^234$�
-1�9�^[a-zA-Z0-9]*$�2aA3bB9zZ�
--1�-1�^[a-z0-9]*$�2aA3b#B9zZ�
+0¦0¦^$¦¦
+1¦3¦^abc$¦abc¦
+-1¦-1¦^xyz$¦^xyz^¦
+-1¦-1¦^234$¦^234$¦
+1¦9¦^[a-zA-Z0-9]*$¦2aA3bB9zZ¦
+-1¦-1¦^[a-z0-9]*$¦2aA3b#B9zZ¦
diff --git a/test/src/thread-tests.el b/test/src/thread-tests.el
new file mode 100644
index 0000000..73da72e
--- /dev/null
+++ b/test/src/thread-tests.el
@@ -0,0 +1,247 @@
+;;; threads.el --- tests for threads.
+
+;; Copyright (C) 2012-2016 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 <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(ert-deftest threads-is-one ()
+ "test for existence of a thread"
+ (should (current-thread)))
+
+(ert-deftest threads-threadp ()
+ "test of threadp"
+ (should (threadp (current-thread))))
+
+(ert-deftest threads-type ()
+ "test of thread type"
+ (should (eq (type-of (current-thread)) 'thread)))
+
+(ert-deftest threads-name ()
+ "test for name of a thread"
+ (should
+ (string= "hi bob" (thread-name (make-thread #'ignore "hi bob")))))
+
+(ert-deftest threads-alive ()
+ "test for thread liveness"
+ (should
+ (thread-alive-p (make-thread #'ignore))))
+
+(ert-deftest threads-all-threads ()
+ "simple test for all-threads"
+ (should (listp (all-threads))))
+
+(defvar threads-test-global nil)
+
+(defun threads-test-thread1 ()
+ (setq threads-test-global 23))
+
+(ert-deftest threads-basic ()
+ "basic thread test"
+ (should
+ (progn
+ (setq threads-test-global nil)
+ (make-thread #'threads-test-thread1)
+ (while (not threads-test-global)
+ (thread-yield))
+ threads-test-global)))
+
+(ert-deftest threads-join ()
+ "test of thread-join"
+ (should
+ (progn
+ (setq threads-test-global nil)
+ (let ((thread (make-thread #'threads-test-thread1)))
+ (thread-join thread)
+ (and threads-test-global
+ (not (thread-alive-p thread)))))))
+
+(ert-deftest threads-join-self ()
+ "cannot thread-join the current thread"
+ (should-error (thread-join (current-thread))))
+
+(defvar threads-test-binding nil)
+
+(defun threads-test-thread2 ()
+ (let ((threads-test-binding 23))
+ (thread-yield))
+ (setq threads-test-global 23))
+
+(ert-deftest threads-let-binding ()
+ "simple test of threads and let bindings"
+ (should
+ (progn
+ (setq threads-test-global nil)
+ (make-thread #'threads-test-thread2)
+ (while (not threads-test-global)
+ (thread-yield))
+ (and (not threads-test-binding)
+ threads-test-global))))
+
+(ert-deftest threads-mutexp ()
+ "simple test of mutexp"
+ (should-not (mutexp 'hi)))
+
+(ert-deftest threads-mutexp-2 ()
+ "another simple test of mutexp"
+ (should (mutexp (make-mutex))))
+
+(ert-deftest threads-mutex-type ()
+ "type-of mutex"
+ (should (eq (type-of (make-mutex)) 'mutex)))
+
+(ert-deftest threads-mutex-lock-unlock ()
+ "test mutex-lock and unlock"
+ (should
+ (let ((mx (make-mutex)))
+ (mutex-lock mx)
+ (mutex-unlock mx)
+ t)))
+
+(ert-deftest threads-mutex-recursive ()
+ "test mutex-lock and unlock"
+ (should
+ (let ((mx (make-mutex)))
+ (mutex-lock mx)
+ (mutex-lock mx)
+ (mutex-unlock mx)
+ (mutex-unlock mx)
+ t)))
+
+(defvar threads-mutex nil)
+(defvar threads-mutex-key nil)
+
+(defun threads-test-mlock ()
+ (mutex-lock threads-mutex)
+ (setq threads-mutex-key 23)
+ (while threads-mutex-key
+ (thread-yield))
+ (mutex-unlock threads-mutex))
+
+(ert-deftest threads-mutex-contention ()
+ "test of mutex contention"
+ (should
+ (progn
+ (setq threads-mutex (make-mutex))
+ (setq threads-mutex-key nil)
+ (make-thread #'threads-test-mlock)
+ ;; Wait for other thread to get the lock.
+ (while (not threads-mutex-key)
+ (thread-yield))
+ ;; Try now.
+ (setq threads-mutex-key nil)
+ (mutex-lock threads-mutex)
+ (mutex-unlock threads-mutex)
+ t)))
+
+(defun threads-test-mlock2 ()
+ (setq threads-mutex-key 23)
+ (mutex-lock threads-mutex))
+
+(ert-deftest threads-mutex-signal ()
+ "test signaling a blocked thread"
+ (should
+ (progn
+ (setq threads-mutex (make-mutex))
+ (setq threads-mutex-key nil)
+ (mutex-lock threads-mutex)
+ (let ((thr (make-thread #'threads-test-mlock2)))
+ (while (not threads-mutex-key)
+ (thread-yield))
+ (thread-signal thr 'quit nil)
+ (thread-join thr))
+ t)))
+
+(defun threads-test-io-switch ()
+ (setq threads-test-global 23))
+
+(ert-deftest threads-io-switch ()
+ "test that accept-process-output causes thread switch"
+ (should
+ (progn
+ (setq threads-test-global nil)
+ (make-thread #'threads-test-io-switch)
+ (while (not threads-test-global)
+ (accept-process-output nil 1))
+ threads-test-global)))
+
+(ert-deftest threads-condvarp ()
+ "simple test of condition-variable-p"
+ (should-not (condition-variable-p 'hi)))
+
+(ert-deftest threads-condvarp-2 ()
+ "another simple test of condition-variable-p"
+ (should (condition-variable-p (make-condition-variable (make-mutex)))))
+
+(ert-deftest threads-condvar-type ()
+ "type-of condvar"
+ (should (eq (type-of (make-condition-variable (make-mutex)))
+ 'condition-variable)))
+
+(ert-deftest threads-condvar-mutex ()
+ "simple test of condition-mutex"
+ (should
+ (let ((m (make-mutex)))
+ (eq m (condition-mutex (make-condition-variable m))))))
+
+(ert-deftest threads-condvar-name ()
+ "simple test of condition-name"
+ (should
+ (eq nil (condition-name (make-condition-variable (make-mutex))))))
+
+(ert-deftest threads-condvar-name-2 ()
+ "another simple test of condition-name"
+ (should
+ (string= "hi bob"
+ (condition-name (make-condition-variable (make-mutex)
+ "hi bob")))))
+(defun call-error ()
+ "Call `error'."
+ (error "Error is called"))
+
+;; This signals an error internally; the error should be caught.
+(defun thread-custom ()
+ (defcustom thread-custom-face 'highlight
+ "Face used for thread customizations."
+ :type 'face
+ :group 'widget-faces))
+
+(ert-deftest thread-errors ()
+ "Test what happens when a thread signals an error."
+ (should (threadp (make-thread #'call-error "call-error")))
+ (should (threadp (make-thread #'thread-custom "thread-custom"))))
+
+(ert-deftest thread-sticky-point ()
+ "Test bug #25165 with point movement in cloned buffer."
+ (with-temp-buffer
+ (insert "Lorem ipsum dolor sit amet, consectetur adipiscing elit.")
+ (goto-char (point-min))
+ (clone-indirect-buffer nil nil)
+ (forward-char 20)
+ (sit-for 1)
+ (should (= (point) 21))))
+
+(ert-deftest thread-signal-early ()
+ "Test signaling a thread as soon as it is started by the OS."
+ (let ((thread
+ (make-thread #'(lambda ()
+ (while t (thread-yield))))))
+ (thread-signal thread 'error nil)
+ (sit-for 1)
+ (should-not (thread-alive-p thread))))
+
+;;; threads.el ends here