commit a2eb83d037b36f43a124426a120af432b94b5b4e (HEAD, refs/remotes/origin/master) Author: Po Lu Date: Wed Jan 26 06:05:35 2022 +0000 Simplify Haiku scrolling code * src/haikuterm.c (haiku_scroll_run): Remove code that can never be reached since Cairo frames are always double buffered. diff --git a/src/haikuterm.c b/src/haikuterm.c index 90d6f926c8..b9eb1d2fc5 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -2325,50 +2325,14 @@ haiku_scroll_run (struct window *w, struct run *run) height = run->height; } - if (!height) - return; - block_input (); gui_clear_cursor (w); + BView_draw_lock (view); -#ifdef USE_BE_CAIRO - if (EmacsView_double_buffered_p (view)) - { -#endif - BView_StartClip (view); - BView_CopyBits (view, x, from_y, width, height, - x, to_y, width, height); - BView_EndClip (view); -#ifdef USE_BE_CAIRO - } - else - { - EmacsWindow_begin_cr_critical_section (FRAME_HAIKU_WINDOW (f)); - cairo_surface_t *surface = FRAME_CR_SURFACE (f); - cairo_surface_t *s - = cairo_surface_create_similar (surface, - cairo_surface_get_content (surface), - width, height); - cairo_t *cr = cairo_create (s); - if (surface) - { - cairo_set_source_surface (cr, surface, -x, -from_y); - cairo_paint (cr); - cairo_destroy (cr); - - cr = haiku_begin_cr_clip (f, NULL); - cairo_save (cr); - cairo_set_source_surface (cr, s, x, to_y); - cairo_set_operator (cr, CAIRO_OPERATOR_SOURCE); - cairo_rectangle (cr, x, to_y, width, height); - cairo_fill (cr); - cairo_restore (cr); - cairo_surface_destroy (s); - haiku_end_cr_clip (cr); - } - EmacsWindow_end_cr_critical_section (FRAME_HAIKU_WINDOW (f)); - } -#endif + BView_StartClip (view); + BView_CopyBits (view, x, from_y, width, height, + x, to_y, width, height); + BView_EndClip (view); BView_draw_unlock (view); unblock_input (); commit 401ccb0b9c697fd3af026a72b6621a692e206aea Author: Po Lu Date: Wed Jan 26 13:53:20 2022 +0800 Fix GTK menu bar height reporting when scaled * src/gtkutil.c (xg_update_frame_menubar): Multiply requisition height by GDK scale. diff --git a/src/gtkutil.c b/src/gtkutil.c index 607cf5ee2e..98907bf022 100644 --- a/src/gtkutil.c +++ b/src/gtkutil.c @@ -4012,6 +4012,7 @@ xg_update_frame_menubar (struct frame *f) { xp_output *x = f->output_data.xp; GtkRequisition req; + int scale = xg_get_scale (f); if (!x->menubar_widget || gtk_widget_get_mapped (x->menubar_widget)) return; @@ -4029,9 +4030,9 @@ xg_update_frame_menubar (struct frame *f) gtk_widget_show_all (x->menubar_widget); gtk_widget_get_preferred_size (x->menubar_widget, NULL, &req); req.height *= xg_get_scale (f); - if (FRAME_MENUBAR_HEIGHT (f) != req.height) + if (FRAME_MENUBAR_HEIGHT (f) != (req.height * scale)) { - FRAME_MENUBAR_HEIGHT (f) = req.height; + FRAME_MENUBAR_HEIGHT (f) = req.height * scale; adjust_frame_size (f, -1, -1, 2, 0, Qmenu_bar_lines); } unblock_input (); commit 3e00ab5efb33fd26a38f718d348012e7b718b0a8 Author: Po Lu Date: Wed Jan 26 13:46:28 2022 +0800 ; * src/xterm.c (handle_one_xevent): Fix formatting of XI2 switch. diff --git a/src/xterm.c b/src/xterm.c index 919c8b12ab..b2cdbe6a0f 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -10357,10 +10357,12 @@ handle_one_xevent (struct x_display_info *dpyinfo, } x_detect_focus_change (dpyinfo, any, event, &inev.ie); goto XI_OTHER; + case XI_FocusOut: any = x_any_window_to_frame (dpyinfo, focusout->event); x_detect_focus_change (dpyinfo, any, event, &inev.ie); goto XI_OTHER; + case XI_Enter: any = x_top_window_to_frame (dpyinfo, enter->event); @@ -10502,6 +10504,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, x_note_mouse_movement (dpyinfo->last_mouse_glyph_frame, &ev); #endif goto XI_OTHER; + case XI_Motion: { struct xi_device_t *device; @@ -10782,6 +10785,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, do_help = 1; goto XI_OTHER; } + case XI_ButtonRelease: case XI_ButtonPress: { @@ -10981,6 +10985,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, #endif goto XI_OTHER; } + case XI_KeyPress: { int state = xev->mods.effective; @@ -11350,6 +11355,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, } goto XI_OTHER; } + case XI_KeyRelease: x_display_set_last_user_time (dpyinfo, xev->time); @@ -11387,7 +11393,6 @@ handle_one_xevent (struct x_display_info *dpyinfo, case XI_PropertyEvent: case XI_HierarchyChanged: case XI_DeviceChanged: - #ifdef XISlaveSwitch if (xi_event->evtype == XI_DeviceChanged && (((XIDeviceChangedEvent *) xi_event)->reason @@ -11396,6 +11401,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, #endif x_init_master_valuators (dpyinfo); goto XI_OTHER; + #ifdef XI_TouchBegin case XI_TouchBegin: { @@ -11482,6 +11488,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, goto XI_OTHER; } + case XI_TouchUpdate: { struct xi_device_t *device; @@ -11524,6 +11531,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, goto XI_OTHER; } + case XI_TouchEnd: { struct xi_device_t *device; @@ -11554,6 +11562,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, goto XI_OTHER; } + #endif #ifdef XI_GesturePinchBegin case XI_GesturePinchBegin: @@ -11599,6 +11608,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, *finish = X_EVENT_DROP; goto XI_OTHER; } + case XI_GesturePinchEnd: { x_display_set_last_user_time (dpyinfo, xi_event->time); @@ -11617,6 +11627,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, default: goto XI_OTHER; } + xi_done_keysym: #ifdef HAVE_X_I18N if (FRAME_XIC (f) && (FRAME_XIC_STYLE (f) & XIMStatusArea)) @@ -11625,6 +11636,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (must_free_data) XFreeEventData (dpyinfo->display, &event->xcookie); goto done_keysym; + XI_OTHER: if (must_free_data) XFreeEventData (dpyinfo->display, &event->xcookie); commit f97c3f9ced9acc79f71643b846f4afd8615b88b8 Merge: db7de56eef 7eca80b204 Author: Stefan Kangas Date: Wed Jan 26 06:30:26 2022 +0100 Merge from origin/emacs-28 7eca80b204 ; * src/composite.c (syms_of_composite) Date: Wed Jan 26 05:09:09 2022 +0000 Simplify Haiku underline code * src/haikuterm.c (haiku_draw_text_decoration): Remove code left over from when mouse face had to be set manually. diff --git a/src/haikuterm.c b/src/haikuterm.c index e7d596cec3..90d6f926c8 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -632,20 +632,12 @@ haiku_draw_text_decoration (struct glyph_string *s, struct face *face, && (s->prev->face->underline_pixels_above_descent_line == s->face->underline_pixels_above_descent_line)) { - struct face *prev_face = s->prev->face; - - if (prev_face && prev_face->underline == FACE_UNDER_LINE) - { - /* We use the same underline style as the previous one. */ - thickness = s->prev->underline_thickness; - position = s->prev->underline_position; - } - else - goto calculate_underline_metrics; + /* We use the same underline style as the previous one. */ + thickness = s->prev->underline_thickness; + position = s->prev->underline_position; } else { - calculate_underline_metrics:; struct font *font = font_for_underline_metrics (s); unsigned long minimum_offset; bool underline_at_descent_line; commit bca68550844da7849ab33616345525918e82f3c8 Author: Po Lu Date: Wed Jan 26 01:20:48 2022 +0000 Make `haiku-menu-bar-open' faster * src/haikumenu.c (Fhaiku_menu_bar_open): Get draw lock before updating the menu bar. * src/haikuterm.c (haiku_read_socket): Don't update menu bar if b->no_lock. diff --git a/src/haikumenu.c b/src/haikumenu.c index 3fee583160..b73baf72e0 100644 --- a/src/haikumenu.c +++ b/src/haikumenu.c @@ -644,17 +644,20 @@ the position of the last non-menu event instead. */) struct frame *f = decode_window_system_frame (frame); if (FRAME_EXTERNAL_MENU_BAR (f)) - set_frame_menubar (f, 1); + { + block_input (); + BView_draw_lock (FRAME_HAIKU_VIEW (f)); + set_frame_menubar (f, 1); + BMenuBar_start_tracking (FRAME_HAIKU_MENU_BAR (f)); + BView_draw_unlock (FRAME_HAIKU_VIEW (f)); + unblock_input (); + } else { return call2 (Qpopup_menu, call0 (Qmouse_menu_bar_map), last_nonmenu_event); } - block_input (); - BMenuBar_start_tracking (FRAME_HAIKU_MENU_BAR (f)); - unblock_input (); - return Qnil; } diff --git a/src/haikuterm.c b/src/haikuterm.c index c8cc02a298..e7d596cec3 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -3178,15 +3178,25 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) if (type == MENU_BAR_OPEN) { - BView_draw_lock (FRAME_HAIKU_VIEW (f)); - /* This shouldn't be here, but nsmenu does it, so - it should probably be safe. */ - int was_waiting_for_input_p = waiting_for_input; - if (waiting_for_input) - waiting_for_input = 0; - set_frame_menubar (f, 1); - waiting_for_input = was_waiting_for_input_p; - BView_draw_unlock (FRAME_HAIKU_VIEW (f)); + /* b->no_lock means that MenusBeginning was called + from the main thread, which means tracking was + started manually, and we have already updated the + menu bar. */ + if (!b->no_lock) + { + BView_draw_lock (FRAME_HAIKU_VIEW (f)); + /* This shouldn't be here, but nsmenu does it, so + it should probably be safe. */ + int was_waiting_for_input_p = waiting_for_input; + if (waiting_for_input) + waiting_for_input = 0; + set_frame_menubar (f, 1); + waiting_for_input = was_waiting_for_input_p; + BView_draw_unlock (FRAME_HAIKU_VIEW (f)); + } + + /* But set the flag anyway, because the menu will end + from the window thread. */ FRAME_OUTPUT_DATA (f)->menu_bar_open_p = 1; popup_activated_p += 1; commit 19c6fb16746718d94b9e316503c5779de88e2e2d Author: Stefan Kangas Date: Wed Jan 26 00:44:00 2022 +0100 ; * test/lisp/emacs-lisp/derived-tests.el: Silence byte-compiler. diff --git a/test/lisp/emacs-lisp/derived-tests.el b/test/lisp/emacs-lisp/derived-tests.el index 0589819ccc..547b16843d 100644 --- a/test/lisp/emacs-lisp/derived-tests.el +++ b/test/lisp/emacs-lisp/derived-tests.el @@ -40,6 +40,9 @@ (derived-tests--child-mode) (should (equal (buffer-string) "PB CB MH AFP=S AFC=S "))))) +(declare-function mode-a "derived-tests") +(declare-function mode-b "derived-tests") +(declare-function mode-c "derived-tests") (ert-deftest test-add-font-lock () (define-derived-mode mode-a fundamental-mode "mode-a" (font-lock-add-keywords nil `(("a" 0 'font-lock-keyword-face)))) commit 51fdcca000f7ee5b08115a81e58b2e56036fade6 Author: Stefan Kangas Date: Wed Jan 26 00:42:10 2022 +0100 * src/image.c (parse_image_spec): Use NILP. diff --git a/src/image.c b/src/image.c index 951531505e..32e03ab6f7 100644 --- a/src/image.c +++ b/src/image.c @@ -1177,7 +1177,7 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords, return false; maybe_done: - if (EQ (XCDR (plist), Qnil)) + if (NILP (XCDR (plist))) { /* Check that all mandatory fields are present. */ for (i = 0; i < nkeywords; ++i) commit fb16a6c124c99a0e58dc8152b9a803c8a28e2436 Author: Lars Ingebrigtsen Date: Tue Jan 25 14:55:26 2022 +0100 Improve how change-log-mode fills all-file-name lines * lisp/vc/add-log.el (change-log-fill-file-list): New function to improve how we fill all-file-name ChangeLog lines (bug#19341). (change-log-indent): Use it. diff --git a/lisp/vc/add-log.el b/lisp/vc/add-log.el index e9a21825e1..beaad2e835 100644 --- a/lisp/vc/add-log.el +++ b/lisp/vc/add-log.el @@ -1068,8 +1068,23 @@ the change log file in another window." (insert-before-markers "(")) (error nil))))) +;; If we're filling a line that has a whole bunch of file names, and +;; we're still in the file names, then transform this so that it'll +;; still font-lock properly. +(defun change-log-fill-file-list () + (save-excursion + (unless (bobp) + (forward-line -1) + (when (looking-at change-log-file-names-re) + (goto-char (match-end 0)) + (while (looking-at "\\=, \\([^ ,:([\n]+\\)") + (goto-char (match-end 0))) + (when (looking-at ", *\n") + (replace-match ":\n *" t t)))))) + (defun change-log-indent () (change-log-fill-parenthesized-list) + (change-log-fill-file-list) (let* ((indent (save-excursion (beginning-of-line) commit 2362eb09804541cf75d0148d23f4dbe50fe311d0 Author: Lars Ingebrigtsen Date: Tue Jan 25 14:37:50 2022 +0100 Fix up Gnus FAQ entry * doc/misc/gnus-faq.texi (FAQ 3-9): Remove mention of nnimap-list-pattern, which was removed some years ago (bug#53522). diff --git a/doc/misc/gnus-faq.texi b/doc/misc/gnus-faq.texi index 14a8c4c12d..b576f383ac 100644 --- a/doc/misc/gnus-faq.texi +++ b/doc/misc/gnus-faq.texi @@ -653,8 +653,7 @@ about the server there. (add-to-list 'gnus-secondary-select-methods '(nnimap "Give the baby a name" (nnimap-address "imap.yourProvider.net") - (nnimap-port 143) - (nnimap-list-pattern "archive.*"))) + (nnimap-port 143))) @end example @noindent commit 50fea24b8b64dfcdd7beda87d3fab53711173eb8 Author: Andrea Corallo Date: Tue Jan 25 22:15:51 2022 +0100 * src/comp.c (emit_lisp_obj_rval): Make use of NILP. diff --git a/src/comp.c b/src/comp.c index d8fe80df3a..d755df802f 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1720,7 +1720,7 @@ emit_lisp_obj_rval (Lisp_Object obj) emit_comment (format_string ("const lisp obj: %s", SSDATA (Fprin1_to_string (obj, Qnil)))); - if (EQ (obj, Qnil)) + if (NILP (obj)) { gcc_jit_rvalue *n; n = emit_rvalue_from_lisp_word ((Lisp_Word) iQnil); commit 2d4d6f1a3fb292588f6506e4890117836ae541dd Author: Andrea Corallo Date: Tue Jan 25 22:05:05 2022 +0100 ;* src/fns.c (concat_strings): Add missing space. diff --git a/src/fns.c b/src/fns.c index 13b2cf944b..87237f3b5e 100644 --- a/src/fns.c +++ b/src/fns.c @@ -848,7 +848,7 @@ concat_strings (ptrdiff_t nargs, Lisp_Object *args) if (dest_multibyte && some_unibyte) { /* Non-ASCII characters in unibyte strings take two bytes when - converted to multibyte -- count them and adjust the total. */ + converted to multibyte -- count them and adjust the total. */ for (ptrdiff_t i = 0; i < nargs; i++) { Lisp_Object arg = args[i]; commit f4ed3f39c979f101e523ff1073ffe364d5c44501 Author: Stefan Monnier Date: Tue Jan 25 14:36:48 2022 -0500 * src/comp.c (emit_limple_insn): Fix another int/Lisp_Object mixup diff --git a/src/comp.c b/src/comp.c index 9abc5d9690..d8fe80df3a 100644 --- a/src/comp.c +++ b/src/comp.c @@ -2237,9 +2237,9 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_block *target1 = retrive_block (arg[2]); gcc_jit_block *target2 = retrive_block (arg[3]); - if ((CALL1I (comp-cstr-imm-vld-p, arg[0]) + if ((!NILP (CALL1I (comp-cstr-imm-vld-p, arg[0])) && NILP (CALL1I (comp-cstr-imm, arg[0]))) - || (CALL1I (comp-cstr-imm-vld-p, arg[1]) + || (!NILP (CALL1I (comp-cstr-imm-vld-p, arg[1])) && NILP (CALL1I (comp-cstr-imm, arg[1])))) emit_cond_jump (emit_BASE_EQ (a, b), target1, target2); else commit 84276bf775d42388ebc69683d093adef7fc0ed74 Author: Glenn Morris Date: Tue Jan 25 09:38:50 2022 -0800 Tag an mml-sec test * test/lisp/gnus/mml-sec-tests.el (mml-secure-en-decrypt-3): Tag unstable on hydra.nixos.org due to repeated intermittent failures. diff --git a/test/lisp/gnus/mml-sec-tests.el b/test/lisp/gnus/mml-sec-tests.el index 182d82b961..f308a61764 100644 --- a/test/lisp/gnus/mml-sec-tests.el +++ b/test/lisp/gnus/mml-sec-tests.el @@ -605,6 +605,9 @@ In this test, the encryption key needs to fixed among multiple ones." (ert-deftest mml-secure-en-decrypt-3 () "Encrypt message; then decrypt and test for expected result. In this test, encrypt-to-self variables are set to t." + ;; Random failures with "wrong-type-argument stringp nil". + ;; Seems unlikely to be specific to hydra.nixos.org... + :tags (if (getenv "EMACS_HYDRA_CI") '(:unstable)) (skip-unless (test-conf)) (skip-unless (ignore-errors (epg-find-configuration 'CMS))) ;; sub@example.org with multiple candidate keys, commit d25cb37694de446e6dd1095f489d5436ea9e20ae Author: Eli Zaretskii Date: Tue Jan 25 19:12:50 2022 +0200 ; * src/fns.c (concat_strings): Fix comment style. diff --git a/src/fns.c b/src/fns.c index 986e26f6ae..13b2cf944b 100644 --- a/src/fns.c +++ b/src/fns.c @@ -847,8 +847,8 @@ concat_strings (ptrdiff_t nargs, Lisp_Object *args) if (dest_multibyte && some_unibyte) { - // Non-ASCII chars in unibyte strings take two bytes when - // converted to multibyte -- count them and adjust the total. + /* Non-ASCII characters in unibyte strings take two bytes when + converted to multibyte -- count them and adjust the total. */ for (ptrdiff_t i = 0; i < nargs; i++) { Lisp_Object arg = args[i]; commit 65172e61cc307e9c823a7b958f8327d7d52ec2d4 Author: Andrea Corallo Date: Tue Jan 25 17:52:43 2022 +0100 * src/fns.c (concat_strings): Clean-up unused variable. diff --git a/src/fns.c b/src/fns.c index 251796eb63..986e26f6ae 100644 --- a/src/fns.c +++ b/src/fns.c @@ -923,8 +923,6 @@ concat_strings (ptrdiff_t nargs, Lisp_Object *args) for (ptrdiff_t j = 0; j < len; j++) { int c = XFIXNAT (AREF (arg, j)); - ptrdiff_t arg_len_byte = CHAR_BYTES (c); - if (dest_multibyte) toindex_byte += CHAR_STRING (c, SDATA (result) + toindex_byte); else commit dfaf8bec4e47eac2282e76d23e2ecc03c062ec39 Author: Andrea Corallo Date: Tue Jan 25 12:01:55 2022 +0100 * `batch-byte+native-compile' produce .eln younger than .elc (bug#52912) * lisp/emacs-lisp/comp.el (batch-native-compile): Add return value. (batch-byte+native-compile): Touch the produced .eln after the corresponding .elc is produced. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 71914b2f2b..a23169aa0f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -4195,9 +4195,9 @@ last directory in `native-comp-eln-load-path')." if (or (null byte+native-compile) (cl-notany (lambda (re) (string-match re file)) native-comp-bootstrap-deny-list)) - do (comp--native-compile file) + collect (comp--native-compile file) else - do (byte-compile-file file)))) + collect (byte-compile-file file)))) ;;;###autoload (defun batch-byte+native-compile () @@ -4211,13 +4211,18 @@ variable 'NATIVE_DISABLED' is set, only byte compile." (if (equal (getenv "NATIVE_DISABLED") "1") (batch-byte-compile) (cl-assert (length= command-line-args-left 1)) - (let ((byte+native-compile t) - (byte-to-native-output-buffer-file nil)) - (batch-native-compile) + (let* ((byte+native-compile t) + (byte-to-native-output-buffer-file nil) + (eln-file (car (batch-native-compile)))) (pcase byte-to-native-output-buffer-file (`(,temp-buffer . ,target-file) (unwind-protect - (byte-write-target-file temp-buffer target-file) + (progn + (byte-write-target-file temp-buffer target-file) + ;; Touch the .eln in order to have it older than the + ;; corresponding .elc. + (when (stringp eln-file) + (set-file-times eln-file))) (kill-buffer temp-buffer)))) (setq command-line-args-left (cdr command-line-args-left))))) commit 72a4cdaadcf388f5a870a70a208ad7f04bf35d16 Author: Andrea Corallo Date: Mon Jan 24 15:29:38 2022 +0100 * lisp/emacs-lisp/comp.el (batch-byte+native-compile): Fix unwind form diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3c61063a3c..71914b2f2b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -4217,8 +4217,8 @@ variable 'NATIVE_DISABLED' is set, only byte compile." (pcase byte-to-native-output-buffer-file (`(,temp-buffer . ,target-file) (unwind-protect - (byte-write-target-file temp-buffer target-file)) - (kill-buffer temp-buffer))) + (byte-write-target-file temp-buffer target-file) + (kill-buffer temp-buffer)))) (setq command-line-args-left (cdr command-line-args-left))))) ;;;###autoload commit e8c66036d155adba9a75fb8304c241b55512c93c Author: Stefan Monnier Date: Tue Jan 25 10:03:01 2022 -0500 * src/lisp.h (lisp_h_EQ, lisp_h_NILP): Fix length and indent diff --git a/src/lisp.h b/src/lisp.h index 9f1d093f58..8c55ad72a9 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -365,26 +365,29 @@ typedef EMACS_INT Lisp_Word; ((ok) ? (void) 0 : wrong_type_argument (predicate, x)) #define lisp_h_CONSP(x) TAGGEDP (x, Lisp_Cons) #define lisp_h_BASE_EQ(x, y) (XLI (x) == XLI (y)) -/* #define lisp_h_EQ(x, y) (XLI (x) == XLI (y)) */ - -#define lisp_h_EQ(x, y) ((XLI ((x)) == XLI ((y))) \ - || (symbols_with_pos_enabled \ - && (SYMBOL_WITH_POS_P ((x)) \ - ? BARE_SYMBOL_P ((y)) \ - ? XLI (XSYMBOL_WITH_POS((x))->sym) == XLI (y) \ - : SYMBOL_WITH_POS_P((y)) \ - && (XLI (XSYMBOL_WITH_POS((x))->sym) \ - == XLI (XSYMBOL_WITH_POS((y))->sym)) \ - : (SYMBOL_WITH_POS_P ((y)) \ - && BARE_SYMBOL_P ((x)) \ - && (XLI (x) == XLI ((XSYMBOL_WITH_POS ((y)))->sym)))))) + +/* FIXME: Do we really need to inline the whole thing? + * What about keeping the part after `symbols_with_pos_enabled` in + * a separate function? */ +#define lisp_h_EQ(x, y) \ + ((XLI ((x)) == XLI ((y))) \ + || (symbols_with_pos_enabled \ + && (SYMBOL_WITH_POS_P ((x)) \ + ? (BARE_SYMBOL_P ((y)) \ + ? XLI (XSYMBOL_WITH_POS((x))->sym) == XLI (y) \ + : SYMBOL_WITH_POS_P((y)) \ + && (XLI (XSYMBOL_WITH_POS((x))->sym) \ + == XLI (XSYMBOL_WITH_POS((y))->sym))) \ + : (SYMBOL_WITH_POS_P ((y)) \ + && BARE_SYMBOL_P ((x)) \ + && (XLI (x) == XLI ((XSYMBOL_WITH_POS ((y)))->sym)))))) #define lisp_h_FIXNUMP(x) \ (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) \ - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) \ & ((1 << INTTYPEBITS) - 1))) #define lisp_h_FLOATP(x) TAGGEDP (x, Lisp_Float) -#define lisp_h_NILP(x) /* x == Qnil */ /* ((XLI (x) == XLI (Qnil))) */ /* EQ (x, Qnil) */ BASE_EQ (x, Qnil) +#define lisp_h_NILP(x) BASE_EQ (x, Qnil) #define lisp_h_SET_SYMBOL_VAL(sym, v) \ (eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), \ (sym)->u.s.val.value = (v)) commit 697723b63d69ee6d32a82ab2c88e0ce1e65257ed Author: Mattias Engdegård Date: Fri Jan 21 10:00:19 2022 +0100 Faster concat, append, vconcat, copy-sequence, etc Split the C auxiliary function `concat` into separate functions for string and list/vector as target types, respectively. This makes them simpler and faster. Implement `Fcopy_sequence` more efficiently for strings, lists and vectors instead of using `concat`. The result is a significant performance increase for the Lisp built-ins concat, append, vconcat, copy-sequence and anything using them such as mapconcat, copy-alist and propertize. * src/fns.c (concat2, concat3, Fconcat): Use concat_strings. (Fappend, Fvconcat): Adapt to changed signature of concat. (Fcopy_sequence): Faster implementation for lists, strings, and vectors. (concat_strings): New. (concat): Strip code for string target, simplify, optimise. (Fcopy_alist): Use Fcopy_sequence. diff --git a/src/fns.c b/src/fns.c index ade30fca41..251796eb63 100644 --- a/src/fns.c +++ b/src/fns.c @@ -643,18 +643,19 @@ Do NOT use this function to compare file names for equality. */) } static Lisp_Object concat (ptrdiff_t nargs, Lisp_Object *args, - enum Lisp_Type target_type, bool last_special); + Lisp_Object last_tail, bool vector_target); +static Lisp_Object concat_strings (ptrdiff_t nargs, Lisp_Object *args); Lisp_Object concat2 (Lisp_Object s1, Lisp_Object s2) { - return concat (2, ((Lisp_Object []) {s1, s2}), Lisp_String, 0); + return concat_strings (2, ((Lisp_Object []) {s1, s2})); } Lisp_Object concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3) { - return concat (3, ((Lisp_Object []) {s1, s2, s3}), Lisp_String, 0); + return concat_strings (3, ((Lisp_Object []) {s1, s2, s3})); } DEFUN ("append", Fappend, Sappend, 0, MANY, 0, @@ -665,7 +666,9 @@ The last argument is not copied, just used as the tail of the new list. usage: (append &rest SEQUENCES) */) (ptrdiff_t nargs, Lisp_Object *args) { - return concat (nargs, args, Lisp_Cons, 1); + if (nargs == 0) + return Qnil; + return concat (nargs - 1, args, args[nargs - 1], false); } DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0, @@ -678,7 +681,7 @@ to be `eq'. usage: (concat &rest SEQUENCES) */) (ptrdiff_t nargs, Lisp_Object *args) { - return concat (nargs, args, Lisp_String, 0); + return concat_strings (nargs, args); } DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0, @@ -688,7 +691,7 @@ Each argument may be a list, vector or string. usage: (vconcat &rest SEQUENCES) */) (ptrdiff_t nargs, Lisp_Object *args) { - return concat (nargs, args, Lisp_Vectorlike, 0); + return concat (nargs, args, Qnil, true); } @@ -702,16 +705,48 @@ the same empty object instead of its copy. */) { if (NILP (arg)) return arg; - if (RECORDP (arg)) + if (CONSP (arg)) { - return Frecord (PVSIZE (arg), XVECTOR (arg)->contents); + Lisp_Object val = Fcons (XCAR (arg), Qnil); + Lisp_Object prev = val; + Lisp_Object tail = XCDR (arg); + FOR_EACH_TAIL (tail) + { + Lisp_Object c = Fcons (XCAR (tail), Qnil); + XSETCDR (prev, c); + prev = c; + } + CHECK_LIST_END (tail, tail); + return val; } - if (CHAR_TABLE_P (arg)) + if (STRINGP (arg)) { - return copy_char_table (arg); + ptrdiff_t bytes = SBYTES (arg); + ptrdiff_t chars = SCHARS (arg); + Lisp_Object val = STRING_MULTIBYTE (arg) + ? make_uninit_multibyte_string (chars, bytes) + : make_uninit_string (bytes); + memcpy (SDATA (val), SDATA (arg), bytes); + INTERVAL ivs = string_intervals (arg); + if (ivs) + { + INTERVAL copy = copy_intervals (ivs, 0, chars); + set_interval_object (copy, val); + set_string_intervals (val, copy); + } + return val; } + if (VECTORP (arg)) + return Fvector (ASIZE (arg), XVECTOR (arg)->contents); + + if (RECORDP (arg)) + return Frecord (PVSIZE (arg), XVECTOR (arg)->contents); + + if (CHAR_TABLE_P (arg)) + return copy_char_table (arg); + if (BOOL_VECTOR_P (arg)) { EMACS_INT nbits = bool_vector_size (arg); @@ -721,13 +756,10 @@ the same empty object instead of its copy. */) return val; } - if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg)) - wrong_type_argument (Qsequencep, arg); - - return concat (1, &arg, XTYPE (arg), 0); + wrong_type_argument (Qsequencep, arg); } -/* This structure holds information of an argument of `concat' that is +/* This structure holds information of an argument of `concat_strings' that is a string and has text properties to be copied. */ struct textprop_rec { @@ -737,278 +769,312 @@ struct textprop_rec }; static Lisp_Object -concat (ptrdiff_t nargs, Lisp_Object *args, - enum Lisp_Type target_type, bool last_special) +concat_strings (ptrdiff_t nargs, Lisp_Object *args) { - Lisp_Object val; - Lisp_Object tail; - Lisp_Object this; - ptrdiff_t toindex; - ptrdiff_t toindex_byte = 0; - EMACS_INT result_len; - EMACS_INT result_len_byte; - ptrdiff_t argnum; - Lisp_Object last_tail; - Lisp_Object prev; - bool some_multibyte; - /* When we make a multibyte string, we can't copy text properties - while concatenating each string because the length of resulting - string can't be decided until we finish the whole concatenation. - So, we record strings that have text properties to be copied - here, and copy the text properties after the concatenation. */ - struct textprop_rec *textprops = NULL; - /* Number of elements in textprops. */ - ptrdiff_t num_textprops = 0; USE_SAFE_ALLOCA; - tail = Qnil; - - /* In append, the last arg isn't treated like the others */ - if (last_special && nargs > 0) - { - nargs--; - last_tail = args[nargs]; - } - else - last_tail = Qnil; - - /* Check each argument. */ - for (argnum = 0; argnum < nargs; argnum++) - { - this = args[argnum]; - if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this) - || COMPILEDP (this) || BOOL_VECTOR_P (this))) - wrong_type_argument (Qsequencep, this); - } - - /* Compute total length in chars of arguments in RESULT_LEN. - If desired output is a string, also compute length in bytes - in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE + /* Check types and compute total length in chars of arguments in RESULT_LEN, + length in bytes in RESULT_LEN_BYTE, and determine in DEST_MULTIBYTE whether the result should be a multibyte string. */ - result_len_byte = 0; - result_len = 0; - some_multibyte = 0; - for (argnum = 0; argnum < nargs; argnum++) + EMACS_INT result_len = 0; + EMACS_INT result_len_byte = 0; + bool dest_multibyte = false; + bool some_unibyte = false; + for (ptrdiff_t i = 0; i < nargs; i++) { + Lisp_Object arg = args[i]; EMACS_INT len; - this = args[argnum]; - len = XFIXNAT (Flength (this)); - if (target_type == Lisp_String) - { - /* We must count the number of bytes needed in the string - as well as the number of characters. */ - ptrdiff_t i; - Lisp_Object ch; - int c; - ptrdiff_t this_len_byte; - if (VECTORP (this) || COMPILEDP (this)) - for (i = 0; i < len; i++) - { - ch = AREF (this, i); - CHECK_CHARACTER (ch); - c = XFIXNAT (ch); - this_len_byte = CHAR_BYTES (c); - if (STRING_BYTES_BOUND - result_len_byte < this_len_byte) - string_overflow (); - result_len_byte += this_len_byte; - if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c)) - some_multibyte = 1; - } - else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0) - wrong_type_argument (Qintegerp, Faref (this, make_fixnum (0))); - else if (CONSP (this)) - for (; CONSP (this); this = XCDR (this)) - { - ch = XCAR (this); - CHECK_CHARACTER (ch); - c = XFIXNAT (ch); - this_len_byte = CHAR_BYTES (c); - if (STRING_BYTES_BOUND - result_len_byte < this_len_byte) - string_overflow (); - result_len_byte += this_len_byte; - if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c)) - some_multibyte = 1; - } - else if (STRINGP (this)) + /* We must count the number of bytes needed in the string + as well as the number of characters. */ + + if (STRINGP (arg)) + { + ptrdiff_t arg_len_byte; + len = SCHARS (arg); + arg_len_byte = SBYTES (arg); + if (STRING_MULTIBYTE (arg)) + dest_multibyte = true; + else + some_unibyte = true; + if (STRING_BYTES_BOUND - result_len_byte < arg_len_byte) + string_overflow (); + result_len_byte += arg_len_byte; + } + else if (VECTORP (arg)) + { + len = ASIZE (arg); + ptrdiff_t arg_len_byte = 0; + for (ptrdiff_t j = 0; j < len; j++) { - if (STRING_MULTIBYTE (this)) - { - some_multibyte = 1; - this_len_byte = SBYTES (this); - } - else - this_len_byte = count_size_as_multibyte (SDATA (this), - SCHARS (this)); - if (STRING_BYTES_BOUND - result_len_byte < this_len_byte) - string_overflow (); - result_len_byte += this_len_byte; + Lisp_Object ch = AREF (arg, j); + CHECK_CHARACTER (ch); + int c = XFIXNAT (ch); + arg_len_byte += CHAR_BYTES (c); + if (!ASCII_CHAR_P (c) && !CHAR_BYTE8_P (c)) + dest_multibyte = true; } + if (STRING_BYTES_BOUND - result_len_byte < arg_len_byte) + string_overflow (); + result_len_byte += arg_len_byte; } + else if (NILP (arg)) + continue; + else if (CONSP (arg)) + { + len = XFIXNAT (Flength (arg)); + ptrdiff_t arg_len_byte = 0; + for (; CONSP (arg); arg = XCDR (arg)) + { + Lisp_Object ch = XCAR (arg); + CHECK_CHARACTER (ch); + int c = XFIXNAT (ch); + arg_len_byte += CHAR_BYTES (c); + if (!ASCII_CHAR_P (c) && !CHAR_BYTE8_P (c)) + dest_multibyte = true; + } + if (STRING_BYTES_BOUND - result_len_byte < arg_len_byte) + string_overflow (); + result_len_byte += arg_len_byte; + } + else + wrong_type_argument (Qsequencep, arg); result_len += len; if (MOST_POSITIVE_FIXNUM < result_len) memory_full (SIZE_MAX); } - if (! some_multibyte) + if (dest_multibyte && some_unibyte) + { + // Non-ASCII chars in unibyte strings take two bytes when + // converted to multibyte -- count them and adjust the total. + for (ptrdiff_t i = 0; i < nargs; i++) + { + Lisp_Object arg = args[i]; + if (STRINGP (arg) && !STRING_MULTIBYTE (arg)) + { + ptrdiff_t bytes = SCHARS (arg); + const unsigned char *s = SDATA (arg); + ptrdiff_t nonascii = 0; + for (ptrdiff_t j = 0; j < bytes; j++) + nonascii += s[j] >> 7; + if (STRING_BYTES_BOUND - result_len_byte < nonascii) + string_overflow (); + result_len_byte += nonascii; + } + } + } + + if (!dest_multibyte) result_len_byte = result_len; /* Create the output object. */ - if (target_type == Lisp_Cons) - val = Fmake_list (make_fixnum (result_len), Qnil); - else if (target_type == Lisp_Vectorlike) - val = make_nil_vector (result_len); - else if (some_multibyte) - val = make_uninit_multibyte_string (result_len, result_len_byte); - else - val = make_uninit_string (result_len); - - /* In `append', if all but last arg are nil, return last arg. */ - if (target_type == Lisp_Cons && NILP (val)) - return last_tail; + Lisp_Object result = dest_multibyte + ? make_uninit_multibyte_string (result_len, result_len_byte) + : make_uninit_string (result_len); /* Copy the contents of the args into the result. */ - if (CONSP (val)) - tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */ - else - toindex = 0, toindex_byte = 0; + ptrdiff_t toindex = 0; + ptrdiff_t toindex_byte = 0; - prev = Qnil; - if (STRINGP (val)) - SAFE_NALLOCA (textprops, 1, nargs); + /* When we make a multibyte string, we can't copy text properties + while concatenating each string because the length of resulting + string can't be decided until we finish the whole concatenation. + So, we record strings that have text properties to be copied + here, and copy the text properties after the concatenation. */ + struct textprop_rec *textprops; + /* Number of elements in textprops. */ + ptrdiff_t num_textprops = 0; + SAFE_NALLOCA (textprops, 1, nargs); - for (argnum = 0; argnum < nargs; argnum++) + for (ptrdiff_t i = 0; i < nargs; i++) { - Lisp_Object thislen; - ptrdiff_t thisleni = 0; - ptrdiff_t thisindex = 0; - ptrdiff_t thisindex_byte = 0; - - this = args[argnum]; - if (!CONSP (this)) - thislen = Flength (this), thisleni = XFIXNUM (thislen); - - /* Between strings of the same kind, copy fast. */ - if (STRINGP (this) && STRINGP (val) - && STRING_MULTIBYTE (this) == some_multibyte) + Lisp_Object arg = args[i]; + if (STRINGP (arg)) { - ptrdiff_t thislen_byte = SBYTES (this); - - memcpy (SDATA (val) + toindex_byte, SDATA (this), SBYTES (this)); - if (string_intervals (this)) + if (string_intervals (arg)) { - textprops[num_textprops].argnum = argnum; + textprops[num_textprops].argnum = i; textprops[num_textprops].from = 0; - textprops[num_textprops++].to = toindex; + textprops[num_textprops].to = toindex; + num_textprops++; + } + ptrdiff_t nchars = SCHARS (arg); + if (STRING_MULTIBYTE (arg) == dest_multibyte) + { + /* Between strings of the same kind, copy fast. */ + ptrdiff_t arg_len_byte = SBYTES (arg); + memcpy (SDATA (result) + toindex_byte, SDATA (arg), arg_len_byte); + toindex_byte += arg_len_byte; } - toindex_byte += thislen_byte; - toindex += thisleni; + else + { + /* Copy a single-byte string to a multibyte string. */ + toindex_byte += copy_text (SDATA (arg), + SDATA (result) + toindex_byte, + nchars, 0, 1); + } + toindex += nchars; } - /* Copy a single-byte string to a multibyte string. */ - else if (STRINGP (this) && STRINGP (val)) + else if (VECTORP (arg)) { - if (string_intervals (this)) + ptrdiff_t len = ASIZE (arg); + for (ptrdiff_t j = 0; j < len; j++) { - textprops[num_textprops].argnum = argnum; - textprops[num_textprops].from = 0; - textprops[num_textprops++].to = toindex; + int c = XFIXNAT (AREF (arg, j)); + ptrdiff_t arg_len_byte = CHAR_BYTES (c); + + if (dest_multibyte) + toindex_byte += CHAR_STRING (c, SDATA (result) + toindex_byte); + else + SSET (result, toindex_byte++, c); + toindex++; } - toindex_byte += copy_text (SDATA (this), - SDATA (val) + toindex_byte, - SCHARS (this), 0, 1); - toindex += thisleni; } else - /* Copy element by element. */ - while (1) + for (Lisp_Object tail = arg; !NILP (tail); tail = XCDR (tail)) { - register Lisp_Object elt; - - /* Fetch next element of `this' arg into `elt', or break if - `this' is exhausted. */ - if (NILP (this)) break; - if (CONSP (this)) - elt = XCAR (this), this = XCDR (this); - else if (thisindex >= thisleni) - break; - else if (STRINGP (this)) - { - int c; - if (STRING_MULTIBYTE (this)) - c = fetch_string_char_advance_no_check (this, &thisindex, - &thisindex_byte); - else - { - c = SREF (this, thisindex); thisindex++; - if (some_multibyte && !ASCII_CHAR_P (c)) - c = BYTE8_TO_CHAR (c); - } - XSETFASTINT (elt, c); - } - else if (BOOL_VECTOR_P (this)) - { - elt = bool_vector_ref (this, thisindex); - thisindex++; - } - else - { - elt = AREF (this, thisindex); - thisindex++; - } - - /* Store this element into the result. */ - if (toindex < 0) - { - XSETCAR (tail, elt); - prev = tail; - tail = XCDR (tail); - } - else if (VECTORP (val)) - { - ASET (val, toindex, elt); - toindex++; - } + int c = XFIXNAT (XCAR (tail)); + if (dest_multibyte) + toindex_byte += CHAR_STRING (c, SDATA (result) + toindex_byte); else - { - int c; - CHECK_CHARACTER (elt); - c = XFIXNAT (elt); - if (some_multibyte) - toindex_byte += CHAR_STRING (c, SDATA (val) + toindex_byte); - else - SSET (val, toindex_byte++, c); - toindex++; - } + SSET (result, toindex_byte++, c); + toindex++; } } - if (!NILP (prev)) - XSETCDR (prev, last_tail); if (num_textprops > 0) { - Lisp_Object props; ptrdiff_t last_to_end = -1; - - for (argnum = 0; argnum < num_textprops; argnum++) + for (ptrdiff_t i = 0; i < num_textprops; i++) { - this = args[textprops[argnum].argnum]; - props = text_property_list (this, - make_fixnum (0), - make_fixnum (SCHARS (this)), - Qnil); + Lisp_Object arg = args[textprops[i].argnum]; + Lisp_Object props = text_property_list (arg, + make_fixnum (0), + make_fixnum (SCHARS (arg)), + Qnil); /* If successive arguments have properties, be sure that the value of `composition' property be the copy. */ - if (last_to_end == textprops[argnum].to) + if (last_to_end == textprops[i].to) make_composition_value_copy (props); - add_text_properties_from_list (val, props, - make_fixnum (textprops[argnum].to)); - last_to_end = textprops[argnum].to + SCHARS (this); + add_text_properties_from_list (result, props, + make_fixnum (textprops[i].to)); + last_to_end = textprops[i].to + SCHARS (arg); } } SAFE_FREE (); - return val; + return result; +} + +/* Concatenate sequences into a list or vector. */ + +Lisp_Object +concat (ptrdiff_t nargs, Lisp_Object *args, Lisp_Object last_tail, + bool vector_target) +{ + /* Check argument types and compute total length of arguments. */ + EMACS_INT result_len = 0; + for (ptrdiff_t i = 0; i < nargs; i++) + { + Lisp_Object arg = args[i]; + if (!(CONSP (arg) || NILP (arg) || VECTORP (arg) || STRINGP (arg) + || COMPILEDP (arg) || BOOL_VECTOR_P (arg))) + wrong_type_argument (Qsequencep, arg); + EMACS_INT len = XFIXNAT (Flength (arg)); + result_len += len; + if (MOST_POSITIVE_FIXNUM < result_len) + memory_full (SIZE_MAX); + } + + /* Create the output object. */ + Lisp_Object result = vector_target + ? make_nil_vector (result_len) + : Fmake_list (make_fixnum (result_len), Qnil); + + /* In `append', if all but last arg are nil, return last arg. */ + if (!vector_target && NILP (result)) + return last_tail; + + /* Copy the contents of the args into the result. */ + Lisp_Object tail = Qnil; + ptrdiff_t toindex = 0; + if (CONSP (result)) + { + tail = result; + toindex = -1; /* -1 in toindex is flag we are making a list */ + } + + Lisp_Object prev = Qnil; + + for (ptrdiff_t i = 0; i < nargs; i++) + { + ptrdiff_t arglen = 0; + ptrdiff_t argindex = 0; + ptrdiff_t argindex_byte = 0; + + Lisp_Object arg = args[i]; + if (!CONSP (arg)) + arglen = XFIXNUM (Flength (arg)); + + /* Copy element by element. */ + while (1) + { + /* Fetch next element of `arg' arg into `elt', or break if + `arg' is exhausted. */ + Lisp_Object elt; + if (NILP (arg)) + break; + if (CONSP (arg)) + { + elt = XCAR (arg); + arg = XCDR (arg); + } + else if (argindex >= arglen) + break; + else if (STRINGP (arg)) + { + int c; + if (STRING_MULTIBYTE (arg)) + c = fetch_string_char_advance_no_check (arg, &argindex, + &argindex_byte); + else + { + c = SREF (arg, argindex); + argindex++; + } + XSETFASTINT (elt, c); + } + else if (BOOL_VECTOR_P (arg)) + { + elt = bool_vector_ref (arg, argindex); + argindex++; + } + else + { + elt = AREF (arg, argindex); + argindex++; + } + + /* Store this element into the result. */ + if (toindex < 0) + { + XSETCAR (tail, elt); + prev = tail; + tail = XCDR (tail); + } + else + { + ASET (result, toindex, elt); + toindex++; + } + } + } + if (!NILP (prev)) + XSETCDR (prev, last_tail); + + return result; } static Lisp_Object string_char_byte_cache_string; @@ -1380,7 +1446,7 @@ Elements of ALIST that are not conses are also shared. */) { if (NILP (alist)) return alist; - alist = concat (1, &alist, Lisp_Cons, false); + alist = Fcopy_sequence (alist); for (Lisp_Object tem = alist; !NILP (tem); tem = XCDR (tem)) { Lisp_Object car = XCAR (tem); commit f16039b16120abd0b7e1293292f90d69358e0fef Author: Lars Ingebrigtsen Date: Tue Jan 25 14:21:22 2022 +0100 Don't mutate literals in tabulated-list-widen-current-column * lisp/emacs-lisp/tabulated-list.el (tabulated-list-widen-current-column): Avoid mutating constants (bug#53501). diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 2defef8107..b740a7457a 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -755,6 +755,9 @@ Interactively, N is the prefix numeric argument, and defaults to 1)))) (setq col-nb (1+ col-nb)) (setq found t) + ;; `tabulated-list-format' may be a constant (sharing list + ;; structures), so copy it before mutating. + (setq tabulated-list-format (copy-tree tabulated-list-format t)) (setf (cadr (aref tabulated-list-format col-nb)) (max 1 (+ col-width n))) (tabulated-list-print t) commit c40398e0080a44eac709871f9eb3fca2bb9a1560 Author: Lars Ingebrigtsen Date: Tue Jan 25 13:58:30 2022 +0100 Fix widening some columns in tabulated-list-widen-current-column * lisp/emacs-lisp/tabulated-list.el (tabulated-list-widen-current-column): Don't bug out on list-based columns (bug#53498). diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index a242ac1899..2defef8107 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -745,7 +745,10 @@ Interactively, N is the prefix numeric argument, and defaults to (max (setq col-width (cadr (aref tabulated-list-format col-nb))) - (string-width (aref entry col-nb))) + (let ((desc (aref entry col-nb))) + (string-width (if (stringp desc) + desc + (car desc))))) (or (plist-get (nthcdr 3 (aref tabulated-list-format col-nb)) :pad-right) commit 44ffd6a825300fec5e492805bb105d2c8c3d0c1c Author: Jim Porter Date: Mon Jan 24 21:08:50 2022 -0800 Treat "-" as a positional arg in 'eshell-eval-using-options' * lisp/eshell/esh-opt.el (eshell--process-args): Treat "-" as a positional arg. * lisp/eshell/em-tramp.el (eshell/su): Simplify checking for "-". * test/lisp/eshell/esh-opt-tests.el (esh-opt-test/eval-using-options-stdin): New test. diff --git a/lisp/eshell/em-tramp.el b/lisp/eshell/em-tramp.el index 791458822d..2afd4fe066 100644 --- a/lisp/eshell/em-tramp.el +++ b/lisp/eshell/em-tramp.el @@ -57,13 +57,12 @@ (autoload 'eshell-parse-command "esh-cmd") -(defun eshell/su (&rest arguments) +(defun eshell/su (&rest args) "Alias \"su\" to call TRAMP. Uses the system su through TRAMP's su method." - (setq arguments (eshell-stringify-list (flatten-tree arguments))) (eshell-eval-using-options - "su" arguments + "su" args '((?h "help" nil nil "show this usage screen") (?l "login" nil login "provide a login environment") (? nil nil login "provide a login environment") @@ -77,10 +76,6 @@ Become another USER during a login session.") (prefix (file-remote-p default-directory))) (dolist (arg args) (if (string-equal arg "-") (setq login t) (setq user arg))) - ;; `eshell-eval-using-options' tries to handle "-" as a - ;; short option; double-check whether the original - ;; arguments include it. - (when (member "-" arguments) (setq login t)) (when login (setq dir "~/")) (if (and prefix (or diff --git a/lisp/eshell/esh-opt.el b/lisp/eshell/esh-opt.el index 8c29fff809..0961e214f4 100644 --- a/lisp/eshell/esh-opt.el +++ b/lisp/eshell/esh-opt.el @@ -283,6 +283,9 @@ triggered to say that the switch is unrecognized." (memq :parse-leading-options-only options)))) (setq arg (nth ai eshell--args)) (if (not (and (stringp arg) + ;; A string of length 1 can't be an option; (if + ;; it's "-", that generally means stdin). + (> (length arg) 1) (string-match "^-\\(-\\)?\\(.*\\)" arg))) ;; Positional argument found, skip (setq ai (1+ ai) @@ -295,9 +298,9 @@ triggered to say that the switch is unrecognized." (if (> (length switch) 0) (eshell--process-option name switch 1 ai options opt-vals) (setq ai (length eshell--args))) - (while (> (length switch) 0) - (setq switch (eshell--process-option name switch 0 - ai options opt-vals))))))) + (while (> (length switch) 0) + (setq switch (eshell--process-option name switch 0 + ai options opt-vals))))))) (nconc (mapcar #'cdr opt-vals) eshell--args))) (provide 'esh-opt) diff --git a/test/lisp/eshell/esh-opt-tests.el b/test/lisp/eshell/esh-opt-tests.el index 4331c02ff5..5b30de414a 100644 --- a/test/lisp/eshell/esh-opt-tests.el +++ b/test/lisp/eshell/esh-opt-tests.el @@ -182,6 +182,27 @@ (should (equal ignore-pattern "*.txt")) (should (equal args '("/some/path"))))) +(ert-deftest esh-opt-test/eval-using-options-stdin () + "Test that \"-\" is a positional arg in `eshell-eval-using-options'." + (eshell-eval-using-options + "cat" '("-") + '((?A "show-all" nil show-all + "show all characters")) + (should (eq show-all nil)) + (should (equal args '("-")))) + (eshell-eval-using-options + "cat" '("-A" "-") + '((?A "show-all" nil show-all + "show all characters")) + (should (eq show-all t)) + (should (equal args '("-")))) + (eshell-eval-using-options + "cat" '("-" "-A") + '((?A "show-all" nil show-all + "show all characters")) + (should (eq show-all t)) + (should (equal args '("-"))))) + (ert-deftest esh-opt-test/eval-using-options-terminate-options () "Test that \"--\" terminates options in `eshell-eval-using-options'." (eshell-eval-using-options commit dea24a0f7d4ae42fae912dd724a770678054989a Author: Jim Porter Date: Mon Jan 24 21:03:42 2022 -0800 Don't manipulate args in-place for 'eshell-eval-using-options' This is necessary for preserve the original arguments to forward on to :external commands. Previously, when :preserve-args was also set, the original argument list could be altered, changing the meaning of the command. * lisp/eshell/esh-opt.el (eshell-eval-using-options): Copy MACRO-ARGS when :preserve-args is set, and pass the original value to 'eshell--do-opts'. (eshell--do-opts): Use the original arguments when calling an external command. * lisp/eshell/em-tramp.el (eshell/su, eshell/sudo): Don't copy the original arguments, since 'eshell-eval-using-options' does this for us. * test/lisp/eshell/esh-opt-tests.el (esh-opt-process-args-test): Split this test into... (esh-opt-test/process-args) (esh-opt-test/process-args-parse-leading-options-only) (esh-opt-test/process-args-external): ... these. (test-eshell-eval-using-options): Split this test into... (esh-opt-test/eval-using-options-short) (esh-opt-test/eval-using-options-long) (esh-opt-test/eval-using-options-constant) (esh-opt-test/eval-using-options-user-specified) (esh-opt-test/eval-using-options-short-single-token) (esh-opt-test/eval-using-options-terminate-options) (esh-opt-test/eval-using-options-parse-leading-options-only) (esh-opt-test/eval-using-options-unrecognized): ... these. (esh-opt-test/eval-using-options-external): New test. * test/lisp/eshell/em-tramp-tests.el: New tests. diff --git a/lisp/eshell/em-tramp.el b/lisp/eshell/em-tramp.el index e9018bdb93..791458822d 100644 --- a/lisp/eshell/em-tramp.el +++ b/lisp/eshell/em-tramp.el @@ -57,41 +57,42 @@ (autoload 'eshell-parse-command "esh-cmd") -(defun eshell/su (&rest args) +(defun eshell/su (&rest arguments) "Alias \"su\" to call TRAMP. Uses the system su through TRAMP's su method." - (setq args (eshell-stringify-list (flatten-tree args))) - (let ((orig-args (copy-tree args))) - (eshell-eval-using-options - "su" args - '((?h "help" nil nil "show this usage screen") - (?l "login" nil login "provide a login environment") - (? nil nil login "provide a login environment") - :usage "[- | -l | --login] [USER] + (setq arguments (eshell-stringify-list (flatten-tree arguments))) + (eshell-eval-using-options + "su" arguments + '((?h "help" nil nil "show this usage screen") + (?l "login" nil login "provide a login environment") + (? nil nil login "provide a login environment") + :usage "[- | -l | --login] [USER] Become another USER during a login session.") - (throw 'eshell-replace-command - (let ((user "root") - (host (or (file-remote-p default-directory 'host) - "localhost")) - (dir (file-local-name (expand-file-name default-directory))) - (prefix (file-remote-p default-directory))) - (dolist (arg args) - (if (string-equal arg "-") (setq login t) (setq user arg))) - ;; `eshell-eval-using-options' does not handle "-". - (if (member "-" orig-args) (setq login t)) - (if login (setq dir "~/")) - (if (and prefix - (or - (not (string-equal - "su" (file-remote-p default-directory 'method))) - (not (string-equal - user (file-remote-p default-directory 'user))))) - (eshell-parse-command - "cd" (list (format "%s|su:%s@%s:%s" - (substring prefix 0 -1) user host dir))) - (eshell-parse-command - "cd" (list (format "/su:%s@%s:%s" user host dir))))))))) + (throw 'eshell-replace-command + (let ((user "root") + (host (or (file-remote-p default-directory 'host) + "localhost")) + (dir (file-local-name (expand-file-name default-directory))) + (prefix (file-remote-p default-directory))) + (dolist (arg args) + (if (string-equal arg "-") (setq login t) (setq user arg))) + ;; `eshell-eval-using-options' tries to handle "-" as a + ;; short option; double-check whether the original + ;; arguments include it. + (when (member "-" arguments) (setq login t)) + (when login (setq dir "~/")) + (if (and prefix + (or + (not (string-equal + "su" (file-remote-p default-directory 'method))) + (not (string-equal + user (file-remote-p default-directory 'user))))) + (eshell-parse-command + "cd" (list (format "%s|su:%s@%s:%s" + (substring prefix 0 -1) user host dir))) + (eshell-parse-command + "cd" (list (format "/su:%s@%s:%s" user host dir)))))))) (put 'eshell/su 'eshell-no-numeric-conversions t) @@ -99,41 +100,35 @@ Become another USER during a login session.") "Alias \"sudo\" to call Tramp. Uses the system sudo through TRAMP's sudo method." - (setq args (eshell-stringify-list (flatten-tree args))) - (let ((orig-args (copy-tree args))) - (eshell-eval-using-options - "sudo" args - '((?h "help" nil nil "show this usage screen") - (?u "user" t user "execute a command as another USER") - :show-usage - :parse-leading-options-only - :usage "[(-u | --user) USER] COMMAND + (eshell-eval-using-options + "sudo" args + '((?h "help" nil nil "show this usage screen") + (?u "user" t user "execute a command as another USER") + :show-usage + :parse-leading-options-only + :usage "[(-u | --user) USER] COMMAND Execute a COMMAND as the superuser or another USER.") - (throw 'eshell-external - (let ((user (or user "root")) - (host (or (file-remote-p default-directory 'host) - "localhost")) - (dir (file-local-name (expand-file-name default-directory))) - (prefix (file-remote-p default-directory))) - ;; `eshell-eval-using-options' reads options of COMMAND. - (while (and (stringp (car orig-args)) - (member (car orig-args) '("-u" "--user"))) - (setq orig-args (cddr orig-args))) - (let ((default-directory - (if (and prefix - (or - (not - (string-equal - "sudo" - (file-remote-p default-directory 'method))) - (not - (string-equal - user - (file-remote-p default-directory 'user))))) - (format "%s|sudo:%s@%s:%s" - (substring prefix 0 -1) user host dir) - (format "/sudo:%s@%s:%s" user host dir)))) - (eshell-named-command (car orig-args) (cdr orig-args)))))))) + (throw 'eshell-external + (let* ((user (or user "root")) + (host (or (file-remote-p default-directory 'host) + "localhost")) + (dir (file-local-name (expand-file-name default-directory))) + (prefix (file-remote-p default-directory)) + (default-directory + (if (and prefix + (or + (not + (string-equal + "sudo" + (file-remote-p default-directory 'method))) + (not + (string-equal + user + (file-remote-p default-directory 'user))))) + (format "%s|sudo:%s@%s:%s" + (substring prefix 0 -1) user host dir) + (format "/sudo:%s@%s:%s" user host dir)))) + (eshell-named-command (car args) (cdr args)))))) (put 'eshell/sudo 'eshell-no-numeric-conversions t) diff --git a/lisp/eshell/esh-opt.el b/lisp/eshell/esh-opt.el index c802bee3af..8c29fff809 100644 --- a/lisp/eshell/esh-opt.el +++ b/lisp/eshell/esh-opt.el @@ -97,10 +97,10 @@ let-bound variable `args'." (declare (debug (form form sexp body))) `(let* ((temp-args ,(if (memq ':preserve-args (cadr options)) - macro-args + (list 'copy-tree macro-args) (list 'eshell-stringify-list (list 'flatten-tree macro-args)))) - (processed-args (eshell--do-opts ,name ,options temp-args)) + (processed-args (eshell--do-opts ,name ,options temp-args ,macro-args)) ,@(delete-dups (delq nil (mapcar (lambda (opt) (and (listp opt) (nth 3 opt) @@ -117,7 +117,7 @@ let-bound variable `args'." ;; Documented part of the interface; see eshell-eval-using-options. (defvar eshell--args) -(defun eshell--do-opts (name options args) +(defun eshell--do-opts (name options args orig-args) "Helper function for `eshell-eval-using-options'. This code doesn't really need to be macro expanded everywhere." (require 'esh-ext) @@ -135,7 +135,7 @@ This code doesn't really need to be macro expanded everywhere." (error "%s" usage-msg)))))) (if ext-command (throw 'eshell-external - (eshell-external-command ext-command args)) + (eshell-external-command ext-command orig-args)) args))) (defun eshell-show-usage (name options) diff --git a/test/lisp/eshell/em-tramp-tests.el b/test/lisp/eshell/em-tramp-tests.el new file mode 100644 index 0000000000..7f054da514 --- /dev/null +++ b/test/lisp/eshell/em-tramp-tests.el @@ -0,0 +1,85 @@ +;;; em-tramp-tests.el --- em-tramp test suite -*- lexical-binding:t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'em-tramp) + +(ert-deftest em-tramp-test/su-default () + "Test Eshell `su' command with no arguments." + (should (equal + (catch 'eshell-replace-command (eshell/su)) + `(eshell-trap-errors + (eshell-named-command + "cd" + (list ,(format "/su:root@localhost:%s" default-directory))))))) + +(ert-deftest em-tramp-test/su-user () + "Test Eshell `su' command with USER argument." + (should (equal + (catch 'eshell-replace-command (eshell/su "USER")) + `(eshell-trap-errors + (eshell-named-command + "cd" + (list ,(format "/su:USER@localhost:%s" default-directory))))))) + +(ert-deftest em-tramp-test/su-login () + "Test Eshell `su' command with -/-l/--login option." + (dolist (args '(("--login") + ("-l") + ("-"))) + (should (equal + (catch 'eshell-replace-command (apply #'eshell/su args)) + `(eshell-trap-errors + (eshell-named-command + "cd" + (list "/su:root@localhost:~/"))))))) + +(defun mock-eshell-named-command (&rest args) + "Dummy function to test Eshell `sudo' command rewriting." + (list default-directory args)) + +(ert-deftest em-tramp-test/sudo-basic () + "Test Eshell `sudo' command with default user." + (cl-letf (((symbol-function 'eshell-named-command) + #'mock-eshell-named-command)) + (should (equal + (catch 'eshell-external (eshell/sudo "echo" "hi")) + `(,(format "/sudo:root@localhost:%s" default-directory) + ("echo" ("hi"))))) + (should (equal + (catch 'eshell-external (eshell/sudo "echo" "-u" "hi")) + `(,(format "/sudo:root@localhost:%s" default-directory) + ("echo" ("-u" "hi"))))))) + +(ert-deftest em-tramp-test/sudo-user () + "Test Eshell `sudo' command with specified user." + (cl-letf (((symbol-function 'eshell-named-command) + #'mock-eshell-named-command)) + (should (equal + (catch 'eshell-external (eshell/sudo "-u" "USER" "echo" "hi")) + `(,(format "/sudo:USER@localhost:%s" default-directory) + ("echo" ("hi"))))) + (should (equal + (catch 'eshell-external (eshell/sudo "-u" "USER" "echo" "-u" "hi")) + `(,(format "/sudo:USER@localhost:%s" default-directory) + ("echo" ("-u" "hi"))))))) + +;;; em-tramp-tests.el ends here diff --git a/test/lisp/eshell/esh-opt-tests.el b/test/lisp/eshell/esh-opt-tests.el index b76ed8866d..4331c02ff5 100644 --- a/test/lisp/eshell/esh-opt-tests.el +++ b/test/lisp/eshell/esh-opt-tests.el @@ -22,8 +22,8 @@ (require 'ert) (require 'esh-opt) -(ert-deftest esh-opt-process-args-test () - "Unit tests which verify correct behavior of `eshell--process-args'." +(ert-deftest esh-opt-test/process-args () + "Test behavior of `eshell--process-args'." (should (equal '(t) (eshell--process-args @@ -35,7 +35,10 @@ (eshell--process-args "sudo" '("-u" "root" "world") '((?u "user" t user - "execute a command as another USER"))))) + "execute a command as another USER")))))) + +(ert-deftest esh-opt-test/process-args-parse-leading-options-only () + "Test behavior of :parse-leading-options-only in `eshell--process-args'." (should (equal '(nil "emerge" "-uDN" "world") (eshell--process-args @@ -55,9 +58,10 @@ (eshell--process-args "sudo" '("-u" "root" "emerge" "-uDN" "world") '((?u "user" t user - "execute a command as another USER"))))) + "execute a command as another USER")))))) - ;; Test :external. +(ert-deftest esh-opt-test/process-args-external () + "Test behavior of :external in `eshell--process-args'." (cl-letf (((symbol-function 'eshell-search-path) #'ignore)) (should (equal '(nil "/some/path") @@ -85,9 +89,8 @@ :external "ls")) :type 'error))) -(ert-deftest test-eshell-eval-using-options () - "Tests for `eshell-eval-using-options'." - ;; Test short options. +(ert-deftest esh-opt-test/eval-using-options-short () + "Test `eshell-eval-using-options' with short options." (eshell-eval-using-options "ls" '("-a" "/some/path") '((?a "all" nil show-all @@ -99,17 +102,19 @@ '((?a "all" nil show-all "do not ignore entries starting with .")) (should (eq show-all nil)) - (should (equal args '("/some/path")))) + (should (equal args '("/some/path"))))) - ;; Test long options. +(ert-deftest esh-opt-test/eval-using-options-long () + "Test `eshell-eval-using-options' with long options." (eshell-eval-using-options "ls" '("--all" "/some/path") '((?a "all" nil show-all "do not ignore entries starting with .")) (should (eq show-all t)) - (should (equal args '("/some/path")))) + (should (equal args '("/some/path"))))) - ;; Test options with constant values. +(ert-deftest esh-opt-test/eval-using-options-constant () + "Test `eshell-eval-using-options' with options with constant values." (eshell-eval-using-options "ls" '("/some/path" "-h") '((?h "human-readable" 1024 human-readable @@ -127,9 +132,10 @@ '((?h "human-readable" 1024 human-readable "print sizes in human readable format")) (should (eq human-readable nil)) - (should (equal args '("/some/path")))) + (should (equal args '("/some/path"))))) - ;; Test options with user-specified values. +(ert-deftest esh-opt-test/eval-using-options-user-specified () + "Test `eshell-eval-using-options' with options with user-specified values." (eshell-eval-using-options "ls" '("-I" "*.txt" "/some/path") '((?I "ignore" t ignore-pattern @@ -153,9 +159,10 @@ '((?I "ignore" t ignore-pattern "do not list implied entries matching pattern")) (should (equal ignore-pattern "*.txt")) - (should (equal args '("/some/path")))) + (should (equal args '("/some/path"))))) - ;; Test multiple short options in a single token. +(ert-deftest esh-opt-test/eval-using-options-short-single-token () + "Test `eshell-eval-using-options' with multiple short options in one token." (eshell-eval-using-options "ls" '("-al" "/some/path") '((?a "all" nil show-all @@ -173,9 +180,10 @@ "do not list implied entries matching pattern")) (should (eq t show-all)) (should (equal ignore-pattern "*.txt")) - (should (equal args '("/some/path")))) + (should (equal args '("/some/path"))))) - ;; Test that "--" terminates options. +(ert-deftest esh-opt-test/eval-using-options-terminate-options () + "Test that \"--\" terminates options in `eshell-eval-using-options'." (eshell-eval-using-options "ls" '("--" "-a") '((?a "all" nil show-all @@ -187,9 +195,10 @@ '((?a "all" nil show-all "do not ignore entries starting with .")) (should (eq show-all nil)) - (should (equal args '("--all")))) + (should (equal args '("--all"))))) - ;; Test :parse-leading-options-only. +(ert-deftest esh-opt-test/eval-using-options-parse-leading-options-only () + "Test :parse-leading-options-only in `eshell-eval-using-options'." (eshell-eval-using-options "sudo" '("-u" "root" "whoami") '((?u "user" t user "execute a command as another USER") @@ -212,27 +221,47 @@ '((?u "user" t user "execute a command as another USER") :parse-leading-options-only) (should (eq user nil)) - (should (equal args '("emerge" "-uDN" "world")))) + (should (equal args '("emerge" "-uDN" "world"))))) - ;; Test unrecognized options. +(ert-deftest esh-opt-test/eval-using-options-unrecognized () + "Test `eshell-eval-using-options' with unrecognized options." (should-error (eshell-eval-using-options "ls" '("-u" "/some/path") - '((?a "all" nil show-all - "do not ignore entries starting with .")) - (ignore show-all))) + '((?a "all" nil _show-all + "do not ignore entries starting with .")))) (should-error (eshell-eval-using-options "ls" '("-au" "/some/path") - '((?a "all" nil show-all - "do not ignore entries starting with .")) - (ignore show-all))) + '((?a "all" nil _show-all + "do not ignore entries starting with .")))) (should-error (eshell-eval-using-options "ls" '("--unrecognized" "/some/path") - '((?a "all" nil show-all - "do not ignore entries starting with .")) - (ignore show-all)))) + '((?a "all" nil _show-all + "do not ignore entries starting with ."))))) + +(ert-deftest esh-opt-test/eval-using-options-external () + "Test :external in `eshell-eval-using-options'." + (cl-letf (((symbol-function 'eshell-search-path) #'identity) + ((symbol-function 'eshell-external-command) #'list)) + (should + (equal (catch 'eshell-external + (eshell-eval-using-options + "ls" '("/some/path" "-u") + '((?a "all" nil _show-all + "do not ignore entries starting with .") + :external "ls"))) + '("ls" ("/some/path" "-u")))) + (should + (equal (catch 'eshell-external + (eshell-eval-using-options + "ls" '("/some/path2" "-u") + '((?a "all" nil _show-all + "do not ignore entries starting with .") + :preserve-args + :external "ls"))) + '("ls" ("/some/path2" "-u")))))) (provide 'esh-opt-tests) commit 7eca80b20444f7bd7bcb6a66a9054e029f0e7013 (refs/remotes/origin/emacs-28) Author: Eli Zaretskii Date: Tue Jan 25 14:15:36 2022 +0200 ; * src/composite.c (syms_of_composite) : Doc fix. diff --git a/src/composite.c b/src/composite.c index 711284ba6f..a4db66b92d 100644 --- a/src/composite.c +++ b/src/composite.c @@ -2064,7 +2064,8 @@ The default value is the function `compose-chars-after'. */); Use the command `auto-composition-mode' to change this variable. If this variable is a string, `auto-composition-mode' will be disabled in -buffers displayed on a terminal whose type compares equal to this string. */); +buffers displayed on a terminal whose type, as reported by `tty-type', +compares equal to that string. */); Vauto_composition_mode = Qt; DEFVAR_LISP ("auto-composition-function", Vauto_composition_function, commit 115f3f59346595ce01625396c448983a9d17f24c Author: Lars Ingebrigtsen Date: Tue Jan 25 12:51:23 2022 +0100 Improve the term-clear-full-screen-programs doc string * lisp/term.el (term-clear-full-screen-programs): Improve the doc string. diff --git a/lisp/term.el b/lisp/term.el index 0c8763b462..3e05d529cd 100644 --- a/lisp/term.el +++ b/lisp/term.el @@ -524,8 +524,8 @@ This means text can automatically reflow if the window is resized." "27.1") (defcustom term-clear-full-screen-programs t - "Whether to clear contents of full-screen TUI programs after exit. -If non-nil, output of full-screen TUI programs is cleared after + "Whether to clear contents of full-screen terminal programs after exit. +If non-nil, output of full-screen terminal programs is cleared after exiting them. Note however that a minority of such programs don't send an appropriate escape sequence to the terminal before exiting so their output isn't cleared regardless of this option." commit 4d342f36a6764aaf33c76d48d19899be621dc59b Author: Po Lu Date: Tue Jan 25 11:19:20 2022 +0000 Improve reliability of menu bar updates on Haiku * src/haiku_support.cc (class EmacsWindow): New fields `menu_update_cv', `menu_update_mutex' and `menu_updated_p'. (~EmacsWindow): Destroy cv and mutex. (MenusBeginning): Release lock and wait for condition to be become true. (EmacsWindow_signal_menu_update_complete): New function. * src/haiku_support.h (struct haiku_menu_bar_state_event): New field `no_lock'. * src/haikumenu.c (Fhaiku_menu_bar_open): Always update menu bar. * src/haikuterm.c (haiku_read_socket): Always update menu bar and signal the window thread after update completion. diff --git a/src/haiku_support.cc b/src/haiku_support.cc index af30bc8b3c..41e5b71182 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -408,6 +408,9 @@ class EmacsWindow : public BWindow window_look pre_override_redirect_style; window_feel pre_override_redirect_feel; uint32 pre_override_redirect_workspaces; + pthread_mutex_t menu_update_mutex = PTHREAD_MUTEX_INITIALIZER; + pthread_cond_t menu_update_cv = PTHREAD_COND_INITIALIZER; + bool menu_updated_p = false; EmacsWindow () : BWindow (BRect (0, 0, 0, 0), "", B_TITLED_WINDOW_LOOK, B_NORMAL_WINDOW_FEEL, B_NO_SERVER_SIDE_WINDOW_MODIFIERS) @@ -433,6 +436,9 @@ class EmacsWindow : public BWindow if (this->parent) UnparentAndUnlink (); child_frame_lock.Unlock (); + + pthread_cond_destroy (&menu_update_cv); + pthread_mutex_destroy (&menu_update_mutex); } void @@ -805,9 +811,36 @@ class EmacsWindow : public BWindow MenusBeginning () { struct haiku_menu_bar_state_event rq; + int lock_count = 0; + thread_id current_thread = find_thread (NULL); + thread_id window_thread = Thread (); rq.window = this; + rq.no_lock = false; + + if (window_thread != current_thread) + rq.no_lock = true; haiku_write (MENU_BAR_OPEN, &rq); + + if (!rq.no_lock) + { + while (IsLocked ()) + { + ++lock_count; + UnlockLooper (); + } + pthread_mutex_lock (&menu_update_mutex); + while (!menu_updated_p) + pthread_cond_wait (&menu_update_cv, + &menu_update_mutex); + menu_updated_p = false; + pthread_mutex_unlock (&menu_update_mutex); + for (; lock_count; --lock_count) + { + if (!LockLooper ()) + gui_abort ("Failed to lock after cv signal denoting menu update"); + } + } menu_bar_active_p = true; } @@ -3212,3 +3245,14 @@ be_find_setting (const char *name) return value; } + +void +EmacsWindow_signal_menu_update_complete (void *window) +{ + EmacsWindow *w = (EmacsWindow *) window; + + pthread_mutex_lock (&w->menu_update_mutex); + w->menu_updated_p = true; + pthread_cond_signal (&w->menu_update_cv); + pthread_mutex_unlock (&w->menu_update_mutex); +} diff --git a/src/haiku_support.h b/src/haiku_support.h index 6ddc28759b..8d4dddd90f 100644 --- a/src/haiku_support.h +++ b/src/haiku_support.h @@ -299,6 +299,7 @@ struct haiku_menu_bar_resize_event struct haiku_menu_bar_state_event { void *window; + bool no_lock; }; #define HAIKU_THIN 0 @@ -864,6 +865,9 @@ extern "C" extern const char * be_find_setting (const char *name); + extern void + EmacsWindow_signal_menu_update_complete (void *window); + #ifdef __cplusplus extern void * find_appropriate_view_for_draw (void *vw); diff --git a/src/haikumenu.c b/src/haikumenu.c index 1c75e0f9a4..3fee583160 100644 --- a/src/haikumenu.c +++ b/src/haikumenu.c @@ -644,10 +644,7 @@ the position of the last non-menu event instead. */) struct frame *f = decode_window_system_frame (frame); if (FRAME_EXTERNAL_MENU_BAR (f)) - { - if (!FRAME_OUTPUT_DATA (f)->menu_up_to_date_p) - set_frame_menubar (f, 1); - } + set_frame_menubar (f, 1); else { return call2 (Qpopup_menu, call0 (Qmouse_menu_bar_map), diff --git a/src/haikuterm.c b/src/haikuterm.c index 7ab41805ea..c8cc02a298 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -3178,20 +3178,20 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) if (type == MENU_BAR_OPEN) { - if (!FRAME_OUTPUT_DATA (f)->menu_up_to_date_p) - { - BView_draw_lock (FRAME_HAIKU_VIEW (f)); - /* This shouldn't be here, but nsmenu does it, so - it should probably be safe. */ - int was_waiting_for_input_p = waiting_for_input; - if (waiting_for_input) - waiting_for_input = 0; - set_frame_menubar (f, 1); - waiting_for_input = was_waiting_for_input_p; - BView_draw_unlock (FRAME_HAIKU_VIEW (f)); - } + BView_draw_lock (FRAME_HAIKU_VIEW (f)); + /* This shouldn't be here, but nsmenu does it, so + it should probably be safe. */ + int was_waiting_for_input_p = waiting_for_input; + if (waiting_for_input) + waiting_for_input = 0; + set_frame_menubar (f, 1); + waiting_for_input = was_waiting_for_input_p; + BView_draw_unlock (FRAME_HAIKU_VIEW (f)); FRAME_OUTPUT_DATA (f)->menu_bar_open_p = 1; popup_activated_p += 1; + + if (!b->no_lock) + EmacsWindow_signal_menu_update_complete (b->window); } else { commit 03c9257b119637703482e00816d054320b81f214 Author: Po Lu Date: Tue Jan 25 10:18:35 2022 +0000 * src/haiku_support.cc (Highlight): Send events if !highlight_p. diff --git a/src/haiku_support.cc b/src/haiku_support.cc index 23f7472e3f..af30bc8b3c 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -1650,7 +1650,7 @@ class EmacsMenuItem : public BMenuItem r = Frame (); menu->GetMouse (&pt, &buttons); - if (r.Contains (pt)) + if (!highlight_p || r.Contains (pt)) haiku_write (MENU_BAR_HELP_EVENT, &rq); } commit 0a70f748e759b77a760be2efac8e2460b777c6f5 Author: Po Lu Date: Tue Jan 25 10:02:16 2022 +0000 Don't send menu help events on Haiku if the pointer isn't in the menu * src/haiku_support.cc (Highlight): Only send help events if the mouse cursor is actually in the menu. diff --git a/src/haiku_support.cc b/src/haiku_support.cc index ae2736110e..23f7472e3f 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -1635,17 +1635,23 @@ class EmacsMenuItem : public BMenuItem Highlight (bool highlight_p) { struct haiku_menu_bar_help_event rq; + BMenu *menu = Menu (); + BRect r; + BPoint pt; + uint32 buttons; if (help) - { - Menu ()->SetToolTip (highlight_p ? help : NULL); - } + menu->SetToolTip (highlight_p ? help : NULL); else if (menu_bar_id >= 0) { rq.window = wind_ptr; rq.mb_idx = highlight_p ? menu_bar_id : -1; - haiku_write (MENU_BAR_HELP_EVENT, &rq); + r = Frame (); + menu->GetMouse (&pt, &buttons); + + if (r.Contains (pt)) + haiku_write (MENU_BAR_HELP_EVENT, &rq); } BMenuItem::Highlight (highlight_p);