[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] xwidget 0298a2c: merge master
|
From: |
Joakim Verona |
|
Subject: |
[Emacs-diffs] xwidget 0298a2c: merge master |
|
Date: |
Thu, 15 Jan 2015 15:19:40 +0000 |
branch: xwidget
commit 0298a2c6a10bc3b79cb2f45a1961dd7ac6da4e6d
Merge: a1124bc 0e97c44
Author: Joakim Verona <address@hidden>
Commit: Joakim Verona <address@hidden>
merge master
---
admin/ChangeLog | 7 +
admin/unidata/Makefile.in | 7 +-
etc/NEWS | 2 +
lib-src/ChangeLog | 17 +
lib-src/make-docfile.c | 135 +++++--
lisp/ChangeLog | 124 ++++++-
lisp/Makefile.in | 30 +-
lisp/emacs-lisp/cl-generic.el | 607 +++++++++++++++++++++++++++++
lisp/emacs-lisp/cl-macs.el | 52 ++-
lisp/emacs-lisp/eieio-core.el | 28 ++-
lisp/files.el | 5 +-
lisp/frame.el | 58 ++--
lisp/menu-bar.el | 3 +-
lisp/net/eww.el | 38 +-
lisp/progmodes/cc-bytecomp.el | 72 +++-
lisp/progmodes/cc-defs.el | 43 ++-
lisp/progmodes/cc-langs.el | 5 +-
lisp/progmodes/xref.el | 1 +
src/.gdbinit | 21 +-
src/ChangeLog | 233 +++++++++++
src/Makefile.in | 9 +-
src/buffer.c | 161 +++++----
src/callint.c | 3 +-
src/callproc.c | 23 +-
src/character.c | 6 +-
src/coding.c | 2 +-
src/data.c | 42 ++-
src/decompress.c | 3 +-
src/dired.c | 29 +-
src/dispnew.c | 3 +-
src/editfns.c | 88 +++--
src/emacs.c | 3 +-
src/eval.c | 3 +-
src/fileio.c | 13 +-
src/fns.c | 3 +-
src/frame.c | 111 ++++--
src/frame.h | 6 +
src/gnutls.c | 6 +-
src/gtkutil.c | 2 +-
src/image.c | 3 +-
src/keyboard.c | 17 +-
src/lisp.h | 31 +-
src/nsfns.m | 6 +-
src/process.c | 19 +-
src/process.h | 2 +
src/search.c | 31 +--
src/w32fns.c | 55 ++-
src/w32heap.c | 2 +-
src/w32menu.c | 49 ++-
src/w32proc.c | 11 +-
src/w32term.h | 4 +-
src/window.c | 5 +-
src/xdisp.c | 16 +-
src/xfaces.c | 3 +-
src/xfns.c | 13 +-
src/xmenu.c | 119 +++----
src/xml.c | 29 +-
src/xrdb.c | 2 +-
src/xsettings.c | 2 +-
src/xterm.c | 8 +-
src/xterm.h | 2 +-
test/ChangeLog | 11 +
test/automated/cl-generic-tests.el | 133 +++++++
test/automated/eieio-test-methodinvoke.el | 72 ++--
64 files changed, 2040 insertions(+), 609 deletions(-)
diff --git a/admin/ChangeLog b/admin/ChangeLog
index dc029a0..2b04281 100644
--- a/admin/ChangeLog
+++ b/admin/ChangeLog
@@ -1,3 +1,10 @@
+2015-01-12 Paul Eggert <address@hidden>
+
+ Say "ELC foo.elc" instead of "GEN foo.elc"
+ * unidata/Makefile.in (AM_V_ELC, am__v_ELC_, am__v_ELC_0)
+ (am__v_ELC_1): New macros.
+ (%.elc): Use them.
+
2015-01-08 Glenn Morris <address@hidden>
* authors.el (authors-aliases): Add an entry to ignore.
diff --git a/admin/unidata/Makefile.in b/admin/unidata/Makefile.in
index 777d127..1396f09 100644
--- a/admin/unidata/Makefile.in
+++ b/admin/unidata/Makefile.in
@@ -34,6 +34,11 @@ emacs = "${EMACS}" -batch --no-site-file --no-site-lisp
# 'make' verbosity.
AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@
+AM_V_ELC = $(address@hidden@)
+am__v_ELC_ = $(address@hidden@)
+am__v_ELC_0 = @echo " ELC " $@;
+am__v_ELC_1 =
+
AM_V_GEN = $(address@hidden@)
am__v_GEN_ = $(address@hidden@)
am__v_GEN_0 = @echo " GEN " $@;
@@ -58,7 +63,7 @@ ${top_srcdir}/src/macuvs.h: ${srcdir}/uvs.el
${srcdir}/IVD_Sequences.txt | \
> $@
%.elc: %.el
- $(AM_V_GEN)${emacs} -f batch-byte-compile $<
+ $(AM_V_ELC)${emacs} -f batch-byte-compile $<
unidata.txt: ${srcdir}/UnicodeData.txt
$(AM_V_GEN)sed -e 's/\([^;]*\);\(.*\)/(#x\1 "\2")/' -e 's/;/" "/g' \
diff --git a/etc/NEWS b/etc/NEWS
index b3267e1..f291c0c 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -480,6 +480,8 @@ As a result of the above, these commands are now obsolete:
* New Modes and Packages in Emacs 25.1
+** cl-generic.el provides CLOS-style multiple-dispatch generic functions.
+
** scss-mode (a minor variant of css-mode)
** let-alist is a new macro (and a package) that allows one to easily
diff --git a/lib-src/ChangeLog b/lib-src/ChangeLog
index 7403596..e9205fd 100644
--- a/lib-src/ChangeLog
+++ b/lib-src/ChangeLog
@@ -1,3 +1,20 @@
+2015-01-13 Paul Eggert <address@hidden>
+
+ Don't say Fnext_read_file_uses_dialog_p is const
+ * make-docfile.c (write_globals):
+ Add a special hack for Fnext_read_file_uses_dialog_p.
+
+2015-01-13 Dmitry Antipov <address@hidden>
+
+ Support DEFUN attributes.
+ * make-docfile.c (struct global): New field 'flags'.
+ (DEFUN_noreturn, DEFUN_const): New enum bitfields.
+ (add_global): Now return pointer to global.
+ (write_globals): Add _Noreturn and ATTRIBUTE_CONST attributes
+ if requested by global's flags.
+ (stream_match): New function.
+ (scan_c_stream): Recognize 'attributes:' of DEFUN.
+
2015-01-10 Paul Eggert <address@hidden>
Port to 32-bit --with-wide-int
diff --git a/lib-src/make-docfile.c b/lib-src/make-docfile.c
index bc5420e..741fa4b 100644
--- a/lib-src/make-docfile.c
+++ b/lib-src/make-docfile.c
@@ -562,6 +562,7 @@ struct global
{
enum global_type type;
char *name;
+ int flags;
union
{
int value;
@@ -569,13 +570,16 @@ struct global
} v;
};
+/* Bit values for FLAGS field from the above. Applied for DEFUNs only. */
+enum { DEFUN_noreturn = 1, DEFUN_const = 2 };
+
/* All the variable names we saw while scanning C sources in `-g'
mode. */
int num_globals;
int num_globals_allocated;
struct global *globals;
-static void
+static struct global *
add_global (enum global_type type, char *name, int value, char const *svalue)
{
/* Ignore the one non-symbol that can occur. */
@@ -601,7 +605,10 @@ add_global (enum global_type type, char *name, int value,
char const *svalue)
globals[num_globals - 1].v.svalue = svalue;
else
globals[num_globals - 1].v.value = value;
+ globals[num_globals - 1].flags = 0;
+ return globals + num_globals - 1;
}
+ return NULL;
}
static int
@@ -708,13 +715,7 @@ write_globals (void)
globals[i].name, globals[i].name, globals[i].name);
else
{
- /* It would be nice to have a cleaner way to deal with these
- special hacks. */
- if (strcmp (globals[i].name, "Fthrow") == 0
- || strcmp (globals[i].name, "Ftop_level") == 0
- || strcmp (globals[i].name, "Fkill_emacs") == 0
- || strcmp (globals[i].name, "Fexit_recursive_edit") == 0
- || strcmp (globals[i].name, "Fabort_recursive_edit") == 0)
+ if (globals[i].flags & DEFUN_noreturn)
fputs ("_Noreturn ", stdout);
printf ("EXFUN (%s, ", globals[i].name);
@@ -726,37 +727,20 @@ write_globals (void)
printf ("%d", globals[i].v.value);
putchar (')');
- /* It would be nice to have a cleaner way to deal with these
- special hacks, too. */
- if (strcmp (globals[i].name, "Fatom") == 0
- || strcmp (globals[i].name, "Fbyteorder") == 0
- || strcmp (globals[i].name, "Fcharacterp") == 0
- || strcmp (globals[i].name, "Fchar_or_string_p") == 0
- || strcmp (globals[i].name, "Fconsp") == 0
- || strcmp (globals[i].name, "Feq") == 0
- || strcmp (globals[i].name, "Fface_attribute_relative_p") == 0
- || strcmp (globals[i].name, "Fframe_windows_min_size") == 0
- || strcmp (globals[i].name, "Fgnutls_errorp") == 0
- || strcmp (globals[i].name, "Fidentity") == 0
- || strcmp (globals[i].name, "Fintegerp") == 0
- || strcmp (globals[i].name, "Finteractive") == 0
- || strcmp (globals[i].name, "Ffloatp") == 0
- || strcmp (globals[i].name, "Flistp") == 0
- || strcmp (globals[i].name, "Fmax_char") == 0
- || strcmp (globals[i].name, "Fnatnump") == 0
- || strcmp (globals[i].name, "Fnlistp") == 0
- || strcmp (globals[i].name, "Fnull") == 0
- || strcmp (globals[i].name, "Fnumberp") == 0
- || strcmp (globals[i].name, "Fstringp") == 0
- || strcmp (globals[i].name, "Fsymbolp") == 0
- || strcmp (globals[i].name, "Ftool_bar_height") == 0
- || strcmp (globals[i].name, "Fwindow__sanitize_window_sizes") == 0
-#ifndef WINDOWSNT
- || strcmp (globals[i].name, "Fgnutls_available_p") == 0
- || strcmp (globals[i].name, "Fzlib_available_p") == 0
-#endif
- || 0)
+ if (globals[i].flags & DEFUN_const)
fputs (" ATTRIBUTE_CONST", stdout);
+ else if (strcmp (globals[i].name, "Fnext_read_file_uses_dialog_p")
+ == 0)
+ {
+ /* It would be nice to have a cleaner way to deal with this
+ special hack. */
+ fputs (("\n"
+ "#if ! (defined USE_GTK || defined USE_MOTIF \\\n"
+ " || defined HAVE_NS || defined HAVE_NTGUI)\n"
+ "\tATTRIBUTE_CONST\n"
+ "#endif\n"),
+ stdout);
+ }
puts (";");
}
@@ -817,6 +801,23 @@ scan_c_file (char *filename, const char *mode)
return scan_c_stream (infile);
}
+/* Return 1 if next input from INFILE is equal to P, -1 if EOF,
+ 0 if input doesn't match. */
+
+static int
+stream_match (FILE *infile, const char *p)
+{
+ for (; *p; p++)
+ {
+ int c = getc (infile);
+ if (c == EOF)
+ return -1;
+ if (c != *p)
+ return 0;
+ }
+ return 1;
+}
+
static int
scan_c_stream (FILE *infile)
{
@@ -1033,7 +1034,63 @@ scan_c_stream (FILE *infile)
if (generate_globals)
{
- add_global (FUNCTION, name, maxargs, 0);
+ struct global *g = add_global (FUNCTION, name, maxargs, 0);
+
+ /* The following code tries to recognize function attributes
+ specified after the docstring, e.g.:
+
+ DEFUN ("foo", Ffoo, Sfoo, X, Y, Z,
+ doc: /\* doc *\/
+ attributes: attribute1 attribute2 ...)
+ (Lisp_Object arg...)
+
+ Now only 'noreturn' and 'const' attributes are used. */
+
+ /* Advance to the end of docstring. */
+ c = getc (infile);
+ if (c == EOF)
+ goto eof;
+ int d = getc (infile);
+ if (d == EOF)
+ goto eof;
+ while (1)
+ {
+ if (c == '*' && d == '/')
+ break;
+ c = d, d = getc (infile);
+ if (d == EOF)
+ goto eof;
+ }
+ /* Skip spaces, if any. */
+ do
+ {
+ c = getc (infile);
+ if (c == EOF)
+ goto eof;
+ }
+ while (c == ' ' || c == '\n' || c == '\r' || c == '\t');
+ /* Check for 'attributes:' token. */
+ if (c == 'a' && stream_match (infile, "ttributes:"))
+ {
+ char *p = input_buffer;
+ /* Collect attributes up to ')'. */
+ while (1)
+ {
+ c = getc (infile);
+ if (c == EOF)
+ goto eof;
+ if (c == ')')
+ break;
+ if (p - input_buffer > sizeof (input_buffer))
+ abort ();
+ *p++ = c;
+ }
+ *p = 0;
+ if (strstr (input_buffer, "noreturn"))
+ g->flags |= DEFUN_noreturn;
+ if (strstr (input_buffer, "const"))
+ g->flags |= DEFUN_const;
+ }
continue;
}
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 674b267..b7a38af 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,107 @@
+2015-01-15 Stefan Monnier <address@hidden>
+
+ * emacs-lisp/eieio-core.el: Provide support for cl-generic.
+ (eieio--generic-tagcode): New function.
+ (cl-generic-tagcode-function): Use it.
+ (eieio--generic-tag-types): New function.
+ (cl-generic-tag-types-function): Use it.
+ (eieio-object-p): Tighten up the test.
+
+ * emacs-lisp/cl-generic.el (cl-generic-define-method): Fix paren typo.
+
+2015-01-14 Stefan Monnier <address@hidden>
+
+ * emacs-lisp/cl-generic.el: New file.
+
+ * emacs-lisp/cl-macs.el (cl-flet): Allow (FUN EXP) forms.
+ (cl-load-time-value, cl-labels): Use closures rather than
+ backquoted lambdas.
+ (cl-macrolet): Use `eval' to create the function value, and support CL
+ style arguments in for the defined macros.
+
+2015-01-14 Stefan Monnier <address@hidden>
+
+ * net/eww.el: Use lexical-binding.
+ (eww-links-at-point): Remove unused arg.
+ (eww-mode-map): Inherit from special-mode-map.
+ (eww-mode): Derive from special-mode. Don't use `setq' on a hook.
+
+2015-01-13 Alan Mackenzie <address@hidden>
+
+ Allow compilation during loading of Modes derived from a CC Mode mode.
+ Fixes debbugs#19206.
+
+ * progmodes/cc-bytecomp.el (cc-bytecomp-compiling-or-loading):
+ New function which walks the stack to discover whether we're compiling
+ or loading.
+ (cc-bytecomp-is-compiling): Reformulate, and move towards
+ beginning.
+ (cc-bytecomp-is-loading): New defsubst.
+ (cc-bytecomp-setup-environment, cc-bytecomp-restore-environment):
+ Use the above defsubsts.
+ (cc-require-when-compile, cc-bytecomp-defvar)
+ (cc-bytecomp-defun): Simplify conditionals.
+
+ * progmodes/cc-defs.el (cc-bytecomp-compiling-or-loading):
+ "Borrow" this function from cc-bytecomp.el.
+ (c-get-current-file): Reformulate using the above.
+ (c-lang-defconst): Prevent duplicate entries of file names in a
+ symbol's 'source property.
+ (c-lang-const): Use cc-bytecomp-is-compiling.
+
+ * progmodes/cc-langs.el (c-make-init-lang-vars-fun):
+ Use cc-bytecomp-is-compiling.
+
+2015-01-13 Stefan Monnier <address@hidden>
+
+ * emacs-lisp/eieio-core.el (eieio-defclass): Fix call to `defclass'
+ (bug#19552).
+
+2015-01-13 Dmitry Gutov <address@hidden>
+
+ * menu-bar.el (menu-bar-goto-menu): Before calling
+ `xref-marker-stack-empty-p', first check that `xref' is loaded.
+ (Bug#19554)
+
+2015-01-12 Martin Rudalics <address@hidden>
+
+ * progmodes/xref.el (xref-marker-stack-empty-p): Add autoload
+ cookie (Bug#19554).
+
+ * frame.el (frame-notice-user-settings): Remove code dealing with
+ frame-initial-frame-tool-bar-height. Turn off `tool-bar-mode'
+ only if `window-system-frame-alist' or `default-frame-alist' ask
+ for it.
+ (make-frame): Update frame-adjust-size-history if needed.
+
+2015-01-12 Paul Eggert <address@hidden>
+
+ Have 'make' output better GEN names
+ * Makefile.in (PHONY_EXTRAS): New macro.
+ (.PHONY): Depend on it, and on $(lisp)/loaddefs.el, so that the
+ relevant files' time stamps are ignored.
+ (custom-deps, $(lisp)/cus-load.el, finder-data)
+ ($(lisp)/finder-inf.el): Use PHONY_EXTRAS.
+ (custom-deps, $(lisp)/cus-load.el, finder-data)
+ ($(lisp)/finder-inf.el, autoloads, $(lisp)/loaddefs.el)
+ ($(lisp)/subdirs.el, update-subdirs):
+ Output more-accurate destination names with GEN.
+
+ Say "ELC foo.elc" instead of "GEN foo.elc"
+ * Makefile.in (AM_V_ELC, am__v_ELC_, am__v_ELC_0, am__v_ELC_1):
+ New macros.
+ ($(THEFILE)c, .el.elc): Use them.
+
+2015-01-11 Michael Albinus <address@hidden>
+
+ * files.el (directory-files-recursively): Do not include
+ superfluous remote file names.
+
+2015-01-11 Lars Magne Ingebrigtsen <address@hidden>
+
+ * net/eww.el (eww): Interpret anything that looks like a protocol
+ designator as a full URL.
+
2015-01-10 Lars Magne Ingebrigtsen <address@hidden>
* net/shr.el (shr-urlify): Don't bother the user about
@@ -363,8 +467,8 @@
to `pre-command-hook'.
(xref--xref-buffer-mode-map): Don't remap `next-line' and
`previous-line'. Additionally bind `xref-next-line' and
- `xref-prev-line' to `n' and `p' respectively. Bind
- `xref-show-location-at-point' to `C-o'.
+ `xref-prev-line' to `n' and `p' respectively.
+ Bind `xref-show-location-at-point' to `C-o'.
2015-01-01 Eli Zaretskii <address@hidden>
@@ -553,15 +657,15 @@
Add argument MSG to display user-friendly message when no process
is running.
(python-shell-switch-to-shell): Call pop-to-buffer with NORECORD.
- (python-shell-make-comint): Rename argument SHOW from POP. Use
- display-buffer instead of pop-to-buffer.
+ (python-shell-make-comint): Rename argument SHOW from POP.
+ Use display-buffer instead of pop-to-buffer.
(run-python): Doc fix. Return process.
(python-shell-get-or-create-process): Make obsolete.
2014-12-27 Fabián Ezequiel Gallina <address@hidden>
- * progmodes/python.el (python-shell-buffer-substring): Handle
- cornercase when region sent starts at point-min.
+ * progmodes/python.el (python-shell-buffer-substring):
+ Handle cornercase when region sent starts at point-min.
2014-12-27 Eli Zaretskii <address@hidden>
@@ -733,8 +837,8 @@
2014-12-25 Filipp Gunbin <address@hidden>
- * dired-aux.el (dired-maybe-insert-subdir): Make
- dired-maybe-insert-subdir always skip trivial files.
+ * dired-aux.el (dired-maybe-insert-subdir):
+ Make dired-maybe-insert-subdir always skip trivial files.
2014-12-25 Helmut Eller <address@hidden>
Dmitry Gutov <address@hidden>
@@ -779,8 +883,8 @@
* window.el (mouse-autoselect-window-position-1): New variable.
(mouse-autoselect-window-cancel)
- (mouse-autoselect-window-select, handle-select-window): With
- delayed autoselection select window only if mouse moves after
+ (mouse-autoselect-window-select, handle-select-window):
+ With delayed autoselection select window only if mouse moves after
selecting its frame.
2014-12-24 Michael Albinus <address@hidden>
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index 565ca77..7bf5386 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -31,6 +31,11 @@ XARGS_LIMIT = @XARGS_LIMIT@
# 'make' verbosity.
AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@
+AM_V_ELC = $(address@hidden@)
+am__v_ELC_ = $(address@hidden@)
+am__v_ELC_0 = @echo " ELC " $@;
+am__v_ELC_1 =
+
AM_V_GEN = $(address@hidden@)
am__v_GEN_ = $(address@hidden@)
am__v_GEN_0 = @echo " GEN " $@;
@@ -145,7 +150,8 @@ setwins_for_subdirs=for file in `find ${srcdir} -type d
-print`; do \
# we add them here to make sure they get built.
all: compile-main $(lisp)/cus-load.el $(lisp)/finder-inf.el
-.PHONY: all custom-deps finder-data autoloads update-subdirs
+PHONY_EXTRAS =
+.PHONY: all custom-deps finder-data autoloads update-subdirs $(PHONY_EXTRAS)
# custom-deps and finder-data both used to scan _all_ the *.el files.
# This could lead to problems in parallel builds if automatically
@@ -161,18 +167,19 @@ all: compile-main $(lisp)/cus-load.el
$(lisp)/finder-inf.el
# Nowadays these commands don't scan automatically generated files,
# since they will never contain any useful information
# (see finder-no-scan-regexp and custom-dependencies-no-scan-regexp).
-$(lisp)/cus-load.el:
- $(MAKE) custom-deps
custom-deps:
+ $(AM_V_at)$(MAKE) PHONY_EXTRAS=$(lisp)/cus-load.el $(lisp)/cus-load.el
+$(lisp)/cus-load.el:
$(AM_V_GEN)$(setwins_almost); \
echo Directories: $$wins; \
$(emacs) -l cus-dep \
--eval '(setq generated-custom-dependencies-file (unmsys--file-name
"$(srcdir)/cus-load.el"))' \
-f custom-make-dependencies $$wins
-$(lisp)/finder-inf.el:
- $(MAKE) finder-data
finder-data:
+ $(AM_V_at)$(MAKE) PHONY_EXTRAS=$(lisp)/finder-inf.el \
+ $(lisp)/finder-inf.el
+$(lisp)/finder-inf.el:
$(AM_V_GEN)$(setwins_finder); \
echo Directories: $$wins; \
$(emacs) -l finder \
@@ -185,21 +192,22 @@ finder-data:
# Note that we set no-update-autoloads in _generated_ leim files.
# If you want to allow autoloads in such files, remove that,
# and make this depend on leim.
-autoloads: $(LOADDEFS)
+autoloads .PHONY: $(lisp)/loaddefs.el
+$(lisp)/loaddefs.el: $(LOADDEFS)
$(AM_V_GEN)$(setwins_almost); \
echo Directories: $$wins; \
$(emacs) -l autoload \
--eval '(setq autoload-ensure-writable t)' \
--eval '(setq autoload-builtin-package-versions t)' \
- --eval '(setq generated-autoload-file (expand-file-name
(unmsys--file-name "$(srcdir)/loaddefs.el")))' \
+ --eval '(setq generated-autoload-file (expand-file-name
(unmsys--file-name "$@")))' \
-f batch-update-autoloads $$wins
# This is required by the bootstrap-emacs target in ../src/Makefile, so
# we know that if we have an emacs executable, we also have a subdirs.el.
$(lisp)/subdirs.el:
- $(MAKE) update-subdirs
+ $(AM_V_GEN)$(MAKE) update-subdirs
update-subdirs:
- $(AM_V_GEN)$(setwins_for_subdirs); \
+ $(AM_V_at)$(setwins_for_subdirs); \
for file in $$wins; do \
$(srcdir)/../build-aux/update-subdirs $$file; \
done;
@@ -260,7 +268,7 @@ TAGS: $(lisptagsfiles1) $(lisptagsfiles2) $(lisptagsfiles3)
$(lisptagsfiles4)
THEFILE = no-such-file
.PHONY: $(THEFILE)c
$(THEFILE)c:
- $(AM_V_GEN)$(emacs) $(BYTE_COMPILE_FLAGS) \
+ $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \
-l bytecomp -f byte-compile-refresh-preloaded \
-f batch-byte-compile $(THEFILE)
@@ -276,7 +284,7 @@ $(THEFILE)c:
# An old-fashioned suffix rule, which, according to the GNU Make manual,
# cannot have prerequisites.
.el.elc:
- $(AM_V_GEN)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $<
+ $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $<
.PHONY: compile-first compile-main compile compile-always
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
new file mode 100644
index 0000000..41a419a
--- /dev/null
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -0,0 +1,607 @@
+;;; cl-generic.el --- CLOS-style generic functions for Elisp -*-
lexical-binding: t; -*-
+
+;; Copyright (C) 2015 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <address@hidden>
+
+;; 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 implements the most of CLOS's multiple-dispatch generic functions.
+;; To use it you need either (require 'cl-generic) or (require 'cl-lib).
+;; The main entry points are: `cl-defgeneric' and `cl-defmethod'.
+
+;; Missing elements:
+;; - We don't support next-method-p, make-method, call-method,
+;; define-method-combination.
+;; - Method and generic function objects: CLOS defines methods as objects
+;; (same for generic functions), whereas we don't offer such an abstraction.
+;; - `no-next-method' should receive the "calling method" object, but since we
+;; don't have such a thing, we pass nil instead.
+;; - In defgeneric we don't support the options:
+;; declare, :method-combination, :generic-function-class, :method-class,
+;; :method.
+;; Added elements:
+;; - We support aliases to generic functions.
+;; - The kind of thing on which to dispatch can be extended.
+;; There is support in this file for (eql <val>) dispatch as well as dispatch
+;; on the type of CL structs, and eieio-core.el adds support for EIEIO
+;; defclass objects.
+
+;;; Code:
+
+;; Note: For generic functions that dispatch on several arguments (i.e. those
+;; which use the multiple-dispatch feature), we always use the same "tagcodes"
+;; and the same set of arguments on which to dispatch. This works, but is
+;; often suboptimal since after one dispatch, the remaining dispatches can
+;; usually be simplified, or even completely skipped.
+
+(eval-when-compile (require 'cl-lib))
+(eval-when-compile (require 'pcase))
+
+(defvar cl-generic-tagcode-function
+ (lambda (type _name)
+ (if (eq type t) '(0 . 'cl--generic-type)
+ (error "Unknown specializer %S" type)))
+ "Function to get the Elisp code to extract the tag on which we dispatch.
+Takes a \"parameter-specializer-name\" and a variable name, and returns
+a pair (PRIORITY . CODE) where CODE is an Elisp expression that should be
+used to extract the \"tag\" (from the object held in the named variable)
+that should uniquely determine if we have a match
+\(i.e. the \"tag\" is the value that will be used to dispatch to the proper
+method(s)).
+Such \"tagcodes\" will be or'd together.
+PRIORITY is an integer from 0 to 100 which is used to sort the tagcodes
+in the `or'. The higher the priority, the more specific the tag should be.
+More specifically, if PRIORITY is N and we have two objects X and Y
+whose tag (according to TAGCODE) is `eql', then it should be the case
+that for all other (PRIORITY . TAGCODE) where PRIORITY ≤ N, then
+\(eval TAGCODE) for X is `eql' to (eval TAGCODE) for Y.")
+
+(defvar cl-generic-tag-types-function
+ (lambda (tag) (if (eq tag 'cl--generic-type) '(t)))
+ "Function to get the list of types that a given \"tag\" matches.
+They should be sorted from most specific to least specific.")
+
+(cl-defstruct (cl--generic
+ (:constructor nil)
+ (:constructor cl--generic-make
+ (name &optional dispatches method-table))
+ (:predicate nil))
+ (name nil :read-only t) ;Pointer back to the symbol.
+ ;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index
+ ;; of the corresponding argument and TAGCODES is a list of (PRIORITY . EXP)
+ ;; where the EXPs are expressions (to be `or'd together) to compute the tag
+ ;; on which to dispatch and PRIORITY is the priority of each expression to
+ ;; decide in which order to sort them.
+ ;; The most important dispatch is last in the list (and the least is first).
+ dispatches
+ ;; `method-table' is a list of
+ ;; ((SPECIALIZERS . QUALIFIER) USES-CNM . FUNCTION), where
+ ;; USES-CNM is a boolean indicating if FUNCTION calls `cl-call-next-method'
+ ;; (and hence expects an extra argument holding the next-method).
+ method-table)
+
+(defmacro cl--generic (name)
+ `(get ,name 'cl--generic))
+
+(defun cl-generic-ensure-function (name)
+ (let (generic
+ (origname name))
+ (while (and (null (setq generic (cl--generic name)))
+ (fboundp name)
+ (symbolp (symbol-function name)))
+ (setq name (symbol-function name)))
+ (unless (or (not (fboundp name))
+ (and (functionp name) generic))
+ (error "%s is already defined as something else than a generic function"
+ origname))
+ (if generic
+ (cl-assert (eq name (cl--generic-name generic)))
+ (setf (cl--generic name) (setq generic (cl--generic-make name)))
+ (defalias name (cl--generic-make-function generic)))
+ generic))
+
+(defun cl--generic-setf-rewrite (name)
+ (let ((setter (intern (format "cl-generic-setter--%s" name))))
+ (cons setter
+ `(eval-and-compile
+ (unless (eq ',setter (get ',name 'cl-generic-setter))
+ ;; (when (get ',name 'gv-expander)
+ ;; (error "gv-expander conflicts with (setf %S)" ',name))
+ (setf (get ',name 'cl-generic-setter) ',setter)
+ (gv-define-setter ,name (val &rest args)
+ (cons ',setter (cons val args))))))))
+
+;;;###autoload
+(defmacro cl-defgeneric (name args &rest options-and-methods)
+ "Create a generic function NAME.
+DOC-STRING is the base documentation for this class. A generic
+function has no body, as its purpose is to decide which method body
+is appropriate to use. Specific methods are defined with `defmethod'.
+With this implementation the ARGS are currently ignored.
+OPTIONS-AND-METHODS is currently only used to specify the docstring,
+via (:documentation DOCSTRING)."
+ (declare (indent 2) (doc-string 3))
+ (let* ((docprop (assq :documentation options-and-methods))
+ (doc (cond ((stringp (car-safe options-and-methods))
+ (pop options-and-methods))
+ (docprop
+ (prog1
+ (cadr docprop)
+ (setq options-and-methods
+ (delq docprop options-and-methods)))))))
+ `(progn
+ ,(when (eq 'setf (car-safe name))
+ (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite
+ (cadr name))))
+ (setq name setter)
+ code))
+ (defalias ',name
+ (cl-generic-define ',name ',args ',options-and-methods)
+ ,doc))))
+
+(defun cl--generic-mandatory-args (args)
+ (let ((res ()))
+ (while (not (memq (car args) '(nil &rest &optional &key)))
+ (push (pop args) res))
+ (nreverse res)))
+
+;;;###autoload
+(defun cl-generic-define (name args options-and-methods)
+ (let ((generic (cl-generic-ensure-function name))
+ (mandatory (cl--generic-mandatory-args args))
+ (apo (assq :argument-precedence-order options-and-methods)))
+ (setf (cl--generic-dispatches generic) nil)
+ (when apo
+ (dolist (arg (cdr apo))
+ (let ((pos (memq arg mandatory)))
+ (unless pos (error "%S is not a mandatory argument" arg))
+ (push (list (- (length mandatory) (length pos)))
+ (cl--generic-dispatches generic)))))
+ (setf (cl--generic-method-table generic) nil)
+ (cl--generic-make-function generic)))
+
+(defvar cl-generic-current-method-specializers nil
+ ;; This is let-bound during macro-expansion of method bodies, so that those
+ ;; bodies can be optimized knowing that the specializers have matched.
+ ;; FIXME: This presumes the formal arguments aren't modified via `setq' and
+ ;; aren't shadowed either ;-(
+ ;; FIXME: This might leak outside the scope of the method if, during
+ ;; macroexpansion of the method, something causes some other macroexpansion
+ ;; (e.g. an autoload).
+ "List of (VAR . TYPE) where TYPE is var's specializer.")
+
+(eval-and-compile ;Needed while compiling the cl-defmethod calls below!
+ (defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el.
+ "Check which of the symbols VARS appear in SEXP."
+ (let ((res '()))
+ (while (consp sexp)
+ (dolist (var (cl--generic-fgrep vars (pop sexp)))
+ (unless (memq var res) (push var res))))
+ (and (memq sexp vars) (not (memq sexp res)) (push sexp res))
+ res))
+
+ (defun cl--generic-lambda (args body with-cnm)
+ "Make the lambda expression for a method with ARGS and BODY."
+ (let ((plain-args ())
+ (cl-generic-current-method-specializers nil)
+ (doc-string (if (stringp (car-safe body)) (pop body)))
+ (mandatory t))
+ (dolist (arg args)
+ (push (pcase arg
+ ((or '&optional '&rest '&key) (setq mandatory nil) arg)
+ ((and `(,name . ,type) (guard mandatory))
+ (push (cons name (car type))
+ cl-generic-current-method-specializers)
+ name)
+ (_ arg))
+ plain-args))
+ (setq plain-args (nreverse plain-args))
+ (let ((fun `(cl-function (lambda ,plain-args
+ ,@(if doc-string (list doc-string))
+ ,@body))))
+ (if (not with-cnm)
+ (cons nil fun)
+ ;; First macroexpand away the cl-function stuff (e.g. &key and
+ ;; destructuring args, `declare' and whatnot).
+ (pcase (macroexpand fun macroexpand-all-environment)
+ (`#'(lambda ,args . ,body)
+ (require 'cl-lib) ;Needed to expand `cl-flet'.
+ (let* ((doc-string (and doc-string (stringp (car body))
+ (pop body)))
+ (cnm (make-symbol "cl--cnm"))
+ (nbody (macroexpand-all
+ `(cl-flet ((cl-call-next-method ,cnm))
+ ,@body)
+ macroexpand-all-environment))
+ ;; FIXME: Rather than `grep' after the fact, the
+ ;; macroexpansion should directly set some flag when cnm
+ ;; is used.
+ ;; FIXME: Also, optimize the case where call-next-method is
+ ;; only called with explicit arguments.
+ (uses-cnm (cl--generic-fgrep (list cnm) nbody)))
+ (cons (not (not uses-cnm))
+ `#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
+ ,@(if doc-string (list doc-string))
+ ,nbody))))
+ (f (error "Unexpected macroexpansion result: %S" f))))))))
+
+
+;;;###autoload
+(defmacro cl-defmethod (name args &rest body)
+ "Define a new method for generic function NAME.
+I.e. it defines the implementation of NAME to use for invocations where the
+value of the dispatch argument matches the specified TYPE.
+The dispatch argument has to be one of the mandatory arguments, and
+all methods of NAME have to use the same argument for dispatch.
+The dispatch argument and TYPE are specified in ARGS where the corresponding
+formal argument appears as (VAR TYPE) rather than just VAR.
+
+The optional second argument QUALIFIER is a specifier that
+modifies how the method is combined with other methods, including:
+ :before - Method will be called before the primary
+ :after - Method will be called after the primary
+ :around - Method will be called around everything else
+The absence of QUALIFIER means this is a \"primary\" method.
+
+Other than a type, TYPE can also be of the form `(eql VAL)' in
+which case this method will be invoked when the argument is `eql' to VAL.
+
+\(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)"
+ (declare (doc-string 3) (indent 2))
+ (let ((qualifiers nil))
+ (while (keywordp args)
+ (push args qualifiers)
+ (setq args (pop body)))
+ (pcase-let* ((with-cnm (not (memq (car qualifiers) '(:before :after))))
+ (`(,uses-cnm . ,fun) (cl--generic-lambda args body with-cnm)))
+ `(progn
+ ,(when (eq 'setf (car-safe name))
+ (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite
+ (cadr name))))
+ (setq name setter)
+ code))
+ (cl-generic-define-method ',name ',qualifiers ',args
+ ,uses-cnm ,fun)))))
+
+;;;###autoload
+(defun cl-generic-define-method (name qualifiers args uses-cnm function)
+ (when (> (length qualifiers) 1)
+ (error "We only support a single qualifier per method: %S" qualifiers))
+ (unless (memq (car qualifiers) '(nil :primary :around :after :before))
+ (error "Unsupported qualifier in: %S" qualifiers))
+ (let* ((generic (cl-generic-ensure-function name))
+ (mandatory (cl--generic-mandatory-args args))
+ (specializers
+ (mapcar (lambda (arg) (if (consp arg) (cadr arg) t)) mandatory))
+ (key (cons specializers (or (car qualifiers) ':primary)))
+ (mt (cl--generic-method-table generic))
+ (me (assoc key mt))
+ (dispatches (cl--generic-dispatches generic))
+ (i 0))
+ (dolist (specializer specializers)
+ (let* ((tagcode (funcall cl-generic-tagcode-function specializer 'arg))
+ (x (assq i dispatches)))
+ (if (not x)
+ (setf (cl--generic-dispatches generic)
+ (setq dispatches (cons (list i tagcode) dispatches)))
+ (unless (member tagcode (cdr x))
+ (setf (cdr x)
+ (nreverse (sort (cons tagcode (cdr x))
+ #'car-less-than-car)))))
+ (setq i (1+ i))))
+ (if me (setcdr me (cons uses-cnm function))
+ (setf (cl--generic-method-table generic)
+ (cons `(,key ,uses-cnm . ,function) mt)))
+ ;; For aliases, cl--generic-name gives us the actual name.
+ (defalias (cl--generic-name generic)
+ (cl--generic-make-function generic))))
+
+(defmacro cl--generic-with-memoization (place &rest code)
+ (declare (indent 1) (debug t))
+ (gv-letplace (getter setter) place
+ `(or ,getter
+ ,(macroexp-let2 nil val (macroexp-progn code)
+ `(progn
+ ,(funcall setter val)
+ ,val)))))
+
+(defvar cl--generic-dispatchers (make-hash-table :test #'equal))
+
+(defun cl--generic-get-dispatcher (tagcodes dispatch-arg)
+ (cl--generic-with-memoization
+ (gethash (cons dispatch-arg tagcodes) cl--generic-dispatchers)
+ (let ((lexical-binding t)
+ (extraargs ()))
+ (dotimes (_ dispatch-arg)
+ (push (make-symbol "arg") extraargs))
+ (byte-compile
+ `(lambda (generic dispatches-left)
+ (let ((method-cache (make-hash-table :test #'eql)))
+ (lambda (,@extraargs arg &rest args)
+ (apply (cl--generic-with-memoization
+ (gethash (or ,@(mapcar #'cdr tagcodes)) method-cache)
+ (cl--generic-cache-miss
+ generic ',dispatch-arg dispatches-left
+ (list ,@(mapcar #'cdr tagcodes))))
+ ,@extraargs arg args))))))))
+
+(defun cl--generic-make-function (generic)
+ (let* ((dispatches (cl--generic-dispatches generic))
+ (dispatch
+ (progn
+ (while (and dispatches
+ (member (cdar dispatches)
+ '(nil ((0 . 'cl--generic-type)))))
+ (setq dispatches (cdr dispatches)))
+ (pop dispatches))))
+ (if (null dispatch)
+ (cl--generic-build-combined-method
+ (cl--generic-name generic)
+ (cl--generic-method-table generic))
+ (let ((dispatcher (cl--generic-get-dispatcher
+ (cdr dispatch) (car dispatch))))
+ (funcall dispatcher generic dispatches)))))
+
+(defun cl--generic-nest (fun methods)
+ (pcase-dolist (`(,uses-cnm . ,method) methods)
+ (setq fun
+ (if (not uses-cnm) method
+ (let ((next fun))
+ (lambda (&rest args)
+ (apply method
+ ;; FIXME: This sucks: passing just `next' would
+ ;; be a lot more efficient than the lambda+apply
+ ;; quasi-η, but we need this to implement the
+ ;; "if call-next-method is called with no
+ ;; arguments, then use the previous arguments".
+ (lambda (&rest cnm-args)
+ (apply next (or cnm-args args)))
+ args))))))
+ fun)
+
+(defvar cl--generic-combined-method-memoization
+ (make-hash-table :test #'equal :weakness 'value)
+ "Table storing previously built combined-methods.
+This is particularly useful when many different tags select the same set
+of methods, since this table then allows us to share a single combined-method
+for all those different tags in the method-cache.")
+
+(defun cl--generic-build-combined-method (generic-name methods)
+ (let ((mets-by-qual ()))
+ (dolist (qm methods)
+ (push (cdr qm) (alist-get (cdar qm) mets-by-qual)))
+ (cl--generic-with-memoization
+ (gethash (cons generic-name mets-by-qual)
+ cl--generic-combined-method-memoization)
+ (cond
+ ((null mets-by-qual) (lambda (&rest args)
+ (cl-no-applicable-method generic-name args)))
+ (t
+ (let* ((fun (lambda (&rest args)
+ ;; FIXME: CLOS passes as second arg the "calling method".
+ ;; We don't currently have "method objects" like CLOS
+ ;; does so we can't really do it the CLOS way.
+ ;; The closest would be to pass the lambda corresponding
+ ;; to the method, but the caller wouldn't be able to do
+ ;; much with it anyway. So we pass nil for now.
+ (apply #'cl-no-next-method generic-name nil args)))
+ ;; We use `cdr' to drop the `uses-cnm' annotations.
+ (before
+ (mapcar #'cdr (reverse (alist-get :before mets-by-qual))))
+ (after (mapcar #'cdr (alist-get :after mets-by-qual))))
+ (setq fun (cl--generic-nest fun (alist-get :primary mets-by-qual)))
+ (when (or after before)
+ (let ((next fun))
+ (setq fun (lambda (&rest args)
+ (dolist (bf before)
+ (apply bf args))
+ (apply next args)
+ (dolist (af after)
+ (apply af args))))))
+ (cl--generic-nest fun (alist-get :around mets-by-qual))))))))
+
+(defun cl--generic-cache-miss (generic dispatch-arg dispatches-left tags)
+ (let ((types (apply #'append (mapcar cl-generic-tag-types-function tags)))
+ (methods '()))
+ (dolist (method-desc (cl--generic-method-table generic))
+ (let ((m (member (nth dispatch-arg (caar method-desc)) types)))
+ (when m
+ (push (cons (length m) method-desc) methods))))
+ ;; Sort the methods, most specific first.
+ ;; It would be tempting to sort them once and for all in the method-table
+ ;; rather than here, but the order might depend on the actual argument
+ ;; (e.g. for multiple inheritance with defclass).
+ (setq methods (nreverse (mapcar #'cdr (sort methods #'car-less-than-car))))
+ (cl--generic-make-function (cl--generic-make (cl--generic-name generic)
+ dispatches-left methods))))
+
+;;; Define some pre-defined generic functions, used internally.
+
+(define-error 'cl-no-method "No method for %S")
+(define-error 'cl-no-next-method "No next method for %S" 'cl-no-method)
+(define-error 'cl-no-applicable-method "No applicable method for %S"
+ 'cl-no-method)
+
+(cl-defgeneric cl-no-next-method (generic method &rest args)
+ "Function called when `cl-call-next-method' finds no next method.")
+(cl-defmethod cl-no-next-method ((generic t) method &rest args)
+ (signal 'cl-no-next-method `(,generic ,method ,@args)))
+
+(cl-defgeneric cl-no-applicable-method (generic &rest args)
+ "Function called when a method call finds no applicable method.")
+(cl-defmethod cl-no-applicable-method ((generic t) &rest args)
+ (signal 'cl-no-applicable-method `(,generic ,@args)))
+
+(defun cl-call-next-method (&rest _args)
+ "Function to call the next applicable method.
+Can only be used from within the lexical body of a primary or around method."
+ (error "cl-call-next-method only allowed inside primary and around methods"))
+
+;;; Add support for describe-function
+
+(add-hook 'help-fns-describe-function-functions 'cl--generic-describe)
+(defun cl--generic-describe (function)
+ ;; FIXME: Fix up the main "in `<file>'" hyperlink, and add such hyperlinks
+ ;; for each method.
+ (let ((generic (if (symbolp function) (cl--generic function))))
+ (when generic
+ (save-excursion
+ (insert "\n\nThis is a generic function.\n\n")
+ (insert (propertize "Implementations:\n\n" 'face 'bold))
+ ;; Loop over fanciful generics
+ (pcase-dolist (`((,type . ,qualifier) . ,method)
+ (cl--generic-method-table generic))
+ (insert "`")
+ (if (symbolp type)
+ ;; FIXME: Add support for cl-structs in help-variable.
+ (help-insert-xref-button (symbol-name type)
+ 'help-variable type)
+ (insert (format "%S" type)))
+ (insert (format "' %S %S\n"
+ (car qualifier)
+ (let ((args (help-function-arglist method)))
+ ;; Drop cl--generic-next arg if present.
+ (if (memq (car qualifier) '(:after :before))
+ args (cdr args)))))
+ (insert (or (documentation method) "Undocumented") "\n\n"))))))
+
+;;; Support for (eql <val>) specializers.
+
+(defvar cl--generic-eql-used (make-hash-table :test #'eql))
+
+(add-function :before-until cl-generic-tagcode-function
+ #'cl--generic-eql-tagcode)
+(defun cl--generic-eql-tagcode (type name)
+ (when (eq (car-safe type) 'eql)
+ (puthash (cadr type) type cl--generic-eql-used)
+ `(100 . (gethash ,name cl--generic-eql-used))))
+
+(add-function :before-until cl-generic-tag-types-function
+ #'cl--generic-eql-tag-types)
+(defun cl--generic-eql-tag-types (tag)
+ (if (eq (car-safe tag) 'eql) (list tag)))
+
+;;; Support for cl-defstructs specializers.
+
+(add-function :before-until cl-generic-tagcode-function
+ #'cl--generic-struct-tagcode)
+(defun cl--generic-struct-tagcode (type name)
+ (and (symbolp type)
+ (get type 'cl-struct-type)
+ (or (eq 'vector (car (get type 'cl-struct-type)))
+ (error "Can't dispatch on cl-struct %S: type is %S"
+ type (car (get type 'cl-struct-type))))
+ (or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots)))
+ (error "Can't dispatch on cl-struct %S: no tag in slot 0"
+ type))
+ ;; We could/should check the vector has length >0,
+ ;; but really, mixing vectors and structs is a bad idea,
+ ;; so let's not waste time trying to handle the case
+ ;; of an empty vector.
+ ;; BEWARE: this returns a bogus tag for non-struct vectors.
+ `(50 . (and (vectorp ,name) (aref ,name 0)))))
+
+(add-function :before-until cl-generic-tag-types-function
+ #'cl--generic-struct-tag-types)
+(defun cl--generic-struct-tag-types (tag)
+ ;; FIXME: cl-defstruct doesn't make it easy for us.
+ (and (symbolp tag)
+ ;; A method call shouldn't itself mess with the match-data.
+ (string-match-p "\\`cl-struct-\\(.*\\)" (symbol-name tag))
+ (let ((types (list (intern (substring (symbol-name tag) 10)))))
+ (while (get (car types) 'cl-struct-include)
+ (push (get (car types) 'cl-struct-include) types))
+ (push 'cl-struct types) ;The "parent type" of all cl-structs.
+ (nreverse types))))
+
+;;; Dispatch on "old-style types".
+
+(defconst cl--generic-typeof-types
+ ;; Hand made from the source code of `type-of'.
+ '((integer number) (symbol) (string array) (cons list)
+ ;; Markers aren't `numberp', yet they are accepted wherever integers are
+ ;; accepted, pretty much.
+ (marker) (overlay) (float number) (window-configuration)
+ (process) (window) (subr) (compiled-function) (buffer) (char-table array)
+ (bool-vector array)
+ (frame) (hash-table) (font-spec) (font-entity) (font-object)
+ (vector array)
+ ;; Plus, hand made:
+ (null list symbol)
+ (list)
+ (array)
+ (number)))
+
+(add-function :before-until cl-generic-tagcode-function
+ #'cl--generic-typeof-tagcode)
+(defun cl--generic-typeof-tagcode (type name)
+ ;; FIXME: Add support for other types accepted by `cl-typep' such
+ ;; as `character', `atom', `face', `function', ...
+ (and (assq type cl--generic-typeof-types)
+ (progn
+ (if (memq type '(vector array))
+ (message "`%S' also matches CL structs and EIEIO classes" type))
+ ;; FIXME: We could also change `type-of' to return `null' for nil.
+ `(10 . (if ,name (type-of ,name) 'null)))))
+
+(add-function :before-until cl-generic-tag-types-function
+ #'cl--generic-typeof-types)
+(defun cl--generic-typeof-types (tag)
+ (and (symbolp tag)
+ (assq tag cl--generic-typeof-types)))
+
+;;; Just for kicks: dispatch on major-mode
+;;
+;; Here's how you'd use it:
+;; (cl-defmethod foo ((x (major-mode text-mode)) y z) ...)
+;; And then
+;; (foo 'major-mode toto titi)
+;;
+;; FIXME: Better would be to do that via dispatch on an "implicit argument".
+
+;; (defvar cl--generic-major-modes (make-hash-table :test #'eq))
+;;
+;; (add-function :before-until cl-generic-tagcode-function
+;; #'cl--generic-major-mode-tagcode)
+;; (defun cl--generic-major-mode-tagcode (type name)
+;; (if (eq 'major-mode (car-safe type))
+;; `(50 . (if (eq ,name 'major-mode)
+;; (cl--generic-with-memoization
+;; (gethash major-mode cl--generic-major-modes)
+;; `(cl--generic-major-mode . ,major-mode))))))
+;;
+;; (add-function :before-until cl-generic-tag-types-function
+;; #'cl--generic-major-mode-types)
+;; (defun cl--generic-major-mode-types (tag)
+;; (when (eq (car-safe tag) 'cl--generic-major-mode)
+;; (if (eq tag 'fundamental-mode) '(fundamental-mode t)
+;; (let ((types `((major-mode ,(cdr tag)))))
+;; (while (get (car types) 'derived-mode-parent)
+;; (push (list 'major-mode (get (car types) 'derived-mode-parent))
+;; types))
+;; (unless (eq 'fundamental-mode (car types))
+;; (push '(major-mode fundamental-mode) types))
+;; (nreverse types)))))
+
+;; Local variables:
+;; generated-autoload-file: "cl-loaddefs.el"
+;; End:
+
+(provide 'cl-generic)
+;;; cl-generic.el ends here
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index fff5b27..0070599 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -625,14 +625,20 @@ The result of the body appears to the compiler as a
quoted constant."
(set `(setq ,temp ,form)))
(if (and (fboundp 'byte-compile-file-form-defmumble)
(boundp 'this-kind) (boundp 'that-one))
- (fset 'byte-compile-file-form
- `(lambda (form)
- (fset 'byte-compile-file-form
- ',(symbol-function 'byte-compile-file-form))
- (byte-compile-file-form ',set)
- (byte-compile-file-form form)))
- (print set (symbol-value 'byte-compile--outbuffer)))
- `(symbol-value ',temp))
+ ;; Else, we can't output right away, so we have to delay it to the
+ ;; next time we're at the top-level.
+ ;; FIXME: Use advice-add/remove.
+ (fset 'byte-compile-file-form
+ (let ((old (symbol-function 'byte-compile-file-form)))
+ (lambda (form)
+ (fset 'byte-compile-file-form old)
+ (byte-compile-file-form set)
+ (byte-compile-file-form form))))
+ ;; If we're not in the middle of compiling something, we can
+ ;; output directly to byte-compile-outbuffer, to make sure
+ ;; temp is set before we use it.
+ (print set byte-compile--outbuffer))
+ temp)
`',(eval form)))
@@ -1824,18 +1830,30 @@ a `let' form, except that the list of symbols can be
computed at run-time."
(defmacro cl-flet (bindings &rest body)
"Make local function definitions.
Like `cl-labels' but the definitions are not recursive.
+Each binding can take the form (FUNC EXP) where
+FUNC is the function name, and EXP is an expression that returns the
+function value to which it should be bound, or it can take the more common
+form \(FUNC ARGLIST BODY...) which is a shorthand
+for (FUNC (lambda ARGLIST BODY)).
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(declare (indent 1) (debug ((&rest (cl-defun)) cl-declarations body)))
(let ((binds ()) (newenv macroexpand-all-environment))
(dolist (binding bindings)
- (let ((var (make-symbol (format "--cl-%s--" (car binding)))))
- (push (list var `(cl-function (lambda . ,(cdr binding)))) binds)
+ (let ((var (make-symbol (format "--cl-%s--" (car binding))))
+ (args-and-body (cdr binding)))
+ (if (and (= (length args-and-body) 1) (symbolp (car args-and-body)))
+ ;; Optimize (cl-flet ((fun var)) body).
+ (setq var (car args-and-body))
+ (push (list var (if (= (length args-and-body) 1)
+ (car args-and-body)
+ `(cl-function (lambda . ,args-and-body))))
+ binds))
(push (cons (car binding)
- `(lambda (&rest cl-labels-args)
- (cl-list* 'funcall ',var
- cl-labels-args)))
+ (lambda (&rest cl-labels-args)
+ (cl-list* 'funcall var cl-labels-args)))
newenv)))
+ ;; FIXME: Eliminate those functions which aren't referenced.
`(let ,(nreverse binds)
,@(macroexp-unprogn
(macroexpand-all
@@ -1869,9 +1887,8 @@ in closures will only work if `lexical-binding' is in use.
(let ((var (make-symbol (format "--cl-%s--" (car binding)))))
(push (list var `(cl-function (lambda . ,(cdr binding)))) binds)
(push (cons (car binding)
- `(lambda (&rest cl-labels-args)
- (cl-list* 'funcall ',var
- cl-labels-args)))
+ (lambda (&rest cl-labels-args)
+ (cl-list* 'funcall var cl-labels-args)))
newenv)))
(macroexpand-all `(letrec ,(nreverse binds) ,@body)
;; Don't override lexical-let's macro-expander.
@@ -1898,7 +1915,8 @@ This is like `cl-flet', but for macros instead of
functions.
(res (cl--transform-lambda (cdar bindings) name)))
(eval (car res))
(macroexpand-all (macroexp-progn body)
- (cons (cons name `(lambda ,@(cdr res)))
+ (cons (cons name
+ (eval `(cl-function (lambda ,@(cdr res)))
t))
macroexpand-all-environment))))))
(defconst cl--old-macroexpand
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index dc2c873..bfa922b 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -264,7 +264,7 @@ Return nil if that option doesn't exist."
(defsubst eieio-object-p (obj)
"Return non-nil if OBJ is an EIEIO object."
- (and (arrayp obj)
+ (and (vectorp obj)
(condition-case nil
(eq (aref (eieio--object-class-object obj) 0) 'defclass)
(error nil))))
@@ -1303,11 +1303,35 @@ method invocation orders of the involved classes."
(define-error 'unbound-slot "Unbound slot")
(define-error 'inconsistent-class-hierarchy "Inconsistent class hierarchy")
+;;; Hooking into cl-generic.
+
+(require 'cl-generic)
+
+(add-function :before-until cl-generic-tagcode-function
+ #'eieio--generic-tagcode)
+(defun eieio--generic-tagcode (type name)
+ ;; CLHS says:
+ ;; A class must be defined before it can be used as a parameter
+ ;; specializer in a defmethod form.
+ ;; So we can ignore types that are not known to denote classes.
+ (and (class-p type)
+ ;; Prefer (aref ,name 0) over (eieio--class-tag ,name) so that
+ ;; the tagcode is identical to the tagcode used for cl-struct.
+ `(50 . (and (vectorp ,name) (aref ,name 0)))))
+
+(add-function :before-until cl-generic-tag-types-function
+ #'eieio--generic-tag-types)
+(defun eieio--generic-tag-types (tag)
+ (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag))
+ (mapcar #'eieio--class-symbol
+ (eieio--class-precedence-list (symbol-value tag)))))
+
;;; Backward compatibility functions
;; To support .elc files compiled for older versions of EIEIO.
(defun eieio-defclass (cname superclasses slots options)
- (eval `(defclass ,cname ,superclasses ,slots ,options)))
+ (declare (obsolete eieio-defclass-internal "25.1"))
+ (eval `(defclass ,cname ,superclasses ,slots ,@options)))
(provide 'eieio-core)
diff --git a/lisp/files.el b/lisp/files.el
index 1533c35..175f85b 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -740,7 +740,10 @@ This function works recursively. Files are returned in
\"depth first\"
and alphabetical order.
If INCLUDE-DIRECTORIES, also include directories that have matching names."
(let ((result nil)
- (files nil))
+ (files nil)
+ ;; When DIR is "/", remote file names like "/method:" could
+ ;; also be offered. We shall suppress them.
+ (tramp-mode (and tramp-mode (file-remote-p dir))))
(dolist (file (sort (file-name-all-completions "" dir)
'string<))
(unless (member file '("./" "../"))
diff --git a/lisp/frame.el b/lisp/frame.el
index 8b92730..1d5bbf2 100644
--- a/lisp/frame.el
+++ b/lisp/frame.el
@@ -275,23 +275,22 @@ there (in decreasing order of priority)."
;; by the lines added in x-create-frame for the tool-bar and
;; switch `tool-bar-mode' off.
(when (display-graphic-p)
- (let ((tool-bar-lines
- (or (assq 'tool-bar-lines initial-frame-alist)
- (assq 'tool-bar-lines window-system-frame-alist)
- (assq 'tool-bar-lines default-frame-alist))))
- ;; Shrink frame by its initial tool bar height iff either zero
- ;; tool bar lines have been requested in one of the frame's
- ;; alists or tool bar mode has been turned off explicitly in
- ;; the user's init file.
- (when (and tool-bar-lines
- (> frame-initial-frame-tool-bar-height 0)
- (or (not tool-bar-mode)
- (null (cdr tool-bar-lines))
- (eq 0 (cdr tool-bar-lines))))
- (set-frame-height
- frame-initial-frame (- (frame-text-height frame-initial-frame)
- frame-initial-frame-tool-bar-height)
- nil t)
+ (let* ((init-lines
+ (assq 'tool-bar-lines initial-frame-alist))
+ (other-lines
+ (or (assq 'tool-bar-lines window-system-frame-alist)
+ (assq 'tool-bar-lines default-frame-alist)))
+ (lines (or init-lines other-lines))
+ (height (tool-bar-height frame-initial-frame t)))
+ ;; Adjust frame top if either zero (nil) tool bar lines have
+ ;; been requested in the most relevant of the frame's alists
+ ;; or tool bar mode has been explicitly turned off in the
+ ;; user's init file.
+ (when (and (> height 0)
+ (or (and lines
+ (or (null (cdr lines))
+ (eq 0 (cdr lines))))
+ (not tool-bar-mode)))
(let* ((initial-top
(cdr (assq 'top frame-initial-geometry-arguments)))
(top (frame-parameter frame-initial-frame 'top)))
@@ -299,15 +298,19 @@ there (in decreasing order of priority)."
(let ((adjusted-top
(cond
((and (consp top) (eq '+ (car top)))
- (list '+ (+ (cadr top)
- frame-initial-frame-tool-bar-height)))
+ (list '+ (+ (cadr top) height)))
((and (consp top) (eq '- (car top)))
- (list '- (- (cadr top)
- frame-initial-frame-tool-bar-height)))
- (t (+ top frame-initial-frame-tool-bar-height)))))
+ (list '- (- (cadr top) height)))
+ (t (+ top height)))))
(modify-frame-parameters
frame-initial-frame `((top . ,adjusted-top))))))
- (tool-bar-mode -1))))
+ ;; Reset `tool-bar-mode' when zero tool bar lines have been
+ ;; requested for the window-system or default frame alists.
+ (when (and tool-bar-mode
+ (and other-lines
+ (or (null (cdr other-lines))
+ (eq 0 (cdr other-lines)))))
+ (tool-bar-mode -1)))))
;; The initial frame we create above always has a minibuffer.
;; If the user wants to remove it, or make it a minibuffer-only
@@ -682,6 +685,9 @@ the new frame according to its own rules."
(push p params)))
;; Now make the frame.
(run-hooks 'before-make-frame-hook)
+
+;; (setq frame-adjust-size-history '(t))
+
(setq frame
(funcall (gui-method frame-creation-function w) params))
(normal-erase-is-backspace-setup-frame frame)
@@ -690,6 +696,12 @@ the new frame according to its own rules."
(unless (assq param parameters) ;Overridden by explicit parameters.
(let ((val (frame-parameter oldframe param)))
(when val (set-frame-parameter frame param val)))))
+
+ (when (eq (car frame-adjust-size-history) t)
+ (setq frame-adjust-size-history
+ (cons t (cons (list "Frame made")
+ (cdr frame-adjust-size-history)))))
+
(run-hook-with-args 'after-make-frame-functions frame)
frame))
diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el
index 67cb327..cd1a4d0 100644
--- a/lisp/menu-bar.el
+++ b/lisp/menu-bar.el
@@ -381,7 +381,8 @@
(bindings--define-key menu [xref-pop]
'(menu-item "Back" xref-pop-marker-stack
- :visible (not (xref-marker-stack-empty-p))
+ :visible (and (featurep 'xref)
+ (not (xref-marker-stack-empty-p)))
:help "Back to the position of the last search"))
(bindings--define-key menu [xref-apropos]
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index 6a6da17..879eb53 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -1,4 +1,4 @@
-;;; eww.el --- Emacs Web Wowser
+;;; eww.el --- Emacs Web Wowser -*- lexical-binding:t -*-
;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
@@ -255,7 +255,9 @@ word(s) will be searched for via `eww-search-prefix'."
((string-match-p "\\`ftp://"; url)
(user-error "FTP is not supported."))
(t
- (if (or (string-match "\\`https?:" url)
+ ;; Anything that starts with something that vaguely looks
+ ;; like a protocol designator is interpreted as a full URL.
+ (if (or (string-match "\\`[A-Za-z]+:" url)
;; Also try to match "naked" URLs like
;; en.wikipedia.org/wiki/Free software
(string-match "\\`[A-Za-z_]+\\.[A-Za-z._]+/" url)
@@ -550,7 +552,7 @@ See the `eww-search-prefix' variable for the search engine
used."
"Return URI of the Web page the current EWW buffer is visiting."
(plist-get eww-data :url))
-(defun eww-links-at-point (&optional pt)
+(defun eww-links-at-point ()
"Return list of URIs, if any, linked at point."
(remq nil
(list (get-text-property (point) 'shr-url)
@@ -629,17 +631,13 @@ the like."
(defvar eww-mode-map
(let ((map (make-sparse-keymap)))
- (suppress-keymap map)
- (define-key map "q" 'quit-window)
- (define-key map "g" 'eww-reload)
+ (set-keymap-parent map special-mode-map)
+ (define-key map "g" 'eww-reload) ;FIXME: revert-buffer-function instead!
(define-key map "G" 'eww)
(define-key map [?\t] 'shr-next-link)
(define-key map [?\M-\t] 'shr-previous-link)
(define-key map [backtab] 'shr-previous-link)
(define-key map [delete] 'scroll-down-command)
- (define-key map [?\S-\ ] 'scroll-down-command)
- (define-key map "\177" 'scroll-down-command)
- (define-key map " " 'scroll-up-command)
(define-key map "l" 'eww-back-url)
(define-key map "r" 'eww-forward-url)
(define-key map "n" 'eww-next-url)
@@ -697,21 +695,19 @@ the like."
map)
"Tool bar for `eww-mode'.")
-(define-derived-mode eww-mode nil "eww"
- "Mode for browsing the web.
-
-\\{eww-mode-map}"
+(define-derived-mode eww-mode special-mode "eww"
+ "Mode for browsing the web."
(setq-local eww-data (list :title ""))
- (setq-local browse-url-browser-function 'eww-browse-url)
- (setq-local after-change-functions 'eww-process-text-input)
+ (setq-local browse-url-browser-function #'eww-browse-url)
+ (add-hook 'after-change-functions #'eww-process-text-input nil t)
(setq-local eww-history nil)
(setq-local eww-history-position 0)
(when (boundp 'tool-bar-map)
- (setq-local tool-bar-map eww-tool-bar-map))
+ (setq-local tool-bar-map eww-tool-bar-map))
;; desktop support
- (setq-local desktop-save-buffer 'eww-desktop-misc-data)
+ (setq-local desktop-save-buffer #'eww-desktop-misc-data)
;; multi-page isearch support
- (setq-local multi-isearch-next-buffer-function 'eww-isearch-next-buffer)
+ (setq-local multi-isearch-next-buffer-function #'eww-isearch-next-buffer)
(setq truncate-lines t)
(buffer-disable-undo)
(setq buffer-read-only t))
@@ -1054,7 +1050,7 @@ See URL
`https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
(insert value)
(shr-ensure-newline)
(when (< (count-lines start (point)) lines)
- (dotimes (i (- lines (count-lines start (point))))
+ (dotimes (_ (- lines (count-lines start (point))))
(insert "\n")))
(setq end (point-marker))
(goto-char start)
@@ -1846,7 +1842,7 @@ Also used when saving `eww-history'.")
;; .
r))
-(defun eww-desktop-misc-data (directory)
+(defun eww-desktop-misc-data (_directory)
"Return a property list with data used to restore eww buffers.
This list will contain, as :history, the list, whose first element is
the value of `eww-data', and the tail is `eww-history'.
@@ -1894,7 +1890,7 @@ Otherwise, the restored buffer will contain a prompt to
do so by using
;;; Isearch support
-(defun eww-isearch-next-buffer (&optional buffer wrap)
+(defun eww-isearch-next-buffer (&optional _buffer wrap)
"Go to the next page to search using `rel' attribute for navigation."
(if wrap
(condition-case nil
diff --git a/lisp/progmodes/cc-bytecomp.el b/lisp/progmodes/cc-bytecomp.el
index bf7803c..b63eeb4 100644
--- a/lisp/progmodes/cc-bytecomp.el
+++ b/lisp/progmodes/cc-bytecomp.el
@@ -89,13 +89,60 @@
;;`(message ,@args)
)
+(defun cc-bytecomp-compiling-or-loading ()
+ ;; Determine whether byte-compilation or loading is currently active,
+ ;; returning 'compiling, 'loading or nil.
+ ;; If both are active, the "innermost" activity counts. Note that
+ ;; compilation can trigger loading (various `require' type forms)
+ ;; and loading can trigger compilation (the package manager does
+ ;; this). We walk the lisp stack if necessary.
+ (cond
+ ((and load-in-progress
+ (boundp 'byte-compile-dest-file)
+ (stringp byte-compile-dest-file))
+ (let ((n 0) elt)
+ (while (and
+ (setq elt (backtrace-frame n))
+ (not (and (car elt)
+ (memq (cadr elt)
+ '(load require
+ byte-compile-file byte-recompile-directory
+ batch-byte-compile)))))
+ (setq n (1+ n)))
+ (cond
+ ((memq (cadr elt) '(load require))
+ 'loading)
+ ((memq (cadr elt) '(byte-compile-file
+ byte-recompile-directory
+ batch-byte-compile))
+ 'compiling)
+ (t ; Can't happen.
+ (message "cc-bytecomp-compiling-or-loading: System flags spuriously
set")
+ nil))))
+ (load-in-progress
+ ;; Being loaded.
+ 'loading)
+ ((and (boundp 'byte-compile-dest-file)
+ (stringp byte-compile-dest-file))
+ ;; Being compiled.
+ 'compiling)
+ (t
+ ;; Being evaluated interactively.
+ nil)))
+
+(defsubst cc-bytecomp-is-compiling ()
+ "Return non-nil if eval'ed during compilation."
+ (eq (cc-bytecomp-compiling-or-loading) 'compiling))
+
+(defsubst cc-bytecomp-is-loading ()
+ "Return non-nil if eval'ed during loading.
+Nil will be returned if we're in a compilation triggered by the loading."
+ (eq (cc-bytecomp-compiling-or-loading) 'loading))
+
(defun cc-bytecomp-setup-environment ()
;; Eval'ed during compilation to setup variables, functions etc
;; declared with `cc-bytecomp-defvar' et al.
- (if (not load-in-progress)
- ;; Look at `load-in-progress' to tell whether we're called
- ;; directly in the file being compiled or just from some file
- ;; being loaded during compilation.
+ (if (not (cc-bytecomp-is-loading))
(let (p)
(if cc-bytecomp-environment-set
(error "Byte compilation environment already set - \
@@ -143,7 +190,7 @@ perhaps a `cc-bytecomp-restore-environment' is forgotten
somewhere"))
(defun cc-bytecomp-restore-environment ()
;; Eval'ed during compilation to restore variables, functions etc
;; declared with `cc-bytecomp-defvar' et al.
- (if (not load-in-progress)
+ (if (not (cc-bytecomp-is-loading))
(let (p)
(setq p cc-bytecomp-unbound-variables)
(while p
@@ -287,8 +334,7 @@ use within `eval-when-compile'."
`(eval-when-compile
(if (and (fboundp 'cc-bytecomp-is-compiling)
(cc-bytecomp-is-compiling))
- (if (or (not load-in-progress)
- (not (featurep ,cc-part)))
+ (if (not (featurep ,cc-part))
(cc-bytecomp-load (symbol-name ,cc-part)))
(require ,cc-part))))
@@ -301,12 +347,6 @@ afterwards. Don't use within `eval-when-compile'."
(require ,feature)
(eval-when-compile (cc-bytecomp-setup-environment))))
-(defun cc-bytecomp-is-compiling ()
- "Return non-nil if eval'ed during compilation. Don't use outside
-`eval-when-compile'."
- (and (boundp 'byte-compile-dest-file)
- (stringp byte-compile-dest-file)))
-
(defmacro cc-bytecomp-defvar (var)
"Binds the symbol as a variable during compilation of the file,
to silence the byte compiler. Don't use within `eval-when-compile'."
@@ -320,8 +360,7 @@ to silence the byte compiler. Don't use within
`eval-when-compile'."
"cc-bytecomp-defvar: Saving %s (as unbound)" ',var)
(setq cc-bytecomp-unbound-variables
(cons ',var cc-bytecomp-unbound-variables))))
- (if (and (cc-bytecomp-is-compiling)
- (not load-in-progress))
+ (if (cc-bytecomp-is-compiling)
(progn
(defvar ,var)
(set ',var (intern (concat "cc-bytecomp-ignore-var:"
@@ -349,8 +388,7 @@ at compile time, e.g. for macros and inline functions."
(setq cc-bytecomp-original-functions
(cons (list ',fun nil 'unbound)
cc-bytecomp-original-functions))))
- (if (and (cc-bytecomp-is-compiling)
- (not load-in-progress))
+ (if (cc-bytecomp-is-compiling)
(progn
(fset ',fun (intern (concat "cc-bytecomp-ignore-fun:"
(symbol-name ',fun))))
diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el
index 2ea566a..d0beab1 100644
--- a/lisp/progmodes/cc-defs.el
+++ b/lisp/progmodes/cc-defs.el
@@ -1983,19 +1983,22 @@ system."
(defvar c-lang-const-expansion nil)
+;; Ugly hack to pull in the definition of `cc-bytecomp-compiling-or-loading`
+;; from cc-bytecomp to make it available at loadtime. This is the same
+;; mechanism used in cc-mode.el for `c-populate-syntax-table'.
+(defalias 'cc-bytecomp-compiling-or-loading
+ (cc-eval-when-compile
+ (let ((f (symbol-function 'cc-bytecomp-compiling-or-loading)))
+ (if (byte-code-function-p f) f (byte-compile f)))))
+
(defsubst c-get-current-file ()
;; Return the base name of the current file.
- (let ((file (cond
- (load-in-progress
- ;; Being loaded.
- load-file-name)
- ((and (boundp 'byte-compile-dest-file)
- (stringp byte-compile-dest-file))
- ;; Being compiled.
- byte-compile-dest-file)
- (t
- ;; Being evaluated interactively.
- (buffer-file-name)))))
+ (let* ((c-or-l (cc-bytecomp-compiling-or-loading))
+ (file
+ (cond
+ ((eq c-or-l 'loading) load-file-name)
+ ((eq c-or-l 'compiling) byte-compile-dest-file)
+ ((null c-or-l) (buffer-file-name)))))
(and file
(file-name-sans-extension
(file-name-nondirectory file)))))
@@ -2062,6 +2065,9 @@ constant. A file is identified by its base name."
;; language constant source definitions.)
(c-lang-const-expansion 'call)
(c-langs-are-parametric t)
+ (file (intern
+ (or (c-get-current-file)
+ (error "`c-lang-defconst' can only be used in a file"))))
bindings
pre-files)
@@ -2121,9 +2127,14 @@ constant. A file is identified by its base name."
;; definitions for this symbol, to make sure the order in the
;; `source' property is correct even when files are loaded out of
;; order.
- (setq pre-files (nreverse
- ;; Reverse to get the right load order.
- (mapcar 'car (get sym 'source))))
+ (setq pre-files (mapcar 'car (get sym 'source)))
+ (if (memq file pre-files)
+ ;; This can happen when the source file (e.g. cc-langs.el) is first
+ ;; loaded as source, setting a 'source property entry, and then itself
+ ;; being compiled.
+ (setq pre-files (cdr (memq file pre-files))))
+ ;; Reverse to get the right load order.
+ (setq pre-files (nreverse pre-files))
`(eval-and-compile
(c-define-lang-constant ',name ,bindings
@@ -2233,9 +2244,7 @@ quoted."
(if (or (eq c-lang-const-expansion 'call)
(and (not c-lang-const-expansion)
(not mode))
- load-in-progress
- (not (boundp 'byte-compile-dest-file))
- (not (stringp byte-compile-dest-file)))
+ (not (cc-bytecomp-is-compiling)))
;; Either a straight call is requested in the context, or
;; we're in an "uncontrolled" context and got no language,
;; or we're not being byte compiled so the compile time
diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el
index 17d717e..4d16a9b 100644
--- a/lisp/progmodes/cc-langs.el
+++ b/lisp/progmodes/cc-langs.el
@@ -3260,10 +3260,7 @@ function it returns is byte compiled with all the
evaluated results
from the language constants. Use the `c-init-language-vars' macro to
accomplish that conveniently."
- (if (and (not load-in-progress)
- (boundp 'byte-compile-dest-file)
- (stringp byte-compile-dest-file))
-
+ (if (cc-bytecomp-is-compiling)
;; No need to byte compile this lambda since the byte compiler is
;; smart enough to detect the `funcall' construct in the
;; `c-init-language-vars' macro below and compile it all straight
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index b822619..7f77d21 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -301,6 +301,7 @@ backward."
(let ((marker (ring-remove ring)))
(set-marker marker nil nil)))))
+;;;###autoload
(defun xref-marker-stack-empty-p ()
"Return t if the marker stack is empty; nil otherwise."
(ring-empty-p xref--marker-ring))
diff --git a/src/.gdbinit b/src/.gdbinit
index 1a2a973..91beaef 100644
--- a/src/.gdbinit
+++ b/src/.gdbinit
@@ -70,14 +70,18 @@ define xgettype
set $type = (enum Lisp_Type) (USE_LSB_TAG ? $bugfix & (1 << GCTYPEBITS) - 1
: (EMACS_UINT) $bugfix >> VALBITS)
end
+define xgetsym
+ xgetptr $arg0
+ if (!USE_LSB_TAG)
+ set $ptr = ($ptr << GCTYPEBITS)
+ end
+ set $ptr = ((struct Lisp_Symbol *) ((char *)lispsym + $ptr))
+end
+
# Access the name of a symbol
define xsymname
- if (CHECK_LISP_OBJECT_TYPE)
- set $bugfix = $arg0.i
- else
- set $bugfix = $arg0
- end
- set $symname = ((struct Lisp_Symbol *) ((char *)lispsym + $bugfix))->name
+ xgetsym $arg0
+ set $symname = $ptr->name
end
# Set up something to print out s-expressions.
@@ -760,7 +764,7 @@ end
define xsymbol
set $sym = $
- xgetptr $sym
+ xgetsym $sym
print (struct Lisp_Symbol *) $ptr
xprintsym $sym
echo \n
@@ -1082,8 +1086,7 @@ define xprintstr
end
define xprintsym
- xgetptr $arg0
- xsymname $ptr
+ xsymname $arg0
xgetptr $symname
set $sym_name = (struct Lisp_String *) $ptr
xprintstr $sym_name
diff --git a/src/ChangeLog b/src/ChangeLog
index 8f441be..b2588f1 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,236 @@
+2015-01-14 Eli Zaretskii <address@hidden>
+
+ * w32fns.c (w32_wnd_proc): Ignore MENUITEMINFO's dwItemData data
+ when FLAGS indicate the item is not highlighted. (Bug#19596)
+
+2015-01-14 Martin Rudalics <address@hidden>
+
+ * xmenu.c (update_frame_menubar): Remove garbaged code.
+
+2015-01-14 Paul Eggert <address@hidden>
+
+ remove_slash_colon need not be inline
+ * process.c, process.h (remove_slash_colon): No longer inline.
+ This saves text bytes without hurting runtime performance.
+
+2015-01-14 Dmitry Antipov <address@hidden>
+
+ Avoid extra multibyteness check in ENCODE_FILE users.
+ * callproc.c (encode_current_directory, Fcall_process, call_process):
+ * dired.c (directory_files_internal, file_name_completion):
+ Do not check for STRING_MULTIBYTE because encode_file_name
+ is a no-op for unibyte strings.
+
+ * process.h (remove_slash_colon): New function.
+ * callproc.c (encode_current_directory, call_process):
+ * process.c (Fstart_process): Use it.
+
+ Consistently handle time zone specification.
+ * editfns.c (decode_time_zone): New function, refactored out from ...
+ (Fencode_time): ... adjusted user.
+ (Fset_time_zone_rule): Use decode_time_zone.
+
+ * editfns.c (make_buffer_string_both): If requested range intersects
+ the gap, don't move the latter but copy in two regions, thus avoiding
+ unnecessary relocation of buffer data.
+
+2015-01-14 Paul Eggert <address@hidden>
+
+ Use bool for boolean in xmenu.c, xml.c
+ * xmenu.c (x_menu_set_in_use, popup_get_selection)
+ (Fx_menu_bar_open_internal, popup_widget_loop)
+ (x_activate_menubar, xg_crazy_callback_abort)
+ (update_frame_menubar, set_frame_menubar)
+ (initialize_frame_menubar, free_frame_menubar)
+ (create_and_show_popup_menu, x_menu_show)
+ (create_and_show_dialog, x_dialog_show):
+ * xml.c (libxml2_loaded_p, init_libxml2_functions, parse_region)
+ (Flibxml_parse_html_region, Flibxml_parse_xml_region):
+ * xrdb.c (main) [TESTRM]:
+ * xsettings.c (init_gsettings):
+ * xterm.c (XFillRectangle, xg_scroll_callback)
+ (xg_end_scroll_callback):
+ * xterm.h (x_menu_set_in_use) [USE_GTK || USE_MOTIF]:
+ Use bool for boolean.
+ * xmenu.c (TRUE): Remove; no longer used.
+ (show_help_event): Remove long-unused code.
+ (set_frame_menubar): Remove "#if 1" and corresponding "#endif" lines.
+
+2015-01-13 Paul Eggert <address@hidden>
+
+ Don't say Fnext_read_file_uses_dialog_p is const
+ It's const only if a windowing system is not used; don't say it's
+ const otherwise. See:
+ http://lists.gnu.org/archive/html/emacs-devel/2015-01/msg00310.html
+ * fileio.c (next_read_file_uses_dialog_p): Remove.
+ Move guts back to ...
+ (Fnext_read_file_uses_dialog_p): ... here.
+ Don't declare as const, as make-docfile.c now has a special case
+ for this function. This is an ugly hack, but it's better than
+ lying to the compiler.
+
+ Remove now-unnecessary forward XTYPE decl
+ * lisp.h (XTYPE): Remove forward declaration. The recent merge
+ from emacs-24 fixed the problem in a better way, by moving XPNTR's
+ definition to after XTYPE's.
+
+2015-01-13 Eli Zaretskii <address@hidden>
+
+ Fix problems with 32-bit wide-int build exposed by MinGW.
+ * lisp.h (XPNTR): Move definition to after XTYPE, to avoid
+ compilation error in an unoptimized build when !USE_LSB_TAG.
+
+ * w32heap.c (DUMPED_HEAP_SIZE): For 32-bit wide-int build, use the
+ same larger value as for the 64-bit build.
+
+ * w32term.h (SCROLL_BAR_PACK): Cast the result to UINT_PTR to
+ avoid compiler warnings.
+
+ * w32proc.c (Fw32_get_codepage_charset, Fw32_set_keyboard_layout):
+ Avoid compiler warnings about cast from integer to pointer of
+ different size.
+
+ * w32menu.c (menubar_selection_callback, w32_menu_show): Cast to
+ UINT_PTR instead of EMACS_INT, to avoid compiler warnings about
+ casting from integer to pointer of different size.
+ (add_menu_item): Pass the help-echo string as a pointer to
+ Lisp_String, not as a Lisp_Object.
+ (w32_menu_display_help): Use make_lisp_ptr to reconstruct a Lisp
+ string object from its C pointer.
+
+ * w32fns.c (w32_msg_pump) <WM_EMACS_UNREGISTER_HOT_KEY>: Use
+ make_lisp_ptr instead of XIL, to reconstruct a Lisp_Cons from its
+ C pointer.
+ <WM_EMACS_TOGGLE_LOCK_KEY>: msg.lparam is now a C integer.
+ (Fx_create_frame): Type-cast the result of XFASTINT to avoild
+ compiler warnings about size differences.
+ (Fw32_unregister_hot_key): Pass the tail of w32_grabbed_keys as a
+ pointer to a Lisp_Cons struct, not as a disguised EMACS_INT.
+ (Fw32_toggle_lock_key): Pass the new state of the key as a C
+ integer; use -1 for nil. Doc fix.
+
+ * .gdbinit (xgetsym): New subroutine.
+ (xsymname, xsymbol): Use it.
+ (xprintsym): No need to call xgetptr.
+
+2015-01-13 Martin Rudalics <address@hidden>
+
+ * frame.c (adjust_frame_size): Make sure new numbers of
+ lines/columns get installed after font size change (Bug#19575).
+
+2015-01-13 Dmitry Antipov <address@hidden>
+
+ Add DEFUN attributes.
+ * callint.c (Finteractive):
+ * character.c (Fcharacterp, Fmax_char):
+ * data.c (Feq, Fnull, Fconsp, Fatom, Flistp, Fnlistp, Fsymbolp)
+ (Fstringp, Fchar_or_string_p, Fintegerp, Fnatnump, Fnumberp)
+ (Ffloatp, Fbyteorder):
+ * decompress.c (Fzlib_available_p):
+ * fns.c (Fidentity):
+ * frame.c (Fframe_windows_min_size):
+ * gnutls.c (Fgnutls_error_p, Fgnutls_available_p):
+ * window.c (Fwindow__sanitize_window_sizes):
+ * xdisp.c (Ftool_bar_height):
+ * xfaces.c (Fface_attribute_relative_p): Add const attribute.
+ * emacs.c (Fkill_emacs):
+ * eval.c (Fthrow):
+ * keyboard.c (Ftop_level, Fexit_recursive_edit)
+ (Fabor_recursive_edit): Add noreturn attribute.
+
+ * search.c (fast_string_match_internal): New function,
+ consolidated from...
+ (fast_string_match, fast_string_match_ignore_case): ...functions
+ which are...
+ * lisp.h (fast_string_match, fast_string_match_ignore_case):
+ inlined from here now.
+ (fast_string_match_internal): Add prototype.
+ * dired.c (file_name_completion): Use fast_string_match_internal.
+
+ * fileio.c (next_read_file_uses_dialog_p): New workaround ...
+ (Fnext_read_file_uses_dialog_p): ... called from here to avoid
+ ATTRIBUTE_CONST dependency from #ifdefs. For details, see
+ http://lists.gnu.org/archive/html/emacs-devel/2015-01/msg00289.html.
+
+2015-01-12 Paul Eggert <address@hidden>
+
+ Port to 32-bit MingGW --with-wide-int
+ Problem reported by Eli Zaretskii in:
+ http://lists.gnu.org/archive/html/emacs-devel/2015-01/msg00265.html
+ * lisp.h (struct Lisp_Sub_Char_Table): Check that offset matches
+ what we think it is, rather than checking only its alignment (and
+ doing so incorrectly on MinGW).
+
+2015-01-12 Dmitry Antipov <address@hidden>
+
+ * fileio.c (Ffile_name_as_directory, Fdirectory_file_name):
+ Remove dead NILP check.
+ * image.c (Flookup_image): Use regular format for docstring.
+ * keyboard.c (apply_modifiers_uncached): Use stpcpy.
+
+2015-01-12 Martin Rudalics <address@hidden>
+
+ * dispnew.c (change_frame_size_1): Pass Qchange_frame_size to
+ adjust_frame_size.
+ * frame.c (frame_default_tool_bar_height): New variable.
+ (adjust_frame_size): Possibly add requested adjustment to
+ Vframe_adjust_size_history.
+ (make_frame): Initialize tool_bar_redisplayed_once slot.
+ (Fset_frame_height, Fset_frame_width, Fset_frame_size): Clarify
+ doc-string. Call adjust_frame_size unconditionally (the frame's
+ text size may remain unaltered but the pixel size may change).
+ (x_figure_window_size): If frame_default_tool_bar_height was
+ set, use it instead of calculating the tool bar height from
+ DEFAULT_TOOL_BAR_IMAGE_HEIGHT. Don't set
+ Vframe_initial_frame_tool_bar_height.
+ (Qchange_frame_size, Qxg_frame_set_char_size)
+ (Qset_window_configuration, Qx_create_frame_1)
+ (Qx_create_frame_2): New symbols.
+ (Vframe_initial_frame_tool_bar_height): Remove.
+ (Vframe_adjust_size_history): New history variable for debugging
+ frame size adjustments.
+ * frame.h (struct frame): New boolean slot
+ tool_bar_redisplayed_once.
+ (frame_default_tool_bar_height): Extern.
+ * gtkutil.c (xg_frame_set_char_size): Pass Qxg_frame_set_char_size
+ to adjust_frame_size.
+ * nsfns.m (Fx_create_frame): Pass Pass Qx_create_frame_1 and
+ Qx_create_frame_2 to adjust_frame_size.
+ * w32fns.c (x_change_tool_bar_height): Call adjust_frame_size with
+ inhibit 1 when we have not redisplayed the tool bar yet.
+ (Fx_create_frame): Pass Pass Qx_create_frame_1 and
+ Qx_create_frame_2 to adjust_frame_size.
+ * w32menu.c (set_frame_menubar): Simplify adjust_frame_size
+ call.
+ * window.c (Fset_window_configuration): Pass
+ Qset_window_configuration to adjust_frame_size.
+ * xdisp.c (redisplay_tool_bar): Assign new height to
+ frame_default_tool_bar_height.
+ (redisplay_internal): If we haven't redisplayed this frame's
+ tool bar, call redisplay_tool_bar early so we can adjust the
+ frame size accordingly.
+ * xfns.c (x_change_tool_bar_height): Call adjust_frame_size with
+ inhibit 1 when we have not redisplayed the tool bar yet.
+ (Fx_create_frame): Pass Pass Qx_create_frame_1 and
+ Qx_create_frame_2 to adjust_frame_size.
+
+2015-01-12 Paul Eggert <address@hidden>
+
+ Have 'make' output better GEN names
+ * Makefile.in (gl-stamp, globals.h): Simplify by putting the new
+ contents of globals.h into gl-stamp. This lets us use AM_V_GEN
+ more naturally so that 'make' can output more-accurate names.
+
+2015-01-11 Stefan Monnier <address@hidden>
+
+ * buffer.c (init_buffer_once): Initialize buffer_local_flags before
+ calling reset_buffer_local_variables, and make sure we initialize
+ it completely.
+
+2015-01-11 Dmitry Antipov <address@hidden>
+
+ * coding.c (Fcoding_system_plist): Use common style for docstring.
+
2015-01-11 Paul Eggert <address@hidden>
Port to MSB hosts without optimization
diff --git a/src/Makefile.in b/src/Makefile.in
index 9bd86d5..079e0e4 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -502,14 +502,13 @@ buildobj.h: Makefile
done >address@hidden
$(AM_V_at)mv address@hidden $@
-globals.h: gl-stamp; @true
-
GLOBAL_SOURCES = $(base_obj:.o=.c) $(NS_OBJC_OBJ:.o=.m)
gl-stamp: $(libsrc)/make-docfile$(EXEEXT) $(GLOBAL_SOURCES)
- $(AM_V_GEN)$(libsrc)/make-docfile -d $(srcdir) -g $(obj) > gl.tmp
- $(AM_V_at)$(top_srcdir)/build-aux/move-if-change gl.tmp globals.h
- $(AM_V_at)echo timestamp > $@
+ $(AM_V_GEN)$(libsrc)/make-docfile -d $(srcdir) -g $(obj) >$@
+
+globals.h: gl-stamp
+ $(AM_V_GEN)cmp $< $@ >/dev/null || cp $< $@
$(ALLOBJS): globals.h
diff --git a/src/buffer.c b/src/buffer.c
index 2ea69f3..6bff57f 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -5035,6 +5035,93 @@ init_buffer_once (void)
memset (buffer_permanent_local_flags, 0, sizeof
buffer_permanent_local_flags);
+ /* 0 means not a lisp var, -1 means always local, else mask. */
+ memset (&buffer_local_flags, 0, sizeof buffer_local_flags);
+ bset_filename (&buffer_local_flags, make_number (-1));
+ bset_directory (&buffer_local_flags, make_number (-1));
+ bset_backed_up (&buffer_local_flags, make_number (-1));
+ bset_save_length (&buffer_local_flags, make_number (-1));
+ bset_auto_save_file_name (&buffer_local_flags, make_number (-1));
+ bset_read_only (&buffer_local_flags, make_number (-1));
+ bset_major_mode (&buffer_local_flags, make_number (-1));
+ bset_mode_name (&buffer_local_flags, make_number (-1));
+ bset_undo_list (&buffer_local_flags, make_number (-1));
+ bset_mark_active (&buffer_local_flags, make_number (-1));
+ bset_point_before_scroll (&buffer_local_flags, make_number (-1));
+ bset_file_truename (&buffer_local_flags, make_number (-1));
+ bset_invisibility_spec (&buffer_local_flags, make_number (-1));
+ bset_file_format (&buffer_local_flags, make_number (-1));
+ bset_auto_save_file_format (&buffer_local_flags, make_number (-1));
+ bset_display_count (&buffer_local_flags, make_number (-1));
+ bset_display_time (&buffer_local_flags, make_number (-1));
+ bset_enable_multibyte_characters (&buffer_local_flags, make_number (-1));
+
+ /* These used to be stuck at 0 by default, but now that the all-zero value
+ means Qnil, we have to initialize them explicitly. */
+ bset_name (&buffer_local_flags, make_number (0));
+ bset_mark (&buffer_local_flags, make_number (0));
+ bset_local_var_alist (&buffer_local_flags, make_number (0));
+ bset_keymap (&buffer_local_flags, make_number (0));
+ bset_downcase_table (&buffer_local_flags, make_number (0));
+ bset_upcase_table (&buffer_local_flags, make_number (0));
+ bset_case_canon_table (&buffer_local_flags, make_number (0));
+ bset_case_eqv_table (&buffer_local_flags, make_number (0));
+ bset_minor_modes (&buffer_local_flags, make_number (0));
+ bset_width_table (&buffer_local_flags, make_number (0));
+ bset_pt_marker (&buffer_local_flags, make_number (0));
+ bset_begv_marker (&buffer_local_flags, make_number (0));
+ bset_zv_marker (&buffer_local_flags, make_number (0));
+ bset_last_selected_window (&buffer_local_flags, make_number (0));
+
+ idx = 1;
+ XSETFASTINT (BVAR (&buffer_local_flags, mode_line_format), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, abbrev_mode), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, overwrite_mode), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, case_fold_search), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, auto_fill_function), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, selective_display), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, selective_display_ellipses), idx);
++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, tab_width), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, truncate_lines), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, word_wrap), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, ctl_arrow), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, fill_column), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, left_margin), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, abbrev_table), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, display_table), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, syntax_table), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, cache_long_scans), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, category_table), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, bidi_display_reordering), idx);
++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, bidi_paragraph_direction), idx);
++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, buffer_file_coding_system), idx);
+ /* Make this one a permanent local. */
+ buffer_permanent_local_flags[idx++] = 1;
+ XSETFASTINT (BVAR (&buffer_local_flags, left_margin_cols), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, right_margin_cols), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, left_fringe_width), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, right_fringe_width), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, fringes_outside_margins), idx);
++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, scroll_bar_width), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, scroll_bar_height), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, vertical_scroll_bar_type), idx);
++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, horizontal_scroll_bar_type), idx);
++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, indicate_empty_lines), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, indicate_buffer_boundaries), idx);
++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, fringe_indicator_alist), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, fringe_cursor_alist), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, scroll_up_aggressively), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, scroll_down_aggressively), idx);
++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, header_line_format), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, cursor_type), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, extra_line_spacing), idx); ++idx;
+ XSETFASTINT (BVAR (&buffer_local_flags, cursor_in_non_selected_windows),
idx); ++idx;
+
+ /* Need more room? */
+ if (idx >= MAX_PER_BUFFER_VARS)
+ emacs_abort ();
+ last_per_buffer_idx = idx;
+
/* Make sure all markable slots in buffer_defaults
are initialized reasonably, so mark_buffer won't choke. */
reset_buffer (&buffer_defaults);
@@ -5121,79 +5208,9 @@ init_buffer_once (void)
to say that it has its own local value for the slot.
The local flag bits are in the local_var_flags slot of the buffer. */
- /* Nothing can work if this isn't true */
+ /* Nothing can work if this isn't true. */
{ verify (sizeof (EMACS_INT) == word_size); }
- /* 0 means not a lisp var, -1 means always local, else mask */
- memset (&buffer_local_flags, 0, sizeof buffer_local_flags);
- bset_filename (&buffer_local_flags, make_number (-1));
- bset_directory (&buffer_local_flags, make_number (-1));
- bset_backed_up (&buffer_local_flags, make_number (-1));
- bset_save_length (&buffer_local_flags, make_number (-1));
- bset_auto_save_file_name (&buffer_local_flags, make_number (-1));
- bset_read_only (&buffer_local_flags, make_number (-1));
- bset_major_mode (&buffer_local_flags, make_number (-1));
- bset_mode_name (&buffer_local_flags, make_number (-1));
- bset_undo_list (&buffer_local_flags, make_number (-1));
- bset_mark_active (&buffer_local_flags, make_number (-1));
- bset_point_before_scroll (&buffer_local_flags, make_number (-1));
- bset_file_truename (&buffer_local_flags, make_number (-1));
- bset_invisibility_spec (&buffer_local_flags, make_number (-1));
- bset_file_format (&buffer_local_flags, make_number (-1));
- bset_auto_save_file_format (&buffer_local_flags, make_number (-1));
- bset_display_count (&buffer_local_flags, make_number (-1));
- bset_display_time (&buffer_local_flags, make_number (-1));
- bset_enable_multibyte_characters (&buffer_local_flags, make_number (-1));
-
- idx = 1;
- XSETFASTINT (BVAR (&buffer_local_flags, mode_line_format), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, abbrev_mode), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, overwrite_mode), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, case_fold_search), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, auto_fill_function), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, selective_display), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, selective_display_ellipses), idx);
++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, tab_width), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, truncate_lines), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, word_wrap), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, ctl_arrow), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, fill_column), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, left_margin), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, abbrev_table), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, display_table), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, syntax_table), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, cache_long_scans), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, category_table), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, bidi_display_reordering), idx);
++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, bidi_paragraph_direction), idx);
++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, buffer_file_coding_system), idx);
- /* Make this one a permanent local. */
- buffer_permanent_local_flags[idx++] = 1;
- XSETFASTINT (BVAR (&buffer_local_flags, left_margin_cols), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, right_margin_cols), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, left_fringe_width), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, right_fringe_width), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, fringes_outside_margins), idx);
++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, scroll_bar_width), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, scroll_bar_height), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, vertical_scroll_bar_type), idx);
++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, horizontal_scroll_bar_type), idx);
++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, indicate_empty_lines), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, indicate_buffer_boundaries), idx);
++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, fringe_indicator_alist), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, fringe_cursor_alist), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, scroll_up_aggressively), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, scroll_down_aggressively), idx);
++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, header_line_format), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, cursor_type), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, extra_line_spacing), idx); ++idx;
- XSETFASTINT (BVAR (&buffer_local_flags, cursor_in_non_selected_windows),
idx); ++idx;
-
- /* Need more room? */
- if (idx >= MAX_PER_BUFFER_VARS)
- emacs_abort ();
- last_per_buffer_idx = idx;
-
Vbuffer_alist = Qnil;
current_buffer = 0;
all_buffers = 0;
@@ -5210,7 +5227,7 @@ init_buffer_once (void)
DEFSYM (Qkill_buffer_hook, "kill-buffer-hook");
Fput (Qkill_buffer_hook, Qpermanent_local, Qt);
- /* super-magic invisible buffer */
+ /* Super-magic invisible buffer. */
Vprin1_to_string_buffer = Fget_buffer_create (build_pure_c_string ("
prin1"));
Vbuffer_alist = Qnil;
diff --git a/src/callint.c b/src/callint.c
index 2595503..dd238b9 100644
--- a/src/callint.c
+++ b/src/callint.c
@@ -101,7 +101,8 @@ If the string begins with `^' and `shift-select-mode' is
non-nil,
Emacs first calls the function `handle-shift-selection'.
You may use `@', `*', and `^' together. They are processed in the
order that they appear, before reading any arguments.
-usage: (interactive &optional ARGS) */)
+usage: (interactive &optional ARGS) */
+ attributes: const)
(Lisp_Object args)
{
return Qnil;
diff --git a/src/callproc.c b/src/callproc.c
index 0fdf278..63ab9bf 100644
--- a/src/callproc.c
+++ b/src/callproc.c
@@ -131,12 +131,9 @@ encode_current_directory (void)
report_file_error ("Setting current directory",
BVAR (current_buffer, directory));
- /* Remove "/:" from dir. */
- if (! NILP (Fstring_match (build_string ("^/:"), dir, Qnil)))
- dir = Fsubstring (dir, make_number (2), Qnil);
+ /* Remove "/:" from DIR and encode it. */
+ dir = ENCODE_FILE (remove_slash_colon (dir));
- if (STRING_MULTIBYTE (dir))
- dir = ENCODE_FILE (dir);
if (! file_accessible_directory_p (dir))
report_file_error ("Setting current directory",
BVAR (current_buffer, directory));
@@ -267,7 +264,7 @@ usage: (call-process PROGRAM &optional INFILE DESTINATION
DISPLAY &rest ARGS) *
infile = build_string (NULL_DEVICE);
GCPRO1 (infile);
- encoded_infile = STRING_MULTIBYTE (infile) ? ENCODE_FILE (infile) : infile;
+ encoded_infile = ENCODE_FILE (infile);
filefd = emacs_open (SSDATA (encoded_infile), O_RDONLY, 0);
if (filefd < 0)
@@ -439,9 +436,9 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int
filefd,
GCPRO4 (buffer, current_dir, error_file, output_file);
- if (STRINGP (error_file) && STRING_MULTIBYTE (error_file))
+ if (STRINGP (error_file))
error_file = ENCODE_FILE (error_file);
- if (STRINGP (output_file) && STRING_MULTIBYTE (output_file))
+ if (STRINGP (output_file))
output_file = ENCODE_FILE (output_file);
UNGCPRO;
}
@@ -468,11 +465,8 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int
filefd,
report_file_error ("Searching for program", args[0]);
}
- /* If program file name starts with /: for quoting a magic name,
- discard that. */
- if (SBYTES (path) > 2 && SREF (path, 0) == '/'
- && SREF (path, 1) == ':')
- path = Fsubstring (path, make_number (2), Qnil);
+ /* Remove "/:" from PATH. */
+ path = remove_slash_colon (path);
SAFE_NALLOCA (new_argv, 1, nargs < 4 ? 2 : nargs - 2);
@@ -498,8 +492,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int
filefd,
}
else
new_argv[1] = 0;
- if (STRING_MULTIBYTE (path))
- path = ENCODE_FILE (path);
+ path = ENCODE_FILE (path);
new_argv[0] = SSDATA (path);
UNGCPRO;
}
diff --git a/src/character.c b/src/character.c
index 4a5c7ec..39d32c9 100644
--- a/src/character.c
+++ b/src/character.c
@@ -232,14 +232,16 @@ DEFUN ("characterp", Fcharacterp, Scharacterp, 1, 2, 0,
In Emacs Lisp, characters are represented by character codes, which
are non-negative integers. The function `max-char' returns the
maximum character code.
-usage: (characterp OBJECT) */)
+usage: (characterp OBJECT) */
+ attributes: const)
(Lisp_Object object, Lisp_Object ignore)
{
return (CHARACTERP (object) ? Qt : Qnil);
}
DEFUN ("max-char", Fmax_char, Smax_char, 0, 0, 0,
- doc: /* Return the character of the maximum code. */)
+ doc: /* Return the character of the maximum code. */
+ attributes: const)
(void)
{
return make_number (MAX_CHAR);
diff --git a/src/coding.c b/src/coding.c
index 20c6476..b11143a 100644
--- a/src/coding.c
+++ b/src/coding.c
@@ -10671,7 +10671,7 @@ Any alias or subsidiary coding system is not a base
coding system. */)
DEFUN ("coding-system-plist", Fcoding_system_plist, Scoding_system_plist,
1, 1, 0,
- doc: "Return the property list of CODING-SYSTEM.")
+ doc: /* Return the property list of CODING-SYSTEM. */)
(Lisp_Object coding_system)
{
Lisp_Object spec, attrs;
diff --git a/src/data.c b/src/data.c
index 820c3ce..0389eb4 100644
--- a/src/data.c
+++ b/src/data.c
@@ -176,7 +176,8 @@ args_out_of_range_3 (Lisp_Object a1, Lisp_Object a2,
Lisp_Object a3)
/* Data type predicates. */
DEFUN ("eq", Feq, Seq, 2, 2, 0,
- doc: /* Return t if the two args are the same Lisp object. */)
+ doc: /* Return t if the two args are the same Lisp object. */
+ attributes: const)
(Lisp_Object obj1, Lisp_Object obj2)
{
if (EQ (obj1, obj2))
@@ -185,7 +186,8 @@ DEFUN ("eq", Feq, Seq, 2, 2, 0,
}
DEFUN ("null", Fnull, Snull, 1, 1, 0,
- doc: /* Return t if OBJECT is nil. */)
+ doc: /* Return t if OBJECT is nil. */
+ attributes: const)
(Lisp_Object object)
{
if (NILP (object))
@@ -263,7 +265,8 @@ for example, (type-of 1) returns `integer'. */)
}
DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0,
- doc: /* Return t if OBJECT is a cons cell. */)
+ doc: /* Return t if OBJECT is a cons cell. */
+ attributes: const)
(Lisp_Object object)
{
if (CONSP (object))
@@ -272,7 +275,8 @@ DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0,
}
DEFUN ("atom", Fatom, Satom, 1, 1, 0,
- doc: /* Return t if OBJECT is not a cons cell. This includes nil. */)
+ doc: /* Return t if OBJECT is not a cons cell. This includes nil. */
+ attributes: const)
(Lisp_Object object)
{
if (CONSP (object))
@@ -282,7 +286,8 @@ DEFUN ("atom", Fatom, Satom, 1, 1, 0,
DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
doc: /* Return t if OBJECT is a list, that is, a cons cell or nil.
-Otherwise, return nil. */)
+Otherwise, return nil. */
+ attributes: const)
(Lisp_Object object)
{
if (CONSP (object) || NILP (object))
@@ -291,7 +296,8 @@ Otherwise, return nil. */)
}
DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
- doc: /* Return t if OBJECT is not a list. Lists include nil. */)
+ doc: /* Return t if OBJECT is not a list. Lists include nil. */
+ attributes: const)
(Lisp_Object object)
{
if (CONSP (object) || NILP (object))
@@ -300,7 +306,8 @@ DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
}
DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
- doc: /* Return t if OBJECT is a symbol. */)
+ doc: /* Return t if OBJECT is a symbol. */
+ attributes: const)
(Lisp_Object object)
{
if (SYMBOLP (object))
@@ -333,7 +340,8 @@ DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
}
DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
- doc: /* Return t if OBJECT is a string. */)
+ doc: /* Return t if OBJECT is a string. */
+ attributes: const)
(Lisp_Object object)
{
if (STRINGP (object))
@@ -436,7 +444,8 @@ DEFUN ("byte-code-function-p", Fbyte_code_function_p,
Sbyte_code_function_p,
}
DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
- doc: /* Return t if OBJECT is a character or a string. */)
+ doc: /* Return t if OBJECT is a character or a string. */
+ attributes: const)
(register Lisp_Object object)
{
if (CHARACTERP (object) || STRINGP (object))
@@ -445,7 +454,8 @@ DEFUN ("char-or-string-p", Fchar_or_string_p,
Schar_or_string_p, 1, 1, 0,
}
DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0,
- doc: /* Return t if OBJECT is an integer. */)
+ doc: /* Return t if OBJECT is an integer. */
+ attributes: const)
(Lisp_Object object)
{
if (INTEGERP (object))
@@ -463,7 +473,8 @@ DEFUN ("integer-or-marker-p", Finteger_or_marker_p,
Sinteger_or_marker_p, 1, 1,
}
DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
- doc: /* Return t if OBJECT is a nonnegative integer. */)
+ doc: /* Return t if OBJECT is a nonnegative integer. */
+ attributes: const)
(Lisp_Object object)
{
if (NATNUMP (object))
@@ -472,7 +483,8 @@ DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
}
DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
- doc: /* Return t if OBJECT is a number (floating point or integer). */)
+ doc: /* Return t if OBJECT is a number (floating point or integer). */
+ attributes: const)
(Lisp_Object object)
{
if (NUMBERP (object))
@@ -492,7 +504,8 @@ DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
}
DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
- doc: /* Return t if OBJECT is a floating point number. */)
+ doc: /* Return t if OBJECT is a floating point number. */
+ attributes: const)
(Lisp_Object object)
{
if (FLOATP (object))
@@ -2954,7 +2967,8 @@ DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0,
doc: /* Return the byteorder for the machine.
Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
-lowercase l) for small endian machines. */)
+lowercase l) for small endian machines. */
+ attributes: const)
(void)
{
unsigned i = 0x04030201;
diff --git a/src/decompress.c b/src/decompress.c
index b14f0a2..b78dace 100644
--- a/src/decompress.c
+++ b/src/decompress.c
@@ -88,7 +88,8 @@ unwind_decompress (void *ddata)
}
DEFUN ("zlib-available-p", Fzlib_available_p, Szlib_available_p, 0, 0, 0,
- doc: /* Return t if zlib decompression is available in this instance of
Emacs. */)
+ doc: /* Return t if zlib decompression is available in this instance of
Emacs. */
+ attributes: const)
(void)
{
#ifdef WINDOWSNT
diff --git a/src/dired.c b/src/dired.c
index 00f9a5b..ca43cd9 100644
--- a/src/dired.c
+++ b/src/dired.c
@@ -176,10 +176,8 @@ directory_files_internal (Lisp_Object directory,
Lisp_Object full,
/* Note: ENCODE_FILE and DECODE_FILE can GC because they can run
run_pre_post_conversion_on_str which calls Lisp directly and
indirectly. */
- if (STRING_MULTIBYTE (dirfilename))
- dirfilename = ENCODE_FILE (dirfilename);
- encoded_directory = (STRING_MULTIBYTE (directory)
- ? ENCODE_FILE (directory) : directory);
+ dirfilename = ENCODE_FILE (dirfilename);
+ encoded_directory = ENCODE_FILE (directory);
/* Now *bufp is the compiled form of MATCH; don't call anything
which might compile a new regexp until we're done with the loop! */
@@ -482,7 +480,7 @@ file_name_completion (Lisp_Object file, Lisp_Object
dirname, bool all_flag,
/* Actually, this is not quite true any more: we do most of the completion
work with decoded file names, but we still do some filtering based
on the encoded file name. */
- encoded_file = STRING_MULTIBYTE (file) ? ENCODE_FILE (file) : file;
+ encoded_file = ENCODE_FILE (file);
encoded_dir = ENCODE_FILE (Fdirectory_file_name (dirname));
@@ -634,23 +632,14 @@ file_name_completion (Lisp_Object file, Lisp_Object
dirname, bool all_flag,
name = DECODE_FILE (name);
{
- Lisp_Object regexps;
+ Lisp_Object regexps, table = (completion_ignore_case
+ ? Vascii_canon_table : Qnil);
/* Ignore this element if it fails to match all the regexps. */
- if (completion_ignore_case)
- {
- for (regexps = Vcompletion_regexp_list; CONSP (regexps);
- regexps = XCDR (regexps))
- if (fast_string_match_ignore_case (XCAR (regexps), name) < 0)
- break;
- }
- else
- {
- for (regexps = Vcompletion_regexp_list; CONSP (regexps);
- regexps = XCDR (regexps))
- if (fast_string_match (XCAR (regexps), name) < 0)
- break;
- }
+ for (regexps = Vcompletion_regexp_list; CONSP (regexps);
+ regexps = XCDR (regexps))
+ if (fast_string_match_internal (XCAR (regexps), name, table) < 0)
+ break;
if (CONSP (regexps))
continue;
diff --git a/src/dispnew.c b/src/dispnew.c
index bb75973..bfa06bd 100644
--- a/src/dispnew.c
+++ b/src/dispnew.c
@@ -5536,7 +5536,8 @@ change_frame_size_1 (struct frame *f, int new_width, int
new_height,
/* Adjust frame size but make sure x_set_window_size does not
get called. */
- adjust_frame_size (f, new_width, new_height, 5, pretend, Qnil);
+ adjust_frame_size (f, new_width, new_height, 5, pretend,
+ Qchange_frame_size);
}
}
diff --git a/src/editfns.c b/src/editfns.c
index cd15f65..621e841 100644
--- a/src/editfns.c
+++ b/src/editfns.c
@@ -2063,6 +2063,29 @@ check_tm_member (Lisp_Object obj, int offset)
return n - offset;
}
+/* Decode ZONE as a time zone specification. */
+
+static Lisp_Object
+decode_time_zone (Lisp_Object zone)
+{
+ if (EQ (zone, Qt))
+ return build_string ("UTC0");
+ else if (STRINGP (zone))
+ return zone;
+ else if (INTEGERP (zone))
+ {
+ static char const tzbuf_format[] = "XXX%s%"pI"d:%02d:%02d";
+ char tzbuf[sizeof tzbuf_format + INT_STRLEN_BOUND (EMACS_INT)];
+ EMACS_INT abszone = eabs (XINT (zone)), zone_hr = abszone / (60 * 60);
+ int zone_min = (abszone / 60) % 60, zone_sec = abszone % 60;
+
+ return make_formatted_string (tzbuf, tzbuf_format, &"-"[XINT (zone) < 0],
+ zone_hr, zone_min, zone_sec);
+ }
+ else
+ xsignal2 (Qerror, build_string ("Invalid time zone specification"), zone);
+}
+
DEFUN ("encode-time", Fencode_time, Sencode_time, 6, MANY, 0,
doc: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to
internal time.
This is the reverse operation of `decode-time', which see.
@@ -2105,30 +2128,7 @@ usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR
&optional ZONE) */)
value = mktime (&tm);
else
{
- static char const tzbuf_format[] = "XXX%s%"pI"d:%02d:%02d";
- char tzbuf[sizeof tzbuf_format + INT_STRLEN_BOUND (EMACS_INT)];
- const char *tzstring;
-
- if (EQ (zone, Qt))
- tzstring = "UTC0";
- else if (STRINGP (zone))
- tzstring = SSDATA (zone);
- else if (INTEGERP (zone))
- {
- EMACS_INT abszone = eabs (XINT (zone));
- EMACS_INT zone_hr = abszone / (60*60);
- int zone_min = (abszone/60) % 60;
- int zone_sec = abszone % 60;
- sprintf (tzbuf, tzbuf_format, &"-"[XINT (zone) < 0],
- zone_hr, zone_min, zone_sec);
- tzstring = tzbuf;
- }
- else
- tzstring = 0;
-
- timezone_t tz = tzstring ? tzalloc (tzstring) : 0;
- if (! tz)
- error ("Invalid time zone specification");
+ timezone_t tz = tzalloc (SSDATA (decode_time_zone (zone)));
value = mktime_z (tz, &tm);
tzfree (tz);
}
@@ -2265,7 +2265,8 @@ the data it can't find. */)
DEFUN ("set-time-zone-rule", Fset_time_zone_rule, Sset_time_zone_rule, 1, 1, 0,
doc: /* Set the local time zone using TZ, a string specifying a time
zone rule.
If TZ is nil, use implementation-defined default time zone information.
-If TZ is t, use Universal Time.
+If TZ is t, use Universal Time. If TZ is an integer, it is treated as in
+`encode-time'.
Instead of calling this function, you typically want (setenv "TZ" TZ).
That changes both the environment of the Emacs process and the
@@ -2273,17 +2274,7 @@ variable `process-environment', whereas
`set-time-zone-rule' affects
only the former. */)
(Lisp_Object tz)
{
- const char *tzstring;
-
- if (! (NILP (tz) || EQ (tz, Qt)))
- CHECK_STRING (tz);
-
- if (NILP (tz))
- tzstring = initial_tz;
- else if (EQ (tz, Qt))
- tzstring = "UTC0";
- else
- tzstring = SSDATA (tz);
+ const char *tzstring = NILP (tz) ? initial_tz : SSDATA (decode_time_zone
(tz));
block_input ();
set_time_zone_rule (tzstring);
@@ -2633,15 +2624,34 @@ make_buffer_string_both (ptrdiff_t start, ptrdiff_t
start_byte,
ptrdiff_t end, ptrdiff_t end_byte, bool props)
{
Lisp_Object result, tem, tem1;
+ ptrdiff_t beg0, end0, beg1, end1, size;
- if (start < GPT && GPT < end)
- move_gap_both (start, start_byte);
+ if (start_byte < GPT_BYTE && GPT_BYTE < end_byte)
+ {
+ /* Two regions, before and after the gap. */
+ beg0 = start_byte;
+ end0 = GPT_BYTE;
+ beg1 = GPT_BYTE + GAP_SIZE - BEG_BYTE;
+ end1 = end_byte + GAP_SIZE - BEG_BYTE;
+ }
+ else
+ {
+ /* The only region. */
+ beg0 = start_byte;
+ end0 = end_byte;
+ beg1 = -1;
+ end1 = -1;
+ }
if (! NILP (BVAR (current_buffer, enable_multibyte_characters)))
result = make_uninit_multibyte_string (end - start, end_byte - start_byte);
else
result = make_uninit_string (end - start);
- memcpy (SDATA (result), BYTE_POS_ADDR (start_byte), end_byte - start_byte);
+
+ size = end0 - beg0;
+ memcpy (SDATA (result), BYTE_POS_ADDR (beg0), size);
+ if (beg1 != -1)
+ memcpy (SDATA (result) + size, BEG_ADDR + beg1, end1 - beg1);
/* If desired, update and copy the text properties. */
if (props)
diff --git a/src/emacs.c b/src/emacs.c
index e7094b1..d83311a 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -1898,7 +1898,8 @@ or SIGHUP, and upon SIGINT in batch mode.
The value of `kill-emacs-hook', if not void,
is a list of functions (of no args),
-all of which are called before Emacs is actually killed. */)
+all of which are called before Emacs is actually killed. */
+ attributes: noreturn)
(Lisp_Object arg)
{
struct gcpro gcpro1;
diff --git a/src/eval.c b/src/eval.c
index 7e4b016..5cadb1b 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1162,7 +1162,8 @@ unwind_to_catch (struct handler *catch, Lisp_Object value)
DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0,
doc: /* Throw to the catch for TAG and return VALUE from it.
-Both TAG and VALUE are evalled. */)
+Both TAG and VALUE are evalled. */
+ attributes: noreturn)
(register Lisp_Object tag, Lisp_Object value)
{
struct handler *c;
diff --git a/src/fileio.c b/src/fileio.c
index 15c6f91..6c443c9 100644
--- a/src/fileio.c
+++ b/src/fileio.c
@@ -522,8 +522,6 @@ For a Unix-syntax file name, just appends a slash. */)
USE_SAFE_ALLOCA;
CHECK_STRING (file);
- if (NILP (file))
- return Qnil;
/* If the file name has special constructs in it,
call the corresponding file handler. */
@@ -591,9 +589,6 @@ In Unix-syntax, this function just removes the final slash.
*/)
CHECK_STRING (directory);
- if (NILP (directory))
- return Qnil;
-
/* If the file name has special constructs in it,
call the corresponding file handler. */
handler = Ffind_file_name_handler (directory, Qdirectory_file_name);
@@ -5738,8 +5733,8 @@ then any auto-save counts as "recent". */)
they're never autosaved. */
return (SAVE_MODIFF < BUF_AUTOSAVE_MODIFF (current_buffer) ? Qt : Qnil);
}
-
-/* Reading and completing file names */
+
+/* Reading and completing file names. */
DEFUN ("next-read-file-uses-dialog-p", Fnext_read_file_uses_dialog_p,
Snext_read_file_uses_dialog_p, 0, 0, 0,
@@ -5748,8 +5743,8 @@ The return value is only relevant for a call to
`read-file-name' that happens
before any other event (mouse or keypress) is handled. */)
(void)
{
-#if defined (USE_MOTIF) || defined (HAVE_NTGUI) || defined (USE_GTK) \
- || defined (HAVE_NS)
+#if (defined USE_GTK || defined USE_MOTIF \
+ || defined HAVE_NS || defined HAVE_NTGUI)
if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
&& use_dialog_box
&& use_file_dialog
diff --git a/src/fns.c b/src/fns.c
index 7739663..91cd513 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -46,7 +46,8 @@ static void sort_vector_copy (Lisp_Object, ptrdiff_t,
static bool internal_equal (Lisp_Object, Lisp_Object, int, bool, Lisp_Object);
DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
- doc: /* Return the argument unchanged. */)
+ doc: /* Return the argument unchanged. */
+ attributes: const)
(Lisp_Object arg)
{
return arg;
diff --git a/src/frame.c b/src/frame.c
index 3d2ffbf..ec580f3 100644
--- a/src/frame.c
+++ b/src/frame.c
@@ -67,6 +67,9 @@ static struct frame *last_nonminibuf_frame;
/* False means there are no visible garbaged frames. */
bool frame_garbaged;
+/* The default tool bar height for future frames. */
+int frame_default_tool_bar_height;
+
#ifdef HAVE_WINDOW_SYSTEM
static void x_report_frame_params (struct frame *, Lisp_Object *);
#endif
@@ -267,7 +270,8 @@ predicates which report frame's specific UI-related
capabilities. */)
/* Placeholder used by temacs -nw before window.el is loaded. */
DEFUN ("frame-windows-min-size", Fframe_windows_min_size,
Sframe_windows_min_size, 4, 4, 0,
- doc: /* */)
+ doc: /* */
+ attributes: const)
(Lisp_Object frame, Lisp_Object horizontal,
Lisp_Object ignore, Lisp_Object pixelwise)
{
@@ -331,6 +335,8 @@ adjust_frame_size (struct frame *f, int new_width, int
new_height, int inhibit,
int unit_height = FRAME_LINE_HEIGHT (f);
int old_pixel_width = FRAME_PIXEL_WIDTH (f);
int old_pixel_height = FRAME_PIXEL_HEIGHT (f);
+ int old_cols = FRAME_COLS (f);
+ int old_lines = FRAME_LINES (f);
int new_pixel_width, new_pixel_height;
/* The following two values are calculated from the old frame pixel
sizes and any "new" settings for tool bar, menu bar and internal
@@ -358,6 +364,20 @@ adjust_frame_size (struct frame *f, int new_width, int
new_height, int inhibit,
Lisp_Object frame;
XSETFRAME (frame, f);
+
+ /* `make-frame' initializes Vframe_adjust_size_history to (Qt) and
+ strips its car when exiting. Just in case make sure its size never
+ exceeds 100. */
+ if (!NILP (Fconsp (Vframe_adjust_size_history))
+ && EQ (Fcar (Vframe_adjust_size_history), Qt)
+ && XFASTINT (Fsafe_length (Vframe_adjust_size_history)) <= 100)
+ Vframe_adjust_size_history =
+ Fcons (Qt, Fcons (list5 (make_number (0),
+ make_number (new_text_width),
+ make_number (new_text_height),
+ make_number (inhibit), parameter),
+ Fcdr (Vframe_adjust_size_history)));
+
/* The following two values are calculated from the old window body
sizes and any "new" settings for scroll bars, dividers, fringes and
margins (though the latter should have been processed already). */
@@ -425,6 +445,17 @@ adjust_frame_size (struct frame *f, int new_width, int
new_height, int inhibit,
else if (inhibit_vertical)
new_text_height = old_text_height;
+ if (!NILP (Fconsp (Vframe_adjust_size_history))
+ && EQ (Fcar (Vframe_adjust_size_history), Qt)
+ && XFASTINT (Fsafe_length (Vframe_adjust_size_history)) <= 100)
+ Vframe_adjust_size_history =
+ Fcons (Qt, Fcons (list5 (make_number (1),
+ make_number (new_text_width),
+ make_number (new_text_height),
+ make_number (new_cols),
+ make_number (new_lines)),
+ Fcdr (Vframe_adjust_size_history)));
+
x_set_window_size (f, 0, new_text_width, new_text_height, 1);
f->resized_p = true;
@@ -437,7 +468,9 @@ adjust_frame_size (struct frame *f, int new_width, int
new_height, int inhibit,
&& new_windows_width == old_windows_width
&& new_windows_height == old_windows_height
&& new_pixel_width == old_pixel_width
- && new_pixel_height == old_pixel_height)
+ && new_pixel_height == old_pixel_height
+ && new_cols == old_cols
+ && new_lines == old_lines)
/* No change. Sanitize window sizes and return. */
{
sanitize_window_sizes (frame, Qt);
@@ -496,6 +529,17 @@ adjust_frame_size (struct frame *f, int new_width, int
new_height, int inhibit,
SET_FRAME_COLS (f, new_cols);
SET_FRAME_LINES (f, new_lines);
+ if (!NILP (Fconsp (Vframe_adjust_size_history))
+ && EQ (Fcar (Vframe_adjust_size_history), Qt)
+ && XFASTINT (Fsafe_length (Vframe_adjust_size_history)) <= 100)
+ Vframe_adjust_size_history =
+ Fcons (Qt, Fcons (list5 (make_number (2),
+ make_number (new_text_width),
+ make_number (new_text_height),
+ make_number (new_cols),
+ make_number (new_lines)),
+ Fcdr (Vframe_adjust_size_history)));
+
{
struct window *w = XWINDOW (FRAME_SELECTED_WINDOW (f));
int text_area_x, text_area_y, text_area_width, text_area_height;
@@ -554,6 +598,7 @@ make_frame (bool mini_p)
f->garbaged = true;
f->can_x_set_window_size = false;
f->can_run_window_configuration_change_hook = false;
+ f->tool_bar_redisplayed_once = false;
f->column_width = 1; /* !FRAME_WINDOW_P value. */
f->line_height = 1; /* !FRAME_WINDOW_P value. */
#ifdef HAVE_WINDOW_SYSTEM
@@ -2808,7 +2853,7 @@ DEFUN ("frame-bottom-divider-width",
Fbottom_divider_width, Sbottom_divider_widt
}
DEFUN ("set-frame-height", Fset_frame_height, Sset_frame_height, 2, 4, 0,
- doc: /* Set height of frame FRAME to HEIGHT lines.
+ doc: /* Set text height of frame FRAME to HEIGHT lines.
Optional third arg PRETEND non-nil means that redisplay should use
HEIGHT lines but that the idea of the actual height of the frame should
not be changed.
@@ -2827,14 +2872,13 @@ multiple of the default frame font height. */)
pixel_height = (!NILP (pixelwise)
? XINT (height)
: XINT (height) * FRAME_LINE_HEIGHT (f));
- if (pixel_height != FRAME_TEXT_HEIGHT (f))
- adjust_frame_size (f, -1, pixel_height, 1, !NILP (pretend), Qheight);
+ adjust_frame_size (f, -1, pixel_height, 1, !NILP (pretend), Qheight);
return Qnil;
}
DEFUN ("set-frame-width", Fset_frame_width, Sset_frame_width, 2, 4, 0,
- doc: /* Set width of frame FRAME to WIDTH columns.
+ doc: /* Set text width of frame FRAME to WIDTH columns.
Optional third arg PRETEND non-nil means that redisplay should use WIDTH
columns but that the idea of the actual width of the frame should not
be changed.
@@ -2853,14 +2897,13 @@ multiple of the default frame font width. */)
pixel_width = (!NILP (pixelwise)
? XINT (width)
: XINT (width) * FRAME_COLUMN_WIDTH (f));
- if (pixel_width != FRAME_TEXT_WIDTH (f))
- adjust_frame_size (f, pixel_width, -1, 1, !NILP (pretend), Qwidth);
+ adjust_frame_size (f, pixel_width, -1, 1, !NILP (pretend), Qwidth);
return Qnil;
}
DEFUN ("set-frame-size", Fset_frame_size, Sset_frame_size, 3, 4, 0,
- doc: /* Set size of FRAME to WIDTH by HEIGHT, measured in characters.
+ doc: /* Set text size of FRAME to WIDTH by HEIGHT, measured in
characters.
Optional argument PIXELWISE non-nil means to measure in pixels. Note:
When `frame-resize-pixelwise' is nil, some window managers may refuse to
honor a WIDTH that is not an integer multiple of the default frame font
@@ -2880,10 +2923,7 @@ font height. */)
pixel_height = (!NILP (pixelwise)
? XINT (height)
: XINT (height) * FRAME_LINE_HEIGHT (f));
-
- if (pixel_width != FRAME_TEXT_WIDTH (f)
- || pixel_height != FRAME_TEXT_HEIGHT (f))
- adjust_frame_size (f, pixel_width, pixel_height, 1, 0, Qsize);
+ adjust_frame_size (f, pixel_width, pixel_height, 1, 0, Qsize);
return Qnil;
}
@@ -4492,23 +4532,27 @@ x_figure_window_size (struct frame *f, Lisp_Object
parms, bool toolbar_p)
frames without having to guess how tall the tool bar will get. */
if (toolbar_p && FRAME_TOOL_BAR_LINES (f))
{
- int margin, relief;
+ if (frame_default_tool_bar_height)
+ FRAME_TOOL_BAR_HEIGHT (f) = frame_default_tool_bar_height;
+ else
+ {
+ int margin, relief;
- relief = (tool_bar_button_relief >= 0
- ? tool_bar_button_relief
- : DEFAULT_TOOL_BAR_BUTTON_RELIEF);
+ relief = (tool_bar_button_relief >= 0
+ ? tool_bar_button_relief
+ : DEFAULT_TOOL_BAR_BUTTON_RELIEF);
- if (RANGED_INTEGERP (1, Vtool_bar_button_margin, INT_MAX))
- margin = XFASTINT (Vtool_bar_button_margin);
- else if (CONSP (Vtool_bar_button_margin)
- && RANGED_INTEGERP (1, XCDR (Vtool_bar_button_margin), INT_MAX))
- margin = XFASTINT (XCDR (Vtool_bar_button_margin));
- else
- margin = 0;
+ if (RANGED_INTEGERP (1, Vtool_bar_button_margin, INT_MAX))
+ margin = XFASTINT (Vtool_bar_button_margin);
+ else if (CONSP (Vtool_bar_button_margin)
+ && RANGED_INTEGERP (1, XCDR (Vtool_bar_button_margin),
INT_MAX))
+ margin = XFASTINT (XCDR (Vtool_bar_button_margin));
+ else
+ margin = 0;
- FRAME_TOOL_BAR_HEIGHT (f)
- = DEFAULT_TOOL_BAR_IMAGE_HEIGHT + 2 * margin + 2 * relief;
- Vframe_initial_frame_tool_bar_height = make_number
(FRAME_TOOL_BAR_HEIGHT (f));
+ FRAME_TOOL_BAR_HEIGHT (f)
+ = DEFAULT_TOOL_BAR_IMAGE_HEIGHT + 2 * margin + 2 * relief;
+ }
}
top = x_get_arg (dpyinfo, parms, Qtop, 0, 0, RES_TYPE_NUMBER);
@@ -4779,6 +4823,11 @@ syms_of_frame (void)
DEFSYM (Qtool_bar_external, "tool-bar-external");
DEFSYM (Qtool_bar_size, "tool-bar-size");
DEFSYM (Qframe_inner_size, "frame-inner-size");
+ DEFSYM (Qchange_frame_size, "change-frame-size");
+ DEFSYM (Qxg_frame_set_char_size, "xg-frame-set-char-size");
+ DEFSYM (Qset_window_configuration, "set-window-configuration");
+ DEFSYM (Qx_create_frame_1, "x-create-frame-1");
+ DEFSYM (Qx_create_frame_2, "x-create-frame-2");
#ifdef HAVE_NS
DEFSYM (Qns_parse_geometry, "ns-parse-geometry");
@@ -4968,10 +5017,6 @@ or call the function `tool-bar-mode'. */);
Vtool_bar_mode = Qnil;
#endif
- DEFVAR_LISP ("frame-initial-frame-tool-bar-height",
Vframe_initial_frame_tool_bar_height,
- doc: /* Height of tool bar of initial frame. */);
- Vframe_initial_frame_tool_bar_height = make_number (0);
-
DEFVAR_KBOARD ("default-minibuffer-frame", Vdefault_minibuffer_frame,
doc: /* Minibufferless frames use this frame's minibuffer.
Emacs cannot create minibufferless frames unless this is set to an
@@ -5050,6 +5095,10 @@ even if this option is non-nil. */);
frame_inhibit_implied_resize = Qt;
#endif
+ DEFVAR_LISP ("frame-adjust-size-history", Vframe_adjust_size_history,
+ doc: /* History of frame size adjustments. */);
+ Vframe_adjust_size_history = Qnil;
+
staticpro (&Vframe_list);
defsubr (&Sframep);
diff --git a/src/frame.h b/src/frame.h
index d1ed4d4..cb0044c 100644
--- a/src/frame.h
+++ b/src/frame.h
@@ -336,6 +336,10 @@ struct frame
for this frame. */
bool_bf can_run_window_configuration_change_hook : 1;
+ /* True means tool bar has been redisplayed at least once in current
+ session. */
+ bool_bf tool_bar_redisplayed_once : 1;
+
/* Bitfield area ends here. */
/* Number of lines (rounded up) of tool bar. REMOVE THIS */
@@ -1096,6 +1100,8 @@ SET_FRAME_VISIBLE (struct frame *f, int v)
extern Lisp_Object selected_frame;
+extern int frame_default_tool_bar_height;
+
extern struct frame *decode_window_system_frame (Lisp_Object);
extern struct frame *decode_live_frame (Lisp_Object);
extern struct frame *decode_any_frame (Lisp_Object);
diff --git a/src/gnutls.c b/src/gnutls.c
index 75fe614..5e6c635 100644
--- a/src/gnutls.c
+++ b/src/gnutls.c
@@ -695,7 +695,8 @@ See also `gnutls-boot'. */)
DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0,
doc: /* Return t if ERROR indicates a GnuTLS problem.
ERROR is an integer or a symbol with an integer `gnutls-code' property.
-usage: (gnutls-errorp ERROR) */)
+usage: (gnutls-errorp ERROR) */
+ attributes: const)
(Lisp_Object err)
{
if (EQ (err, Qt)) return Qnil;
@@ -1603,7 +1604,8 @@ This function may also return `gnutls-e-again', or
#endif /* HAVE_GNUTLS */
DEFUN ("gnutls-available-p", Fgnutls_available_p, Sgnutls_available_p, 0, 0, 0,
- doc: /* Return t if GnuTLS is available in this instance of Emacs. */)
+ doc: /* Return t if GnuTLS is available in this instance of Emacs. */
+ attributes: const)
(void)
{
#ifdef HAVE_GNUTLS
diff --git a/src/gtkutil.c b/src/gtkutil.c
index bedac84..694278a 100644
--- a/src/gtkutil.c
+++ b/src/gtkutil.c
@@ -954,7 +954,7 @@ xg_frame_set_char_size (struct frame *f, int width, int
height)
x_wait_for_event (f, ConfigureNotify);
}
else
- adjust_frame_size (f, -1, -1, 5, 0, Qnil);
+ adjust_frame_size (f, -1, -1, 5, 0, Qxg_frame_set_char_size);
}
/* Handle height/width changes (i.e. add/remove/move menu/toolbar).
diff --git a/src/image.c b/src/image.c
index 5d08a89..9c09c55 100644
--- a/src/image.c
+++ b/src/image.c
@@ -9288,7 +9288,8 @@ DEFUN ("imagep", Fimagep, Simagep, 1, 1, 0,
}
-DEFUN ("lookup-image", Flookup_image, Slookup_image, 1, 1, 0, "")
+DEFUN ("lookup-image", Flookup_image, Slookup_image, 1, 1, 0,
+ doc: /* */)
(Lisp_Object spec)
{
ptrdiff_t id = -1;
diff --git a/src/keyboard.c b/src/keyboard.c
index 6afbd5d..dbae12b 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -1163,7 +1163,8 @@ top_level_1 (Lisp_Object ignore)
DEFUN ("top-level", Ftop_level, Stop_level, 0, 0, "",
doc: /* Exit all recursive editing levels.
-This also exits all active minibuffers. */)
+This also exits all active minibuffers. */
+ attributes: noreturn)
(void)
{
#ifdef HAVE_WINDOW_SYSTEM
@@ -1186,7 +1187,8 @@ user_error (const char *msg)
/* _Noreturn will be added to prototype by make-docfile. */
DEFUN ("exit-recursive-edit", Fexit_recursive_edit, Sexit_recursive_edit, 0,
0, "",
- doc: /* Exit from the innermost recursive edit or minibuffer. */)
+ doc: /* Exit from the innermost recursive edit or minibuffer. */
+ attributes: noreturn)
(void)
{
if (command_loop_level > 0 || minibuf_level > 0)
@@ -1197,7 +1199,8 @@ DEFUN ("exit-recursive-edit", Fexit_recursive_edit,
Sexit_recursive_edit, 0, 0,
/* _Noreturn will be added to prototype by make-docfile. */
DEFUN ("abort-recursive-edit", Fabort_recursive_edit, Sabort_recursive_edit,
0, 0, "",
- doc: /* Abort the command that requested this recursive edit or
minibuffer input. */)
+ doc: /* Abort the command that requested this recursive edit or
minibuffer input. */
+ attributes: noreturn)
(void)
{
if (command_loop_level > 0 || minibuf_level > 0)
@@ -6293,10 +6296,10 @@ apply_modifiers_uncached (int modifiers, char *base,
int base_len, int base_len_
if (modifiers & meta_modifier) { *p++ = 'M'; *p++ = '-'; }
if (modifiers & shift_modifier) { *p++ = 'S'; *p++ = '-'; }
if (modifiers & super_modifier) { *p++ = 's'; *p++ = '-'; }
- if (modifiers & double_modifier) { strcpy (p, "double-"); p += 7; }
- if (modifiers & triple_modifier) { strcpy (p, "triple-"); p += 7; }
- if (modifiers & down_modifier) { strcpy (p, "down-"); p += 5; }
- if (modifiers & drag_modifier) { strcpy (p, "drag-"); p += 5; }
+ if (modifiers & double_modifier) p = stpcpy (p, "double-");
+ if (modifiers & triple_modifier) p = stpcpy (p, "triple-");
+ if (modifiers & down_modifier) p = stpcpy (p, "down-");
+ if (modifiers & drag_modifier) p = stpcpy (p, "drag-");
/* The click modifier is denoted by the absence of other modifiers. */
*p = '\0';
diff --git a/src/lisp.h b/src/lisp.h
index 9e1f150..b6608da 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -610,7 +610,6 @@ INLINE bool (VECTORLIKEP) (Lisp_Object);
INLINE bool WINDOWP (Lisp_Object);
INLINE struct Lisp_Save_Value *XSAVE_VALUE (Lisp_Object);
INLINE struct Lisp_Symbol *(XSYMBOL) (Lisp_Object);
-INLINE enum Lisp_Type (XTYPE) (Lisp_Object);
INLINE void *(XUNTAG) (Lisp_Object, int);
/* Defined in chartab.c. */
@@ -825,9 +824,6 @@ DEFINE_GDB_SYMBOL_END (VALMASK)
#define MOST_POSITIVE_FIXNUM (EMACS_INT_MAX >> INTTYPEBITS)
#define MOST_NEGATIVE_FIXNUM (-1 - MOST_POSITIVE_FIXNUM)
-/* Extract the pointer hidden within A. */
-LISP_MACRO_DEFUN (XPNTR, void *, (Lisp_Object a), (a))
-
#if USE_LSB_TAG
LISP_MACRO_DEFUN (make_number, Lisp_Object, (EMACS_INT n), (n))
@@ -917,6 +913,9 @@ XUNTAG (Lisp_Object a, int type)
#endif /* ! USE_LSB_TAG */
+/* Extract the pointer hidden within A. */
+LISP_MACRO_DEFUN (XPNTR, void *, (Lisp_Object a), (a))
+
/* Extract A's value as an unsigned integer. */
INLINE EMACS_UINT
XUINT (Lisp_Object a)
@@ -1694,10 +1693,9 @@ CHAR_TABLE_EXTRA_SLOTS (struct Lisp_Char_Table *ct)
- CHAR_TABLE_STANDARD_SLOTS);
}
-/* Make sure that sub char-table contents slot
- is aligned on a multiple of Lisp_Objects. */
-verify ((offsetof (struct Lisp_Sub_Char_Table, contents)
- - offsetof (struct Lisp_Sub_Char_Table, depth)) % word_size == 0);
+/* Make sure that sub char-table contents slot is where we think it is. */
+verify (offsetof (struct Lisp_Sub_Char_Table, contents)
+ == offsetof (struct Lisp_Vector, contents[SUB_CHAR_TABLE_OFFSET]));
/***********************************************************************
Symbols
@@ -4060,10 +4058,23 @@ struct re_registers;
extern struct re_pattern_buffer *compile_pattern (Lisp_Object,
struct re_registers *,
Lisp_Object, bool, bool);
-extern ptrdiff_t fast_string_match (Lisp_Object, Lisp_Object);
+extern ptrdiff_t fast_string_match_internal (Lisp_Object, Lisp_Object,
+ Lisp_Object);
+
+INLINE ptrdiff_t
+fast_string_match (Lisp_Object regexp, Lisp_Object string)
+{
+ return fast_string_match_internal (regexp, string, Qnil);
+}
+
+INLINE ptrdiff_t
+fast_string_match_ignore_case (Lisp_Object regexp, Lisp_Object string)
+{
+ return fast_string_match_internal (regexp, string, Vascii_canon_table);
+}
+
extern ptrdiff_t fast_c_string_match_ignore_case (Lisp_Object, const char *,
ptrdiff_t);
-extern ptrdiff_t fast_string_match_ignore_case (Lisp_Object, Lisp_Object);
extern ptrdiff_t fast_looking_at (Lisp_Object, ptrdiff_t, ptrdiff_t,
ptrdiff_t, ptrdiff_t, Lisp_Object);
extern ptrdiff_t find_newline (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t,
diff --git a/src/nsfns.m b/src/nsfns.m
index 828ee88..cc2e496 100644
--- a/src/nsfns.m
+++ b/src/nsfns.m
@@ -1251,7 +1251,8 @@ This function is an internal primitive--use `make-frame'
instead. */)
/* Read comment about this code in corresponding place in xfns.c. */
adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f),
- FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, 1, Qnil);
+ FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, 1,
+ Qx_create_frame_1);
/* The resources controlling the menu-bar and tool-bar are
processed specially at startup, and reflected in the mode
@@ -1325,7 +1326,8 @@ This function is an internal primitive--use `make-frame'
instead. */)
/* Allow x_set_window_size, now. */
f->can_x_set_window_size = true;
- adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), 0, 1,
Qnil);
+ adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), 0, 1,
+ Qx_create_frame_2);
if (! f->output_data.ns->explicit_parent)
{
diff --git a/src/process.c b/src/process.c
index 9015383..77c94f2 100644
--- a/src/process.c
+++ b/src/process.c
@@ -1517,11 +1517,8 @@ usage: (start-process NAME BUFFER PROGRAM &rest
PROGRAM-ARGS) */)
tem = program;
}
- /* If program file name starts with /: for quoting a magic name,
- discard that. */
- if (SBYTES (tem) > 2 && SREF (tem, 0) == '/'
- && SREF (tem, 1) == ':')
- tem = Fsubstring (tem, make_number (2), Qnil);
+ /* Remove "/:" from TEM. */
+ tem = remove_slash_colon (tem);
{
Lisp_Object arg_encoding = Qnil;
@@ -3830,6 +3827,18 @@ Data that is unavailable is returned as nil. */)
#endif
}
+/* If program file NAME starts with /: for quoting a magic
+ name, remove that, preserving the multibyteness of NAME. */
+
+Lisp_Object
+remove_slash_colon (Lisp_Object name)
+{
+ return
+ ((SBYTES (name) > 2 && SREF (name, 0) == '/' && SREF (name, 1) == ':')
+ ? make_specified_string (SSDATA (name) + 2, SCHARS (name) - 2,
+ SBYTES (name) - 2, STRING_MULTIBYTE (name))
+ : name);
+}
/* Turn off input and output for process PROC. */
diff --git a/src/process.h b/src/process.h
index 7803672..36979dc 100644
--- a/src/process.h
+++ b/src/process.h
@@ -237,4 +237,6 @@ extern Lisp_Object network_interface_list (void);
extern Lisp_Object network_interface_info (Lisp_Object);
#endif
+extern Lisp_Object remove_slash_colon (Lisp_Object);
+
INLINE_HEADER_END
diff --git a/src/search.c b/src/search.c
index 0252542..e961798 100644
--- a/src/search.c
+++ b/src/search.c
@@ -459,17 +459,18 @@ matched by parenthesis constructs in the pattern. */)
return string_match_1 (regexp, string, start, 1);
}
-/* Match REGEXP against STRING, searching all of STRING,
- and return the index of the match, or negative on failure.
- This does not clobber the match data. */
+/* Match REGEXP against STRING using translation table TABLE,
+ searching all of STRING, and return the index of the match,
+ or negative on failure. This does not clobber the match data. */
ptrdiff_t
-fast_string_match (Lisp_Object regexp, Lisp_Object string)
+fast_string_match_internal (Lisp_Object regexp, Lisp_Object string,
+ Lisp_Object table)
{
ptrdiff_t val;
struct re_pattern_buffer *bufp;
- bufp = compile_pattern (regexp, 0, Qnil,
+ bufp = compile_pattern (regexp, 0, table,
0, STRING_MULTIBYTE (string));
immediate_quit = 1;
re_match_object = string;
@@ -504,26 +505,6 @@ fast_c_string_match_ignore_case (Lisp_Object regexp,
return val;
}
-/* Like fast_string_match but ignore case. */
-
-ptrdiff_t
-fast_string_match_ignore_case (Lisp_Object regexp, Lisp_Object string)
-{
- ptrdiff_t val;
- struct re_pattern_buffer *bufp;
-
- bufp = compile_pattern (regexp, 0, Vascii_canon_table,
- 0, STRING_MULTIBYTE (string));
- immediate_quit = 1;
- re_match_object = string;
-
- val = re_search (bufp, SSDATA (string),
- SBYTES (string), 0,
- SBYTES (string), 0);
- immediate_quit = 0;
- return val;
-}
-
/* Match REGEXP against the characters after POS to LIMIT, and return
the number of matched characters. If STRING is non-nil, match
against the characters in it. In that case, POS and LIMIT are
diff --git a/src/w32fns.c b/src/w32fns.c
index 789a91a..2dd92ff 100644
--- a/src/w32fns.c
+++ b/src/w32fns.c
@@ -1744,8 +1744,11 @@ x_change_tool_bar_height (struct frame *f, int height)
/* Recalculate toolbar height. */
f->n_tool_bar_rows = 0;
- adjust_frame_size (f, -1, -1, (old_height == 0 || height == 0) ? 2 : 4, 0,
- Qtool_bar_lines);
+ adjust_frame_size (f, -1, -1,
+ (!f->tool_bar_redisplayed_once ? 1
+ : (old_height == 0 || height == 0) ? 2
+ : 4),
+ 0, Qtool_bar_lines);
/* adjust_frame_size might not have done anything, garbage frame
here. */
@@ -2540,7 +2543,7 @@ w32_msg_pump (deferred_msg * msg_buf)
thread-safe. The next line is okay because the cons
cell is never made into garbage and is not relocated by
GC. */
- XSETCAR (XIL ((EMACS_INT) msg.lParam), Qnil);
+ XSETCAR (make_lisp_ptr ((void *)msg.lParam, Lisp_Cons), Qnil);
if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, 0, 0))
emacs_abort ();
break;
@@ -2548,16 +2551,10 @@ w32_msg_pump (deferred_msg * msg_buf)
{
int vk_code = (int) msg.wParam;
int cur_state = (GetKeyState (vk_code) & 1);
- Lisp_Object new_state = XIL ((EMACS_INT) msg.lParam);
-
- /* NB: This code must be thread-safe. It is safe to
- call NILP because symbols are not relocated by GC,
- and pointer here is not touched by GC (so the markbit
- can't be set). Numbers are safe because they are
- immediate values. */
- if (NILP (new_state)
- || (NUMBERP (new_state)
- && ((XUINT (new_state)) & 1) != cur_state))
+ int new_state = msg.lParam;
+
+ if (new_state == -1
+ || ((new_state & 1) != cur_state))
{
one_w32_display_info.faked_key = vk_code;
@@ -4520,7 +4517,9 @@ This function is an internal primitive--use `make-frame'
instead. */)
/* Specify the parent under which to make this window. */
if (!NILP (parent))
{
- f->output_data.w32->parent_desc = (Window) XFASTINT (parent);
+ /* Cast to UINT_PTR shuts up compiler warnings about cast to
+ pointer from integer of different size. */
+ f->output_data.w32->parent_desc = (Window) (UINT_PTR) XFASTINT (parent);
f->output_data.w32->explicit_parent = 1;
}
else
@@ -4617,7 +4616,8 @@ This function is an internal primitive--use `make-frame'
instead. */)
had one frame line vs one toolbar line which left us with a zero
root window height which was obviously wrong as well ... */
adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f),
- FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, 1, Qnil);
+ FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, 1,
+ Qx_create_frame_1);
/* The X resources controlling the menu-bar and tool-bar are
processed specially at startup, and reflected in the mode
@@ -4685,7 +4685,8 @@ This function is an internal primitive--use `make-frame'
instead. */)
/* Allow x_set_window_size, now. */
f->can_x_set_window_size = true;
- adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), 0, 1,
Qnil);
+ adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), 0, 1,
+ Qx_create_frame_2);
/* Tell the server what size and position, etc, we want, and how
badly we want them. This should be done after we have the menu
@@ -7255,10 +7256,17 @@ DEFUN ("w32-unregister-hot-key",
Fw32_unregister_hot_key,
if (!NILP (item))
{
+ LPARAM lparam;
+
+ eassert (CONSP (item));
+ /* Pass the tail of the list as a pointer to a Lisp_Cons cell,
+ so that it works in a --with-wide-int build as well. */
+ lparam = (LPARAM) XUNTAG (item, Lisp_Cons);
+
/* Notify input thread about hot-key definition being removed, so
that it takes effect without needing focus switch. */
if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_UNREGISTER_HOT_KEY,
- (WPARAM) XINT (XCAR (item)), (LPARAM) XLI (item)))
+ (WPARAM) XINT (XCAR (item)), lparam))
{
MSG msg;
GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
@@ -7313,10 +7321,15 @@ DEFUN ("w32-toggle-lock-key", Fw32_toggle_lock_key,
doc: /* Toggle the state of the lock key KEY.
KEY can be `capslock', `kp-numlock', or `scroll'.
If the optional parameter NEW-STATE is a number, then the state of KEY
-is set to off if the low bit of NEW-STATE is zero, otherwise on. */)
+is set to off if the low bit of NEW-STATE is zero, otherwise on.
+If NEW-STATE is omitted or nil, the function toggles the state,
+
+Value is the new state of the key, or nil if the function failed
+to change the state. */)
(Lisp_Object key, Lisp_Object new_state)
{
int vk_code;
+ LPARAM lparam;
if (EQ (key, intern ("capslock")))
vk_code = VK_CAPITAL;
@@ -7330,8 +7343,12 @@ is set to off if the low bit of NEW-STATE is zero,
otherwise on. */)
if (!dwWindowsThreadId)
return make_number (w32_console_toggle_lock_key (vk_code, new_state));
+ if (NILP (new_state))
+ lparam = -1;
+ else
+ lparam = (XUINT (new_state)) & 1;
if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_TOGGLE_LOCK_KEY,
- (WPARAM) vk_code, (LPARAM) XLI (new_state)))
+ (WPARAM) vk_code, lparam))
{
MSG msg;
GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
diff --git a/src/w32heap.c b/src/w32heap.c
index f683323..d5a9dae 100644
--- a/src/w32heap.c
+++ b/src/w32heap.c
@@ -114,7 +114,7 @@ typedef struct _RTL_HEAP_PARAMETERS {
than half of the size stated below. It would be nice to find a way
to build only the first bootstrap-emacs.exe with the large size,
and reset that to a lower value afterwards. */
-#ifdef _WIN64
+#if defined _WIN64 || defined WIDE_EMACS_INT
# define DUMPED_HEAP_SIZE (18*1024*1024)
#else
# define DUMPED_HEAP_SIZE (11*1024*1024)
diff --git a/src/w32menu.c b/src/w32menu.c
index 7a946d2..2a1dafb 100644
--- a/src/w32menu.c
+++ b/src/w32menu.c
@@ -217,9 +217,9 @@ menubar_selection_callback (struct frame *f, void *
client_data)
else
{
entry = AREF (vector, i + MENU_ITEMS_ITEM_VALUE);
- /* The EMACS_INT cast avoids a warning. There's no problem
+ /* The UINT_PTR cast avoids a warning. There's no problem
as long as pointers have enough bits to hold small integers. */
- if ((int) (EMACS_INT) client_data == i)
+ if ((int) (UINT_PTR) client_data == i)
{
int j;
struct input_event buf;
@@ -501,8 +501,7 @@ set_frame_menubar (struct frame *f, bool first_time, bool
deep_p)
/* Force the window size to be recomputed so that the frame's text
area remains the same, if menubar has just been created. */
if (old_widget == NULL)
- adjust_frame_size (f, FRAME_TEXT_WIDTH (f),
- FRAME_TEXT_HEIGHT (f), 2, 0, Qmenu_bar_lines);
+ adjust_frame_size (f, -1, -1, 2, 0, Qmenu_bar_lines);
}
unblock_input ();
@@ -707,7 +706,7 @@ w32_menu_show (struct frame *f, int x, int y, int menuflags,
wv->key = SSDATA (descrip);
/* Use the contents index as call_data, since we are
restricted to 16-bits. */
- wv->call_data = !NILP (def) ? (void *) (EMACS_INT) i : 0;
+ wv->call_data = !NILP (def) ? (void *) (UINT_PTR) i : 0;
if (NILP (type))
wv->button_type = BUTTON_TYPE_NONE;
@@ -1402,17 +1401,21 @@ add_menu_item (HMENU menu, widget_value *wv, HMENU item)
info.cbSize = sizeof (info);
info.fMask = MIIM_DATA;
- /* Set help string for menu item. Leave it as a Lisp_Object
- until it is ready to be displayed, since GC can happen while
- menus are active. */
+ /* Set help string for menu item. Leave it as a pointer to
+ a Lisp_String until it is ready to be displayed, since GC
+ can happen while menus are active. */
if (!NILP (wv->help))
{
+ /* We use XUNTAG below because in a 32-bit build
+ --with-wide-int we cannot pass a Lisp_Object
+ via a DWORD member of MENUITEMINFO. */
/* As of Jul-2012, w32api headers say that dwItemData
has DWORD type, but that's a bug: it should actually
be ULONG_PTR, which is correct for 32-bit and 64-bit
Windows alike. MSVC headers get it right; hopefully,
MinGW headers will, too. */
- info.dwItemData = (ULONG_PTR) XLI (wv->help);
+ eassert (STRINGP (wv->help));
+ info.dwItemData = (ULONG_PTR) XUNTAG (wv->help, Lisp_String);
}
if (wv->button_type == BUTTON_TYPE_RADIO)
{
@@ -1473,11 +1476,24 @@ w32_menu_display_help (HWND owner, HMENU menu, UINT
item, UINT flags)
struct frame *f = x_window_to_frame (&one_w32_display_info, owner);
Lisp_Object frame, help;
- /* No help echo on owner-draw menu items, or when the keyboard is used
- to navigate the menus, since tooltips are distracting if they pop
- up elsewhere. */
- if (flags & MF_OWNERDRAW || flags & MF_POPUP
- || !(flags & MF_MOUSESELECT))
+ /* No help echo on owner-draw menu items, or when the keyboard
+ is used to navigate the menus, since tooltips are distracting
+ if they pop up elsewhere. */
+ if ((flags & MF_OWNERDRAW) || (flags & MF_POPUP)
+ || !(flags & MF_MOUSESELECT)
+ /* Ignore any dwItemData for menu items whose flags don't
+ have the MF_HILITE bit set. These are dwItemData that
+ Windows sends our way, but they aren't pointers to our
+ Lisp_String objects, so trying to create Lisp_Strings out
+ of them below and pass that to the keyboard queue will
+ crash Emacs when we try to display those "strings". It
+ is unclear why we get these dwItemData, or what they are:
+ sometimes they point to a wchar_t string that is the menu
+ title, sometimes to someting that doesn't look like text
+ at all. (The problematic data also comes with the 0x0800
+ bit set, but this bit is not documented, so we don't want
+ to depend on it.) */
+ || !(flags & MF_HILITE))
help = Qnil;
else
{
@@ -1488,7 +1504,10 @@ w32_menu_display_help (HWND owner, HMENU menu, UINT
item, UINT flags)
info.fMask = MIIM_DATA;
get_menu_item_info (menu, item, FALSE, &info);
- help = info.dwItemData ? XIL (info.dwItemData) : Qnil;
+ help =
+ info.dwItemData
+ ? make_lisp_ptr ((void *) info.dwItemData, Lisp_String)
+ : Qnil;
}
/* Store the help echo in the keyboard buffer as the X toolkit
diff --git a/src/w32proc.c b/src/w32proc.c
index 26cfa29..74731db 100644
--- a/src/w32proc.c
+++ b/src/w32proc.c
@@ -3077,13 +3077,18 @@ yield nil. */)
(Lisp_Object cp)
{
CHARSETINFO info;
+ DWORD dwcp;
CHECK_NUMBER (cp);
if (!IsValidCodePage (XINT (cp)))
return Qnil;
- if (TranslateCharsetInfo ((DWORD *) XINT (cp), &info, TCI_SRCCODEPAGE))
+ /* Going through a temporary DWORD variable avoids compiler warning
+ about cast to pointer from integer of different size, when
+ building --with-wide-int. */
+ dwcp = XINT (cp);
+ if (TranslateCharsetInfo ((DWORD *) dwcp, &info, TCI_SRCCODEPAGE))
return make_number (info.ciCharset);
return Qnil;
@@ -3142,8 +3147,8 @@ If successful, the new layout id is returned, otherwise
nil. */)
CHECK_NUMBER_CAR (layout);
CHECK_NUMBER_CDR (layout);
- kl = (HKL) ((XINT (XCAR (layout)) & 0xffff)
- | (XINT (XCDR (layout)) << 16));
+ kl = (HKL) (UINT_PTR) ((XINT (XCAR (layout)) & 0xffff)
+ | (XINT (XCDR (layout)) << 16));
/* Synchronize layout with input thread. */
if (dwWindowsThreadId)
diff --git a/src/w32term.h b/src/w32term.h
index 042d7ab..c905ef1 100644
--- a/src/w32term.h
+++ b/src/w32term.h
@@ -493,8 +493,8 @@ struct scroll_bar {
(XSETINT ((low), ((DWORDLONG)(int64)) & 0xffffffff), \
XSETINT ((high), ((DWORDLONG)(int64) >> 32) & 0xffffffff))
#else /* not _WIN64 */
-/* Building a 32-bit C integer from two 16-bit lisp integers. */
-#define SCROLL_BAR_PACK(low, high) (XINT (high) << 16 | XINT (low))
+/* Building a 32-bit C unsigned integer from two 16-bit lisp integers. */
+#define SCROLL_BAR_PACK(low, high) ((UINT_PTR)(XINT (high) << 16 | XINT (low)))
/* Setting two lisp integers to the low and high words of a 32-bit C int. */
#define SCROLL_BAR_UNPACK(low, high, int32) \
diff --git a/src/window.c b/src/window.c
index 4dec976..60ba375 100644
--- a/src/window.c
+++ b/src/window.c
@@ -3003,7 +3003,8 @@ resize_root_window (Lisp_Object window, Lisp_Object
delta, Lisp_Object horizonta
/* Placeholder used by temacs -nw before window.el is loaded. */
DEFUN ("window--sanitize-window-sizes", Fwindow__sanitize_window_sizes,
Swindow__sanitize_window_sizes, 2, 2, 0,
- doc: /* */)
+ doc: /* */
+ attributes: const)
(Lisp_Object frame, Lisp_Object horizontal)
{
return Qnil;
@@ -6427,7 +6428,7 @@ the return value is nil. Otherwise the value is t. */)
/* Allow x_set_window_size again and apply frame size changes if
needed. */
f->can_x_set_window_size = true;
- adjust_frame_size (f, -1, -1, 1, 0, Qnil);
+ adjust_frame_size (f, -1, -1, 1, 0, Qset_window_configuration);
adjust_frame_glyphs (f);
unblock_input ();
diff --git a/src/xdisp.c b/src/xdisp.c
index 8b68ab7..120e810 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -12332,7 +12332,8 @@ DEFUN ("tool-bar-height", Ftool_bar_height,
Stool_bar_height,
0, 2, 0,
doc: /* Return the number of lines occupied by the tool bar of FRAME.
If FRAME is nil or omitted, use the selected frame. Optional argument
-PIXELWISE non-nil means return the height of the tool bar in pixels. */)
+PIXELWISE non-nil means return the height of the tool bar in pixels. */
+ attributes: const)
(Lisp_Object frame, Lisp_Object pixelwise)
{
int height = 0;
@@ -12408,6 +12409,7 @@ redisplay_tool_bar (struct frame *f)
if (new_height != WINDOW_PIXEL_HEIGHT (w))
{
x_change_tool_bar_height (f, new_height);
+ frame_default_tool_bar_height = new_height;
/* Always do that now. */
clear_glyph_matrix (w->desired_matrix);
f->fonts_changed = 1;
@@ -12502,6 +12504,7 @@ redisplay_tool_bar (struct frame *f)
if (change_height_p)
{
x_change_tool_bar_height (f, new_height);
+ frame_default_tool_bar_height = new_height;
clear_glyph_matrix (w->desired_matrix);
f->n_tool_bar_rows = nrows;
f->fonts_changed = 1;
@@ -13831,6 +13834,17 @@ redisplay_internal (void)
retry_frame:
+#if defined (HAVE_WINDOW_SYSTEM) && !defined (USE_GTK) && !defined (HAVE_NS)
+ /* Redisplay internal tool bar if this is the first time so we
+ can adjust the frame height right now, if necessary. */
+ if (!f->tool_bar_redisplayed_once)
+ {
+ if (redisplay_tool_bar (f))
+ adjust_frame_glyphs (f);
+ f->tool_bar_redisplayed_once = true;
+ }
+#endif
+
if (FRAME_WINDOW_P (f) || FRAME_TERMCAP_P (f) || f == sf)
{
bool gcscrollbars
diff --git a/src/xfaces.c b/src/xfaces.c
index 6ecd857..85af770 100644
--- a/src/xfaces.c
+++ b/src/xfaces.c
@@ -3546,7 +3546,8 @@ with the value VALUE is relative.
A relative value is one that doesn't entirely override whatever is
inherited from another face. For most possible attributes,
the only relative value that users see is `unspecified'.
-However, for :height, floating point values are also relative. */)
+However, for :height, floating point values are also relative. */
+ attributes: const)
(Lisp_Object attribute, Lisp_Object value)
{
if (EQ (value, Qunspecified) || (EQ (value, QCignore_defface)))
diff --git a/src/xfns.c b/src/xfns.c
index 4a41752..936c769 100644
--- a/src/xfns.c
+++ b/src/xfns.c
@@ -1130,8 +1130,11 @@ x_change_tool_bar_height (struct frame *f, int height)
/* Recalculate toolbar height. */
f->n_tool_bar_rows = 0;
- adjust_frame_size (f, -1, -1, (old_height == 0 || height == 0) ? 2 : 4, 0,
- Qtool_bar_lines);
+ adjust_frame_size (f, -1, -1,
+ (!f->tool_bar_redisplayed_once ? 1
+ : (old_height == 0 || height == 0) ? 2
+ : 4),
+ 0, Qtool_bar_lines);
/* adjust_frame_size might not have done anything, garbage frame
here. */
@@ -3160,7 +3163,8 @@ This function is an internal primitive--use `make-frame'
instead. */)
had one frame line vs one toolbar line which left us with a zero
root window height which was obviously wrong as well ... */
adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f),
- FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, 1, Qnil);
+ FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, 1,
+ Qx_create_frame_1);
/* Set the menu-bar-lines and tool-bar-lines parameters. We don't
look up the X resources controlling the menu-bar and tool-bar
@@ -3234,7 +3238,8 @@ This function is an internal primitive--use `make-frame'
instead. */)
/* Consider frame official, now. */
f->can_x_set_window_size = true;
- adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), 0, 1,
Qnil);
+ adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), 0, 1,
+ Qx_create_frame_2);
#if defined (USE_X_TOOLKIT) || defined (USE_GTK)
/* Create the menu bar. */
diff --git a/src/xmenu.c b/src/xmenu.c
index fd667a8..9063a8a 100644
--- a/src/xmenu.c
+++ b/src/xmenu.c
@@ -104,10 +104,6 @@ along with GNU Emacs. If not, see
<http://www.gnu.org/licenses/>. */
#include "menu.h"
-#ifndef TRUE
-#define TRUE 1
-#endif /* no TRUE */
-
/* Flag which when set indicates a dialog or menu has been posted by
Xt on behalf of one of the widget sets. */
@@ -146,7 +142,7 @@ menubar_id_to_frame (LWLIB_ID id)
/* Set menu_items_inuse so no other popup menu or dialog is created. */
void
-x_menu_set_in_use (int in_use)
+x_menu_set_in_use (bool in_use)
{
menu_items_inuse = in_use ? Qt : Qnil;
popup_activated_flag = in_use;
@@ -222,7 +218,8 @@ x_menu_wait_for_event (void *data)
with BLOCK_INPUT, UNBLOCK_INPUT wrappers. */
static void
-popup_get_selection (XEvent *initial_event, struct x_display_info *dpyinfo,
LWLIB_ID id, int do_timers)
+popup_get_selection (XEvent *initial_event, struct x_display_info *dpyinfo,
+ LWLIB_ID id, bool do_timers)
{
XEvent event;
@@ -287,13 +284,13 @@ If FRAME is nil or not given, use the selected frame. */)
block_input ();
if (FRAME_EXTERNAL_MENU_BAR (f))
- set_frame_menubar (f, 0, 1);
+ set_frame_menubar (f, false, true);
menubar = FRAME_X_OUTPUT (f)->menubar_widget;
if (menubar)
{
Window child;
- bool error_p = 0;
+ bool error_p = false;
x_catch_errors (FRAME_X_DISPLAY (f));
memset (&ev, 0, sizeof ev);
@@ -366,7 +363,7 @@ If FRAME is nil or not given, use the selected frame. */)
f = decode_window_system_frame (frame);
if (FRAME_EXTERNAL_MENU_BAR (f))
- set_frame_menubar (f, 0, 1);
+ set_frame_menubar (f, false, true);
menubar = FRAME_X_OUTPUT (f)->menubar_widget;
if (menubar)
@@ -390,7 +387,7 @@ If FRAME is nil or not given, use the selected frame. */)
Used for popup menus and dialogs. */
static void
-popup_widget_loop (int do_timers, GtkWidget *widget)
+popup_widget_loop (bool do_timers, GtkWidget *widget)
{
++popup_activated_flag;
@@ -431,7 +428,7 @@ x_activate_menubar (struct frame *f)
return;
#endif
- set_frame_menubar (f, 0, 1);
+ set_frame_menubar (f, false, true);
block_input ();
popup_activated_flag = 1;
#ifdef USE_GTK
@@ -488,24 +485,7 @@ show_help_event (struct frame *f, xt_or_gtk_widget widget,
Lisp_Object help)
kbd_buffer_store_help_event (frame, help);
}
else
- {
-#if 0 /* This code doesn't do anything useful. ++kfs */
- /* WIDGET is the popup menu. It's parent is the frame's
- widget. See which frame that is. */
- xt_or_gtk_widget frame_widget = XtParent (widget);
- Lisp_Object tail;
-
- for (tail = Vframe_list; CONSP (tail); tail = XCDR (tail))
- {
- frame = XCAR (tail);
- if (FRAMEP (frame)
- && (f = XFRAME (frame),
- FRAME_X_P (f) && f->output_data.x->widget == frame_widget))
- break;
- }
-#endif
- show_help_echo (help, Qnil, Qnil, Qnil);
- }
+ show_help_echo (help, Qnil, Qnil, Qnil);
}
/* Callback called when menu items are highlighted/unhighlighted
@@ -554,7 +534,7 @@ menu_highlight_callback (Widget widget, LWLIB_ID id, void
*call_data)
selected in a radio group. If this variable is set to a non-zero
value, we are creating menus and don't want callbacks right now.
*/
-static int xg_crazy_callback_abort;
+static bool xg_crazy_callback_abort;
/* This callback is called from the menu bar pulldown menu
when the user makes a selection.
@@ -656,13 +636,13 @@ update_frame_menubar (struct frame *f)
lw_refigure_widget (x->column_widget, True);
/* Force the pane widget to resize itself. */
+ int new_height = -1;
#ifdef USE_LUCID
/* For reasons I don't know Lucid wants to add one pixel to the frame
height when adding the menu bar. Compensate that here. */
- adjust_frame_size (f, -1, FRAME_TEXT_HEIGHT (f) - 1, 2, 0, Qmenu_bar_lines);
-#else
- adjust_frame_size (f, -1, -1, 2, 0, Qmenu_bar_lines);
+ new_height = FRAME_TEXT_HEIGHT (f) - 1;
#endif /* USE_LUCID */
+ adjust_frame_size (f, -1, new_height, 2, false, Qmenu_bar_lines);
unblock_input ();
#endif /* USE_GTK */
}
@@ -729,11 +709,11 @@ set_frame_menubar (struct frame *f, bool first_time, bool
deep_p)
#endif
if (! menubar_widget)
- deep_p = 1;
+ deep_p = true;
/* Make the first call for any given frame always go deep. */
else if (!f->output_data.x->saved_menu_event && !deep_p)
{
- deep_p = 1;
+ deep_p = true;
f->output_data.x->saved_menu_event = xmalloc (sizeof (XEvent));
f->output_data.x->saved_menu_event->type = 0;
}
@@ -840,7 +820,7 @@ set_frame_menubar (struct frame *f, bool first_time, bool
deep_p)
else
first_wv->contents = wv;
/* Don't set wv->name here; GC during the loop might relocate it. */
- wv->enabled = 1;
+ wv->enabled = true;
wv->button_type = BUTTON_TYPE_NONE;
prev_wv = wv;
}
@@ -931,7 +911,7 @@ set_frame_menubar (struct frame *f, bool first_time, bool
deep_p)
block_input ();
#ifdef USE_GTK
- xg_crazy_callback_abort = 1;
+ xg_crazy_callback_abort = true;
if (menubar_widget)
{
/* The fourth arg is DEEP_P, which says to consider the entire
@@ -980,7 +960,7 @@ set_frame_menubar (struct frame *f, bool first_time, bool
deep_p)
menubar_widget = lw_create_widget ("menubar", "menubar", id,
first_wv,
f->output_data.x->column_widget,
- 0,
+ false,
popup_activate_callback,
menubar_selection_callback,
popup_deactivate_callback,
@@ -1002,11 +982,11 @@ set_frame_menubar (struct frame *f, bool first_time,
bool deep_p)
+ f->output_data.x->menubar_widget->core.border_width)
: 0);
-#if 1 /* Experimentally, we now get the right results
+#ifdef USE_LUCID
+ /* Experimentally, we now get the right results
for -geometry -0-0 without this. 24 Aug 96, rms.
Maybe so, but the menu bar size is missing the pixels so the
WM size hints are off by these pixels. Jan D, oct 2009. */
-#ifdef USE_LUCID
if (FRAME_EXTERNAL_MENU_BAR (f))
{
Dimension ibw = 0;
@@ -1015,7 +995,6 @@ set_frame_menubar (struct frame *f, bool first_time, bool
deep_p)
menubar_size += ibw;
}
#endif /* USE_LUCID */
-#endif /* 1 */
FRAME_MENUBAR_HEIGHT (f) = menubar_size;
}
@@ -1025,7 +1004,7 @@ set_frame_menubar (struct frame *f, bool first_time, bool
deep_p)
update_frame_menubar (f);
#ifdef USE_GTK
- xg_crazy_callback_abort = 0;
+ xg_crazy_callback_abort = false;
#endif
unblock_input ();
@@ -1042,7 +1021,7 @@ initialize_frame_menubar (struct frame *f)
/* This function is called before the first chance to redisplay
the frame. It has to be, so the frame will have the right size. */
fset_menu_bar_items (f, menu_bar_items (FRAME_MENU_BAR_ITEMS (f)));
- set_frame_menubar (f, 1, 1);
+ set_frame_menubar (f, true, true);
}
@@ -1094,21 +1073,21 @@ free_frame_menubar (struct frame *f)
if (f->output_data.x->widget)
{
+ int new_height = -1;
#ifdef USE_MOTIF
XtVaGetValues (f->output_data.x->widget, XtNx, &x1, XtNy, &y1, NULL);
if (x1 == 0 && y1 == 0)
XtVaSetValues (f->output_data.x->widget, XtNx, x0, XtNy, y0, NULL);
- if (frame_inhibit_resize (f, 0, Qmenu_bar_lines))
- adjust_frame_size (f, -1, old_height, 1, 0, Qmenu_bar_lines);
- else
+ if (frame_inhibit_resize (f, false, Qmenu_bar_lines))
+ new_height = old_height;
#endif /* USE_MOTIF */
- adjust_frame_size (f, -1, -1, 2, 0, Qmenu_bar_lines);
+ adjust_frame_size (f, -1, new_height, 2, false, Qmenu_bar_lines);
}
else
{
#ifdef USE_MOTIF
- if (frame_inhibit_resize (f, 0, Qmenu_bar_lines))
- adjust_frame_size (f, -1, old_height, 1, 0, Qmenu_bar_lines);
+ if (frame_inhibit_resize (f, false, Qmenu_bar_lines))
+ adjust_frame_size (f, -1, old_height, 1, false, Qmenu_bar_lines);
#endif
}
@@ -1218,17 +1197,17 @@ create_and_show_popup_menu (struct frame *f,
widget_value *first_wv,
#ifdef HAVE_GTK3
/* Always use position function for Gtk3. Otherwise menus may become
too small to show anything. */
- use_pos_func = 1;
+ use_pos_func = true;
#endif
eassert (FRAME_X_P (f));
- xg_crazy_callback_abort = 1;
+ xg_crazy_callback_abort = true;
menu = xg_create_widget ("popup", first_wv->name, f, first_wv,
G_CALLBACK (popup_selection_callback),
G_CALLBACK (popup_deactivate_callback),
G_CALLBACK (menu_highlight_callback));
- xg_crazy_callback_abort = 0;
+ xg_crazy_callback_abort = false;
if (use_pos_func)
{
@@ -1269,7 +1248,7 @@ create_and_show_popup_menu (struct frame *f, widget_value
*first_wv,
two. show_help_echo uses this to detect popup menus. */
popup_activated_flag = 1;
/* Process events that apply to the menu. */
- popup_widget_loop (1, menu);
+ popup_widget_loop (true, menu);
}
unbind_to (specpdl_count, Qnil);
@@ -1331,14 +1310,14 @@ create_and_show_popup_menu (struct frame *f,
widget_value *first_wv,
menu_id = widget_id_tick++;
menu = lw_create_widget ("popup", first_wv->name, menu_id, first_wv,
- f->output_data.x->widget, 1, 0,
+ f->output_data.x->widget, true, 0,
popup_selection_callback,
popup_deactivate_callback,
menu_highlight_callback);
event->type = ButtonPress;
event->serial = 0;
- event->send_event = 0;
+ event->send_event = false;
event->display = FRAME_X_DISPLAY (f);
event->time = CurrentTime;
event->root = FRAME_DISPLAY_INFO (f)->root_window;
@@ -1374,7 +1353,7 @@ create_and_show_popup_menu (struct frame *f, widget_value
*first_wv,
record_unwind_protect_int (pop_down_menu, (int) menu_id);
/* Process events that apply to the menu. */
- popup_get_selection (0, FRAME_DISPLAY_INFO (f), menu_id, 1);
+ popup_get_selection (0, FRAME_DISPLAY_INFO (f), menu_id, true);
unbind_to (specpdl_count, Qnil);
}
@@ -1400,8 +1379,6 @@ x_menu_show (struct frame *f, int x, int y, int menuflags,
= alloca (menu_items_used * sizeof *subprefix_stack);
int submenu_depth = 0;
- int first_pane;
-
ptrdiff_t specpdl_count = SPECPDL_INDEX ();
eassert (FRAME_X_P (f));
@@ -1421,7 +1398,7 @@ x_menu_show (struct frame *f, int x, int y, int menuflags,
wv = make_widget_value ("menu", NULL, true, Qnil);
wv->button_type = BUTTON_TYPE_NONE;
first_wv = wv;
- first_pane = 1;
+ bool first_pane = true;
/* Loop over all panes and items, filling in the tree. */
i = 0;
@@ -1432,14 +1409,14 @@ x_menu_show (struct frame *f, int x, int y, int
menuflags,
submenu_stack[submenu_depth++] = save_wv;
save_wv = prev_wv;
prev_wv = 0;
- first_pane = 1;
+ first_pane = true;
i++;
}
else if (EQ (AREF (menu_items, i), Qlambda))
{
prev_wv = save_wv;
save_wv = submenu_stack[--submenu_depth];
- first_pane = 0;
+ first_pane = false;
i++;
}
else if (EQ (AREF (menu_items, i), Qt)
@@ -1493,7 +1470,7 @@ x_menu_show (struct frame *f, int x, int y, int menuflags,
save_wv = wv;
prev_wv = 0;
}
- first_pane = 0;
+ first_pane = false;
i += MENU_ITEMS_PANE_LENGTH;
}
else
@@ -1688,7 +1665,7 @@ create_and_show_dialog (struct frame *f, widget_value
*first_wv)
gtk_widget_show_all (menu);
/* Process events that apply to the menu. */
- popup_widget_loop (1, menu);
+ popup_widget_loop (true, menu);
unbind_to (specpdl_count, Qnil);
}
@@ -1725,7 +1702,7 @@ create_and_show_dialog (struct frame *f, widget_value
*first_wv)
apply_systemfont_to_dialog (f->output_data.x->widget);
#endif
lw_create_widget (first_wv->name, "dialog", dialog_id, first_wv,
- f->output_data.x->widget, 1, 0,
+ f->output_data.x->widget, true, 0,
dialog_selection_callback, 0, 0);
lw_modify_all_widgets (dialog_id, first_wv->contents, True);
/* Display the dialog box. */
@@ -1742,7 +1719,7 @@ create_and_show_dialog (struct frame *f, widget_value
*first_wv)
record_unwind_protect_int (pop_down_menu, (int) dialog_id);
- popup_get_selection (0, FRAME_DISPLAY_INFO (f), dialog_id, 1);
+ popup_get_selection (0, FRAME_DISPLAY_INFO (f), dialog_id, true);
unbind_to (count, Qnil);
}
@@ -1765,8 +1742,8 @@ x_dialog_show (struct frame *f, Lisp_Object title,
/* Number of elements seen so far, before boundary. */
int left_count = 0;
- /* 1 means we've seen the boundary between left-hand elts and right-hand. */
- int boundary_seen = 0;
+ /* Whether we've seen the boundary between left-hand elts and right-hand. */
+ bool boundary_seen = false;
ptrdiff_t specpdl_count = SPECPDL_INDEX ();
@@ -1813,7 +1790,7 @@ x_dialog_show (struct frame *f, Lisp_Object title,
{
/* This is the boundary between left-side elts
and right-side elts. Stop incrementing right_count. */
- boundary_seen = 1;
+ boundary_seen = true;
i++;
continue;
}
@@ -2099,7 +2076,7 @@ x_menu_show (struct frame *f, int x, int y, int menuflags,
if ((menuflags & MENU_KEYMAPS) && !NILP (prefix))
pane_string++;
- lpane = XMenuAddPane (FRAME_X_DISPLAY (f), menu, pane_string, TRUE);
+ lpane = XMenuAddPane (FRAME_X_DISPLAY (f), menu, pane_string, true);
if (lpane == XM_FAILURE)
{
XMenuDestroy (FRAME_X_DISPLAY (f), menu);
@@ -2224,8 +2201,8 @@ x_menu_show (struct frame *f, int x, int y, int menuflags,
y += 1.5*height/(maxlines+2);
}
- XMenuSetAEQ (menu, TRUE);
- XMenuSetFreeze (menu, TRUE);
+ XMenuSetAEQ (menu, true);
+ XMenuSetFreeze (menu, true);
pane = selidx = 0;
#ifndef MSDOS
diff --git a/src/xml.c b/src/xml.c
index 3e64788..e324177 100644
--- a/src/xml.c
+++ b/src/xml.c
@@ -43,14 +43,12 @@ DEF_DLL_FN (void, xmlFreeDoc, (xmlDocPtr));
DEF_DLL_FN (void, xmlCleanupParser, (void));
DEF_DLL_FN (void, xmlCheckVersion, (int));
-static int
+static bool
libxml2_loaded_p (void)
{
Lisp_Object found = Fassq (Qlibxml2_dll, Vlibrary_cache);
- if (CONSP (found))
- return EQ (XCDR (found), Qt) ? 1 : 0;
- return 0;
+ return CONSP (found) && EQ (XCDR (found), Qt);
}
# undef htmlReadMemory
@@ -81,20 +79,20 @@ load_dll_functions (HMODULE library)
#else /* !WINDOWSNT */
-static int
+static bool
libxml2_loaded_p (void)
{
- return 1;
+ return true;
}
#endif /* !WINDOWSNT */
-static int
+static bool
init_libxml2_functions (void)
{
#ifdef WINDOWSNT
if (libxml2_loaded_p ())
- return 1;
+ return true;
else
{
HMODULE library;
@@ -102,22 +100,22 @@ init_libxml2_functions (void)
if (!(library = w32_delayed_load (Qlibxml2_dll)))
{
message1 ("libxml2 library not found");
- return 0;
+ return false;
}
if (! load_dll_functions (library))
goto bad_library;
Vlibrary_cache = Fcons (Fcons (Qlibxml2_dll, Qt), Vlibrary_cache);
- return 1;
+ return true;
}
bad_library:
Vlibrary_cache = Fcons (Fcons (Qlibxml2_dll, Qnil), Vlibrary_cache);
- return 0;
+ return false;
#else /* !WINDOWSNT */
- return 1;
+ return true;
#endif /* !WINDOWSNT */
}
@@ -177,7 +175,8 @@ make_dom (xmlNode *node)
}
static Lisp_Object
-parse_region (Lisp_Object start, Lisp_Object end, Lisp_Object base_url,
Lisp_Object discard_comments, int htmlp)
+parse_region (Lisp_Object start, Lisp_Object end, Lisp_Object base_url,
+ Lisp_Object discard_comments, bool htmlp)
{
xmlDoc *doc;
Lisp_Object result = Qnil;
@@ -263,7 +262,7 @@ If DISCARD-COMMENTS is non-nil, all HTML comments are
discarded. */)
(Lisp_Object start, Lisp_Object end, Lisp_Object base_url, Lisp_Object
discard_comments)
{
if (init_libxml2_functions ())
- return parse_region (start, end, base_url, discard_comments, 1);
+ return parse_region (start, end, base_url, discard_comments, true);
return Qnil;
}
@@ -276,7 +275,7 @@ If DISCARD-COMMENTS is non-nil, all HTML comments are
discarded. */)
(Lisp_Object start, Lisp_Object end, Lisp_Object base_url, Lisp_Object
discard_comments)
{
if (init_libxml2_functions ())
- return parse_region (start, end, base_url, discard_comments, 0);
+ return parse_region (start, end, base_url, discard_comments, false);
return Qnil;
}
diff --git a/src/xrdb.c b/src/xrdb.c
index f1176da..9e85e5a 100644
--- a/src/xrdb.c
+++ b/src/xrdb.c
@@ -667,7 +667,7 @@ main (int argc, char **argv)
/* In a real program, you'd want to also do this: */
display->db = xdb;
- while (1)
+ while (true)
{
char query_name[90];
char query_class[90];
diff --git a/src/xsettings.c b/src/xsettings.c
index 8dbc7d9..028487b 100644
--- a/src/xsettings.c
+++ b/src/xsettings.c
@@ -804,7 +804,7 @@ init_gsettings (void)
GSettingsSchema *sc = g_settings_schema_source_lookup
(g_settings_schema_source_get_default (),
GSETTINGS_SCHEMA,
- TRUE);
+ true);
schema_found = sc != NULL;
if (sc) g_settings_schema_unref (sc);
}
diff --git a/src/xterm.c b/src/xterm.c
index 9a87a1e..40043dc 100644
--- a/src/xterm.c
+++ b/src/xterm.c
@@ -3051,7 +3051,7 @@ XTflash (struct frame *f)
gc = gdk_gc_new_with_values (window,
&vals, GDK_GC_FUNCTION | GDK_GC_FOREGROUND);
#define XFillRectangle(d, win, gc, x, y, w, h) \
- gdk_draw_rectangle (window, gc, TRUE, x, y, w, h)
+ gdk_draw_rectangle (window, gc, true, x, y, w, h)
#endif /* ! HAVE_GTK3 */
#else /* ! USE_GTK */
GC gc;
@@ -4604,7 +4604,7 @@ xg_scroll_callback (GtkRange *range,
GtkAdjustment *adj = GTK_ADJUSTMENT (gtk_range_get_adjustment (range));
struct frame *f = g_object_get_data (G_OBJECT (range), XG_FRAME_DATA);
- if (xg_ignore_gtk_scrollbar) return FALSE;
+ if (xg_ignore_gtk_scrollbar) return false;
switch (scroll)
{
@@ -4660,7 +4660,7 @@ xg_scroll_callback (GtkRange *range,
bar->horizontal);
}
- return FALSE;
+ return false;
}
/* Callback for button release. Sets dragging to -1 when dragging is done. */
@@ -4679,7 +4679,7 @@ xg_end_scroll_callback (GtkWidget *widget,
window_being_scrolled = Qnil;
}
- return FALSE;
+ return false;
}
diff --git a/src/xterm.h b/src/xterm.h
index f2aff72..123f31c 100644
--- a/src/xterm.h
+++ b/src/xterm.h
@@ -1099,7 +1099,7 @@ extern Lisp_Object xw_popup_dialog (struct frame *,
Lisp_Object, Lisp_Object);
#endif
#if defined USE_GTK || defined USE_MOTIF
-extern void x_menu_set_in_use (int);
+extern void x_menu_set_in_use (bool);
#endif
extern void x_menu_wait_for_event (void *data);
extern void initialize_frame_menubar (struct frame *);
diff --git a/test/ChangeLog b/test/ChangeLog
index 83bb8bf..a33ec87 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -1,3 +1,14 @@
+2015-01-15 Stefan Monnier <address@hidden>
+
+ * automated/eieio-test-methodinvoke.el (eieio-test-method-store): Add
+ keysym arg instead of relying on internal var eieio--generic-call-key.
+ Update all callers.
+ (eieio-test-cl-generic-1): New tests.
+
+2015-01-14 Stefan Monnier <address@hidden>
+
+ * automated/cl-generic-tests.el: New file.
+
2015-01-08 Stefan Monnier <address@hidden>
* automated/eieio-tests.el (eieio-test-23-inheritance-check): Don't use
diff --git a/test/automated/cl-generic-tests.el
b/test/automated/cl-generic-tests.el
new file mode 100644
index 0000000..17bce6a
--- /dev/null
+++ b/test/automated/cl-generic-tests.el
@@ -0,0 +1,133 @@
+;;; cl-generic-tests.el --- Tests for cl-generic.el functionality -*-
lexical-binding: t; -*-
+
+;; Copyright (C) 2015 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <address@hidden>
+
+;; 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:
+
+;;; Code:
+
+(require 'ert)
+(require 'cl-lib)
+
+(cl-defgeneric cl--generic-1 (x y))
+(cl-defgeneric (setf cl--generic-1) (v y z) "My generic doc.")
+
+(ert-deftest cl-generic-test-0 ()
+ (cl-defgeneric cl--generic-1 (x y))
+ (cl-defmethod cl--generic-1 ((x t) y) (cons x y))
+ (should (equal (cl--generic-1 'a 'b) '(a . b))))
+
+(ert-deftest cl-generic-test-1-eql ()
+ (cl-defgeneric cl--generic-1 (x y))
+ (cl-defmethod cl--generic-1 ((x t) y) (cons x y))
+ (cl-defmethod cl--generic-1 ((_x (eql 4)) _y)
+ (cons "quatre" (cl-call-next-method)))
+ (cl-defmethod cl--generic-1 ((_x (eql 5)) _y)
+ (cons "cinq" (cl-call-next-method)))
+ (cl-defmethod cl--generic-1 ((_x (eql 6)) y)
+ (cons "six" (cl-call-next-method 'a y)))
+ (should (equal (cl--generic-1 'a nil) '(a)))
+ (should (equal (cl--generic-1 4 nil) '("quatre" 4)))
+ (should (equal (cl--generic-1 5 nil) '("cinq" 5)))
+ (should (equal (cl--generic-1 6 nil) '("six" a))))
+
+(cl-defstruct cl-generic-struct-parent a b)
+(cl-defstruct (cl-generic-struct-child1 (:include cl-generic-struct-parent)) c)
+(cl-defstruct (cl-generic-struct-child11 (:include cl-generic-struct-child1))
d)
+(cl-defstruct (cl-generic-struct-child2 (:include cl-generic-struct-parent)) e)
+
+(ert-deftest cl-generic-test-2-struct ()
+ (cl-defgeneric cl--generic-1 (x y) "My doc.")
+ (cl-defmethod cl--generic-1 ((x t) y) "Doc 1." (cons x y))
+ (cl-defmethod cl--generic-1 ((_x cl-generic-struct-parent) y)
+ "Doc 2." (cons "parent" (cl-call-next-method 'a y)))
+ (cl-defmethod cl--generic-1 ((_x cl-generic-struct-child1) _y)
+ (cons "child1" (cl-call-next-method)))
+ (cl-defmethod cl--generic-1 :around ((_x t) _y)
+ (cons "around" (cl-call-next-method)))
+ (cl-defmethod cl--generic-1 :around ((_x cl-generic-struct-child11) _y)
+ (cons "child11" (cl-call-next-method)))
+ (cl-defmethod cl--generic-1 ((_x cl-generic-struct-child2) _y)
+ (cons "child2" (cl-call-next-method)))
+ (should (equal (cl--generic-1 (make-cl-generic-struct-child1) nil)
+ '("around" "child1" "parent" a)))
+ (should (equal (cl--generic-1 (make-cl-generic-struct-child2) nil)
+ '("around""child2" "parent" a)))
+ (should (equal (cl--generic-1 (make-cl-generic-struct-child11) nil)
+ '("child11" "around""child1" "parent" a))))
+
+(ert-deftest cl-generic-test-3-setf ()
+ (cl-defmethod (setf cl--generic-1) (v (y t) z) (list v y z))
+ (cl-defmethod (setf cl--generic-1) (v (_y (eql 4)) z) (list v "four" z))
+ (should (equal (setf (cl--generic-1 'a 'b) 'v) '(v a b)))
+ (should (equal (setf (cl--generic-1 4 'b) 'v) '(v "four" b)))
+ (let ((x ()))
+ (should (equal (setf (cl--generic-1 (progn (push 1 x) 'a)
+ (progn (push 2 x) 'b))
+ (progn (push 3 x) 'v))
+ '(v a b)))
+ (should (equal x '(3 2 1)))))
+
+(ert-deftest cl-generic-test-4-overlapping-tagcodes ()
+ (cl-defgeneric cl--generic-1 (x y) "My doc.")
+ (cl-defmethod cl--generic-1 ((y t) z) (list y z))
+ (cl-defmethod cl--generic-1 ((_y (eql 4)) _z)
+ (cons "four" (cl-call-next-method)))
+ (cl-defmethod cl--generic-1 ((_y integer) _z)
+ (cons "integer" (cl-call-next-method)))
+ (cl-defmethod cl--generic-1 ((_y number) _z)
+ (cons "number" (cl-call-next-method)))
+ (should (equal (cl--generic-1 'a 'b) '(a b)))
+ (should (equal (cl--generic-1 1 'b) '("integer" "number" 1 b)))
+ (should (equal (cl--generic-1 4 'b) '("four" "integer" "number" 4 b))))
+
+(ert-deftest cl-generic-test-5-alias ()
+ (cl-defgeneric cl--generic-1 (x y) "My doc.")
+ (defalias 'cl--generic-2 #'cl--generic-1)
+ (cl-defmethod cl--generic-1 ((y t) z) (list y z))
+ (cl-defmethod cl--generic-2 ((_y (eql 4)) _z)
+ (cons "four" (cl-call-next-method)))
+ (should (equal (cl--generic-1 4 'b) '("four" 4 b))))
+
+(ert-deftest cl-generic-test-6-multiple-dispatch ()
+ (cl-defgeneric cl--generic-1 (x y) "My doc.")
+ (cl-defmethod cl--generic-1 (x y) (list x y))
+ (cl-defmethod cl--generic-1 (_x (_y integer))
+ (cons "y-int" (cl-call-next-method)))
+ (cl-defmethod cl--generic-1 ((_x integer) _y)
+ (cons "x-int" (cl-call-next-method)))
+ (cl-defmethod cl--generic-1 ((_x integer) (_y integer))
+ (cons "x&y-int" (cl-call-next-method)))
+ (should (equal (cl--generic-1 1 2) '("x&y-int" "x-int" "y-int" 1 2))))
+
+(ert-deftest cl-generic-test-7-apo ()
+ (cl-defgeneric cl--generic-1 (x y)
+ (:documentation "My doc.") (:argument-precedence-order y x))
+ (cl-defmethod cl--generic-1 (x y) (list x y))
+ (cl-defmethod cl--generic-1 (_x (_y integer))
+ (cons "y-int" (cl-call-next-method)))
+ (cl-defmethod cl--generic-1 ((_x integer) _y)
+ (cons "x-int" (cl-call-next-method)))
+ (cl-defmethod cl--generic-1 ((_x integer) (_y integer))
+ (cons "x&y-int" (cl-call-next-method)))
+ (should (equal (cl--generic-1 1 2) '("x&y-int" "y-int" "x-int" 1 2))))
+
+(provide 'cl-generic-tests)
+;;; cl-generic-tests.el ends here
diff --git a/test/automated/eieio-test-methodinvoke.el
b/test/automated/eieio-test-methodinvoke.el
index 2de836c..6362fc5 100644
--- a/test/automated/eieio-test-methodinvoke.el
+++ b/test/automated/eieio-test-methodinvoke.el
@@ -58,12 +58,10 @@
(defvar eieio-test-method-order-list nil
"List of symbols stored during method invocation.")
-(defun eieio-test-method-store ()
+(defun eieio-test-method-store (keysym)
"Store current invocation class symbol in the invocation order list."
- (let* ((keysym (aref [ :STATIC :BEFORE :PRIMARY :AFTER ]
- (or eieio--generic-call-key 0)))
- ;; FIXME: Don't depend on `eieio--scoped-class'!
- (c (list keysym (eieio--class-symbol (eieio--scoped-class)))))
+ ;; FIXME: Don't depend on `eieio--scoped-class'!
+ (let* ((c (list keysym (eieio--class-symbol (eieio--scoped-class)))))
(push c eieio-test-method-order-list)))
(defun eieio-test-match (rightanswer)
@@ -88,36 +86,36 @@
(defclass eitest-B (eitest-B-base1 eitest-B-base2) ())
(defmethod eitest-F :BEFORE ((p eitest-B-base1))
- (eieio-test-method-store))
+ (eieio-test-method-store :BEFORE))
(defmethod eitest-F :BEFORE ((p eitest-B-base2))
- (eieio-test-method-store))
+ (eieio-test-method-store :BEFORE))
(defmethod eitest-F :BEFORE ((p eitest-B))
- (eieio-test-method-store))
+ (eieio-test-method-store :BEFORE))
(defmethod eitest-F ((p eitest-B))
- (eieio-test-method-store)
+ (eieio-test-method-store :PRIMARY)
(call-next-method))
(defmethod eitest-F ((p eitest-B-base1))
- (eieio-test-method-store)
+ (eieio-test-method-store :PRIMARY)
(call-next-method))
(defmethod eitest-F ((p eitest-B-base2))
- (eieio-test-method-store)
+ (eieio-test-method-store :PRIMARY)
(when (next-method-p)
(call-next-method))
)
(defmethod eitest-F :AFTER ((p eitest-B-base1))
- (eieio-test-method-store))
+ (eieio-test-method-store :AFTER))
(defmethod eitest-F :AFTER ((p eitest-B-base2))
- (eieio-test-method-store))
+ (eieio-test-method-store :AFTER))
(defmethod eitest-F :AFTER ((p eitest-B))
- (eieio-test-method-store))
+ (eieio-test-method-store :AFTER))
(ert-deftest eieio-test-method-order-list-3 ()
(let ((eieio-test-method-order-list nil)
@@ -152,15 +150,15 @@
;;; Return value from :PRIMARY
;;
(defmethod eitest-I :BEFORE ((a eitest-A))
- (eieio-test-method-store)
+ (eieio-test-method-store :BEFORE)
":before")
(defmethod eitest-I :PRIMARY ((a eitest-A))
- (eieio-test-method-store)
+ (eieio-test-method-store :PRIMARY)
":primary")
(defmethod eitest-I :AFTER ((a eitest-A))
- (eieio-test-method-store)
+ (eieio-test-method-store :AFTER)
":after")
(ert-deftest eieio-test-method-order-list-5 ()
@@ -179,17 +177,17 @@
;; Just use the obsolete name once, to make sure it also works.
(defmethod constructor :STATIC ((p C-base1) &rest args)
- (eieio-test-method-store)
+ (eieio-test-method-store :STATIC)
(if (next-method-p) (call-next-method))
)
(defmethod eieio-constructor :STATIC ((p C-base2) &rest args)
- (eieio-test-method-store)
+ (eieio-test-method-store :STATIC)
(if (next-method-p) (call-next-method))
)
(defmethod eieio-constructor :STATIC ((p C) &rest args)
- (eieio-test-method-store)
+ (eieio-test-method-store :STATIC)
(call-next-method)
)
@@ -216,24 +214,24 @@
(defmethod eitest-F ((p D))
"D"
- (eieio-test-method-store)
+ (eieio-test-method-store :PRIMARY)
(call-next-method))
(defmethod eitest-F ((p D-base0))
"D-base0"
- (eieio-test-method-store)
+ (eieio-test-method-store :PRIMARY)
;; This should have no next
;; (when (next-method-p) (call-next-method))
)
(defmethod eitest-F ((p D-base1))
"D-base1"
- (eieio-test-method-store)
+ (eieio-test-method-store :PRIMARY)
(call-next-method))
(defmethod eitest-F ((p D-base2))
"D-base2"
- (eieio-test-method-store)
+ (eieio-test-method-store :PRIMARY)
(when (next-method-p)
(call-next-method))
)
@@ -258,21 +256,21 @@
(defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first)
(defmethod eitest-F ((p E))
- (eieio-test-method-store)
+ (eieio-test-method-store :PRIMARY)
(call-next-method))
(defmethod eitest-F ((p E-base0))
- (eieio-test-method-store)
+ (eieio-test-method-store :PRIMARY)
;; This should have no next
;; (when (next-method-p) (call-next-method))
)
(defmethod eitest-F ((p E-base1))
- (eieio-test-method-store)
+ (eieio-test-method-store :PRIMARY)
(call-next-method))
(defmethod eitest-F ((p E-base2))
- (eieio-test-method-store)
+ (eieio-test-method-store :PRIMARY)
(when (next-method-p)
(call-next-method))
)
@@ -380,3 +378,21 @@
'(CNM-1-1 CNM-2 INIT)))
(should (equal (eieio-test-arguments-for 'CNM-2)
'(INIT)))))
+
+;;; Check cl-generic integration.
+
+(cl-defgeneric eieio-test--1 (x y))
+
+(ert-deftest eieio-test-cl-generic-1 ()
+ (cl-defmethod eieio-test--1 (x y) (list x y))
+ (cl-defmethod eieio-test--1 ((_x CNM-0) y)
+ (cons "CNM-0" (cl-call-next-method 7 y)))
+ (cl-defmethod eieio-test--1 ((_x CNM-1-1) _y)
+ (cons "CNM-1-1" (cl-call-next-method)))
+ (cl-defmethod eieio-test--1 ((_x CNM-1-2) y)
+ (cons "CNM-1-2" (cl-call-next-method)))
+ (should (equal (eieio-test--1 4 5) '(4 5)))
+ (should (equal (eieio-test--1 (make-instance 'CNM-0) 5)
+ '("CNM-0" 7 5)))
+ (should (equal (eieio-test--1 (make-instance 'CNM-2) 5)
+ '("CNM-1-1" "CNM-1-2" "CNM-0" 7 5))))