commit c452ffe4c28da21991f1f98007fbe1d66c7e0538 (HEAD, refs/remotes/origin/master) Author: Po Lu Date: Fri Dec 31 07:29:30 2021 +0000 Prevent double buffering from being disabled on USE_BE_CAIRO builds The direct rendering code used in that situation never completely worked, and the BDirectWindow destructor is also buggy. Completely remove that code in order to let us inherit from BWindow, so as to prevent the buggy destructor from being run. * src/haiku_support.cc (cairo_format_from_color_space): Delete function. (class EmacsWindow): Inherit from BWindow. (EmacsWindow): Call BWindow constructor instead. (MessageReceived): (DispatchMessage): (FrameResized): (FrameMoved): (Zoom): Call BWindow functions instead. (EmacsView_cairo_surface): Stop looking for surfaces in the window. (EmacsWindow_begin_cr_critical_section): (EmacsWindow_end_cr_critical_section): Stop locking the window. * src/haikufns.c (haiku_set_inhibit_double_buffering): Always enable double buffering on Cairo builds. diff --git a/src/haiku_support.cc b/src/haiku_support.cc index b8f6e84d2c..d211f1157d 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -104,28 +104,6 @@ gui_abort (const char *msg) emacs_abort (); } -#ifdef USE_BE_CAIRO -static cairo_format_t -cairo_format_from_color_space (color_space space) -{ - switch (space) - { - case B_RGBA32: - return CAIRO_FORMAT_ARGB32; - case B_RGB32: - return CAIRO_FORMAT_RGB24; - case B_RGB16: - return CAIRO_FORMAT_RGB16_565; - case B_GRAY8: - return CAIRO_FORMAT_A8; - case B_GRAY1: - return CAIRO_FORMAT_A1; - default: - gui_abort ("Unsupported color space"); - } -} -#endif - static void map_key (char *chars, int32 offset, uint32_t *c) { @@ -242,7 +220,7 @@ class Emacs : public BApplication } }; -class EmacsWindow : public BDirectWindow +class EmacsWindow : public BWindow { public: struct child_frame @@ -261,13 +239,8 @@ class EmacsWindow : public BDirectWindow int zoomed_p = 0; int shown_flag = 0; -#ifdef USE_BE_CAIRO - BLocker surface_lock; - cairo_surface_t *cr_surface = NULL; -#endif - - EmacsWindow () : BDirectWindow (BRect (0, 0, 0, 0), "", B_TITLED_WINDOW_LOOK, - B_NORMAL_WINDOW_FEEL, B_NO_SERVER_SIDE_WINDOW_MODIFIERS) + EmacsWindow () : BWindow (BRect (0, 0, 0, 0), "", B_TITLED_WINDOW_LOOK, + B_NORMAL_WINDOW_FEEL, B_NO_SERVER_SIDE_WINDOW_MODIFIERS) { } @@ -284,17 +257,6 @@ class EmacsWindow : public BDirectWindow if (this->parent) UnparentAndUnlink (); - -#ifdef USE_BE_CAIRO - if (!surface_lock.Lock ()) - gui_abort ("Failed to lock cairo surface"); - if (cr_surface) - { - cairo_surface_destroy (cr_surface); - cr_surface = NULL; - } - surface_lock.Unlock (); -#endif } void @@ -457,43 +419,6 @@ class EmacsWindow : public BDirectWindow haiku_write (ACTIVATION, &rq); } - void - DirectConnected (direct_buffer_info *info) - { -#ifdef USE_BE_CAIRO - if (!surface_lock.Lock ()) - gui_abort ("Failed to lock window direct cr surface"); - if (cr_surface) - { - cairo_surface_destroy (cr_surface); - cr_surface = NULL; - } - - if (info->buffer_state != B_DIRECT_STOP) - { - int left, top, right, bottom; - left = info->clip_bounds.left; - top = info->clip_bounds.top; - right = info->clip_bounds.right; - bottom = info->clip_bounds.bottom; - - unsigned char *bits = (unsigned char *) info->bits; - if ((info->bits_per_pixel % 8) == 0) - { - bits += info->bytes_per_row * top; - bits += (left * info->bits_per_pixel / 8); - cr_surface = cairo_image_surface_create_for_data - (bits, - cairo_format_from_color_space (info->pixel_format), - right - left + 1, - bottom - top + 1, - info->bytes_per_row); - } - } - surface_lock.Unlock (); -#endif - } - void MessageReceived (BMessage *msg) { @@ -567,7 +492,7 @@ class EmacsWindow : public BDirectWindow haiku_write (FILE_PANEL_EVENT, &rq); } else - BDirectWindow::MessageReceived (msg); + BWindow::MessageReceived (msg); } void @@ -638,7 +563,7 @@ class EmacsWindow : public BDirectWindow }; } else - BDirectWindow::DispatchMessage (msg, handler); + BWindow::DispatchMessage (msg, handler); } void @@ -668,7 +593,7 @@ class EmacsWindow : public BDirectWindow rq.px_widthf = newWidth + 1.0f; haiku_write (FRAME_RESIZED, &rq); - BDirectWindow::FrameResized (newWidth, newHeight); + BWindow::FrameResized (newWidth, newHeight); } void @@ -684,7 +609,7 @@ class EmacsWindow : public BDirectWindow for (struct child_frame *f = subset_windows; f; f = f->next) DoMove (f); - BDirectWindow::FrameMoved (newPosition); + BWindow::FrameMoved (newPosition); } void @@ -716,7 +641,7 @@ class EmacsWindow : public BDirectWindow void Minimize (bool minimized_p) { - BDirectWindow::Minimize (minimized_p); + BWindow::Minimize (minimized_p); struct haiku_iconification_event rq; rq.window = this; rq.iconified_p = !parent && minimized_p; @@ -776,7 +701,7 @@ class EmacsWindow : public BDirectWindow x_before_zoom = y_before_zoom = INT_MIN; } - BDirectWindow::Zoom (o, w, h); + BWindow::Zoom (o, w, h); } void @@ -2816,8 +2741,7 @@ cairo_surface_t * EmacsView_cairo_surface (void *view) { EmacsView *vw = (EmacsView *) view; - EmacsWindow *wn = (EmacsWindow *) vw->Window (); - return vw->cr_surface ? vw->cr_surface : wn->cr_surface; + return vw->cr_surface; } /* Transfer each clip rectangle in VIEW to the cairo context @@ -2843,10 +2767,7 @@ BView_cr_dump_clipping (void *view, cairo_t *ctx) void EmacsWindow_begin_cr_critical_section (void *window) { - EmacsWindow *w = (EmacsWindow *) window; - if (!w->surface_lock.Lock ()) - gui_abort ("Couldn't lock cairo surface"); - + BWindow *w = (BWindow *) window; BView *vw = (BView *) w->FindView ("Emacs"); EmacsView *ev = dynamic_cast (vw); if (ev && !ev->cr_surface_lock.Lock ()) @@ -2857,8 +2778,7 @@ EmacsWindow_begin_cr_critical_section (void *window) void EmacsWindow_end_cr_critical_section (void *window) { - EmacsWindow *w = (EmacsWindow *) window; - w->surface_lock.Unlock (); + BWindow *w = (BWindow *) window; BView *vw = (BView *) w->FindView ("Emacs"); EmacsView *ev = dynamic_cast (vw); if (ev) diff --git a/src/haikufns.c b/src/haikufns.c index 737b033899..b9198e9d44 100644 --- a/src/haikufns.c +++ b/src/haikufns.c @@ -1510,20 +1510,24 @@ haiku_set_inhibit_double_buffering (struct frame *f, Lisp_Object old_value) { block_input (); +#ifndef USE_BE_CAIRO if (FRAME_HAIKU_WINDOW (f)) { if (NILP (new_value)) { +#endif EmacsView_set_up_double_buffering (FRAME_HAIKU_VIEW (f)); if (!NILP (old_value)) { SET_FRAME_GARBAGED (f); expose_frame (f, 0, 0, 0, 0); } +#ifndef USE_BE_CAIRO } else EmacsView_disable_double_buffering (FRAME_HAIKU_VIEW (f)); } +#endif unblock_input (); } commit 080a529f7e9c1a750f39d92f1e8f1e7170d6fb81 Author: Po Lu Date: Fri Dec 31 14:04:40 2021 +0800 Don't select for gesture events on xwidgets if the server is too old * src/xwidget.c (x_draw_xwidget_glyph_string): Only select for XI gesture events if the server supports XI 2.4 or later. diff --git a/src/xwidget.c b/src/xwidget.c index 4f14152833..36f216d939 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -2247,9 +2247,12 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) XISetMask (m, XI_Enter); XISetMask (m, XI_Leave); #ifdef XI_GesturePinchBegin - XISetMask (m, XI_GesturePinchBegin); - XISetMask (m, XI_GesturePinchUpdate); - XISetMask (m, XI_GesturePinchEnd); + if (FRAME_DISPLAY_INFO (s->f)->xi2_version >= 4) + { + XISetMask (m, XI_GesturePinchBegin); + XISetMask (m, XI_GesturePinchUpdate); + XISetMask (m, XI_GesturePinchEnd); + } #endif XISelectEvents (xv->dpy, xv->wdesc, &mask, 1); } commit 291085a2a61d7596e6f3e3152247198fdf85da26 Author: Stefan Monnier Date: Fri Dec 31 00:16:03 2021 -0500 (Fmake_finalizer): Check the arg is a function * src/eval.c (syms_of_eval): Add `Qfunctionp`. * src/alloc.c (Fmake_finalizer): Check the arg is a function. diff --git a/src/alloc.c b/src/alloc.c index 16f9076b03..d82af1980a 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3888,6 +3888,7 @@ count as reachable for the purpose of deciding whether to run FUNCTION. FUNCTION will be run once per finalizer object. */) (Lisp_Object function) { + CHECK_TYPE (FUNCTIONP (function), Qfunctionp, function); struct Lisp_Finalizer *finalizer = ALLOCATE_PSEUDOVECTOR (struct Lisp_Finalizer, function, PVEC_FINALIZER); finalizer->function = function; diff --git a/src/eval.c b/src/eval.c index ddf455e4d7..83ec3eab11 100644 --- a/src/eval.c +++ b/src/eval.c @@ -4594,5 +4594,6 @@ alist of active lexical bindings. */); defsubr (&Sbacktrace_eval); defsubr (&Sbacktrace__locals); defsubr (&Sspecial_variable_p); + DEFSYM (Qfunctionp, "functionp"); defsubr (&Sfunctionp); } commit 87f7412418ff2e4b2fe29d921aa6583b0b17bc29 Author: Stefan Monnier Date: Fri Dec 31 00:03:35 2021 -0500 * lisp/emacs-lisp/package.el (package-get-version): Add fallback diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index de4cebccca..7b90e361bd 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4076,7 +4076,9 @@ The list is displayed in a buffer named `*Packages*'." "Return the version number of the package in which this is used. Assumes it is used from an Elisp file placed inside the top-level directory of an installed ELPA package. -The return value is a string (or nil in case we can't find it)." +The return value is a string (or nil in case we can't find it). +It works in more cases if the call is in the file which contains +the `Version:' header." ;; In a sense, this is a lie, but it does just what we want: precompute ;; the version at compile time and hardcodes it into the .elc file! (declare (pure t)) @@ -4095,6 +4097,7 @@ The return value is a string (or nil in case we can't find it)." (let* ((pkgdir (file-name-directory file)) (pkgname (file-name-nondirectory (directory-file-name pkgdir))) (mainfile (expand-file-name (concat pkgname ".el") pkgdir))) + (unless (file-readable-p mainfile) (setq mainfile file)) (when (file-readable-p mainfile) (require 'lisp-mnt) (with-temp-buffer commit 59732a83c8875c8986d2221600d559a24d8309cc Author: Stefan Monnier Date: Thu Dec 30 23:17:45 2021 -0500 Don't store docstrings of preloaded .el files in etc/DOC Since the location of those files changes between build time and installation time, this requires to tweak the file name used in those (#$ . NNN) references during the dump so they don't hardcode the build directory. We do it in the same way as was already done for those same file names in `load-history`, except we convert them back to absolute file names more lazily (i.e. when fetching the actual docstring rather than at startup), which requires remembering the `lisp-dir` computed at startup in the new `lisp-directory` variable. * src/Makefile.in ($(etc)/DOC): Don't scan Lisp files any more. * src/lread.c (Fload): Use relative file names for `load-file-name` when preloading for the dump, like we already did for `current-load-list`. (read_list): Don't zero-out dynamic docstring references during the preload since they won't be filled later by Snarf-documentation any more. (read1): Remove the hash-hack for doc references that were zeroed. * lisp/startup.el (lisp-directory): New variable. (command-line): Set it. * src/doc.c (get_doc_string): Use `lisp-directory` for dynamic docstring references using relative file names. (syms_of_doc): Add `Qlisp_directory`. * lib-src/make-docfile.c (scan_file): Don't handle `.el` or `.elc` files any more. (IS_SLASH): Remove macro, not used any more. (skip_white, read_lisp_symbol, search_lisp_doc_at_eol) (scan_lisp_file): Remove functions, not used any more. * doc/lispref/loading.texi (Library Search): Mention `lisp-directory`. diff --git a/doc/lispref/loading.texi b/doc/lispref/loading.texi index e4cd940ab2..3efcf055dc 100644 --- a/doc/lispref/loading.texi +++ b/doc/lispref/loading.texi @@ -291,9 +291,10 @@ a directory) or @code{nil} (which stands for the current working directory). @end defvar - When Emacs starts up, it sets up the value of @code{load-path} -in several steps. First, it initializes @code{load-path} using -default locations set when Emacs was compiled. Normally, this + When Emacs starts up, it sets up the value of @code{load-path} in +several steps. First, it looks for the directory containing its own +Lisp files, using default locations set when Emacs was compiled. +It saves this directory in @code{lisp-directory}. Normally, this is a directory something like @example @@ -307,9 +308,11 @@ Emacs. If Emacs cannot find them, it will not start correctly. If you run Emacs from the directory where it was built---that is, an executable that has not been formally installed---Emacs instead -initializes @code{load-path} using the @file{lisp} +initializes @code{lisp-directory} using the @file{lisp} directory in the directory containing the sources from which it was built. + +Emacs first initializes @code{load-path} with this @code{lisp-directory}. @c Though there should be no *.el files in builddir/lisp, so it's pointless. If you built Emacs in a separate directory from the sources, it also adds the lisp directories from the build directory. @@ -396,6 +399,14 @@ a @file{site-load.el} or @file{site-init.el} file to customize the dumped Emacs (@pxref{Building Emacs}), any changes to @code{load-path} that these files make will be lost after dumping. +@defvar lisp-directory +This variable holds a string naming the directory which holds +Emacs's own @code{.el} and @code{.elc} files. This is usually the +place where those files are located in the Emacs installation tree, +unless Emacs is run from its build directory in which case it points +to the @code{lisp} directory in source directory from which it was built. +@end defvar + @deffn Command locate-library library &optional nosuffix path interactive-call This command finds the precise file name for library @var{library}. It searches for the library in the same way @code{load} does, and the diff --git a/etc/NEWS b/etc/NEWS index bbe0aed3f7..f6ba0167e0 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -71,6 +71,11 @@ Unlike the default X and GTK build, the resulting Emacs binary will work on any underlying window system supported by GDK, such as Wayland and Broadway. +--- +** The docstrings of preloaded files are not in etc/DOC any more. +Instead, they're fetched from the corresponding '.elc' file, as was already +the case for all the non-preloaded files. + * Startup Changes in Emacs 29.1 @@ -886,6 +891,9 @@ The input must be encoded text. * Lisp Changes in Emacs 29.1 ++++ +** New variable 'lisp-directory' holds the directory of Emacs's own Lisp files. + +++ ** New facility for handling session state: 'multisession-value'. This can be used as a convenient way to store (simple) application diff --git a/lib-src/make-docfile.c b/lib-src/make-docfile.c index d17c28be90..913aa69aac 100644 --- a/lib-src/make-docfile.c +++ b/lib-src/make-docfile.c @@ -19,8 +19,8 @@ You should have received a copy of the GNU General Public License along with GNU Emacs. If not, see . */ -/* The arguments given to this program are all the C and Lisp source files - of GNU Emacs. .elc and .el and .c files are allowed. +/* The arguments given to this program are all the C files + of GNU Emacs. .c files are allowed. A .o file can also be specified; the .c file it was made from is used. This helps the makefile pass the correct list of files. Option -d DIR means change to DIR before looking for files. @@ -62,13 +62,9 @@ along with GNU Emacs. If not, see . */ Similarly, msdos defines this as sys_chdir, but we're not linking with the file where that function is defined. */ #undef chdir -#define IS_SLASH(c) ((c) == '/' || (c) == '\\' || (c) == ':') -#else /* not DOS_NT */ -#define IS_SLASH(c) ((c) == '/') #endif /* not DOS_NT */ static void scan_file (char *filename); -static void scan_lisp_file (const char *filename, const char *mode); static void scan_c_file (char *filename, const char *mode); static void scan_c_stream (FILE *infile); static void start_globals (void); @@ -238,16 +234,9 @@ put_filename (char *filename) static void scan_file (char *filename) { - ptrdiff_t len = strlen (filename); - if (!generate_globals) put_filename (filename); - if (len > 4 && !strcmp (filename + len - 4, ".elc")) - scan_lisp_file (filename, "rb"); - else if (len > 3 && !strcmp (filename + len - 3, ".el")) - scan_lisp_file (filename, "r"); - else - scan_c_file (filename, "r"); + scan_c_file (filename, "r"); } static void @@ -1225,453 +1214,4 @@ scan_c_stream (FILE *infile) fatal ("read error"); } -/* Read a file of Lisp code, compiled or interpreted. - Looks for - (defun NAME ARGS DOCSTRING ...) - (defmacro NAME ARGS DOCSTRING ...) - (defsubst NAME ARGS DOCSTRING ...) - (autoload (quote NAME) FILE DOCSTRING ...) - (defvar NAME VALUE DOCSTRING) - (defconst NAME VALUE DOCSTRING) - (fset (quote NAME) (make-byte-code ... DOCSTRING ...)) - (fset (quote NAME) #[... DOCSTRING ...]) - (defalias (quote NAME) #[... DOCSTRING ...]) - (custom-declare-variable (quote NAME) VALUE DOCSTRING ...) - starting in column zero. - (quote NAME) may appear as 'NAME as well. - - We also look for #@LENGTH CONTENTS^_ at the beginning of the line. - When we find that, we save it for the following defining-form, - and we use that instead of reading a doc string within that defining-form. - - For defvar, defconst, and fset we skip to the docstring with a kludgy - formatting convention: all docstrings must appear on the same line as the - initial open-paren (the one in column zero) and must contain a backslash - and a newline immediately after the initial double-quote. No newlines - must appear between the beginning of the form and the first double-quote. - For defun, defmacro, and autoload, we know how to skip over the - arglist, but the doc string must still have a backslash and newline - immediately after the double quote. - The only source files that must follow this convention are preloaded - uncompiled ones like loaddefs.el; aside from that, it is always the .elc - file that we should look at, and they are no problem because byte-compiler - output follows this convention. - The NAME and DOCSTRING are output. - NAME is preceded by `F' for a function or `V' for a variable. - An entry is output only if DOCSTRING has \ newline just after the opening ". - */ - -static void -skip_white (FILE *infile) -{ - int c; - do - c = getc (infile); - while (c_isspace (c)); - - ungetc (c, infile); -} - -static void -read_lisp_symbol (FILE *infile, char *buffer) -{ - int c; - char *fillp = buffer; - - skip_white (infile); - while (true) - { - c = getc (infile); - if (c == '\\') - { - c = getc (infile); - if (c < 0) - return; - *fillp++ = c; - } - else if (c_isspace (c) || c == '(' || c == ')' || c < 0) - { - ungetc (c, infile); - *fillp = 0; - break; - } - else - *fillp++ = c; - } - - if (! buffer[0]) - fprintf (stderr, "## expected a symbol, got '%c'\n", c); - - skip_white (infile); -} - -static bool -search_lisp_doc_at_eol (FILE *infile) -{ - int c = 0, c1 = 0, c2 = 0; - - /* Skip until the end of line; remember two previous chars. */ - while (c != '\n' && c != '\r' && c != EOF) - { - c2 = c1; - c1 = c; - c = getc (infile); - } - - /* If two previous characters were " and \, - this is a doc string. Otherwise, there is none. */ - if (c2 != '"' || c1 != '\\') - { -#ifdef DEBUG - fprintf (stderr, "## non-docstring found\n"); -#endif - ungetc (c, infile); - return false; - } - return true; -} - -#define DEF_ELISP_FILE(fn) { #fn, sizeof(#fn) - 1 } - -static void -scan_lisp_file (const char *filename, const char *mode) -{ - FILE *infile; - int c; - char *saved_string = 0; - /* These are the only files that are loaded uncompiled, and must - follow the conventions of the doc strings expected by this - function. These conventions are automatically followed by the - byte compiler when it produces the .elc files. */ - static struct { - const char *fn; - int fl; - } const uncompiled[] = { - DEF_ELISP_FILE (loaddefs.el), - DEF_ELISP_FILE (loadup.el), - DEF_ELISP_FILE (charprop.el), - DEF_ELISP_FILE (cp51932.el), - DEF_ELISP_FILE (eucjp-ms.el) - }; - int i; - int flen = strlen (filename); - - if (generate_globals) - fatal ("scanning lisp file when -g specified"); - if (flen > 3 && !strcmp (filename + flen - 3, ".el")) - { - bool match = false; - for (i = 0; i < sizeof (uncompiled) / sizeof (uncompiled[0]); i++) - { - if (uncompiled[i].fl <= flen - && !strcmp (filename + flen - uncompiled[i].fl, uncompiled[i].fn) - && (flen == uncompiled[i].fl - || IS_SLASH (filename[flen - uncompiled[i].fl - 1]))) - { - match = true; - break; - } - } - if (!match) - fatal ("uncompiled lisp file %s is not supported", filename); - } - - infile = fopen (filename, mode); - if (infile == NULL) - { - perror (filename); - exit (EXIT_FAILURE); - } - - c = '\n'; - while (!feof (infile)) - { - char buffer[BUFSIZ]; - char type; - - /* If not at end of line, skip till we get to one. */ - if (c != '\n' && c != '\r') - { - c = getc (infile); - continue; - } - /* Skip the line break. */ - while (c == '\n' || c == '\r') - c = getc (infile); - /* Detect a dynamic doc string and save it for the next expression. */ - if (c == '#') - { - c = getc (infile); - if (c == '@') - { - ptrdiff_t length = 0; - ptrdiff_t i; - - /* Read the length. */ - while ((c = getc (infile), - c_isdigit (c))) - { - if (INT_MULTIPLY_WRAPV (length, 10, &length) - || INT_ADD_WRAPV (length, c - '0', &length) - || SIZE_MAX < length) - memory_exhausted (); - } - - if (length <= 1) - fatal ("invalid dynamic doc string length"); - - if (c != ' ') - fatal ("space not found after dynamic doc string length"); - - /* The next character is a space that is counted in the length - but not part of the doc string. - We already read it, so just ignore it. */ - length--; - - /* Read in the contents. */ - free (saved_string); - saved_string = xmalloc (length); - for (i = 0; i < length; i++) - saved_string[i] = getc (infile); - /* The last character is a ^_. - That is needed in the .elc file - but it is redundant in DOC. So get rid of it here. */ - saved_string[length - 1] = 0; - /* Skip the line break. */ - while (c == '\n' || c == '\r') - c = getc (infile); - /* Skip the following line. */ - while (! (c == '\n' || c == '\r' || c < 0)) - c = getc (infile); - } - continue; - } - - if (c != '(') - continue; - - read_lisp_symbol (infile, buffer); - - if (! strcmp (buffer, "defun") - || ! strcmp (buffer, "defmacro") - || ! strcmp (buffer, "defsubst")) - { - type = 'F'; - read_lisp_symbol (infile, buffer); - - /* Skip the arguments: either "nil" or a list in parens. */ - - c = getc (infile); - if (c == 'n') /* nil */ - { - if ((c = getc (infile)) != 'i' - || (c = getc (infile)) != 'l') - { - fprintf (stderr, "## unparsable arglist in %s (%s)\n", - buffer, filename); - continue; - } - } - else if (c != '(') - { - fprintf (stderr, "## unparsable arglist in %s (%s)\n", - buffer, filename); - continue; - } - else - while (! (c == ')' || c < 0)) - c = getc (infile); - skip_white (infile); - - /* If the next three characters aren't `dquote bslash newline' - then we're not reading a docstring. - */ - if ((c = getc (infile)) != '"' - || (c = getc (infile)) != '\\' - || ((c = getc (infile)) != '\n' && c != '\r')) - { -#ifdef DEBUG - fprintf (stderr, "## non-docstring in %s (%s)\n", - buffer, filename); -#endif - continue; - } - } - - /* defcustom can only occur in uncompiled Lisp files. */ - else if (! strcmp (buffer, "defvar") - || ! strcmp (buffer, "defconst") - || ! strcmp (buffer, "defcustom")) - { - type = 'V'; - read_lisp_symbol (infile, buffer); - - if (saved_string == 0) - if (!search_lisp_doc_at_eol (infile)) - continue; - } - - else if (! strcmp (buffer, "custom-declare-variable") - || ! strcmp (buffer, "defvaralias") - ) - { - type = 'V'; - - c = getc (infile); - if (c == '\'') - read_lisp_symbol (infile, buffer); - else - { - if (c != '(') - { - fprintf (stderr, - "## unparsable name in custom-declare-variable in %s\n", - filename); - continue; - } - read_lisp_symbol (infile, buffer); - if (strcmp (buffer, "quote")) - { - fprintf (stderr, - "## unparsable name in custom-declare-variable in %s\n", - filename); - continue; - } - read_lisp_symbol (infile, buffer); - c = getc (infile); - if (c != ')') - { - fprintf (stderr, - "## unparsable quoted name in custom-declare-variable in %s\n", - filename); - continue; - } - } - - if (saved_string == 0) - if (!search_lisp_doc_at_eol (infile)) - continue; - } - - else if (! strcmp (buffer, "fset") || ! strcmp (buffer, "defalias")) - { - type = 'F'; - - c = getc (infile); - if (c == '\'') - read_lisp_symbol (infile, buffer); - else - { - if (c != '(') - { - fprintf (stderr, "## unparsable name in fset in %s\n", - filename); - continue; - } - read_lisp_symbol (infile, buffer); - if (strcmp (buffer, "quote")) - { - fprintf (stderr, "## unparsable name in fset in %s\n", - filename); - continue; - } - read_lisp_symbol (infile, buffer); - c = getc (infile); - if (c != ')') - { - fprintf (stderr, - "## unparsable quoted name in fset in %s\n", - filename); - continue; - } - } - - if (saved_string == 0) - if (!search_lisp_doc_at_eol (infile)) - continue; - } - - else if (! strcmp (buffer, "autoload")) - { - type = 'F'; - c = getc (infile); - if (c == '\'') - read_lisp_symbol (infile, buffer); - else - { - if (c != '(') - { - fprintf (stderr, "## unparsable name in autoload in %s\n", - filename); - continue; - } - read_lisp_symbol (infile, buffer); - if (strcmp (buffer, "quote")) - { - fprintf (stderr, "## unparsable name in autoload in %s\n", - filename); - continue; - } - read_lisp_symbol (infile, buffer); - c = getc (infile); - if (c != ')') - { - fprintf (stderr, - "## unparsable quoted name in autoload in %s\n", - filename); - continue; - } - } - skip_white (infile); - c = getc (infile); - if (c != '\"') - { - fprintf (stderr, "## autoload of %s unparsable (%s)\n", - buffer, filename); - continue; - } - read_c_string_or_comment (infile, 0, false, 0); - - if (saved_string == 0) - if (!search_lisp_doc_at_eol (infile)) - continue; - } - -#ifdef DEBUG - else if (! strcmp (buffer, "if") - || ! strcmp (buffer, "byte-code")) - continue; -#endif - - else - { -#ifdef DEBUG - fprintf (stderr, "## unrecognized top-level form, %s (%s)\n", - buffer, filename); -#endif - continue; - } - - /* At this point, we should either use the previous dynamic doc string in - saved_string or gobble a doc string from the input file. - In the latter case, the opening quote (and leading backslash-newline) - have already been read. */ - - printf ("\037%c%s\n", type, buffer); - if (saved_string) - { - fputs (saved_string, stdout); - /* Don't use one dynamic doc string twice. */ - free (saved_string); - saved_string = 0; - } - else - read_c_string_or_comment (infile, 1, false, 0); - } - free (saved_string); - if (ferror (infile) || fclose (infile) != 0) - fatal ("%s: read error", filename); -} - - /* make-docfile.c ends here */ diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 11107ec0f6..a64af022d4 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -4926,13 +4926,13 @@ binding slots have been popped." ;; if it weren't for the fact that we need to figure out when a defalias ;; defines a macro, so as to add it to byte-compile-macro-environment. ;; - ;; FIXME: we also use this hunk-handler to implement the function's dynamic - ;; docstring feature. We could actually implement it more elegantly in - ;; byte-compile-lambda so it applies to all lambdas, but the problem is that - ;; the resulting .elc format will not be recognized by make-docfile, so - ;; either we stop using DOC for the docstrings of preloaded elc files (at the - ;; cost of around 24KB on 32bit hosts, double on 64bit hosts) or we need to - ;; build DOC in a more clever way (e.g. handle anonymous elements). + ;; FIXME: we also use this hunk-handler to implement the function's + ;; dynamic docstring feature (via byte-compile-file-form-defmumble). + ;; We should actually implement it (more elegantly) in + ;; byte-compile-lambda so it applies to all lambdas. We did it here + ;; so the resulting .elc format was recognizable by make-docfile, + ;; but since then we stopped using DOC for the docstrings of + ;; preloaded elc files so that obstacle is gone. (let ((byte-compile-free-references nil) (byte-compile-free-assignments nil)) (pcase form diff --git a/lisp/startup.el b/lisp/startup.el index b79467339b..727432a4cb 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -1056,6 +1056,9 @@ the `--debug-init' option to view a complete error backtrace." (when debug-on-error-should-be-set (setq debug-on-error debug-on-error-from-init-file)))) +(defvar lisp-directory nil + "Directory containing the Lisp files that come with GNU Emacs.") + (defun command-line () "A subroutine of `normal-top-level'. Amongst another things, it parses the command-line arguments." @@ -1087,8 +1090,7 @@ Amongst another things, it parses the command-line arguments." (let ((simple-file-name ;; Look for simple.el or simple.elc and use their directory ;; as the place where all Lisp files live. - (locate-file "simple" load-path (get-load-suffixes))) - lisp-dir) + (locate-file "simple" load-path (get-load-suffixes)))) ;; Don't abort if simple.el cannot be found, but print a warning. ;; Although in most usage we are going to cryptically abort a moment ;; later anyway, due to missing required bidi data files (eg bug#13430). @@ -1104,12 +1106,13 @@ please check its value") (unless (file-readable-p lispdir) (princ (format "Lisp directory %s not readable?" lispdir)) (terpri))) - (setq lisp-dir (file-truename (file-name-directory simple-file-name))) + (setq lisp-directory + (file-truename (file-name-directory simple-file-name))) (setq load-history (mapcar (lambda (elt) (if (and (stringp (car elt)) (not (file-name-absolute-p (car elt)))) - (cons (concat lisp-dir + (cons (concat lisp-directory (car elt)) (cdr elt)) elt)) diff --git a/src/Makefile.in b/src/Makefile.in index ea4a7207ff..76e4675c2a 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -642,13 +642,11 @@ endif ## for the first time, this prevents any variation between configurations ## in the contents of the DOC file. ## -$(etc)/DOC: lisp.mk $(libsrc)/make-docfile$(EXEEXT) $(doc_obj) $(lisp) +$(etc)/DOC: $(libsrc)/make-docfile$(EXEEXT) $(doc_obj) $(AM_V_GEN)$(MKDIR_P) $(etc) $(AM_V_at)rm -f $(etc)/DOC $(AM_V_at)$(libsrc)/make-docfile -d $(srcdir) \ $(SOME_MACHINE_OBJECTS) $(doc_obj) > $(etc)/DOC - $(AM_V_at)$(libsrc)/make-docfile -a $(etc)/DOC -d $(lispsource) \ - $(shortlisp) $(libsrc)/make-docfile$(EXEEXT) $(libsrc)/make-fingerprint$(EXEEXT): \ $(lib)/libgnu.a diff --git a/src/doc.c b/src/doc.c index 6be023bb93..129d3a517b 100644 --- a/src/doc.c +++ b/src/doc.c @@ -84,16 +84,19 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition) char *from, *to, *name, *p, *p1; Lisp_Object file, pos; ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object dir; USE_SAFE_ALLOCA; if (FIXNUMP (filepos)) { file = Vdoc_file_name; + dir = Vdoc_directory; pos = filepos; } else if (CONSP (filepos)) { file = XCAR (filepos); + dir = Fsymbol_value (Qlisp_directory); pos = XCDR (filepos); } else @@ -101,7 +104,7 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition) EMACS_INT position = eabs (XFIXNUM (pos)); - if (!STRINGP (Vdoc_directory)) + if (!STRINGP (dir)) return Qnil; if (!STRINGP (file)) @@ -113,7 +116,7 @@ get_doc_string (Lisp_Object filepos, bool unibyte, bool definition) Lisp_Object tem = Ffile_name_absolute_p (file); file = ENCODE_FILE (file); Lisp_Object docdir - = NILP (tem) ? ENCODE_FILE (Vdoc_directory) : empty_unibyte_string; + = NILP (tem) ? ENCODE_FILE (dir) : empty_unibyte_string; ptrdiff_t docdir_sizemax = SBYTES (docdir) + 1; if (will_dump_p ()) docdir_sizemax = max (docdir_sizemax, sizeof sibling_etc); @@ -703,6 +706,7 @@ See variable `text-quoting-style'. */) void syms_of_doc (void) { + DEFSYM (Qlisp_directory, "lisp-directory"); DEFSYM (Qsubstitute_command_keys, "substitute-command-keys"); DEFSYM (Qfunction_documentation, "function-documentation"); DEFSYM (Qgrave, "grave"); diff --git a/src/lread.c b/src/lread.c index 4992576414..55b3d473dc 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1545,7 +1545,7 @@ Return t if the file exists and loads successfully. */) message_with_string ("Loading %s...", file, 1); } - specbind (Qload_file_name, found_eff); + specbind (Qload_file_name, hist_file_name); specbind (Qload_true_file_name, found); specbind (Qinhibit_file_name_operation, Qnil); specbind (Qload_in_progress, Qt); @@ -3224,23 +3224,6 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) Fstring_as_unibyte (AREF (tmp, COMPILED_BYTECODE))); } - if (COMPILED_DOC_STRING < ASIZE (tmp) - && EQ (AREF (tmp, COMPILED_DOC_STRING), make_fixnum (0))) - { - /* read_list found a docstring like '(#$ . 5521)' and treated it - as 0. This placeholder 0 would lead to accidental sharing in - purecopy's hash-consing, so replace it with a (hopefully) - unique integer placeholder, which is negative so that it is - not confused with a DOC file offset (the USE_LSB_TAG shift - relies on the fact that VALMASK is one bit narrower than - INTMASK). Eventually Snarf-documentation should replace the - placeholder with the actual docstring. */ - verify (INTMASK & ~VALMASK); - EMACS_UINT hash = ((XHASH (tmp) >> USE_LSB_TAG) - | (INTMASK - INTMASK / 2)); - ASET (tmp, COMPILED_DOC_STRING, make_ufixnum (hash)); - } - XSETPVECTYPE (vec, PVEC_COMPILED); return tmp; } @@ -4208,31 +4191,13 @@ read_list (bool flag, Lisp_Object readcharfun) /* While building, if the list starts with #$, treat it specially. */ if (EQ (elt, Vload_file_name) - && ! NILP (elt) - && !NILP (Vpurify_flag)) + && ! NILP (elt)) { - if (NILP (Vdoc_file_name)) - /* We have not yet called Snarf-documentation, so assume - this file is described in the DOC file - and Snarf-documentation will fill in the right value later. - For now, replace the whole list with 0. */ - doc_reference = 1; - else - /* We have already called Snarf-documentation, so make a relative - file name for this file, so it can be found properly - in the installed Lisp directory. - We don't use Fexpand_file_name because that would make - the directory absolute now. */ - { - AUTO_STRING (dot_dot_lisp, "../lisp/"); - elt = concat2 (dot_dot_lisp, Ffile_name_nondirectory (elt)); - } + if (!NILP (Vpurify_flag)) + doc_reference = 0; + else if (load_force_doc_strings) + doc_reference = 2; } - else if (EQ (elt, Vload_file_name) - && ! NILP (elt) - && load_force_doc_strings) - doc_reference = 2; - if (ch) { if (flag > 0) @@ -4253,8 +4218,6 @@ read_list (bool flag, Lisp_Object readcharfun) if (ch == ')') { - if (doc_reference == 1) - return make_fixnum (0); if (doc_reference == 2 && FIXNUMP (XCDR (val))) { char *saved = NULL; commit 337005af0bf21244cabdc0b2a2c11d0095ecd0fa Author: Po Lu Date: Fri Dec 31 10:07:30 2021 +0800 Add pinch event support to xwidgets * src/xterm.c (handle_one_xevent): Pass through pinch events to xwidgets and provide root coordinates when translating motion events. * src/xwidget.c (xwidget_motion_notify): Use provided root window coordinates. (xwidget_pinch): New function. * src/xwidget.h (xwidget_motion_notify): Update prototype. (xwidget_pinch): New function prototype. diff --git a/src/xterm.c b/src/xterm.c index afac07e7ff..d3d85a9e0d 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -10268,7 +10268,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, && xv_total_y == 0.0)); else xwidget_motion_notify (xv, xev->event_x, xev->event_y, - state, xev->time); + xev->root_x, xev->root_y, state, + xev->time); goto XI_OTHER; } @@ -11112,6 +11113,17 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (!device || !device->master_p) goto XI_OTHER; +#ifdef HAVE_XWIDGETS + struct xwidget_view *xvw = xwidget_view_from_window (pev->event); + + if (xvw) + { + *finish = X_EVENT_DROP; + xwidget_pinch (xvw, pev); + goto XI_OTHER; + } +#endif + any = x_any_window_to_frame (dpyinfo, pev->event); if (any) { @@ -11133,8 +11145,17 @@ handle_one_xevent (struct x_display_info *dpyinfo, goto XI_OTHER; } case XI_GesturePinchEnd: - *finish = X_EVENT_DROP; - goto XI_OTHER; + { +#if defined HAVE_XWIDGETS && HAVE_USABLE_XI_GESTURE_PINCH_EVENT + XIGesturePinchEvent *pev = (XIGesturePinchEvent *) xi_event; + struct xwidget_view *xvw = xwidget_view_from_window (pev->event); + + if (xvw) + xwidget_pinch (xvw, pev); +#endif + *finish = X_EVENT_DROP; + goto XI_OTHER; + } #endif default: goto XI_OTHER; diff --git a/src/xwidget.c b/src/xwidget.c index 05997bb9d5..4f14152833 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -1162,7 +1162,9 @@ xwidget_button (struct xwidget_view *view, #ifdef HAVE_XINPUT2 void xwidget_motion_notify (struct xwidget_view *view, - double x, double y, uint state, Time time) + double x, double y, + double root_x, double root_y, + uint state, Time time) { GdkEvent *xg_event; GtkWidget *target; @@ -1190,8 +1192,8 @@ xwidget_motion_notify (struct xwidget_view *view, xg_event->any.window = gtk_widget_get_window (target); xg_event->motion.x = target_x; xg_event->motion.y = target_y; - xg_event->motion.x_root = lrint (x); - xg_event->motion.y_root = lrint (y); + xg_event->motion.x_root = root_x; + xg_event->motion.y_root = root_y; xg_event->motion.time = time; xg_event->motion.state = state; xg_event->motion.device = find_suitable_pointer (view->frame); @@ -1248,6 +1250,70 @@ xwidget_scroll (struct xwidget_view *view, double x, double y, gtk_main_do_event (xg_event); gdk_event_free (xg_event); } + +#ifdef HAVE_USABLE_XI_GESTURE_PINCH_EVENT +void +xwidget_pinch (struct xwidget_view *view, XIGesturePinchEvent *xev) +{ +#if GTK_CHECK_VERSION (3, 18, 0) + GdkEvent *xg_event; + GtkWidget *target; + struct xwidget *model = XXWIDGET (view->model); + int target_x, target_y; + double x = xev->event_x; + double y = xev->event_y; + + if (NILP (model->buffer)) + return; + + record_osr_embedder (view); + + target = find_widget_at_pos (model->widgetwindow_osr, + lrint (x + view->clip_left), + lrint (y + view->clip_top), + &target_x, &target_y); + + if (!target) + { + target_x = lrint (x); + target_y = lrint (y); + target = model->widget_osr; + } + + xg_event = gdk_event_new (GDK_TOUCHPAD_PINCH); + xg_event->any.window = gtk_widget_get_window (target); + xg_event->touchpad_pinch.x = target_x; + xg_event->touchpad_pinch.y = target_y; + xg_event->touchpad_pinch.dx = xev->delta_x; + xg_event->touchpad_pinch.dy = xev->delta_y; + xg_event->touchpad_pinch.angle_delta = xev->delta_angle; + xg_event->touchpad_pinch.scale = xev->scale; + xg_event->touchpad_pinch.x_root = xev->root_x; + xg_event->touchpad_pinch.y_root = xev->root_y; + xg_event->touchpad_pinch.state = xev->mods.effective; + xg_event->touchpad_pinch.n_fingers = 2; + + switch (xev->evtype) + { + case XI_GesturePinchBegin: + xg_event->touchpad_pinch.phase = GDK_TOUCHPAD_GESTURE_PHASE_BEGIN; + break; + case XI_GesturePinchUpdate: + xg_event->touchpad_pinch.phase = GDK_TOUCHPAD_GESTURE_PHASE_UPDATE; + break; + case XI_GesturePinchEnd: + xg_event->touchpad_pinch.phase = GDK_TOUCHPAD_GESTURE_PHASE_END; + break; + } + + gdk_event_set_device (xg_event, find_suitable_pointer (view->frame)); + + g_object_ref (xg_event->any.window); + gtk_main_do_event (xg_event); + gdk_event_free (xg_event); +#endif +} +#endif #endif #ifdef HAVE_XINPUT2 @@ -2180,6 +2246,11 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) XISetMask (m, XI_ButtonRelease); XISetMask (m, XI_Enter); XISetMask (m, XI_Leave); +#ifdef XI_GesturePinchBegin + XISetMask (m, XI_GesturePinchBegin); + XISetMask (m, XI_GesturePinchUpdate); + XISetMask (m, XI_GesturePinchEnd); +#endif XISelectEvents (xv->dpy, xv->wdesc, &mask, 1); } #endif diff --git a/src/xwidget.h b/src/xwidget.h index ab60b9ed34..0c6ed1a381 100644 --- a/src/xwidget.h +++ b/src/xwidget.h @@ -43,6 +43,10 @@ struct window; #import "nsxwidget.h" #endif +#ifdef HAVE_XINPUT2 +#include +#endif + struct xwidget { union vectorlike_header header; @@ -210,9 +214,12 @@ extern void xwidget_motion_or_crossing (struct xwidget_view *, const XEvent *); #ifdef HAVE_XINPUT2 extern void xwidget_motion_notify (struct xwidget_view *, double, - double, uint, Time); + double, double, double, uint, Time); extern void xwidget_scroll (struct xwidget_view *, double, double, double, double, uint, Time, bool); +#ifdef HAVE_USABLE_XI_GESTURE_PINCH_EVENT +extern void xwidget_pinch (struct xwidget_view *, XIGesturePinchEvent *); +#endif #endif #endif #else commit 77f17649d81b2fbe8917264e6b253a95a3f2eea1 Author: Po Lu Date: Fri Dec 31 09:27:12 2021 +0800 Restore original xwidget embedder after performing a lispy event * src/xwidget.c (Fxwidget_perform_lispy_event): Restore original embedder after performing event. (Fdelete_xwidget_view): Block input around non-reentrant section. diff --git a/src/xwidget.c b/src/xwidget.c index 025275f1a0..05997bb9d5 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -461,10 +461,12 @@ selected frame is not an X-Windows frame. */) if (!f) return Qnil; + block_input (); osw = gtk_widget_get_window (xw->widgetwindow_osr); embedder = gtk_widget_get_window (FRAME_GTK_OUTER_WIDGET (f)); gdk_offscreen_window_set_embedder (osw, embedder); + unblock_input (); #endif widget = gtk_window_get_focus (GTK_WINDOW (xw->widgetwindow_osr)); @@ -540,7 +542,17 @@ selected frame is not an X-Windows frame. */) } if (character == -1 && keycode == -1) - return Qnil; + { +#ifdef HAVE_XINPUT2 + block_input (); + if (xw->embedder_view) + record_osr_embedder (xw->embedder_view); + else + gdk_offscreen_window_set_embedder (osw, NULL); + unblock_input (); +#endif + return Qnil; + } block_input (); xg_event = gdk_event_new (GDK_KEY_PRESS); @@ -584,6 +596,13 @@ selected frame is not an X-Windows frame. */) xg_event->type = GDK_KEY_RELEASE; gtk_main_do_event (xg_event); gdk_event_free (xg_event); + +#ifdef HAVE_XINPUT2 + if (xw->embedder_view) + record_osr_embedder (xw->embedder_view); + else + gdk_offscreen_window_set_embedder (osw, NULL); +#endif unblock_input (); #endif @@ -2612,18 +2631,18 @@ DEFUN ("delete-xwidget-view", { CHECK_XWIDGET_VIEW (xwidget_view); struct xwidget_view *xv = XXWIDGET_VIEW (xwidget_view); + + block_input (); #ifdef USE_GTK struct xwidget *xw = XXWIDGET (xv->model); GdkWindow *w; #ifdef HAVE_X_WINDOWS if (xv->wdesc != None) { - block_input (); cairo_destroy (xv->cr_context); cairo_surface_destroy (xv->cr_surface); XDestroyWindow (xv->dpy, xv->wdesc); Fremhash (make_fixnum (xv->wdesc), x_window_to_xwv_map); - unblock_input (); } #else gtk_widget_destroy (xv->widget); @@ -2644,6 +2663,7 @@ DEFUN ("delete-xwidget-view", internal_xwidget_view_list = Fdelq (xwidget_view, internal_xwidget_view_list); Vxwidget_view_list = Fcopy_sequence (internal_xwidget_view_list); + unblock_input (); return Qnil; } commit cc43606b552b66154cc243186e252ff3933e4206 Author: Po Lu Date: Fri Dec 31 09:18:56 2021 +0800 * src/xwidget.c (Fxwidget_perform_lispy_event): Use FRAME_WINDOW_P. diff --git a/src/xwidget.c b/src/xwidget.c index 49e15a0955..025275f1a0 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -452,7 +452,7 @@ selected frame is not an X-Windows frame. */) if (!NILP (frame)) f = decode_window_system_frame (frame); - else if (FRAME_X_P (SELECTED_FRAME ())) + else if (FRAME_WINDOW_P (SELECTED_FRAME ())) f = SELECTED_FRAME (); #ifdef USE_GTK commit 1d2d7ee87eb1981af4033755c4385e9130b696ff Author: Glenn Morris Date: Thu Dec 30 09:25:02 2021 -0800 * lisp/window.el (display-comint-buffer-action): Fix type. diff --git a/lisp/window.el b/lisp/window.el index d75dd9931b..eb063a3646 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -7476,7 +7476,7 @@ ALIST. See `display-buffer' for details." (defcustom display-comint-buffer-action 'display-buffer-same-window "The action to display a comint buffer." - :type 'display-buffer--action-function-custom-type + :type display-buffer--action-function-custom-type :risky t :version "29.1" :group 'windows commit d0974e294d6af4e1e89e1e2640bbd92c511c028a Author: Philipp Stephani Date: Thu Dec 30 17:59:07 2021 +0100 * lisp/emacs-lisp/ert.el (ert-select-tests): Document new error. diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index e3e85b5cef..70ce3a71b2 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -950,7 +950,8 @@ t -- Selects UNIVERSE. :expected, :unexpected -- Select tests according to their most recent result. a string -- A regular expression selecting all tests with matching names. a test -- (i.e., an object of the ert-test data-type) Selects that test. -a symbol -- Selects the test that the symbol names, errors if none. +a symbol -- Selects the test that the symbol names, signals an + `ert-test-unbound' error if none. \(member TESTS...) -- Selects the elements of TESTS, a list of tests or symbols naming tests. \(eql TEST) -- Selects TEST, a test or a symbol naming a test. commit 097452efbc0d087fbff401651bc6379721202243 Author: Philipp Stephani Date: Thu Dec 30 17:18:54 2021 +0100 * lisp/emacs-lisp/ert.el (ert-select-tests): Simplify nested switch diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index da14b93d1b..e3e85b5cef 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -1015,52 +1015,42 @@ contained in UNIVERSE." (unless (ert-test-boundp selector) (signal 'ert-test-unbound (list selector))) (list (ert-get-test selector))) - (`(,operator . ,operands) - (cl-ecase operator - (member - (mapcar (lambda (purported-test) - (pcase-exhaustive purported-test - ((pred symbolp) - (unless (ert-test-boundp purported-test) - (signal 'ert-test-unbound - (list purported-test))) - (ert-get-test purported-test)) - ((pred ert-test-p) purported-test))) - operands)) - (eql - (cl-assert (eql (length operands) 1)) - (ert-select-tests `(member ,@operands) universe)) - (and - ;; Do these definitions of AND, NOT and OR satisfy de - ;; Morgan's laws? Should they? - (cl-case (length operands) - (0 (ert-select-tests 't universe)) - (t (ert-select-tests `(and ,@(cdr operands)) - (ert-select-tests (car operands) - universe))))) - (not - (cl-assert (eql (length operands) 1)) - (let ((all-tests (ert-select-tests 't universe))) - (cl-set-difference all-tests - (ert-select-tests (car operands) - all-tests)))) - (or - (cl-case (length operands) - (0 (ert-select-tests 'nil universe)) - (t (cl-union (ert-select-tests (car operands) universe) - (ert-select-tests `(or ,@(cdr operands)) - universe))))) - (tag - (cl-assert (eql (length operands) 1)) - (let ((tag (car operands))) - (ert-select-tests `(satisfies - ,(lambda (test) - (member tag (ert-test-tags test)))) - universe))) - (satisfies - (cl-assert (eql (length operands) 1)) - (cl-remove-if-not (car operands) - (ert-select-tests 't universe))))))) + (`(member . ,operands) + (mapcar (lambda (purported-test) + (pcase-exhaustive purported-test + ((pred symbolp) + (unless (ert-test-boundp purported-test) + (signal 'ert-test-unbound + (list purported-test))) + (ert-get-test purported-test)) + ((pred ert-test-p) purported-test))) + operands)) + (`(eql ,operand) + (ert-select-tests `(member ,operand) universe)) + ;; Do these definitions of AND, NOT and OR satisfy de Morgan's + ;; laws? Should they? + (`(and) + (ert-select-tests 't universe)) + (`(and ,first . ,rest) + (ert-select-tests `(and ,@rest) + (ert-select-tests first universe))) + (`(not ,operand) + (let ((all-tests (ert-select-tests 't universe))) + (cl-set-difference all-tests + (ert-select-tests operand all-tests)))) + (`(or) + (ert-select-tests 'nil universe)) + (`(or ,first . ,rest) + (cl-union (ert-select-tests first universe) + (ert-select-tests `(or ,@rest) universe))) + (`(tag ,tag) + (ert-select-tests `(satisfies + ,(lambda (test) + (member tag (ert-test-tags test)))) + universe)) + (`(satisfies ,predicate) + (cl-remove-if-not predicate + (ert-select-tests 't universe))))) (define-error 'ert-test-unbound "ERT test is unbound") commit f6da1eed7447c363ef927fea9b23a7b35587473c Author: Philipp Stephani Date: Thu Dec 30 16:59:16 2021 +0100 Properly report errors about unbound ERT test symbols. Assertions should only be used to check internal consistency within a package, not to check arguments passed by callers. Instead, define and use a new error symbol. * lisp/emacs-lisp/ert.el (ert-test-unbound): New error symbol. (ert-select-tests): Use it. * test/lisp/emacs-lisp/ert-tests.el (ert-test-select-undefined): New unit test. * etc/NEWS: Document new behavior. diff --git a/etc/NEWS b/etc/NEWS index 96e95967ef..bbe0aed3f7 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -175,6 +175,9 @@ When environment variable 'EMACS_TEST_JUNIT_REPORT' is set, ERT generates a JUnit test report under this file name. This is useful for Emacs integration into CI/CD test environments. +*** Unbound test symbols now signal an 'ert-test-unbound' error. +This affects the 'ert-select-tests' function and its callers. + ** Emoji +++ diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index c570132870..da14b93d1b 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -1012,7 +1012,8 @@ contained in UNIVERSE." universe)))) ((pred ert-test-p) (list selector)) ((pred symbolp) - (cl-assert (ert-test-boundp selector)) + (unless (ert-test-boundp selector) + (signal 'ert-test-unbound (list selector))) (list (ert-get-test selector))) (`(,operator . ,operands) (cl-ecase operator @@ -1020,7 +1021,9 @@ contained in UNIVERSE." (mapcar (lambda (purported-test) (pcase-exhaustive purported-test ((pred symbolp) - (cl-assert (ert-test-boundp purported-test)) + (unless (ert-test-boundp purported-test) + (signal 'ert-test-unbound + (list purported-test))) (ert-get-test purported-test)) ((pred ert-test-p) purported-test))) operands)) @@ -1059,6 +1062,8 @@ contained in UNIVERSE." (cl-remove-if-not (car operands) (ert-select-tests 't universe))))))) +(define-error 'ert-test-unbound "ERT test is unbound") + (defun ert--insert-human-readable-selector (selector) "Insert a human-readable presentation of SELECTOR into the current buffer." ;; This is needed to avoid printing the (huge) contents of the diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index 1a8c9bf4f0..e2b41297ad 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -495,6 +495,12 @@ This macro is used to test if macroexpansion in `should' works." (should (equal (ert-select-tests '(tag b) (list test)) (list test))) (should (equal (ert-select-tests '(tag c) (list test)) '())))) +(ert-deftest ert-test-select-undefined () + (let* ((symbol (make-symbol "ert-not-a-test")) + (data (should-error (ert-select-tests symbol t) + :type 'ert-test-unbound))) + (should (eq (cadr data) symbol)))) + ;;; Tests for utility functions. (ert-deftest ert-test-parse-keys-and-body () commit 94891dd225c7e74b89588814b6f8b11cec633659 Author: Philipp Stephani Date: Thu Dec 30 16:22:32 2021 +0100 ; * lisp/emacs-lisp/ert.el: Update reference to 'cl-assert' diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index cc464a0f81..c570132870 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -39,7 +39,7 @@ ;; but signals a different error when its condition is violated that ;; is caught and processed by ERT. In addition, it analyzes its ;; argument form and records information that helps debugging -;; (`assert' tries to do something similar when its second argument +;; (`cl-assert' tries to do something similar when its second argument ;; SHOW-ARGS is true, but `should' is more sophisticated). For ;; information on `should-not' and `should-error', see their ;; docstrings. `skip-unless' skips the test immediately without commit 6738c1cc8cb720087c2c3fffcc98a410063cb381 Author: Eli Zaretskii Date: Thu Dec 30 16:44:13 2021 +0200 Fix multisession-tests on MS-Windows * test/lisp/emacs-lisp/multisession-tests.el (multi-test-files-simple): On MS-Windows and Haiku, wait before invoking the Emacs sub-process, not after, to ensure the later update is detected with 1-sec file time resolution. diff --git a/test/lisp/emacs-lisp/multisession-tests.el b/test/lisp/emacs-lisp/multisession-tests.el index 57ca420488..17457d9be2 100644 --- a/test/lisp/emacs-lisp/multisession-tests.el +++ b/test/lisp/emacs-lisp/multisession-tests.el @@ -116,6 +116,10 @@ (should (= (multisession-value multisession--sfoo) 0)) (cl-incf (multisession-value multisession--sfoo)) (should (= (multisession-value multisession--sfoo) 1)) + ;; On Windows and Haiku, we don't have sub-second resolution, so + ;; let some time pass to make the "later" logic work. + (when (memq system-type '(windows-nt haiku)) + (sleep-for 0.6)) (call-process (concat invocation-directory invocation-name) nil t nil @@ -130,9 +134,6 @@ "" :synchronized t) (cl-incf (multisession-value multisession--sfoo)))))) - ;; On Windows, we don't have sub-second resolution. - (when (memq system-type '(windows-nt haiku)) - (sleep-for 2)) (should (= (multisession-value multisession--sfoo) 2))))) (ert-deftest multi-test-files-busy () commit a67b1f1944262f41e58c87f09d28858725aa5ca9 Author: Po Lu Date: Thu Dec 30 19:43:58 2021 +0800 Make sure widget buttons always have a left box line * lisp/wid-edit.el (widget-specify-button): Add an invisible before-string to the button overlay. (bug#51550) diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index a53add7d08..22f3d29908 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -437,8 +437,9 @@ the :notify function can't know the new value.") (follow-link (widget-get widget :follow-link)) (help-echo (widget-get widget :help-echo))) (widget-put widget :button-overlay overlay) - (if (functionp help-echo) + (when (functionp help-echo) (setq help-echo 'widget-mouse-help)) + (overlay-put overlay 'before-string #(" " 0 1 (invisible t))) (overlay-put overlay 'button widget) (overlay-put overlay 'keymap (widget-get widget :keymap)) (overlay-put overlay 'evaporate t) commit cc9ac56081719f553b3e7758c391c595c3fa4eaf Author: Alan Mackenzie Date: Thu Dec 30 11:32:25 2021 +0000 CC Mode: Prevent rapid alternation of fontification of "found types" This fixes bug #52863. * lisp/progmodes/cc-engine.el (c-forward-decl-or-cast-1): When a new type is found, postpone entering it into c-found-types (and thus triggering the fontification of that type throughout the buffer) until the end of the function, when we're sure that the "type" found actually is a type. diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index d289148874..11f3668137 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -9937,6 +9937,10 @@ This function might do hidden buffer changes." ;; Set when we have encountered a keyword (e.g. "extern") which ;; causes the following declaration to be treated as though top-level. make-top + ;; A list of found types in this declaration. This is an association + ;; list, the car being the buffer position, the cdr being the + ;; identifier. + found-type-list ;; Save `c-record-type-identifiers' and ;; `c-record-ref-identifiers' since ranges are recorded ;; speculatively and should be thrown away if it turns out @@ -10006,10 +10010,17 @@ This function might do hidden buffer changes." ;; If the previous identifier is a found type we ;; record it as a real one; it might be some sort of ;; alias for a prefix like "unsigned". - (save-excursion - (goto-char type-start) - (let ((c-promote-possible-types t)) - (c-forward-type)))) + ;; We postpone entering the new found type into c-found-types + ;; until we are sure of it, thus preventing rapid alternation + ;; of the fontification of the token throughout the buffer. + (push (cons type-start + (buffer-substring-no-properties + type-start + (save-excursion + (goto-char type-start) + (c-end-of-token) + (point)))) + found-type-list)) ;; Signal a type declaration for "struct foo {". (when (and backup-at-type-decl @@ -10255,13 +10266,10 @@ This function might do hidden buffer changes." (when (eq at-type 'found) ;; Remove the ostensible type from the found types list. (when type-start - (c-unfind-type - (buffer-substring-no-properties - type-start - (save-excursion - (goto-char type-start) - (c-end-of-token) - (point))))) + (let ((discard-t (assq type-start found-type-list))) + (when discard-t + (setq found-type-list + (remq discard-t found-type-list))))) t)) ;; The token which we assumed to be a type is actually the ;; identifier, and we have no explicit type. @@ -10875,6 +10883,14 @@ This function might do hidden buffer changes." ;; interactive refontification. (c-put-c-type-property (point) 'c-decl-arg-start)) + ;; Enter all the found types into `c-found-types'. + (when found-type-list + (save-excursion + (let ((c-promote-possible-types t)) + (dolist (ft found-type-list) + (goto-char (car ft)) + (c-forward-type))))) + ;; Record the type's coordinates in `c-record-type-identifiers' for ;; later fontification. (when (and c-record-type-identifiers at-type ;; (not (eq at-type t)) commit 8b90d91f2160c04a4f1efb0a5c05dd7c38ef0110 Author: Eli Zaretskii Date: Thu Dec 30 13:32:14 2021 +0200 Fix previous change in 'pop_it' * src/xdisp.c (restore_face_box_flags): New function. (pop_it): Use 'restore_face_box_flags'. (Bug#51550) diff --git a/src/xdisp.c b/src/xdisp.c index 6c63278f52..4136079f49 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -6829,6 +6829,27 @@ iterate_out_of_display_property (struct it *it) it->current.string_pos = it->position; } +/* Restore the IT->face_box_p flag, since it could have been + overwritten by the face of the object that we just finished + displaying. Also, set the IT->start_of_box_run_p flag if the + change in faces requires that. */ +static void +restore_face_box_flags (struct it *it, int prev_face_id) +{ + struct face *face = FACE_FROM_ID_OR_NULL (it->f, it->face_id); + + if (face) + { + struct face *prev_face = FACE_FROM_ID_OR_NULL (it->f, prev_face_id); + + if (!(it->start_of_box_run_p && prev_face && prev_face->box)) + it->start_of_box_run_p = (face->box != FACE_NO_BOX + && (prev_face == NULL + || prev_face->box == FACE_NO_BOX)); + it->face_box_p = face->box != FACE_NO_BOX; + } +} + /* Restore IT's settings from IT->stack. Called, for example, when no more overlay strings must be processed, and we return to delivering display elements from a buffer, or when the end of a string from a @@ -6873,43 +6894,13 @@ pop_it (struct it *it) break; case GET_FROM_BUFFER: { - struct face *face = FACE_FROM_ID_OR_NULL (it->f, it->face_id); - - /* Restore the face_box_p flag, since it could have been - overwritten by the face of the object that we just finished - displaying. Also, set the start_of_box_run_p flag if the - change in faces requires that. */ - if (face) - { - struct face *prev_face = FACE_FROM_ID_OR_NULL (it->f, prev_face_id); - - if (!(it->start_of_box_run_p && prev_face && prev_face->box)) - it->start_of_box_run_p = (face->box != FACE_NO_BOX - && (prev_face == NULL - || prev_face->box == FACE_NO_BOX)); - it->face_box_p = face->box != FACE_NO_BOX; - } + restore_face_box_flags (it, prev_face_id); it->object = it->w->contents; } break; case GET_FROM_STRING: { - struct face *face = FACE_FROM_ID_OR_NULL (it->f, it->face_id); - - /* Restore the face_box_p flag, since it could have been - overwritten by the face of the object that we just finished - displaying. Also, set the start_of_box_run_p flag if the - change in faces requires that. */ - if (face) - { - struct face *prev_face = FACE_FROM_ID_OR_NULL (it->f, prev_face_id); - - if (!(it->start_of_box_run_p && prev_face && prev_face->box)) - it->start_of_box_run_p = (face->box != FACE_NO_BOX - && (prev_face == NULL - || prev_face->box == FACE_NO_BOX)); - it->face_box_p = face->box != FACE_NO_BOX; - } + restore_face_box_flags (it, prev_face_id); it->object = it->string; } break; commit c80d2f3d67d9802f39288945758f6bb7b88fd259 Author: Eli Zaretskii Date: Thu Dec 30 13:21:01 2021 +0200 Fix start-of-box-face display after display and overlay strings * src/xdisp.c (pop_it): Recompute the 'start_of_box_run_p' flag, like we do in 'handle_fontified_prop', when faces change while iterating over a buffer or string. (Bug#51550) diff --git a/src/xdisp.c b/src/xdisp.c index a6c122aee8..6c63278f52 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -6841,6 +6841,7 @@ pop_it (struct it *it) struct iterator_stack_entry *p; bool from_display_prop = it->from_disp_prop_p; ptrdiff_t prev_pos = IT_CHARPOS (*it); + int prev_face_id = it->face_id; eassert (it->sp > 0); --it->sp; @@ -6876,9 +6877,18 @@ pop_it (struct it *it) /* Restore the face_box_p flag, since it could have been overwritten by the face of the object that we just finished - displaying. */ + displaying. Also, set the start_of_box_run_p flag if the + change in faces requires that. */ if (face) - it->face_box_p = face->box != FACE_NO_BOX; + { + struct face *prev_face = FACE_FROM_ID_OR_NULL (it->f, prev_face_id); + + if (!(it->start_of_box_run_p && prev_face && prev_face->box)) + it->start_of_box_run_p = (face->box != FACE_NO_BOX + && (prev_face == NULL + || prev_face->box == FACE_NO_BOX)); + it->face_box_p = face->box != FACE_NO_BOX; + } it->object = it->w->contents; } break; @@ -6888,9 +6898,18 @@ pop_it (struct it *it) /* Restore the face_box_p flag, since it could have been overwritten by the face of the object that we just finished - displaying. */ + displaying. Also, set the start_of_box_run_p flag if the + change in faces requires that. */ if (face) - it->face_box_p = face->box != FACE_NO_BOX; + { + struct face *prev_face = FACE_FROM_ID_OR_NULL (it->f, prev_face_id); + + if (!(it->start_of_box_run_p && prev_face && prev_face->box)) + it->start_of_box_run_p = (face->box != FACE_NO_BOX + && (prev_face == NULL + || prev_face->box == FACE_NO_BOX)); + it->face_box_p = face->box != FACE_NO_BOX; + } it->object = it->string; } break; commit d1c7ce68ba91129124b4869b15df97c63fa3d4cb Author: Juri Linkov Date: Thu Dec 30 10:08:37 2021 +0200 * lisp/tab-line.el (tab-line-tab-name-format-default): Add help-echo. (bug#52889) diff --git a/lisp/tab-line.el b/lisp/tab-line.el index af0647acf7..003bfe1fbe 100644 --- a/lisp/tab-line.el +++ b/lisp/tab-line.el @@ -495,6 +495,8 @@ which the tab will represent." (apply 'propertize (concat (propertize name 'keymap tab-line-tab-map + 'help-echo (if selected-p "Current tab" + "Click to select tab") ;; Don't turn mouse-1 into mouse-2 (bug#49247) 'follow-link 'ignore) (or (and (or buffer-p (assq 'buffer tab) (assq 'close tab))