aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorJoakim Verona2015-01-15 14:54:25 +0100
committerJoakim Verona2015-01-15 14:54:25 +0100
commit0298a2c6a10bc3b79cb2f45a1961dd7ac6da4e6d (patch)
tree6c7ea25ac137f5764d931e841598a3c1ea434ab0
parenta1124bc117e41019de49c82d13d1a72a50df977d (diff)
parent0e97c44c3699c4606a04f589828acdf9c03f447e (diff)
downloademacs-0298a2c6a10bc3b79cb2f45a1961dd7ac6da4e6d.tar.gz
emacs-0298a2c6a10bc3b79cb2f45a1961dd7ac6da4e6d.zip
merge master
-rw-r--r--admin/ChangeLog7
-rw-r--r--admin/unidata/Makefile.in7
-rw-r--r--etc/NEWS2
-rw-r--r--lib-src/ChangeLog17
-rw-r--r--lib-src/make-docfile.c135
-rw-r--r--lisp/ChangeLog124
-rw-r--r--lisp/Makefile.in30
-rw-r--r--lisp/emacs-lisp/cl-generic.el607
-rw-r--r--lisp/emacs-lisp/cl-macs.el52
-rw-r--r--lisp/emacs-lisp/eieio-core.el28
-rw-r--r--lisp/files.el5
-rw-r--r--lisp/frame.el58
-rw-r--r--lisp/menu-bar.el3
-rw-r--r--lisp/net/eww.el38
-rw-r--r--lisp/progmodes/cc-bytecomp.el72
-rw-r--r--lisp/progmodes/cc-defs.el43
-rw-r--r--lisp/progmodes/cc-langs.el5
-rw-r--r--lisp/progmodes/xref.el1
-rw-r--r--src/.gdbinit21
-rw-r--r--src/ChangeLog233
-rw-r--r--src/Makefile.in9
-rw-r--r--src/buffer.c161
-rw-r--r--src/callint.c3
-rw-r--r--src/callproc.c23
-rw-r--r--src/character.c6
-rw-r--r--src/coding.c2
-rw-r--r--src/data.c42
-rw-r--r--src/decompress.c3
-rw-r--r--src/dired.c29
-rw-r--r--src/dispnew.c3
-rw-r--r--src/editfns.c88
-rw-r--r--src/emacs.c3
-rw-r--r--src/eval.c3
-rw-r--r--src/fileio.c13
-rw-r--r--src/fns.c3
-rw-r--r--src/frame.c111
-rw-r--r--src/frame.h6
-rw-r--r--src/gnutls.c6
-rw-r--r--src/gtkutil.c2
-rw-r--r--src/image.c3
-rw-r--r--src/keyboard.c17
-rw-r--r--src/lisp.h31
-rw-r--r--src/nsfns.m6
-rw-r--r--src/process.c19
-rw-r--r--src/process.h2
-rw-r--r--src/search.c31
-rw-r--r--src/w32fns.c55
-rw-r--r--src/w32heap.c2
-rw-r--r--src/w32menu.c49
-rw-r--r--src/w32proc.c11
-rw-r--r--src/w32term.h4
-rw-r--r--src/window.c5
-rw-r--r--src/xdisp.c16
-rw-r--r--src/xfaces.c3
-rw-r--r--src/xfns.c13
-rw-r--r--src/xmenu.c119
-rw-r--r--src/xml.c29
-rw-r--r--src/xrdb.c2
-rw-r--r--src/xsettings.c2
-rw-r--r--src/xterm.c8
-rw-r--r--src/xterm.h2
-rw-r--r--test/ChangeLog11
-rw-r--r--test/automated/cl-generic-tests.el133
-rw-r--r--test/automated/eieio-test-methodinvoke.el72
64 files changed, 2040 insertions, 609 deletions
diff --git a/admin/ChangeLog b/admin/ChangeLog
index dc029a0be0c..2b04281f400 100644
--- a/admin/ChangeLog
+++ b/admin/ChangeLog
@@ -1,3 +1,10 @@
12015-01-12 Paul Eggert <eggert@cs.ucla.edu>
2
3 Say "ELC foo.elc" instead of "GEN foo.elc"
4 * unidata/Makefile.in (AM_V_ELC, am__v_ELC_, am__v_ELC_0)
5 (am__v_ELC_1): New macros.
6 (%.elc): Use them.
7
12015-01-08 Glenn Morris <rgm@gnu.org> 82015-01-08 Glenn Morris <rgm@gnu.org>
2 9
3 * authors.el (authors-aliases): Add an entry to ignore. 10 * authors.el (authors-aliases): Add an entry to ignore.
diff --git a/admin/unidata/Makefile.in b/admin/unidata/Makefile.in
index 777d1270fff..1396f0926f4 100644
--- a/admin/unidata/Makefile.in
+++ b/admin/unidata/Makefile.in
@@ -34,6 +34,11 @@ emacs = "${EMACS}" -batch --no-site-file --no-site-lisp
34# 'make' verbosity. 34# 'make' verbosity.
35AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ 35AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@
36 36
37AM_V_ELC = $(am__v_ELC_@AM_V@)
38am__v_ELC_ = $(am__v_ELC_@AM_DEFAULT_V@)
39am__v_ELC_0 = @echo " ELC " $@;
40am__v_ELC_1 =
41
37AM_V_GEN = $(am__v_GEN_@AM_V@) 42AM_V_GEN = $(am__v_GEN_@AM_V@)
38am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) 43am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@)
39am__v_GEN_0 = @echo " GEN " $@; 44am__v_GEN_0 = @echo " GEN " $@;
@@ -58,7 +63,7 @@ ${top_srcdir}/src/macuvs.h: ${srcdir}/uvs.el ${srcdir}/IVD_Sequences.txt | \
58 > $@ 63 > $@
59 64
60%.elc: %.el 65%.elc: %.el
61 $(AM_V_GEN)${emacs} -f batch-byte-compile $< 66 $(AM_V_ELC)${emacs} -f batch-byte-compile $<
62 67
63unidata.txt: ${srcdir}/UnicodeData.txt 68unidata.txt: ${srcdir}/UnicodeData.txt
64 $(AM_V_GEN)sed -e 's/\([^;]*\);\(.*\)/(#x\1 "\2")/' -e 's/;/" "/g' \ 69 $(AM_V_GEN)sed -e 's/\([^;]*\);\(.*\)/(#x\1 "\2")/' -e 's/;/" "/g' \
diff --git a/etc/NEWS b/etc/NEWS
index b3267e1ce60..f291c0c9ad9 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -480,6 +480,8 @@ As a result of the above, these commands are now obsolete:
480 480
481* New Modes and Packages in Emacs 25.1 481* New Modes and Packages in Emacs 25.1
482 482
483** cl-generic.el provides CLOS-style multiple-dispatch generic functions.
484
483** scss-mode (a minor variant of css-mode) 485** scss-mode (a minor variant of css-mode)
484 486
485** let-alist is a new macro (and a package) that allows one to easily 487** 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 740359605fd..e9205fdd12a 100644
--- a/lib-src/ChangeLog
+++ b/lib-src/ChangeLog
@@ -1,3 +1,20 @@
12015-01-13 Paul Eggert <eggert@cs.ucla.edu>
2
3 Don't say Fnext_read_file_uses_dialog_p is const
4 * make-docfile.c (write_globals):
5 Add a special hack for Fnext_read_file_uses_dialog_p.
6
72015-01-13 Dmitry Antipov <dmantipov@yandex.ru>
8
9 Support DEFUN attributes.
10 * make-docfile.c (struct global): New field 'flags'.
11 (DEFUN_noreturn, DEFUN_const): New enum bitfields.
12 (add_global): Now return pointer to global.
13 (write_globals): Add _Noreturn and ATTRIBUTE_CONST attributes
14 if requested by global's flags.
15 (stream_match): New function.
16 (scan_c_stream): Recognize 'attributes:' of DEFUN.
17
12015-01-10 Paul Eggert <eggert@cs.ucla.edu> 182015-01-10 Paul Eggert <eggert@cs.ucla.edu>
2 19
3 Port to 32-bit --with-wide-int 20 Port to 32-bit --with-wide-int
diff --git a/lib-src/make-docfile.c b/lib-src/make-docfile.c
index bc5420ea939..741fa4bfa42 100644
--- a/lib-src/make-docfile.c
+++ b/lib-src/make-docfile.c
@@ -562,6 +562,7 @@ struct global
562{ 562{
563 enum global_type type; 563 enum global_type type;
564 char *name; 564 char *name;
565 int flags;
565 union 566 union
566 { 567 {
567 int value; 568 int value;
@@ -569,13 +570,16 @@ struct global
569 } v; 570 } v;
570}; 571};
571 572
573/* Bit values for FLAGS field from the above. Applied for DEFUNs only. */
574enum { DEFUN_noreturn = 1, DEFUN_const = 2 };
575
572/* All the variable names we saw while scanning C sources in `-g' 576/* All the variable names we saw while scanning C sources in `-g'
573 mode. */ 577 mode. */
574int num_globals; 578int num_globals;
575int num_globals_allocated; 579int num_globals_allocated;
576struct global *globals; 580struct global *globals;
577 581
578static void 582static struct global *
579add_global (enum global_type type, char *name, int value, char const *svalue) 583add_global (enum global_type type, char *name, int value, char const *svalue)
580{ 584{
581 /* Ignore the one non-symbol that can occur. */ 585 /* 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)
601 globals[num_globals - 1].v.svalue = svalue; 605 globals[num_globals - 1].v.svalue = svalue;
602 else 606 else
603 globals[num_globals - 1].v.value = value; 607 globals[num_globals - 1].v.value = value;
608 globals[num_globals - 1].flags = 0;
609 return globals + num_globals - 1;
604 } 610 }
611 return NULL;
605} 612}
606 613
607static int 614static int
@@ -708,13 +715,7 @@ write_globals (void)
708 globals[i].name, globals[i].name, globals[i].name); 715 globals[i].name, globals[i].name, globals[i].name);
709 else 716 else
710 { 717 {
711 /* It would be nice to have a cleaner way to deal with these 718 if (globals[i].flags & DEFUN_noreturn)
712 special hacks. */
713 if (strcmp (globals[i].name, "Fthrow") == 0
714 || strcmp (globals[i].name, "Ftop_level") == 0
715 || strcmp (globals[i].name, "Fkill_emacs") == 0
716 || strcmp (globals[i].name, "Fexit_recursive_edit") == 0
717 || strcmp (globals[i].name, "Fabort_recursive_edit") == 0)
718 fputs ("_Noreturn ", stdout); 719 fputs ("_Noreturn ", stdout);
719 720
720 printf ("EXFUN (%s, ", globals[i].name); 721 printf ("EXFUN (%s, ", globals[i].name);
@@ -726,37 +727,20 @@ write_globals (void)
726 printf ("%d", globals[i].v.value); 727 printf ("%d", globals[i].v.value);
727 putchar (')'); 728 putchar (')');
728 729
729 /* It would be nice to have a cleaner way to deal with these 730 if (globals[i].flags & DEFUN_const)
730 special hacks, too. */
731 if (strcmp (globals[i].name, "Fatom") == 0
732 || strcmp (globals[i].name, "Fbyteorder") == 0
733 || strcmp (globals[i].name, "Fcharacterp") == 0
734 || strcmp (globals[i].name, "Fchar_or_string_p") == 0
735 || strcmp (globals[i].name, "Fconsp") == 0
736 || strcmp (globals[i].name, "Feq") == 0
737 || strcmp (globals[i].name, "Fface_attribute_relative_p") == 0
738 || strcmp (globals[i].name, "Fframe_windows_min_size") == 0
739 || strcmp (globals[i].name, "Fgnutls_errorp") == 0
740 || strcmp (globals[i].name, "Fidentity") == 0
741 || strcmp (globals[i].name, "Fintegerp") == 0
742 || strcmp (globals[i].name, "Finteractive") == 0
743 || strcmp (globals[i].name, "Ffloatp") == 0
744 || strcmp (globals[i].name, "Flistp") == 0
745 || strcmp (globals[i].name, "Fmax_char") == 0
746 || strcmp (globals[i].name, "Fnatnump") == 0
747 || strcmp (globals[i].name, "Fnlistp") == 0
748 || strcmp (globals[i].name, "Fnull") == 0
749 || strcmp (globals[i].name, "Fnumberp") == 0
750 || strcmp (globals[i].name, "Fstringp") == 0
751 || strcmp (globals[i].name, "Fsymbolp") == 0
752 || strcmp (globals[i].name, "Ftool_bar_height") == 0
753 || strcmp (globals[i].name, "Fwindow__sanitize_window_sizes") == 0
754#ifndef WINDOWSNT
755 || strcmp (globals[i].name, "Fgnutls_available_p") == 0
756 || strcmp (globals[i].name, "Fzlib_available_p") == 0
757#endif
758 || 0)
759 fputs (" ATTRIBUTE_CONST", stdout); 731 fputs (" ATTRIBUTE_CONST", stdout);
732 else if (strcmp (globals[i].name, "Fnext_read_file_uses_dialog_p")
733 == 0)
734 {
735 /* It would be nice to have a cleaner way to deal with this
736 special hack. */
737 fputs (("\n"
738 "#if ! (defined USE_GTK || defined USE_MOTIF \\\n"
739 " || defined HAVE_NS || defined HAVE_NTGUI)\n"
740 "\tATTRIBUTE_CONST\n"
741 "#endif\n"),
742 stdout);
743 }
760 744
761 puts (";"); 745 puts (";");
762 } 746 }
@@ -817,6 +801,23 @@ scan_c_file (char *filename, const char *mode)
817 return scan_c_stream (infile); 801 return scan_c_stream (infile);
818} 802}
819 803
804/* Return 1 if next input from INFILE is equal to P, -1 if EOF,
805 0 if input doesn't match. */
806
807static int
808stream_match (FILE *infile, const char *p)
809{
810 for (; *p; p++)
811 {
812 int c = getc (infile);
813 if (c == EOF)
814 return -1;
815 if (c != *p)
816 return 0;
817 }
818 return 1;
819}
820
820static int 821static int
821scan_c_stream (FILE *infile) 822scan_c_stream (FILE *infile)
822{ 823{
@@ -1033,7 +1034,63 @@ scan_c_stream (FILE *infile)
1033 1034
1034 if (generate_globals) 1035 if (generate_globals)
1035 { 1036 {
1036 add_global (FUNCTION, name, maxargs, 0); 1037 struct global *g = add_global (FUNCTION, name, maxargs, 0);
1038
1039 /* The following code tries to recognize function attributes
1040 specified after the docstring, e.g.:
1041
1042 DEFUN ("foo", Ffoo, Sfoo, X, Y, Z,
1043 doc: /\* doc *\/
1044 attributes: attribute1 attribute2 ...)
1045 (Lisp_Object arg...)
1046
1047 Now only 'noreturn' and 'const' attributes are used. */
1048
1049 /* Advance to the end of docstring. */
1050 c = getc (infile);
1051 if (c == EOF)
1052 goto eof;
1053 int d = getc (infile);
1054 if (d == EOF)
1055 goto eof;
1056 while (1)
1057 {
1058 if (c == '*' && d == '/')
1059 break;
1060 c = d, d = getc (infile);
1061 if (d == EOF)
1062 goto eof;
1063 }
1064 /* Skip spaces, if any. */
1065 do
1066 {
1067 c = getc (infile);
1068 if (c == EOF)
1069 goto eof;
1070 }
1071 while (c == ' ' || c == '\n' || c == '\r' || c == '\t');
1072 /* Check for 'attributes:' token. */
1073 if (c == 'a' && stream_match (infile, "ttributes:"))
1074 {
1075 char *p = input_buffer;
1076 /* Collect attributes up to ')'. */
1077 while (1)
1078 {
1079 c = getc (infile);
1080 if (c == EOF)
1081 goto eof;
1082 if (c == ')')
1083 break;
1084 if (p - input_buffer > sizeof (input_buffer))
1085 abort ();
1086 *p++ = c;
1087 }
1088 *p = 0;
1089 if (strstr (input_buffer, "noreturn"))
1090 g->flags |= DEFUN_noreturn;
1091 if (strstr (input_buffer, "const"))
1092 g->flags |= DEFUN_const;
1093 }
1037 continue; 1094 continue;
1038 } 1095 }
1039 1096
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 674b26716a4..b7a38af9609 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,107 @@
12015-01-15 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * emacs-lisp/eieio-core.el: Provide support for cl-generic.
4 (eieio--generic-tagcode): New function.
5 (cl-generic-tagcode-function): Use it.
6 (eieio--generic-tag-types): New function.
7 (cl-generic-tag-types-function): Use it.
8 (eieio-object-p): Tighten up the test.
9
10 * emacs-lisp/cl-generic.el (cl-generic-define-method): Fix paren typo.
11
122015-01-14 Stefan Monnier <monnier@iro.umontreal.ca>
13
14 * emacs-lisp/cl-generic.el: New file.
15
16 * emacs-lisp/cl-macs.el (cl-flet): Allow (FUN EXP) forms.
17 (cl-load-time-value, cl-labels): Use closures rather than
18 backquoted lambdas.
19 (cl-macrolet): Use `eval' to create the function value, and support CL
20 style arguments in for the defined macros.
21
222015-01-14 Stefan Monnier <monnier@iro.umontreal.ca>
23
24 * net/eww.el: Use lexical-binding.
25 (eww-links-at-point): Remove unused arg.
26 (eww-mode-map): Inherit from special-mode-map.
27 (eww-mode): Derive from special-mode. Don't use `setq' on a hook.
28
292015-01-13 Alan Mackenzie <acm@muc.de>
30
31 Allow compilation during loading of Modes derived from a CC Mode mode.
32 Fixes debbugs#19206.
33
34 * progmodes/cc-bytecomp.el (cc-bytecomp-compiling-or-loading):
35 New function which walks the stack to discover whether we're compiling
36 or loading.
37 (cc-bytecomp-is-compiling): Reformulate, and move towards
38 beginning.
39 (cc-bytecomp-is-loading): New defsubst.
40 (cc-bytecomp-setup-environment, cc-bytecomp-restore-environment):
41 Use the above defsubsts.
42 (cc-require-when-compile, cc-bytecomp-defvar)
43 (cc-bytecomp-defun): Simplify conditionals.
44
45 * progmodes/cc-defs.el (cc-bytecomp-compiling-or-loading):
46 "Borrow" this function from cc-bytecomp.el.
47 (c-get-current-file): Reformulate using the above.
48 (c-lang-defconst): Prevent duplicate entries of file names in a
49 symbol's 'source property.
50 (c-lang-const): Use cc-bytecomp-is-compiling.
51
52 * progmodes/cc-langs.el (c-make-init-lang-vars-fun):
53 Use cc-bytecomp-is-compiling.
54
552015-01-13 Stefan Monnier <monnier@iro.umontreal.ca>
56
57 * emacs-lisp/eieio-core.el (eieio-defclass): Fix call to `defclass'
58 (bug#19552).
59
602015-01-13 Dmitry Gutov <dgutov@yandex.ru>
61
62 * menu-bar.el (menu-bar-goto-menu): Before calling
63 `xref-marker-stack-empty-p', first check that `xref' is loaded.
64 (Bug#19554)
65
662015-01-12 Martin Rudalics <rudalics@gmx.at>
67
68 * progmodes/xref.el (xref-marker-stack-empty-p): Add autoload
69 cookie (Bug#19554).
70
71 * frame.el (frame-notice-user-settings): Remove code dealing with
72 frame-initial-frame-tool-bar-height. Turn off `tool-bar-mode'
73 only if `window-system-frame-alist' or `default-frame-alist' ask
74 for it.
75 (make-frame): Update frame-adjust-size-history if needed.
76
772015-01-12 Paul Eggert <eggert@cs.ucla.edu>
78
79 Have 'make' output better GEN names
80 * Makefile.in (PHONY_EXTRAS): New macro.
81 (.PHONY): Depend on it, and on $(lisp)/loaddefs.el, so that the
82 relevant files' time stamps are ignored.
83 (custom-deps, $(lisp)/cus-load.el, finder-data)
84 ($(lisp)/finder-inf.el): Use PHONY_EXTRAS.
85 (custom-deps, $(lisp)/cus-load.el, finder-data)
86 ($(lisp)/finder-inf.el, autoloads, $(lisp)/loaddefs.el)
87 ($(lisp)/subdirs.el, update-subdirs):
88 Output more-accurate destination names with GEN.
89
90 Say "ELC foo.elc" instead of "GEN foo.elc"
91 * Makefile.in (AM_V_ELC, am__v_ELC_, am__v_ELC_0, am__v_ELC_1):
92 New macros.
93 ($(THEFILE)c, .el.elc): Use them.
94
952015-01-11 Michael Albinus <michael.albinus@gmx.de>
96
97 * files.el (directory-files-recursively): Do not include
98 superfluous remote file names.
99
1002015-01-11 Lars Magne Ingebrigtsen <larsi@gnus.org>
101
102 * net/eww.el (eww): Interpret anything that looks like a protocol
103 designator as a full URL.
104
12015-01-10 Lars Magne Ingebrigtsen <larsi@gnus.org> 1052015-01-10 Lars Magne Ingebrigtsen <larsi@gnus.org>
2 106
3 * net/shr.el (shr-urlify): Don't bother the user about 107 * net/shr.el (shr-urlify): Don't bother the user about
@@ -363,8 +467,8 @@
363 to `pre-command-hook'. 467 to `pre-command-hook'.
364 (xref--xref-buffer-mode-map): Don't remap `next-line' and 468 (xref--xref-buffer-mode-map): Don't remap `next-line' and
365 `previous-line'. Additionally bind `xref-next-line' and 469 `previous-line'. Additionally bind `xref-next-line' and
366 `xref-prev-line' to `n' and `p' respectively. Bind 470 `xref-prev-line' to `n' and `p' respectively.
367 `xref-show-location-at-point' to `C-o'. 471 Bind `xref-show-location-at-point' to `C-o'.
368 472
3692015-01-01 Eli Zaretskii <eliz@gnu.org> 4732015-01-01 Eli Zaretskii <eliz@gnu.org>
370 474
@@ -553,15 +657,15 @@
553 Add argument MSG to display user-friendly message when no process 657 Add argument MSG to display user-friendly message when no process
554 is running. 658 is running.
555 (python-shell-switch-to-shell): Call pop-to-buffer with NORECORD. 659 (python-shell-switch-to-shell): Call pop-to-buffer with NORECORD.
556 (python-shell-make-comint): Rename argument SHOW from POP. Use 660 (python-shell-make-comint): Rename argument SHOW from POP.
557 display-buffer instead of pop-to-buffer. 661 Use display-buffer instead of pop-to-buffer.
558 (run-python): Doc fix. Return process. 662 (run-python): Doc fix. Return process.
559 (python-shell-get-or-create-process): Make obsolete. 663 (python-shell-get-or-create-process): Make obsolete.
560 664
5612014-12-27 Fabián Ezequiel Gallina <fgallina@gnu.org> 6652014-12-27 Fabián Ezequiel Gallina <fgallina@gnu.org>
562 666
563 * progmodes/python.el (python-shell-buffer-substring): Handle 667 * progmodes/python.el (python-shell-buffer-substring):
564 cornercase when region sent starts at point-min. 668 Handle cornercase when region sent starts at point-min.
565 669
5662014-12-27 Eli Zaretskii <eliz@gnu.org> 6702014-12-27 Eli Zaretskii <eliz@gnu.org>
567 671
@@ -733,8 +837,8 @@
733 837
7342014-12-25 Filipp Gunbin <fgunbin@fastmail.fm> 8382014-12-25 Filipp Gunbin <fgunbin@fastmail.fm>
735 839
736 * dired-aux.el (dired-maybe-insert-subdir): Make 840 * dired-aux.el (dired-maybe-insert-subdir):
737 dired-maybe-insert-subdir always skip trivial files. 841 Make dired-maybe-insert-subdir always skip trivial files.
738 842
7392014-12-25 Helmut Eller <eller.helmut@gmail.com> 8432014-12-25 Helmut Eller <eller.helmut@gmail.com>
740 Dmitry Gutov <dgutov@yandex.ru> 844 Dmitry Gutov <dgutov@yandex.ru>
@@ -779,8 +883,8 @@
779 883
780 * window.el (mouse-autoselect-window-position-1): New variable. 884 * window.el (mouse-autoselect-window-position-1): New variable.
781 (mouse-autoselect-window-cancel) 885 (mouse-autoselect-window-cancel)
782 (mouse-autoselect-window-select, handle-select-window): With 886 (mouse-autoselect-window-select, handle-select-window):
783 delayed autoselection select window only if mouse moves after 887 With delayed autoselection select window only if mouse moves after
784 selecting its frame. 888 selecting its frame.
785 889
7862014-12-24 Michael Albinus <michael.albinus@gmx.de> 8902014-12-24 Michael Albinus <michael.albinus@gmx.de>
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index 565ca77de3b..7bf53861e71 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -31,6 +31,11 @@ XARGS_LIMIT = @XARGS_LIMIT@
31# 'make' verbosity. 31# 'make' verbosity.
32AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@ 32AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@
33 33
34AM_V_ELC = $(am__v_ELC_@AM_V@)
35am__v_ELC_ = $(am__v_ELC_@AM_DEFAULT_V@)
36am__v_ELC_0 = @echo " ELC " $@;
37am__v_ELC_1 =
38
34AM_V_GEN = $(am__v_GEN_@AM_V@) 39AM_V_GEN = $(am__v_GEN_@AM_V@)
35am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@) 40am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@)
36am__v_GEN_0 = @echo " GEN " $@; 41am__v_GEN_0 = @echo " GEN " $@;
@@ -145,7 +150,8 @@ setwins_for_subdirs=for file in `find ${srcdir} -type d -print`; do \
145# we add them here to make sure they get built. 150# we add them here to make sure they get built.
146all: compile-main $(lisp)/cus-load.el $(lisp)/finder-inf.el 151all: compile-main $(lisp)/cus-load.el $(lisp)/finder-inf.el
147 152
148.PHONY: all custom-deps finder-data autoloads update-subdirs 153PHONY_EXTRAS =
154.PHONY: all custom-deps finder-data autoloads update-subdirs $(PHONY_EXTRAS)
149 155
150# custom-deps and finder-data both used to scan _all_ the *.el files. 156# custom-deps and finder-data both used to scan _all_ the *.el files.
151# This could lead to problems in parallel builds if automatically 157# 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
161# Nowadays these commands don't scan automatically generated files, 167# Nowadays these commands don't scan automatically generated files,
162# since they will never contain any useful information 168# since they will never contain any useful information
163# (see finder-no-scan-regexp and custom-dependencies-no-scan-regexp). 169# (see finder-no-scan-regexp and custom-dependencies-no-scan-regexp).
164$(lisp)/cus-load.el:
165 $(MAKE) custom-deps
166custom-deps: 170custom-deps:
171 $(AM_V_at)$(MAKE) PHONY_EXTRAS=$(lisp)/cus-load.el $(lisp)/cus-load.el
172$(lisp)/cus-load.el:
167 $(AM_V_GEN)$(setwins_almost); \ 173 $(AM_V_GEN)$(setwins_almost); \
168 echo Directories: $$wins; \ 174 echo Directories: $$wins; \
169 $(emacs) -l cus-dep \ 175 $(emacs) -l cus-dep \
170 --eval '(setq generated-custom-dependencies-file (unmsys--file-name "$(srcdir)/cus-load.el"))' \ 176 --eval '(setq generated-custom-dependencies-file (unmsys--file-name "$(srcdir)/cus-load.el"))' \
171 -f custom-make-dependencies $$wins 177 -f custom-make-dependencies $$wins
172 178
173$(lisp)/finder-inf.el:
174 $(MAKE) finder-data
175finder-data: 179finder-data:
180 $(AM_V_at)$(MAKE) PHONY_EXTRAS=$(lisp)/finder-inf.el \
181 $(lisp)/finder-inf.el
182$(lisp)/finder-inf.el:
176 $(AM_V_GEN)$(setwins_finder); \ 183 $(AM_V_GEN)$(setwins_finder); \
177 echo Directories: $$wins; \ 184 echo Directories: $$wins; \
178 $(emacs) -l finder \ 185 $(emacs) -l finder \
@@ -185,21 +192,22 @@ finder-data:
185# Note that we set no-update-autoloads in _generated_ leim files. 192# Note that we set no-update-autoloads in _generated_ leim files.
186# If you want to allow autoloads in such files, remove that, 193# If you want to allow autoloads in such files, remove that,
187# and make this depend on leim. 194# and make this depend on leim.
188autoloads: $(LOADDEFS) 195autoloads .PHONY: $(lisp)/loaddefs.el
196$(lisp)/loaddefs.el: $(LOADDEFS)
189 $(AM_V_GEN)$(setwins_almost); \ 197 $(AM_V_GEN)$(setwins_almost); \
190 echo Directories: $$wins; \ 198 echo Directories: $$wins; \
191 $(emacs) -l autoload \ 199 $(emacs) -l autoload \
192 --eval '(setq autoload-ensure-writable t)' \ 200 --eval '(setq autoload-ensure-writable t)' \
193 --eval '(setq autoload-builtin-package-versions t)' \ 201 --eval '(setq autoload-builtin-package-versions t)' \
194 --eval '(setq generated-autoload-file (expand-file-name (unmsys--file-name "$(srcdir)/loaddefs.el")))' \ 202 --eval '(setq generated-autoload-file (expand-file-name (unmsys--file-name "$@")))' \
195 -f batch-update-autoloads $$wins 203 -f batch-update-autoloads $$wins
196 204
197# This is required by the bootstrap-emacs target in ../src/Makefile, so 205# This is required by the bootstrap-emacs target in ../src/Makefile, so
198# we know that if we have an emacs executable, we also have a subdirs.el. 206# we know that if we have an emacs executable, we also have a subdirs.el.
199$(lisp)/subdirs.el: 207$(lisp)/subdirs.el:
200 $(MAKE) update-subdirs 208 $(AM_V_GEN)$(MAKE) update-subdirs
201update-subdirs: 209update-subdirs:
202 $(AM_V_GEN)$(setwins_for_subdirs); \ 210 $(AM_V_at)$(setwins_for_subdirs); \
203 for file in $$wins; do \ 211 for file in $$wins; do \
204 $(srcdir)/../build-aux/update-subdirs $$file; \ 212 $(srcdir)/../build-aux/update-subdirs $$file; \
205 done; 213 done;
@@ -260,7 +268,7 @@ TAGS: $(lisptagsfiles1) $(lisptagsfiles2) $(lisptagsfiles3) $(lisptagsfiles4)
260THEFILE = no-such-file 268THEFILE = no-such-file
261.PHONY: $(THEFILE)c 269.PHONY: $(THEFILE)c
262$(THEFILE)c: 270$(THEFILE)c:
263 $(AM_V_GEN)$(emacs) $(BYTE_COMPILE_FLAGS) \ 271 $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \
264 -l bytecomp -f byte-compile-refresh-preloaded \ 272 -l bytecomp -f byte-compile-refresh-preloaded \
265 -f batch-byte-compile $(THEFILE) 273 -f batch-byte-compile $(THEFILE)
266 274
@@ -276,7 +284,7 @@ $(THEFILE)c:
276# An old-fashioned suffix rule, which, according to the GNU Make manual, 284# An old-fashioned suffix rule, which, according to the GNU Make manual,
277# cannot have prerequisites. 285# cannot have prerequisites.
278.el.elc: 286.el.elc:
279 $(AM_V_GEN)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $< 287 $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $<
280 288
281.PHONY: compile-first compile-main compile compile-always 289.PHONY: compile-first compile-main compile compile-always
282 290
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
new file mode 100644
index 00000000000..41a419a3c4a
--- /dev/null
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -0,0 +1,607 @@
1;;; cl-generic.el --- CLOS-style generic functions for Elisp -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2015 Free Software Foundation, Inc.
4
5;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23
24;; This implements the most of CLOS's multiple-dispatch generic functions.
25;; To use it you need either (require 'cl-generic) or (require 'cl-lib).
26;; The main entry points are: `cl-defgeneric' and `cl-defmethod'.
27
28;; Missing elements:
29;; - We don't support next-method-p, make-method, call-method,
30;; define-method-combination.
31;; - Method and generic function objects: CLOS defines methods as objects
32;; (same for generic functions), whereas we don't offer such an abstraction.
33;; - `no-next-method' should receive the "calling method" object, but since we
34;; don't have such a thing, we pass nil instead.
35;; - In defgeneric we don't support the options:
36;; declare, :method-combination, :generic-function-class, :method-class,
37;; :method.
38;; Added elements:
39;; - We support aliases to generic functions.
40;; - The kind of thing on which to dispatch can be extended.
41;; There is support in this file for (eql <val>) dispatch as well as dispatch
42;; on the type of CL structs, and eieio-core.el adds support for EIEIO
43;; defclass objects.
44
45;;; Code:
46
47;; Note: For generic functions that dispatch on several arguments (i.e. those
48;; which use the multiple-dispatch feature), we always use the same "tagcodes"
49;; and the same set of arguments on which to dispatch. This works, but is
50;; often suboptimal since after one dispatch, the remaining dispatches can
51;; usually be simplified, or even completely skipped.
52
53(eval-when-compile (require 'cl-lib))
54(eval-when-compile (require 'pcase))
55
56(defvar cl-generic-tagcode-function
57 (lambda (type _name)
58 (if (eq type t) '(0 . 'cl--generic-type)
59 (error "Unknown specializer %S" type)))
60 "Function to get the Elisp code to extract the tag on which we dispatch.
61Takes a \"parameter-specializer-name\" and a variable name, and returns
62a pair (PRIORITY . CODE) where CODE is an Elisp expression that should be
63used to extract the \"tag\" (from the object held in the named variable)
64that should uniquely determine if we have a match
65\(i.e. the \"tag\" is the value that will be used to dispatch to the proper
66method(s)).
67Such \"tagcodes\" will be or'd together.
68PRIORITY is an integer from 0 to 100 which is used to sort the tagcodes
69in the `or'. The higher the priority, the more specific the tag should be.
70More specifically, if PRIORITY is N and we have two objects X and Y
71whose tag (according to TAGCODE) is `eql', then it should be the case
72that for all other (PRIORITY . TAGCODE) where PRIORITY ≤ N, then
73\(eval TAGCODE) for X is `eql' to (eval TAGCODE) for Y.")
74
75(defvar cl-generic-tag-types-function
76 (lambda (tag) (if (eq tag 'cl--generic-type) '(t)))
77 "Function to get the list of types that a given \"tag\" matches.
78They should be sorted from most specific to least specific.")
79
80(cl-defstruct (cl--generic
81 (:constructor nil)
82 (:constructor cl--generic-make
83 (name &optional dispatches method-table))
84 (:predicate nil))
85 (name nil :read-only t) ;Pointer back to the symbol.
86 ;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index
87 ;; of the corresponding argument and TAGCODES is a list of (PRIORITY . EXP)
88 ;; where the EXPs are expressions (to be `or'd together) to compute the tag
89 ;; on which to dispatch and PRIORITY is the priority of each expression to
90 ;; decide in which order to sort them.
91 ;; The most important dispatch is last in the list (and the least is first).
92 dispatches
93 ;; `method-table' is a list of
94 ;; ((SPECIALIZERS . QUALIFIER) USES-CNM . FUNCTION), where
95 ;; USES-CNM is a boolean indicating if FUNCTION calls `cl-call-next-method'
96 ;; (and hence expects an extra argument holding the next-method).
97 method-table)
98
99(defmacro cl--generic (name)
100 `(get ,name 'cl--generic))
101
102(defun cl-generic-ensure-function (name)
103 (let (generic
104 (origname name))
105 (while (and (null (setq generic (cl--generic name)))
106 (fboundp name)
107 (symbolp (symbol-function name)))
108 (setq name (symbol-function name)))
109 (unless (or (not (fboundp name))
110 (and (functionp name) generic))
111 (error "%s is already defined as something else than a generic function"
112 origname))
113 (if generic
114 (cl-assert (eq name (cl--generic-name generic)))
115 (setf (cl--generic name) (setq generic (cl--generic-make name)))
116 (defalias name (cl--generic-make-function generic)))
117 generic))
118
119(defun cl--generic-setf-rewrite (name)
120 (let ((setter (intern (format "cl-generic-setter--%s" name))))
121 (cons setter
122 `(eval-and-compile
123 (unless (eq ',setter (get ',name 'cl-generic-setter))
124 ;; (when (get ',name 'gv-expander)
125 ;; (error "gv-expander conflicts with (setf %S)" ',name))
126 (setf (get ',name 'cl-generic-setter) ',setter)
127 (gv-define-setter ,name (val &rest args)
128 (cons ',setter (cons val args))))))))
129
130;;;###autoload
131(defmacro cl-defgeneric (name args &rest options-and-methods)
132 "Create a generic function NAME.
133DOC-STRING is the base documentation for this class. A generic
134function has no body, as its purpose is to decide which method body
135is appropriate to use. Specific methods are defined with `defmethod'.
136With this implementation the ARGS are currently ignored.
137OPTIONS-AND-METHODS is currently only used to specify the docstring,
138via (:documentation DOCSTRING)."
139 (declare (indent 2) (doc-string 3))
140 (let* ((docprop (assq :documentation options-and-methods))
141 (doc (cond ((stringp (car-safe options-and-methods))
142 (pop options-and-methods))
143 (docprop
144 (prog1
145 (cadr docprop)
146 (setq options-and-methods
147 (delq docprop options-and-methods)))))))
148 `(progn
149 ,(when (eq 'setf (car-safe name))
150 (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite
151 (cadr name))))
152 (setq name setter)
153 code))
154 (defalias ',name
155 (cl-generic-define ',name ',args ',options-and-methods)
156 ,doc))))
157
158(defun cl--generic-mandatory-args (args)
159 (let ((res ()))
160 (while (not (memq (car args) '(nil &rest &optional &key)))
161 (push (pop args) res))
162 (nreverse res)))
163
164;;;###autoload
165(defun cl-generic-define (name args options-and-methods)
166 (let ((generic (cl-generic-ensure-function name))
167 (mandatory (cl--generic-mandatory-args args))
168 (apo (assq :argument-precedence-order options-and-methods)))
169 (setf (cl--generic-dispatches generic) nil)
170 (when apo
171 (dolist (arg (cdr apo))
172 (let ((pos (memq arg mandatory)))
173 (unless pos (error "%S is not a mandatory argument" arg))
174 (push (list (- (length mandatory) (length pos)))
175 (cl--generic-dispatches generic)))))
176 (setf (cl--generic-method-table generic) nil)
177 (cl--generic-make-function generic)))
178
179(defvar cl-generic-current-method-specializers nil
180 ;; This is let-bound during macro-expansion of method bodies, so that those
181 ;; bodies can be optimized knowing that the specializers have matched.
182 ;; FIXME: This presumes the formal arguments aren't modified via `setq' and
183 ;; aren't shadowed either ;-(
184 ;; FIXME: This might leak outside the scope of the method if, during
185 ;; macroexpansion of the method, something causes some other macroexpansion
186 ;; (e.g. an autoload).
187 "List of (VAR . TYPE) where TYPE is var's specializer.")
188
189(eval-and-compile ;Needed while compiling the cl-defmethod calls below!
190 (defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el.
191 "Check which of the symbols VARS appear in SEXP."
192 (let ((res '()))
193 (while (consp sexp)
194 (dolist (var (cl--generic-fgrep vars (pop sexp)))
195 (unless (memq var res) (push var res))))
196 (and (memq sexp vars) (not (memq sexp res)) (push sexp res))
197 res))
198
199 (defun cl--generic-lambda (args body with-cnm)
200 "Make the lambda expression for a method with ARGS and BODY."
201 (let ((plain-args ())
202 (cl-generic-current-method-specializers nil)
203 (doc-string (if (stringp (car-safe body)) (pop body)))
204 (mandatory t))
205 (dolist (arg args)
206 (push (pcase arg
207 ((or '&optional '&rest '&key) (setq mandatory nil) arg)
208 ((and `(,name . ,type) (guard mandatory))
209 (push (cons name (car type))
210 cl-generic-current-method-specializers)
211 name)
212 (_ arg))
213 plain-args))
214 (setq plain-args (nreverse plain-args))
215 (let ((fun `(cl-function (lambda ,plain-args
216 ,@(if doc-string (list doc-string))
217 ,@body))))
218 (if (not with-cnm)
219 (cons nil fun)
220 ;; First macroexpand away the cl-function stuff (e.g. &key and
221 ;; destructuring args, `declare' and whatnot).
222 (pcase (macroexpand fun macroexpand-all-environment)
223 (`#'(lambda ,args . ,body)
224 (require 'cl-lib) ;Needed to expand `cl-flet'.
225 (let* ((doc-string (and doc-string (stringp (car body))
226 (pop body)))
227 (cnm (make-symbol "cl--cnm"))
228 (nbody (macroexpand-all
229 `(cl-flet ((cl-call-next-method ,cnm))
230 ,@body)
231 macroexpand-all-environment))
232 ;; FIXME: Rather than `grep' after the fact, the
233 ;; macroexpansion should directly set some flag when cnm
234 ;; is used.
235 ;; FIXME: Also, optimize the case where call-next-method is
236 ;; only called with explicit arguments.
237 (uses-cnm (cl--generic-fgrep (list cnm) nbody)))
238 (cons (not (not uses-cnm))
239 `#'(lambda (,@(if uses-cnm (list cnm)) ,@args)
240 ,@(if doc-string (list doc-string))
241 ,nbody))))
242 (f (error "Unexpected macroexpansion result: %S" f))))))))
243
244
245;;;###autoload
246(defmacro cl-defmethod (name args &rest body)
247 "Define a new method for generic function NAME.
248I.e. it defines the implementation of NAME to use for invocations where the
249value of the dispatch argument matches the specified TYPE.
250The dispatch argument has to be one of the mandatory arguments, and
251all methods of NAME have to use the same argument for dispatch.
252The dispatch argument and TYPE are specified in ARGS where the corresponding
253formal argument appears as (VAR TYPE) rather than just VAR.
254
255The optional second argument QUALIFIER is a specifier that
256modifies how the method is combined with other methods, including:
257 :before - Method will be called before the primary
258 :after - Method will be called after the primary
259 :around - Method will be called around everything else
260The absence of QUALIFIER means this is a \"primary\" method.
261
262Other than a type, TYPE can also be of the form `(eql VAL)' in
263which case this method will be invoked when the argument is `eql' to VAL.
264
265\(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)"
266 (declare (doc-string 3) (indent 2))
267 (let ((qualifiers nil))
268 (while (keywordp args)
269 (push args qualifiers)
270 (setq args (pop body)))
271 (pcase-let* ((with-cnm (not (memq (car qualifiers) '(:before :after))))
272 (`(,uses-cnm . ,fun) (cl--generic-lambda args body with-cnm)))
273 `(progn
274 ,(when (eq 'setf (car-safe name))
275 (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite
276 (cadr name))))
277 (setq name setter)
278 code))
279 (cl-generic-define-method ',name ',qualifiers ',args
280 ,uses-cnm ,fun)))))
281
282;;;###autoload
283(defun cl-generic-define-method (name qualifiers args uses-cnm function)
284 (when (> (length qualifiers) 1)
285 (error "We only support a single qualifier per method: %S" qualifiers))
286 (unless (memq (car qualifiers) '(nil :primary :around :after :before))
287 (error "Unsupported qualifier in: %S" qualifiers))
288 (let* ((generic (cl-generic-ensure-function name))
289 (mandatory (cl--generic-mandatory-args args))
290 (specializers
291 (mapcar (lambda (arg) (if (consp arg) (cadr arg) t)) mandatory))
292 (key (cons specializers (or (car qualifiers) ':primary)))
293 (mt (cl--generic-method-table generic))
294 (me (assoc key mt))
295 (dispatches (cl--generic-dispatches generic))
296 (i 0))
297 (dolist (specializer specializers)
298 (let* ((tagcode (funcall cl-generic-tagcode-function specializer 'arg))
299 (x (assq i dispatches)))
300 (if (not x)
301 (setf (cl--generic-dispatches generic)
302 (setq dispatches (cons (list i tagcode) dispatches)))
303 (unless (member tagcode (cdr x))
304 (setf (cdr x)
305 (nreverse (sort (cons tagcode (cdr x))
306 #'car-less-than-car)))))
307 (setq i (1+ i))))
308 (if me (setcdr me (cons uses-cnm function))
309 (setf (cl--generic-method-table generic)
310 (cons `(,key ,uses-cnm . ,function) mt)))
311 ;; For aliases, cl--generic-name gives us the actual name.
312 (defalias (cl--generic-name generic)
313 (cl--generic-make-function generic))))
314
315(defmacro cl--generic-with-memoization (place &rest code)
316 (declare (indent 1) (debug t))
317 (gv-letplace (getter setter) place
318 `(or ,getter
319 ,(macroexp-let2 nil val (macroexp-progn code)
320 `(progn
321 ,(funcall setter val)
322 ,val)))))
323
324(defvar cl--generic-dispatchers (make-hash-table :test #'equal))
325
326(defun cl--generic-get-dispatcher (tagcodes dispatch-arg)
327 (cl--generic-with-memoization
328 (gethash (cons dispatch-arg tagcodes) cl--generic-dispatchers)
329 (let ((lexical-binding t)
330 (extraargs ()))
331 (dotimes (_ dispatch-arg)
332 (push (make-symbol "arg") extraargs))
333 (byte-compile
334 `(lambda (generic dispatches-left)
335 (let ((method-cache (make-hash-table :test #'eql)))
336 (lambda (,@extraargs arg &rest args)
337 (apply (cl--generic-with-memoization
338 (gethash (or ,@(mapcar #'cdr tagcodes)) method-cache)
339 (cl--generic-cache-miss
340 generic ',dispatch-arg dispatches-left
341 (list ,@(mapcar #'cdr tagcodes))))
342 ,@extraargs arg args))))))))
343
344(defun cl--generic-make-function (generic)
345 (let* ((dispatches (cl--generic-dispatches generic))
346 (dispatch
347 (progn
348 (while (and dispatches
349 (member (cdar dispatches)
350 '(nil ((0 . 'cl--generic-type)))))
351 (setq dispatches (cdr dispatches)))
352 (pop dispatches))))
353 (if (null dispatch)
354 (cl--generic-build-combined-method
355 (cl--generic-name generic)
356 (cl--generic-method-table generic))
357 (let ((dispatcher (cl--generic-get-dispatcher
358 (cdr dispatch) (car dispatch))))
359 (funcall dispatcher generic dispatches)))))
360
361(defun cl--generic-nest (fun methods)
362 (pcase-dolist (`(,uses-cnm . ,method) methods)
363 (setq fun
364 (if (not uses-cnm) method
365 (let ((next fun))
366 (lambda (&rest args)
367 (apply method
368 ;; FIXME: This sucks: passing just `next' would
369 ;; be a lot more efficient than the lambda+apply
370 ;; quasi-η, but we need this to implement the
371 ;; "if call-next-method is called with no
372 ;; arguments, then use the previous arguments".
373 (lambda (&rest cnm-args)
374 (apply next (or cnm-args args)))
375 args))))))
376 fun)
377
378(defvar cl--generic-combined-method-memoization
379 (make-hash-table :test #'equal :weakness 'value)
380 "Table storing previously built combined-methods.
381This is particularly useful when many different tags select the same set
382of methods, since this table then allows us to share a single combined-method
383for all those different tags in the method-cache.")
384
385(defun cl--generic-build-combined-method (generic-name methods)
386 (let ((mets-by-qual ()))
387 (dolist (qm methods)
388 (push (cdr qm) (alist-get (cdar qm) mets-by-qual)))
389 (cl--generic-with-memoization
390 (gethash (cons generic-name mets-by-qual)
391 cl--generic-combined-method-memoization)
392 (cond
393 ((null mets-by-qual) (lambda (&rest args)
394 (cl-no-applicable-method generic-name args)))
395 (t
396 (let* ((fun (lambda (&rest args)
397 ;; FIXME: CLOS passes as second arg the "calling method".
398 ;; We don't currently have "method objects" like CLOS
399 ;; does so we can't really do it the CLOS way.
400 ;; The closest would be to pass the lambda corresponding
401 ;; to the method, but the caller wouldn't be able to do
402 ;; much with it anyway. So we pass nil for now.
403 (apply #'cl-no-next-method generic-name nil args)))
404 ;; We use `cdr' to drop the `uses-cnm' annotations.
405 (before
406 (mapcar #'cdr (reverse (alist-get :before mets-by-qual))))
407 (after (mapcar #'cdr (alist-get :after mets-by-qual))))
408 (setq fun (cl--generic-nest fun (alist-get :primary mets-by-qual)))
409 (when (or after before)
410 (let ((next fun))
411 (setq fun (lambda (&rest args)
412 (dolist (bf before)
413 (apply bf args))
414 (apply next args)
415 (dolist (af after)
416 (apply af args))))))
417 (cl--generic-nest fun (alist-get :around mets-by-qual))))))))
418
419(defun cl--generic-cache-miss (generic dispatch-arg dispatches-left tags)
420 (let ((types (apply #'append (mapcar cl-generic-tag-types-function tags)))
421 (methods '()))
422 (dolist (method-desc (cl--generic-method-table generic))
423 (let ((m (member (nth dispatch-arg (caar method-desc)) types)))
424 (when m
425 (push (cons (length m) method-desc) methods))))
426 ;; Sort the methods, most specific first.
427 ;; It would be tempting to sort them once and for all in the method-table
428 ;; rather than here, but the order might depend on the actual argument
429 ;; (e.g. for multiple inheritance with defclass).
430 (setq methods (nreverse (mapcar #'cdr (sort methods #'car-less-than-car))))
431 (cl--generic-make-function (cl--generic-make (cl--generic-name generic)
432 dispatches-left methods))))
433
434;;; Define some pre-defined generic functions, used internally.
435
436(define-error 'cl-no-method "No method for %S")
437(define-error 'cl-no-next-method "No next method for %S" 'cl-no-method)
438(define-error 'cl-no-applicable-method "No applicable method for %S"
439 'cl-no-method)
440
441(cl-defgeneric cl-no-next-method (generic method &rest args)
442 "Function called when `cl-call-next-method' finds no next method.")
443(cl-defmethod cl-no-next-method ((generic t) method &rest args)
444 (signal 'cl-no-next-method `(,generic ,method ,@args)))
445
446(cl-defgeneric cl-no-applicable-method (generic &rest args)
447 "Function called when a method call finds no applicable method.")
448(cl-defmethod cl-no-applicable-method ((generic t) &rest args)
449 (signal 'cl-no-applicable-method `(,generic ,@args)))
450
451(defun cl-call-next-method (&rest _args)
452 "Function to call the next applicable method.
453Can only be used from within the lexical body of a primary or around method."
454 (error "cl-call-next-method only allowed inside primary and around methods"))
455
456;;; Add support for describe-function
457
458(add-hook 'help-fns-describe-function-functions 'cl--generic-describe)
459(defun cl--generic-describe (function)
460 ;; FIXME: Fix up the main "in `<file>'" hyperlink, and add such hyperlinks
461 ;; for each method.
462 (let ((generic (if (symbolp function) (cl--generic function))))
463 (when generic
464 (save-excursion
465 (insert "\n\nThis is a generic function.\n\n")
466 (insert (propertize "Implementations:\n\n" 'face 'bold))
467 ;; Loop over fanciful generics
468 (pcase-dolist (`((,type . ,qualifier) . ,method)
469 (cl--generic-method-table generic))
470 (insert "`")
471 (if (symbolp type)
472 ;; FIXME: Add support for cl-structs in help-variable.
473 (help-insert-xref-button (symbol-name type)
474 'help-variable type)
475 (insert (format "%S" type)))
476 (insert (format "' %S %S\n"
477 (car qualifier)
478 (let ((args (help-function-arglist method)))
479 ;; Drop cl--generic-next arg if present.
480 (if (memq (car qualifier) '(:after :before))
481 args (cdr args)))))
482 (insert (or (documentation method) "Undocumented") "\n\n"))))))
483
484;;; Support for (eql <val>) specializers.
485
486(defvar cl--generic-eql-used (make-hash-table :test #'eql))
487
488(add-function :before-until cl-generic-tagcode-function
489 #'cl--generic-eql-tagcode)
490(defun cl--generic-eql-tagcode (type name)
491 (when (eq (car-safe type) 'eql)
492 (puthash (cadr type) type cl--generic-eql-used)
493 `(100 . (gethash ,name cl--generic-eql-used))))
494
495(add-function :before-until cl-generic-tag-types-function
496 #'cl--generic-eql-tag-types)
497(defun cl--generic-eql-tag-types (tag)
498 (if (eq (car-safe tag) 'eql) (list tag)))
499
500;;; Support for cl-defstructs specializers.
501
502(add-function :before-until cl-generic-tagcode-function
503 #'cl--generic-struct-tagcode)
504(defun cl--generic-struct-tagcode (type name)
505 (and (symbolp type)
506 (get type 'cl-struct-type)
507 (or (eq 'vector (car (get type 'cl-struct-type)))
508 (error "Can't dispatch on cl-struct %S: type is %S"
509 type (car (get type 'cl-struct-type))))
510 (or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots)))
511 (error "Can't dispatch on cl-struct %S: no tag in slot 0"
512 type))
513 ;; We could/should check the vector has length >0,
514 ;; but really, mixing vectors and structs is a bad idea,
515 ;; so let's not waste time trying to handle the case
516 ;; of an empty vector.
517 ;; BEWARE: this returns a bogus tag for non-struct vectors.
518 `(50 . (and (vectorp ,name) (aref ,name 0)))))
519
520(add-function :before-until cl-generic-tag-types-function
521 #'cl--generic-struct-tag-types)
522(defun cl--generic-struct-tag-types (tag)
523 ;; FIXME: cl-defstruct doesn't make it easy for us.
524 (and (symbolp tag)
525 ;; A method call shouldn't itself mess with the match-data.
526 (string-match-p "\\`cl-struct-\\(.*\\)" (symbol-name tag))
527 (let ((types (list (intern (substring (symbol-name tag) 10)))))
528 (while (get (car types) 'cl-struct-include)
529 (push (get (car types) 'cl-struct-include) types))
530 (push 'cl-struct types) ;The "parent type" of all cl-structs.
531 (nreverse types))))
532
533;;; Dispatch on "old-style types".
534
535(defconst cl--generic-typeof-types
536 ;; Hand made from the source code of `type-of'.
537 '((integer number) (symbol) (string array) (cons list)
538 ;; Markers aren't `numberp', yet they are accepted wherever integers are
539 ;; accepted, pretty much.
540 (marker) (overlay) (float number) (window-configuration)
541 (process) (window) (subr) (compiled-function) (buffer) (char-table array)
542 (bool-vector array)
543 (frame) (hash-table) (font-spec) (font-entity) (font-object)
544 (vector array)
545 ;; Plus, hand made:
546 (null list symbol)
547 (list)
548 (array)
549 (number)))
550
551(add-function :before-until cl-generic-tagcode-function
552 #'cl--generic-typeof-tagcode)
553(defun cl--generic-typeof-tagcode (type name)
554 ;; FIXME: Add support for other types accepted by `cl-typep' such
555 ;; as `character', `atom', `face', `function', ...
556 (and (assq type cl--generic-typeof-types)
557 (progn
558 (if (memq type '(vector array))
559 (message "`%S' also matches CL structs and EIEIO classes" type))
560 ;; FIXME: We could also change `type-of' to return `null' for nil.
561 `(10 . (if ,name (type-of ,name) 'null)))))
562
563(add-function :before-until cl-generic-tag-types-function
564 #'cl--generic-typeof-types)
565(defun cl--generic-typeof-types (tag)
566 (and (symbolp tag)
567 (assq tag cl--generic-typeof-types)))
568
569;;; Just for kicks: dispatch on major-mode
570;;
571;; Here's how you'd use it:
572;; (cl-defmethod foo ((x (major-mode text-mode)) y z) ...)
573;; And then
574;; (foo 'major-mode toto titi)
575;;
576;; FIXME: Better would be to do that via dispatch on an "implicit argument".
577
578;; (defvar cl--generic-major-modes (make-hash-table :test #'eq))
579;;
580;; (add-function :before-until cl-generic-tagcode-function
581;; #'cl--generic-major-mode-tagcode)
582;; (defun cl--generic-major-mode-tagcode (type name)
583;; (if (eq 'major-mode (car-safe type))
584;; `(50 . (if (eq ,name 'major-mode)
585;; (cl--generic-with-memoization
586;; (gethash major-mode cl--generic-major-modes)
587;; `(cl--generic-major-mode . ,major-mode))))))
588;;
589;; (add-function :before-until cl-generic-tag-types-function
590;; #'cl--generic-major-mode-types)
591;; (defun cl--generic-major-mode-types (tag)
592;; (when (eq (car-safe tag) 'cl--generic-major-mode)
593;; (if (eq tag 'fundamental-mode) '(fundamental-mode t)
594;; (let ((types `((major-mode ,(cdr tag)))))
595;; (while (get (car types) 'derived-mode-parent)
596;; (push (list 'major-mode (get (car types) 'derived-mode-parent))
597;; types))
598;; (unless (eq 'fundamental-mode (car types))
599;; (push '(major-mode fundamental-mode) types))
600;; (nreverse types)))))
601
602;; Local variables:
603;; generated-autoload-file: "cl-loaddefs.el"
604;; End:
605
606(provide 'cl-generic)
607;;; cl-generic.el ends here
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index fff5b27315c..0070599af6f 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."
625 (set `(setq ,temp ,form))) 625 (set `(setq ,temp ,form)))
626 (if (and (fboundp 'byte-compile-file-form-defmumble) 626 (if (and (fboundp 'byte-compile-file-form-defmumble)
627 (boundp 'this-kind) (boundp 'that-one)) 627 (boundp 'this-kind) (boundp 'that-one))
628 (fset 'byte-compile-file-form 628 ;; Else, we can't output right away, so we have to delay it to the
629 `(lambda (form) 629 ;; next time we're at the top-level.
630 (fset 'byte-compile-file-form 630 ;; FIXME: Use advice-add/remove.
631 ',(symbol-function 'byte-compile-file-form)) 631 (fset 'byte-compile-file-form
632 (byte-compile-file-form ',set) 632 (let ((old (symbol-function 'byte-compile-file-form)))
633 (byte-compile-file-form form))) 633 (lambda (form)
634 (print set (symbol-value 'byte-compile--outbuffer))) 634 (fset 'byte-compile-file-form old)
635 `(symbol-value ',temp)) 635 (byte-compile-file-form set)
636 (byte-compile-file-form form))))
637 ;; If we're not in the middle of compiling something, we can
638 ;; output directly to byte-compile-outbuffer, to make sure
639 ;; temp is set before we use it.
640 (print set byte-compile--outbuffer))
641 temp)
636 `',(eval form))) 642 `',(eval form)))
637 643
638 644
@@ -1824,18 +1830,30 @@ a `let' form, except that the list of symbols can be computed at run-time."
1824(defmacro cl-flet (bindings &rest body) 1830(defmacro cl-flet (bindings &rest body)
1825 "Make local function definitions. 1831 "Make local function definitions.
1826Like `cl-labels' but the definitions are not recursive. 1832Like `cl-labels' but the definitions are not recursive.
1833Each binding can take the form (FUNC EXP) where
1834FUNC is the function name, and EXP is an expression that returns the
1835function value to which it should be bound, or it can take the more common
1836form \(FUNC ARGLIST BODY...) which is a shorthand
1837for (FUNC (lambda ARGLIST BODY)).
1827 1838
1828\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" 1839\(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
1829 (declare (indent 1) (debug ((&rest (cl-defun)) cl-declarations body))) 1840 (declare (indent 1) (debug ((&rest (cl-defun)) cl-declarations body)))
1830 (let ((binds ()) (newenv macroexpand-all-environment)) 1841 (let ((binds ()) (newenv macroexpand-all-environment))
1831 (dolist (binding bindings) 1842 (dolist (binding bindings)
1832 (let ((var (make-symbol (format "--cl-%s--" (car binding))))) 1843 (let ((var (make-symbol (format "--cl-%s--" (car binding))))
1833 (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) 1844 (args-and-body (cdr binding)))
1845 (if (and (= (length args-and-body) 1) (symbolp (car args-and-body)))
1846 ;; Optimize (cl-flet ((fun var)) body).
1847 (setq var (car args-and-body))
1848 (push (list var (if (= (length args-and-body) 1)
1849 (car args-and-body)
1850 `(cl-function (lambda . ,args-and-body))))
1851 binds))
1834 (push (cons (car binding) 1852 (push (cons (car binding)
1835 `(lambda (&rest cl-labels-args) 1853 (lambda (&rest cl-labels-args)
1836 (cl-list* 'funcall ',var 1854 (cl-list* 'funcall var cl-labels-args)))
1837 cl-labels-args)))
1838 newenv))) 1855 newenv)))
1856 ;; FIXME: Eliminate those functions which aren't referenced.
1839 `(let ,(nreverse binds) 1857 `(let ,(nreverse binds)
1840 ,@(macroexp-unprogn 1858 ,@(macroexp-unprogn
1841 (macroexpand-all 1859 (macroexpand-all
@@ -1869,9 +1887,8 @@ in closures will only work if `lexical-binding' is in use.
1869 (let ((var (make-symbol (format "--cl-%s--" (car binding))))) 1887 (let ((var (make-symbol (format "--cl-%s--" (car binding)))))
1870 (push (list var `(cl-function (lambda . ,(cdr binding)))) binds) 1888 (push (list var `(cl-function (lambda . ,(cdr binding)))) binds)
1871 (push (cons (car binding) 1889 (push (cons (car binding)
1872 `(lambda (&rest cl-labels-args) 1890 (lambda (&rest cl-labels-args)
1873 (cl-list* 'funcall ',var 1891 (cl-list* 'funcall var cl-labels-args)))
1874 cl-labels-args)))
1875 newenv))) 1892 newenv)))
1876 (macroexpand-all `(letrec ,(nreverse binds) ,@body) 1893 (macroexpand-all `(letrec ,(nreverse binds) ,@body)
1877 ;; Don't override lexical-let's macro-expander. 1894 ;; Don't override lexical-let's macro-expander.
@@ -1898,7 +1915,8 @@ This is like `cl-flet', but for macros instead of functions.
1898 (res (cl--transform-lambda (cdar bindings) name))) 1915 (res (cl--transform-lambda (cdar bindings) name)))
1899 (eval (car res)) 1916 (eval (car res))
1900 (macroexpand-all (macroexp-progn body) 1917 (macroexpand-all (macroexp-progn body)
1901 (cons (cons name `(lambda ,@(cdr res))) 1918 (cons (cons name
1919 (eval `(cl-function (lambda ,@(cdr res))) t))
1902 macroexpand-all-environment)))))) 1920 macroexpand-all-environment))))))
1903 1921
1904(defconst cl--old-macroexpand 1922(defconst cl--old-macroexpand
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index dc2c873eb42..bfa922bade6 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."
264 264
265(defsubst eieio-object-p (obj) 265(defsubst eieio-object-p (obj)
266 "Return non-nil if OBJ is an EIEIO object." 266 "Return non-nil if OBJ is an EIEIO object."
267 (and (arrayp obj) 267 (and (vectorp obj)
268 (condition-case nil 268 (condition-case nil
269 (eq (aref (eieio--object-class-object obj) 0) 'defclass) 269 (eq (aref (eieio--object-class-object obj) 0) 'defclass)
270 (error nil)))) 270 (error nil))))
@@ -1303,11 +1303,35 @@ method invocation orders of the involved classes."
1303(define-error 'unbound-slot "Unbound slot") 1303(define-error 'unbound-slot "Unbound slot")
1304(define-error 'inconsistent-class-hierarchy "Inconsistent class hierarchy") 1304(define-error 'inconsistent-class-hierarchy "Inconsistent class hierarchy")
1305 1305
1306;;; Hooking into cl-generic.
1307
1308(require 'cl-generic)
1309
1310(add-function :before-until cl-generic-tagcode-function
1311 #'eieio--generic-tagcode)
1312(defun eieio--generic-tagcode (type name)
1313 ;; CLHS says:
1314 ;; A class must be defined before it can be used as a parameter
1315 ;; specializer in a defmethod form.
1316 ;; So we can ignore types that are not known to denote classes.
1317 (and (class-p type)
1318 ;; Prefer (aref ,name 0) over (eieio--class-tag ,name) so that
1319 ;; the tagcode is identical to the tagcode used for cl-struct.
1320 `(50 . (and (vectorp ,name) (aref ,name 0)))))
1321
1322(add-function :before-until cl-generic-tag-types-function
1323 #'eieio--generic-tag-types)
1324(defun eieio--generic-tag-types (tag)
1325 (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag))
1326 (mapcar #'eieio--class-symbol
1327 (eieio--class-precedence-list (symbol-value tag)))))
1328
1306;;; Backward compatibility functions 1329;;; Backward compatibility functions
1307;; To support .elc files compiled for older versions of EIEIO. 1330;; To support .elc files compiled for older versions of EIEIO.
1308 1331
1309(defun eieio-defclass (cname superclasses slots options) 1332(defun eieio-defclass (cname superclasses slots options)
1310 (eval `(defclass ,cname ,superclasses ,slots ,options))) 1333 (declare (obsolete eieio-defclass-internal "25.1"))
1334 (eval `(defclass ,cname ,superclasses ,slots ,@options)))
1311 1335
1312 1336
1313(provide 'eieio-core) 1337(provide 'eieio-core)
diff --git a/lisp/files.el b/lisp/files.el
index 1533c35e6ca..175f85b29d0 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -740,7 +740,10 @@ This function works recursively. Files are returned in \"depth first\"
740and alphabetical order. 740and alphabetical order.
741If INCLUDE-DIRECTORIES, also include directories that have matching names." 741If INCLUDE-DIRECTORIES, also include directories that have matching names."
742 (let ((result nil) 742 (let ((result nil)
743 (files nil)) 743 (files nil)
744 ;; When DIR is "/", remote file names like "/method:" could
745 ;; also be offered. We shall suppress them.
746 (tramp-mode (and tramp-mode (file-remote-p dir))))
744 (dolist (file (sort (file-name-all-completions "" dir) 747 (dolist (file (sort (file-name-all-completions "" dir)
745 'string<)) 748 'string<))
746 (unless (member file '("./" "../")) 749 (unless (member file '("./" "../"))
diff --git a/lisp/frame.el b/lisp/frame.el
index 8b927309f0a..1d5bbf2317e 100644
--- a/lisp/frame.el
+++ b/lisp/frame.el
@@ -275,23 +275,22 @@ there (in decreasing order of priority)."
275 ;; by the lines added in x-create-frame for the tool-bar and 275 ;; by the lines added in x-create-frame for the tool-bar and
276 ;; switch `tool-bar-mode' off. 276 ;; switch `tool-bar-mode' off.
277 (when (display-graphic-p) 277 (when (display-graphic-p)
278 (let ((tool-bar-lines 278 (let* ((init-lines
279 (or (assq 'tool-bar-lines initial-frame-alist) 279 (assq 'tool-bar-lines initial-frame-alist))
280 (assq 'tool-bar-lines window-system-frame-alist) 280 (other-lines
281 (assq 'tool-bar-lines default-frame-alist)))) 281 (or (assq 'tool-bar-lines window-system-frame-alist)
282 ;; Shrink frame by its initial tool bar height iff either zero 282 (assq 'tool-bar-lines default-frame-alist)))
283 ;; tool bar lines have been requested in one of the frame's 283 (lines (or init-lines other-lines))
284 ;; alists or tool bar mode has been turned off explicitly in 284 (height (tool-bar-height frame-initial-frame t)))
285 ;; the user's init file. 285 ;; Adjust frame top if either zero (nil) tool bar lines have
286 (when (and tool-bar-lines 286 ;; been requested in the most relevant of the frame's alists
287 (> frame-initial-frame-tool-bar-height 0) 287 ;; or tool bar mode has been explicitly turned off in the
288 (or (not tool-bar-mode) 288 ;; user's init file.
289 (null (cdr tool-bar-lines)) 289 (when (and (> height 0)
290 (eq 0 (cdr tool-bar-lines)))) 290 (or (and lines
291 (set-frame-height 291 (or (null (cdr lines))
292 frame-initial-frame (- (frame-text-height frame-initial-frame) 292 (eq 0 (cdr lines))))
293 frame-initial-frame-tool-bar-height) 293 (not tool-bar-mode)))
294 nil t)
295 (let* ((initial-top 294 (let* ((initial-top
296 (cdr (assq 'top frame-initial-geometry-arguments))) 295 (cdr (assq 'top frame-initial-geometry-arguments)))
297 (top (frame-parameter frame-initial-frame 'top))) 296 (top (frame-parameter frame-initial-frame 'top)))
@@ -299,15 +298,19 @@ there (in decreasing order of priority)."
299 (let ((adjusted-top 298 (let ((adjusted-top
300 (cond 299 (cond
301 ((and (consp top) (eq '+ (car top))) 300 ((and (consp top) (eq '+ (car top)))
302 (list '+ (+ (cadr top) 301 (list '+ (+ (cadr top) height)))
303 frame-initial-frame-tool-bar-height)))
304 ((and (consp top) (eq '- (car top))) 302 ((and (consp top) (eq '- (car top)))
305 (list '- (- (cadr top) 303 (list '- (- (cadr top) height)))
306 frame-initial-frame-tool-bar-height))) 304 (t (+ top height)))))
307 (t (+ top frame-initial-frame-tool-bar-height)))))
308 (modify-frame-parameters 305 (modify-frame-parameters
309 frame-initial-frame `((top . ,adjusted-top)))))) 306 frame-initial-frame `((top . ,adjusted-top))))))
310 (tool-bar-mode -1)))) 307 ;; Reset `tool-bar-mode' when zero tool bar lines have been
308 ;; requested for the window-system or default frame alists.
309 (when (and tool-bar-mode
310 (and other-lines
311 (or (null (cdr other-lines))
312 (eq 0 (cdr other-lines)))))
313 (tool-bar-mode -1)))))
311 314
312 ;; The initial frame we create above always has a minibuffer. 315 ;; The initial frame we create above always has a minibuffer.
313 ;; If the user wants to remove it, or make it a minibuffer-only 316 ;; 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."
682 (push p params))) 685 (push p params)))
683 ;; Now make the frame. 686 ;; Now make the frame.
684 (run-hooks 'before-make-frame-hook) 687 (run-hooks 'before-make-frame-hook)
688
689;; (setq frame-adjust-size-history '(t))
690
685 (setq frame 691 (setq frame
686 (funcall (gui-method frame-creation-function w) params)) 692 (funcall (gui-method frame-creation-function w) params))
687 (normal-erase-is-backspace-setup-frame frame) 693 (normal-erase-is-backspace-setup-frame frame)
@@ -690,6 +696,12 @@ the new frame according to its own rules."
690 (unless (assq param parameters) ;Overridden by explicit parameters. 696 (unless (assq param parameters) ;Overridden by explicit parameters.
691 (let ((val (frame-parameter oldframe param))) 697 (let ((val (frame-parameter oldframe param)))
692 (when val (set-frame-parameter frame param val))))) 698 (when val (set-frame-parameter frame param val)))))
699
700 (when (eq (car frame-adjust-size-history) t)
701 (setq frame-adjust-size-history
702 (cons t (cons (list "Frame made")
703 (cdr frame-adjust-size-history)))))
704
693 (run-hook-with-args 'after-make-frame-functions frame) 705 (run-hook-with-args 'after-make-frame-functions frame)
694 frame)) 706 frame))
695 707
diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el
index 67cb3273d23..cd1a4d05b55 100644
--- a/lisp/menu-bar.el
+++ b/lisp/menu-bar.el
@@ -381,7 +381,8 @@
381 381
382 (bindings--define-key menu [xref-pop] 382 (bindings--define-key menu [xref-pop]
383 '(menu-item "Back" xref-pop-marker-stack 383 '(menu-item "Back" xref-pop-marker-stack
384 :visible (not (xref-marker-stack-empty-p)) 384 :visible (and (featurep 'xref)
385 (not (xref-marker-stack-empty-p)))
385 :help "Back to the position of the last search")) 386 :help "Back to the position of the last search"))
386 387
387 (bindings--define-key menu [xref-apropos] 388 (bindings--define-key menu [xref-apropos]
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index 6a6da17d1ce..879eb53115e 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -1,4 +1,4 @@
1;;; eww.el --- Emacs Web Wowser 1;;; eww.el --- Emacs Web Wowser -*- lexical-binding:t -*-
2 2
3;; Copyright (C) 2013-2015 Free Software Foundation, Inc. 3;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
4 4
@@ -255,7 +255,9 @@ word(s) will be searched for via `eww-search-prefix'."
255 ((string-match-p "\\`ftp://" url) 255 ((string-match-p "\\`ftp://" url)
256 (user-error "FTP is not supported.")) 256 (user-error "FTP is not supported."))
257 (t 257 (t
258 (if (or (string-match "\\`https?:" url) 258 ;; Anything that starts with something that vaguely looks
259 ;; like a protocol designator is interpreted as a full URL.
260 (if (or (string-match "\\`[A-Za-z]+:" url)
259 ;; Also try to match "naked" URLs like 261 ;; Also try to match "naked" URLs like
260 ;; en.wikipedia.org/wiki/Free software 262 ;; en.wikipedia.org/wiki/Free software
261 (string-match "\\`[A-Za-z_]+\\.[A-Za-z._]+/" url) 263 (string-match "\\`[A-Za-z_]+\\.[A-Za-z._]+/" url)
@@ -550,7 +552,7 @@ See the `eww-search-prefix' variable for the search engine used."
550 "Return URI of the Web page the current EWW buffer is visiting." 552 "Return URI of the Web page the current EWW buffer is visiting."
551 (plist-get eww-data :url)) 553 (plist-get eww-data :url))
552 554
553(defun eww-links-at-point (&optional pt) 555(defun eww-links-at-point ()
554 "Return list of URIs, if any, linked at point." 556 "Return list of URIs, if any, linked at point."
555 (remq nil 557 (remq nil
556 (list (get-text-property (point) 'shr-url) 558 (list (get-text-property (point) 'shr-url)
@@ -629,17 +631,13 @@ the like."
629 631
630(defvar eww-mode-map 632(defvar eww-mode-map
631 (let ((map (make-sparse-keymap))) 633 (let ((map (make-sparse-keymap)))
632 (suppress-keymap map) 634 (set-keymap-parent map special-mode-map)
633 (define-key map "q" 'quit-window) 635 (define-key map "g" 'eww-reload) ;FIXME: revert-buffer-function instead!
634 (define-key map "g" 'eww-reload)
635 (define-key map "G" 'eww) 636 (define-key map "G" 'eww)
636 (define-key map [?\t] 'shr-next-link) 637 (define-key map [?\t] 'shr-next-link)
637 (define-key map [?\M-\t] 'shr-previous-link) 638 (define-key map [?\M-\t] 'shr-previous-link)
638 (define-key map [backtab] 'shr-previous-link) 639 (define-key map [backtab] 'shr-previous-link)
639 (define-key map [delete] 'scroll-down-command) 640 (define-key map [delete] 'scroll-down-command)
640 (define-key map [?\S-\ ] 'scroll-down-command)
641 (define-key map "\177" 'scroll-down-command)
642 (define-key map " " 'scroll-up-command)
643 (define-key map "l" 'eww-back-url) 641 (define-key map "l" 'eww-back-url)
644 (define-key map "r" 'eww-forward-url) 642 (define-key map "r" 'eww-forward-url)
645 (define-key map "n" 'eww-next-url) 643 (define-key map "n" 'eww-next-url)
@@ -697,21 +695,19 @@ the like."
697 map) 695 map)
698 "Tool bar for `eww-mode'.") 696 "Tool bar for `eww-mode'.")
699 697
700(define-derived-mode eww-mode nil "eww" 698(define-derived-mode eww-mode special-mode "eww"
701 "Mode for browsing the web. 699 "Mode for browsing the web."
702
703\\{eww-mode-map}"
704 (setq-local eww-data (list :title "")) 700 (setq-local eww-data (list :title ""))
705 (setq-local browse-url-browser-function 'eww-browse-url) 701 (setq-local browse-url-browser-function #'eww-browse-url)
706 (setq-local after-change-functions 'eww-process-text-input) 702 (add-hook 'after-change-functions #'eww-process-text-input nil t)
707 (setq-local eww-history nil) 703 (setq-local eww-history nil)
708 (setq-local eww-history-position 0) 704 (setq-local eww-history-position 0)
709 (when (boundp 'tool-bar-map) 705 (when (boundp 'tool-bar-map)
710 (setq-local tool-bar-map eww-tool-bar-map)) 706 (setq-local tool-bar-map eww-tool-bar-map))
711 ;; desktop support 707 ;; desktop support
712 (setq-local desktop-save-buffer 'eww-desktop-misc-data) 708 (setq-local desktop-save-buffer #'eww-desktop-misc-data)
713 ;; multi-page isearch support 709 ;; multi-page isearch support
714 (setq-local multi-isearch-next-buffer-function 'eww-isearch-next-buffer) 710 (setq-local multi-isearch-next-buffer-function #'eww-isearch-next-buffer)
715 (setq truncate-lines t) 711 (setq truncate-lines t)
716 (buffer-disable-undo) 712 (buffer-disable-undo)
717 (setq buffer-read-only t)) 713 (setq buffer-read-only t))
@@ -1054,7 +1050,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
1054 (insert value) 1050 (insert value)
1055 (shr-ensure-newline) 1051 (shr-ensure-newline)
1056 (when (< (count-lines start (point)) lines) 1052 (when (< (count-lines start (point)) lines)
1057 (dotimes (i (- lines (count-lines start (point)))) 1053 (dotimes (_ (- lines (count-lines start (point))))
1058 (insert "\n"))) 1054 (insert "\n")))
1059 (setq end (point-marker)) 1055 (setq end (point-marker))
1060 (goto-char start) 1056 (goto-char start)
@@ -1846,7 +1842,7 @@ Also used when saving `eww-history'.")
1846 ;; . 1842 ;; .
1847 r)) 1843 r))
1848 1844
1849(defun eww-desktop-misc-data (directory) 1845(defun eww-desktop-misc-data (_directory)
1850 "Return a property list with data used to restore eww buffers. 1846 "Return a property list with data used to restore eww buffers.
1851This list will contain, as :history, the list, whose first element is 1847This list will contain, as :history, the list, whose first element is
1852the value of `eww-data', and the tail is `eww-history'. 1848the 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
1894 1890
1895;;; Isearch support 1891;;; Isearch support
1896 1892
1897(defun eww-isearch-next-buffer (&optional buffer wrap) 1893(defun eww-isearch-next-buffer (&optional _buffer wrap)
1898 "Go to the next page to search using `rel' attribute for navigation." 1894 "Go to the next page to search using `rel' attribute for navigation."
1899 (if wrap 1895 (if wrap
1900 (condition-case nil 1896 (condition-case nil
diff --git a/lisp/progmodes/cc-bytecomp.el b/lisp/progmodes/cc-bytecomp.el
index bf7803c85ca..b63eeb4c7a6 100644
--- a/lisp/progmodes/cc-bytecomp.el
+++ b/lisp/progmodes/cc-bytecomp.el
@@ -89,13 +89,60 @@
89 ;;`(message ,@args) 89 ;;`(message ,@args)
90 ) 90 )
91 91
92(defun cc-bytecomp-compiling-or-loading ()
93 ;; Determine whether byte-compilation or loading is currently active,
94 ;; returning 'compiling, 'loading or nil.
95 ;; If both are active, the "innermost" activity counts. Note that
96 ;; compilation can trigger loading (various `require' type forms)
97 ;; and loading can trigger compilation (the package manager does
98 ;; this). We walk the lisp stack if necessary.
99 (cond
100 ((and load-in-progress
101 (boundp 'byte-compile-dest-file)
102 (stringp byte-compile-dest-file))
103 (let ((n 0) elt)
104 (while (and
105 (setq elt (backtrace-frame n))
106 (not (and (car elt)
107 (memq (cadr elt)
108 '(load require
109 byte-compile-file byte-recompile-directory
110 batch-byte-compile)))))
111 (setq n (1+ n)))
112 (cond
113 ((memq (cadr elt) '(load require))
114 'loading)
115 ((memq (cadr elt) '(byte-compile-file
116 byte-recompile-directory
117 batch-byte-compile))
118 'compiling)
119 (t ; Can't happen.
120 (message "cc-bytecomp-compiling-or-loading: System flags spuriously set")
121 nil))))
122 (load-in-progress
123 ;; Being loaded.
124 'loading)
125 ((and (boundp 'byte-compile-dest-file)
126 (stringp byte-compile-dest-file))
127 ;; Being compiled.
128 'compiling)
129 (t
130 ;; Being evaluated interactively.
131 nil)))
132
133(defsubst cc-bytecomp-is-compiling ()
134 "Return non-nil if eval'ed during compilation."
135 (eq (cc-bytecomp-compiling-or-loading) 'compiling))
136
137(defsubst cc-bytecomp-is-loading ()
138 "Return non-nil if eval'ed during loading.
139Nil will be returned if we're in a compilation triggered by the loading."
140 (eq (cc-bytecomp-compiling-or-loading) 'loading))
141
92(defun cc-bytecomp-setup-environment () 142(defun cc-bytecomp-setup-environment ()
93 ;; Eval'ed during compilation to setup variables, functions etc 143 ;; Eval'ed during compilation to setup variables, functions etc
94 ;; declared with `cc-bytecomp-defvar' et al. 144 ;; declared with `cc-bytecomp-defvar' et al.
95 (if (not load-in-progress) 145 (if (not (cc-bytecomp-is-loading))
96 ;; Look at `load-in-progress' to tell whether we're called
97 ;; directly in the file being compiled or just from some file
98 ;; being loaded during compilation.
99 (let (p) 146 (let (p)
100 (if cc-bytecomp-environment-set 147 (if cc-bytecomp-environment-set
101 (error "Byte compilation environment already set - \ 148 (error "Byte compilation environment already set - \
@@ -143,7 +190,7 @@ perhaps a `cc-bytecomp-restore-environment' is forgotten somewhere"))
143(defun cc-bytecomp-restore-environment () 190(defun cc-bytecomp-restore-environment ()
144 ;; Eval'ed during compilation to restore variables, functions etc 191 ;; Eval'ed during compilation to restore variables, functions etc
145 ;; declared with `cc-bytecomp-defvar' et al. 192 ;; declared with `cc-bytecomp-defvar' et al.
146 (if (not load-in-progress) 193 (if (not (cc-bytecomp-is-loading))
147 (let (p) 194 (let (p)
148 (setq p cc-bytecomp-unbound-variables) 195 (setq p cc-bytecomp-unbound-variables)
149 (while p 196 (while p
@@ -287,8 +334,7 @@ use within `eval-when-compile'."
287 `(eval-when-compile 334 `(eval-when-compile
288 (if (and (fboundp 'cc-bytecomp-is-compiling) 335 (if (and (fboundp 'cc-bytecomp-is-compiling)
289 (cc-bytecomp-is-compiling)) 336 (cc-bytecomp-is-compiling))
290 (if (or (not load-in-progress) 337 (if (not (featurep ,cc-part))
291 (not (featurep ,cc-part)))
292 (cc-bytecomp-load (symbol-name ,cc-part))) 338 (cc-bytecomp-load (symbol-name ,cc-part)))
293 (require ,cc-part)))) 339 (require ,cc-part))))
294 340
@@ -301,12 +347,6 @@ afterwards. Don't use within `eval-when-compile'."
301 (require ,feature) 347 (require ,feature)
302 (eval-when-compile (cc-bytecomp-setup-environment)))) 348 (eval-when-compile (cc-bytecomp-setup-environment))))
303 349
304(defun cc-bytecomp-is-compiling ()
305 "Return non-nil if eval'ed during compilation. Don't use outside
306`eval-when-compile'."
307 (and (boundp 'byte-compile-dest-file)
308 (stringp byte-compile-dest-file)))
309
310(defmacro cc-bytecomp-defvar (var) 350(defmacro cc-bytecomp-defvar (var)
311 "Binds the symbol as a variable during compilation of the file, 351 "Binds the symbol as a variable during compilation of the file,
312to silence the byte compiler. Don't use within `eval-when-compile'." 352to 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'."
320 "cc-bytecomp-defvar: Saving %s (as unbound)" ',var) 360 "cc-bytecomp-defvar: Saving %s (as unbound)" ',var)
321 (setq cc-bytecomp-unbound-variables 361 (setq cc-bytecomp-unbound-variables
322 (cons ',var cc-bytecomp-unbound-variables)))) 362 (cons ',var cc-bytecomp-unbound-variables))))
323 (if (and (cc-bytecomp-is-compiling) 363 (if (cc-bytecomp-is-compiling)
324 (not load-in-progress))
325 (progn 364 (progn
326 (defvar ,var) 365 (defvar ,var)
327 (set ',var (intern (concat "cc-bytecomp-ignore-var:" 366 (set ',var (intern (concat "cc-bytecomp-ignore-var:"
@@ -349,8 +388,7 @@ at compile time, e.g. for macros and inline functions."
349 (setq cc-bytecomp-original-functions 388 (setq cc-bytecomp-original-functions
350 (cons (list ',fun nil 'unbound) 389 (cons (list ',fun nil 'unbound)
351 cc-bytecomp-original-functions)))) 390 cc-bytecomp-original-functions))))
352 (if (and (cc-bytecomp-is-compiling) 391 (if (cc-bytecomp-is-compiling)
353 (not load-in-progress))
354 (progn 392 (progn
355 (fset ',fun (intern (concat "cc-bytecomp-ignore-fun:" 393 (fset ',fun (intern (concat "cc-bytecomp-ignore-fun:"
356 (symbol-name ',fun)))) 394 (symbol-name ',fun))))
diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el
index 2ea566a7a25..d0beab1d485 100644
--- a/lisp/progmodes/cc-defs.el
+++ b/lisp/progmodes/cc-defs.el
@@ -1983,19 +1983,22 @@ system."
1983 1983
1984(defvar c-lang-const-expansion nil) 1984(defvar c-lang-const-expansion nil)
1985 1985
1986;; Ugly hack to pull in the definition of `cc-bytecomp-compiling-or-loading`
1987;; from cc-bytecomp to make it available at loadtime. This is the same
1988;; mechanism used in cc-mode.el for `c-populate-syntax-table'.
1989(defalias 'cc-bytecomp-compiling-or-loading
1990 (cc-eval-when-compile
1991 (let ((f (symbol-function 'cc-bytecomp-compiling-or-loading)))
1992 (if (byte-code-function-p f) f (byte-compile f)))))
1993
1986(defsubst c-get-current-file () 1994(defsubst c-get-current-file ()
1987 ;; Return the base name of the current file. 1995 ;; Return the base name of the current file.
1988 (let ((file (cond 1996 (let* ((c-or-l (cc-bytecomp-compiling-or-loading))
1989 (load-in-progress 1997 (file
1990 ;; Being loaded. 1998 (cond
1991 load-file-name) 1999 ((eq c-or-l 'loading) load-file-name)
1992 ((and (boundp 'byte-compile-dest-file) 2000 ((eq c-or-l 'compiling) byte-compile-dest-file)
1993 (stringp byte-compile-dest-file)) 2001 ((null c-or-l) (buffer-file-name)))))
1994 ;; Being compiled.
1995 byte-compile-dest-file)
1996 (t
1997 ;; Being evaluated interactively.
1998 (buffer-file-name)))))
1999 (and file 2002 (and file
2000 (file-name-sans-extension 2003 (file-name-sans-extension
2001 (file-name-nondirectory file))))) 2004 (file-name-nondirectory file)))))
@@ -2062,6 +2065,9 @@ constant. A file is identified by its base name."
2062 ;; language constant source definitions.) 2065 ;; language constant source definitions.)
2063 (c-lang-const-expansion 'call) 2066 (c-lang-const-expansion 'call)
2064 (c-langs-are-parametric t) 2067 (c-langs-are-parametric t)
2068 (file (intern
2069 (or (c-get-current-file)
2070 (error "`c-lang-defconst' can only be used in a file"))))
2065 bindings 2071 bindings
2066 pre-files) 2072 pre-files)
2067 2073
@@ -2121,9 +2127,14 @@ constant. A file is identified by its base name."
2121 ;; definitions for this symbol, to make sure the order in the 2127 ;; definitions for this symbol, to make sure the order in the
2122 ;; `source' property is correct even when files are loaded out of 2128 ;; `source' property is correct even when files are loaded out of
2123 ;; order. 2129 ;; order.
2124 (setq pre-files (nreverse 2130 (setq pre-files (mapcar 'car (get sym 'source)))
2125 ;; Reverse to get the right load order. 2131 (if (memq file pre-files)
2126 (mapcar 'car (get sym 'source)))) 2132 ;; This can happen when the source file (e.g. cc-langs.el) is first
2133 ;; loaded as source, setting a 'source property entry, and then itself
2134 ;; being compiled.
2135 (setq pre-files (cdr (memq file pre-files))))
2136 ;; Reverse to get the right load order.
2137 (setq pre-files (nreverse pre-files))
2127 2138
2128 `(eval-and-compile 2139 `(eval-and-compile
2129 (c-define-lang-constant ',name ,bindings 2140 (c-define-lang-constant ',name ,bindings
@@ -2233,9 +2244,7 @@ quoted."
2233 (if (or (eq c-lang-const-expansion 'call) 2244 (if (or (eq c-lang-const-expansion 'call)
2234 (and (not c-lang-const-expansion) 2245 (and (not c-lang-const-expansion)
2235 (not mode)) 2246 (not mode))
2236 load-in-progress 2247 (not (cc-bytecomp-is-compiling)))
2237 (not (boundp 'byte-compile-dest-file))
2238 (not (stringp byte-compile-dest-file)))
2239 ;; Either a straight call is requested in the context, or 2248 ;; Either a straight call is requested in the context, or
2240 ;; we're in an "uncontrolled" context and got no language, 2249 ;; we're in an "uncontrolled" context and got no language,
2241 ;; or we're not being byte compiled so the compile time 2250 ;; 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 17d717e740f..4d16a9b9d33 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
3260from the language constants. Use the `c-init-language-vars' macro to 3260from the language constants. Use the `c-init-language-vars' macro to
3261accomplish that conveniently." 3261accomplish that conveniently."
3262 3262
3263 (if (and (not load-in-progress) 3263 (if (cc-bytecomp-is-compiling)
3264 (boundp 'byte-compile-dest-file)
3265 (stringp byte-compile-dest-file))
3266
3267 ;; No need to byte compile this lambda since the byte compiler is 3264 ;; No need to byte compile this lambda since the byte compiler is
3268 ;; smart enough to detect the `funcall' construct in the 3265 ;; smart enough to detect the `funcall' construct in the
3269 ;; `c-init-language-vars' macro below and compile it all straight 3266 ;; `c-init-language-vars' macro below and compile it all straight
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index b822619f783..7f77d218a48 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -301,6 +301,7 @@ backward."
301 (let ((marker (ring-remove ring))) 301 (let ((marker (ring-remove ring)))
302 (set-marker marker nil nil))))) 302 (set-marker marker nil nil)))))
303 303
304;;;###autoload
304(defun xref-marker-stack-empty-p () 305(defun xref-marker-stack-empty-p ()
305 "Return t if the marker stack is empty; nil otherwise." 306 "Return t if the marker stack is empty; nil otherwise."
306 (ring-empty-p xref--marker-ring)) 307 (ring-empty-p xref--marker-ring))
diff --git a/src/.gdbinit b/src/.gdbinit
index 1a2a973e694..91beaef8d73 100644
--- a/src/.gdbinit
+++ b/src/.gdbinit
@@ -70,14 +70,18 @@ define xgettype
70 set $type = (enum Lisp_Type) (USE_LSB_TAG ? $bugfix & (1 << GCTYPEBITS) - 1 : (EMACS_UINT) $bugfix >> VALBITS) 70 set $type = (enum Lisp_Type) (USE_LSB_TAG ? $bugfix & (1 << GCTYPEBITS) - 1 : (EMACS_UINT) $bugfix >> VALBITS)
71end 71end
72 72
73define xgetsym
74 xgetptr $arg0
75 if (!USE_LSB_TAG)
76 set $ptr = ($ptr << GCTYPEBITS)
77 end
78 set $ptr = ((struct Lisp_Symbol *) ((char *)lispsym + $ptr))
79end
80
73# Access the name of a symbol 81# Access the name of a symbol
74define xsymname 82define xsymname
75 if (CHECK_LISP_OBJECT_TYPE) 83 xgetsym $arg0
76 set $bugfix = $arg0.i 84 set $symname = $ptr->name
77 else
78 set $bugfix = $arg0
79 end
80 set $symname = ((struct Lisp_Symbol *) ((char *)lispsym + $bugfix))->name
81end 85end
82 86
83# Set up something to print out s-expressions. 87# Set up something to print out s-expressions.
@@ -760,7 +764,7 @@ end
760 764
761define xsymbol 765define xsymbol
762 set $sym = $ 766 set $sym = $
763 xgetptr $sym 767 xgetsym $sym
764 print (struct Lisp_Symbol *) $ptr 768 print (struct Lisp_Symbol *) $ptr
765 xprintsym $sym 769 xprintsym $sym
766 echo \n 770 echo \n
@@ -1082,8 +1086,7 @@ define xprintstr
1082end 1086end
1083 1087
1084define xprintsym 1088define xprintsym
1085 xgetptr $arg0 1089 xsymname $arg0
1086 xsymname $ptr
1087 xgetptr $symname 1090 xgetptr $symname
1088 set $sym_name = (struct Lisp_String *) $ptr 1091 set $sym_name = (struct Lisp_String *) $ptr
1089 xprintstr $sym_name 1092 xprintstr $sym_name
diff --git a/src/ChangeLog b/src/ChangeLog
index 8f441be3307..b2588f1451f 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,236 @@
12015-01-14 Eli Zaretskii <eliz@gnu.org>
2
3 * w32fns.c (w32_wnd_proc): Ignore MENUITEMINFO's dwItemData data
4 when FLAGS indicate the item is not highlighted. (Bug#19596)
5
62015-01-14 Martin Rudalics <rudalics@gmx.at>
7
8 * xmenu.c (update_frame_menubar): Remove garbaged code.
9
102015-01-14 Paul Eggert <eggert@cs.ucla.edu>
11
12 remove_slash_colon need not be inline
13 * process.c, process.h (remove_slash_colon): No longer inline.
14 This saves text bytes without hurting runtime performance.
15
162015-01-14 Dmitry Antipov <dmantipov@yandex.ru>
17
18 Avoid extra multibyteness check in ENCODE_FILE users.
19 * callproc.c (encode_current_directory, Fcall_process, call_process):
20 * dired.c (directory_files_internal, file_name_completion):
21 Do not check for STRING_MULTIBYTE because encode_file_name
22 is a no-op for unibyte strings.
23
24 * process.h (remove_slash_colon): New function.
25 * callproc.c (encode_current_directory, call_process):
26 * process.c (Fstart_process): Use it.
27
28 Consistently handle time zone specification.
29 * editfns.c (decode_time_zone): New function, refactored out from ...
30 (Fencode_time): ... adjusted user.
31 (Fset_time_zone_rule): Use decode_time_zone.
32
33 * editfns.c (make_buffer_string_both): If requested range intersects
34 the gap, don't move the latter but copy in two regions, thus avoiding
35 unnecessary relocation of buffer data.
36
372015-01-14 Paul Eggert <eggert@cs.ucla.edu>
38
39 Use bool for boolean in xmenu.c, xml.c
40 * xmenu.c (x_menu_set_in_use, popup_get_selection)
41 (Fx_menu_bar_open_internal, popup_widget_loop)
42 (x_activate_menubar, xg_crazy_callback_abort)
43 (update_frame_menubar, set_frame_menubar)
44 (initialize_frame_menubar, free_frame_menubar)
45 (create_and_show_popup_menu, x_menu_show)
46 (create_and_show_dialog, x_dialog_show):
47 * xml.c (libxml2_loaded_p, init_libxml2_functions, parse_region)
48 (Flibxml_parse_html_region, Flibxml_parse_xml_region):
49 * xrdb.c (main) [TESTRM]:
50 * xsettings.c (init_gsettings):
51 * xterm.c (XFillRectangle, xg_scroll_callback)
52 (xg_end_scroll_callback):
53 * xterm.h (x_menu_set_in_use) [USE_GTK || USE_MOTIF]:
54 Use bool for boolean.
55 * xmenu.c (TRUE): Remove; no longer used.
56 (show_help_event): Remove long-unused code.
57 (set_frame_menubar): Remove "#if 1" and corresponding "#endif" lines.
58
592015-01-13 Paul Eggert <eggert@cs.ucla.edu>
60
61 Don't say Fnext_read_file_uses_dialog_p is const
62 It's const only if a windowing system is not used; don't say it's
63 const otherwise. See:
64 http://lists.gnu.org/archive/html/emacs-devel/2015-01/msg00310.html
65 * fileio.c (next_read_file_uses_dialog_p): Remove.
66 Move guts back to ...
67 (Fnext_read_file_uses_dialog_p): ... here.
68 Don't declare as const, as make-docfile.c now has a special case
69 for this function. This is an ugly hack, but it's better than
70 lying to the compiler.
71
72 Remove now-unnecessary forward XTYPE decl
73 * lisp.h (XTYPE): Remove forward declaration. The recent merge
74 from emacs-24 fixed the problem in a better way, by moving XPNTR's
75 definition to after XTYPE's.
76
772015-01-13 Eli Zaretskii <eliz@gnu.org>
78
79 Fix problems with 32-bit wide-int build exposed by MinGW.
80 * lisp.h (XPNTR): Move definition to after XTYPE, to avoid
81 compilation error in an unoptimized build when !USE_LSB_TAG.
82
83 * w32heap.c (DUMPED_HEAP_SIZE): For 32-bit wide-int build, use the
84 same larger value as for the 64-bit build.
85
86 * w32term.h (SCROLL_BAR_PACK): Cast the result to UINT_PTR to
87 avoid compiler warnings.
88
89 * w32proc.c (Fw32_get_codepage_charset, Fw32_set_keyboard_layout):
90 Avoid compiler warnings about cast from integer to pointer of
91 different size.
92
93 * w32menu.c (menubar_selection_callback, w32_menu_show): Cast to
94 UINT_PTR instead of EMACS_INT, to avoid compiler warnings about
95 casting from integer to pointer of different size.
96 (add_menu_item): Pass the help-echo string as a pointer to
97 Lisp_String, not as a Lisp_Object.
98 (w32_menu_display_help): Use make_lisp_ptr to reconstruct a Lisp
99 string object from its C pointer.
100
101 * w32fns.c (w32_msg_pump) <WM_EMACS_UNREGISTER_HOT_KEY>: Use
102 make_lisp_ptr instead of XIL, to reconstruct a Lisp_Cons from its
103 C pointer.
104 <WM_EMACS_TOGGLE_LOCK_KEY>: msg.lparam is now a C integer.
105 (Fx_create_frame): Type-cast the result of XFASTINT to avoild
106 compiler warnings about size differences.
107 (Fw32_unregister_hot_key): Pass the tail of w32_grabbed_keys as a
108 pointer to a Lisp_Cons struct, not as a disguised EMACS_INT.
109 (Fw32_toggle_lock_key): Pass the new state of the key as a C
110 integer; use -1 for nil. Doc fix.
111
112 * .gdbinit (xgetsym): New subroutine.
113 (xsymname, xsymbol): Use it.
114 (xprintsym): No need to call xgetptr.
115
1162015-01-13 Martin Rudalics <rudalics@gmx.at>
117
118 * frame.c (adjust_frame_size): Make sure new numbers of
119 lines/columns get installed after font size change (Bug#19575).
120
1212015-01-13 Dmitry Antipov <dmantipov@yandex.ru>
122
123 Add DEFUN attributes.
124 * callint.c (Finteractive):
125 * character.c (Fcharacterp, Fmax_char):
126 * data.c (Feq, Fnull, Fconsp, Fatom, Flistp, Fnlistp, Fsymbolp)
127 (Fstringp, Fchar_or_string_p, Fintegerp, Fnatnump, Fnumberp)
128 (Ffloatp, Fbyteorder):
129 * decompress.c (Fzlib_available_p):
130 * fns.c (Fidentity):
131 * frame.c (Fframe_windows_min_size):
132 * gnutls.c (Fgnutls_error_p, Fgnutls_available_p):
133 * window.c (Fwindow__sanitize_window_sizes):
134 * xdisp.c (Ftool_bar_height):
135 * xfaces.c (Fface_attribute_relative_p): Add const attribute.
136 * emacs.c (Fkill_emacs):
137 * eval.c (Fthrow):
138 * keyboard.c (Ftop_level, Fexit_recursive_edit)
139 (Fabor_recursive_edit): Add noreturn attribute.
140
141 * search.c (fast_string_match_internal): New function,
142 consolidated from...
143 (fast_string_match, fast_string_match_ignore_case): ...functions
144 which are...
145 * lisp.h (fast_string_match, fast_string_match_ignore_case):
146 inlined from here now.
147 (fast_string_match_internal): Add prototype.
148 * dired.c (file_name_completion): Use fast_string_match_internal.
149
150 * fileio.c (next_read_file_uses_dialog_p): New workaround ...
151 (Fnext_read_file_uses_dialog_p): ... called from here to avoid
152 ATTRIBUTE_CONST dependency from #ifdefs. For details, see
153 http://lists.gnu.org/archive/html/emacs-devel/2015-01/msg00289.html.
154
1552015-01-12 Paul Eggert <eggert@cs.ucla.edu>
156
157 Port to 32-bit MingGW --with-wide-int
158 Problem reported by Eli Zaretskii in:
159 http://lists.gnu.org/archive/html/emacs-devel/2015-01/msg00265.html
160 * lisp.h (struct Lisp_Sub_Char_Table): Check that offset matches
161 what we think it is, rather than checking only its alignment (and
162 doing so incorrectly on MinGW).
163
1642015-01-12 Dmitry Antipov <dmantipov@yandex.ru>
165
166 * fileio.c (Ffile_name_as_directory, Fdirectory_file_name):
167 Remove dead NILP check.
168 * image.c (Flookup_image): Use regular format for docstring.
169 * keyboard.c (apply_modifiers_uncached): Use stpcpy.
170
1712015-01-12 Martin Rudalics <rudalics@gmx.at>
172
173 * dispnew.c (change_frame_size_1): Pass Qchange_frame_size to
174 adjust_frame_size.
175 * frame.c (frame_default_tool_bar_height): New variable.
176 (adjust_frame_size): Possibly add requested adjustment to
177 Vframe_adjust_size_history.
178 (make_frame): Initialize tool_bar_redisplayed_once slot.
179 (Fset_frame_height, Fset_frame_width, Fset_frame_size): Clarify
180 doc-string. Call adjust_frame_size unconditionally (the frame's
181 text size may remain unaltered but the pixel size may change).
182 (x_figure_window_size): If frame_default_tool_bar_height was
183 set, use it instead of calculating the tool bar height from
184 DEFAULT_TOOL_BAR_IMAGE_HEIGHT. Don't set
185 Vframe_initial_frame_tool_bar_height.
186 (Qchange_frame_size, Qxg_frame_set_char_size)
187 (Qset_window_configuration, Qx_create_frame_1)
188 (Qx_create_frame_2): New symbols.
189 (Vframe_initial_frame_tool_bar_height): Remove.
190 (Vframe_adjust_size_history): New history variable for debugging
191 frame size adjustments.
192 * frame.h (struct frame): New boolean slot
193 tool_bar_redisplayed_once.
194 (frame_default_tool_bar_height): Extern.
195 * gtkutil.c (xg_frame_set_char_size): Pass Qxg_frame_set_char_size
196 to adjust_frame_size.
197 * nsfns.m (Fx_create_frame): Pass Pass Qx_create_frame_1 and
198 Qx_create_frame_2 to adjust_frame_size.
199 * w32fns.c (x_change_tool_bar_height): Call adjust_frame_size with
200 inhibit 1 when we have not redisplayed the tool bar yet.
201 (Fx_create_frame): Pass Pass Qx_create_frame_1 and
202 Qx_create_frame_2 to adjust_frame_size.
203 * w32menu.c (set_frame_menubar): Simplify adjust_frame_size
204 call.
205 * window.c (Fset_window_configuration): Pass
206 Qset_window_configuration to adjust_frame_size.
207 * xdisp.c (redisplay_tool_bar): Assign new height to
208 frame_default_tool_bar_height.
209 (redisplay_internal): If we haven't redisplayed this frame's
210 tool bar, call redisplay_tool_bar early so we can adjust the
211 frame size accordingly.
212 * xfns.c (x_change_tool_bar_height): Call adjust_frame_size with
213 inhibit 1 when we have not redisplayed the tool bar yet.
214 (Fx_create_frame): Pass Pass Qx_create_frame_1 and
215 Qx_create_frame_2 to adjust_frame_size.
216
2172015-01-12 Paul Eggert <eggert@cs.ucla.edu>
218
219 Have 'make' output better GEN names
220 * Makefile.in (gl-stamp, globals.h): Simplify by putting the new
221 contents of globals.h into gl-stamp. This lets us use AM_V_GEN
222 more naturally so that 'make' can output more-accurate names.
223
2242015-01-11 Stefan Monnier <monnier@iro.umontreal.ca>
225
226 * buffer.c (init_buffer_once): Initialize buffer_local_flags before
227 calling reset_buffer_local_variables, and make sure we initialize
228 it completely.
229
2302015-01-11 Dmitry Antipov <dmantipov@yandex.ru>
231
232 * coding.c (Fcoding_system_plist): Use common style for docstring.
233
12015-01-11 Paul Eggert <eggert@cs.ucla.edu> 2342015-01-11 Paul Eggert <eggert@cs.ucla.edu>
2 235
3 Port to MSB hosts without optimization 236 Port to MSB hosts without optimization
diff --git a/src/Makefile.in b/src/Makefile.in
index 9bd86d54793..079e0e41c9f 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -502,14 +502,13 @@ buildobj.h: Makefile
502 done >$@.tmp 502 done >$@.tmp
503 $(AM_V_at)mv $@.tmp $@ 503 $(AM_V_at)mv $@.tmp $@
504 504
505globals.h: gl-stamp; @true
506
507GLOBAL_SOURCES = $(base_obj:.o=.c) $(NS_OBJC_OBJ:.o=.m) 505GLOBAL_SOURCES = $(base_obj:.o=.c) $(NS_OBJC_OBJ:.o=.m)
508 506
509gl-stamp: $(libsrc)/make-docfile$(EXEEXT) $(GLOBAL_SOURCES) 507gl-stamp: $(libsrc)/make-docfile$(EXEEXT) $(GLOBAL_SOURCES)
510 $(AM_V_GEN)$(libsrc)/make-docfile -d $(srcdir) -g $(obj) > gl.tmp 508 $(AM_V_GEN)$(libsrc)/make-docfile -d $(srcdir) -g $(obj) >$@
511 $(AM_V_at)$(top_srcdir)/build-aux/move-if-change gl.tmp globals.h 509
512 $(AM_V_at)echo timestamp > $@ 510globals.h: gl-stamp
511 $(AM_V_GEN)cmp $< $@ >/dev/null || cp $< $@
513 512
514$(ALLOBJS): globals.h 513$(ALLOBJS): globals.h
515 514
diff --git a/src/buffer.c b/src/buffer.c
index 2ea69f38f91..6bff57fe12e 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -5035,6 +5035,93 @@ init_buffer_once (void)
5035 5035
5036 memset (buffer_permanent_local_flags, 0, sizeof buffer_permanent_local_flags); 5036 memset (buffer_permanent_local_flags, 0, sizeof buffer_permanent_local_flags);
5037 5037
5038 /* 0 means not a lisp var, -1 means always local, else mask. */
5039 memset (&buffer_local_flags, 0, sizeof buffer_local_flags);
5040 bset_filename (&buffer_local_flags, make_number (-1));
5041 bset_directory (&buffer_local_flags, make_number (-1));
5042 bset_backed_up (&buffer_local_flags, make_number (-1));
5043 bset_save_length (&buffer_local_flags, make_number (-1));
5044 bset_auto_save_file_name (&buffer_local_flags, make_number (-1));
5045 bset_read_only (&buffer_local_flags, make_number (-1));
5046 bset_major_mode (&buffer_local_flags, make_number (-1));
5047 bset_mode_name (&buffer_local_flags, make_number (-1));
5048 bset_undo_list (&buffer_local_flags, make_number (-1));
5049 bset_mark_active (&buffer_local_flags, make_number (-1));
5050 bset_point_before_scroll (&buffer_local_flags, make_number (-1));
5051 bset_file_truename (&buffer_local_flags, make_number (-1));
5052 bset_invisibility_spec (&buffer_local_flags, make_number (-1));
5053 bset_file_format (&buffer_local_flags, make_number (-1));
5054 bset_auto_save_file_format (&buffer_local_flags, make_number (-1));
5055 bset_display_count (&buffer_local_flags, make_number (-1));
5056 bset_display_time (&buffer_local_flags, make_number (-1));
5057 bset_enable_multibyte_characters (&buffer_local_flags, make_number (-1));
5058
5059 /* These used to be stuck at 0 by default, but now that the all-zero value
5060 means Qnil, we have to initialize them explicitly. */
5061 bset_name (&buffer_local_flags, make_number (0));
5062 bset_mark (&buffer_local_flags, make_number (0));
5063 bset_local_var_alist (&buffer_local_flags, make_number (0));
5064 bset_keymap (&buffer_local_flags, make_number (0));
5065 bset_downcase_table (&buffer_local_flags, make_number (0));
5066 bset_upcase_table (&buffer_local_flags, make_number (0));
5067 bset_case_canon_table (&buffer_local_flags, make_number (0));
5068 bset_case_eqv_table (&buffer_local_flags, make_number (0));
5069 bset_minor_modes (&buffer_local_flags, make_number (0));
5070 bset_width_table (&buffer_local_flags, make_number (0));
5071 bset_pt_marker (&buffer_local_flags, make_number (0));
5072 bset_begv_marker (&buffer_local_flags, make_number (0));
5073 bset_zv_marker (&buffer_local_flags, make_number (0));
5074 bset_last_selected_window (&buffer_local_flags, make_number (0));
5075
5076 idx = 1;
5077 XSETFASTINT (BVAR (&buffer_local_flags, mode_line_format), idx); ++idx;
5078 XSETFASTINT (BVAR (&buffer_local_flags, abbrev_mode), idx); ++idx;
5079 XSETFASTINT (BVAR (&buffer_local_flags, overwrite_mode), idx); ++idx;
5080 XSETFASTINT (BVAR (&buffer_local_flags, case_fold_search), idx); ++idx;
5081 XSETFASTINT (BVAR (&buffer_local_flags, auto_fill_function), idx); ++idx;
5082 XSETFASTINT (BVAR (&buffer_local_flags, selective_display), idx); ++idx;
5083 XSETFASTINT (BVAR (&buffer_local_flags, selective_display_ellipses), idx); ++idx;
5084 XSETFASTINT (BVAR (&buffer_local_flags, tab_width), idx); ++idx;
5085 XSETFASTINT (BVAR (&buffer_local_flags, truncate_lines), idx); ++idx;
5086 XSETFASTINT (BVAR (&buffer_local_flags, word_wrap), idx); ++idx;
5087 XSETFASTINT (BVAR (&buffer_local_flags, ctl_arrow), idx); ++idx;
5088 XSETFASTINT (BVAR (&buffer_local_flags, fill_column), idx); ++idx;
5089 XSETFASTINT (BVAR (&buffer_local_flags, left_margin), idx); ++idx;
5090 XSETFASTINT (BVAR (&buffer_local_flags, abbrev_table), idx); ++idx;
5091 XSETFASTINT (BVAR (&buffer_local_flags, display_table), idx); ++idx;
5092 XSETFASTINT (BVAR (&buffer_local_flags, syntax_table), idx); ++idx;
5093 XSETFASTINT (BVAR (&buffer_local_flags, cache_long_scans), idx); ++idx;
5094 XSETFASTINT (BVAR (&buffer_local_flags, category_table), idx); ++idx;
5095 XSETFASTINT (BVAR (&buffer_local_flags, bidi_display_reordering), idx); ++idx;
5096 XSETFASTINT (BVAR (&buffer_local_flags, bidi_paragraph_direction), idx); ++idx;
5097 XSETFASTINT (BVAR (&buffer_local_flags, buffer_file_coding_system), idx);
5098 /* Make this one a permanent local. */
5099 buffer_permanent_local_flags[idx++] = 1;
5100 XSETFASTINT (BVAR (&buffer_local_flags, left_margin_cols), idx); ++idx;
5101 XSETFASTINT (BVAR (&buffer_local_flags, right_margin_cols), idx); ++idx;
5102 XSETFASTINT (BVAR (&buffer_local_flags, left_fringe_width), idx); ++idx;
5103 XSETFASTINT (BVAR (&buffer_local_flags, right_fringe_width), idx); ++idx;
5104 XSETFASTINT (BVAR (&buffer_local_flags, fringes_outside_margins), idx); ++idx;
5105 XSETFASTINT (BVAR (&buffer_local_flags, scroll_bar_width), idx); ++idx;
5106 XSETFASTINT (BVAR (&buffer_local_flags, scroll_bar_height), idx); ++idx;
5107 XSETFASTINT (BVAR (&buffer_local_flags, vertical_scroll_bar_type), idx); ++idx;
5108 XSETFASTINT (BVAR (&buffer_local_flags, horizontal_scroll_bar_type), idx); ++idx;
5109 XSETFASTINT (BVAR (&buffer_local_flags, indicate_empty_lines), idx); ++idx;
5110 XSETFASTINT (BVAR (&buffer_local_flags, indicate_buffer_boundaries), idx); ++idx;
5111 XSETFASTINT (BVAR (&buffer_local_flags, fringe_indicator_alist), idx); ++idx;
5112 XSETFASTINT (BVAR (&buffer_local_flags, fringe_cursor_alist), idx); ++idx;
5113 XSETFASTINT (BVAR (&buffer_local_flags, scroll_up_aggressively), idx); ++idx;
5114 XSETFASTINT (BVAR (&buffer_local_flags, scroll_down_aggressively), idx); ++idx;
5115 XSETFASTINT (BVAR (&buffer_local_flags, header_line_format), idx); ++idx;
5116 XSETFASTINT (BVAR (&buffer_local_flags, cursor_type), idx); ++idx;
5117 XSETFASTINT (BVAR (&buffer_local_flags, extra_line_spacing), idx); ++idx;
5118 XSETFASTINT (BVAR (&buffer_local_flags, cursor_in_non_selected_windows), idx); ++idx;
5119
5120 /* Need more room? */
5121 if (idx >= MAX_PER_BUFFER_VARS)
5122 emacs_abort ();
5123 last_per_buffer_idx = idx;
5124
5038 /* Make sure all markable slots in buffer_defaults 5125 /* Make sure all markable slots in buffer_defaults
5039 are initialized reasonably, so mark_buffer won't choke. */ 5126 are initialized reasonably, so mark_buffer won't choke. */
5040 reset_buffer (&buffer_defaults); 5127 reset_buffer (&buffer_defaults);
@@ -5121,79 +5208,9 @@ init_buffer_once (void)
5121 to say that it has its own local value for the slot. 5208 to say that it has its own local value for the slot.
5122 The local flag bits are in the local_var_flags slot of the buffer. */ 5209 The local flag bits are in the local_var_flags slot of the buffer. */
5123 5210
5124 /* Nothing can work if this isn't true */ 5211 /* Nothing can work if this isn't true. */
5125 { verify (sizeof (EMACS_INT) == word_size); } 5212 { verify (sizeof (EMACS_INT) == word_size); }
5126 5213
5127 /* 0 means not a lisp var, -1 means always local, else mask */
5128 memset (&buffer_local_flags, 0, sizeof buffer_local_flags);
5129 bset_filename (&buffer_local_flags, make_number (-1));
5130 bset_directory (&buffer_local_flags, make_number (-1));
5131 bset_backed_up (&buffer_local_flags, make_number (-1));
5132 bset_save_length (&buffer_local_flags, make_number (-1));
5133 bset_auto_save_file_name (&buffer_local_flags, make_number (-1));
5134 bset_read_only (&buffer_local_flags, make_number (-1));
5135 bset_major_mode (&buffer_local_flags, make_number (-1));
5136 bset_mode_name (&buffer_local_flags, make_number (-1));
5137 bset_undo_list (&buffer_local_flags, make_number (-1));
5138 bset_mark_active (&buffer_local_flags, make_number (-1));
5139 bset_point_before_scroll (&buffer_local_flags, make_number (-1));
5140 bset_file_truename (&buffer_local_flags, make_number (-1));
5141 bset_invisibility_spec (&buffer_local_flags, make_number (-1));
5142 bset_file_format (&buffer_local_flags, make_number (-1));
5143 bset_auto_save_file_format (&buffer_local_flags, make_number (-1));
5144 bset_display_count (&buffer_local_flags, make_number (-1));
5145 bset_display_time (&buffer_local_flags, make_number (-1));
5146 bset_enable_multibyte_characters (&buffer_local_flags, make_number (-1));
5147
5148 idx = 1;
5149 XSETFASTINT (BVAR (&buffer_local_flags, mode_line_format), idx); ++idx;
5150 XSETFASTINT (BVAR (&buffer_local_flags, abbrev_mode), idx); ++idx;
5151 XSETFASTINT (BVAR (&buffer_local_flags, overwrite_mode), idx); ++idx;
5152 XSETFASTINT (BVAR (&buffer_local_flags, case_fold_search), idx); ++idx;
5153 XSETFASTINT (BVAR (&buffer_local_flags, auto_fill_function), idx); ++idx;
5154 XSETFASTINT (BVAR (&buffer_local_flags, selective_display), idx); ++idx;
5155 XSETFASTINT (BVAR (&buffer_local_flags, selective_display_ellipses), idx); ++idx;
5156 XSETFASTINT (BVAR (&buffer_local_flags, tab_width), idx); ++idx;
5157 XSETFASTINT (BVAR (&buffer_local_flags, truncate_lines), idx); ++idx;
5158 XSETFASTINT (BVAR (&buffer_local_flags, word_wrap), idx); ++idx;
5159 XSETFASTINT (BVAR (&buffer_local_flags, ctl_arrow), idx); ++idx;
5160 XSETFASTINT (BVAR (&buffer_local_flags, fill_column), idx); ++idx;
5161 XSETFASTINT (BVAR (&buffer_local_flags, left_margin), idx); ++idx;
5162 XSETFASTINT (BVAR (&buffer_local_flags, abbrev_table), idx); ++idx;
5163 XSETFASTINT (BVAR (&buffer_local_flags, display_table), idx); ++idx;
5164 XSETFASTINT (BVAR (&buffer_local_flags, syntax_table), idx); ++idx;
5165 XSETFASTINT (BVAR (&buffer_local_flags, cache_long_scans), idx); ++idx;
5166 XSETFASTINT (BVAR (&buffer_local_flags, category_table), idx); ++idx;
5167 XSETFASTINT (BVAR (&buffer_local_flags, bidi_display_reordering), idx); ++idx;
5168 XSETFASTINT (BVAR (&buffer_local_flags, bidi_paragraph_direction), idx); ++idx;
5169 XSETFASTINT (BVAR (&buffer_local_flags, buffer_file_coding_system), idx);
5170 /* Make this one a permanent local. */
5171 buffer_permanent_local_flags[idx++] = 1;
5172 XSETFASTINT (BVAR (&buffer_local_flags, left_margin_cols), idx); ++idx;
5173 XSETFASTINT (BVAR (&buffer_local_flags, right_margin_cols), idx); ++idx;
5174 XSETFASTINT (BVAR (&buffer_local_flags, left_fringe_width), idx); ++idx;
5175 XSETFASTINT (BVAR (&buffer_local_flags, right_fringe_width), idx); ++idx;
5176 XSETFASTINT (BVAR (&buffer_local_flags, fringes_outside_margins), idx); ++idx;
5177 XSETFASTINT (BVAR (&buffer_local_flags, scroll_bar_width), idx); ++idx;
5178 XSETFASTINT (BVAR (&buffer_local_flags, scroll_bar_height), idx); ++idx;
5179 XSETFASTINT (BVAR (&buffer_local_flags, vertical_scroll_bar_type), idx); ++idx;
5180 XSETFASTINT (BVAR (&buffer_local_flags, horizontal_scroll_bar_type), idx); ++idx;
5181 XSETFASTINT (BVAR (&buffer_local_flags, indicate_empty_lines), idx); ++idx;
5182 XSETFASTINT (BVAR (&buffer_local_flags, indicate_buffer_boundaries), idx); ++idx;
5183 XSETFASTINT (BVAR (&buffer_local_flags, fringe_indicator_alist), idx); ++idx;
5184 XSETFASTINT (BVAR (&buffer_local_flags, fringe_cursor_alist), idx); ++idx;
5185 XSETFASTINT (BVAR (&buffer_local_flags, scroll_up_aggressively), idx); ++idx;
5186 XSETFASTINT (BVAR (&buffer_local_flags, scroll_down_aggressively), idx); ++idx;
5187 XSETFASTINT (BVAR (&buffer_local_flags, header_line_format), idx); ++idx;
5188 XSETFASTINT (BVAR (&buffer_local_flags, cursor_type), idx); ++idx;
5189 XSETFASTINT (BVAR (&buffer_local_flags, extra_line_spacing), idx); ++idx;
5190 XSETFASTINT (BVAR (&buffer_local_flags, cursor_in_non_selected_windows), idx); ++idx;
5191
5192 /* Need more room? */
5193 if (idx >= MAX_PER_BUFFER_VARS)
5194 emacs_abort ();
5195 last_per_buffer_idx = idx;
5196
5197 Vbuffer_alist = Qnil; 5214 Vbuffer_alist = Qnil;
5198 current_buffer = 0; 5215 current_buffer = 0;
5199 all_buffers = 0; 5216 all_buffers = 0;
@@ -5210,7 +5227,7 @@ init_buffer_once (void)
5210 DEFSYM (Qkill_buffer_hook, "kill-buffer-hook"); 5227 DEFSYM (Qkill_buffer_hook, "kill-buffer-hook");
5211 Fput (Qkill_buffer_hook, Qpermanent_local, Qt); 5228 Fput (Qkill_buffer_hook, Qpermanent_local, Qt);
5212 5229
5213 /* super-magic invisible buffer */ 5230 /* Super-magic invisible buffer. */
5214 Vprin1_to_string_buffer = Fget_buffer_create (build_pure_c_string (" prin1")); 5231 Vprin1_to_string_buffer = Fget_buffer_create (build_pure_c_string (" prin1"));
5215 Vbuffer_alist = Qnil; 5232 Vbuffer_alist = Qnil;
5216 5233
diff --git a/src/callint.c b/src/callint.c
index 25955039ac7..dd238b976aa 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,
101 Emacs first calls the function `handle-shift-selection'. 101 Emacs first calls the function `handle-shift-selection'.
102You may use `@', `*', and `^' together. They are processed in the 102You may use `@', `*', and `^' together. They are processed in the
103 order that they appear, before reading any arguments. 103 order that they appear, before reading any arguments.
104usage: (interactive &optional ARGS) */) 104usage: (interactive &optional ARGS) */
105 attributes: const)
105 (Lisp_Object args) 106 (Lisp_Object args)
106{ 107{
107 return Qnil; 108 return Qnil;
diff --git a/src/callproc.c b/src/callproc.c
index 0fdf278073d..63ab9bf70db 100644
--- a/src/callproc.c
+++ b/src/callproc.c
@@ -131,12 +131,9 @@ encode_current_directory (void)
131 report_file_error ("Setting current directory", 131 report_file_error ("Setting current directory",
132 BVAR (current_buffer, directory)); 132 BVAR (current_buffer, directory));
133 133
134 /* Remove "/:" from dir. */ 134 /* Remove "/:" from DIR and encode it. */
135 if (! NILP (Fstring_match (build_string ("^/:"), dir, Qnil))) 135 dir = ENCODE_FILE (remove_slash_colon (dir));
136 dir = Fsubstring (dir, make_number (2), Qnil);
137 136
138 if (STRING_MULTIBYTE (dir))
139 dir = ENCODE_FILE (dir);
140 if (! file_accessible_directory_p (dir)) 137 if (! file_accessible_directory_p (dir))
141 report_file_error ("Setting current directory", 138 report_file_error ("Setting current directory",
142 BVAR (current_buffer, directory)); 139 BVAR (current_buffer, directory));
@@ -267,7 +264,7 @@ usage: (call-process PROGRAM &optional INFILE DESTINATION DISPLAY &rest ARGS) *
267 infile = build_string (NULL_DEVICE); 264 infile = build_string (NULL_DEVICE);
268 265
269 GCPRO1 (infile); 266 GCPRO1 (infile);
270 encoded_infile = STRING_MULTIBYTE (infile) ? ENCODE_FILE (infile) : infile; 267 encoded_infile = ENCODE_FILE (infile);
271 268
272 filefd = emacs_open (SSDATA (encoded_infile), O_RDONLY, 0); 269 filefd = emacs_open (SSDATA (encoded_infile), O_RDONLY, 0);
273 if (filefd < 0) 270 if (filefd < 0)
@@ -439,9 +436,9 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
439 436
440 GCPRO4 (buffer, current_dir, error_file, output_file); 437 GCPRO4 (buffer, current_dir, error_file, output_file);
441 438
442 if (STRINGP (error_file) && STRING_MULTIBYTE (error_file)) 439 if (STRINGP (error_file))
443 error_file = ENCODE_FILE (error_file); 440 error_file = ENCODE_FILE (error_file);
444 if (STRINGP (output_file) && STRING_MULTIBYTE (output_file)) 441 if (STRINGP (output_file))
445 output_file = ENCODE_FILE (output_file); 442 output_file = ENCODE_FILE (output_file);
446 UNGCPRO; 443 UNGCPRO;
447 } 444 }
@@ -468,11 +465,8 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
468 report_file_error ("Searching for program", args[0]); 465 report_file_error ("Searching for program", args[0]);
469 } 466 }
470 467
471 /* If program file name starts with /: for quoting a magic name, 468 /* Remove "/:" from PATH. */
472 discard that. */ 469 path = remove_slash_colon (path);
473 if (SBYTES (path) > 2 && SREF (path, 0) == '/'
474 && SREF (path, 1) == ':')
475 path = Fsubstring (path, make_number (2), Qnil);
476 470
477 SAFE_NALLOCA (new_argv, 1, nargs < 4 ? 2 : nargs - 2); 471 SAFE_NALLOCA (new_argv, 1, nargs < 4 ? 2 : nargs - 2);
478 472
@@ -498,8 +492,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
498 } 492 }
499 else 493 else
500 new_argv[1] = 0; 494 new_argv[1] = 0;
501 if (STRING_MULTIBYTE (path)) 495 path = ENCODE_FILE (path);
502 path = ENCODE_FILE (path);
503 new_argv[0] = SSDATA (path); 496 new_argv[0] = SSDATA (path);
504 UNGCPRO; 497 UNGCPRO;
505 } 498 }
diff --git a/src/character.c b/src/character.c
index 4a5c7ec3156..39d32c9d41a 100644
--- a/src/character.c
+++ b/src/character.c
@@ -232,14 +232,16 @@ DEFUN ("characterp", Fcharacterp, Scharacterp, 1, 2, 0,
232In Emacs Lisp, characters are represented by character codes, which 232In Emacs Lisp, characters are represented by character codes, which
233are non-negative integers. The function `max-char' returns the 233are non-negative integers. The function `max-char' returns the
234maximum character code. 234maximum character code.
235usage: (characterp OBJECT) */) 235usage: (characterp OBJECT) */
236 attributes: const)
236 (Lisp_Object object, Lisp_Object ignore) 237 (Lisp_Object object, Lisp_Object ignore)
237{ 238{
238 return (CHARACTERP (object) ? Qt : Qnil); 239 return (CHARACTERP (object) ? Qt : Qnil);
239} 240}
240 241
241DEFUN ("max-char", Fmax_char, Smax_char, 0, 0, 0, 242DEFUN ("max-char", Fmax_char, Smax_char, 0, 0, 0,
242 doc: /* Return the character of the maximum code. */) 243 doc: /* Return the character of the maximum code. */
244 attributes: const)
243 (void) 245 (void)
244{ 246{
245 return make_number (MAX_CHAR); 247 return make_number (MAX_CHAR);
diff --git a/src/coding.c b/src/coding.c
index 20c64762160..b11143a32fb 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. */)
10671 10671
10672DEFUN ("coding-system-plist", Fcoding_system_plist, Scoding_system_plist, 10672DEFUN ("coding-system-plist", Fcoding_system_plist, Scoding_system_plist,
10673 1, 1, 0, 10673 1, 1, 0,
10674 doc: "Return the property list of CODING-SYSTEM.") 10674 doc: /* Return the property list of CODING-SYSTEM. */)
10675 (Lisp_Object coding_system) 10675 (Lisp_Object coding_system)
10676{ 10676{
10677 Lisp_Object spec, attrs; 10677 Lisp_Object spec, attrs;
diff --git a/src/data.c b/src/data.c
index 820c3ce8407..0389eb49b06 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)
176/* Data type predicates. */ 176/* Data type predicates. */
177 177
178DEFUN ("eq", Feq, Seq, 2, 2, 0, 178DEFUN ("eq", Feq, Seq, 2, 2, 0,
179 doc: /* Return t if the two args are the same Lisp object. */) 179 doc: /* Return t if the two args are the same Lisp object. */
180 attributes: const)
180 (Lisp_Object obj1, Lisp_Object obj2) 181 (Lisp_Object obj1, Lisp_Object obj2)
181{ 182{
182 if (EQ (obj1, obj2)) 183 if (EQ (obj1, obj2))
@@ -185,7 +186,8 @@ DEFUN ("eq", Feq, Seq, 2, 2, 0,
185} 186}
186 187
187DEFUN ("null", Fnull, Snull, 1, 1, 0, 188DEFUN ("null", Fnull, Snull, 1, 1, 0,
188 doc: /* Return t if OBJECT is nil. */) 189 doc: /* Return t if OBJECT is nil. */
190 attributes: const)
189 (Lisp_Object object) 191 (Lisp_Object object)
190{ 192{
191 if (NILP (object)) 193 if (NILP (object))
@@ -263,7 +265,8 @@ for example, (type-of 1) returns `integer'. */)
263} 265}
264 266
265DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, 267DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0,
266 doc: /* Return t if OBJECT is a cons cell. */) 268 doc: /* Return t if OBJECT is a cons cell. */
269 attributes: const)
267 (Lisp_Object object) 270 (Lisp_Object object)
268{ 271{
269 if (CONSP (object)) 272 if (CONSP (object))
@@ -272,7 +275,8 @@ DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0,
272} 275}
273 276
274DEFUN ("atom", Fatom, Satom, 1, 1, 0, 277DEFUN ("atom", Fatom, Satom, 1, 1, 0,
275 doc: /* Return t if OBJECT is not a cons cell. This includes nil. */) 278 doc: /* Return t if OBJECT is not a cons cell. This includes nil. */
279 attributes: const)
276 (Lisp_Object object) 280 (Lisp_Object object)
277{ 281{
278 if (CONSP (object)) 282 if (CONSP (object))
@@ -282,7 +286,8 @@ DEFUN ("atom", Fatom, Satom, 1, 1, 0,
282 286
283DEFUN ("listp", Flistp, Slistp, 1, 1, 0, 287DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
284 doc: /* Return t if OBJECT is a list, that is, a cons cell or nil. 288 doc: /* Return t if OBJECT is a list, that is, a cons cell or nil.
285Otherwise, return nil. */) 289Otherwise, return nil. */
290 attributes: const)
286 (Lisp_Object object) 291 (Lisp_Object object)
287{ 292{
288 if (CONSP (object) || NILP (object)) 293 if (CONSP (object) || NILP (object))
@@ -291,7 +296,8 @@ Otherwise, return nil. */)
291} 296}
292 297
293DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, 298DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
294 doc: /* Return t if OBJECT is not a list. Lists include nil. */) 299 doc: /* Return t if OBJECT is not a list. Lists include nil. */
300 attributes: const)
295 (Lisp_Object object) 301 (Lisp_Object object)
296{ 302{
297 if (CONSP (object) || NILP (object)) 303 if (CONSP (object) || NILP (object))
@@ -300,7 +306,8 @@ DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
300} 306}
301 307
302DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, 308DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
303 doc: /* Return t if OBJECT is a symbol. */) 309 doc: /* Return t if OBJECT is a symbol. */
310 attributes: const)
304 (Lisp_Object object) 311 (Lisp_Object object)
305{ 312{
306 if (SYMBOLP (object)) 313 if (SYMBOLP (object))
@@ -333,7 +340,8 @@ DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
333} 340}
334 341
335DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0, 342DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
336 doc: /* Return t if OBJECT is a string. */) 343 doc: /* Return t if OBJECT is a string. */
344 attributes: const)
337 (Lisp_Object object) 345 (Lisp_Object object)
338{ 346{
339 if (STRINGP (object)) 347 if (STRINGP (object))
@@ -436,7 +444,8 @@ DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
436} 444}
437 445
438DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0, 446DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
439 doc: /* Return t if OBJECT is a character or a string. */) 447 doc: /* Return t if OBJECT is a character or a string. */
448 attributes: const)
440 (register Lisp_Object object) 449 (register Lisp_Object object)
441{ 450{
442 if (CHARACTERP (object) || STRINGP (object)) 451 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,
445} 454}
446 455
447DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, 456DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0,
448 doc: /* Return t if OBJECT is an integer. */) 457 doc: /* Return t if OBJECT is an integer. */
458 attributes: const)
449 (Lisp_Object object) 459 (Lisp_Object object)
450{ 460{
451 if (INTEGERP (object)) 461 if (INTEGERP (object))
@@ -463,7 +473,8 @@ DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1,
463} 473}
464 474
465DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0, 475DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
466 doc: /* Return t if OBJECT is a nonnegative integer. */) 476 doc: /* Return t if OBJECT is a nonnegative integer. */
477 attributes: const)
467 (Lisp_Object object) 478 (Lisp_Object object)
468{ 479{
469 if (NATNUMP (object)) 480 if (NATNUMP (object))
@@ -472,7 +483,8 @@ DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
472} 483}
473 484
474DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0, 485DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
475 doc: /* Return t if OBJECT is a number (floating point or integer). */) 486 doc: /* Return t if OBJECT is a number (floating point or integer). */
487 attributes: const)
476 (Lisp_Object object) 488 (Lisp_Object object)
477{ 489{
478 if (NUMBERP (object)) 490 if (NUMBERP (object))
@@ -492,7 +504,8 @@ DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
492} 504}
493 505
494DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0, 506DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
495 doc: /* Return t if OBJECT is a floating point number. */) 507 doc: /* Return t if OBJECT is a floating point number. */
508 attributes: const)
496 (Lisp_Object object) 509 (Lisp_Object object)
497{ 510{
498 if (FLOATP (object)) 511 if (FLOATP (object))
@@ -2954,7 +2967,8 @@ DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
2954DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0, 2967DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0,
2955 doc: /* Return the byteorder for the machine. 2968 doc: /* Return the byteorder for the machine.
2956Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII 2969Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2957lowercase l) for small endian machines. */) 2970lowercase l) for small endian machines. */
2971 attributes: const)
2958 (void) 2972 (void)
2959{ 2973{
2960 unsigned i = 0x04030201; 2974 unsigned i = 0x04030201;
diff --git a/src/decompress.c b/src/decompress.c
index b14f0a2cd79..b78dacee207 100644
--- a/src/decompress.c
+++ b/src/decompress.c
@@ -88,7 +88,8 @@ unwind_decompress (void *ddata)
88} 88}
89 89
90DEFUN ("zlib-available-p", Fzlib_available_p, Szlib_available_p, 0, 0, 0, 90DEFUN ("zlib-available-p", Fzlib_available_p, Szlib_available_p, 0, 0, 0,
91 doc: /* Return t if zlib decompression is available in this instance of Emacs. */) 91 doc: /* Return t if zlib decompression is available in this instance of Emacs. */
92 attributes: const)
92 (void) 93 (void)
93{ 94{
94#ifdef WINDOWSNT 95#ifdef WINDOWSNT
diff --git a/src/dired.c b/src/dired.c
index 00f9a5b0765..ca43cd90219 100644
--- a/src/dired.c
+++ b/src/dired.c
@@ -176,10 +176,8 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full,
176 /* Note: ENCODE_FILE and DECODE_FILE can GC because they can run 176 /* Note: ENCODE_FILE and DECODE_FILE can GC because they can run
177 run_pre_post_conversion_on_str which calls Lisp directly and 177 run_pre_post_conversion_on_str which calls Lisp directly and
178 indirectly. */ 178 indirectly. */
179 if (STRING_MULTIBYTE (dirfilename)) 179 dirfilename = ENCODE_FILE (dirfilename);
180 dirfilename = ENCODE_FILE (dirfilename); 180 encoded_directory = ENCODE_FILE (directory);
181 encoded_directory = (STRING_MULTIBYTE (directory)
182 ? ENCODE_FILE (directory) : directory);
183 181
184 /* Now *bufp is the compiled form of MATCH; don't call anything 182 /* Now *bufp is the compiled form of MATCH; don't call anything
185 which might compile a new regexp until we're done with the loop! */ 183 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,
482 /* Actually, this is not quite true any more: we do most of the completion 480 /* Actually, this is not quite true any more: we do most of the completion
483 work with decoded file names, but we still do some filtering based 481 work with decoded file names, but we still do some filtering based
484 on the encoded file name. */ 482 on the encoded file name. */
485 encoded_file = STRING_MULTIBYTE (file) ? ENCODE_FILE (file) : file; 483 encoded_file = ENCODE_FILE (file);
486 484
487 encoded_dir = ENCODE_FILE (Fdirectory_file_name (dirname)); 485 encoded_dir = ENCODE_FILE (Fdirectory_file_name (dirname));
488 486
@@ -634,23 +632,14 @@ file_name_completion (Lisp_Object file, Lisp_Object dirname, bool all_flag,
634 name = DECODE_FILE (name); 632 name = DECODE_FILE (name);
635 633
636 { 634 {
637 Lisp_Object regexps; 635 Lisp_Object regexps, table = (completion_ignore_case
636 ? Vascii_canon_table : Qnil);
638 637
639 /* Ignore this element if it fails to match all the regexps. */ 638 /* Ignore this element if it fails to match all the regexps. */
640 if (completion_ignore_case) 639 for (regexps = Vcompletion_regexp_list; CONSP (regexps);
641 { 640 regexps = XCDR (regexps))
642 for (regexps = Vcompletion_regexp_list; CONSP (regexps); 641 if (fast_string_match_internal (XCAR (regexps), name, table) < 0)
643 regexps = XCDR (regexps)) 642 break;
644 if (fast_string_match_ignore_case (XCAR (regexps), name) < 0)
645 break;
646 }
647 else
648 {
649 for (regexps = Vcompletion_regexp_list; CONSP (regexps);
650 regexps = XCDR (regexps))
651 if (fast_string_match (XCAR (regexps), name) < 0)
652 break;
653 }
654 643
655 if (CONSP (regexps)) 644 if (CONSP (regexps))
656 continue; 645 continue;
diff --git a/src/dispnew.c b/src/dispnew.c
index bb75973edb8..bfa06bd2878 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,
5536 5536
5537 /* Adjust frame size but make sure x_set_window_size does not 5537 /* Adjust frame size but make sure x_set_window_size does not
5538 get called. */ 5538 get called. */
5539 adjust_frame_size (f, new_width, new_height, 5, pretend, Qnil); 5539 adjust_frame_size (f, new_width, new_height, 5, pretend,
5540 Qchange_frame_size);
5540 } 5541 }
5541} 5542}
5542 5543
diff --git a/src/editfns.c b/src/editfns.c
index cd15f6569aa..621e841c3f5 100644
--- a/src/editfns.c
+++ b/src/editfns.c
@@ -2063,6 +2063,29 @@ check_tm_member (Lisp_Object obj, int offset)
2063 return n - offset; 2063 return n - offset;
2064} 2064}
2065 2065
2066/* Decode ZONE as a time zone specification. */
2067
2068static Lisp_Object
2069decode_time_zone (Lisp_Object zone)
2070{
2071 if (EQ (zone, Qt))
2072 return build_string ("UTC0");
2073 else if (STRINGP (zone))
2074 return zone;
2075 else if (INTEGERP (zone))
2076 {
2077 static char const tzbuf_format[] = "XXX%s%"pI"d:%02d:%02d";
2078 char tzbuf[sizeof tzbuf_format + INT_STRLEN_BOUND (EMACS_INT)];
2079 EMACS_INT abszone = eabs (XINT (zone)), zone_hr = abszone / (60 * 60);
2080 int zone_min = (abszone / 60) % 60, zone_sec = abszone % 60;
2081
2082 return make_formatted_string (tzbuf, tzbuf_format, &"-"[XINT (zone) < 0],
2083 zone_hr, zone_min, zone_sec);
2084 }
2085 else
2086 xsignal2 (Qerror, build_string ("Invalid time zone specification"), zone);
2087}
2088
2066DEFUN ("encode-time", Fencode_time, Sencode_time, 6, MANY, 0, 2089DEFUN ("encode-time", Fencode_time, Sencode_time, 6, MANY, 0,
2067 doc: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time. 2090 doc: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
2068This is the reverse operation of `decode-time', which see. 2091This is the reverse operation of `decode-time', which see.
@@ -2105,30 +2128,7 @@ usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
2105 value = mktime (&tm); 2128 value = mktime (&tm);
2106 else 2129 else
2107 { 2130 {
2108 static char const tzbuf_format[] = "XXX%s%"pI"d:%02d:%02d"; 2131 timezone_t tz = tzalloc (SSDATA (decode_time_zone (zone)));
2109 char tzbuf[sizeof tzbuf_format + INT_STRLEN_BOUND (EMACS_INT)];
2110 const char *tzstring;
2111
2112 if (EQ (zone, Qt))
2113 tzstring = "UTC0";
2114 else if (STRINGP (zone))
2115 tzstring = SSDATA (zone);
2116 else if (INTEGERP (zone))
2117 {
2118 EMACS_INT abszone = eabs (XINT (zone));
2119 EMACS_INT zone_hr = abszone / (60*60);
2120 int zone_min = (abszone/60) % 60;
2121 int zone_sec = abszone % 60;
2122 sprintf (tzbuf, tzbuf_format, &"-"[XINT (zone) < 0],
2123 zone_hr, zone_min, zone_sec);
2124 tzstring = tzbuf;
2125 }
2126 else
2127 tzstring = 0;
2128
2129 timezone_t tz = tzstring ? tzalloc (tzstring) : 0;
2130 if (! tz)
2131 error ("Invalid time zone specification");
2132 value = mktime_z (tz, &tm); 2132 value = mktime_z (tz, &tm);
2133 tzfree (tz); 2133 tzfree (tz);
2134 } 2134 }
@@ -2265,7 +2265,8 @@ the data it can't find. */)
2265DEFUN ("set-time-zone-rule", Fset_time_zone_rule, Sset_time_zone_rule, 1, 1, 0, 2265DEFUN ("set-time-zone-rule", Fset_time_zone_rule, Sset_time_zone_rule, 1, 1, 0,
2266 doc: /* Set the local time zone using TZ, a string specifying a time zone rule. 2266 doc: /* Set the local time zone using TZ, a string specifying a time zone rule.
2267If TZ is nil, use implementation-defined default time zone information. 2267If TZ is nil, use implementation-defined default time zone information.
2268If TZ is t, use Universal Time. 2268If TZ is t, use Universal Time. If TZ is an integer, it is treated as in
2269`encode-time'.
2269 2270
2270Instead of calling this function, you typically want (setenv "TZ" TZ). 2271Instead of calling this function, you typically want (setenv "TZ" TZ).
2271That changes both the environment of the Emacs process and the 2272That changes both the environment of the Emacs process and the
@@ -2273,17 +2274,7 @@ variable `process-environment', whereas `set-time-zone-rule' affects
2273only the former. */) 2274only the former. */)
2274 (Lisp_Object tz) 2275 (Lisp_Object tz)
2275{ 2276{
2276 const char *tzstring; 2277 const char *tzstring = NILP (tz) ? initial_tz : SSDATA (decode_time_zone (tz));
2277
2278 if (! (NILP (tz) || EQ (tz, Qt)))
2279 CHECK_STRING (tz);
2280
2281 if (NILP (tz))
2282 tzstring = initial_tz;
2283 else if (EQ (tz, Qt))
2284 tzstring = "UTC0";
2285 else
2286 tzstring = SSDATA (tz);
2287 2278
2288 block_input (); 2279 block_input ();
2289 set_time_zone_rule (tzstring); 2280 set_time_zone_rule (tzstring);
@@ -2633,15 +2624,34 @@ make_buffer_string_both (ptrdiff_t start, ptrdiff_t start_byte,
2633 ptrdiff_t end, ptrdiff_t end_byte, bool props) 2624 ptrdiff_t end, ptrdiff_t end_byte, bool props)
2634{ 2625{
2635 Lisp_Object result, tem, tem1; 2626 Lisp_Object result, tem, tem1;
2627 ptrdiff_t beg0, end0, beg1, end1, size;
2636 2628
2637 if (start < GPT && GPT < end) 2629 if (start_byte < GPT_BYTE && GPT_BYTE < end_byte)
2638 move_gap_both (start, start_byte); 2630 {
2631 /* Two regions, before and after the gap. */
2632 beg0 = start_byte;
2633 end0 = GPT_BYTE;
2634 beg1 = GPT_BYTE + GAP_SIZE - BEG_BYTE;
2635 end1 = end_byte + GAP_SIZE - BEG_BYTE;
2636 }
2637 else
2638 {
2639 /* The only region. */
2640 beg0 = start_byte;
2641 end0 = end_byte;
2642 beg1 = -1;
2643 end1 = -1;
2644 }
2639 2645
2640 if (! NILP (BVAR (current_buffer, enable_multibyte_characters))) 2646 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)))
2641 result = make_uninit_multibyte_string (end - start, end_byte - start_byte); 2647 result = make_uninit_multibyte_string (end - start, end_byte - start_byte);
2642 else 2648 else
2643 result = make_uninit_string (end - start); 2649 result = make_uninit_string (end - start);
2644 memcpy (SDATA (result), BYTE_POS_ADDR (start_byte), end_byte - start_byte); 2650
2651 size = end0 - beg0;
2652 memcpy (SDATA (result), BYTE_POS_ADDR (beg0), size);
2653 if (beg1 != -1)
2654 memcpy (SDATA (result) + size, BEG_ADDR + beg1, end1 - beg1);
2645 2655
2646 /* If desired, update and copy the text properties. */ 2656 /* If desired, update and copy the text properties. */
2647 if (props) 2657 if (props)
diff --git a/src/emacs.c b/src/emacs.c
index e7094b11580..d83311ac5b6 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -1898,7 +1898,8 @@ or SIGHUP, and upon SIGINT in batch mode.
1898 1898
1899The value of `kill-emacs-hook', if not void, 1899The value of `kill-emacs-hook', if not void,
1900is a list of functions (of no args), 1900is a list of functions (of no args),
1901all of which are called before Emacs is actually killed. */) 1901all of which are called before Emacs is actually killed. */
1902 attributes: noreturn)
1902 (Lisp_Object arg) 1903 (Lisp_Object arg)
1903{ 1904{
1904 struct gcpro gcpro1; 1905 struct gcpro gcpro1;
diff --git a/src/eval.c b/src/eval.c
index 7e4b016b236..5cadb1bc2de 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1162,7 +1162,8 @@ unwind_to_catch (struct handler *catch, Lisp_Object value)
1162 1162
1163DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0, 1163DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0,
1164 doc: /* Throw to the catch for TAG and return VALUE from it. 1164 doc: /* Throw to the catch for TAG and return VALUE from it.
1165Both TAG and VALUE are evalled. */) 1165Both TAG and VALUE are evalled. */
1166 attributes: noreturn)
1166 (register Lisp_Object tag, Lisp_Object value) 1167 (register Lisp_Object tag, Lisp_Object value)
1167{ 1168{
1168 struct handler *c; 1169 struct handler *c;
diff --git a/src/fileio.c b/src/fileio.c
index 15c6f9123a2..6c443c91db7 100644
--- a/src/fileio.c
+++ b/src/fileio.c
@@ -522,8 +522,6 @@ For a Unix-syntax file name, just appends a slash. */)
522 USE_SAFE_ALLOCA; 522 USE_SAFE_ALLOCA;
523 523
524 CHECK_STRING (file); 524 CHECK_STRING (file);
525 if (NILP (file))
526 return Qnil;
527 525
528 /* If the file name has special constructs in it, 526 /* If the file name has special constructs in it,
529 call the corresponding file handler. */ 527 call the corresponding file handler. */
@@ -591,9 +589,6 @@ In Unix-syntax, this function just removes the final slash. */)
591 589
592 CHECK_STRING (directory); 590 CHECK_STRING (directory);
593 591
594 if (NILP (directory))
595 return Qnil;
596
597 /* If the file name has special constructs in it, 592 /* If the file name has special constructs in it,
598 call the corresponding file handler. */ 593 call the corresponding file handler. */
599 handler = Ffind_file_name_handler (directory, Qdirectory_file_name); 594 handler = Ffind_file_name_handler (directory, Qdirectory_file_name);
@@ -5738,8 +5733,8 @@ then any auto-save counts as "recent". */)
5738 they're never autosaved. */ 5733 they're never autosaved. */
5739 return (SAVE_MODIFF < BUF_AUTOSAVE_MODIFF (current_buffer) ? Qt : Qnil); 5734 return (SAVE_MODIFF < BUF_AUTOSAVE_MODIFF (current_buffer) ? Qt : Qnil);
5740} 5735}
5741 5736
5742/* Reading and completing file names */ 5737/* Reading and completing file names. */
5743 5738
5744DEFUN ("next-read-file-uses-dialog-p", Fnext_read_file_uses_dialog_p, 5739DEFUN ("next-read-file-uses-dialog-p", Fnext_read_file_uses_dialog_p,
5745 Snext_read_file_uses_dialog_p, 0, 0, 0, 5740 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
5748before any other event (mouse or keypress) is handled. */) 5743before any other event (mouse or keypress) is handled. */)
5749 (void) 5744 (void)
5750{ 5745{
5751#if defined (USE_MOTIF) || defined (HAVE_NTGUI) || defined (USE_GTK) \ 5746#if (defined USE_GTK || defined USE_MOTIF \
5752 || defined (HAVE_NS) 5747 || defined HAVE_NS || defined HAVE_NTGUI)
5753 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event)) 5748 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
5754 && use_dialog_box 5749 && use_dialog_box
5755 && use_file_dialog 5750 && use_file_dialog
diff --git a/src/fns.c b/src/fns.c
index 7739663b775..91cd5132546 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -46,7 +46,8 @@ static void sort_vector_copy (Lisp_Object, ptrdiff_t,
46static bool internal_equal (Lisp_Object, Lisp_Object, int, bool, Lisp_Object); 46static bool internal_equal (Lisp_Object, Lisp_Object, int, bool, Lisp_Object);
47 47
48DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0, 48DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
49 doc: /* Return the argument unchanged. */) 49 doc: /* Return the argument unchanged. */
50 attributes: const)
50 (Lisp_Object arg) 51 (Lisp_Object arg)
51{ 52{
52 return arg; 53 return arg;
diff --git a/src/frame.c b/src/frame.c
index 3d2ffbf624f..ec580f37c5b 100644
--- a/src/frame.c
+++ b/src/frame.c
@@ -67,6 +67,9 @@ static struct frame *last_nonminibuf_frame;
67/* False means there are no visible garbaged frames. */ 67/* False means there are no visible garbaged frames. */
68bool frame_garbaged; 68bool frame_garbaged;
69 69
70/* The default tool bar height for future frames. */
71int frame_default_tool_bar_height;
72
70#ifdef HAVE_WINDOW_SYSTEM 73#ifdef HAVE_WINDOW_SYSTEM
71static void x_report_frame_params (struct frame *, Lisp_Object *); 74static void x_report_frame_params (struct frame *, Lisp_Object *);
72#endif 75#endif
@@ -267,7 +270,8 @@ predicates which report frame's specific UI-related capabilities. */)
267/* Placeholder used by temacs -nw before window.el is loaded. */ 270/* Placeholder used by temacs -nw before window.el is loaded. */
268DEFUN ("frame-windows-min-size", Fframe_windows_min_size, 271DEFUN ("frame-windows-min-size", Fframe_windows_min_size,
269 Sframe_windows_min_size, 4, 4, 0, 272 Sframe_windows_min_size, 4, 4, 0,
270 doc: /* */) 273 doc: /* */
274 attributes: const)
271 (Lisp_Object frame, Lisp_Object horizontal, 275 (Lisp_Object frame, Lisp_Object horizontal,
272 Lisp_Object ignore, Lisp_Object pixelwise) 276 Lisp_Object ignore, Lisp_Object pixelwise)
273{ 277{
@@ -331,6 +335,8 @@ adjust_frame_size (struct frame *f, int new_width, int new_height, int inhibit,
331 int unit_height = FRAME_LINE_HEIGHT (f); 335 int unit_height = FRAME_LINE_HEIGHT (f);
332 int old_pixel_width = FRAME_PIXEL_WIDTH (f); 336 int old_pixel_width = FRAME_PIXEL_WIDTH (f);
333 int old_pixel_height = FRAME_PIXEL_HEIGHT (f); 337 int old_pixel_height = FRAME_PIXEL_HEIGHT (f);
338 int old_cols = FRAME_COLS (f);
339 int old_lines = FRAME_LINES (f);
334 int new_pixel_width, new_pixel_height; 340 int new_pixel_width, new_pixel_height;
335 /* The following two values are calculated from the old frame pixel 341 /* The following two values are calculated from the old frame pixel
336 sizes and any "new" settings for tool bar, menu bar and internal 342 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,
358 Lisp_Object frame; 364 Lisp_Object frame;
359 365
360 XSETFRAME (frame, f); 366 XSETFRAME (frame, f);
367
368 /* `make-frame' initializes Vframe_adjust_size_history to (Qt) and
369 strips its car when exiting. Just in case make sure its size never
370 exceeds 100. */
371 if (!NILP (Fconsp (Vframe_adjust_size_history))
372 && EQ (Fcar (Vframe_adjust_size_history), Qt)
373 && XFASTINT (Fsafe_length (Vframe_adjust_size_history)) <= 100)
374 Vframe_adjust_size_history =
375 Fcons (Qt, Fcons (list5 (make_number (0),
376 make_number (new_text_width),
377 make_number (new_text_height),
378 make_number (inhibit), parameter),
379 Fcdr (Vframe_adjust_size_history)));
380
361 /* The following two values are calculated from the old window body 381 /* The following two values are calculated from the old window body
362 sizes and any "new" settings for scroll bars, dividers, fringes and 382 sizes and any "new" settings for scroll bars, dividers, fringes and
363 margins (though the latter should have been processed already). */ 383 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,
425 else if (inhibit_vertical) 445 else if (inhibit_vertical)
426 new_text_height = old_text_height; 446 new_text_height = old_text_height;
427 447
448 if (!NILP (Fconsp (Vframe_adjust_size_history))
449 && EQ (Fcar (Vframe_adjust_size_history), Qt)
450 && XFASTINT (Fsafe_length (Vframe_adjust_size_history)) <= 100)
451 Vframe_adjust_size_history =
452 Fcons (Qt, Fcons (list5 (make_number (1),
453 make_number (new_text_width),
454 make_number (new_text_height),
455 make_number (new_cols),
456 make_number (new_lines)),
457 Fcdr (Vframe_adjust_size_history)));
458
428 x_set_window_size (f, 0, new_text_width, new_text_height, 1); 459 x_set_window_size (f, 0, new_text_width, new_text_height, 1);
429 f->resized_p = true; 460 f->resized_p = true;
430 461
@@ -437,7 +468,9 @@ adjust_frame_size (struct frame *f, int new_width, int new_height, int inhibit,
437 && new_windows_width == old_windows_width 468 && new_windows_width == old_windows_width
438 && new_windows_height == old_windows_height 469 && new_windows_height == old_windows_height
439 && new_pixel_width == old_pixel_width 470 && new_pixel_width == old_pixel_width
440 && new_pixel_height == old_pixel_height) 471 && new_pixel_height == old_pixel_height
472 && new_cols == old_cols
473 && new_lines == old_lines)
441 /* No change. Sanitize window sizes and return. */ 474 /* No change. Sanitize window sizes and return. */
442 { 475 {
443 sanitize_window_sizes (frame, Qt); 476 sanitize_window_sizes (frame, Qt);
@@ -496,6 +529,17 @@ adjust_frame_size (struct frame *f, int new_width, int new_height, int inhibit,
496 SET_FRAME_COLS (f, new_cols); 529 SET_FRAME_COLS (f, new_cols);
497 SET_FRAME_LINES (f, new_lines); 530 SET_FRAME_LINES (f, new_lines);
498 531
532 if (!NILP (Fconsp (Vframe_adjust_size_history))
533 && EQ (Fcar (Vframe_adjust_size_history), Qt)
534 && XFASTINT (Fsafe_length (Vframe_adjust_size_history)) <= 100)
535 Vframe_adjust_size_history =
536 Fcons (Qt, Fcons (list5 (make_number (2),
537 make_number (new_text_width),
538 make_number (new_text_height),
539 make_number (new_cols),
540 make_number (new_lines)),
541 Fcdr (Vframe_adjust_size_history)));
542
499 { 543 {
500 struct window *w = XWINDOW (FRAME_SELECTED_WINDOW (f)); 544 struct window *w = XWINDOW (FRAME_SELECTED_WINDOW (f));
501 int text_area_x, text_area_y, text_area_width, text_area_height; 545 int text_area_x, text_area_y, text_area_width, text_area_height;
@@ -554,6 +598,7 @@ make_frame (bool mini_p)
554 f->garbaged = true; 598 f->garbaged = true;
555 f->can_x_set_window_size = false; 599 f->can_x_set_window_size = false;
556 f->can_run_window_configuration_change_hook = false; 600 f->can_run_window_configuration_change_hook = false;
601 f->tool_bar_redisplayed_once = false;
557 f->column_width = 1; /* !FRAME_WINDOW_P value. */ 602 f->column_width = 1; /* !FRAME_WINDOW_P value. */
558 f->line_height = 1; /* !FRAME_WINDOW_P value. */ 603 f->line_height = 1; /* !FRAME_WINDOW_P value. */
559#ifdef HAVE_WINDOW_SYSTEM 604#ifdef HAVE_WINDOW_SYSTEM
@@ -2808,7 +2853,7 @@ DEFUN ("frame-bottom-divider-width", Fbottom_divider_width, Sbottom_divider_widt
2808} 2853}
2809 2854
2810DEFUN ("set-frame-height", Fset_frame_height, Sset_frame_height, 2, 4, 0, 2855DEFUN ("set-frame-height", Fset_frame_height, Sset_frame_height, 2, 4, 0,
2811 doc: /* Set height of frame FRAME to HEIGHT lines. 2856 doc: /* Set text height of frame FRAME to HEIGHT lines.
2812Optional third arg PRETEND non-nil means that redisplay should use 2857Optional third arg PRETEND non-nil means that redisplay should use
2813HEIGHT lines but that the idea of the actual height of the frame should 2858HEIGHT lines but that the idea of the actual height of the frame should
2814not be changed. 2859not be changed.
@@ -2827,14 +2872,13 @@ multiple of the default frame font height. */)
2827 pixel_height = (!NILP (pixelwise) 2872 pixel_height = (!NILP (pixelwise)
2828 ? XINT (height) 2873 ? XINT (height)
2829 : XINT (height) * FRAME_LINE_HEIGHT (f)); 2874 : XINT (height) * FRAME_LINE_HEIGHT (f));
2830 if (pixel_height != FRAME_TEXT_HEIGHT (f)) 2875 adjust_frame_size (f, -1, pixel_height, 1, !NILP (pretend), Qheight);
2831 adjust_frame_size (f, -1, pixel_height, 1, !NILP (pretend), Qheight);
2832 2876
2833 return Qnil; 2877 return Qnil;
2834} 2878}
2835 2879
2836DEFUN ("set-frame-width", Fset_frame_width, Sset_frame_width, 2, 4, 0, 2880DEFUN ("set-frame-width", Fset_frame_width, Sset_frame_width, 2, 4, 0,
2837 doc: /* Set width of frame FRAME to WIDTH columns. 2881 doc: /* Set text width of frame FRAME to WIDTH columns.
2838Optional third arg PRETEND non-nil means that redisplay should use WIDTH 2882Optional third arg PRETEND non-nil means that redisplay should use WIDTH
2839columns but that the idea of the actual width of the frame should not 2883columns but that the idea of the actual width of the frame should not
2840be changed. 2884be changed.
@@ -2853,14 +2897,13 @@ multiple of the default frame font width. */)
2853 pixel_width = (!NILP (pixelwise) 2897 pixel_width = (!NILP (pixelwise)
2854 ? XINT (width) 2898 ? XINT (width)
2855 : XINT (width) * FRAME_COLUMN_WIDTH (f)); 2899 : XINT (width) * FRAME_COLUMN_WIDTH (f));
2856 if (pixel_width != FRAME_TEXT_WIDTH (f)) 2900 adjust_frame_size (f, pixel_width, -1, 1, !NILP (pretend), Qwidth);
2857 adjust_frame_size (f, pixel_width, -1, 1, !NILP (pretend), Qwidth);
2858 2901
2859 return Qnil; 2902 return Qnil;
2860} 2903}
2861 2904
2862DEFUN ("set-frame-size", Fset_frame_size, Sset_frame_size, 3, 4, 0, 2905DEFUN ("set-frame-size", Fset_frame_size, Sset_frame_size, 3, 4, 0,
2863 doc: /* Set size of FRAME to WIDTH by HEIGHT, measured in characters. 2906 doc: /* Set text size of FRAME to WIDTH by HEIGHT, measured in characters.
2864Optional argument PIXELWISE non-nil means to measure in pixels. Note: 2907Optional argument PIXELWISE non-nil means to measure in pixels. Note:
2865When `frame-resize-pixelwise' is nil, some window managers may refuse to 2908When `frame-resize-pixelwise' is nil, some window managers may refuse to
2866honor a WIDTH that is not an integer multiple of the default frame font 2909honor a WIDTH that is not an integer multiple of the default frame font
@@ -2880,10 +2923,7 @@ font height. */)
2880 pixel_height = (!NILP (pixelwise) 2923 pixel_height = (!NILP (pixelwise)
2881 ? XINT (height) 2924 ? XINT (height)
2882 : XINT (height) * FRAME_LINE_HEIGHT (f)); 2925 : XINT (height) * FRAME_LINE_HEIGHT (f));
2883 2926 adjust_frame_size (f, pixel_width, pixel_height, 1, 0, Qsize);
2884 if (pixel_width != FRAME_TEXT_WIDTH (f)
2885 || pixel_height != FRAME_TEXT_HEIGHT (f))
2886 adjust_frame_size (f, pixel_width, pixel_height, 1, 0, Qsize);
2887 2927
2888 return Qnil; 2928 return Qnil;
2889} 2929}
@@ -4492,23 +4532,27 @@ x_figure_window_size (struct frame *f, Lisp_Object parms, bool toolbar_p)
4492 frames without having to guess how tall the tool bar will get. */ 4532 frames without having to guess how tall the tool bar will get. */
4493 if (toolbar_p && FRAME_TOOL_BAR_LINES (f)) 4533 if (toolbar_p && FRAME_TOOL_BAR_LINES (f))
4494 { 4534 {
4495 int margin, relief; 4535 if (frame_default_tool_bar_height)
4536 FRAME_TOOL_BAR_HEIGHT (f) = frame_default_tool_bar_height;
4537 else
4538 {
4539 int margin, relief;
4496 4540
4497 relief = (tool_bar_button_relief >= 0 4541 relief = (tool_bar_button_relief >= 0
4498 ? tool_bar_button_relief 4542 ? tool_bar_button_relief
4499 : DEFAULT_TOOL_BAR_BUTTON_RELIEF); 4543 : DEFAULT_TOOL_BAR_BUTTON_RELIEF);
4500 4544
4501 if (RANGED_INTEGERP (1, Vtool_bar_button_margin, INT_MAX)) 4545 if (RANGED_INTEGERP (1, Vtool_bar_button_margin, INT_MAX))
4502 margin = XFASTINT (Vtool_bar_button_margin); 4546 margin = XFASTINT (Vtool_bar_button_margin);
4503 else if (CONSP (Vtool_bar_button_margin) 4547 else if (CONSP (Vtool_bar_button_margin)
4504 && RANGED_INTEGERP (1, XCDR (Vtool_bar_button_margin), INT_MAX)) 4548 && RANGED_INTEGERP (1, XCDR (Vtool_bar_button_margin), INT_MAX))
4505 margin = XFASTINT (XCDR (Vtool_bar_button_margin)); 4549 margin = XFASTINT (XCDR (Vtool_bar_button_margin));
4506 else 4550 else
4507 margin = 0; 4551 margin = 0;
4508 4552
4509 FRAME_TOOL_BAR_HEIGHT (f) 4553 FRAME_TOOL_BAR_HEIGHT (f)
4510 = DEFAULT_TOOL_BAR_IMAGE_HEIGHT + 2 * margin + 2 * relief; 4554 = DEFAULT_TOOL_BAR_IMAGE_HEIGHT + 2 * margin + 2 * relief;
4511 Vframe_initial_frame_tool_bar_height = make_number (FRAME_TOOL_BAR_HEIGHT (f)); 4555 }
4512 } 4556 }
4513 4557
4514 top = x_get_arg (dpyinfo, parms, Qtop, 0, 0, RES_TYPE_NUMBER); 4558 top = x_get_arg (dpyinfo, parms, Qtop, 0, 0, RES_TYPE_NUMBER);
@@ -4779,6 +4823,11 @@ syms_of_frame (void)
4779 DEFSYM (Qtool_bar_external, "tool-bar-external"); 4823 DEFSYM (Qtool_bar_external, "tool-bar-external");
4780 DEFSYM (Qtool_bar_size, "tool-bar-size"); 4824 DEFSYM (Qtool_bar_size, "tool-bar-size");
4781 DEFSYM (Qframe_inner_size, "frame-inner-size"); 4825 DEFSYM (Qframe_inner_size, "frame-inner-size");
4826 DEFSYM (Qchange_frame_size, "change-frame-size");
4827 DEFSYM (Qxg_frame_set_char_size, "xg-frame-set-char-size");
4828 DEFSYM (Qset_window_configuration, "set-window-configuration");
4829 DEFSYM (Qx_create_frame_1, "x-create-frame-1");
4830 DEFSYM (Qx_create_frame_2, "x-create-frame-2");
4782 4831
4783#ifdef HAVE_NS 4832#ifdef HAVE_NS
4784 DEFSYM (Qns_parse_geometry, "ns-parse-geometry"); 4833 DEFSYM (Qns_parse_geometry, "ns-parse-geometry");
@@ -4968,10 +5017,6 @@ or call the function `tool-bar-mode'. */);
4968 Vtool_bar_mode = Qnil; 5017 Vtool_bar_mode = Qnil;
4969#endif 5018#endif
4970 5019
4971 DEFVAR_LISP ("frame-initial-frame-tool-bar-height", Vframe_initial_frame_tool_bar_height,
4972 doc: /* Height of tool bar of initial frame. */);
4973 Vframe_initial_frame_tool_bar_height = make_number (0);
4974
4975 DEFVAR_KBOARD ("default-minibuffer-frame", Vdefault_minibuffer_frame, 5020 DEFVAR_KBOARD ("default-minibuffer-frame", Vdefault_minibuffer_frame,
4976 doc: /* Minibufferless frames use this frame's minibuffer. 5021 doc: /* Minibufferless frames use this frame's minibuffer.
4977Emacs cannot create minibufferless frames unless this is set to an 5022Emacs cannot create minibufferless frames unless this is set to an
@@ -5050,6 +5095,10 @@ even if this option is non-nil. */);
5050 frame_inhibit_implied_resize = Qt; 5095 frame_inhibit_implied_resize = Qt;
5051#endif 5096#endif
5052 5097
5098 DEFVAR_LISP ("frame-adjust-size-history", Vframe_adjust_size_history,
5099 doc: /* History of frame size adjustments. */);
5100 Vframe_adjust_size_history = Qnil;
5101
5053 staticpro (&Vframe_list); 5102 staticpro (&Vframe_list);
5054 5103
5055 defsubr (&Sframep); 5104 defsubr (&Sframep);
diff --git a/src/frame.h b/src/frame.h
index d1ed4d4a67e..cb0044cfe23 100644
--- a/src/frame.h
+++ b/src/frame.h
@@ -336,6 +336,10 @@ struct frame
336 for this frame. */ 336 for this frame. */
337 bool_bf can_run_window_configuration_change_hook : 1; 337 bool_bf can_run_window_configuration_change_hook : 1;
338 338
339 /* True means tool bar has been redisplayed at least once in current
340 session. */
341 bool_bf tool_bar_redisplayed_once : 1;
342
339 /* Bitfield area ends here. */ 343 /* Bitfield area ends here. */
340 344
341 /* Number of lines (rounded up) of tool bar. REMOVE THIS */ 345 /* Number of lines (rounded up) of tool bar. REMOVE THIS */
@@ -1096,6 +1100,8 @@ SET_FRAME_VISIBLE (struct frame *f, int v)
1096 1100
1097extern Lisp_Object selected_frame; 1101extern Lisp_Object selected_frame;
1098 1102
1103extern int frame_default_tool_bar_height;
1104
1099extern struct frame *decode_window_system_frame (Lisp_Object); 1105extern struct frame *decode_window_system_frame (Lisp_Object);
1100extern struct frame *decode_live_frame (Lisp_Object); 1106extern struct frame *decode_live_frame (Lisp_Object);
1101extern struct frame *decode_any_frame (Lisp_Object); 1107extern struct frame *decode_any_frame (Lisp_Object);
diff --git a/src/gnutls.c b/src/gnutls.c
index 75fe6149a55..5e6c6353b45 100644
--- a/src/gnutls.c
+++ b/src/gnutls.c
@@ -695,7 +695,8 @@ See also `gnutls-boot'. */)
695DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0, 695DEFUN ("gnutls-errorp", Fgnutls_errorp, Sgnutls_errorp, 1, 1, 0,
696 doc: /* Return t if ERROR indicates a GnuTLS problem. 696 doc: /* Return t if ERROR indicates a GnuTLS problem.
697ERROR is an integer or a symbol with an integer `gnutls-code' property. 697ERROR is an integer or a symbol with an integer `gnutls-code' property.
698usage: (gnutls-errorp ERROR) */) 698usage: (gnutls-errorp ERROR) */
699 attributes: const)
699 (Lisp_Object err) 700 (Lisp_Object err)
700{ 701{
701 if (EQ (err, Qt)) return Qnil; 702 if (EQ (err, Qt)) return Qnil;
@@ -1603,7 +1604,8 @@ This function may also return `gnutls-e-again', or
1603#endif /* HAVE_GNUTLS */ 1604#endif /* HAVE_GNUTLS */
1604 1605
1605DEFUN ("gnutls-available-p", Fgnutls_available_p, Sgnutls_available_p, 0, 0, 0, 1606DEFUN ("gnutls-available-p", Fgnutls_available_p, Sgnutls_available_p, 0, 0, 0,
1606 doc: /* Return t if GnuTLS is available in this instance of Emacs. */) 1607 doc: /* Return t if GnuTLS is available in this instance of Emacs. */
1608 attributes: const)
1607 (void) 1609 (void)
1608{ 1610{
1609#ifdef HAVE_GNUTLS 1611#ifdef HAVE_GNUTLS
diff --git a/src/gtkutil.c b/src/gtkutil.c
index bedac8451e2..694278a2b4c 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)
954 x_wait_for_event (f, ConfigureNotify); 954 x_wait_for_event (f, ConfigureNotify);
955 } 955 }
956 else 956 else
957 adjust_frame_size (f, -1, -1, 5, 0, Qnil); 957 adjust_frame_size (f, -1, -1, 5, 0, Qxg_frame_set_char_size);
958} 958}
959 959
960/* Handle height/width changes (i.e. add/remove/move menu/toolbar). 960/* Handle height/width changes (i.e. add/remove/move menu/toolbar).
diff --git a/src/image.c b/src/image.c
index 5d08a890234..9c09c5596b9 100644
--- a/src/image.c
+++ b/src/image.c
@@ -9288,7 +9288,8 @@ DEFUN ("imagep", Fimagep, Simagep, 1, 1, 0,
9288} 9288}
9289 9289
9290 9290
9291DEFUN ("lookup-image", Flookup_image, Slookup_image, 1, 1, 0, "") 9291DEFUN ("lookup-image", Flookup_image, Slookup_image, 1, 1, 0,
9292 doc: /* */)
9292 (Lisp_Object spec) 9293 (Lisp_Object spec)
9293{ 9294{
9294 ptrdiff_t id = -1; 9295 ptrdiff_t id = -1;
diff --git a/src/keyboard.c b/src/keyboard.c
index 6afbd5d5fb8..dbae12b79f1 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -1163,7 +1163,8 @@ top_level_1 (Lisp_Object ignore)
1163 1163
1164DEFUN ("top-level", Ftop_level, Stop_level, 0, 0, "", 1164DEFUN ("top-level", Ftop_level, Stop_level, 0, 0, "",
1165 doc: /* Exit all recursive editing levels. 1165 doc: /* Exit all recursive editing levels.
1166This also exits all active minibuffers. */) 1166This also exits all active minibuffers. */
1167 attributes: noreturn)
1167 (void) 1168 (void)
1168{ 1169{
1169#ifdef HAVE_WINDOW_SYSTEM 1170#ifdef HAVE_WINDOW_SYSTEM
@@ -1186,7 +1187,8 @@ user_error (const char *msg)
1186 1187
1187/* _Noreturn will be added to prototype by make-docfile. */ 1188/* _Noreturn will be added to prototype by make-docfile. */
1188DEFUN ("exit-recursive-edit", Fexit_recursive_edit, Sexit_recursive_edit, 0, 0, "", 1189DEFUN ("exit-recursive-edit", Fexit_recursive_edit, Sexit_recursive_edit, 0, 0, "",
1189 doc: /* Exit from the innermost recursive edit or minibuffer. */) 1190 doc: /* Exit from the innermost recursive edit or minibuffer. */
1191 attributes: noreturn)
1190 (void) 1192 (void)
1191{ 1193{
1192 if (command_loop_level > 0 || minibuf_level > 0) 1194 if (command_loop_level > 0 || minibuf_level > 0)
@@ -1197,7 +1199,8 @@ DEFUN ("exit-recursive-edit", Fexit_recursive_edit, Sexit_recursive_edit, 0, 0,
1197 1199
1198/* _Noreturn will be added to prototype by make-docfile. */ 1200/* _Noreturn will be added to prototype by make-docfile. */
1199DEFUN ("abort-recursive-edit", Fabort_recursive_edit, Sabort_recursive_edit, 0, 0, "", 1201DEFUN ("abort-recursive-edit", Fabort_recursive_edit, Sabort_recursive_edit, 0, 0, "",
1200 doc: /* Abort the command that requested this recursive edit or minibuffer input. */) 1202 doc: /* Abort the command that requested this recursive edit or minibuffer input. */
1203 attributes: noreturn)
1201 (void) 1204 (void)
1202{ 1205{
1203 if (command_loop_level > 0 || minibuf_level > 0) 1206 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_
6293 if (modifiers & meta_modifier) { *p++ = 'M'; *p++ = '-'; } 6296 if (modifiers & meta_modifier) { *p++ = 'M'; *p++ = '-'; }
6294 if (modifiers & shift_modifier) { *p++ = 'S'; *p++ = '-'; } 6297 if (modifiers & shift_modifier) { *p++ = 'S'; *p++ = '-'; }
6295 if (modifiers & super_modifier) { *p++ = 's'; *p++ = '-'; } 6298 if (modifiers & super_modifier) { *p++ = 's'; *p++ = '-'; }
6296 if (modifiers & double_modifier) { strcpy (p, "double-"); p += 7; } 6299 if (modifiers & double_modifier) p = stpcpy (p, "double-");
6297 if (modifiers & triple_modifier) { strcpy (p, "triple-"); p += 7; } 6300 if (modifiers & triple_modifier) p = stpcpy (p, "triple-");
6298 if (modifiers & down_modifier) { strcpy (p, "down-"); p += 5; } 6301 if (modifiers & down_modifier) p = stpcpy (p, "down-");
6299 if (modifiers & drag_modifier) { strcpy (p, "drag-"); p += 5; } 6302 if (modifiers & drag_modifier) p = stpcpy (p, "drag-");
6300 /* The click modifier is denoted by the absence of other modifiers. */ 6303 /* The click modifier is denoted by the absence of other modifiers. */
6301 6304
6302 *p = '\0'; 6305 *p = '\0';
diff --git a/src/lisp.h b/src/lisp.h
index 9e1f1501464..b6608daa20e 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -610,7 +610,6 @@ INLINE bool (VECTORLIKEP) (Lisp_Object);
610INLINE bool WINDOWP (Lisp_Object); 610INLINE bool WINDOWP (Lisp_Object);
611INLINE struct Lisp_Save_Value *XSAVE_VALUE (Lisp_Object); 611INLINE struct Lisp_Save_Value *XSAVE_VALUE (Lisp_Object);
612INLINE struct Lisp_Symbol *(XSYMBOL) (Lisp_Object); 612INLINE struct Lisp_Symbol *(XSYMBOL) (Lisp_Object);
613INLINE enum Lisp_Type (XTYPE) (Lisp_Object);
614INLINE void *(XUNTAG) (Lisp_Object, int); 613INLINE void *(XUNTAG) (Lisp_Object, int);
615 614
616/* Defined in chartab.c. */ 615/* Defined in chartab.c. */
@@ -825,9 +824,6 @@ DEFINE_GDB_SYMBOL_END (VALMASK)
825#define MOST_POSITIVE_FIXNUM (EMACS_INT_MAX >> INTTYPEBITS) 824#define MOST_POSITIVE_FIXNUM (EMACS_INT_MAX >> INTTYPEBITS)
826#define MOST_NEGATIVE_FIXNUM (-1 - MOST_POSITIVE_FIXNUM) 825#define MOST_NEGATIVE_FIXNUM (-1 - MOST_POSITIVE_FIXNUM)
827 826
828/* Extract the pointer hidden within A. */
829LISP_MACRO_DEFUN (XPNTR, void *, (Lisp_Object a), (a))
830
831#if USE_LSB_TAG 827#if USE_LSB_TAG
832 828
833LISP_MACRO_DEFUN (make_number, Lisp_Object, (EMACS_INT n), (n)) 829LISP_MACRO_DEFUN (make_number, Lisp_Object, (EMACS_INT n), (n))
@@ -917,6 +913,9 @@ XUNTAG (Lisp_Object a, int type)
917 913
918#endif /* ! USE_LSB_TAG */ 914#endif /* ! USE_LSB_TAG */
919 915
916/* Extract the pointer hidden within A. */
917LISP_MACRO_DEFUN (XPNTR, void *, (Lisp_Object a), (a))
918
920/* Extract A's value as an unsigned integer. */ 919/* Extract A's value as an unsigned integer. */
921INLINE EMACS_UINT 920INLINE EMACS_UINT
922XUINT (Lisp_Object a) 921XUINT (Lisp_Object a)
@@ -1694,10 +1693,9 @@ CHAR_TABLE_EXTRA_SLOTS (struct Lisp_Char_Table *ct)
1694 - CHAR_TABLE_STANDARD_SLOTS); 1693 - CHAR_TABLE_STANDARD_SLOTS);
1695} 1694}
1696 1695
1697/* Make sure that sub char-table contents slot 1696/* Make sure that sub char-table contents slot is where we think it is. */
1698 is aligned on a multiple of Lisp_Objects. */ 1697verify (offsetof (struct Lisp_Sub_Char_Table, contents)
1699verify ((offsetof (struct Lisp_Sub_Char_Table, contents) 1698 == offsetof (struct Lisp_Vector, contents[SUB_CHAR_TABLE_OFFSET]));
1700 - offsetof (struct Lisp_Sub_Char_Table, depth)) % word_size == 0);
1701 1699
1702/*********************************************************************** 1700/***********************************************************************
1703 Symbols 1701 Symbols
@@ -4060,10 +4058,23 @@ struct re_registers;
4060extern struct re_pattern_buffer *compile_pattern (Lisp_Object, 4058extern struct re_pattern_buffer *compile_pattern (Lisp_Object,
4061 struct re_registers *, 4059 struct re_registers *,
4062 Lisp_Object, bool, bool); 4060 Lisp_Object, bool, bool);
4063extern ptrdiff_t fast_string_match (Lisp_Object, Lisp_Object); 4061extern ptrdiff_t fast_string_match_internal (Lisp_Object, Lisp_Object,
4062 Lisp_Object);
4063
4064INLINE ptrdiff_t
4065fast_string_match (Lisp_Object regexp, Lisp_Object string)
4066{
4067 return fast_string_match_internal (regexp, string, Qnil);
4068}
4069
4070INLINE ptrdiff_t
4071fast_string_match_ignore_case (Lisp_Object regexp, Lisp_Object string)
4072{
4073 return fast_string_match_internal (regexp, string, Vascii_canon_table);
4074}
4075
4064extern ptrdiff_t fast_c_string_match_ignore_case (Lisp_Object, const char *, 4076extern ptrdiff_t fast_c_string_match_ignore_case (Lisp_Object, const char *,
4065 ptrdiff_t); 4077 ptrdiff_t);
4066extern ptrdiff_t fast_string_match_ignore_case (Lisp_Object, Lisp_Object);
4067extern ptrdiff_t fast_looking_at (Lisp_Object, ptrdiff_t, ptrdiff_t, 4078extern ptrdiff_t fast_looking_at (Lisp_Object, ptrdiff_t, ptrdiff_t,
4068 ptrdiff_t, ptrdiff_t, Lisp_Object); 4079 ptrdiff_t, ptrdiff_t, Lisp_Object);
4069extern ptrdiff_t find_newline (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, 4080extern ptrdiff_t find_newline (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t,
diff --git a/src/nsfns.m b/src/nsfns.m
index 828ee88e635..cc2e49641e8 100644
--- a/src/nsfns.m
+++ b/src/nsfns.m
@@ -1251,7 +1251,8 @@ This function is an internal primitive--use `make-frame' instead. */)
1251 1251
1252 /* Read comment about this code in corresponding place in xfns.c. */ 1252 /* Read comment about this code in corresponding place in xfns.c. */
1253 adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f), 1253 adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f),
1254 FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, 1, Qnil); 1254 FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, 1,
1255 Qx_create_frame_1);
1255 1256
1256 /* The resources controlling the menu-bar and tool-bar are 1257 /* The resources controlling the menu-bar and tool-bar are
1257 processed specially at startup, and reflected in the mode 1258 processed specially at startup, and reflected in the mode
@@ -1325,7 +1326,8 @@ This function is an internal primitive--use `make-frame' instead. */)
1325 /* Allow x_set_window_size, now. */ 1326 /* Allow x_set_window_size, now. */
1326 f->can_x_set_window_size = true; 1327 f->can_x_set_window_size = true;
1327 1328
1328 adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), 0, 1, Qnil); 1329 adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), 0, 1,
1330 Qx_create_frame_2);
1329 1331
1330 if (! f->output_data.ns->explicit_parent) 1332 if (! f->output_data.ns->explicit_parent)
1331 { 1333 {
diff --git a/src/process.c b/src/process.c
index 9015383b8b5..77c94f29211 100644
--- a/src/process.c
+++ b/src/process.c
@@ -1517,11 +1517,8 @@ usage: (start-process NAME BUFFER PROGRAM &rest PROGRAM-ARGS) */)
1517 tem = program; 1517 tem = program;
1518 } 1518 }
1519 1519
1520 /* If program file name starts with /: for quoting a magic name, 1520 /* Remove "/:" from TEM. */
1521 discard that. */ 1521 tem = remove_slash_colon (tem);
1522 if (SBYTES (tem) > 2 && SREF (tem, 0) == '/'
1523 && SREF (tem, 1) == ':')
1524 tem = Fsubstring (tem, make_number (2), Qnil);
1525 1522
1526 { 1523 {
1527 Lisp_Object arg_encoding = Qnil; 1524 Lisp_Object arg_encoding = Qnil;
@@ -3830,6 +3827,18 @@ Data that is unavailable is returned as nil. */)
3830#endif 3827#endif
3831} 3828}
3832 3829
3830/* If program file NAME starts with /: for quoting a magic
3831 name, remove that, preserving the multibyteness of NAME. */
3832
3833Lisp_Object
3834remove_slash_colon (Lisp_Object name)
3835{
3836 return
3837 ((SBYTES (name) > 2 && SREF (name, 0) == '/' && SREF (name, 1) == ':')
3838 ? make_specified_string (SSDATA (name) + 2, SCHARS (name) - 2,
3839 SBYTES (name) - 2, STRING_MULTIBYTE (name))
3840 : name);
3841}
3833 3842
3834/* Turn off input and output for process PROC. */ 3843/* Turn off input and output for process PROC. */
3835 3844
diff --git a/src/process.h b/src/process.h
index 7803672d61a..36979dcac9e 100644
--- a/src/process.h
+++ b/src/process.h
@@ -237,4 +237,6 @@ extern Lisp_Object network_interface_list (void);
237extern Lisp_Object network_interface_info (Lisp_Object); 237extern Lisp_Object network_interface_info (Lisp_Object);
238#endif 238#endif
239 239
240extern Lisp_Object remove_slash_colon (Lisp_Object);
241
240INLINE_HEADER_END 242INLINE_HEADER_END
diff --git a/src/search.c b/src/search.c
index 0252542a361..e9617985c18 100644
--- a/src/search.c
+++ b/src/search.c
@@ -459,17 +459,18 @@ matched by parenthesis constructs in the pattern. */)
459 return string_match_1 (regexp, string, start, 1); 459 return string_match_1 (regexp, string, start, 1);
460} 460}
461 461
462/* Match REGEXP against STRING, searching all of STRING, 462/* Match REGEXP against STRING using translation table TABLE,
463 and return the index of the match, or negative on failure. 463 searching all of STRING, and return the index of the match,
464 This does not clobber the match data. */ 464 or negative on failure. This does not clobber the match data. */
465 465
466ptrdiff_t 466ptrdiff_t
467fast_string_match (Lisp_Object regexp, Lisp_Object string) 467fast_string_match_internal (Lisp_Object regexp, Lisp_Object string,
468 Lisp_Object table)
468{ 469{
469 ptrdiff_t val; 470 ptrdiff_t val;
470 struct re_pattern_buffer *bufp; 471 struct re_pattern_buffer *bufp;
471 472
472 bufp = compile_pattern (regexp, 0, Qnil, 473 bufp = compile_pattern (regexp, 0, table,
473 0, STRING_MULTIBYTE (string)); 474 0, STRING_MULTIBYTE (string));
474 immediate_quit = 1; 475 immediate_quit = 1;
475 re_match_object = string; 476 re_match_object = string;
@@ -504,26 +505,6 @@ fast_c_string_match_ignore_case (Lisp_Object regexp,
504 return val; 505 return val;
505} 506}
506 507
507/* Like fast_string_match but ignore case. */
508
509ptrdiff_t
510fast_string_match_ignore_case (Lisp_Object regexp, Lisp_Object string)
511{
512 ptrdiff_t val;
513 struct re_pattern_buffer *bufp;
514
515 bufp = compile_pattern (regexp, 0, Vascii_canon_table,
516 0, STRING_MULTIBYTE (string));
517 immediate_quit = 1;
518 re_match_object = string;
519
520 val = re_search (bufp, SSDATA (string),
521 SBYTES (string), 0,
522 SBYTES (string), 0);
523 immediate_quit = 0;
524 return val;
525}
526
527/* Match REGEXP against the characters after POS to LIMIT, and return 508/* Match REGEXP against the characters after POS to LIMIT, and return
528 the number of matched characters. If STRING is non-nil, match 509 the number of matched characters. If STRING is non-nil, match
529 against the characters in it. In that case, POS and LIMIT are 510 against the characters in it. In that case, POS and LIMIT are
diff --git a/src/w32fns.c b/src/w32fns.c
index 789a91a3c96..2dd92ff8a3a 100644
--- a/src/w32fns.c
+++ b/src/w32fns.c
@@ -1744,8 +1744,11 @@ x_change_tool_bar_height (struct frame *f, int height)
1744 /* Recalculate toolbar height. */ 1744 /* Recalculate toolbar height. */
1745 f->n_tool_bar_rows = 0; 1745 f->n_tool_bar_rows = 0;
1746 1746
1747 adjust_frame_size (f, -1, -1, (old_height == 0 || height == 0) ? 2 : 4, 0, 1747 adjust_frame_size (f, -1, -1,
1748 Qtool_bar_lines); 1748 (!f->tool_bar_redisplayed_once ? 1
1749 : (old_height == 0 || height == 0) ? 2
1750 : 4),
1751 0, Qtool_bar_lines);
1749 1752
1750 /* adjust_frame_size might not have done anything, garbage frame 1753 /* adjust_frame_size might not have done anything, garbage frame
1751 here. */ 1754 here. */
@@ -2540,7 +2543,7 @@ w32_msg_pump (deferred_msg * msg_buf)
2540 thread-safe. The next line is okay because the cons 2543 thread-safe. The next line is okay because the cons
2541 cell is never made into garbage and is not relocated by 2544 cell is never made into garbage and is not relocated by
2542 GC. */ 2545 GC. */
2543 XSETCAR (XIL ((EMACS_INT) msg.lParam), Qnil); 2546 XSETCAR (make_lisp_ptr ((void *)msg.lParam, Lisp_Cons), Qnil);
2544 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, 0, 0)) 2547 if (!PostThreadMessage (dwMainThreadId, WM_EMACS_DONE, 0, 0))
2545 emacs_abort (); 2548 emacs_abort ();
2546 break; 2549 break;
@@ -2548,16 +2551,10 @@ w32_msg_pump (deferred_msg * msg_buf)
2548 { 2551 {
2549 int vk_code = (int) msg.wParam; 2552 int vk_code = (int) msg.wParam;
2550 int cur_state = (GetKeyState (vk_code) & 1); 2553 int cur_state = (GetKeyState (vk_code) & 1);
2551 Lisp_Object new_state = XIL ((EMACS_INT) msg.lParam); 2554 int new_state = msg.lParam;
2552 2555
2553 /* NB: This code must be thread-safe. It is safe to 2556 if (new_state == -1
2554 call NILP because symbols are not relocated by GC, 2557 || ((new_state & 1) != cur_state))
2555 and pointer here is not touched by GC (so the markbit
2556 can't be set). Numbers are safe because they are
2557 immediate values. */
2558 if (NILP (new_state)
2559 || (NUMBERP (new_state)
2560 && ((XUINT (new_state)) & 1) != cur_state))
2561 { 2558 {
2562 one_w32_display_info.faked_key = vk_code; 2559 one_w32_display_info.faked_key = vk_code;
2563 2560
@@ -4520,7 +4517,9 @@ This function is an internal primitive--use `make-frame' instead. */)
4520 /* Specify the parent under which to make this window. */ 4517 /* Specify the parent under which to make this window. */
4521 if (!NILP (parent)) 4518 if (!NILP (parent))
4522 { 4519 {
4523 f->output_data.w32->parent_desc = (Window) XFASTINT (parent); 4520 /* Cast to UINT_PTR shuts up compiler warnings about cast to
4521 pointer from integer of different size. */
4522 f->output_data.w32->parent_desc = (Window) (UINT_PTR) XFASTINT (parent);
4524 f->output_data.w32->explicit_parent = 1; 4523 f->output_data.w32->explicit_parent = 1;
4525 } 4524 }
4526 else 4525 else
@@ -4617,7 +4616,8 @@ This function is an internal primitive--use `make-frame' instead. */)
4617 had one frame line vs one toolbar line which left us with a zero 4616 had one frame line vs one toolbar line which left us with a zero
4618 root window height which was obviously wrong as well ... */ 4617 root window height which was obviously wrong as well ... */
4619 adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f), 4618 adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f),
4620 FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, 1, Qnil); 4619 FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, 1,
4620 Qx_create_frame_1);
4621 4621
4622 /* The X resources controlling the menu-bar and tool-bar are 4622 /* The X resources controlling the menu-bar and tool-bar are
4623 processed specially at startup, and reflected in the mode 4623 processed specially at startup, and reflected in the mode
@@ -4685,7 +4685,8 @@ This function is an internal primitive--use `make-frame' instead. */)
4685 /* Allow x_set_window_size, now. */ 4685 /* Allow x_set_window_size, now. */
4686 f->can_x_set_window_size = true; 4686 f->can_x_set_window_size = true;
4687 4687
4688 adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), 0, 1, Qnil); 4688 adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), 0, 1,
4689 Qx_create_frame_2);
4689 4690
4690 /* Tell the server what size and position, etc, we want, and how 4691 /* Tell the server what size and position, etc, we want, and how
4691 badly we want them. This should be done after we have the menu 4692 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,
7255 7256
7256 if (!NILP (item)) 7257 if (!NILP (item))
7257 { 7258 {
7259 LPARAM lparam;
7260
7261 eassert (CONSP (item));
7262 /* Pass the tail of the list as a pointer to a Lisp_Cons cell,
7263 so that it works in a --with-wide-int build as well. */
7264 lparam = (LPARAM) XUNTAG (item, Lisp_Cons);
7265
7258 /* Notify input thread about hot-key definition being removed, so 7266 /* Notify input thread about hot-key definition being removed, so
7259 that it takes effect without needing focus switch. */ 7267 that it takes effect without needing focus switch. */
7260 if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_UNREGISTER_HOT_KEY, 7268 if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_UNREGISTER_HOT_KEY,
7261 (WPARAM) XINT (XCAR (item)), (LPARAM) XLI (item))) 7269 (WPARAM) XINT (XCAR (item)), lparam))
7262 { 7270 {
7263 MSG msg; 7271 MSG msg;
7264 GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE); 7272 GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
@@ -7313,10 +7321,15 @@ DEFUN ("w32-toggle-lock-key", Fw32_toggle_lock_key,
7313 doc: /* Toggle the state of the lock key KEY. 7321 doc: /* Toggle the state of the lock key KEY.
7314KEY can be `capslock', `kp-numlock', or `scroll'. 7322KEY can be `capslock', `kp-numlock', or `scroll'.
7315If the optional parameter NEW-STATE is a number, then the state of KEY 7323If the optional parameter NEW-STATE is a number, then the state of KEY
7316is set to off if the low bit of NEW-STATE is zero, otherwise on. */) 7324is set to off if the low bit of NEW-STATE is zero, otherwise on.
7325If NEW-STATE is omitted or nil, the function toggles the state,
7326
7327Value is the new state of the key, or nil if the function failed
7328to change the state. */)
7317 (Lisp_Object key, Lisp_Object new_state) 7329 (Lisp_Object key, Lisp_Object new_state)
7318{ 7330{
7319 int vk_code; 7331 int vk_code;
7332 LPARAM lparam;
7320 7333
7321 if (EQ (key, intern ("capslock"))) 7334 if (EQ (key, intern ("capslock")))
7322 vk_code = VK_CAPITAL; 7335 vk_code = VK_CAPITAL;
@@ -7330,8 +7343,12 @@ is set to off if the low bit of NEW-STATE is zero, otherwise on. */)
7330 if (!dwWindowsThreadId) 7343 if (!dwWindowsThreadId)
7331 return make_number (w32_console_toggle_lock_key (vk_code, new_state)); 7344 return make_number (w32_console_toggle_lock_key (vk_code, new_state));
7332 7345
7346 if (NILP (new_state))
7347 lparam = -1;
7348 else
7349 lparam = (XUINT (new_state)) & 1;
7333 if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_TOGGLE_LOCK_KEY, 7350 if (PostThreadMessage (dwWindowsThreadId, WM_EMACS_TOGGLE_LOCK_KEY,
7334 (WPARAM) vk_code, (LPARAM) XLI (new_state))) 7351 (WPARAM) vk_code, lparam))
7335 { 7352 {
7336 MSG msg; 7353 MSG msg;
7337 GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE); 7354 GetMessage (&msg, NULL, WM_EMACS_DONE, WM_EMACS_DONE);
diff --git a/src/w32heap.c b/src/w32heap.c
index f68332319c1..d5a9dae0aa4 100644
--- a/src/w32heap.c
+++ b/src/w32heap.c
@@ -114,7 +114,7 @@ typedef struct _RTL_HEAP_PARAMETERS {
114 than half of the size stated below. It would be nice to find a way 114 than half of the size stated below. It would be nice to find a way
115 to build only the first bootstrap-emacs.exe with the large size, 115 to build only the first bootstrap-emacs.exe with the large size,
116 and reset that to a lower value afterwards. */ 116 and reset that to a lower value afterwards. */
117#ifdef _WIN64 117#if defined _WIN64 || defined WIDE_EMACS_INT
118# define DUMPED_HEAP_SIZE (18*1024*1024) 118# define DUMPED_HEAP_SIZE (18*1024*1024)
119#else 119#else
120# define DUMPED_HEAP_SIZE (11*1024*1024) 120# define DUMPED_HEAP_SIZE (11*1024*1024)
diff --git a/src/w32menu.c b/src/w32menu.c
index 7a946d2dc75..2a1dafbd6d7 100644
--- a/src/w32menu.c
+++ b/src/w32menu.c
@@ -217,9 +217,9 @@ menubar_selection_callback (struct frame *f, void * client_data)
217 else 217 else
218 { 218 {
219 entry = AREF (vector, i + MENU_ITEMS_ITEM_VALUE); 219 entry = AREF (vector, i + MENU_ITEMS_ITEM_VALUE);
220 /* The EMACS_INT cast avoids a warning. There's no problem 220 /* The UINT_PTR cast avoids a warning. There's no problem
221 as long as pointers have enough bits to hold small integers. */ 221 as long as pointers have enough bits to hold small integers. */
222 if ((int) (EMACS_INT) client_data == i) 222 if ((int) (UINT_PTR) client_data == i)
223 { 223 {
224 int j; 224 int j;
225 struct input_event buf; 225 struct input_event buf;
@@ -501,8 +501,7 @@ set_frame_menubar (struct frame *f, bool first_time, bool deep_p)
501 /* Force the window size to be recomputed so that the frame's text 501 /* Force the window size to be recomputed so that the frame's text
502 area remains the same, if menubar has just been created. */ 502 area remains the same, if menubar has just been created. */
503 if (old_widget == NULL) 503 if (old_widget == NULL)
504 adjust_frame_size (f, FRAME_TEXT_WIDTH (f), 504 adjust_frame_size (f, -1, -1, 2, 0, Qmenu_bar_lines);
505 FRAME_TEXT_HEIGHT (f), 2, 0, Qmenu_bar_lines);
506 } 505 }
507 506
508 unblock_input (); 507 unblock_input ();
@@ -707,7 +706,7 @@ w32_menu_show (struct frame *f, int x, int y, int menuflags,
707 wv->key = SSDATA (descrip); 706 wv->key = SSDATA (descrip);
708 /* Use the contents index as call_data, since we are 707 /* Use the contents index as call_data, since we are
709 restricted to 16-bits. */ 708 restricted to 16-bits. */
710 wv->call_data = !NILP (def) ? (void *) (EMACS_INT) i : 0; 709 wv->call_data = !NILP (def) ? (void *) (UINT_PTR) i : 0;
711 710
712 if (NILP (type)) 711 if (NILP (type))
713 wv->button_type = BUTTON_TYPE_NONE; 712 wv->button_type = BUTTON_TYPE_NONE;
@@ -1402,17 +1401,21 @@ add_menu_item (HMENU menu, widget_value *wv, HMENU item)
1402 info.cbSize = sizeof (info); 1401 info.cbSize = sizeof (info);
1403 info.fMask = MIIM_DATA; 1402 info.fMask = MIIM_DATA;
1404 1403
1405 /* Set help string for menu item. Leave it as a Lisp_Object 1404 /* Set help string for menu item. Leave it as a pointer to
1406 until it is ready to be displayed, since GC can happen while 1405 a Lisp_String until it is ready to be displayed, since GC
1407 menus are active. */ 1406 can happen while menus are active. */
1408 if (!NILP (wv->help)) 1407 if (!NILP (wv->help))
1409 { 1408 {
1409 /* We use XUNTAG below because in a 32-bit build
1410 --with-wide-int we cannot pass a Lisp_Object
1411 via a DWORD member of MENUITEMINFO. */
1410 /* As of Jul-2012, w32api headers say that dwItemData 1412 /* As of Jul-2012, w32api headers say that dwItemData
1411 has DWORD type, but that's a bug: it should actually 1413 has DWORD type, but that's a bug: it should actually
1412 be ULONG_PTR, which is correct for 32-bit and 64-bit 1414 be ULONG_PTR, which is correct for 32-bit and 64-bit
1413 Windows alike. MSVC headers get it right; hopefully, 1415 Windows alike. MSVC headers get it right; hopefully,
1414 MinGW headers will, too. */ 1416 MinGW headers will, too. */
1415 info.dwItemData = (ULONG_PTR) XLI (wv->help); 1417 eassert (STRINGP (wv->help));
1418 info.dwItemData = (ULONG_PTR) XUNTAG (wv->help, Lisp_String);
1416 } 1419 }
1417 if (wv->button_type == BUTTON_TYPE_RADIO) 1420 if (wv->button_type == BUTTON_TYPE_RADIO)
1418 { 1421 {
@@ -1473,11 +1476,24 @@ w32_menu_display_help (HWND owner, HMENU menu, UINT item, UINT flags)
1473 struct frame *f = x_window_to_frame (&one_w32_display_info, owner); 1476 struct frame *f = x_window_to_frame (&one_w32_display_info, owner);
1474 Lisp_Object frame, help; 1477 Lisp_Object frame, help;
1475 1478
1476 /* No help echo on owner-draw menu items, or when the keyboard is used 1479 /* No help echo on owner-draw menu items, or when the keyboard
1477 to navigate the menus, since tooltips are distracting if they pop 1480 is used to navigate the menus, since tooltips are distracting
1478 up elsewhere. */ 1481 if they pop up elsewhere. */
1479 if (flags & MF_OWNERDRAW || flags & MF_POPUP 1482 if ((flags & MF_OWNERDRAW) || (flags & MF_POPUP)
1480 || !(flags & MF_MOUSESELECT)) 1483 || !(flags & MF_MOUSESELECT)
1484 /* Ignore any dwItemData for menu items whose flags don't
1485 have the MF_HILITE bit set. These are dwItemData that
1486 Windows sends our way, but they aren't pointers to our
1487 Lisp_String objects, so trying to create Lisp_Strings out
1488 of them below and pass that to the keyboard queue will
1489 crash Emacs when we try to display those "strings". It
1490 is unclear why we get these dwItemData, or what they are:
1491 sometimes they point to a wchar_t string that is the menu
1492 title, sometimes to someting that doesn't look like text
1493 at all. (The problematic data also comes with the 0x0800
1494 bit set, but this bit is not documented, so we don't want
1495 to depend on it.) */
1496 || !(flags & MF_HILITE))
1481 help = Qnil; 1497 help = Qnil;
1482 else 1498 else
1483 { 1499 {
@@ -1488,7 +1504,10 @@ w32_menu_display_help (HWND owner, HMENU menu, UINT item, UINT flags)
1488 info.fMask = MIIM_DATA; 1504 info.fMask = MIIM_DATA;
1489 get_menu_item_info (menu, item, FALSE, &info); 1505 get_menu_item_info (menu, item, FALSE, &info);
1490 1506
1491 help = info.dwItemData ? XIL (info.dwItemData) : Qnil; 1507 help =
1508 info.dwItemData
1509 ? make_lisp_ptr ((void *) info.dwItemData, Lisp_String)
1510 : Qnil;
1492 } 1511 }
1493 1512
1494 /* Store the help echo in the keyboard buffer as the X toolkit 1513 /* Store the help echo in the keyboard buffer as the X toolkit
diff --git a/src/w32proc.c b/src/w32proc.c
index 26cfa2996d0..74731db2426 100644
--- a/src/w32proc.c
+++ b/src/w32proc.c
@@ -3077,13 +3077,18 @@ yield nil. */)
3077 (Lisp_Object cp) 3077 (Lisp_Object cp)
3078{ 3078{
3079 CHARSETINFO info; 3079 CHARSETINFO info;
3080 DWORD dwcp;
3080 3081
3081 CHECK_NUMBER (cp); 3082 CHECK_NUMBER (cp);
3082 3083
3083 if (!IsValidCodePage (XINT (cp))) 3084 if (!IsValidCodePage (XINT (cp)))
3084 return Qnil; 3085 return Qnil;
3085 3086
3086 if (TranslateCharsetInfo ((DWORD *) XINT (cp), &info, TCI_SRCCODEPAGE)) 3087 /* Going through a temporary DWORD variable avoids compiler warning
3088 about cast to pointer from integer of different size, when
3089 building --with-wide-int. */
3090 dwcp = XINT (cp);
3091 if (TranslateCharsetInfo ((DWORD *) dwcp, &info, TCI_SRCCODEPAGE))
3087 return make_number (info.ciCharset); 3092 return make_number (info.ciCharset);
3088 3093
3089 return Qnil; 3094 return Qnil;
@@ -3142,8 +3147,8 @@ If successful, the new layout id is returned, otherwise nil. */)
3142 CHECK_NUMBER_CAR (layout); 3147 CHECK_NUMBER_CAR (layout);
3143 CHECK_NUMBER_CDR (layout); 3148 CHECK_NUMBER_CDR (layout);
3144 3149
3145 kl = (HKL) ((XINT (XCAR (layout)) & 0xffff) 3150 kl = (HKL) (UINT_PTR) ((XINT (XCAR (layout)) & 0xffff)
3146 | (XINT (XCDR (layout)) << 16)); 3151 | (XINT (XCDR (layout)) << 16));
3147 3152
3148 /* Synchronize layout with input thread. */ 3153 /* Synchronize layout with input thread. */
3149 if (dwWindowsThreadId) 3154 if (dwWindowsThreadId)
diff --git a/src/w32term.h b/src/w32term.h
index 042d7abd945..c905ef15737 100644
--- a/src/w32term.h
+++ b/src/w32term.h
@@ -493,8 +493,8 @@ struct scroll_bar {
493 (XSETINT ((low), ((DWORDLONG)(int64)) & 0xffffffff), \ 493 (XSETINT ((low), ((DWORDLONG)(int64)) & 0xffffffff), \
494 XSETINT ((high), ((DWORDLONG)(int64) >> 32) & 0xffffffff)) 494 XSETINT ((high), ((DWORDLONG)(int64) >> 32) & 0xffffffff))
495#else /* not _WIN64 */ 495#else /* not _WIN64 */
496/* Building a 32-bit C integer from two 16-bit lisp integers. */ 496/* Building a 32-bit C unsigned integer from two 16-bit lisp integers. */
497#define SCROLL_BAR_PACK(low, high) (XINT (high) << 16 | XINT (low)) 497#define SCROLL_BAR_PACK(low, high) ((UINT_PTR)(XINT (high) << 16 | XINT (low)))
498 498
499/* Setting two lisp integers to the low and high words of a 32-bit C int. */ 499/* Setting two lisp integers to the low and high words of a 32-bit C int. */
500#define SCROLL_BAR_UNPACK(low, high, int32) \ 500#define SCROLL_BAR_UNPACK(low, high, int32) \
diff --git a/src/window.c b/src/window.c
index 4dec9768e2c..60ba3750f5b 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
3003/* Placeholder used by temacs -nw before window.el is loaded. */ 3003/* Placeholder used by temacs -nw before window.el is loaded. */
3004DEFUN ("window--sanitize-window-sizes", Fwindow__sanitize_window_sizes, 3004DEFUN ("window--sanitize-window-sizes", Fwindow__sanitize_window_sizes,
3005 Swindow__sanitize_window_sizes, 2, 2, 0, 3005 Swindow__sanitize_window_sizes, 2, 2, 0,
3006 doc: /* */) 3006 doc: /* */
3007 attributes: const)
3007 (Lisp_Object frame, Lisp_Object horizontal) 3008 (Lisp_Object frame, Lisp_Object horizontal)
3008{ 3009{
3009 return Qnil; 3010 return Qnil;
@@ -6427,7 +6428,7 @@ the return value is nil. Otherwise the value is t. */)
6427 /* Allow x_set_window_size again and apply frame size changes if 6428 /* Allow x_set_window_size again and apply frame size changes if
6428 needed. */ 6429 needed. */
6429 f->can_x_set_window_size = true; 6430 f->can_x_set_window_size = true;
6430 adjust_frame_size (f, -1, -1, 1, 0, Qnil); 6431 adjust_frame_size (f, -1, -1, 1, 0, Qset_window_configuration);
6431 6432
6432 adjust_frame_glyphs (f); 6433 adjust_frame_glyphs (f);
6433 unblock_input (); 6434 unblock_input ();
diff --git a/src/xdisp.c b/src/xdisp.c
index 8b68ab7ddf7..120e810f445 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -12332,7 +12332,8 @@ DEFUN ("tool-bar-height", Ftool_bar_height, Stool_bar_height,
12332 0, 2, 0, 12332 0, 2, 0,
12333 doc: /* Return the number of lines occupied by the tool bar of FRAME. 12333 doc: /* Return the number of lines occupied by the tool bar of FRAME.
12334If FRAME is nil or omitted, use the selected frame. Optional argument 12334If FRAME is nil or omitted, use the selected frame. Optional argument
12335PIXELWISE non-nil means return the height of the tool bar in pixels. */) 12335PIXELWISE non-nil means return the height of the tool bar in pixels. */
12336 attributes: const)
12336 (Lisp_Object frame, Lisp_Object pixelwise) 12337 (Lisp_Object frame, Lisp_Object pixelwise)
12337{ 12338{
12338 int height = 0; 12339 int height = 0;
@@ -12408,6 +12409,7 @@ redisplay_tool_bar (struct frame *f)
12408 if (new_height != WINDOW_PIXEL_HEIGHT (w)) 12409 if (new_height != WINDOW_PIXEL_HEIGHT (w))
12409 { 12410 {
12410 x_change_tool_bar_height (f, new_height); 12411 x_change_tool_bar_height (f, new_height);
12412 frame_default_tool_bar_height = new_height;
12411 /* Always do that now. */ 12413 /* Always do that now. */
12412 clear_glyph_matrix (w->desired_matrix); 12414 clear_glyph_matrix (w->desired_matrix);
12413 f->fonts_changed = 1; 12415 f->fonts_changed = 1;
@@ -12502,6 +12504,7 @@ redisplay_tool_bar (struct frame *f)
12502 if (change_height_p) 12504 if (change_height_p)
12503 { 12505 {
12504 x_change_tool_bar_height (f, new_height); 12506 x_change_tool_bar_height (f, new_height);
12507 frame_default_tool_bar_height = new_height;
12505 clear_glyph_matrix (w->desired_matrix); 12508 clear_glyph_matrix (w->desired_matrix);
12506 f->n_tool_bar_rows = nrows; 12509 f->n_tool_bar_rows = nrows;
12507 f->fonts_changed = 1; 12510 f->fonts_changed = 1;
@@ -13831,6 +13834,17 @@ redisplay_internal (void)
13831 13834
13832 retry_frame: 13835 retry_frame:
13833 13836
13837#if defined (HAVE_WINDOW_SYSTEM) && !defined (USE_GTK) && !defined (HAVE_NS)
13838 /* Redisplay internal tool bar if this is the first time so we
13839 can adjust the frame height right now, if necessary. */
13840 if (!f->tool_bar_redisplayed_once)
13841 {
13842 if (redisplay_tool_bar (f))
13843 adjust_frame_glyphs (f);
13844 f->tool_bar_redisplayed_once = true;
13845 }
13846#endif
13847
13834 if (FRAME_WINDOW_P (f) || FRAME_TERMCAP_P (f) || f == sf) 13848 if (FRAME_WINDOW_P (f) || FRAME_TERMCAP_P (f) || f == sf)
13835 { 13849 {
13836 bool gcscrollbars 13850 bool gcscrollbars
diff --git a/src/xfaces.c b/src/xfaces.c
index 6ecd857d685..85af770c6a2 100644
--- a/src/xfaces.c
+++ b/src/xfaces.c
@@ -3546,7 +3546,8 @@ with the value VALUE is relative.
3546A relative value is one that doesn't entirely override whatever is 3546A relative value is one that doesn't entirely override whatever is
3547inherited from another face. For most possible attributes, 3547inherited from another face. For most possible attributes,
3548the only relative value that users see is `unspecified'. 3548the only relative value that users see is `unspecified'.
3549However, for :height, floating point values are also relative. */) 3549However, for :height, floating point values are also relative. */
3550 attributes: const)
3550 (Lisp_Object attribute, Lisp_Object value) 3551 (Lisp_Object attribute, Lisp_Object value)
3551{ 3552{
3552 if (EQ (value, Qunspecified) || (EQ (value, QCignore_defface))) 3553 if (EQ (value, Qunspecified) || (EQ (value, QCignore_defface)))
diff --git a/src/xfns.c b/src/xfns.c
index 4a417526dcd..936c769a2de 100644
--- a/src/xfns.c
+++ b/src/xfns.c
@@ -1130,8 +1130,11 @@ x_change_tool_bar_height (struct frame *f, int height)
1130 /* Recalculate toolbar height. */ 1130 /* Recalculate toolbar height. */
1131 f->n_tool_bar_rows = 0; 1131 f->n_tool_bar_rows = 0;
1132 1132
1133 adjust_frame_size (f, -1, -1, (old_height == 0 || height == 0) ? 2 : 4, 0, 1133 adjust_frame_size (f, -1, -1,
1134 Qtool_bar_lines); 1134 (!f->tool_bar_redisplayed_once ? 1
1135 : (old_height == 0 || height == 0) ? 2
1136 : 4),
1137 0, Qtool_bar_lines);
1135 1138
1136 /* adjust_frame_size might not have done anything, garbage frame 1139 /* adjust_frame_size might not have done anything, garbage frame
1137 here. */ 1140 here. */
@@ -3160,7 +3163,8 @@ This function is an internal primitive--use `make-frame' instead. */)
3160 had one frame line vs one toolbar line which left us with a zero 3163 had one frame line vs one toolbar line which left us with a zero
3161 root window height which was obviously wrong as well ... */ 3164 root window height which was obviously wrong as well ... */
3162 adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f), 3165 adjust_frame_size (f, FRAME_COLS (f) * FRAME_COLUMN_WIDTH (f),
3163 FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, 1, Qnil); 3166 FRAME_LINES (f) * FRAME_LINE_HEIGHT (f), 5, 1,
3167 Qx_create_frame_1);
3164 3168
3165 /* Set the menu-bar-lines and tool-bar-lines parameters. We don't 3169 /* Set the menu-bar-lines and tool-bar-lines parameters. We don't
3166 look up the X resources controlling the menu-bar and tool-bar 3170 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. */)
3234 /* Consider frame official, now. */ 3238 /* Consider frame official, now. */
3235 f->can_x_set_window_size = true; 3239 f->can_x_set_window_size = true;
3236 3240
3237 adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), 0, 1, Qnil); 3241 adjust_frame_size (f, FRAME_TEXT_WIDTH (f), FRAME_TEXT_HEIGHT (f), 0, 1,
3242 Qx_create_frame_2);
3238 3243
3239#if defined (USE_X_TOOLKIT) || defined (USE_GTK) 3244#if defined (USE_X_TOOLKIT) || defined (USE_GTK)
3240 /* Create the menu bar. */ 3245 /* Create the menu bar. */
diff --git a/src/xmenu.c b/src/xmenu.c
index fd667a84343..9063a8a2a52 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/>. */
104 104
105#include "menu.h" 105#include "menu.h"
106 106
107#ifndef TRUE
108#define TRUE 1
109#endif /* no TRUE */
110
111 107
112/* Flag which when set indicates a dialog or menu has been posted by 108/* Flag which when set indicates a dialog or menu has been posted by
113 Xt on behalf of one of the widget sets. */ 109 Xt on behalf of one of the widget sets. */
@@ -146,7 +142,7 @@ menubar_id_to_frame (LWLIB_ID id)
146/* Set menu_items_inuse so no other popup menu or dialog is created. */ 142/* Set menu_items_inuse so no other popup menu or dialog is created. */
147 143
148void 144void
149x_menu_set_in_use (int in_use) 145x_menu_set_in_use (bool in_use)
150{ 146{
151 menu_items_inuse = in_use ? Qt : Qnil; 147 menu_items_inuse = in_use ? Qt : Qnil;
152 popup_activated_flag = in_use; 148 popup_activated_flag = in_use;
@@ -222,7 +218,8 @@ x_menu_wait_for_event (void *data)
222 with BLOCK_INPUT, UNBLOCK_INPUT wrappers. */ 218 with BLOCK_INPUT, UNBLOCK_INPUT wrappers. */
223 219
224static void 220static void
225popup_get_selection (XEvent *initial_event, struct x_display_info *dpyinfo, LWLIB_ID id, int do_timers) 221popup_get_selection (XEvent *initial_event, struct x_display_info *dpyinfo,
222 LWLIB_ID id, bool do_timers)
226{ 223{
227 XEvent event; 224 XEvent event;
228 225
@@ -287,13 +284,13 @@ If FRAME is nil or not given, use the selected frame. */)
287 block_input (); 284 block_input ();
288 285
289 if (FRAME_EXTERNAL_MENU_BAR (f)) 286 if (FRAME_EXTERNAL_MENU_BAR (f))
290 set_frame_menubar (f, 0, 1); 287 set_frame_menubar (f, false, true);
291 288
292 menubar = FRAME_X_OUTPUT (f)->menubar_widget; 289 menubar = FRAME_X_OUTPUT (f)->menubar_widget;
293 if (menubar) 290 if (menubar)
294 { 291 {
295 Window child; 292 Window child;
296 bool error_p = 0; 293 bool error_p = false;
297 294
298 x_catch_errors (FRAME_X_DISPLAY (f)); 295 x_catch_errors (FRAME_X_DISPLAY (f));
299 memset (&ev, 0, sizeof ev); 296 memset (&ev, 0, sizeof ev);
@@ -366,7 +363,7 @@ If FRAME is nil or not given, use the selected frame. */)
366 f = decode_window_system_frame (frame); 363 f = decode_window_system_frame (frame);
367 364
368 if (FRAME_EXTERNAL_MENU_BAR (f)) 365 if (FRAME_EXTERNAL_MENU_BAR (f))
369 set_frame_menubar (f, 0, 1); 366 set_frame_menubar (f, false, true);
370 367
371 menubar = FRAME_X_OUTPUT (f)->menubar_widget; 368 menubar = FRAME_X_OUTPUT (f)->menubar_widget;
372 if (menubar) 369 if (menubar)
@@ -390,7 +387,7 @@ If FRAME is nil or not given, use the selected frame. */)
390 Used for popup menus and dialogs. */ 387 Used for popup menus and dialogs. */
391 388
392static void 389static void
393popup_widget_loop (int do_timers, GtkWidget *widget) 390popup_widget_loop (bool do_timers, GtkWidget *widget)
394{ 391{
395 ++popup_activated_flag; 392 ++popup_activated_flag;
396 393
@@ -431,7 +428,7 @@ x_activate_menubar (struct frame *f)
431 return; 428 return;
432#endif 429#endif
433 430
434 set_frame_menubar (f, 0, 1); 431 set_frame_menubar (f, false, true);
435 block_input (); 432 block_input ();
436 popup_activated_flag = 1; 433 popup_activated_flag = 1;
437#ifdef USE_GTK 434#ifdef USE_GTK
@@ -488,24 +485,7 @@ show_help_event (struct frame *f, xt_or_gtk_widget widget, Lisp_Object help)
488 kbd_buffer_store_help_event (frame, help); 485 kbd_buffer_store_help_event (frame, help);
489 } 486 }
490 else 487 else
491 { 488 show_help_echo (help, Qnil, Qnil, Qnil);
492#if 0 /* This code doesn't do anything useful. ++kfs */
493 /* WIDGET is the popup menu. It's parent is the frame's
494 widget. See which frame that is. */
495 xt_or_gtk_widget frame_widget = XtParent (widget);
496 Lisp_Object tail;
497
498 for (tail = Vframe_list; CONSP (tail); tail = XCDR (tail))
499 {
500 frame = XCAR (tail);
501 if (FRAMEP (frame)
502 && (f = XFRAME (frame),
503 FRAME_X_P (f) && f->output_data.x->widget == frame_widget))
504 break;
505 }
506#endif
507 show_help_echo (help, Qnil, Qnil, Qnil);
508 }
509} 489}
510 490
511/* Callback called when menu items are highlighted/unhighlighted 491/* Callback called when menu items are highlighted/unhighlighted
@@ -554,7 +534,7 @@ menu_highlight_callback (Widget widget, LWLIB_ID id, void *call_data)
554 selected in a radio group. If this variable is set to a non-zero 534 selected in a radio group. If this variable is set to a non-zero
555 value, we are creating menus and don't want callbacks right now. 535 value, we are creating menus and don't want callbacks right now.
556*/ 536*/
557static int xg_crazy_callback_abort; 537static bool xg_crazy_callback_abort;
558 538
559/* This callback is called from the menu bar pulldown menu 539/* This callback is called from the menu bar pulldown menu
560 when the user makes a selection. 540 when the user makes a selection.
@@ -656,13 +636,13 @@ update_frame_menubar (struct frame *f)
656 lw_refigure_widget (x->column_widget, True); 636 lw_refigure_widget (x->column_widget, True);
657 637
658 /* Force the pane widget to resize itself. */ 638 /* Force the pane widget to resize itself. */
639 int new_height = -1;
659#ifdef USE_LUCID 640#ifdef USE_LUCID
660 /* For reasons I don't know Lucid wants to add one pixel to the frame 641 /* For reasons I don't know Lucid wants to add one pixel to the frame
661 height when adding the menu bar. Compensate that here. */ 642 height when adding the menu bar. Compensate that here. */
662 adjust_frame_size (f, -1, FRAME_TEXT_HEIGHT (f) - 1, 2, 0, Qmenu_bar_lines); 643 new_height = FRAME_TEXT_HEIGHT (f) - 1;
663#else
664 adjust_frame_size (f, -1, -1, 2, 0, Qmenu_bar_lines);
665#endif /* USE_LUCID */ 644#endif /* USE_LUCID */
645 adjust_frame_size (f, -1, new_height, 2, false, Qmenu_bar_lines);
666 unblock_input (); 646 unblock_input ();
667#endif /* USE_GTK */ 647#endif /* USE_GTK */
668} 648}
@@ -729,11 +709,11 @@ set_frame_menubar (struct frame *f, bool first_time, bool deep_p)
729#endif 709#endif
730 710
731 if (! menubar_widget) 711 if (! menubar_widget)
732 deep_p = 1; 712 deep_p = true;
733 /* Make the first call for any given frame always go deep. */ 713 /* Make the first call for any given frame always go deep. */
734 else if (!f->output_data.x->saved_menu_event && !deep_p) 714 else if (!f->output_data.x->saved_menu_event && !deep_p)
735 { 715 {
736 deep_p = 1; 716 deep_p = true;
737 f->output_data.x->saved_menu_event = xmalloc (sizeof (XEvent)); 717 f->output_data.x->saved_menu_event = xmalloc (sizeof (XEvent));
738 f->output_data.x->saved_menu_event->type = 0; 718 f->output_data.x->saved_menu_event->type = 0;
739 } 719 }
@@ -840,7 +820,7 @@ set_frame_menubar (struct frame *f, bool first_time, bool deep_p)
840 else 820 else
841 first_wv->contents = wv; 821 first_wv->contents = wv;
842 /* Don't set wv->name here; GC during the loop might relocate it. */ 822 /* Don't set wv->name here; GC during the loop might relocate it. */
843 wv->enabled = 1; 823 wv->enabled = true;
844 wv->button_type = BUTTON_TYPE_NONE; 824 wv->button_type = BUTTON_TYPE_NONE;
845 prev_wv = wv; 825 prev_wv = wv;
846 } 826 }
@@ -931,7 +911,7 @@ set_frame_menubar (struct frame *f, bool first_time, bool deep_p)
931 block_input (); 911 block_input ();
932 912
933#ifdef USE_GTK 913#ifdef USE_GTK
934 xg_crazy_callback_abort = 1; 914 xg_crazy_callback_abort = true;
935 if (menubar_widget) 915 if (menubar_widget)
936 { 916 {
937 /* The fourth arg is DEEP_P, which says to consider the entire 917 /* 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)
980 menubar_widget = lw_create_widget ("menubar", "menubar", id, 960 menubar_widget = lw_create_widget ("menubar", "menubar", id,
981 first_wv, 961 first_wv,
982 f->output_data.x->column_widget, 962 f->output_data.x->column_widget,
983 0, 963 false,
984 popup_activate_callback, 964 popup_activate_callback,
985 menubar_selection_callback, 965 menubar_selection_callback,
986 popup_deactivate_callback, 966 popup_deactivate_callback,
@@ -1002,11 +982,11 @@ set_frame_menubar (struct frame *f, bool first_time, bool deep_p)
1002 + f->output_data.x->menubar_widget->core.border_width) 982 + f->output_data.x->menubar_widget->core.border_width)
1003 : 0); 983 : 0);
1004 984
1005#if 1 /* Experimentally, we now get the right results 985#ifdef USE_LUCID
986 /* Experimentally, we now get the right results
1006 for -geometry -0-0 without this. 24 Aug 96, rms. 987 for -geometry -0-0 without this. 24 Aug 96, rms.
1007 Maybe so, but the menu bar size is missing the pixels so the 988 Maybe so, but the menu bar size is missing the pixels so the
1008 WM size hints are off by these pixels. Jan D, oct 2009. */ 989 WM size hints are off by these pixels. Jan D, oct 2009. */
1009#ifdef USE_LUCID
1010 if (FRAME_EXTERNAL_MENU_BAR (f)) 990 if (FRAME_EXTERNAL_MENU_BAR (f))
1011 { 991 {
1012 Dimension ibw = 0; 992 Dimension ibw = 0;
@@ -1015,7 +995,6 @@ set_frame_menubar (struct frame *f, bool first_time, bool deep_p)
1015 menubar_size += ibw; 995 menubar_size += ibw;
1016 } 996 }
1017#endif /* USE_LUCID */ 997#endif /* USE_LUCID */
1018#endif /* 1 */
1019 998
1020 FRAME_MENUBAR_HEIGHT (f) = menubar_size; 999 FRAME_MENUBAR_HEIGHT (f) = menubar_size;
1021 } 1000 }
@@ -1025,7 +1004,7 @@ set_frame_menubar (struct frame *f, bool first_time, bool deep_p)
1025 update_frame_menubar (f); 1004 update_frame_menubar (f);
1026 1005
1027#ifdef USE_GTK 1006#ifdef USE_GTK
1028 xg_crazy_callback_abort = 0; 1007 xg_crazy_callback_abort = false;
1029#endif 1008#endif
1030 1009
1031 unblock_input (); 1010 unblock_input ();
@@ -1042,7 +1021,7 @@ initialize_frame_menubar (struct frame *f)
1042 /* This function is called before the first chance to redisplay 1021 /* This function is called before the first chance to redisplay
1043 the frame. It has to be, so the frame will have the right size. */ 1022 the frame. It has to be, so the frame will have the right size. */
1044 fset_menu_bar_items (f, menu_bar_items (FRAME_MENU_BAR_ITEMS (f))); 1023 fset_menu_bar_items (f, menu_bar_items (FRAME_MENU_BAR_ITEMS (f)));
1045 set_frame_menubar (f, 1, 1); 1024 set_frame_menubar (f, true, true);
1046} 1025}
1047 1026
1048 1027
@@ -1094,21 +1073,21 @@ free_frame_menubar (struct frame *f)
1094 1073
1095 if (f->output_data.x->widget) 1074 if (f->output_data.x->widget)
1096 { 1075 {
1076 int new_height = -1;
1097#ifdef USE_MOTIF 1077#ifdef USE_MOTIF
1098 XtVaGetValues (f->output_data.x->widget, XtNx, &x1, XtNy, &y1, NULL); 1078 XtVaGetValues (f->output_data.x->widget, XtNx, &x1, XtNy, &y1, NULL);
1099 if (x1 == 0 && y1 == 0) 1079 if (x1 == 0 && y1 == 0)
1100 XtVaSetValues (f->output_data.x->widget, XtNx, x0, XtNy, y0, NULL); 1080 XtVaSetValues (f->output_data.x->widget, XtNx, x0, XtNy, y0, NULL);
1101 if (frame_inhibit_resize (f, 0, Qmenu_bar_lines)) 1081 if (frame_inhibit_resize (f, false, Qmenu_bar_lines))
1102 adjust_frame_size (f, -1, old_height, 1, 0, Qmenu_bar_lines); 1082 new_height = old_height;
1103 else
1104#endif /* USE_MOTIF */ 1083#endif /* USE_MOTIF */
1105 adjust_frame_size (f, -1, -1, 2, 0, Qmenu_bar_lines); 1084 adjust_frame_size (f, -1, new_height, 2, false, Qmenu_bar_lines);
1106 } 1085 }
1107 else 1086 else
1108 { 1087 {
1109#ifdef USE_MOTIF 1088#ifdef USE_MOTIF
1110 if (frame_inhibit_resize (f, 0, Qmenu_bar_lines)) 1089 if (frame_inhibit_resize (f, false, Qmenu_bar_lines))
1111 adjust_frame_size (f, -1, old_height, 1, 0, Qmenu_bar_lines); 1090 adjust_frame_size (f, -1, old_height, 1, false, Qmenu_bar_lines);
1112#endif 1091#endif
1113 } 1092 }
1114 1093
@@ -1218,17 +1197,17 @@ create_and_show_popup_menu (struct frame *f, widget_value *first_wv,
1218#ifdef HAVE_GTK3 1197#ifdef HAVE_GTK3
1219 /* Always use position function for Gtk3. Otherwise menus may become 1198 /* Always use position function for Gtk3. Otherwise menus may become
1220 too small to show anything. */ 1199 too small to show anything. */
1221 use_pos_func = 1; 1200 use_pos_func = true;
1222#endif 1201#endif
1223 1202
1224 eassert (FRAME_X_P (f)); 1203 eassert (FRAME_X_P (f));
1225 1204
1226 xg_crazy_callback_abort = 1; 1205 xg_crazy_callback_abort = true;
1227 menu = xg_create_widget ("popup", first_wv->name, f, first_wv, 1206 menu = xg_create_widget ("popup", first_wv->name, f, first_wv,
1228 G_CALLBACK (popup_selection_callback), 1207 G_CALLBACK (popup_selection_callback),
1229 G_CALLBACK (popup_deactivate_callback), 1208 G_CALLBACK (popup_deactivate_callback),
1230 G_CALLBACK (menu_highlight_callback)); 1209 G_CALLBACK (menu_highlight_callback));
1231 xg_crazy_callback_abort = 0; 1210 xg_crazy_callback_abort = false;
1232 1211
1233 if (use_pos_func) 1212 if (use_pos_func)
1234 { 1213 {
@@ -1269,7 +1248,7 @@ create_and_show_popup_menu (struct frame *f, widget_value *first_wv,
1269 two. show_help_echo uses this to detect popup menus. */ 1248 two. show_help_echo uses this to detect popup menus. */
1270 popup_activated_flag = 1; 1249 popup_activated_flag = 1;
1271 /* Process events that apply to the menu. */ 1250 /* Process events that apply to the menu. */
1272 popup_widget_loop (1, menu); 1251 popup_widget_loop (true, menu);
1273 } 1252 }
1274 1253
1275 unbind_to (specpdl_count, Qnil); 1254 unbind_to (specpdl_count, Qnil);
@@ -1331,14 +1310,14 @@ create_and_show_popup_menu (struct frame *f, widget_value *first_wv,
1331 1310
1332 menu_id = widget_id_tick++; 1311 menu_id = widget_id_tick++;
1333 menu = lw_create_widget ("popup", first_wv->name, menu_id, first_wv, 1312 menu = lw_create_widget ("popup", first_wv->name, menu_id, first_wv,
1334 f->output_data.x->widget, 1, 0, 1313 f->output_data.x->widget, true, 0,
1335 popup_selection_callback, 1314 popup_selection_callback,
1336 popup_deactivate_callback, 1315 popup_deactivate_callback,
1337 menu_highlight_callback); 1316 menu_highlight_callback);
1338 1317
1339 event->type = ButtonPress; 1318 event->type = ButtonPress;
1340 event->serial = 0; 1319 event->serial = 0;
1341 event->send_event = 0; 1320 event->send_event = false;
1342 event->display = FRAME_X_DISPLAY (f); 1321 event->display = FRAME_X_DISPLAY (f);
1343 event->time = CurrentTime; 1322 event->time = CurrentTime;
1344 event->root = FRAME_DISPLAY_INFO (f)->root_window; 1323 event->root = FRAME_DISPLAY_INFO (f)->root_window;
@@ -1374,7 +1353,7 @@ create_and_show_popup_menu (struct frame *f, widget_value *first_wv,
1374 record_unwind_protect_int (pop_down_menu, (int) menu_id); 1353 record_unwind_protect_int (pop_down_menu, (int) menu_id);
1375 1354
1376 /* Process events that apply to the menu. */ 1355 /* Process events that apply to the menu. */
1377 popup_get_selection (0, FRAME_DISPLAY_INFO (f), menu_id, 1); 1356 popup_get_selection (0, FRAME_DISPLAY_INFO (f), menu_id, true);
1378 1357
1379 unbind_to (specpdl_count, Qnil); 1358 unbind_to (specpdl_count, Qnil);
1380 } 1359 }
@@ -1400,8 +1379,6 @@ x_menu_show (struct frame *f, int x, int y, int menuflags,
1400 = alloca (menu_items_used * sizeof *subprefix_stack); 1379 = alloca (menu_items_used * sizeof *subprefix_stack);
1401 int submenu_depth = 0; 1380 int submenu_depth = 0;
1402 1381
1403 int first_pane;
1404
1405 ptrdiff_t specpdl_count = SPECPDL_INDEX (); 1382 ptrdiff_t specpdl_count = SPECPDL_INDEX ();
1406 1383
1407 eassert (FRAME_X_P (f)); 1384 eassert (FRAME_X_P (f));
@@ -1421,7 +1398,7 @@ x_menu_show (struct frame *f, int x, int y, int menuflags,
1421 wv = make_widget_value ("menu", NULL, true, Qnil); 1398 wv = make_widget_value ("menu", NULL, true, Qnil);
1422 wv->button_type = BUTTON_TYPE_NONE; 1399 wv->button_type = BUTTON_TYPE_NONE;
1423 first_wv = wv; 1400 first_wv = wv;
1424 first_pane = 1; 1401 bool first_pane = true;
1425 1402
1426 /* Loop over all panes and items, filling in the tree. */ 1403 /* Loop over all panes and items, filling in the tree. */
1427 i = 0; 1404 i = 0;
@@ -1432,14 +1409,14 @@ x_menu_show (struct frame *f, int x, int y, int menuflags,
1432 submenu_stack[submenu_depth++] = save_wv; 1409 submenu_stack[submenu_depth++] = save_wv;
1433 save_wv = prev_wv; 1410 save_wv = prev_wv;
1434 prev_wv = 0; 1411 prev_wv = 0;
1435 first_pane = 1; 1412 first_pane = true;
1436 i++; 1413 i++;
1437 } 1414 }
1438 else if (EQ (AREF (menu_items, i), Qlambda)) 1415 else if (EQ (AREF (menu_items, i), Qlambda))
1439 { 1416 {
1440 prev_wv = save_wv; 1417 prev_wv = save_wv;
1441 save_wv = submenu_stack[--submenu_depth]; 1418 save_wv = submenu_stack[--submenu_depth];
1442 first_pane = 0; 1419 first_pane = false;
1443 i++; 1420 i++;
1444 } 1421 }
1445 else if (EQ (AREF (menu_items, i), Qt) 1422 else if (EQ (AREF (menu_items, i), Qt)
@@ -1493,7 +1470,7 @@ x_menu_show (struct frame *f, int x, int y, int menuflags,
1493 save_wv = wv; 1470 save_wv = wv;
1494 prev_wv = 0; 1471 prev_wv = 0;
1495 } 1472 }
1496 first_pane = 0; 1473 first_pane = false;
1497 i += MENU_ITEMS_PANE_LENGTH; 1474 i += MENU_ITEMS_PANE_LENGTH;
1498 } 1475 }
1499 else 1476 else
@@ -1688,7 +1665,7 @@ create_and_show_dialog (struct frame *f, widget_value *first_wv)
1688 gtk_widget_show_all (menu); 1665 gtk_widget_show_all (menu);
1689 1666
1690 /* Process events that apply to the menu. */ 1667 /* Process events that apply to the menu. */
1691 popup_widget_loop (1, menu); 1668 popup_widget_loop (true, menu);
1692 1669
1693 unbind_to (specpdl_count, Qnil); 1670 unbind_to (specpdl_count, Qnil);
1694 } 1671 }
@@ -1725,7 +1702,7 @@ create_and_show_dialog (struct frame *f, widget_value *first_wv)
1725 apply_systemfont_to_dialog (f->output_data.x->widget); 1702 apply_systemfont_to_dialog (f->output_data.x->widget);
1726#endif 1703#endif
1727 lw_create_widget (first_wv->name, "dialog", dialog_id, first_wv, 1704 lw_create_widget (first_wv->name, "dialog", dialog_id, first_wv,
1728 f->output_data.x->widget, 1, 0, 1705 f->output_data.x->widget, true, 0,
1729 dialog_selection_callback, 0, 0); 1706 dialog_selection_callback, 0, 0);
1730 lw_modify_all_widgets (dialog_id, first_wv->contents, True); 1707 lw_modify_all_widgets (dialog_id, first_wv->contents, True);
1731 /* Display the dialog box. */ 1708 /* Display the dialog box. */
@@ -1742,7 +1719,7 @@ create_and_show_dialog (struct frame *f, widget_value *first_wv)
1742 1719
1743 record_unwind_protect_int (pop_down_menu, (int) dialog_id); 1720 record_unwind_protect_int (pop_down_menu, (int) dialog_id);
1744 1721
1745 popup_get_selection (0, FRAME_DISPLAY_INFO (f), dialog_id, 1); 1722 popup_get_selection (0, FRAME_DISPLAY_INFO (f), dialog_id, true);
1746 1723
1747 unbind_to (count, Qnil); 1724 unbind_to (count, Qnil);
1748 } 1725 }
@@ -1765,8 +1742,8 @@ x_dialog_show (struct frame *f, Lisp_Object title,
1765 1742
1766 /* Number of elements seen so far, before boundary. */ 1743 /* Number of elements seen so far, before boundary. */
1767 int left_count = 0; 1744 int left_count = 0;
1768 /* 1 means we've seen the boundary between left-hand elts and right-hand. */ 1745 /* Whether we've seen the boundary between left-hand elts and right-hand. */
1769 int boundary_seen = 0; 1746 bool boundary_seen = false;
1770 1747
1771 ptrdiff_t specpdl_count = SPECPDL_INDEX (); 1748 ptrdiff_t specpdl_count = SPECPDL_INDEX ();
1772 1749
@@ -1813,7 +1790,7 @@ x_dialog_show (struct frame *f, Lisp_Object title,
1813 { 1790 {
1814 /* This is the boundary between left-side elts 1791 /* This is the boundary between left-side elts
1815 and right-side elts. Stop incrementing right_count. */ 1792 and right-side elts. Stop incrementing right_count. */
1816 boundary_seen = 1; 1793 boundary_seen = true;
1817 i++; 1794 i++;
1818 continue; 1795 continue;
1819 } 1796 }
@@ -2099,7 +2076,7 @@ x_menu_show (struct frame *f, int x, int y, int menuflags,
2099 if ((menuflags & MENU_KEYMAPS) && !NILP (prefix)) 2076 if ((menuflags & MENU_KEYMAPS) && !NILP (prefix))
2100 pane_string++; 2077 pane_string++;
2101 2078
2102 lpane = XMenuAddPane (FRAME_X_DISPLAY (f), menu, pane_string, TRUE); 2079 lpane = XMenuAddPane (FRAME_X_DISPLAY (f), menu, pane_string, true);
2103 if (lpane == XM_FAILURE) 2080 if (lpane == XM_FAILURE)
2104 { 2081 {
2105 XMenuDestroy (FRAME_X_DISPLAY (f), menu); 2082 XMenuDestroy (FRAME_X_DISPLAY (f), menu);
@@ -2224,8 +2201,8 @@ x_menu_show (struct frame *f, int x, int y, int menuflags,
2224 y += 1.5*height/(maxlines+2); 2201 y += 1.5*height/(maxlines+2);
2225 } 2202 }
2226 2203
2227 XMenuSetAEQ (menu, TRUE); 2204 XMenuSetAEQ (menu, true);
2228 XMenuSetFreeze (menu, TRUE); 2205 XMenuSetFreeze (menu, true);
2229 pane = selidx = 0; 2206 pane = selidx = 0;
2230 2207
2231#ifndef MSDOS 2208#ifndef MSDOS
diff --git a/src/xml.c b/src/xml.c
index 3e64788f822..e32417724ce 100644
--- a/src/xml.c
+++ b/src/xml.c
@@ -43,14 +43,12 @@ DEF_DLL_FN (void, xmlFreeDoc, (xmlDocPtr));
43DEF_DLL_FN (void, xmlCleanupParser, (void)); 43DEF_DLL_FN (void, xmlCleanupParser, (void));
44DEF_DLL_FN (void, xmlCheckVersion, (int)); 44DEF_DLL_FN (void, xmlCheckVersion, (int));
45 45
46static int 46static bool
47libxml2_loaded_p (void) 47libxml2_loaded_p (void)
48{ 48{
49 Lisp_Object found = Fassq (Qlibxml2_dll, Vlibrary_cache); 49 Lisp_Object found = Fassq (Qlibxml2_dll, Vlibrary_cache);
50 50
51 if (CONSP (found)) 51 return CONSP (found) && EQ (XCDR (found), Qt);
52 return EQ (XCDR (found), Qt) ? 1 : 0;
53 return 0;
54} 52}
55 53
56# undef htmlReadMemory 54# undef htmlReadMemory
@@ -81,20 +79,20 @@ load_dll_functions (HMODULE library)
81 79
82#else /* !WINDOWSNT */ 80#else /* !WINDOWSNT */
83 81
84static int 82static bool
85libxml2_loaded_p (void) 83libxml2_loaded_p (void)
86{ 84{
87 return 1; 85 return true;
88} 86}
89 87
90#endif /* !WINDOWSNT */ 88#endif /* !WINDOWSNT */
91 89
92static int 90static bool
93init_libxml2_functions (void) 91init_libxml2_functions (void)
94{ 92{
95#ifdef WINDOWSNT 93#ifdef WINDOWSNT
96 if (libxml2_loaded_p ()) 94 if (libxml2_loaded_p ())
97 return 1; 95 return true;
98 else 96 else
99 { 97 {
100 HMODULE library; 98 HMODULE library;
@@ -102,22 +100,22 @@ init_libxml2_functions (void)
102 if (!(library = w32_delayed_load (Qlibxml2_dll))) 100 if (!(library = w32_delayed_load (Qlibxml2_dll)))
103 { 101 {
104 message1 ("libxml2 library not found"); 102 message1 ("libxml2 library not found");
105 return 0; 103 return false;
106 } 104 }
107 105
108 if (! load_dll_functions (library)) 106 if (! load_dll_functions (library))
109 goto bad_library; 107 goto bad_library;
110 108
111 Vlibrary_cache = Fcons (Fcons (Qlibxml2_dll, Qt), Vlibrary_cache); 109 Vlibrary_cache = Fcons (Fcons (Qlibxml2_dll, Qt), Vlibrary_cache);
112 return 1; 110 return true;
113 } 111 }
114 112
115 bad_library: 113 bad_library:
116 Vlibrary_cache = Fcons (Fcons (Qlibxml2_dll, Qnil), Vlibrary_cache); 114 Vlibrary_cache = Fcons (Fcons (Qlibxml2_dll, Qnil), Vlibrary_cache);
117 115
118 return 0; 116 return false;
119#else /* !WINDOWSNT */ 117#else /* !WINDOWSNT */
120 return 1; 118 return true;
121#endif /* !WINDOWSNT */ 119#endif /* !WINDOWSNT */
122} 120}
123 121
@@ -177,7 +175,8 @@ make_dom (xmlNode *node)
177} 175}
178 176
179static Lisp_Object 177static Lisp_Object
180parse_region (Lisp_Object start, Lisp_Object end, Lisp_Object base_url, Lisp_Object discard_comments, int htmlp) 178parse_region (Lisp_Object start, Lisp_Object end, Lisp_Object base_url,
179 Lisp_Object discard_comments, bool htmlp)
181{ 180{
182 xmlDoc *doc; 181 xmlDoc *doc;
183 Lisp_Object result = Qnil; 182 Lisp_Object result = Qnil;
@@ -263,7 +262,7 @@ If DISCARD-COMMENTS is non-nil, all HTML comments are discarded. */)
263 (Lisp_Object start, Lisp_Object end, Lisp_Object base_url, Lisp_Object discard_comments) 262 (Lisp_Object start, Lisp_Object end, Lisp_Object base_url, Lisp_Object discard_comments)
264{ 263{
265 if (init_libxml2_functions ()) 264 if (init_libxml2_functions ())
266 return parse_region (start, end, base_url, discard_comments, 1); 265 return parse_region (start, end, base_url, discard_comments, true);
267 return Qnil; 266 return Qnil;
268} 267}
269 268
@@ -276,7 +275,7 @@ If DISCARD-COMMENTS is non-nil, all HTML comments are discarded. */)
276 (Lisp_Object start, Lisp_Object end, Lisp_Object base_url, Lisp_Object discard_comments) 275 (Lisp_Object start, Lisp_Object end, Lisp_Object base_url, Lisp_Object discard_comments)
277{ 276{
278 if (init_libxml2_functions ()) 277 if (init_libxml2_functions ())
279 return parse_region (start, end, base_url, discard_comments, 0); 278 return parse_region (start, end, base_url, discard_comments, false);
280 return Qnil; 279 return Qnil;
281} 280}
282 281
diff --git a/src/xrdb.c b/src/xrdb.c
index f1176daa5ee..9e85e5a6277 100644
--- a/src/xrdb.c
+++ b/src/xrdb.c
@@ -667,7 +667,7 @@ main (int argc, char **argv)
667 /* In a real program, you'd want to also do this: */ 667 /* In a real program, you'd want to also do this: */
668 display->db = xdb; 668 display->db = xdb;
669 669
670 while (1) 670 while (true)
671 { 671 {
672 char query_name[90]; 672 char query_name[90];
673 char query_class[90]; 673 char query_class[90];
diff --git a/src/xsettings.c b/src/xsettings.c
index 8dbc7d990fe..028487b91ee 100644
--- a/src/xsettings.c
+++ b/src/xsettings.c
@@ -804,7 +804,7 @@ init_gsettings (void)
804 GSettingsSchema *sc = g_settings_schema_source_lookup 804 GSettingsSchema *sc = g_settings_schema_source_lookup
805 (g_settings_schema_source_get_default (), 805 (g_settings_schema_source_get_default (),
806 GSETTINGS_SCHEMA, 806 GSETTINGS_SCHEMA,
807 TRUE); 807 true);
808 schema_found = sc != NULL; 808 schema_found = sc != NULL;
809 if (sc) g_settings_schema_unref (sc); 809 if (sc) g_settings_schema_unref (sc);
810 } 810 }
diff --git a/src/xterm.c b/src/xterm.c
index 9a87a1ee49c..40043dc9430 100644
--- a/src/xterm.c
+++ b/src/xterm.c
@@ -3051,7 +3051,7 @@ XTflash (struct frame *f)
3051 gc = gdk_gc_new_with_values (window, 3051 gc = gdk_gc_new_with_values (window,
3052 &vals, GDK_GC_FUNCTION | GDK_GC_FOREGROUND); 3052 &vals, GDK_GC_FUNCTION | GDK_GC_FOREGROUND);
3053#define XFillRectangle(d, win, gc, x, y, w, h) \ 3053#define XFillRectangle(d, win, gc, x, y, w, h) \
3054 gdk_draw_rectangle (window, gc, TRUE, x, y, w, h) 3054 gdk_draw_rectangle (window, gc, true, x, y, w, h)
3055#endif /* ! HAVE_GTK3 */ 3055#endif /* ! HAVE_GTK3 */
3056#else /* ! USE_GTK */ 3056#else /* ! USE_GTK */
3057 GC gc; 3057 GC gc;
@@ -4604,7 +4604,7 @@ xg_scroll_callback (GtkRange *range,
4604 GtkAdjustment *adj = GTK_ADJUSTMENT (gtk_range_get_adjustment (range)); 4604 GtkAdjustment *adj = GTK_ADJUSTMENT (gtk_range_get_adjustment (range));
4605 struct frame *f = g_object_get_data (G_OBJECT (range), XG_FRAME_DATA); 4605 struct frame *f = g_object_get_data (G_OBJECT (range), XG_FRAME_DATA);
4606 4606
4607 if (xg_ignore_gtk_scrollbar) return FALSE; 4607 if (xg_ignore_gtk_scrollbar) return false;
4608 4608
4609 switch (scroll) 4609 switch (scroll)
4610 { 4610 {
@@ -4660,7 +4660,7 @@ xg_scroll_callback (GtkRange *range,
4660 bar->horizontal); 4660 bar->horizontal);
4661 } 4661 }
4662 4662
4663 return FALSE; 4663 return false;
4664} 4664}
4665 4665
4666/* Callback for button release. Sets dragging to -1 when dragging is done. */ 4666/* Callback for button release. Sets dragging to -1 when dragging is done. */
@@ -4679,7 +4679,7 @@ xg_end_scroll_callback (GtkWidget *widget,
4679 window_being_scrolled = Qnil; 4679 window_being_scrolled = Qnil;
4680 } 4680 }
4681 4681
4682 return FALSE; 4682 return false;
4683} 4683}
4684 4684
4685 4685
diff --git a/src/xterm.h b/src/xterm.h
index f2aff72e3ac..123f31cda7b 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);
1099#endif 1099#endif
1100 1100
1101#if defined USE_GTK || defined USE_MOTIF 1101#if defined USE_GTK || defined USE_MOTIF
1102extern void x_menu_set_in_use (int); 1102extern void x_menu_set_in_use (bool);
1103#endif 1103#endif
1104extern void x_menu_wait_for_event (void *data); 1104extern void x_menu_wait_for_event (void *data);
1105extern void initialize_frame_menubar (struct frame *); 1105extern void initialize_frame_menubar (struct frame *);
diff --git a/test/ChangeLog b/test/ChangeLog
index 83bb8bf00c7..a33ec8793f4 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -1,3 +1,14 @@
12015-01-15 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * automated/eieio-test-methodinvoke.el (eieio-test-method-store): Add
4 keysym arg instead of relying on internal var eieio--generic-call-key.
5 Update all callers.
6 (eieio-test-cl-generic-1): New tests.
7
82015-01-14 Stefan Monnier <monnier@iro.umontreal.ca>
9
10 * automated/cl-generic-tests.el: New file.
11
12015-01-08 Stefan Monnier <monnier@iro.umontreal.ca> 122015-01-08 Stefan Monnier <monnier@iro.umontreal.ca>
2 13
3 * automated/eieio-tests.el (eieio-test-23-inheritance-check): Don't use 14 * 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 00000000000..17bce6a3157
--- /dev/null
+++ b/test/automated/cl-generic-tests.el
@@ -0,0 +1,133 @@
1;;; cl-generic-tests.el --- Tests for cl-generic.el functionality -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2015 Free Software Foundation, Inc.
4
5;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software: you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation, either version 3 of the License, or
12;; (at your option) any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23
24;;; Code:
25
26(require 'ert)
27(require 'cl-lib)
28
29(cl-defgeneric cl--generic-1 (x y))
30(cl-defgeneric (setf cl--generic-1) (v y z) "My generic doc.")
31
32(ert-deftest cl-generic-test-0 ()
33 (cl-defgeneric cl--generic-1 (x y))
34 (cl-defmethod cl--generic-1 ((x t) y) (cons x y))
35 (should (equal (cl--generic-1 'a 'b) '(a . b))))
36
37(ert-deftest cl-generic-test-1-eql ()
38 (cl-defgeneric cl--generic-1 (x y))
39 (cl-defmethod cl--generic-1 ((x t) y) (cons x y))
40 (cl-defmethod cl--generic-1 ((_x (eql 4)) _y)
41 (cons "quatre" (cl-call-next-method)))
42 (cl-defmethod cl--generic-1 ((_x (eql 5)) _y)
43 (cons "cinq" (cl-call-next-method)))
44 (cl-defmethod cl--generic-1 ((_x (eql 6)) y)
45 (cons "six" (cl-call-next-method 'a y)))
46 (should (equal (cl--generic-1 'a nil) '(a)))
47 (should (equal (cl--generic-1 4 nil) '("quatre" 4)))
48 (should (equal (cl--generic-1 5 nil) '("cinq" 5)))
49 (should (equal (cl--generic-1 6 nil) '("six" a))))
50
51(cl-defstruct cl-generic-struct-parent a b)
52(cl-defstruct (cl-generic-struct-child1 (:include cl-generic-struct-parent)) c)
53(cl-defstruct (cl-generic-struct-child11 (:include cl-generic-struct-child1)) d)
54(cl-defstruct (cl-generic-struct-child2 (:include cl-generic-struct-parent)) e)
55
56(ert-deftest cl-generic-test-2-struct ()
57 (cl-defgeneric cl--generic-1 (x y) "My doc.")
58 (cl-defmethod cl--generic-1 ((x t) y) "Doc 1." (cons x y))
59 (cl-defmethod cl--generic-1 ((_x cl-generic-struct-parent) y)
60 "Doc 2." (cons "parent" (cl-call-next-method 'a y)))
61 (cl-defmethod cl--generic-1 ((_x cl-generic-struct-child1) _y)
62 (cons "child1" (cl-call-next-method)))
63 (cl-defmethod cl--generic-1 :around ((_x t) _y)
64 (cons "around" (cl-call-next-method)))
65 (cl-defmethod cl--generic-1 :around ((_x cl-generic-struct-child11) _y)
66 (cons "child11" (cl-call-next-method)))
67 (cl-defmethod cl--generic-1 ((_x cl-generic-struct-child2) _y)
68 (cons "child2" (cl-call-next-method)))
69 (should (equal (cl--generic-1 (make-cl-generic-struct-child1) nil)
70 '("around" "child1" "parent" a)))
71 (should (equal (cl--generic-1 (make-cl-generic-struct-child2) nil)
72 '("around""child2" "parent" a)))
73 (should (equal (cl--generic-1 (make-cl-generic-struct-child11) nil)
74 '("child11" "around""child1" "parent" a))))
75
76(ert-deftest cl-generic-test-3-setf ()
77 (cl-defmethod (setf cl--generic-1) (v (y t) z) (list v y z))
78 (cl-defmethod (setf cl--generic-1) (v (_y (eql 4)) z) (list v "four" z))
79 (should (equal (setf (cl--generic-1 'a 'b) 'v) '(v a b)))
80 (should (equal (setf (cl--generic-1 4 'b) 'v) '(v "four" b)))
81 (let ((x ()))
82 (should (equal (setf (cl--generic-1 (progn (push 1 x) 'a)
83 (progn (push 2 x) 'b))
84 (progn (push 3 x) 'v))
85 '(v a b)))
86 (should (equal x '(3 2 1)))))
87
88(ert-deftest cl-generic-test-4-overlapping-tagcodes ()
89 (cl-defgeneric cl--generic-1 (x y) "My doc.")
90 (cl-defmethod cl--generic-1 ((y t) z) (list y z))
91 (cl-defmethod cl--generic-1 ((_y (eql 4)) _z)
92 (cons "four" (cl-call-next-method)))
93 (cl-defmethod cl--generic-1 ((_y integer) _z)
94 (cons "integer" (cl-call-next-method)))
95 (cl-defmethod cl--generic-1 ((_y number) _z)
96 (cons "number" (cl-call-next-method)))
97 (should (equal (cl--generic-1 'a 'b) '(a b)))
98 (should (equal (cl--generic-1 1 'b) '("integer" "number" 1 b)))
99 (should (equal (cl--generic-1 4 'b) '("four" "integer" "number" 4 b))))
100
101(ert-deftest cl-generic-test-5-alias ()
102 (cl-defgeneric cl--generic-1 (x y) "My doc.")
103 (defalias 'cl--generic-2 #'cl--generic-1)
104 (cl-defmethod cl--generic-1 ((y t) z) (list y z))
105 (cl-defmethod cl--generic-2 ((_y (eql 4)) _z)
106 (cons "four" (cl-call-next-method)))
107 (should (equal (cl--generic-1 4 'b) '("four" 4 b))))
108
109(ert-deftest cl-generic-test-6-multiple-dispatch ()
110 (cl-defgeneric cl--generic-1 (x y) "My doc.")
111 (cl-defmethod cl--generic-1 (x y) (list x y))
112 (cl-defmethod cl--generic-1 (_x (_y integer))
113 (cons "y-int" (cl-call-next-method)))
114 (cl-defmethod cl--generic-1 ((_x integer) _y)
115 (cons "x-int" (cl-call-next-method)))
116 (cl-defmethod cl--generic-1 ((_x integer) (_y integer))
117 (cons "x&y-int" (cl-call-next-method)))
118 (should (equal (cl--generic-1 1 2) '("x&y-int" "x-int" "y-int" 1 2))))
119
120(ert-deftest cl-generic-test-7-apo ()
121 (cl-defgeneric cl--generic-1 (x y)
122 (:documentation "My doc.") (:argument-precedence-order y x))
123 (cl-defmethod cl--generic-1 (x y) (list x y))
124 (cl-defmethod cl--generic-1 (_x (_y integer))
125 (cons "y-int" (cl-call-next-method)))
126 (cl-defmethod cl--generic-1 ((_x integer) _y)
127 (cons "x-int" (cl-call-next-method)))
128 (cl-defmethod cl--generic-1 ((_x integer) (_y integer))
129 (cons "x&y-int" (cl-call-next-method)))
130 (should (equal (cl--generic-1 1 2) '("x&y-int" "y-int" "x-int" 1 2))))
131
132(provide 'cl-generic-tests)
133;;; cl-generic-tests.el ends here
diff --git a/test/automated/eieio-test-methodinvoke.el b/test/automated/eieio-test-methodinvoke.el
index 2de836ceda5..6362fc5a8d9 100644
--- a/test/automated/eieio-test-methodinvoke.el
+++ b/test/automated/eieio-test-methodinvoke.el
@@ -58,12 +58,10 @@
58(defvar eieio-test-method-order-list nil 58(defvar eieio-test-method-order-list nil
59 "List of symbols stored during method invocation.") 59 "List of symbols stored during method invocation.")
60 60
61(defun eieio-test-method-store () 61(defun eieio-test-method-store (keysym)
62 "Store current invocation class symbol in the invocation order list." 62 "Store current invocation class symbol in the invocation order list."
63 (let* ((keysym (aref [ :STATIC :BEFORE :PRIMARY :AFTER ] 63 ;; FIXME: Don't depend on `eieio--scoped-class'!
64 (or eieio--generic-call-key 0))) 64 (let* ((c (list keysym (eieio--class-symbol (eieio--scoped-class)))))
65 ;; FIXME: Don't depend on `eieio--scoped-class'!
66 (c (list keysym (eieio--class-symbol (eieio--scoped-class)))))
67 (push c eieio-test-method-order-list))) 65 (push c eieio-test-method-order-list)))
68 66
69(defun eieio-test-match (rightanswer) 67(defun eieio-test-match (rightanswer)
@@ -88,36 +86,36 @@
88(defclass eitest-B (eitest-B-base1 eitest-B-base2) ()) 86(defclass eitest-B (eitest-B-base1 eitest-B-base2) ())
89 87
90(defmethod eitest-F :BEFORE ((p eitest-B-base1)) 88(defmethod eitest-F :BEFORE ((p eitest-B-base1))
91 (eieio-test-method-store)) 89 (eieio-test-method-store :BEFORE))
92 90
93(defmethod eitest-F :BEFORE ((p eitest-B-base2)) 91(defmethod eitest-F :BEFORE ((p eitest-B-base2))
94 (eieio-test-method-store)) 92 (eieio-test-method-store :BEFORE))
95 93
96(defmethod eitest-F :BEFORE ((p eitest-B)) 94(defmethod eitest-F :BEFORE ((p eitest-B))
97 (eieio-test-method-store)) 95 (eieio-test-method-store :BEFORE))
98 96
99(defmethod eitest-F ((p eitest-B)) 97(defmethod eitest-F ((p eitest-B))
100 (eieio-test-method-store) 98 (eieio-test-method-store :PRIMARY)
101 (call-next-method)) 99 (call-next-method))
102 100
103(defmethod eitest-F ((p eitest-B-base1)) 101(defmethod eitest-F ((p eitest-B-base1))
104 (eieio-test-method-store) 102 (eieio-test-method-store :PRIMARY)
105 (call-next-method)) 103 (call-next-method))
106 104
107(defmethod eitest-F ((p eitest-B-base2)) 105(defmethod eitest-F ((p eitest-B-base2))
108 (eieio-test-method-store) 106 (eieio-test-method-store :PRIMARY)
109 (when (next-method-p) 107 (when (next-method-p)
110 (call-next-method)) 108 (call-next-method))
111 ) 109 )
112 110
113(defmethod eitest-F :AFTER ((p eitest-B-base1)) 111(defmethod eitest-F :AFTER ((p eitest-B-base1))
114 (eieio-test-method-store)) 112 (eieio-test-method-store :AFTER))
115 113
116(defmethod eitest-F :AFTER ((p eitest-B-base2)) 114(defmethod eitest-F :AFTER ((p eitest-B-base2))
117 (eieio-test-method-store)) 115 (eieio-test-method-store :AFTER))
118 116
119(defmethod eitest-F :AFTER ((p eitest-B)) 117(defmethod eitest-F :AFTER ((p eitest-B))
120 (eieio-test-method-store)) 118 (eieio-test-method-store :AFTER))
121 119
122(ert-deftest eieio-test-method-order-list-3 () 120(ert-deftest eieio-test-method-order-list-3 ()
123 (let ((eieio-test-method-order-list nil) 121 (let ((eieio-test-method-order-list nil)
@@ -152,15 +150,15 @@
152;;; Return value from :PRIMARY 150;;; Return value from :PRIMARY
153;; 151;;
154(defmethod eitest-I :BEFORE ((a eitest-A)) 152(defmethod eitest-I :BEFORE ((a eitest-A))
155 (eieio-test-method-store) 153 (eieio-test-method-store :BEFORE)
156 ":before") 154 ":before")
157 155
158(defmethod eitest-I :PRIMARY ((a eitest-A)) 156(defmethod eitest-I :PRIMARY ((a eitest-A))
159 (eieio-test-method-store) 157 (eieio-test-method-store :PRIMARY)
160 ":primary") 158 ":primary")
161 159
162(defmethod eitest-I :AFTER ((a eitest-A)) 160(defmethod eitest-I :AFTER ((a eitest-A))
163 (eieio-test-method-store) 161 (eieio-test-method-store :AFTER)
164 ":after") 162 ":after")
165 163
166(ert-deftest eieio-test-method-order-list-5 () 164(ert-deftest eieio-test-method-order-list-5 ()
@@ -179,17 +177,17 @@
179 177
180;; Just use the obsolete name once, to make sure it also works. 178;; Just use the obsolete name once, to make sure it also works.
181(defmethod constructor :STATIC ((p C-base1) &rest args) 179(defmethod constructor :STATIC ((p C-base1) &rest args)
182 (eieio-test-method-store) 180 (eieio-test-method-store :STATIC)
183 (if (next-method-p) (call-next-method)) 181 (if (next-method-p) (call-next-method))
184 ) 182 )
185 183
186(defmethod eieio-constructor :STATIC ((p C-base2) &rest args) 184(defmethod eieio-constructor :STATIC ((p C-base2) &rest args)
187 (eieio-test-method-store) 185 (eieio-test-method-store :STATIC)
188 (if (next-method-p) (call-next-method)) 186 (if (next-method-p) (call-next-method))
189 ) 187 )
190 188
191(defmethod eieio-constructor :STATIC ((p C) &rest args) 189(defmethod eieio-constructor :STATIC ((p C) &rest args)
192 (eieio-test-method-store) 190 (eieio-test-method-store :STATIC)
193 (call-next-method) 191 (call-next-method)
194 ) 192 )
195 193
@@ -216,24 +214,24 @@
216 214
217(defmethod eitest-F ((p D)) 215(defmethod eitest-F ((p D))
218 "D" 216 "D"
219 (eieio-test-method-store) 217 (eieio-test-method-store :PRIMARY)
220 (call-next-method)) 218 (call-next-method))
221 219
222(defmethod eitest-F ((p D-base0)) 220(defmethod eitest-F ((p D-base0))
223 "D-base0" 221 "D-base0"
224 (eieio-test-method-store) 222 (eieio-test-method-store :PRIMARY)
225 ;; This should have no next 223 ;; This should have no next
226 ;; (when (next-method-p) (call-next-method)) 224 ;; (when (next-method-p) (call-next-method))
227 ) 225 )
228 226
229(defmethod eitest-F ((p D-base1)) 227(defmethod eitest-F ((p D-base1))
230 "D-base1" 228 "D-base1"
231 (eieio-test-method-store) 229 (eieio-test-method-store :PRIMARY)
232 (call-next-method)) 230 (call-next-method))
233 231
234(defmethod eitest-F ((p D-base2)) 232(defmethod eitest-F ((p D-base2))
235 "D-base2" 233 "D-base2"
236 (eieio-test-method-store) 234 (eieio-test-method-store :PRIMARY)
237 (when (next-method-p) 235 (when (next-method-p)
238 (call-next-method)) 236 (call-next-method))
239 ) 237 )
@@ -258,21 +256,21 @@
258(defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first) 256(defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first)
259 257
260(defmethod eitest-F ((p E)) 258(defmethod eitest-F ((p E))
261 (eieio-test-method-store) 259 (eieio-test-method-store :PRIMARY)
262 (call-next-method)) 260 (call-next-method))
263 261
264(defmethod eitest-F ((p E-base0)) 262(defmethod eitest-F ((p E-base0))
265 (eieio-test-method-store) 263 (eieio-test-method-store :PRIMARY)
266 ;; This should have no next 264 ;; This should have no next
267 ;; (when (next-method-p) (call-next-method)) 265 ;; (when (next-method-p) (call-next-method))
268 ) 266 )
269 267
270(defmethod eitest-F ((p E-base1)) 268(defmethod eitest-F ((p E-base1))
271 (eieio-test-method-store) 269 (eieio-test-method-store :PRIMARY)
272 (call-next-method)) 270 (call-next-method))
273 271
274(defmethod eitest-F ((p E-base2)) 272(defmethod eitest-F ((p E-base2))
275 (eieio-test-method-store) 273 (eieio-test-method-store :PRIMARY)
276 (when (next-method-p) 274 (when (next-method-p)
277 (call-next-method)) 275 (call-next-method))
278 ) 276 )
@@ -380,3 +378,21 @@
380 '(CNM-1-1 CNM-2 INIT))) 378 '(CNM-1-1 CNM-2 INIT)))
381 (should (equal (eieio-test-arguments-for 'CNM-2) 379 (should (equal (eieio-test-arguments-for 'CNM-2)
382 '(INIT))))) 380 '(INIT)))))
381
382;;; Check cl-generic integration.
383
384(cl-defgeneric eieio-test--1 (x y))
385
386(ert-deftest eieio-test-cl-generic-1 ()
387 (cl-defmethod eieio-test--1 (x y) (list x y))
388 (cl-defmethod eieio-test--1 ((_x CNM-0) y)
389 (cons "CNM-0" (cl-call-next-method 7 y)))
390 (cl-defmethod eieio-test--1 ((_x CNM-1-1) _y)
391 (cons "CNM-1-1" (cl-call-next-method)))
392 (cl-defmethod eieio-test--1 ((_x CNM-1-2) y)
393 (cons "CNM-1-2" (cl-call-next-method)))
394 (should (equal (eieio-test--1 4 5) '(4 5)))
395 (should (equal (eieio-test--1 (make-instance 'CNM-0) 5)
396 '("CNM-0" 7 5)))
397 (should (equal (eieio-test--1 (make-instance 'CNM-2) 5)
398 '("CNM-1-1" "CNM-1-2" "CNM-0" 7 5))))