commit f471eaf44058cfec9e5f7eb53d0a66520f4d4f6d (HEAD, refs/remotes/origin/master) Author: Lars Ingebrigtsen Date: Mon May 23 08:19:04 2022 +0200 Make bootstrap remove more generated files * Makefile.in (bootstrap-clean): Remove lisp/leim/ja-dic/. diff --git a/Makefile.in b/Makefile.in index c3c218a197..4b74963665 100644 --- a/Makefile.in +++ b/Makefile.in @@ -965,7 +965,7 @@ bootstrap-clean: $(distclean_dirs:=_bootstrap-clean) [ ! -f config.log ] || mv -f config.log config.log~ rm -rf ${srcdir}/info rm -f ${srcdir}/etc/refcards/emacsver.tex - rm -rf native-lisp/ + rm -rf native-lisp/ lisp/leim/ja-dic/ ${top_bootclean} ### 'maintainer-clean' commit a6312d4217cef0d0079a9ad198495dfb2106cc6f Author: Lars Ingebrigtsen Date: Mon May 23 08:09:05 2022 +0200 Make bootstrap remove the native-lisp/ directory * Makefile.in (bootstrap-clean): Remove the native-lisp/ directory. diff --git a/Makefile.in b/Makefile.in index 877802ec11..c3c218a197 100644 --- a/Makefile.in +++ b/Makefile.in @@ -965,6 +965,7 @@ bootstrap-clean: $(distclean_dirs:=_bootstrap-clean) [ ! -f config.log ] || mv -f config.log config.log~ rm -rf ${srcdir}/info rm -f ${srcdir}/etc/refcards/emacsver.tex + rm -rf native-lisp/ ${top_bootclean} ### 'maintainer-clean' commit b629cb3f547b5acd6d4ee3574d31b3530f93ff1f Author: Po Lu Date: Mon May 23 13:30:33 2022 +0800 Minor fixes to PGTK child frames * src/gtkutil.c (xg_check_special_colors): Handle child frames correctly. * src/pgtkfns.c (pgtk_set_child_frame_border_width): Synchronize code from X. (bug#55588) * src/pgtkmenu.c (pgtk_menu_show, pgtk_dialog_show): Allow in child frames. There are no problems here. * src/pgtkterm.c (pgtk_mouse_position): Clean up coding style. diff --git a/src/gtkutil.c b/src/gtkutil.c index 11ccbbd668..f2018bc01f 100644 --- a/src/gtkutil.c +++ b/src/gtkutil.c @@ -736,67 +736,74 @@ xg_check_special_colors (struct frame *f, const char *color_name, Emacs_Color *color) { - bool success_p = 0; - bool get_bg = strcmp ("gtk_selection_bg_color", color_name) == 0; - bool get_fg = !get_bg && strcmp ("gtk_selection_fg_color", color_name) == 0; + bool success_p; + bool get_bg; + bool get_fg; +#ifdef HAVE_GTK3 + GtkStyleContext *gsty; + GdkRGBA col; + char buf[sizeof "rgb://rrrr/gggg/bbbb"]; + int state; + GdkRGBA *c; + unsigned short r, g, b; +#else + GtkStyle *gsty; + GdkColor *grgb; +#endif + + get_bg = !strcmp ("gtk_selection_bg_color", color_name); + get_fg = !get_bg && !strcmp ("gtk_selection_fg_color", color_name); + success_p = false; - if (! FRAME_GTK_WIDGET (f) || ! (get_bg || get_fg)) +#ifdef HAVE_PGTK + while (FRAME_PARENT_FRAME (f)) + f = FRAME_PARENT_FRAME (f); +#endif + + if (!FRAME_GTK_WIDGET (f) || !(get_bg || get_fg)) return success_p; block_input (); - { #ifdef HAVE_GTK3 -#ifndef HAVE_PGTK - GtkStyleContext *gsty - = gtk_widget_get_style_context (FRAME_GTK_OUTER_WIDGET (f)); -#else - GtkStyleContext *gsty - = gtk_widget_get_style_context (FRAME_WIDGET (f)); -#endif - GdkRGBA col; - char buf[sizeof "rgb://rrrr/gggg/bbbb"]; - int state = GTK_STATE_FLAG_SELECTED|GTK_STATE_FLAG_FOCUSED; - if (get_fg) - gtk_style_context_get_color (gsty, state, &col); - else - { - GdkRGBA *c; - /* FIXME: Retrieving the background color is deprecated in - GTK+ 3.16. New versions of GTK+ don't use the concept of a - single background color any more, so we shouldn't query for - it. */ - gtk_style_context_get (gsty, state, - GTK_STYLE_PROPERTY_BACKGROUND_COLOR, &c, - NULL); - col = *c; - gdk_rgba_free (c); - } + gsty = gtk_widget_get_style_context (FRAME_GTK_OUTER_WIDGET (f)); + state = GTK_STATE_FLAG_SELECTED | GTK_STATE_FLAG_FOCUSED; + + if (get_fg) + gtk_style_context_get_color (gsty, state, &col); + else + { + /* FIXME: Retrieving the background color is deprecated in + GTK+ 3.16. New versions of GTK+ don't use the concept of a + single background color any more, so we shouldn't query for + it. */ + gtk_style_context_get (gsty, state, + GTK_STYLE_PROPERTY_BACKGROUND_COLOR, &c, + NULL); + col = *c; + gdk_rgba_free (c); + } - unsigned short - r = col.red * 65535, - g = col.green * 65535, - b = col.blue * 65535; + r = col.red * 65535; + g = col.green * 65535; + b = col.blue * 65535; #ifndef HAVE_PGTK - sprintf (buf, "rgb:%04x/%04x/%04x", r, g, b); - success_p = x_parse_color (f, buf, color) != 0; + sprintf (buf, "rgb:%04x/%04x/%04x", r, g, b); + success_p = x_parse_color (f, buf, color) != 0; #else - sprintf (buf, "#%04x%04x%04x", r, g, b); - success_p = pgtk_parse_color (f, buf, color) != 0; + sprintf (buf, "#%04x%04x%04x", r, g, b); + success_p = pgtk_parse_color (f, buf, color) != 0; #endif #else - GtkStyle *gsty = gtk_widget_get_style (FRAME_GTK_WIDGET (f)); - GdkColor *grgb = get_bg - ? &gsty->bg[GTK_STATE_SELECTED] - : &gsty->fg[GTK_STATE_SELECTED]; + gsty = gtk_widget_get_style (FRAME_GTK_WIDGET (f)); + grgb = (get_bg ? &gsty->bg[GTK_STATE_SELECTED] + : &gsty->fg[GTK_STATE_SELECTED]); - color->red = grgb->red; - color->green = grgb->green; - color->blue = grgb->blue; - color->pixel = grgb->pixel; - success_p = 1; + color->red = grgb->red; + color->green = grgb->green; + color->blue = grgb->blue; + color->pixel = grgb->pixel; + success_p = 1; #endif - - } unblock_input (); return success_p; } diff --git a/src/pgtkfns.c b/src/pgtkfns.c index 1feb3fe250..b26709d90c 100644 --- a/src/pgtkfns.c +++ b/src/pgtkfns.c @@ -566,15 +566,23 @@ pgtk_set_tool_bar_lines (struct frame *f, Lisp_Object value, Lisp_Object oldval) static void pgtk_set_child_frame_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { - int border = check_int_nonnegative (arg); + int border; + + if (NILP (arg)) + border = -1; + else if (RANGED_FIXNUMP (0, arg, INT_MAX)) + border = XFIXNAT (arg); + else + signal_error ("Invalid child frame border width", arg); if (border != FRAME_CHILD_FRAME_BORDER_WIDTH (f)) { f->child_frame_border_width = border; - if (FRAME_X_WINDOW (f)) + if (FRAME_GTK_WIDGET (f)) { - adjust_frame_size (f, -1, -1, 3, false, Qchild_frame_border_width); + adjust_frame_size (f, -1, -1, 3, + false, Qchild_frame_border_width); pgtk_clear_under_internal_border (f); } } diff --git a/src/pgtkmenu.c b/src/pgtkmenu.c index eec9f419d0..2eabf6ac1b 100644 --- a/src/pgtkmenu.c +++ b/src/pgtkmenu.c @@ -610,11 +610,6 @@ pgtk_menu_show (struct frame *f, int x, int y, int menuflags, *error_name = NULL; - if (!FRAME_GTK_OUTER_WIDGET (f)) { - *error_name = "Can't popup from child frames."; - return Qnil; - } - if (menu_items_used <= MENU_ITEMS_PANE_LENGTH) { *error_name = "Empty menu"; @@ -919,11 +914,6 @@ pgtk_dialog_show (struct frame *f, Lisp_Object title, *error_name = NULL; - if (!FRAME_GTK_OUTER_WIDGET (f)) { - *error_name = "Can't popup from child frames."; - return Qnil; - } - if (menu_items_n_panes > 1) { *error_name = "Multiple panes in dialog box"; diff --git a/src/pgtkterm.c b/src/pgtkterm.c index 71b5f23283..da958a6664 100644 --- a/src/pgtkterm.c +++ b/src/pgtkterm.c @@ -3351,15 +3351,10 @@ pgtk_mouse_position (struct frame **fp, int insist, Lisp_Object * bar_window, if (gui_mouse_grabbed (dpyinfo) && (!EQ (track_mouse, Qdropping) && !EQ (track_mouse, Qdrag_source))) - { - /* 1.1. use last_mouse_frame as frame where the pointer is - on. */ - f1 = dpyinfo->last_mouse_frame; - } + f1 = dpyinfo->last_mouse_frame; else { f1 = *fp; - /* 1.2. get frame where the pointer is on. */ win = gtk_widget_get_window (FRAME_GTK_WIDGET (*fp)); seat = gdk_display_get_default_seat (dpyinfo->gdpy); device = gdk_seat_get_pointer (seat); @@ -3385,19 +3380,17 @@ pgtk_mouse_position (struct frame **fp, int insist, Lisp_Object * bar_window, return; } - /* 2. get the display and the device. */ win = gtk_widget_get_window (FRAME_GTK_WIDGET (f1)); - GdkDisplay *gdpy = gdk_window_get_display (win); - seat = gdk_display_get_default_seat (gdpy); + seat = gdk_display_get_default_seat (dpyinfo->gdpy); device = gdk_seat_get_pointer (seat); - /* 3. get x, y relative to edit window of the frame. */ - win = gdk_window_get_device_position (win, device, &win_x, &win_y, &mask); + win = gdk_window_get_device_position (win, device, + &win_x, &win_y, &mask); if (f1 != NULL) { - dpyinfo = FRAME_DISPLAY_INFO (f1); - remember_mouse_glyph (f1, win_x, win_y, &dpyinfo->last_mouse_glyph); + remember_mouse_glyph (f1, win_x, win_y, + &dpyinfo->last_mouse_glyph); dpyinfo->last_mouse_glyph_frame = f1; *bar_window = Qnil; commit 5346b67fc27f50abeec3c4f72252a8d9a36f2e6b Author: Po Lu Date: Mon May 23 11:13:45 2022 +0800 Implement monitor change functions on GNUstep * src/nsfns.m (Fns_display_monitor_attributes_list): Fix coding style. * src/nsterm.m (nstrace_leave, nstrace_restore_global_trace_state) (nstrace_fullscreen_type_name): Fix coding style. (ns_displays_reconfigured, ns_term_init): Make a record of the previous display attributes list and avoid storing duplicate events. ([EmacsApp init]): Listen for NSApplicationDidChangeScreenParametersNotification. ([EmacsApp updateMonitors:]): New method. (syms_of_nsterm): New staticpro. diff --git a/src/nsfns.m b/src/nsfns.m index 818ba6f40f..20c36209eb 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -2769,7 +2769,8 @@ Frames are listed from topmost (first) to bottommost (last). */) } else { - // Flip y coordinate as NS has y starting from the bottom. + /* Flip y coordinate as NS screen coordinates originate from + the bottom. */ y = (short) (primary_display_height - fr.size.height - fr.origin.y); vy = (short) (primary_display_height - vfr.size.height - vfr.origin.y); @@ -2781,11 +2782,12 @@ Frames are listed from topmost (first) to bottommost (last). */) m->geom.height = (unsigned short) fr.size.height; m->work.x = (short) vfr.origin.x; - // y is flipped on NS, so vy - y are pixels missing at the bottom, - // and fr.size.height - vfr.size.height are pixels missing in total. - // Pixels missing at top are - // fr.size.height - vfr.size.height - vy + y. - // work.y is then pixels missing at top + y. + /* y is flipped on NS, so vy - y are pixels missing at the + bottom, and fr.size.height - vfr.size.height are pixels + missing in total. + + Pixels missing at top are fr.size.height - vfr.size.height - + vy + y. work.y is then pixels missing at top + y. */ m->work.y = (short) (fr.size.height - vfr.size.height) - vy + y + y; m->work.width = (unsigned short) vfr.size.width; m->work.height = (unsigned short) vfr.size.height; @@ -2800,13 +2802,14 @@ Frames are listed from topmost (first) to bottommost (last). */) } #else - // Assume 92 dpi as x-display-mm-height/x-display-mm-width does. + /* Assume 92 dpi as x-display-mm-height and x-display-mm-width + do. */ m->mm_width = (int) (25.4 * fr.size.width / 92.0); m->mm_height = (int) (25.4 * fr.size.height / 92.0); #endif } - // Primary monitor is always first for NS. + /* Primary monitor is always ordered first for NS. */ attributes_list = ns_make_monitor_attribute_list (monitors, n_monitors, 0, "NS"); diff --git a/src/nsterm.m b/src/nsterm.m index 67b02c7a54..d7e62a70c4 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -79,6 +79,9 @@ Updated by Christian Limpach (chris@nice.ch) static EmacsMenu *mainMenu; #endif +/* The last known monitor attributes list. */ +static Lisp_Object last_known_monitors; + /* ========================================================================== NSTRACE, Trace support. @@ -89,8 +92,8 @@ Updated by Christian Limpach (chris@nice.ch) /* The following use "volatile" since they can be accessed from parallel threads. */ -volatile int nstrace_num = 0; -volatile int nstrace_depth = 0; +volatile int nstrace_num; +volatile int nstrace_depth; /* When 0, no trace is emitted. This is used by NSTRACE_WHEN and NSTRACE_UNLESS to silence functions called. @@ -101,33 +104,41 @@ Updated by Christian Limpach (chris@nice.ch) volatile int nstrace_enabled_global = 1; /* Called when nstrace_enabled goes out of scope. */ -void nstrace_leave(int * pointer_to_nstrace_enabled) +void +nstrace_leave (int *pointer_to_nstrace_enabled) { if (*pointer_to_nstrace_enabled) - { - --nstrace_depth; - } + --nstrace_depth; } /* Called when nstrace_saved_enabled_global goes out of scope. */ -void nstrace_restore_global_trace_state(int * pointer_to_saved_enabled_global) +void +nstrace_restore_global_trace_state (int *pointer_to_saved_enabled_global) { nstrace_enabled_global = *pointer_to_saved_enabled_global; } -char const * nstrace_fullscreen_type_name (int fs_type) +const char * +nstrace_fullscreen_type_name (int fs_type) { switch (fs_type) { - case -1: return "-1"; - case FULLSCREEN_NONE: return "FULLSCREEN_NONE"; - case FULLSCREEN_WIDTH: return "FULLSCREEN_WIDTH"; - case FULLSCREEN_HEIGHT: return "FULLSCREEN_HEIGHT"; - case FULLSCREEN_BOTH: return "FULLSCREEN_BOTH"; - case FULLSCREEN_MAXIMIZED: return "FULLSCREEN_MAXIMIZED"; - default: return "FULLSCREEN_?????"; + case -1: + return "-1"; + case FULLSCREEN_NONE: + return "FULLSCREEN_NONE"; + case FULLSCREEN_WIDTH: + return "FULLSCREEN_WIDTH"; + case FULLSCREEN_HEIGHT: + return "FULLSCREEN_HEIGHT"; + case FULLSCREEN_BOTH: + return "FULLSCREEN_BOTH"; + case FULLSCREEN_MAXIMIZED: + return "FULLSCREEN_MAXIMIZED"; + default: + return "FULLSCREEN_?????"; } } #endif @@ -5221,9 +5232,17 @@ static Lisp_Object ns_string_to_lispmod (const char *s) { struct input_event ie; union buffered_input_event *ev; + Lisp_Object new_monitors; EVENT_INIT (ie); + new_monitors = Fns_display_monitor_attributes_list (Qnil); + + if (!NILP (Fequal (new_monitors, last_known_monitors))) + return; + + last_known_monitors = new_monitors; + ev = (kbd_store_ptr == kbd_buffer ? kbd_buffer + KBD_BUFFER_SIZE - 1 : kbd_store_ptr - 1); @@ -5601,6 +5620,7 @@ Needs to be here because ns_initialize_display_info () uses AppKit classes. CGDisplayRegisterReconfigurationCallback (ns_displays_reconfigured, NULL); #endif + last_known_monitors = Fns_display_monitor_attributes_list (Qnil); NSTRACE_MSG ("ns_term_init done"); @@ -5642,6 +5662,10 @@ @implementation EmacsApp - (id)init { +#ifdef NS_IMPL_GNUSTEP + NSNotificationCenter *notification_center; +#endif + NSTRACE ("[EmacsApp init]"); if ((self = [super init])) @@ -5654,6 +5678,14 @@ - (id)init #endif } +#ifdef NS_IMPL_GNUSTEP + notification_center = [NSNotificationCenter defaultCenter]; + [notification_center addObserver: self + selector: @selector(updateMonitors:) + name: NSApplicationDidChangeScreenParametersNotification + object: nil]; +#endif + return self; } @@ -5666,11 +5698,11 @@ - (void)run #define NSAppKitVersionNumber10_9 1265 #endif - if ((int)NSAppKitVersionNumber != NSAppKitVersionNumber10_9) - { - [super run]; - return; - } + if ((int) NSAppKitVersionNumber != NSAppKitVersionNumber10_9) + { + [super run]; + return; + } NSAutoreleasePool *pool = [[NSAutoreleasePool alloc] init]; @@ -5854,6 +5886,36 @@ - (BOOL) openFile: (NSString *)fileName return YES; } +#ifdef NS_IMPL_GNUSTEP +- (void) updateMonitors: (NSNotification *) notification +{ + struct input_event ie; + union buffered_input_event *ev; + Lisp_Object new_monitors; + + EVENT_INIT (ie); + + new_monitors = Fns_display_monitor_attributes_list (Qnil); + + if (!NILP (Fequal (new_monitors, last_known_monitors))) + return; + + last_known_monitors = new_monitors; + + ev = (kbd_store_ptr == kbd_buffer + ? kbd_buffer + KBD_BUFFER_SIZE - 1 + : kbd_store_ptr - 1); + + if (kbd_store_ptr != kbd_fetch_ptr + && ev->ie.kind == MONITORS_CHANGED_EVENT) + return; + + ie.kind = MONITORS_CHANGED_EVENT; + XSETTERMINAL (ie.arg, x_display_list->terminal); + + kbd_buffer_store_event (&ie); +} +#endif /* ************************************************************************** @@ -10575,4 +10637,6 @@ Nil means use fullscreen the old (< 10.7) way. The old way works better with syms_of_nsfont (); #endif + last_known_monitors = Qnil; + staticpro (&last_known_monitors); } commit 20662ecd214fbe2a9f200085b9194a6f7677d447 Author: Po Lu Date: Mon May 23 10:55:48 2022 +0800 Handle screen size changes if the RandR library isn't available * src/xterm.c (handle_one_xevent): [!HAVE_XRANDR]: Store MONITORS_CHANGED_EVENT upon root window reconfiguration. diff --git a/src/xterm.c b/src/xterm.c index 2465dbd863..dc1daaf6e1 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -16653,6 +16653,17 @@ handle_one_xevent (struct x_display_info *dpyinfo, /* This function is OK to call even if the X server doesn't support RandR. */ XRRUpdateConfiguration (&configureEvent); +#elif !defined USE_GTK + /* Catch screen size changes even if RandR is not available + on the client. GTK does this internally. */ + + inev.ie.kind = MONITORS_CHANGED_EVENT; + XSETTERMINAL (inev.ie.arg, dpyinfo->terminal); + + /* Store this event now since inev.ie.type could be set to + MOVE_FRAME_EVENT later. */ + kbd_buffer_store_event (&inev.ie); + inev.ie.kind = NO_EVENT; #endif dpyinfo->screen_width = configureEvent.xconfigure.width; commit 7a709b36ef1a2b184fd1b3e2f1ddf2b98b6f3bcc Author: Po Lu Date: Mon May 23 01:57:19 2022 +0000 Fix `gui-backend-selection-owner-p' on Haiku * src/haiku_select.cc (be_update_clipboard_count): New function. (be_set_clipboard_data): Update clipboard counts. (BClipboard_owns_clipboard, clipboard_owner_p) (BClipboard_owns_primary, primary_owner_p) (BClipboard_owns_secondary, secondary_owner_p): Rename functions somewhat. (be_clipboard_owner_p): New function. * src/haikuselect.c (Fhaiku_selection_put) (Fhaiku_selection_owner_p): Update selection counts as well. * src/haikuselect.h: Update prototypes. diff --git a/src/haiku_select.cc b/src/haiku_select.cc index 43b71138b3..764001f62b 100644 --- a/src/haiku_select.cc +++ b/src/haiku_select.cc @@ -28,11 +28,23 @@ along with GNU Emacs. If not, see . */ #include "haikuselect.h" +/* The clipboard object representing the primary selection. */ static BClipboard *primary = NULL; + +/* The clipboard object representing the secondary selection. */ static BClipboard *secondary = NULL; + +/* The clipboard object used by other programs, representing the + clipboard. */ static BClipboard *system_clipboard = NULL; + +/* The number of times the system clipboard has changed. */ static int64 count_clipboard = -1; + +/* The number of times the primary selection has changed. */ static int64 count_primary = -1; + +/* The number of times the secondary selection has changed. */ static int64 count_secondary = -1; static BClipboard * @@ -178,6 +190,25 @@ be_set_clipboard_data_1 (BClipboard *cb, const char *type, const char *data, cb->Unlock (); } +void +be_update_clipboard_count (enum haiku_clipboard id) +{ + switch (id) + { + case CLIPBOARD_CLIPBOARD: + count_clipboard = system_clipboard->SystemCount (); + break; + + case CLIPBOARD_PRIMARY: + count_primary = primary->SystemCount (); + break; + + case CLIPBOARD_SECONDARY: + count_secondary = secondary->SystemCount (); + break; + } +} + char * be_find_clipboard_data (enum haiku_clipboard id, const char *type, ssize_t *len) @@ -190,6 +221,8 @@ void be_set_clipboard_data (enum haiku_clipboard id, const char *type, const char *data, ssize_t len, bool clear) { + be_update_clipboard_count (id); + be_set_clipboard_data_1 (get_clipboard_object (id), type, data, len, clear); } @@ -202,30 +235,48 @@ be_get_clipboard_targets (enum haiku_clipboard id, char **targets, len); } -bool -BClipboard_owns_clipboard (void) +static bool +clipboard_owner_p (void) { return (count_clipboard >= 0 && (count_clipboard + 1 == system_clipboard->SystemCount ())); } -bool -BClipboard_owns_primary (void) +static bool +primary_owner_p (void) { return (count_primary >= 0 && (count_primary + 1 == primary->SystemCount ())); } -bool -BClipboard_owns_secondary (void) +static bool +secondary_owner_p (void) { return (count_secondary >= 0 && (count_secondary + 1 == secondary->SystemCount ())); } +bool +be_clipboard_owner_p (enum haiku_clipboard clipboard) +{ + switch (clipboard) + { + case CLIPBOARD_PRIMARY: + return primary_owner_p (); + + case CLIPBOARD_SECONDARY: + return secondary_owner_p (); + + case CLIPBOARD_CLIPBOARD: + return clipboard_owner_p (); + } + + abort (); +} + void init_haiku_select (void) { diff --git a/src/haikuselect.c b/src/haikuselect.c index 6d03d6eb68..80604252cb 100644 --- a/src/haikuselect.c +++ b/src/haikuselect.c @@ -145,6 +145,8 @@ In that case, the arguments after NAME are ignored. */) if (CONSP (name) || NILP (name)) { + be_update_clipboard_count (clipboard_name); + rc = be_lock_clipboard_message (clipboard_name, &message, true); @@ -179,16 +181,11 @@ of the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'. */) (Lisp_Object selection) { bool value; + enum haiku_clipboard name; block_input (); - if (EQ (selection, QPRIMARY)) - value = BClipboard_owns_primary (); - else if (EQ (selection, QSECONDARY)) - value = BClipboard_owns_secondary (); - else if (EQ (selection, QCLIPBOARD)) - value = BClipboard_owns_clipboard (); - else - value = false; + name = haiku_get_clipboard_name (selection); + value = be_clipboard_owner_p (name); unblock_input (); return value ? Qt : Qnil; diff --git a/src/haikuselect.h b/src/haikuselect.h index b63d3c3653..e9a2f2dd77 100644 --- a/src/haikuselect.h +++ b/src/haikuselect.h @@ -37,6 +37,7 @@ enum haiku_clipboard #ifdef __cplusplus extern "C" { +/* Also declared in haikuterm.h for use in emacs.c. */ extern void init_haiku_select (void); #endif /* Whether or not the selection was recently changed. */ @@ -45,10 +46,8 @@ extern char *be_find_clipboard_data (enum haiku_clipboard, const char *, ssize_t extern void be_set_clipboard_data (enum haiku_clipboard, const char *, const char *, ssize_t, bool); extern void be_get_clipboard_targets (enum haiku_clipboard, char **, int); - -extern bool BClipboard_owns_clipboard (void); -extern bool BClipboard_owns_primary (void); -extern bool BClipboard_owns_secondary (void); +extern bool be_clipboard_owner_p (enum haiku_clipboard); +extern void be_update_clipboard_count (enum haiku_clipboard); extern int be_enum_message (void *, int32 *, int32, int32 *, const char **); extern int be_get_message_data (void *, const char *, int32, int32, commit 42e48f788ac6c7934466fe75b19644045594e5dd Author: Po Lu Date: Mon May 23 09:22:28 2022 +0800 Use GDK for handling monitor changes when built with GTK * src/xterm.c (x_monitors_changed_cb): New function. (handle_one_xevent): Don't handle RRNotify and RRScreenChangeNotify on GTK. (x_term_init): Connect to GdkScreen::monitors-changed instead of selecting for RRNotify events. (mark_xterm): Also mark `last_monitor_attributes_list' on GTK. * src/xterm.h (struct x_display_info): Enable `last_monitor_attributes_list' on GTK builds as well. diff --git a/src/xterm.c b/src/xterm.c index 60c17f0371..2465dbd863 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -14578,6 +14578,42 @@ x_display_pixel_width (struct x_display_info *dpyinfo) return WidthOfScreen (dpyinfo->screen); } +#ifdef USE_GTK +static void +x_monitors_changed_cb (GdkScreen *gscr, gpointer user_data) +{ + struct x_display_info *dpyinfo; + struct input_event ie; + Lisp_Object current_monitors, terminal; + GdkDisplay *gdpy; + Display *dpy; + + gdpy = gdk_screen_get_display (gscr); + dpy = gdk_x11_display_get_xdisplay (gdpy); + dpyinfo = x_display_info_for_display (dpy); + + if (!dpyinfo) + return; + + XSETTERMINAL (terminal, dpyinfo->terminal); + + current_monitors + = Fx_display_monitor_attributes_list (terminal); + + if (NILP (Fequal (current_monitors, + dpyinfo->last_monitor_attributes_list))) + { + EVENT_INIT (ie); + ie.kind = MONITORS_CHANGED_EVENT; + ie.arg = terminal; + + kbd_buffer_store_event (&ie); + } + + dpyinfo->last_monitor_attributes_list = current_monitors; +} +#endif + /* Handles the XEvent EVENT on display DPYINFO. *FINISH is X_EVENT_GOTO_OUT if caller should stop reading events. @@ -20110,7 +20146,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, } } #endif -#ifdef HAVE_XRANDR +#if defined HAVE_XRANDR && !defined USE_GTK if (dpyinfo->xrandr_supported_p && (event->type == (dpyinfo->xrandr_event_base + RRScreenChangeNotify) @@ -23860,6 +23896,10 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) #endif static char const cm_atom_fmt[] = "_NET_WM_CM_S%d"; char cm_atom_sprintf[sizeof cm_atom_fmt - 2 + INT_STRLEN_BOUND (int)]; +#ifdef USE_GTK + GdkDisplay *gdpy; + GdkScreen *gscr; +#endif block_input (); @@ -24469,7 +24509,9 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) #ifdef HAVE_XRANDR Lisp_Object term; +#ifndef USE_GTK dpyinfo->last_monitor_attributes_list = Qnil; +#endif dpyinfo->xrandr_supported_p = XRRQueryExtension (dpy, &dpyinfo->xrandr_event_base, &dpyinfo->xrandr_error_base); @@ -24481,12 +24523,10 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) XRRQueryVersion (dpy, &dpyinfo->xrandr_major_version, &dpyinfo->xrandr_minor_version); +#ifndef USE_GTK if (dpyinfo->xrandr_major_version == 1 && dpyinfo->xrandr_minor_version >= 2) { - dpyinfo->last_monitor_attributes_list - = Fx_display_monitor_attributes_list (term); - XRRSelectInput (dpyinfo->display, dpyinfo->root_window, (RRScreenChangeNotifyMask @@ -24496,10 +24536,26 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) selects for it when the display is initialized. */ | RROutputPropertyNotifyMask)); + + dpyinfo->last_monitor_attributes_list + = Fx_display_monitor_attributes_list (term); } +#endif } #endif +#ifdef USE_GTK + dpyinfo->last_monitor_attributes_list + = Fx_display_monitor_attributes_list (term); + + gdpy = gdk_x11_lookup_xdisplay (dpyinfo->display); + gscr = gdk_display_get_default_screen (gdpy); + + g_signal_connect (G_OBJECT (gscr), "monitors-changed", + G_CALLBACK (x_monitors_changed_cb), + NULL); +#endif + #ifdef HAVE_XKB int xkb_major, xkb_minor, xkb_op, xkb_error_code; xkb_major = XkbMajorVersion; @@ -25305,7 +25361,8 @@ mark_xterm (void) mark_object (val); } -#if defined HAVE_XINPUT2 || defined USE_TOOLKIT_SCROLL_BARS || defined HAVE_XRANDR +#if defined HAVE_XINPUT2 || defined USE_TOOLKIT_SCROLL_BARS \ + || defined HAVE_XRANDR || defined USE_GTK for (dpyinfo = x_display_list; dpyinfo; dpyinfo = dpyinfo->next) { #ifdef HAVE_XINPUT2 @@ -25316,7 +25373,7 @@ mark_xterm (void) for (i = 0; i < dpyinfo->n_protected_windows; ++i) mark_object (dpyinfo->protected_windows[i]); #endif -#ifdef HAVE_XRANDR +#if defined HAVE_XRANDR || defined USE_GTK mark_object (dpyinfo->last_monitor_attributes_list); #endif } diff --git a/src/xterm.h b/src/xterm.h index c59992fdaa..724caf9e75 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -607,7 +607,9 @@ struct x_display_info int xrandr_error_base; int xrandr_major_version; int xrandr_minor_version; +#endif +#if defined HAVE_XRANDR || defined USE_GTK /* This is used to determine if the monitor configuration really changed upon receiving a monitor change event. */ Lisp_Object last_monitor_attributes_list; commit 73b40d8716f6416f75689d3e2442f365130f45b9 Author: F. Jason Park Date: Thu May 5 21:13:47 2022 -0700 Recognize DCC SSEND when receiving files in erc-dcc * lips/erc/erc-dcc.el (erc-dcc-open-network-stream): Use TLS for new connections when :secure flag is set. (erc-dcc-do-GET-command): Set secure flag when user explicitly passes an "-s" option. (erc-dcc-do-LIST-command): Show an "s" to indicate a secure connection when applicable. (erc-dcc-query-handler-alist): Add extra items for "SSEND", etc. (erc-dcc-handle-ctcp-send): Set secure flag when a leading "S" appears in the command type. diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index 918ae9dc97..ff486b2d4e 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -43,7 +43,7 @@ ;; /dcc chat nick - Either accept pending chat offer from nick, or offer ;; DCC chat to nick ;; /dcc close type [nick] - Close DCC connection (SEND/GET/CHAT) with nick -;; /dcc get [-t] nick [file] - Accept DCC offer from nick +;; /dcc get [-t][-s] nick [file] - Accept DCC offer from nick ;; /dcc list - List all DCC offers/connections ;; /dcc send nick file - Offer DCC SEND to nick @@ -107,6 +107,8 @@ Looks like: :size - size of the file, may be nil on incoming DCCs + :secure - optional item indicating sender support for TLS + :turbo - optional item indicating sender support for TSEND") (defun erc-dcc-list-add (type nick peer parent &rest args) @@ -121,12 +123,13 @@ Looks like: ;; more: the entry data from erc-dcc-list for this particular process. (defvar erc-dcc-connect-function 'erc-dcc-open-network-stream) -(defun erc-dcc-open-network-stream (procname buffer addr port _entry) +(defun erc-dcc-open-network-stream (procname buffer addr port entry) ;; FIXME: Time to try activating this again!? (if nil; (fboundp 'open-network-stream-nowait) ;; this currently crashes ;; cvs emacs (open-network-stream-nowait procname buffer addr port) - (open-network-stream procname buffer addr port))) + (open-network-stream procname buffer addr port + :type (and (plist-get entry :secure) 'tls)))) (erc-define-catalog 'english @@ -534,6 +537,9 @@ PROC is the server process." ?n nick ?f filename))) (t (erc-dcc-get-file elt file proc))) + (when (member "-s" flags) + (setq erc-dcc-list (cons (plist-put elt :secure t) + (delq elt erc-dcc-list)))) (when (member "-t" flags) (setq erc-dcc-list (cons (plist-put elt :turbo t) (delq elt erc-dcc-list))))) @@ -574,6 +580,7 @@ It lists the current state of `erc-dcc-list' in an easy to read manner." (process-status (plist-get elt :peer)) "no") ?s (concat size + ;; FIXME consider uniquified names, e.g., foo.bin<2> (if (and (eq 'GET (plist-get elt :type)) (plist-member elt :file) (buffer-live-p (get-buffer (plist-get elt :file))) @@ -587,7 +594,7 @@ It lists the current state of `erc-dcc-list' in an easy to read manner." (plist-get elt :size)))))) ?f (or (and (plist-member elt :file) (plist-get elt :file)) "") ?u (if-let* ((flags (concat (and (plist-get elt :turbo) "t") - (and (plist-get elt :placeholder) "p"))) + (and (plist-get elt :secure) "s"))) ((not (string-empty-p flags)))) (concat " (" flags ")") ""))) @@ -618,6 +625,9 @@ separated by a space." (defvar erc-dcc-query-handler-alist '(("SEND" . erc-dcc-handle-ctcp-send) ("TSEND" . erc-dcc-handle-ctcp-send) + ("SSEND" . erc-dcc-handle-ctcp-send) + ("TSSEND" . erc-dcc-handle-ctcp-send) + ("STSEND" . erc-dcc-handle-ctcp-send) ("CHAT" . erc-dcc-handle-ctcp-chat))) ;;;###autoload @@ -676,6 +686,7 @@ It extracts the information about the dcc request and adds it to (port (match-string 4 query)) (size (match-string 5 query)) (sub (substring (match-string 6 query) 0 -4)) + (secure (seq-contains-p sub ?S #'eq)) (turbo (seq-contains-p sub ?T #'eq))) ;; FIXME: a warning really should also be sent ;; if the ip address != the host the dcc sender is on. @@ -694,7 +705,8 @@ It extracts the information about the dcc request and adds it to nil proc :ip ip :port port :file filename :size (string-to-number size) - :turbo (and turbo t)) + :turbo (and turbo t) + :secure (and secure t)) (if (and (eq erc-dcc-send-request 'auto) (erc-dcc-auto-mask-p (format "\"%s!%s@%s\"" nick login host))) (erc-dcc-get-file (car erc-dcc-list) filename proc)))) diff --git a/test/lisp/erc/erc-dcc-tests.el b/test/lisp/erc/erc-dcc-tests.el index 58011201cd..a10cbfc02c 100644 --- a/test/lisp/erc/erc-dcc-tests.el +++ b/test/lisp/erc/erc-dcc-tests.el @@ -75,7 +75,8 @@ :port "9899" :file "foo" :size 1405135128 - :turbo ,(and turbo t)))) + :turbo ,(and turbo t) + :secure nil))) (goto-char (point-min)) (should (search-forward "file foo offered by tester" nil t)) (erc-dcc-do-LIST-command erc-server-process) commit df1e553688be6e97198e293a1042a1bbbce98271 Author: F. Jason Park Date: Sat Apr 30 02:16:46 2022 -0700 Accommodate nonstandard turbo file senders in erc-dcc * lisp/erc/erc-dcc.el (erc-dcc-list): Document optional :turbo item. (erc-message-english-dcc-list-{head,line,item}): Adjust format strings to make room for "(T)" turbo indicator. (erc-dcc-do-GET-command): Optionally set :turbo in `erc-dcc-list' entry when passed "-t" in the "/DCC GET" slash command. Also add switch to command line in front-matter Commentary, but refrain from publicizing further because our implementation is only defensive and only for receiving. (erc-dcc-do-LIST): Print message with new format specifier for turbo status. (erc-dcc-ctcp-query-send-regexp): Account for T- and S-prefixed commands. Receiving from an SSEND-capable sender will be added in a subsequent commit. (erc-dcc-handle-ctcp-send): Set :turbo item in `erc-dcc-list' member when new match group is nonempty. (erc-dcc--X-send-final-turbo-ack): New internal variable and potential future option for extreme corner cases involving maverick turbo senders, like WeeChat, who don't use the TSEND command variant. (erc-dcc-get-filter): Don't send when turbo is active. * test/lisp/erc/erc-dcc-tests.el: Add new file. (Bug#54458) diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index babd0f3046..918ae9dc97 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -43,7 +43,7 @@ ;; /dcc chat nick - Either accept pending chat offer from nick, or offer ;; DCC chat to nick ;; /dcc close type [nick] - Close DCC connection (SEND/GET/CHAT) with nick -;; /dcc get nick [file] - Accept DCC offer from nick +;; /dcc get [-t] nick [file] - Accept DCC offer from nick ;; /dcc list - List all DCC offers/connections ;; /dcc send nick file - Offer DCC SEND to nick @@ -105,7 +105,9 @@ Looks like: :file - for outgoing sends, the full path to the file. For incoming sends, the suggested filename or vetted filename - :size - size of the file, may be nil on incoming DCCs") + :size - size of the file, may be nil on incoming DCCs + + :turbo - optional item indicating sender support for TSEND") (defun erc-dcc-list-add (type nick peer parent &rest args) "Add a new entry of type TYPE to `erc-dcc-list' and return it." @@ -149,9 +151,9 @@ Looks like: (dcc-get-file-too-long . "DCC: %f: File longer than sender claimed; aborting transfer") (dcc-get-notfound . "DCC: %n hasn't offered %f for DCC transfer") - (dcc-list-head . "DCC: From Type Active Size Filename") - (dcc-list-line . "DCC: -------- ---- ------ -------------- --------") - (dcc-list-item . "DCC: %-8n %-4t %-6a %-14s %f") + (dcc-list-head . "DCC: From Type Active Size Filename") + (dcc-list-line . "DCC: -------- ---- ------ ----------------- --------") + (dcc-list-item . "DCC: %-8n %-4t %-6a %-17s %f%u") (dcc-list-end . "DCC: End of list.") (dcc-malformed . "DCC: error: %n (%u@%h) sent malformed request: %q") (dcc-privileged-port @@ -506,8 +508,12 @@ At least one of TYPE and NICK must be provided." FILE is the filename. If FILE is split into multiple arguments, re-join the arguments, separated by a space. PROC is the server process." - (setq file (and file (mapconcat #'identity file " "))) - (let* ((elt (erc-dcc-member :nick nick :type 'GET :file file)) + (let* ((args (seq-group-by (lambda (s) (eq ?- (aref s 0))) (cons nick file))) + (flags (prog1 (cdr (assq t args)) + (setq args (cdr (assq nil args)) + nick (pop args) + file (and args (mapconcat #'identity args " "))))) + (elt (erc-dcc-member :nick nick :type 'GET :file file)) (filename (or file (plist-get elt :file) "unknown"))) (if elt (let* ((file (read-file-name @@ -527,7 +533,10 @@ PROC is the server process." 'dcc-get-cmd-aborted ?n nick ?f filename))) (t - (erc-dcc-get-file elt file proc)))) + (erc-dcc-get-file elt file proc))) + (when (member "-t" flags) + (setq erc-dcc-list (cons (plist-put elt :turbo t) + (delq elt erc-dcc-list))))) (erc-display-message nil '(notice error) 'active 'dcc-get-notfound ?n nick ?f filename)))) @@ -576,7 +585,12 @@ It lists the current state of `erc-dcc-list' in an easy to read manner." (format " (%d%%)" (floor (* 100.0 byte-count) (plist-get elt :size)))))) - ?f (or (and (plist-member elt :file) (plist-get elt :file)) ""))) + ?f (or (and (plist-member elt :file) (plist-get elt :file)) "") + ?u (if-let* ((flags (concat (and (plist-get elt :turbo) "t") + (and (plist-get elt :placeholder) "p"))) + ((not (string-empty-p flags)))) + (concat " (" flags ")") + ""))) (erc-display-message nil 'notice 'active 'dcc-list-end) @@ -603,6 +617,7 @@ separated by a space." (defvar erc-dcc-query-handler-alist '(("SEND" . erc-dcc-handle-ctcp-send) + ("TSEND" . erc-dcc-handle-ctcp-send) ("CHAT" . erc-dcc-handle-ctcp-chat))) ;;;###autoload @@ -621,12 +636,16 @@ that subcommand." ?q query ?n nick ?u login ?h host)))) (defconst erc-dcc-ctcp-query-send-regexp - (concat "^DCC SEND \\(?:" + (rx bot "DCC " (group-n 6 (: (** 0 2 (any "TS")) "SEND")) " " ;; Following part matches either filename without spaces ;; or filename enclosed in double quotes with any number ;; of escaped double quotes inside. - "\"\\(\\(?:\\\\\"\\|[^\"\\]\\)+\\)\"\\|\\([^ ]+\\)" - "\\) \\([0-9]+\\) \\([0-9]+\\) *\\([0-9]*\\)")) + (: (or (: ?\" (group-n 1 (+ (or (: ?\\ ?\") (not (any ?\" ?\\))))) ?\") + (group-n 2 (+ (not " "))))) + (: " " (group-n 3 (+ digit)) + " " (group-n 4 (+ digit)) + (* " ") (group-n 5 (* digit))) + eot)) (define-inline erc-dcc-unquote-filename (filename) (inline-quote @@ -651,12 +670,13 @@ It extracts the information about the dcc request and adds it to 'dcc-request-bogus ?r "SEND" ?n nick ?u login ?h host)) ((string-match erc-dcc-ctcp-query-send-regexp query) - (let ((filename - (or (match-string 2 query) - (erc-dcc-unquote-filename (match-string 1 query)))) - (ip (erc-decimal-to-ip (match-string 3 query))) - (port (match-string 4 query)) - (size (match-string 5 query))) + (let* ((filename (or (match-string 2 query) + (erc-dcc-unquote-filename (match-string 1 query)))) + (ip (erc-decimal-to-ip (match-string 3 query))) + (port (match-string 4 query)) + (size (match-string 5 query)) + (sub (substring (match-string 6 query) 0 -4)) + (turbo (seq-contains-p sub ?T #'eq))) ;; FIXME: a warning really should also be sent ;; if the ip address != the host the dcc sender is on. (erc-display-message @@ -673,7 +693,8 @@ It extracts the information about the dcc request and adds it to 'GET (format "%s!%s@%s" nick login host) nil proc :ip ip :port port :file filename - :size (string-to-number size)) + :size (string-to-number size) + :turbo (and turbo t)) (if (and (eq erc-dcc-send-request 'auto) (erc-dcc-auto-mask-p (format "\"%s!%s@%s\"" nick login host))) (erc-dcc-get-file (car erc-dcc-list) filename proc)))) @@ -952,6 +973,16 @@ The contents of the BUFFER will then be erased." (setq erc-dcc-byte-count (+ (buffer-size) erc-dcc-byte-count)) (erase-buffer)))) +;; If people really need this, we can convert it into a proper option. + +(defvar erc-dcc--X-send-final-turbo-ack nil + "Workaround for maverick turbo senders that only require a final ACK. +The only known culprit is WeeChat, with its xfer.network.fast_send +option, which is on by default. Leaving this set to nil and calling +/DCC GET -t works just fine, but WeeChat sees it as a failure even +though the file arrives in its entirety. Setting this to t may +alleviate such problems.") + (defun erc-dcc-get-filter (proc str) "This is the process filter for transfers from other clients to this one. It reads incoming bytes from the network and stores them in the DCC @@ -986,7 +1017,14 @@ rather than every 1024 byte block, but nobody seems to care." 'dcc-get-file-too-long ?f (file-name-nondirectory (buffer-name))) (delete-process proc)) - ((not (process-get proc :reportingp)) + ;; Some senders want us to hang up. Only observed w. TSEND. + ((and (plist-get erc-dcc-entry-data :turbo) + (= received-bytes (plist-get erc-dcc-entry-data :size))) + (when erc-dcc--X-send-final-turbo-ack + (process-send-string proc (erc-pack-int received-bytes))) + (delete-process proc)) + ((not (or (plist-get erc-dcc-entry-data :turbo) + (process-get proc :reportingp))) (process-put proc :reportingp t) (process-send-string proc (erc-pack-int received-bytes)) (process-put proc :reportingp nil)))))) @@ -996,7 +1034,8 @@ rather than every 1024 byte block, but nobody seems to care." It shuts down the connection and notifies the user that the transfer is complete." ;; FIXME, we should look at EVENT, and also check size. - (unless (string= event "connection broken by remote peer\n") + (unless (member event '("connection broken by remote peer\n" + "deleted\n")) (lwarn 'erc :warning "Unexpected sentinel event %S for %s" (string-trim-right event) proc)) (with-current-buffer (process-buffer proc) diff --git a/test/lisp/erc/erc-dcc-tests.el b/test/lisp/erc/erc-dcc-tests.el new file mode 100644 index 0000000000..58011201cd --- /dev/null +++ b/test/lisp/erc/erc-dcc-tests.el @@ -0,0 +1,164 @@ +;;; erc-dcc-tests.el --- Tests for erc-dcc -*- 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 . + +;;; Commentary: + +;;; Code: +(require 'ert) +(require 'erc-dcc) + +(ert-deftest erc-dcc-ctcp-query-send-regexp () + (let ((s "DCC SEND \"file name\" 2130706433 9899 1405135128")) + (should (string-match erc-dcc-ctcp-query-send-regexp s)) + (should-not (match-string 2 s)) + (should (string= "file name" (match-string 1 s))) + (should (string= "SEND" (match-string 6 s)))) + (let ((s "DCC SEND \"file \\\" name\" 2130706433 9899 1405135128")) + (should (string-match erc-dcc-ctcp-query-send-regexp s)) + (should-not (match-string 2 s)) + (should (string= "SEND" (match-string 6 s))) + (should (string= "file \" name" + (erc-dcc-unquote-filename (match-string 1 s))))) + (let ((s "DCC SEND filename 2130706433 9899 1405135128")) + (should (string-match erc-dcc-ctcp-query-send-regexp s)) + (should (string= "filename" (match-string 2 s))) + (should (string= "2130706433" (match-string 3 s))) + (should (string= "9899" (match-string 4 s))) + (should (string= "1405135128" (match-string 5 s)))) + (let ((s "DCC TSEND filename 2130706433 9899 1405135128")) + (should (string-match erc-dcc-ctcp-query-send-regexp s)) + (should (string= "TSEND" (match-string 6 s))))) + +;; This also indirectly tests base functionality for +;; `erc-dcc-do-LIST-command' + +(defun erc-dcc-tests--dcc-handle-ctcp-send (turbo) + (with-current-buffer (get-buffer-create "fake-server") + (erc-mode) + (setq erc-server-process + (start-process "fake" (current-buffer) "sleep" "10") + erc-input-marker (make-marker) + erc-insert-marker (make-marker) + erc-server-current-nick "dummy") + (set-process-query-on-exit-flag erc-server-process nil) + (should-not erc-dcc-list) + (erc-ctcp-query-DCC erc-server-process + "tester" + "~tester" + "fake.irc" + "dummy" + (concat "DCC " (if turbo "TSEND" "SEND") + " foo 2130706433 9899 1405135128")) + (should-not (cdr erc-dcc-list)) + (should (equal (plist-put (car erc-dcc-list) :parent 'fake) + `(:nick "tester!~tester@fake.irc" + :type GET + :peer nil + :parent fake + :ip "127.0.0.1" + :port "9899" + :file "foo" + :size 1405135128 + :turbo ,(and turbo t)))) + (goto-char (point-min)) + (should (search-forward "file foo offered by tester" nil t)) + (erc-dcc-do-LIST-command erc-server-process) + (should (search-forward-regexp (concat + "GET +no +1405135128 +foo" + (and turbo " +(T)") "$") + nil t)) + (when noninteractive + (let (erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (kill-buffer)))) + ;; `erc-dcc-list' is global; must leave it empty + (should erc-dcc-list) + (setq erc-dcc-list nil)) + +(ert-deftest erc-dcc-handle-ctcp-send--base () + (erc-dcc-tests--dcc-handle-ctcp-send nil)) + +(ert-deftest erc-dcc-handle-ctcp-send--turbo () + (erc-dcc-tests--dcc-handle-ctcp-send t)) + +(ert-deftest erc-dcc-do-GET-command () + (with-temp-buffer + (let* ((proc (start-process "fake" (current-buffer) "sleep" "10")) + (elt (list :nick "tester!~tester@fake.irc" + :type 'GET + :peer nil + :parent proc + :ip "127.0.0.1" + :port "9899" + :file "foo.bin" + :size 1405135128)) + (erc-dcc-list (list elt)) + ;; + erc-accidental-paste-threshold-seconds + erc-insert-modify-hook erc-send-completed-hook + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook + calls) + (erc-mode) + (setq erc-server-process proc + erc-input-marker (make-marker) + erc-insert-marker (make-marker) + erc-server-current-nick "dummy") + (set-process-query-on-exit-flag proc nil) + (cl-letf (((symbol-function 'read-file-name) + (lambda (&rest _) "foo.bin")) + ((symbol-function 'erc-dcc-get-file) + (lambda (&rest r) (push r calls)))) + (goto-char (point-max)) + (set-marker erc-insert-marker (point-max)) + (erc-display-prompt) + + (ert-info ("No turbo") + (should-not (plist-member elt :turbo)) + (goto-char erc-input-marker) + (insert "/dcc GET tester foo.bin") + (erc-send-current-line) + (should-not (plist-member (car erc-dcc-list) :turbo)) + (should (equal (pop calls) (list elt "foo.bin" proc)))) + + (ert-info ("Arg turbo in pos 2") + (should-not (plist-member elt :turbo)) + (goto-char erc-input-marker) + (insert "/dcc GET -t tester foo.bin") + (erc-send-current-line) + (should (eq t (plist-get (car erc-dcc-list) :turbo))) + (should (equal (pop calls) (list elt "foo.bin" proc)))) + + (ert-info ("Arg turbo in pos 4") + (setq elt (plist-put elt :turbo nil) + erc-dcc-list (list elt)) + (goto-char erc-input-marker) + (insert "/dcc GET tester -t foo.bin") + (erc-send-current-line) + (should (eq t (plist-get (car erc-dcc-list) :turbo))) + (should (equal (pop calls) (list elt "foo.bin" proc)))) + + (ert-info ("Arg turbo in pos 6") + (setq elt (plist-put elt :turbo nil) + erc-dcc-list (list elt)) + (goto-char erc-input-marker) + (insert "/dcc GET tester foo.bin -t") + (erc-send-current-line) + (should (eq t (plist-get (car erc-dcc-list) :turbo))) + (should (equal (pop calls) (list elt "foo.bin" proc)))))))) + +;;; erc-dcc-tests.el ends here commit 758775f15849a5c6f700ab7111449c3ec678bd8a Author: F. Jason Park Date: Sat Apr 9 23:32:22 2022 -0700 Allow matching against string values in erc-dcc-member * lisp/erc/erc-dcc.el (erc-dcc-member): Be more tolerant in the catch-all case by testing for equality instead of identity. (erc-dcc-do-GET-command): Pass file name when querying `erc-dcc-member'. (Bug#54458) diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index 2a06efdaa4..babd0f3046 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -196,7 +196,7 @@ compared with `erc-nick-equal-p' which is IRC case-insensitive." (erc-extract-nick test) (erc-extract-nick val))) ;; not a nick - (eq test val) + (equal test val) (setq cont nil)))) (if cont (setq result elt) @@ -507,7 +507,7 @@ FILE is the filename. If FILE is split into multiple arguments, re-join the arguments, separated by a space. PROC is the server process." (setq file (and file (mapconcat #'identity file " "))) - (let* ((elt (erc-dcc-member :nick nick :type 'GET)) + (let* ((elt (erc-dcc-member :nick nick :type 'GET :file file)) (filename (or file (plist-get elt :file) "unknown"))) (if elt (let* ((file (read-file-name commit 37e26fc5379715010297adff5109736b7ede5cd7 Author: F. Jason Park Date: Mon Mar 28 02:24:43 2022 -0700 Don't send reports in erc-dcc-get-filter when nested * lisp/erc/erc-dcc.el (erc-dcc-get-filter): Don't bother sending a "received so far" receipt if another attempt is still ongoing. (Bug#54458) diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index a37dc7caa3..2a06efdaa4 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -986,9 +986,10 @@ rather than every 1024 byte block, but nobody seems to care." 'dcc-get-file-too-long ?f (file-name-nondirectory (buffer-name))) (delete-process proc)) - (t - (process-send-string - proc (erc-pack-int received-bytes))))))) + ((not (process-get proc :reportingp)) + (process-put proc :reportingp t) + (process-send-string proc (erc-pack-int received-bytes)) + (process-put proc :reportingp nil)))))) (defun erc-dcc-get-sentinel (proc event) "This is the process sentinel for CTCP DCC SEND connections. commit 93f9f6866aea3b0fd09e6c0c7964b265fd086d00 Author: F. Jason Park Date: Wed Mar 30 17:16:11 2022 -0700 Summarize failed transfers in erc-dcc * lisp/erc/erc-dcc.el (erc-dcc-get-sentinel): Display error when total byte count received is lower than expected. (erc-message-english-dcc-get-failed): Add `dcc-get-failed' to the English messages catalog. (erc-dcc-get-file): Tweak initialization of `erc-dcc-entry-data'. (Bug#54458) diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index 59bfd24603..a37dc7caa3 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -144,6 +144,7 @@ Looks like: (dcc-get-bytes-received . "DCC: %f: %b bytes received") (dcc-get-complete . "DCC: file %f transfer complete (%s bytes in %t seconds)") + (dcc-get-failed . "DCC: file %f transfer failed at %s of %v in %t seconds") (dcc-get-cmd-aborted . "DCC: Aborted getting %f from %n") (dcc-get-file-too-long . "DCC: %f: File longer than sender claimed; aborting transfer") @@ -920,8 +921,7 @@ and making the connection." (inhibit-file-name-operation 'write-region)) (write-region (point) (point) erc-dcc-file-name nil 'nomessage)) - (setq erc-server-process parent-proc - erc-dcc-entry-data entry) + (setq erc-server-process parent-proc) (setq erc-dcc-byte-count 0) (setq proc (funcall erc-dcc-connect-function @@ -935,8 +935,8 @@ and making the connection." (set-process-filter proc #'erc-dcc-get-filter) (set-process-sentinel proc #'erc-dcc-get-sentinel) - (setq entry (plist-put entry :start-time (erc-current-time))) - (setq entry (plist-put entry :peer proc))))) + (setq erc-dcc-entry-data (plist-put (plist-put entry :peer proc) + :start-time (erc-current-time)))))) (defun erc-dcc-append-contents (buffer _file) "Append the contents of BUFFER to FILE. @@ -990,27 +990,30 @@ rather than every 1024 byte block, but nobody seems to care." (process-send-string proc (erc-pack-int received-bytes))))))) - -(defun erc-dcc-get-sentinel (proc _event) +(defun erc-dcc-get-sentinel (proc event) "This is the process sentinel for CTCP DCC SEND connections. It shuts down the connection and notifies the user that the transfer is complete." ;; FIXME, we should look at EVENT, and also check size. + (unless (string= event "connection broken by remote peer\n") + (lwarn 'erc :warning "Unexpected sentinel event %S for %s" + (string-trim-right event) proc)) (with-current-buffer (process-buffer proc) (delete-process proc) (setq erc-dcc-list (delete erc-dcc-entry-data erc-dcc-list)) (unless (= (point-min) (point-max)) (erc-dcc-append-contents (current-buffer) erc-dcc-file-name)) - (erc-display-message - nil 'notice erc-server-process - 'dcc-get-complete - ?f erc-dcc-file-name - ?s (number-to-string erc-dcc-byte-count) - ?t (format "%.0f" - (erc-time-diff (plist-get erc-dcc-entry-data :start-time) - nil)))) - (kill-buffer (process-buffer proc)) - (delete-process proc)) + (let ((done (= erc-dcc-byte-count (plist-get erc-dcc-entry-data :size)))) + (erc-display-message + nil (if done 'notice '(notice error)) erc-server-process + (if done 'dcc-get-complete 'dcc-get-failed) + ?v (plist-get erc-dcc-entry-data :size) + ?f erc-dcc-file-name + ?s (number-to-string erc-dcc-byte-count) + ?t (format "%.0f" + (erc-time-diff (plist-get erc-dcc-entry-data :start-time) + nil)))) + (kill-buffer))) ;;; CHAT handling commit 8a677ffe5774b4c5d5afcdb4b7d64b90e889a8f0 Author: Stefan Monnier Date: Sun May 22 16:27:21 2022 -0400 * lisp/cedet/semantic/fw.el: Fix typo diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el index ca82c8156b..113323cb33 100644 --- a/lisp/cedet/semantic/fw.el +++ b/lisp/cedet/semantic/fw.el @@ -285,10 +285,10 @@ later installation should be done in MODE hook." (if (string-match "^semantic-" name) e (cons (intern (format "semantic-%s" name)) (cdr e))))) - overrides - nil) + overrides) (list 'constant-flag (not transient) - 'override-flag t))) + 'override-flag t) + nil)) ;;; User Interrupt handling ;; commit be0cf9e2995df4d0ff504561afdefba00b49438f Author: Stefan Monnier Date: Sun May 22 16:10:58 2022 -0400 mode-local: Revert the deprecation of buffer-local overrides Obviously, I did not understand how the --install-parser was invoked. Revert "mode-local: Deprecate buffer-local overrides" Revert "semantic-install-function-overrides: Declare obsolete" Revert "wisent.el: Prefer `define-mode-local-override`" This reverts commits 91bc24c46768aab4a851c87edaea05c7476ff779, d2e0d1452b976a51579cf044257326850804c562, and 3294ad44ebcd024b4ada68d00bedca33acc52de6. diff --git a/etc/NEWS b/etc/NEWS index b972163b68..80e867135e 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -827,10 +827,6 @@ so automatically. * Changes in Specialized Modes and Packages in Emacs 29.1 -** CEDET ---- -*** Deprecate buffer-local function overrides for mode-local functions - ** Enriched Mode +++ diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el index 0b24f71dc0..ce37a28c35 100644 --- a/lisp/cedet/mode-local.el +++ b/lisp/cedet/mode-local.el @@ -38,12 +38,10 @@ ;; user might wish to customize a given variable or function then ;; the existing customization mechanism should be used. -;; NOTE: `define-overloadable-function' and `define-mode-local-override' are -;; nowadays advantageously replaced by `cl-defgeneric' and `cl-defmethod' -;; (with a `&context (derived-mode )'). - ;; To Do: ;; Allow customization of a variable for a specific mode? +;; +;; Add macro for defining the '-default' functionality. ;;; Code: @@ -189,7 +187,7 @@ behaviors. Use the function `mode-local-bind' to define new bindings.") (defun mode-local-bind (bindings &optional plist mode) "Define BINDINGS in the specified environment. BINDINGS is a list of (VARIABLE . VALUE). -Argument PLIST is a property list each VARIABLE symbol will +Optional argument PLIST is a property list each VARIABLE symbol will be set to. The following properties have special meaning: - `constant-flag' if non-nil, prevent rebinding variables. @@ -197,15 +195,13 @@ be set to. The following properties have special meaning: - `override-flag' if non-nil, define override functions. The `override-flag' and `mode-variable-flag' properties are mutually -exclusive and exactly one of the two must be non-nil. - -Argument MODE must be a major mode symbol. -BINDINGS will be defined globally for this major mode. +exclusive. -For backward compatibility, If MODE is nil, BINDINGS will be defined locally -in the current buffer, in variable `mode-local-symbol-table', but -this use is deprecated and will be removed." - (declare (advertised-calling-convention (bindings plist mode) "29.1")) +If optional argument MODE is non-nil, it must be a major mode symbol. +BINDINGS will be defined globally for this major mode. If MODE is +nil, BINDINGS will be defined locally in the current buffer, in +variable `mode-local-symbol-table'. The later should be done in MODE +hook." ;; Check plist consistency (and (plist-get plist 'mode-variable-flag) (plist-get plist 'override-flag) @@ -221,7 +217,6 @@ this use is deprecated and will be removed." ;; Fail if trying to bind mode variables in local context! (if (plist-get plist 'mode-variable-flag) (error "Mode required to bind mode variables")) - (message "Obsolete use of nil MODE arg to mode-local-bind!") ;; Install in buffer local symbol table. Create a new one if ;; needed. (setq table (or mode-local-symbol-table @@ -417,7 +412,6 @@ Set each SYM to the value of its VAL, locally in buffers already in MODE, or in buffers switched to that mode. Return the value of the last VAL." (declare (debug (symbolp &rest symbolp form))) - (unless mode (error "Argument mode should be a major mode")) (when args (let (i ll bl sl tmp sym val) (setq i 0) @@ -604,7 +598,6 @@ BODY is the implementation of this function." (declare (doc-string 4) (indent defun) (debug (&define name symbolp lambda-list stringp def-body))) - (unless mode (error "Argument mode should be a major mode")) (let ((newname (intern (format "%s-%s" name mode)))) `(progn (eval-and-compile diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el index d07d8d42a8..ca82c8156b 100644 --- a/lisp/cedet/semantic/fw.el +++ b/lisp/cedet/semantic/fw.el @@ -277,19 +277,18 @@ If optional argument MODE is non-nil, it must be a major mode symbol. OVERRIDES will be installed globally for this major mode. If MODE is nil, OVERRIDES will be installed locally in the current buffer. This later installation should be done in MODE hook." - (declare (obsolete define-mode-local-override "29.1")) - (with-suppressed-warnings ((callargs mode-local-bind)) - (mode-local-bind - ;; Add the semantic- prefix to OVERLOAD short names. - (mapcar - (lambda (e) - (let ((name (symbol-name (car e)))) - (if (string-match "^semantic-" name) - e - (cons (intern (format "semantic-%s" name)) (cdr e))))) - overrides) - (list 'constant-flag (not transient) - 'override-flag t)))) + (mode-local-bind + ;; Add the semantic- prefix to OVERLOAD short names. + (mapcar + (lambda (e) + (let ((name (symbol-name (car e)))) + (if (string-match "^semantic-" name) + e + (cons (intern (format "semantic-%s" name)) (cdr e))))) + overrides + nil) + (list 'constant-flag (not transient) + 'override-flag t))) ;;; User Interrupt handling ;; diff --git a/lisp/cedet/semantic/grammar.el b/lisp/cedet/semantic/grammar.el index d8cf6b2004..74d4a229fa 100644 --- a/lisp/cedet/semantic/grammar.el +++ b/lisp/cedet/semantic/grammar.el @@ -880,7 +880,7 @@ Lisp code." (unless (derived-mode-p 'emacs-lisp-mode) (emacs-lisp-mode)) - ;; Header + Prologue +;;;; Header + Prologue (insert header " \n;;; Prologue\n;;\n" @@ -892,7 +892,7 @@ Lisp code." (save-excursion - ;; Declarations +;;;; Declarations (insert " \n;;; Declarations\n;;\n") @@ -927,12 +927,12 @@ Lisp code." (semantic-grammar-setup-data)) "Setup the Semantic Parser.") - ;; Analyzers +;;;; Analyzers (insert " \n;;; Analyzers\n;;\n") (semantic-grammar-insert-defanalyzers) - ;; Epilogue & Footer +;;;; Epilogue & Footer (insert " \n;;; Epilogue\n;;\n" epilogue @@ -967,7 +967,7 @@ Lisp code." ;; have created this language for, and force them to call our ;; setup function again, refreshing all semantic data, and ;; enabling them to work with the new code just created. - ;; FIXME? +;;;; FIXME? ;; At this point, I don't know any user's defined setup code :-( ;; At least, what I can do for now, is to run the generated ;; parser-install function. diff --git a/lisp/cedet/semantic/grm-wy-boot.el b/lisp/cedet/semantic/grm-wy-boot.el index 6525a10443..376fab89c2 100644 --- a/lisp/cedet/semantic/grm-wy-boot.el +++ b/lisp/cedet/semantic/grm-wy-boot.el @@ -422,6 +422,8 @@ (defun semantic-grammar-wy--install-parser () "Setup the Semantic Parser." + (semantic-install-function-overrides + '((semantic-parse-stream . wisent-parse-stream))) (setq semantic-parser-name "LALR" semantic--parse-table semantic-grammar-wy--parse-table semantic-debug-parser-source "grammar.wy" diff --git a/lisp/cedet/semantic/wisent.el b/lisp/cedet/semantic/wisent.el index d06028b48f..55eeef453e 100644 --- a/lisp/cedet/semantic/wisent.el +++ b/lisp/cedet/semantic/wisent.el @@ -154,25 +154,17 @@ and will be collected in `semantic-lex' form: (SYMBOL START . END)." ;; Maybe the latter is faster because it eliminates a lot of function ;; call. ;; -;; Emacs<29 generated grammars which manually setup `wisent-parse-stream' -;; as a buffer-local overload for `semantic-parse-stream', but we don't -;; need that now that we define a mode-local overload instead. -(define-obsolete-function-alias 'wisent-parse-stream - #'wisent--parse-stream "29.1" - "Recompile your grammars so they don't call `wisent-parse-stream' any more.") -(define-mode-local-override semantic-parse-stream semantic-grammar-mode - (stream goal) - "Parse STREAM using the Wisent LALR parser. -See `wisent--parse-stream'." - (wisent--parse-stream stream goal)) -(defun wisent--parse-stream (stream goal) +(defun wisent-parse-stream (stream goal) "Parse STREAM using the Wisent LALR parser. GOAL is a nonterminal symbol to start parsing at. Return the list (STREAM SEMANTIC-STREAM) where STREAM are those elements of STREAM that have not been used. SEMANTIC-STREAM is the list of semantic tags found. The LALR parser automaton must be available in buffer local variable -`semantic--parse-table'." +`semantic--parse-table'. + +Must be installed by `semantic-install-function-overrides' to override +the standard function `semantic-parse-stream'." (let (wisent-lex-istream wisent-lex-lookahead la-elt cache) ;; IMPLEMENTATION NOTES: @@ -275,7 +267,10 @@ Optional arguments GOAL is a nonterminal symbol to start parsing at, DEPTH is the lexical depth to scan, and RETURNONERROR is a flag to stop parsing on syntax error, when non-nil. The LALR parser automaton must be available in buffer local variable -`semantic--parse-table'." +`semantic--parse-table'. + +Must be installed by `semantic-install-function-overrides' to override +the standard function `semantic-parse-region'." (if (or (< start (point-min)) (> end (point-max)) (< end start)) (error "Invalid bounds [%s %s] passed to `wisent-parse-region'" start end)) diff --git a/lisp/cedet/semantic/wisent/grammar.el b/lisp/cedet/semantic/wisent/grammar.el index 3d83ee197d..a4104e333d 100644 --- a/lisp/cedet/semantic/wisent/grammar.el +++ b/lisp/cedet/semantic/wisent/grammar.el @@ -295,7 +295,9 @@ Return the expanded expression." wisent-grammar-mode () "Return the parser setup code." (format - "(setq semantic-parser-name \"LALR\"\n\ + "(semantic-install-function-overrides\n\ + '((semantic-parse-stream . wisent-parse-stream)))\n\ + (setq semantic-parser-name \"LALR\"\n\ semantic--parse-table %s\n\ semantic-debug-parser-source %S\n\ semantic-flex-keywords-obarray %s\n\ commit 8c153047e78e078b2001be9cf16ef3bbaa375a39 Author: Lars Ingebrigtsen Date: Sun May 22 20:16:01 2022 +0200 Fix bytecomp-test--with-suppressed-warnings test * test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-test--with-suppressed-warnings): Adjust test to change in warning message. diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 051e8b9e5c..049eed10f9 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -1251,7 +1251,7 @@ literals (Bug#20852)." (defun zot () (wrong-params 1 2 3))) '((callargs wrong-params)) - "Warning: wrong-params called with") + "Warning: .wrong-params. called with") (test-byte-comp-compile-and-load nil (defvar obsolete-variable nil) commit f14f6180b78656eec2f4dad5b79eb5da20bd0b70 Author: Lars Ingebrigtsen Date: Sun May 22 20:14:03 2022 +0200 Fix previous warning suppression change * lisp/emacs-lisp/bytecomp.el (byte-compile-emit-callargs-warn) (byte-compile-subr-wrong-args): * lisp/emacs-lisp/byte-run.el (with-suppressed-warnings): * lisp/cedet/semantic/fw.el (semantic-install-function-overrides): The `wrong-args' warning is really called `callargs'. diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el index c60778a34d..d07d8d42a8 100644 --- a/lisp/cedet/semantic/fw.el +++ b/lisp/cedet/semantic/fw.el @@ -278,7 +278,7 @@ OVERRIDES will be installed globally for this major mode. If MODE is nil, OVERRIDES will be installed locally in the current buffer. This later installation should be done in MODE hook." (declare (obsolete define-mode-local-override "29.1")) - (with-suppressed-warnings ((wrong-args mode-local-bind)) + (with-suppressed-warnings ((callargs mode-local-bind)) (mode-local-bind ;; Add the semantic- prefix to OVERLOAD short names. (mapcar diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 2d11f350f0..0113051c8e 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -637,7 +637,7 @@ The warnings that can be suppressed are a subset of the warnings in `byte-compile-warning-types'; see the variable `byte-compile-warnings' for a fuller explanation of the warning types. The types that can be suppressed with this macro are -`free-vars', `callargs', `redefine', `obsolete', `wrong-args', +`free-vars', `callargs', `redefine', `obsolete', `interactive-only', `lexical', `mapcar', `constants' and `suspicious'. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 920cdbe5a6..61382d6989 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1494,7 +1494,7 @@ when printing the error message." byte-compile-unresolved-functions))))) (defun byte-compile-emit-callargs-warn (name actual-args min-args max-args) - (when (byte-compile-warning-enabled-p 'wrong-args name) + (when (byte-compile-warning-enabled-p 'callargs name) (byte-compile-warn-x name "`%s' called with %d argument%s, but %s %s" @@ -3839,7 +3839,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (defun byte-compile-subr-wrong-args (form n) - (when (byte-compile-warning-enabled-p 'wrong-args (car form)) + (when (byte-compile-warning-enabled-p 'callargs (car form)) (byte-compile-warn-x (car form) "`%s' called with %d arg%s, but requires %s" (car form) (length (cdr form)) commit 3f746d44decf9f991ee2a0a0529a2bba9ad12988 Author: Lars Ingebrigtsen Date: Sun May 22 20:07:14 2022 +0200 Fix compilation warning in semantic-install-function-overrides * lisp/cedet/semantic/fw.el (semantic-install-function-overrides): Suppress message about wrong number of arguments. diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el index 14ed3e97ed..c60778a34d 100644 --- a/lisp/cedet/semantic/fw.el +++ b/lisp/cedet/semantic/fw.el @@ -278,17 +278,18 @@ OVERRIDES will be installed globally for this major mode. If MODE is nil, OVERRIDES will be installed locally in the current buffer. This later installation should be done in MODE hook." (declare (obsolete define-mode-local-override "29.1")) - (mode-local-bind - ;; Add the semantic- prefix to OVERLOAD short names. - (mapcar - (lambda (e) - (let ((name (symbol-name (car e)))) - (if (string-match "^semantic-" name) - e - (cons (intern (format "semantic-%s" name)) (cdr e))))) - overrides) - (list 'constant-flag (not transient) - 'override-flag t))) + (with-suppressed-warnings ((wrong-args mode-local-bind)) + (mode-local-bind + ;; Add the semantic- prefix to OVERLOAD short names. + (mapcar + (lambda (e) + (let ((name (symbol-name (car e)))) + (if (string-match "^semantic-" name) + e + (cons (intern (format "semantic-%s" name)) (cdr e))))) + overrides) + (list 'constant-flag (not transient) + 'override-flag t)))) ;;; User Interrupt handling ;; commit a0524584e93a66278dcf7bb998398f7484f9e8b5 Author: Lars Ingebrigtsen Date: Sun May 22 20:06:24 2022 +0200 Allow suppressing messages about the wrong number of arguments * lisp/emacs-lisp/byte-run.el (with-suppressed-warnings): Add `wrong-args'. * lisp/emacs-lisp/bytecomp.el (byte-compile-emit-callargs-warn) (byte-compile-subr-wrong-args): Allow suppressing wrong number of arguments. diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 0113051c8e..2d11f350f0 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -637,7 +637,7 @@ The warnings that can be suppressed are a subset of the warnings in `byte-compile-warning-types'; see the variable `byte-compile-warnings' for a fuller explanation of the warning types. The types that can be suppressed with this macro are -`free-vars', `callargs', `redefine', `obsolete', +`free-vars', `callargs', `redefine', `obsolete', `wrong-args', `interactive-only', `lexical', `mapcar', `constants' and `suspicious'. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index e72b96af4a..920cdbe5a6 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1494,15 +1494,16 @@ when printing the error message." byte-compile-unresolved-functions))))) (defun byte-compile-emit-callargs-warn (name actual-args min-args max-args) - (byte-compile-warn-x - name - "%s called with %d argument%s, but %s %s" - name actual-args - (if (= 1 actual-args) "" "s") - (if (< actual-args min-args) - "requires" - "accepts only") - (byte-compile-arglist-signature-string (cons min-args max-args)))) + (when (byte-compile-warning-enabled-p 'wrong-args name) + (byte-compile-warn-x + name + "`%s' called with %d argument%s, but %s %s" + name actual-args + (if (= 1 actual-args) "" "s") + (if (< actual-args min-args) + "requires" + "accepts only") + (byte-compile-arglist-signature-string (cons min-args max-args))))) (defun byte-compile--check-arity-bytecode (form bytecode) "Check that the call in FORM matches that allowed by BYTECODE." @@ -3838,12 +3839,13 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (defun byte-compile-subr-wrong-args (form n) - (byte-compile-warn-x (car form) - "`%s' called with %d arg%s, but requires %s" - (car form) (length (cdr form)) - (if (= 1 (length (cdr form))) "" "s") n) - ;; Get run-time wrong-number-of-args error. - (byte-compile-normal-call form)) + (when (byte-compile-warning-enabled-p 'wrong-args (car form)) + (byte-compile-warn-x (car form) + "`%s' called with %d arg%s, but requires %s" + (car form) (length (cdr form)) + (if (= 1 (length (cdr form))) "" "s") n) + ;; Get run-time wrong-number-of-args error. + (byte-compile-normal-call form))) (defun byte-compile-no-args (form) (if (not (= (length form) 1)) commit b2a5bf142fb25094ff623dc93d2ce916aee3d971 Author: Juri Linkov Date: Sun May 22 20:55:35 2022 +0300 Enable keys M-down, M-up, M-RET for in-buffer completion * lisp/minibuffer.el (completion-in-region-mode-map): Add keybindings M- for minibuffer-previous-completion, M- for minibuffer-next-completion, M-RET for minibuffer-choose-completion. (completion-in-region-mode): Set buffer-local 'minibuffer-completion-auto-choose' to nil. (minibuffer-next-completion): Get the value of 'minibuffer-completion-auto-choose' from the minibuffer. (minibuffer-previous-completion): Simplify by delegating to 'minibuffer-next-completion'. * doc/emacs/programs.texi (Symbol Completion): Add description of keys M-down, M-up, M-RET. https://lists.gnu.org/archive/html/emacs-devel/2022-05/msg00916.html diff --git a/doc/emacs/programs.texi b/doc/emacs/programs.texi index 2720bdda6f..795aabee74 100644 --- a/doc/emacs/programs.texi +++ b/doc/emacs/programs.texi @@ -1439,9 +1439,13 @@ performs completion using the function, variable, or property names defined in the current Emacs session. In all other respects, in-buffer symbol completion behaves like -minibuffer completion. For instance, if Emacs cannot complete to a -unique symbol, it displays a list of completion alternatives in -another window. @xref{Completion}. +minibuffer completion. For instance, if Emacs cannot complete to +a unique symbol, it displays a list of completion alternatives in +another window. Then you can use the keys @kbd{M-@key{DOWN}} and +@kbd{M-@key{UP}} to navigate through the completions displayed +in the completions buffer without leaving the original buffer, +and the key @kbd{M-@key{RET}} to insert the currently highlighted +completion to the buffer. @xref{Completion}. In Text mode and related modes, @kbd{M-@key{TAB}} completes words based on the spell-checker's dictionary. @xref{Spelling}. diff --git a/etc/NEWS b/etc/NEWS index 0295fbf1f1..b972163b68 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -977,7 +977,9 @@ a completion candidate to the minibuffer, then 'M-RET' can be used to choose the currently active candidate from the "*Completions*" buffer and exit the minibuffer. With a prefix argument, 'C-u M-RET' inserts the currently active candidate to the minibuffer, but doesn't -exit the minibuffer. +exit the minibuffer. These keys are also available for in-buffer +completion, but they don't insert candidates automatically, you need +to type 'M-RET' to insert the selected candidate to the buffer. +++ *** The "*Completions*" buffer can now be automatically selected. diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index fb473cf71b..ee00f96b52 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -2543,7 +2543,10 @@ Also respects the obsolete wrapper hook `completion-in-region-functions'. ;; FIXME: Only works if completion-in-region-mode was activated via ;; completion-at-point called directly. "M-?" #'completion-help-at-point - "TAB" #'completion-at-point) + "TAB" #'completion-at-point + "M-" #'minibuffer-previous-completion + "M-" #'minibuffer-next-completion + "M-RET" #'minibuffer-choose-completion) ;; It is difficult to know when to exit completion-in-region-mode (i.e. hide ;; the *Completions*). Here's how previous packages did it: @@ -2590,6 +2593,7 @@ Also respects the obsolete wrapper hook `completion-in-region-functions'. (cl-assert completion-in-region-mode-predicate) (setq completion-in-region-mode--predicate completion-in-region-mode-predicate) + (setq-local minibuffer-completion-auto-choose nil) (add-hook 'post-command-hook #'completion-in-region--postch) (push `(completion-in-region-mode . ,completion-in-region-mode-map) minor-mode-overriding-map-alist))) @@ -4369,30 +4373,25 @@ selected by these commands to the minibuffer." :version "29.1") (defun minibuffer-next-completion (&optional n) - "Run `next-completion' from the minibuffer in its completions window. + "Move to the next item in its completions window from the minibuffer. When `minibuffer-completion-auto-choose' is non-nil, then also insert the selected completion to the minibuffer." (interactive "p") - (with-minibuffer-completions-window - (when completions-highlight-face - (setq-local cursor-face-highlight-nonselected-window t)) - (next-completion (or n 1)) - (when minibuffer-completion-auto-choose - (let ((completion-use-base-affixes t)) - (choose-completion nil t t))))) + (let ((auto-choose minibuffer-completion-auto-choose)) + (with-minibuffer-completions-window + (when completions-highlight-face + (setq-local cursor-face-highlight-nonselected-window t)) + (next-completion (or n 1)) + (when auto-choose + (let ((completion-use-base-affixes t)) + (choose-completion nil t t)))))) (defun minibuffer-previous-completion (&optional n) - "Run `previous-completion' from the minibuffer in its completions window. + "Move to the previous item in its completions window from the minibuffer. When `minibuffer-completion-auto-choose' is non-nil, then also insert the selected completion to the minibuffer." (interactive "p") - (with-minibuffer-completions-window - (when completions-highlight-face - (setq-local cursor-face-highlight-nonselected-window t)) - (previous-completion (or n 1)) - (when minibuffer-completion-auto-choose - (let ((completion-use-base-affixes t)) - (choose-completion nil t t))))) + (minibuffer-next-completion (- (or n 1)))) (defun minibuffer-choose-completion (&optional no-exit no-quit) "Run `choose-completion' from the minibuffer in its completions window. commit 2f68673a712508f70de20f485422c7e01b8ab21b Author: Alan Mackenzie Date: Sun May 22 16:55:05 2022 +0000 CC Mode: Restore string fence properties at each relevant external entry point This fixes bug #55230. * lisp/progmodes/cc-defs.el (c-string-fences-set-flag, c-with-string-fences): New variable and macro. * lisp/progmodes/cc-mode.el (c-called-from-text-property-change-p): Add remove-text-properties to the list of accepted functions. (c-clear-string-fences, c-restore-string-fences): Surround the functions' innards with c-save-buffer-state to prevent text property changes causing change functions to be called. (c-before-change, c-after-change, c-font-lock-fontify-region): Replace the explicit calls to c-restore-string-fences and c-clear-string-fences with invocations of the new macro c-with-string-fences. * lisp/progmodes/cc-awk.el (c-awk-extend-and-syntax-tablify-region) (c-awk-end-of-defun) * lisp/progmodes/cc-cmds.el (c-show-syntactic-information) (c-electric-backspace, c-hungry-delete-backwards, c-electric-delete-forward) (c-hungry-delete-forward, c-electric-pound, c-electric-brace) (c-electric-slash, c-electric-star, c-electric-semi&comma, c-electric-colon) (c-electric-lt-gt, c-electric-paren, c-beginning-of-defun, c-end-of-defun) (c-display-defun-name, c-mark-function, c-beginning-of-statement) (c-end-of-statement, c-indent-command, c-indent-exp, c-indent-defun) (c-indent-line-or-region, c-fill-paragraph, c-indent-new-comment-line) (c-context-line-break) * lisp/progmodes/cc-guess.el (c-guess-region-no-install): These are all "boundary" functions to CC Mode. Surround each by c-with-string-fences. diff --git a/lisp/progmodes/cc-awk.el b/lisp/progmodes/cc-awk.el index 188d5a8a83..9ea1557391 100644 --- a/lisp/progmodes/cc-awk.el +++ b/lisp/progmodes/cc-awk.el @@ -56,6 +56,8 @@ ;; Silence the byte compiler. (cc-bytecomp-defvar c-new-BEG) (cc-bytecomp-defvar c-new-END) +(cc-bytecomp-defun c-restore-string-fences) +(cc-bytecomp-defun c-clear-string-fences) ;; Some functions in cc-engine that are used below. There's a cyclic ;; dependency so it can't be required here. (Perhaps some functions @@ -934,7 +936,7 @@ ;; It prepares the buffer for font ;; locking, hence must get called before `font-lock-after-change-function'. ;; - ;; This function is the AWK value of `c-before-font-lock-function'. + ;; This function is the AWK value of `c-before-font-lock-functions'. ;; It does hidden buffer changes. (c-save-buffer-state () (setq c-new-END (c-awk-end-of-change-region beg end old-len)) @@ -1109,29 +1111,30 @@ nor helpful. Note that this function might do hidden buffer changes. See the comment at the start of cc-engine.el for more info." (interactive "p") - (or arg (setq arg 1)) - (save-match-data - (c-save-buffer-state ; ensures the buffer is writable. - nil - (let ((found t)) ; Has the most recent regexp search found b-of-defun? - (if (>= arg 0) - ;; Go back one defun each time round the following loop. (For +ve arg) - (while (and found (> arg 0) (not (eq (point) (point-min)))) - ;; Go back one "candidate" each time round the next loop until one - ;; is genuinely a beginning-of-defun. - (while (and (setq found (search-backward-regexp - "^[^#} \t\n\r]" (point-min) 'stop-at-limit)) - (not (memq (c-awk-get-NL-prop-prev-line) '(?\$ ?\} ?\#))))) - (setq arg (1- arg))) - ;; The same for a -ve arg. - (if (not (eq (point) (point-max))) (forward-char 1)) - (while (and found (< arg 0) (not (eq (point) (point-max)))) ; The same for -ve arg. - (while (and (setq found (search-forward-regexp - "^[^#} \t\n\r]" (point-max) 'stop-at-limit)) - (not (memq (c-awk-get-NL-prop-prev-line) '(?\$ ?\} ?\#))))) - (setq arg (1+ arg))) - (if found (goto-char (match-beginning 0)))) - (eq arg 0))))) + (c-with-string-fences + (or arg (setq arg 1)) + (save-match-data + (c-save-buffer-state ; ensures the buffer is writable. + nil + (let ((found t)) ; Has the most recent regexp search found b-of-defun? + (if (>= arg 0) + ;; Go back one defun each time round the following loop. (For +ve arg) + (while (and found (> arg 0) (not (eq (point) (point-min)))) + ;; Go back one "candidate" each time round the next loop until one + ;; is genuinely a beginning-of-defun. + (while (and (setq found (search-backward-regexp + "^[^#} \t\n\r]" (point-min) 'stop-at-limit)) + (not (memq (c-awk-get-NL-prop-prev-line) '(?\$ ?\} ?\#))))) + (setq arg (1- arg))) + ;; The same for a -ve arg. + (if (not (eq (point) (point-max))) (forward-char 1)) + (while (and found (< arg 0) (not (eq (point) (point-max)))) ; The same for -ve arg. + (while (and (setq found (search-forward-regexp + "^[^#} \t\n\r]" (point-max) 'stop-at-limit)) + (not (memq (c-awk-get-NL-prop-prev-line) '(?\$ ?\} ?\#))))) + (setq arg (1+ arg))) + (if found (goto-char (match-beginning 0)))) + (eq arg 0)))))) (defun c-awk-forward-awk-pattern () ;; Point is at the start of an AWK pattern (which may be null) or function @@ -1187,39 +1190,40 @@ no explicit action; see function `c-awk-beginning-of-defun'. Note that this function might do hidden buffer changes. See the comment at the start of cc-engine.el for more info." (interactive "p") - (or arg (setq arg 1)) - (save-match-data - (c-save-buffer-state - nil - (let ((start-point (point)) end-point) - ;; Strategy: (For +ve ARG): If we're not already at a beginning-of-defun, - ;; move backwards to one. - ;; Repeat [(i) move forward to end-of-current-defun (see below); - ;; (ii) If this isn't it, move forward to beginning-of-defun]. - ;; We start counting ARG only when step (i) has passed the original point. - (when (> arg 0) - ;; Try to move back to a beginning-of-defun, if not already at one. - (if (not (c-awk-beginning-of-defun-p)) - (when (not (c-awk-beginning-of-defun 1)) ; No bo-defun before point. - (goto-char start-point) - (c-awk-beginning-of-defun -1))) ; if this fails, we're at EOB, tough! - ;; Now count forward, one defun at a time - (while (and (not (eobp)) - (c-awk-end-of-defun1) - (if (> (point) start-point) (setq arg (1- arg)) t) - (> arg 0) - (c-awk-beginning-of-defun -1)))) - - (when (< arg 0) - (setq end-point start-point) - (while (and (not (bobp)) - (c-awk-beginning-of-defun 1) - (if (< (setq end-point (if (bobp) (point) - (save-excursion (c-awk-end-of-defun1)))) - start-point) - (setq arg (1+ arg)) t) - (< arg 0))) - (goto-char (min start-point end-point))))))) + (c-with-string-fences + (or arg (setq arg 1)) + (save-match-data + (c-save-buffer-state + nil + (let ((start-point (point)) end-point) + ;; Strategy: (For +ve ARG): If we're not already at a beginning-of-defun, + ;; move backwards to one. + ;; Repeat [(i) move forward to end-of-current-defun (see below); + ;; (ii) If this isn't it, move forward to beginning-of-defun]. + ;; We start counting ARG only when step (i) has passed the original point. + (when (> arg 0) + ;; Try to move back to a beginning-of-defun, if not already at one. + (if (not (c-awk-beginning-of-defun-p)) + (when (not (c-awk-beginning-of-defun 1)) ; No bo-defun before point. + (goto-char start-point) + (c-awk-beginning-of-defun -1))) ; if this fails, we're at EOB, tough! + ;; Now count forward, one defun at a time + (while (and (not (eobp)) + (c-awk-end-of-defun1) + (if (> (point) start-point) (setq arg (1- arg)) t) + (> arg 0) + (c-awk-beginning-of-defun -1)))) + + (when (< arg 0) + (setq end-point start-point) + (while (and (not (bobp)) + (c-awk-beginning-of-defun 1) + (if (< (setq end-point (if (bobp) (point) + (save-excursion (c-awk-end-of-defun1)))) + start-point) + (setq arg (1+ arg)) t) + (< arg 0))) + (goto-char (min start-point end-point)))))))) (cc-provide 'cc-awk) ; Changed from 'awk-mode, ACM 2002/5/21 diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el index f1f61f7e08..e3f2bd152b 100644 --- a/lisp/progmodes/cc-cmds.el +++ b/lisp/progmodes/cc-cmds.el @@ -49,6 +49,8 @@ ; which looks at this. (cc-bytecomp-defun electric-pair-post-self-insert-function) (cc-bytecomp-defvar c-indent-to-body-directives) +(cc-bytecomp-defun c-restore-string-fences) +(cc-bytecomp-defun c-clear-string-fences) (defvar c-syntactic-context) ;; Indentation / Display syntax functions @@ -210,35 +212,36 @@ and takes care to set the indentation before calling "Show syntactic information for current line. With universal argument, inserts the analysis as a comment on that line." (interactive "P") - (let* ((c-parsing-error nil) - (syntax (if (boundp 'c-syntactic-context) - ;; Use `c-syntactic-context' in the same way as - ;; `c-indent-line', to be consistent. - c-syntactic-context - (c-save-buffer-state nil - (c-guess-basic-syntax))))) - (if (not (consp arg)) - (let (elem pos ols) - (message "Syntactic analysis: %s" syntax) - (unwind-protect - (progn - (while syntax - (setq elem (pop syntax)) - (when (setq pos (c-langelem-pos elem)) - (push (c-put-overlay pos (1+ pos) - 'face 'highlight) - ols)) - (when (setq pos (c-langelem-2nd-pos elem)) - (push (c-put-overlay pos (1+ pos) - 'face 'secondary-selection) - ols))) - (sit-for 10)) - (while ols - (c-delete-overlay (pop ols))))) - (indent-for-comment) - (insert-and-inherit (format "%s" syntax)) - )) - (c-keep-region-active)) + (c-with-string-fences + (let* ((c-parsing-error nil) + (syntax (if (boundp 'c-syntactic-context) + ;; Use `c-syntactic-context' in the same way as + ;; `c-indent-line', to be consistent. + c-syntactic-context + (c-save-buffer-state nil + (c-guess-basic-syntax))))) + (if (not (consp arg)) + (let (elem pos ols) + (message "Syntactic analysis: %s" syntax) + (unwind-protect + (progn + (while syntax + (setq elem (pop syntax)) + (when (setq pos (c-langelem-pos elem)) + (push (c-put-overlay pos (1+ pos) + 'face 'highlight) + ols)) + (when (setq pos (c-langelem-2nd-pos elem)) + (push (c-put-overlay pos (1+ pos) + 'face 'secondary-selection) + ols))) + (sit-for 10)) + (while ols + (c-delete-overlay (pop ols))))) + (indent-for-comment) + (insert-and-inherit (format "%s" syntax)) + )) + (c-keep-region-active))) (defun c-syntactic-information-on-region (from to) "Insert a comment with the syntactic analysis on every line in the region." @@ -414,23 +417,25 @@ argument is supplied, or `c-hungry-delete-key' is nil, or point is inside a literal then the function in the variable `c-backspace-function' is called." (interactive "*P") - (if (c-save-buffer-state () - (or (not c-hungry-delete-key) - arg - (c-in-literal))) - (funcall c-backspace-function (prefix-numeric-value arg)) - (c-hungry-delete-backwards))) + (c-with-string-fences + (if (c-save-buffer-state () + (or (not c-hungry-delete-key) + arg + (c-in-literal))) + (funcall c-backspace-function (prefix-numeric-value arg)) + (c-hungry-delete-backwards)))) (defun c-hungry-delete-backwards () "Delete the preceding character or all preceding whitespace back to the previous non-whitespace character. See also \\[c-hungry-delete-forward]." (interactive) - (let ((here (point))) - (c-skip-ws-backward) - (if (/= (point) here) - (delete-region (point) here) - (funcall c-backspace-function 1)))) + (c-with-string-fences + (let ((here (point))) + (c-skip-ws-backward) + (if (/= (point) here) + (delete-region (point) here) + (funcall c-backspace-function 1))))) (defalias 'c-hungry-backspace 'c-hungry-delete-backwards) @@ -442,23 +447,26 @@ argument is supplied, or `c-hungry-delete-key' is nil, or point is inside a literal then the function in the variable `c-delete-function' is called." (interactive "*P") - (if (c-save-buffer-state () - (or (not c-hungry-delete-key) - arg - (c-in-literal))) - (funcall c-delete-function (prefix-numeric-value arg)) - (c-hungry-delete-forward))) + (c-with-string-fences + (if + (c-save-buffer-state () + (or (not c-hungry-delete-key) + arg + (c-in-literal))) + (funcall c-delete-function (prefix-numeric-value arg)) + (c-hungry-delete-forward)))) (defun c-hungry-delete-forward () "Delete the following character or all following whitespace up to the next non-whitespace character. See also \\[c-hungry-delete-backwards]." (interactive) - (let ((here (point))) - (c-skip-ws-forward) - (if (/= (point) here) - (delete-region (point) here) - (funcall c-delete-function 1)))) + (c-with-string-fences + (let ((here (point))) + (c-skip-ws-forward) + (if (/= (point) here) + (delete-region (point) here) + (funcall c-delete-function 1))))) ;; This function is only used in XEmacs. (defun c-electric-delete (arg) @@ -530,31 +538,32 @@ If `c-electric-flag' is set, handle it specially according to the variable `c-electric-pound-behavior'. If a numeric ARG is supplied, or if point is inside a literal or a macro, nothing special happens." (interactive "*P") - (if (c-save-buffer-state () - (or arg - (not c-electric-flag) - (not (memq 'alignleft c-electric-pound-behavior)) - (save-excursion - (skip-chars-backward " \t") - (not (bolp))) - (save-excursion - (and (= (forward-line -1) 0) - (progn (end-of-line) - (eq (char-before) ?\\)))) - (c-in-literal))) - ;; do nothing special - (let (post-self-insert-hook) ; Disable random functionality. - (self-insert-command (prefix-numeric-value arg))) - ;; place the pound character at the left edge - (let ((pos (- (point-max) (point))) - (bolp (bolp))) - (beginning-of-line) - (delete-horizontal-space) - (insert (c-last-command-char)) - (and (not bolp) - (goto-char (- (point-max) pos))) - )) - (c--call-post-self-insert-hook-more-safely)) + (c-with-string-fences + (if (c-save-buffer-state () + (or arg + (not c-electric-flag) + (not (memq 'alignleft c-electric-pound-behavior)) + (save-excursion + (skip-chars-backward " \t") + (not (bolp))) + (save-excursion + (and (= (forward-line -1) 0) + (progn (end-of-line) + (eq (char-before) ?\\)))) + (c-in-literal))) + ;; do nothing special + (let (post-self-insert-hook) ; Disable random functionality. + (self-insert-command (prefix-numeric-value arg))) + ;; place the pound character at the left edge + (let ((pos (- (point-max) (point))) + (bolp (bolp))) + (beginning-of-line) + (delete-horizontal-space) + (insert (c-last-command-char)) + (and (not bolp) + (goto-char (- (point-max) pos))) + )) + (c--call-post-self-insert-hook-more-safely))) (defun c-point-syntax () ;; Return the syntactic context of the construct at point. (This is NOT @@ -882,60 +891,61 @@ reindented unless `c-syntactic-indentation' is nil. settings of `c-cleanup-list' are done." (interactive "*P") - (let (safepos literal - ;; We want to inhibit blinking the paren since this would be - ;; most disruptive. We'll blink it ourselves later on. - (old-blink-paren blink-paren-function) - blink-paren-function case-fold-search - (at-eol (looking-at "[ \t]*\\\\?$")) - (active-region (and (fboundp 'use-region-p) (use-region-p))) - got-pair-} electric-pair-deletion) - - (c-save-buffer-state () - (setq safepos (c-safe-position (point) (c-parse-state)) - literal (c-in-literal safepos))) - - ;; Insert the brace. Note that expand-abbrev might reindent - ;; the line here if there's a preceding "else" or something. - (let (post-self-insert-hook) ; the only way to get defined functionality - ; from `self-insert-command'. - (self-insert-command (prefix-numeric-value arg))) - - ;; Emulate `electric-pair-mode'. - (when (and (boundp 'electric-pair-mode) - electric-pair-mode) - (let ((size (buffer-size)) - post-self-insert-hook) - (electric-pair-post-self-insert-function) - (setq got-pair-} (and at-eol - (eq (c-last-command-char) ?{) - (eq (char-after) ?})) - electric-pair-deletion (< (buffer-size) size)))) - - ;; Perform any required CC Mode electric actions. - (cond - ((or literal arg (not c-electric-flag) active-region)) - ((not at-eol) - (c-indent-line)) - (electric-pair-deletion - (c-indent-line) - (c-do-brace-electrics 'ignore nil)) - (t (c-do-brace-electrics nil nil) - (when got-pair-} + (c-with-string-fences + (let (safepos literal + ;; We want to inhibit blinking the paren since this would be + ;; most disruptive. We'll blink it ourselves later on. + (old-blink-paren blink-paren-function) + blink-paren-function case-fold-search + (at-eol (looking-at "[ \t]*\\\\?$")) + (active-region (and (fboundp 'use-region-p) (use-region-p))) + got-pair-} electric-pair-deletion) + + (c-save-buffer-state () + (setq safepos (c-safe-position (point) (c-parse-state)) + literal (c-in-literal safepos))) + + ;; Insert the brace. Note that expand-abbrev might reindent + ;; the line here if there's a preceding "else" or something. + (let (post-self-insert-hook) ; the only way to get defined functionality + ; from `self-insert-command'. + (self-insert-command (prefix-numeric-value arg))) + + ;; Emulate `electric-pair-mode'. + (when (and (boundp 'electric-pair-mode) + electric-pair-mode) + (let ((size (buffer-size)) + post-self-insert-hook) + (electric-pair-post-self-insert-function) + (setq got-pair-} (and at-eol + (eq (c-last-command-char) ?{) + (eq (char-after) ?})) + electric-pair-deletion (< (buffer-size) size)))) + + ;; Perform any required CC Mode electric actions. + (cond + ((or literal arg (not c-electric-flag) active-region)) + ((not at-eol) + (c-indent-line)) + (electric-pair-deletion + (c-indent-line) + (c-do-brace-electrics 'ignore nil)) + (t (c-do-brace-electrics nil nil) + (when got-pair-} + (save-excursion + (forward-char) + (c-do-brace-electrics 'assume 'ignore)) + (c-indent-line)))) + + ;; blink the paren + (and (eq (c-last-command-char) ?\}) + (not executing-kbd-macro) + old-blink-paren (save-excursion - (forward-char) - (c-do-brace-electrics 'assume 'ignore)) - (c-indent-line)))) - - ;; blink the paren - (and (eq (c-last-command-char) ?\}) - (not executing-kbd-macro) - old-blink-paren - (save-excursion - (c-save-buffer-state nil - (c-backward-syntactic-ws safepos)) - (funcall old-blink-paren))) - (c--call-post-self-insert-hook-more-safely))) + (c-save-buffer-state nil + (c-backward-syntactic-ws safepos)) + (funcall old-blink-paren))) + (c--call-post-self-insert-hook-more-safely)))) (defun c-electric-slash (arg) "Insert a slash character. @@ -956,39 +966,40 @@ If a numeric ARG is supplied, point is inside a literal, or `c-syntactic-indentation' is nil or `c-electric-flag' is nil, indentation is inhibited." (interactive "*P") - (let ((literal (c-save-buffer-state () (c-in-literal))) - indentp - ;; shut this up - (c-echo-syntactic-information-p nil)) + (c-with-string-fences + (let ((literal (c-save-buffer-state () (c-in-literal))) + indentp + ;; shut this up + (c-echo-syntactic-information-p nil)) - ;; comment-close-slash cleanup? This DOESN'T need `c-electric-flag' or - ;; `c-syntactic-indentation' set. - (when (and (not arg) - (eq literal 'c) - (memq 'comment-close-slash c-cleanup-list) - (eq (c-last-command-char) ?/) - (looking-at (concat "[ \t]*\\(" - (regexp-quote comment-end) "\\)?$")) - ; (eq c-block-comment-ender "*/") ; C-style comments ALWAYS end in */ - (save-excursion - (save-restriction - (narrow-to-region (point-min) (point)) - (back-to-indentation) - (looking-at (concat c-current-comment-prefix "[ \t]*$"))))) - (delete-region (progn (forward-line 0) (point)) - (progn (end-of-line) (point))) - (insert-char ?* 1)) ; the / comes later. ; Do I need a t (retain sticky properties) here? - - (setq indentp (and (not arg) - c-syntactic-indentation - c-electric-flag - (eq (c-last-command-char) ?/) - (eq (char-before) (if literal ?* ?/)))) - (let (post-self-insert-hook) ; Disable random functionality. - (self-insert-command (prefix-numeric-value arg))) - (if indentp - (indent-according-to-mode)) - (c--call-post-self-insert-hook-more-safely))) + ;; comment-close-slash cleanup? This DOESN'T need `c-electric-flag' or + ;; `c-syntactic-indentation' set. + (when (and (not arg) + (eq literal 'c) + (memq 'comment-close-slash c-cleanup-list) + (eq (c-last-command-char) ?/) + (looking-at (concat "[ \t]*\\(" + (regexp-quote comment-end) "\\)?$")) + ; (eq c-block-comment-ender "*/") ; C-style comments ALWAYS end in */ + (save-excursion + (save-restriction + (narrow-to-region (point-min) (point)) + (back-to-indentation) + (looking-at (concat c-current-comment-prefix "[ \t]*$"))))) + (delete-region (progn (forward-line 0) (point)) + (progn (end-of-line) (point))) + (insert-char ?* 1)) ; the / comes later. ; Do I need a t (retain sticky properties) here? + + (setq indentp (and (not arg) + c-syntactic-indentation + c-electric-flag + (eq (c-last-command-char) ?/) + (eq (char-before) (if literal ?* ?/)))) + (let (post-self-insert-hook) ; Disable random functionality. + (self-insert-command (prefix-numeric-value arg))) + (if indentp + (indent-according-to-mode)) + (c--call-post-self-insert-hook-more-safely)))) (defun c-electric-star (arg) "Insert a star character. @@ -999,27 +1010,27 @@ supplied, point is inside a literal, or `c-syntactic-indentation' is nil, this indentation is inhibited." (interactive "*P") - (let (post-self-insert-hook) ; Disable random functionality. - (self-insert-command (prefix-numeric-value arg))) - ;; if we are in a literal, or if arg is given do not reindent the - ;; current line, unless this star introduces a comment-only line. - (if (c-save-buffer-state () - (and c-syntactic-indentation - c-electric-flag - (not arg) - (eq (c-in-literal) 'c) - (eq (char-before) ?*) - (save-excursion - (forward-char -1) - (skip-chars-backward "*") - (if (eq (char-before) ?/) - (forward-char -1)) - (skip-chars-backward " \t") - (bolp)))) - (let (c-echo-syntactic-information-p) ; shut this up - (indent-according-to-mode)) - ) - (c--call-post-self-insert-hook-more-safely)) + (c-with-string-fences + (let (post-self-insert-hook) ; Disable random functionality. + (self-insert-command (prefix-numeric-value arg))) + ;; if we are in a literal, or if arg is given do not reindent the + ;; current line, unless this star introduces a comment-only line. + (if (c-save-buffer-state () + (and c-syntactic-indentation + c-electric-flag + (not arg) + (eq (c-in-literal) 'c) + (eq (char-before) ?*) + (save-excursion + (forward-char -1) + (skip-chars-backward "*") + (if (eq (char-before) ?/) + (forward-char -1)) + (skip-chars-backward " \t") + (bolp)))) + (let (c-echo-syntactic-information-p) ; shut this up + (indent-according-to-mode))) + (c--call-post-self-insert-hook-more-safely))) (defun c-electric-semi&comma (arg) "Insert a comma or semicolon. @@ -1039,60 +1050,61 @@ reindented unless `c-syntactic-indentation' is nil. semicolon following a defun might be cleaned up, depending on the settings of `c-cleanup-list'." (interactive "*P") - (let* (lim literal c-syntactic-context - (here (point)) - ;; shut this up - (c-echo-syntactic-information-p nil)) - - (c-save-buffer-state () - (setq lim (c-most-enclosing-brace (c-parse-state)) - literal (c-in-literal lim))) - - (let (post-self-insert-hook) ; Disable random functionality. - (self-insert-command (prefix-numeric-value arg))) - - (if (and c-electric-flag (not literal) (not arg)) - ;; do all cleanups and newline insertions if c-auto-newline is on. - (if (or (not c-auto-newline) - (not (looking-at "[ \t]*\\\\?$"))) - (if c-syntactic-indentation - (c-indent-line)) - ;; clean ups: list-close-comma or defun-close-semi - (let ((pos (- (point-max) (point)))) - (if (c-save-buffer-state () - (and (or (and - (eq (c-last-command-char) ?,) - (memq 'list-close-comma c-cleanup-list)) - (and - (eq (c-last-command-char) ?\;) - (memq 'defun-close-semi c-cleanup-list))) - (progn - (forward-char -1) - (c-skip-ws-backward) - (eq (char-before) ?})) - ;; make sure matching open brace isn't in a comment - (not (c-in-literal lim)))) - (delete-region (point) here)) - (goto-char (- (point-max) pos))) - ;; reindent line - (when c-syntactic-indentation - (setq c-syntactic-context (c-guess-basic-syntax)) - (c-indent-line c-syntactic-context)) - ;; check to see if a newline should be added - (let ((criteria c-hanging-semi&comma-criteria) - answer add-newline-p) - (while criteria - (setq answer (funcall (car criteria))) - ;; only nil value means continue checking - (if (not answer) - (setq criteria (cdr criteria)) - (setq criteria nil) - ;; only 'stop specifically says do not add a newline - (setq add-newline-p (not (eq answer 'stop))) - )) - (if add-newline-p - (c-newline-and-indent))))) - (c--call-post-self-insert-hook-more-safely))) + (c-with-string-fences + (let* (lim literal c-syntactic-context + (here (point)) + ;; shut this up + (c-echo-syntactic-information-p nil)) + + (c-save-buffer-state () + (setq lim (c-most-enclosing-brace (c-parse-state)) + literal (c-in-literal lim))) + + (let (post-self-insert-hook) ; Disable random functionality. + (self-insert-command (prefix-numeric-value arg))) + + (if (and c-electric-flag (not literal) (not arg)) + ;; do all cleanups and newline insertions if c-auto-newline is on. + (if (or (not c-auto-newline) + (not (looking-at "[ \t]*\\\\?$"))) + (if c-syntactic-indentation + (c-indent-line)) + ;; clean ups: list-close-comma or defun-close-semi + (let ((pos (- (point-max) (point)))) + (if (c-save-buffer-state () + (and (or (and + (eq (c-last-command-char) ?,) + (memq 'list-close-comma c-cleanup-list)) + (and + (eq (c-last-command-char) ?\;) + (memq 'defun-close-semi c-cleanup-list))) + (progn + (forward-char -1) + (c-skip-ws-backward) + (eq (char-before) ?})) + ;; make sure matching open brace isn't in a comment + (not (c-in-literal lim)))) + (delete-region (point) here)) + (goto-char (- (point-max) pos))) + ;; reindent line + (when c-syntactic-indentation + (setq c-syntactic-context (c-guess-basic-syntax)) + (c-indent-line c-syntactic-context)) + ;; check to see if a newline should be added + (let ((criteria c-hanging-semi&comma-criteria) + answer add-newline-p) + (while criteria + (setq answer (funcall (car criteria))) + ;; only nil value means continue checking + (if (not answer) + (setq criteria (cdr criteria)) + (setq criteria nil) + ;; only 'stop specifically says do not add a newline + (setq add-newline-p (not (eq answer 'stop))) + )) + (if add-newline-p + (c-newline-and-indent))))) + (c--call-post-self-insert-hook-more-safely)))) (defun c-electric-colon (arg) "Insert a colon. @@ -1113,89 +1125,90 @@ reindented unless `c-syntactic-indentation' is nil. `c-cleanup-list'." (interactive "*P") - (let* ((bod (c-point 'bod)) - (literal (c-save-buffer-state () (c-in-literal bod))) - newlines is-scope-op - ;; shut this up - (c-echo-syntactic-information-p nil)) - (let (post-self-insert-hook) ; Disable random functionality. - (self-insert-command (prefix-numeric-value arg))) - ;; Any electric action? - (if (and c-electric-flag (not literal) (not arg)) - ;; Unless we're at EOL, only re-indentation happens. - (if (not (looking-at "[ \t]*\\\\?$")) - (if c-syntactic-indentation - (indent-according-to-mode)) - - ;; scope-operator clean-up? - (let ((pos (- (point-max) (point))) - (here (point))) - (if (c-save-buffer-state () ; Why do we need this? [ACM, 2003-03-12] - (and c-auto-newline - (memq 'scope-operator c-cleanup-list) - (eq (char-before) ?:) - (progn - (forward-char -1) - (c-skip-ws-backward) - (eq (char-before) ?:)) - (not (c-in-literal)) - (not (eq (char-after (- (point) 2)) ?:)))) - (progn - (delete-region (point) (1- here)) - (setq is-scope-op t))) - (goto-char (- (point-max) pos))) - - ;; indent the current line if it's done syntactically. - (if c-syntactic-indentation - ;; Cannot use the same syntax analysis as we find below, - ;; since that's made with c-syntactic-indentation-in-macros - ;; always set to t. - (indent-according-to-mode)) - - ;; Calculate where, if anywhere, we want newlines. - (c-save-buffer-state - ((c-syntactic-indentation-in-macros t) - (c-auto-newline-analysis t) - ;; Turn on syntactic macro analysis to help with auto newlines - ;; only. - (syntax (c-guess-basic-syntax)) - (elem syntax)) - ;; Translate substatement-label to label for this operation. - (while elem - (if (eq (car (car elem)) 'substatement-label) - (setcar (car elem) 'label)) - (setq elem (cdr elem))) - ;; some language elements can only be determined by checking - ;; the following line. Let's first look for ones that can be - ;; found when looking on the line with the colon - (setq newlines - (and c-auto-newline - (or (c-lookup-lists '(case-label label access-label) - syntax c-hanging-colons-alist) - (c-lookup-lists '(member-init-intro inher-intro) - (progn - (insert ?\n) - (unwind-protect - (c-guess-basic-syntax) - (delete-char -1))) - c-hanging-colons-alist))))) - ;; does a newline go before the colon? Watch out for already - ;; non-hung colons. However, we don't unhang them because that - ;; would be a cleanup (and anti-social). - (if (and (memq 'before newlines) - (not is-scope-op) - (save-excursion - (skip-chars-backward ": \t") - (not (bolp)))) - (let ((pos (- (point-max) (point)))) - (forward-char -1) - (c-newline-and-indent) - (goto-char (- (point-max) pos)))) - ;; does a newline go after the colon? - (if (and (memq 'after (cdr-safe newlines)) - (not is-scope-op)) - (c-newline-and-indent)))) - (c--call-post-self-insert-hook-more-safely))) + (c-with-string-fences + (let* ((bod (c-point 'bod)) + (literal (c-save-buffer-state () (c-in-literal bod))) + newlines is-scope-op + ;; shut this up + (c-echo-syntactic-information-p nil)) + (let (post-self-insert-hook) ; Disable random functionality. + (self-insert-command (prefix-numeric-value arg))) + ;; Any electric action? + (if (and c-electric-flag (not literal) (not arg)) + ;; Unless we're at EOL, only re-indentation happens. + (if (not (looking-at "[ \t]*\\\\?$")) + (if c-syntactic-indentation + (indent-according-to-mode)) + + ;; scope-operator clean-up? + (let ((pos (- (point-max) (point))) + (here (point))) + (if (c-save-buffer-state () ; Why do we need this? [ACM, 2003-03-12] + (and c-auto-newline + (memq 'scope-operator c-cleanup-list) + (eq (char-before) ?:) + (progn + (forward-char -1) + (c-skip-ws-backward) + (eq (char-before) ?:)) + (not (c-in-literal)) + (not (eq (char-after (- (point) 2)) ?:)))) + (progn + (delete-region (point) (1- here)) + (setq is-scope-op t))) + (goto-char (- (point-max) pos))) + + ;; indent the current line if it's done syntactically. + (if c-syntactic-indentation + ;; Cannot use the same syntax analysis as we find below, + ;; since that's made with c-syntactic-indentation-in-macros + ;; always set to t. + (indent-according-to-mode)) + + ;; Calculate where, if anywhere, we want newlines. + (c-save-buffer-state + ((c-syntactic-indentation-in-macros t) + (c-auto-newline-analysis t) + ;; Turn on syntactic macro analysis to help with auto newlines + ;; only. + (syntax (c-guess-basic-syntax)) + (elem syntax)) + ;; Translate substatement-label to label for this operation. + (while elem + (if (eq (car (car elem)) 'substatement-label) + (setcar (car elem) 'label)) + (setq elem (cdr elem))) + ;; some language elements can only be determined by checking + ;; the following line. Let's first look for ones that can be + ;; found when looking on the line with the colon + (setq newlines + (and c-auto-newline + (or (c-lookup-lists '(case-label label access-label) + syntax c-hanging-colons-alist) + (c-lookup-lists '(member-init-intro inher-intro) + (progn + (insert ?\n) + (unwind-protect + (c-guess-basic-syntax) + (delete-char -1))) + c-hanging-colons-alist))))) + ;; does a newline go before the colon? Watch out for already + ;; non-hung colons. However, we don't unhang them because that + ;; would be a cleanup (and anti-social). + (if (and (memq 'before newlines) + (not is-scope-op) + (save-excursion + (skip-chars-backward ": \t") + (not (bolp)))) + (let ((pos (- (point-max) (point)))) + (forward-char -1) + (c-newline-and-indent) + (goto-char (- (point-max) pos)))) + ;; does a newline go after the colon? + (if (and (memq 'after (cdr-safe newlines)) + (not is-scope-op)) + (c-newline-and-indent)))) + (c--call-post-self-insert-hook-more-safely)))) (defun c-electric-lt-gt (arg) "Insert a \"<\" or \">\" character. @@ -1209,84 +1222,85 @@ finishes a C++ style stream operator in C++ mode. Exceptions are when a numeric argument is supplied, or the point is inside a literal." (interactive "*P") - (let ((literal (c-save-buffer-state () (c-in-literal))) - template-delim include-delim - (c-echo-syntactic-information-p nil) - final-pos found-delim case-fold-search) + (c-with-string-fences + (let ((literal (c-save-buffer-state () (c-in-literal))) + template-delim include-delim + (c-echo-syntactic-information-p nil) + final-pos found-delim case-fold-search) - (let (post-self-insert-hook) ; Disable random functionality. - (self-insert-command (prefix-numeric-value arg))) - (setq final-pos (point)) + (let (post-self-insert-hook) ; Disable random functionality. + (self-insert-command (prefix-numeric-value arg))) + (setq final-pos (point)) ;;;; 2010-01-31: There used to be code here to put a syntax-table text ;;;; property on the new < or > and its mate (if any) when they are template ;;;; parens. This is now done in an after-change function. - (when (and (not arg) (not literal)) - ;; Have we got a delimiter on a #include directive? - (beginning-of-line) - (setq include-delim - (and - (looking-at c-cpp-include-key) - (if (eq (c-last-command-char) ?<) - (eq (match-end 0) (1- final-pos)) - (goto-char (1- final-pos)) - (skip-chars-backward "^<>" (c-point 'bol)) - (eq (char-before) ?<)))) - (goto-char final-pos) - - ;; Indent the line if appropriate. - (when (and c-electric-flag c-syntactic-indentation c-recognize-<>-arglists) - (setq found-delim + (when (and (not arg) (not literal)) + ;; Have we got a delimiter on a #include directive? + (beginning-of-line) + (setq include-delim + (and + (looking-at c-cpp-include-key) (if (eq (c-last-command-char) ?<) - ;; If a <, basically see if it's got "template" before it ..... - (or (and (progn - (backward-char) - (= (point) - (progn (c-beginning-of-current-token) (point)))) - (progn - (c-backward-token-2) - (looking-at c-opt-<>-sexp-key)) - (setq template-delim t)) - ;; ..... or is a C++ << operator. - (and (c-major-mode-is 'c++-mode) - (progn - (goto-char (1- final-pos)) - (c-beginning-of-current-token) - (looking-at "<<")) - (>= (match-end 0) final-pos))) - - ;; It's a >. Either a template/generic terminator ... - (or (and (c-get-char-property (1- final-pos) 'syntax-table) - (setq template-delim t)) - ;; or a C++ >> operator. - (and (c-major-mode-is 'c++-mode) - (progn - (goto-char (1- final-pos)) - (c-beginning-of-current-token) - (looking-at ">>")) - (>= (match-end 0) final-pos))))) - (goto-char final-pos) - - (when found-delim - (indent-according-to-mode))) - - ;; On the off chance that < and > are configured as pairs in - ;; electric-pair-mode. - (when (and (boundp 'electric-pair-mode) electric-pair-mode - (or template-delim include-delim)) - (let (post-self-insert-hook) - (electric-pair-post-self-insert-function)))) - - (when found-delim - (when (and (eq (char-before) ?>) - (not executing-kbd-macro) - blink-paren-function) - ;; From now (2016-01-01), the syntax-table text properties on < and > - ;; are applied in an after-change function, not during redisplay. Hence - ;; we no longer need to call (sit-for 0) for blink paren to work. - (funcall blink-paren-function)))) - (c--call-post-self-insert-hook-more-safely)) + (eq (match-end 0) (1- final-pos)) + (goto-char (1- final-pos)) + (skip-chars-backward "^<>" (c-point 'bol)) + (eq (char-before) ?<)))) + (goto-char final-pos) + + ;; Indent the line if appropriate. + (when (and c-electric-flag c-syntactic-indentation c-recognize-<>-arglists) + (setq found-delim + (if (eq (c-last-command-char) ?<) + ;; If a <, basically see if it's got "template" before it ..... + (or (and (progn + (backward-char) + (= (point) + (progn (c-beginning-of-current-token) (point)))) + (progn + (c-backward-token-2) + (looking-at c-opt-<>-sexp-key)) + (setq template-delim t)) + ;; ..... or is a C++ << operator. + (and (c-major-mode-is 'c++-mode) + (progn + (goto-char (1- final-pos)) + (c-beginning-of-current-token) + (looking-at "<<")) + (>= (match-end 0) final-pos))) + + ;; It's a >. Either a template/generic terminator ... + (or (and (c-get-char-property (1- final-pos) 'syntax-table) + (setq template-delim t)) + ;; or a C++ >> operator. + (and (c-major-mode-is 'c++-mode) + (progn + (goto-char (1- final-pos)) + (c-beginning-of-current-token) + (looking-at ">>")) + (>= (match-end 0) final-pos))))) + (goto-char final-pos) + + (when found-delim + (indent-according-to-mode))) + + ;; On the off chance that < and > are configured as pairs in + ;; electric-pair-mode. + (when (and (boundp 'electric-pair-mode) electric-pair-mode + (or template-delim include-delim)) + (let (post-self-insert-hook) + (electric-pair-post-self-insert-function)))) + + (when found-delim + (when (and (eq (char-before) ?>) + (not executing-kbd-macro) + blink-paren-function) + ;; From now (2016-01-01), the syntax-table text properties on < and > + ;; are applied in an after-change function, not during redisplay. Hence + ;; we no longer need to call (sit-for 0) for blink paren to work. + (funcall blink-paren-function)))) + (c--call-post-self-insert-hook-more-safely))) (defun c-electric-paren (arg) "Insert a parenthesis. @@ -1301,112 +1315,113 @@ removed; see the variable `c-cleanup-list'. Also, if `c-electric-flag' and `c-auto-newline' are both non-nil, some newline cleanups are done if appropriate; see the variable `c-cleanup-list'." (interactive "*P") - (let ((literal (c-save-buffer-state () (c-in-literal))) - ;; shut this up - (c-echo-syntactic-information-p nil) - case-fold-search) - (let (post-self-insert-hook) ; The only way to get defined functionality - ; from `self-insert-command'. - (self-insert-command (prefix-numeric-value arg))) - - (if (and (not arg) (not literal)) - (let* (;; We want to inhibit blinking the paren since this will - ;; be most disruptive. We'll blink it ourselves - ;; afterwards. - (old-blink-paren blink-paren-function) - blink-paren-function) - (if (and c-syntactic-indentation c-electric-flag) - (indent-according-to-mode)) - - ;; If we're at EOL, check for new-line clean-ups. - (when (and c-electric-flag c-auto-newline - (looking-at "[ \t]*\\\\?$")) - - ;; clean up brace-elseif-brace - (when - (and (memq 'brace-elseif-brace c-cleanup-list) - (eq (c-last-command-char) ?\() - (re-search-backward - (concat "}" - "\\([ \t\n]\\|\\\\\n\\)*" - "else" - "\\([ \t\n]\\|\\\\\n\\)+" - "if" - "\\([ \t\n]\\|\\\\\n\\)*" - "(" - "\\=") - nil t) - (not (c-save-buffer-state () (c-in-literal)))) - (delete-region (match-beginning 0) (match-end 0)) - (insert-and-inherit "} else if (")) - - ;; clean up brace-catch-brace - (when - (and (memq 'brace-catch-brace c-cleanup-list) - (eq (c-last-command-char) ?\() - (re-search-backward - (concat "}" - "\\([ \t\n]\\|\\\\\n\\)*" - "catch" - "\\([ \t\n]\\|\\\\\n\\)*" - "(" - "\\=") - nil t) - (not (c-save-buffer-state () (c-in-literal)))) - (delete-region (match-beginning 0) (match-end 0)) - (insert-and-inherit "} catch ("))) - - ;; Apply `electric-pair-mode' stuff. - (when (and (boundp 'electric-pair-mode) - electric-pair-mode) - (let (post-self-insert-hook) - (electric-pair-post-self-insert-function))) - - ;; Check for clean-ups at function calls. These two DON'T need - ;; `c-electric-flag' or `c-syntactic-indentation' set. - ;; Point is currently just after the inserted paren. - (let (beg (end (1- (point)))) - (cond - - ;; space-before-funcall clean-up? - ((and (memq 'space-before-funcall c-cleanup-list) - (eq (c-last-command-char) ?\() - (save-excursion - (backward-char) - (skip-chars-backward " \t") - (setq beg (point)) - (and (c-save-buffer-state () (c-on-identifier)) - ;; Don't add a space into #define FOO().... - (not (and (c-beginning-of-macro) - (c-forward-over-cpp-define-id) - (eq (point) beg)))))) - (save-excursion - (delete-region beg end) - (goto-char beg) - (insert ?\ ))) - - ;; compact-empty-funcall clean-up? - ((c-save-buffer-state () - (and (memq 'compact-empty-funcall c-cleanup-list) - (eq (c-last-command-char) ?\)) - (save-excursion - (c-safe (backward-char 2)) - (when (looking-at "()") - (setq end (point)) - (skip-chars-backward " \t") - (setq beg (point)) - (c-on-identifier))))) - (delete-region beg end)))) - (and (eq last-input-event ?\)) - (not executing-kbd-macro) - old-blink-paren - (funcall old-blink-paren))) - - ;; Apply `electric-pair-mode' stuff inside a string or comment. - (when (and (boundp 'electric-pair-mode) electric-pair-mode) - (let (post-self-insert-hook) - (electric-pair-post-self-insert-function)))) - (c--call-post-self-insert-hook-more-safely))) + (c-with-string-fences + (let ((literal (c-save-buffer-state () (c-in-literal))) + ;; shut this up + (c-echo-syntactic-information-p nil) + case-fold-search) + (let (post-self-insert-hook) ; The only way to get defined functionality + ; from `self-insert-command'. + (self-insert-command (prefix-numeric-value arg))) + + (if (and (not arg) (not literal)) + (let* (;; We want to inhibit blinking the paren since this will + ;; be most disruptive. We'll blink it ourselves + ;; afterwards. + (old-blink-paren blink-paren-function) + blink-paren-function) + (if (and c-syntactic-indentation c-electric-flag) + (indent-according-to-mode)) + + ;; If we're at EOL, check for new-line clean-ups. + (when (and c-electric-flag c-auto-newline + (looking-at "[ \t]*\\\\?$")) + + ;; clean up brace-elseif-brace + (when + (and (memq 'brace-elseif-brace c-cleanup-list) + (eq (c-last-command-char) ?\() + (re-search-backward + (concat "}" + "\\([ \t\n]\\|\\\\\n\\)*" + "else" + "\\([ \t\n]\\|\\\\\n\\)+" + "if" + "\\([ \t\n]\\|\\\\\n\\)*" + "(" + "\\=") + nil t) + (not (c-save-buffer-state () (c-in-literal)))) + (delete-region (match-beginning 0) (match-end 0)) + (insert-and-inherit "} else if (")) + + ;; clean up brace-catch-brace + (when + (and (memq 'brace-catch-brace c-cleanup-list) + (eq (c-last-command-char) ?\() + (re-search-backward + (concat "}" + "\\([ \t\n]\\|\\\\\n\\)*" + "catch" + "\\([ \t\n]\\|\\\\\n\\)*" + "(" + "\\=") + nil t) + (not (c-save-buffer-state () (c-in-literal)))) + (delete-region (match-beginning 0) (match-end 0)) + (insert-and-inherit "} catch ("))) + + ;; Apply `electric-pair-mode' stuff. + (when (and (boundp 'electric-pair-mode) + electric-pair-mode) + (let (post-self-insert-hook) + (electric-pair-post-self-insert-function))) + + ;; Check for clean-ups at function calls. These two DON'T need + ;; `c-electric-flag' or `c-syntactic-indentation' set. + ;; Point is currently just after the inserted paren. + (let (beg (end (1- (point)))) + (cond + + ;; space-before-funcall clean-up? + ((and (memq 'space-before-funcall c-cleanup-list) + (eq (c-last-command-char) ?\() + (save-excursion + (backward-char) + (skip-chars-backward " \t") + (setq beg (point)) + (and (c-save-buffer-state () (c-on-identifier)) + ;; Don't add a space into #define FOO().... + (not (and (c-beginning-of-macro) + (c-forward-over-cpp-define-id) + (eq (point) beg)))))) + (save-excursion + (delete-region beg end) + (goto-char beg) + (insert ?\ ))) + + ;; compact-empty-funcall clean-up? + ((c-save-buffer-state () + (and (memq 'compact-empty-funcall c-cleanup-list) + (eq (c-last-command-char) ?\)) + (save-excursion + (c-safe (backward-char 2)) + (when (looking-at "()") + (setq end (point)) + (skip-chars-backward " \t") + (setq beg (point)) + (c-on-identifier))))) + (delete-region beg end)))) + (and (eq last-input-event ?\)) + (not executing-kbd-macro) + old-blink-paren + (funcall old-blink-paren))) + + ;; Apply `electric-pair-mode' stuff inside a string or comment. + (when (and (boundp 'electric-pair-mode) electric-pair-mode) + (let (post-self-insert-hook) + (electric-pair-post-self-insert-function)))) + (c--call-post-self-insert-hook-more-safely)))) (defun c-electric-continued-statement () "Reindent the current line if appropriate. @@ -1868,70 +1883,71 @@ defun." (c-region-is-active-p) (push-mark)) - (c-save-buffer-state - (beginning-of-defun-function - end-of-defun-function - (paren-state (c-parse-state)) - (orig-point-min (point-min)) (orig-point-max (point-max)) - lim ; Position of { which has been widened to. - where pos case-fold-search) - - (save-restriction - (if (eq c-defun-tactic 'go-outward) - (setq lim (c-widen-to-enclosing-decl-scope ; e.g. class, namespace. - paren-state orig-point-min orig-point-max))) - - ;; Move back out of any macro/comment/string we happen to be in. - (c-beginning-of-macro) - (setq pos (c-literal-start)) - (if pos (goto-char pos)) - - (setq where (c-where-wrt-brace-construct)) - - (if (< arg 0) - ;; Move forward to the closing brace of a function. - (progn - (if (memq where '(at-function-end outwith-function)) - (setq arg (1+ arg))) - (if (< arg 0) - (c-while-widening-to-decl-block - (< (setq arg (- (c-forward-to-nth-EOF-\;-or-} (- arg) where))) 0))) - (prog1 - ;; Move forward to the next opening brace.... - (when (and (= arg 0) - (progn - (c-while-widening-to-decl-block - (not (c-syntactic-re-search-forward "{" nil 'eob))) - (eq (char-before) ?{))) - (backward-char) - ;; ... and backward to the function header. - (c-beginning-of-decl-1) - t) - (c-keep-region-active))) - - ;; Move backward to the opening brace of a function, making successively - ;; larger portions of the buffer visible as necessary. - (when (> arg 0) - (c-while-widening-to-decl-block - (> (setq arg (c-backward-to-nth-BOF-{ arg where)) 0))) - - (when (eq arg 0) - ;; Go backward to this function's header. - (c-beginning-of-decl-1) - - (setq pos (point)) - ;; We're now there, modulo comments and whitespace. - ;; Try to be line oriented; position point at the closest - ;; preceding boi that isn't inside a comment, but if we hit - ;; the previous declaration then we use the current point - ;; instead. - (while (and (/= (point) (c-point 'boi)) - (c-backward-single-comment))) - (if (/= (point) (c-point 'boi)) - (goto-char pos))) - - (c-keep-region-active) - (= arg 0))))) + (c-with-string-fences + (c-save-buffer-state + (beginning-of-defun-function + end-of-defun-function + (paren-state (c-parse-state)) + (orig-point-min (point-min)) (orig-point-max (point-max)) + lim ; Position of { which has been widened to. + where pos case-fold-search) + + (save-restriction + (if (eq c-defun-tactic 'go-outward) + (setq lim (c-widen-to-enclosing-decl-scope ; e.g. class, namespace. + paren-state orig-point-min orig-point-max))) + + ;; Move back out of any macro/comment/string we happen to be in. + (c-beginning-of-macro) + (setq pos (c-literal-start)) + (if pos (goto-char pos)) + + (setq where (c-where-wrt-brace-construct)) + + (if (< arg 0) + ;; Move forward to the closing brace of a function. + (progn + (if (memq where '(at-function-end outwith-function)) + (setq arg (1+ arg))) + (if (< arg 0) + (c-while-widening-to-decl-block + (< (setq arg (- (c-forward-to-nth-EOF-\;-or-} (- arg) where))) 0))) + (prog1 + ;; Move forward to the next opening brace.... + (when (and (= arg 0) + (progn + (c-while-widening-to-decl-block + (not (c-syntactic-re-search-forward "{" nil 'eob))) + (eq (char-before) ?{))) + (backward-char) + ;; ... and backward to the function header. + (c-beginning-of-decl-1) + t) + (c-keep-region-active))) + + ;; Move backward to the opening brace of a function, making successively + ;; larger portions of the buffer visible as necessary. + (when (> arg 0) + (c-while-widening-to-decl-block + (> (setq arg (c-backward-to-nth-BOF-{ arg where)) 0))) + + (when (eq arg 0) + ;; Go backward to this function's header. + (c-beginning-of-decl-1) + + (setq pos (point)) + ;; We're now there, modulo comments and whitespace. + ;; Try to be line oriented; position point at the closest + ;; preceding boi that isn't inside a comment, but if we hit + ;; the previous declaration then we use the current point + ;; instead. + (while (and (/= (point) (c-point 'boi)) + (c-backward-single-comment))) + (if (/= (point) (c-point 'boi)) + (goto-char pos))) + + (c-keep-region-active) + (= arg 0)))))) (defun c-forward-to-nth-EOF-\;-or-} (n where) ;; Skip to the closing brace or semicolon of the Nth function after point. @@ -1998,65 +2014,66 @@ the open-parenthesis that starts a defun; see `beginning-of-defun'." (c-region-is-active-p) (push-mark)) - (c-save-buffer-state - (beginning-of-defun-function - end-of-defun-function - (paren-state (c-parse-state)) - (orig-point-min (point-min)) (orig-point-max (point-max)) - lim - where pos case-fold-search) - - (save-restriction - (if (eq c-defun-tactic 'go-outward) - (setq lim (c-widen-to-enclosing-decl-scope ; e.g. class, namespace - paren-state orig-point-min orig-point-max))) - - ;; Move back out of any macro/comment/string we happen to be in. - (c-beginning-of-macro) - (setq pos (c-literal-start)) - (if pos (goto-char pos)) + (c-with-string-fences + (c-save-buffer-state + (beginning-of-defun-function + end-of-defun-function + (paren-state (c-parse-state)) + (orig-point-min (point-min)) (orig-point-max (point-max)) + lim + where pos case-fold-search) + + (save-restriction + (if (eq c-defun-tactic 'go-outward) + (setq lim (c-widen-to-enclosing-decl-scope ; e.g. class, namespace + paren-state orig-point-min orig-point-max))) + + ;; Move back out of any macro/comment/string we happen to be in. + (c-beginning-of-macro) + (setq pos (c-literal-start)) + (if pos (goto-char pos)) + + (setq where (c-where-wrt-brace-construct)) + + (if (< arg 0) + ;; Move backwards to the } of a function + (progn + (if (memq where '(at-header outwith-function)) + (setq arg (1+ arg))) + (if (< arg 0) + (c-while-widening-to-decl-block + (< (setq arg (- (c-backward-to-nth-BOF-{ (- arg) where))) 0))) + (if (= arg 0) + (c-while-widening-to-decl-block + (progn (c-syntactic-skip-backward "^}") + (not (eq (char-before) ?})))))) + + ;; Move forward to the } of a function + (if (> arg 0) + (c-while-widening-to-decl-block + (> (setq arg (c-forward-to-nth-EOF-\;-or-} arg where)) 0)))) + + ;; Do we need to move forward from the brace to the semicolon? + (when (eq arg 0) + (if (c-in-function-trailer-p) ; after "}" of struct/enum, etc. + (c-syntactic-re-search-forward ";")) - (setq where (c-where-wrt-brace-construct)) + (setq pos (point)) + ;; We're there now, modulo comments and whitespace. + ;; Try to be line oriented; position point after the next + ;; newline that isn't inside a comment, but if we hit the + ;; next declaration then we use the current point instead. + (while (and (not (bolp)) + (not (looking-at "\\s *$")) + (c-forward-single-comment))) + (cond ((bolp)) + ((looking-at "\\s *$") + (forward-line 1)) + (t + (goto-char pos)))) - (if (< arg 0) - ;; Move backwards to the } of a function - (progn - (if (memq where '(at-header outwith-function)) - (setq arg (1+ arg))) - (if (< arg 0) - (c-while-widening-to-decl-block - (< (setq arg (- (c-backward-to-nth-BOF-{ (- arg) where))) 0))) - (if (= arg 0) - (c-while-widening-to-decl-block - (progn (c-syntactic-skip-backward "^}") - (not (eq (char-before) ?})))))) - - ;; Move forward to the } of a function - (if (> arg 0) - (c-while-widening-to-decl-block - (> (setq arg (c-forward-to-nth-EOF-\;-or-} arg where)) 0)))) - - ;; Do we need to move forward from the brace to the semicolon? - (when (eq arg 0) - (if (c-in-function-trailer-p) ; after "}" of struct/enum, etc. - (c-syntactic-re-search-forward ";")) - - (setq pos (point)) - ;; We're there now, modulo comments and whitespace. - ;; Try to be line oriented; position point after the next - ;; newline that isn't inside a comment, but if we hit the - ;; next declaration then we use the current point instead. - (while (and (not (bolp)) - (not (looking-at "\\s *$")) - (c-forward-single-comment))) - (cond ((bolp)) - ((looking-at "\\s *$") - (forward-line 1)) - (t - (goto-char pos)))) - - (c-keep-region-active) - (= arg 0)))) + (c-keep-region-active) + (= arg 0))))) (defun c-defun-name-1 () "Return name of current defun, at current narrowing, or nil if there isn't one. @@ -2342,18 +2359,19 @@ with a brace block, at the outermost level of nesting." "Display the name of the current CC mode defun and the position in it. With a prefix arg, push the name onto the kill ring too." (interactive "P") - (save-restriction - (widen) - (c-save-buffer-state ((name-and-limits (c-defun-name-and-limits nil)) - (name (car name-and-limits)) - (limits (cdr name-and-limits)) - (point-bol (c-point 'bol))) - (when name - (message "%s. Line %s/%s." name - (1+ (count-lines (car limits) (max point-bol (car limits)))) - (count-lines (car limits) (cdr limits))) - (if arg (kill-new name)) - (sit-for 3 t))))) + (c-with-string-fences + (save-restriction + (widen) + (c-save-buffer-state ((name-and-limits (c-defun-name-and-limits nil)) + (name (car name-and-limits)) + (limits (cdr name-and-limits)) + (point-bol (c-point 'bol))) + (when name + (message "%s. Line %s/%s." name + (1+ (count-lines (car limits) (max point-bol (car limits)))) + (count-lines (car limits) (cdr limits))) + (if arg (kill-new name)) + (sit-for 3 t)))))) (put 'c-display-defun-name 'isearch-scroll t) (defun c-mark-function () @@ -2369,34 +2387,35 @@ As opposed to \\[c-beginning-of-defun] and \\[c-end-of-defun], this function does not require the declaration to contain a brace block." (interactive) - (let (decl-limits case-fold-search) - (c-save-buffer-state nil - ;; We try to be line oriented, unless there are several - ;; declarations on the same line. - (if (looking-at c-syntactic-eol) - (c-backward-token-2 1 nil (c-point 'bol))) - (setq decl-limits (c-declaration-limits t))) - - (if (not decl-limits) - (error "Cannot find any declaration") - (let* ((extend-region-p - (and (eq this-command 'c-mark-function) - (eq last-command 'c-mark-function))) - (push-mark-p (and (eq this-command 'c-mark-function) - (not extend-region-p) - (not (c-region-is-active-p))))) - (if push-mark-p (push-mark)) - (if extend-region-p - (progn - (exchange-point-and-mark) - (setq decl-limits (c-declaration-limits t)) - (when (not decl-limits) - (exchange-point-and-mark) - (error "Cannot find any declaration")) - (goto-char (cdr decl-limits)) - (exchange-point-and-mark)) - (goto-char (car decl-limits)) - (push-mark (cdr decl-limits) nil t)))))) + (c-with-string-fences + (let (decl-limits case-fold-search) + (c-save-buffer-state nil + ;; We try to be line oriented, unless there are several + ;; declarations on the same line. + (if (looking-at c-syntactic-eol) + (c-backward-token-2 1 nil (c-point 'bol))) + (setq decl-limits (c-declaration-limits t))) + + (if (not decl-limits) + (error "Cannot find any declaration") + (let* ((extend-region-p + (and (eq this-command 'c-mark-function) + (eq last-command 'c-mark-function))) + (push-mark-p (and (eq this-command 'c-mark-function) + (not extend-region-p) + (not (c-region-is-active-p))))) + (if push-mark-p (push-mark)) + (if extend-region-p + (progn + (exchange-point-and-mark) + (setq decl-limits (c-declaration-limits t)) + (when (not decl-limits) + (exchange-point-and-mark) + (error "Cannot find any declaration")) + (goto-char (cdr decl-limits)) + (exchange-point-and-mark)) + (goto-char (car decl-limits)) + (push-mark (cdr decl-limits) nil t))))))) (defun c-cpp-define-name () "Return the name of the current CPP macro, or NIL if we're not in one." @@ -3033,85 +3052,86 @@ be more \"DWIM:ey\"." nil t)) (if (< count 0) (c-end-of-statement (- count) lim sentence-flag) - (c-save-buffer-state - ((count (or count 1)) - last ; start point for going back ONE chunk. Updated each chunk movement. - (macro-fence - (save-excursion (and (not (bobp)) (c-beginning-of-macro) (point)))) - res ; result from sub-function call - not-bos ; "not beginning-of-statement" - (range (c-collect-line-comments (c-literal-limits lim)))) ; (start.end) of current literal or NIL - - ;; Go back one statement at each iteration of the following loop. - (while (and (/= count 0) - (or (not lim) (> (point) lim))) - ;; Go back one "chunk" each time round the following loop, stopping - ;; when we reach a statement boundary, etc. - (setq last (point)) - (while - (cond ; Each arm of this cond returns NIL on reaching a desired - ; statement boundary, non-NIL otherwise. - ((bobp) - (setq count 0) - nil) - - (range ; point is within or approaching a literal. - (cond - ;; Single line string or sentence-flag is null => skip the - ;; entire literal. - ((or (null sentence-flag) - (c-one-line-string-p range)) - (goto-char (car range)) - (setq range (c-ascertain-preceding-literal)) - ;; N.B. The following is essentially testing for an AWK regexp - ;; at BOS: - ;; Was the previous non-ws thing an end of statement? - (save-excursion - (if macro-fence - (c-backward-comments) - (c-backward-syntactic-ws)) - (not (or (bobp) (c-after-statement-terminator-p))))) - - ;; Comment inside a statement or a multi-line string. - (t (when (setq res ; returns non-nil when we go out of the literal - (if (eq (c-literal-type range) 'string) - (c-beginning-of-sentence-in-string range) - (c-beginning-of-sentence-in-comment range))) - (setq range (c-ascertain-preceding-literal))) - res))) - - ;; Non-literal code. - (t (setq res (c-back-over-illiterals macro-fence)) - (setq not-bos ; "not reached beginning-of-statement". - (or (= (point) last) - (memq (char-after) '(?\) ?\})) - (and - (car res) - ;; We're at a tentative BOS. The next form goes - ;; back over WS looking for an end of previous - ;; statement. - (not (save-excursion - (if macro-fence - (c-backward-comments) - (c-backward-syntactic-ws)) - (or (bobp) (c-after-statement-terminator-p))))))) - ;; Are we about to move backwards into or out of a - ;; preprocessor command? If so, locate its beginning. - (when (eq (cdr res) 'macro-boundary) - (save-excursion - (beginning-of-line) - (setq macro-fence - (and (not (bobp)) - (progn (c-skip-ws-backward) (c-beginning-of-macro)) - (point))))) - ;; Are we about to move backwards into a literal? - (when (memq (cdr res) '(macro-boundary literal)) - (setq range (c-ascertain-preceding-literal))) - not-bos)) - (setq last (point))) - - (if (/= count 0) (setq count (1- count)))) - (c-keep-region-active)))) + (c-with-string-fences + (c-save-buffer-state + ((count (or count 1)) + last ; start point for going back ONE chunk. Updated each chunk movement. + (macro-fence + (save-excursion (and (not (bobp)) (c-beginning-of-macro) (point)))) + res ; result from sub-function call + not-bos ; "not beginning-of-statement" + (range (c-collect-line-comments (c-literal-limits lim)))) ; (start.end) of current literal or NIL + + ;; Go back one statement at each iteration of the following loop. + (while (and (/= count 0) + (or (not lim) (> (point) lim))) + ;; Go back one "chunk" each time round the following loop, stopping + ;; when we reach a statement boundary, etc. + (setq last (point)) + (while + (cond ; Each arm of this cond returns NIL on reaching a desired + ; statement boundary, non-NIL otherwise. + ((bobp) + (setq count 0) + nil) + + (range ; point is within or approaching a literal. + (cond + ;; Single line string or sentence-flag is null => skip the + ;; entire literal. + ((or (null sentence-flag) + (c-one-line-string-p range)) + (goto-char (car range)) + (setq range (c-ascertain-preceding-literal)) + ;; N.B. The following is essentially testing for an AWK regexp + ;; at BOS: + ;; Was the previous non-ws thing an end of statement? + (save-excursion + (if macro-fence + (c-backward-comments) + (c-backward-syntactic-ws)) + (not (or (bobp) (c-after-statement-terminator-p))))) + + ;; Comment inside a statement or a multi-line string. + (t (when (setq res ; returns non-nil when we go out of the literal + (if (eq (c-literal-type range) 'string) + (c-beginning-of-sentence-in-string range) + (c-beginning-of-sentence-in-comment range))) + (setq range (c-ascertain-preceding-literal))) + res))) + + ;; Non-literal code. + (t (setq res (c-back-over-illiterals macro-fence)) + (setq not-bos ; "not reached beginning-of-statement". + (or (= (point) last) + (memq (char-after) '(?\) ?\})) + (and + (car res) + ;; We're at a tentative BOS. The next form goes + ;; back over WS looking for an end of previous + ;; statement. + (not (save-excursion + (if macro-fence + (c-backward-comments) + (c-backward-syntactic-ws)) + (or (bobp) (c-after-statement-terminator-p))))))) + ;; Are we about to move backwards into or out of a + ;; preprocessor command? If so, locate its beginning. + (when (eq (cdr res) 'macro-boundary) + (save-excursion + (beginning-of-line) + (setq macro-fence + (and (not (bobp)) + (progn (c-skip-ws-backward) (c-beginning-of-macro)) + (point))))) + ;; Are we about to move backwards into a literal? + (when (memq (cdr res) '(macro-boundary literal)) + (setq range (c-ascertain-preceding-literal))) + not-bos)) + (setq last (point))) + + (if (/= count 0) (setq count (1- count)))) + (c-keep-region-active))))) (defun c-end-of-statement (&optional count lim sentence-flag) "Go to the end of the innermost C statement. @@ -3129,78 +3149,79 @@ sentence motion in or near comments and multiline strings." (setq count (or count 1)) (if (< count 0) (c-beginning-of-statement (- count) lim sentence-flag) - (c-save-buffer-state - (here ; start point for going forward ONE statement. Updated each statement. - (macro-fence - (save-excursion - (and (not (eobp)) (c-beginning-of-macro) - (progn (c-end-of-macro) (point))))) - res - (range (c-collect-line-comments (c-literal-limits lim)))) ; (start.end) of current literal or NIL - - ;; Go back/forward one statement at each iteration of the following loop. - (while (and (/= count 0) - (or (not lim) (< (point) lim))) - (setq here (point)) ; ONLY HERE is HERE updated - - ;; Go forward one "chunk" each time round the following loop, stopping - ;; when we reach a statement boundary, etc. - (while - (cond ; Each arm of this cond returns NIL on reaching a desired - ; statement boundary, non-NIL otherwise. - ((eobp) - (setq count 0) - nil) + (c-with-string-fences + (c-save-buffer-state + (here ; start point for going forward ONE statement. Updated each statement. + (macro-fence + (save-excursion + (and (not (eobp)) (c-beginning-of-macro) + (progn (c-end-of-macro) (point))))) + res + (range (c-collect-line-comments (c-literal-limits lim)))) ; (start.end) of current literal or NIL + + ;; Go back/forward one statement at each iteration of the following loop. + (while (and (/= count 0) + (or (not lim) (< (point) lim))) + (setq here (point)) ; ONLY HERE is HERE updated + + ;; Go forward one "chunk" each time round the following loop, stopping + ;; when we reach a statement boundary, etc. + (while + (cond ; Each arm of this cond returns NIL on reaching a desired + ; statement boundary, non-NIL otherwise. + ((eobp) + (setq count 0) + nil) + + (range ; point is within a literal. + (cond + ;; sentence-flag is null => skip the entire literal. + ;; or a Single line string. + ((or (null sentence-flag) + (c-one-line-string-p range)) + (goto-char (cdr range)) + (setq range (c-ascertain-following-literal)) + ;; Is there a virtual semicolon here (e.g. for AWK)? + (not (c-at-vsemi-p))) + + ;; Comment or multi-line string. + (t (when (setq res ; gets non-nil when we go out of the literal + (if (eq (c-literal-type range) 'string) + (c-end-of-sentence-in-string range) + (c-end-of-sentence-in-comment range))) + (setq range (c-ascertain-following-literal))) + ;; If we've just come forward out of a literal, check for + ;; vsemi. (N.B. AWK can't have a vsemi after a comment, but + ;; some other language may do in the future) + (and res + (not (c-at-vsemi-p)))))) + + ;; Non-literal code. + (t (setq res (c-forward-over-illiterals macro-fence + (> (point) here))) + ;; Are we about to move forward into or out of a + ;; preprocessor command? + (when (eq (cdr res) 'macro-boundary) + (setq macro-fence + (save-excursion + (if macro-fence + (progn + (end-of-line) + (and (not (eobp)) + (progn (c-skip-ws-forward) + (c-beginning-of-macro)) + (progn (c-end-of-macro) + (point)))) + (and (not (eobp)) + (c-beginning-of-macro) + (progn (c-end-of-macro) (point))))))) + ;; Are we about to move forward into a literal? + (when (memq (cdr res) '(macro-boundary literal)) + (setq range (c-ascertain-following-literal))) + (car res)))) - (range ; point is within a literal. - (cond - ;; sentence-flag is null => skip the entire literal. - ;; or a Single line string. - ((or (null sentence-flag) - (c-one-line-string-p range)) - (goto-char (cdr range)) - (setq range (c-ascertain-following-literal)) - ;; Is there a virtual semicolon here (e.g. for AWK)? - (not (c-at-vsemi-p))) - - ;; Comment or multi-line string. - (t (when (setq res ; gets non-nil when we go out of the literal - (if (eq (c-literal-type range) 'string) - (c-end-of-sentence-in-string range) - (c-end-of-sentence-in-comment range))) - (setq range (c-ascertain-following-literal))) - ;; If we've just come forward out of a literal, check for - ;; vsemi. (N.B. AWK can't have a vsemi after a comment, but - ;; some other language may do in the future) - (and res - (not (c-at-vsemi-p)))))) - - ;; Non-literal code. - (t (setq res (c-forward-over-illiterals macro-fence - (> (point) here))) - ;; Are we about to move forward into or out of a - ;; preprocessor command? - (when (eq (cdr res) 'macro-boundary) - (setq macro-fence - (save-excursion - (if macro-fence - (progn - (end-of-line) - (and (not (eobp)) - (progn (c-skip-ws-forward) - (c-beginning-of-macro)) - (progn (c-end-of-macro) - (point)))) - (and (not (eobp)) - (c-beginning-of-macro) - (progn (c-end-of-macro) (point))))))) - ;; Are we about to move forward into a literal? - (when (memq (cdr res) '(macro-boundary literal)) - (setq range (c-ascertain-following-literal))) - (car res)))) - - (if (/= count 0) (setq count (1- count)))) - (c-keep-region-active)))) + (if (/= count 0) (setq count (1- count)))) + (c-keep-region-active))))) ;; set up electric character functions to work with pending-del, @@ -3539,122 +3560,125 @@ prefix argument is equivalent to -1. depending on the variable `indent-tabs-mode'." (interactive "P") - (let ((indent-function - (if c-syntactic-indentation - (symbol-function 'indent-according-to-mode) - (lambda () - (let ((c-macro-start c-macro-start) - (steps (if (equal arg '(4)) - -1 - (prefix-numeric-value arg)))) - (c-shift-line-indentation (* steps c-basic-offset)) - (when (and c-auto-align-backslashes - (save-excursion - (end-of-line) - (eq (char-before) ?\\)) - (c-query-and-set-macro-start)) - ;; Realign the line continuation backslash if inside a macro. - (c-backslash-region (point) (point) nil t))) - )))) - (if (and c-syntactic-indentation arg) - ;; If c-syntactic-indentation and got arg, always indent this - ;; line as C and shift remaining lines of expression the same - ;; amount. - (let ((shift-amt (save-excursion - (back-to-indentation) - (current-column))) - beg end) - (c-indent-line) - (setq shift-amt (- (save-excursion - (back-to-indentation) - (current-column)) - shift-amt)) - (save-excursion - (if (eq c-tab-always-indent t) - (beginning-of-line)) ; FIXME!!! What is this here for? ACM 2005/10/31 - (setq beg (point)) - (c-forward-sexp 1) - (setq end (point)) - (goto-char beg) - (forward-line 1) - (setq beg (point))) - (if (> end beg) - (indent-code-rigidly beg end shift-amt "#"))) - ;; Else use c-tab-always-indent to determine behavior. - (cond - ;; CASE 1: indent when at column zero or in line's indentation, - ;; otherwise insert a tab - ((not c-tab-always-indent) - (if (save-excursion - (skip-chars-backward " \t") - (not (bolp))) - (funcall c-insert-tab-function) - (funcall indent-function))) - ;; CASE 2: just indent the line - ((eq c-tab-always-indent t) - (funcall indent-function)) - ;; CASE 3: if in a literal, insert a tab, but always indent the - ;; line - (t - (if (c-save-buffer-state () (c-in-literal)) - (funcall c-insert-tab-function)) - (funcall indent-function) - ))))) + (c-with-string-fences + (let ((indent-function + (if c-syntactic-indentation + (symbol-function 'indent-according-to-mode) + (lambda () + (let ((c-macro-start c-macro-start) + (steps (if (equal arg '(4)) + -1 + (prefix-numeric-value arg)))) + (c-shift-line-indentation (* steps c-basic-offset)) + (when (and c-auto-align-backslashes + (save-excursion + (end-of-line) + (eq (char-before) ?\\)) + (c-query-and-set-macro-start)) + ;; Realign the line continuation backslash if inside a macro. + (c-backslash-region (point) (point) nil t))) + )))) + (if (and c-syntactic-indentation arg) + ;; If c-syntactic-indentation and got arg, always indent this + ;; line as C and shift remaining lines of expression the same + ;; amount. + (let ((shift-amt (save-excursion + (back-to-indentation) + (current-column))) + beg end) + (c-indent-line) + (setq shift-amt (- (save-excursion + (back-to-indentation) + (current-column)) + shift-amt)) + (save-excursion + (if (eq c-tab-always-indent t) + (beginning-of-line)) ; FIXME!!! What is this here for? ACM 2005/10/31 + (setq beg (point)) + (c-forward-sexp 1) + (setq end (point)) + (goto-char beg) + (forward-line 1) + (setq beg (point))) + (if (> end beg) + (indent-code-rigidly beg end shift-amt "#"))) + ;; Else use c-tab-always-indent to determine behavior. + (cond + ;; CASE 1: indent when at column zero or in line's indentation, + ;; otherwise insert a tab + ((not c-tab-always-indent) + (if (save-excursion + (skip-chars-backward " \t") + (not (bolp))) + (funcall c-insert-tab-function) + (funcall indent-function))) + ;; CASE 2: just indent the line + ((eq c-tab-always-indent t) + (funcall indent-function)) + ;; CASE 3: if in a literal, insert a tab, but always indent the + ;; line + (t + (if (c-save-buffer-state () (c-in-literal)) + (funcall c-insert-tab-function)) + (funcall indent-function) + )))))) (defun c-indent-exp (&optional shutup-p) "Indent each line in the balanced expression following point syntactically. If optional SHUTUP-P is non-nil, no errors are signaled if no balanced expression is found." (interactive "*P") - (let ((here (point-marker)) - end) - (set-marker-insertion-type here t) - (unwind-protect - (let ((start (save-restriction - ;; Find the closest following open paren that - ;; ends on another line. - (narrow-to-region (point-min) (c-point 'eol)) - (let (beg (end (point))) - (while (and (setq beg (c-down-list-forward end)) - (setq end (c-up-list-forward beg)))) - (and beg - (eq (char-syntax (char-before beg)) ?\() - (1- beg)))))) - ;; sanity check - (if (not start) - (unless shutup-p - (error "Cannot find start of balanced expression to indent")) - (goto-char start) - (setq end (c-safe (scan-sexps (point) 1))) - (if (not end) - (unless shutup-p - (error "Cannot find end of balanced expression to indent")) - (forward-line) - (if (< (point) end) - (c-indent-region (point) end))))) - (goto-char here) - (set-marker here nil)))) + (c-with-string-fences + (let ((here (point-marker)) + end) + (set-marker-insertion-type here t) + (unwind-protect + (let ((start (save-restriction + ;; Find the closest following open paren that + ;; ends on another line. + (narrow-to-region (point-min) (c-point 'eol)) + (let (beg (end (point))) + (while (and (setq beg (c-down-list-forward end)) + (setq end (c-up-list-forward beg)))) + (and beg + (eq (char-syntax (char-before beg)) ?\() + (1- beg)))))) + ;; sanity check + (if (not start) + (unless shutup-p + (error "Cannot find start of balanced expression to indent")) + (goto-char start) + (setq end (c-safe (scan-sexps (point) 1))) + (if (not end) + (unless shutup-p + (error "Cannot find end of balanced expression to indent")) + (forward-line) + (if (< (point) end) + (c-indent-region (point) end))))) + (goto-char here) + (set-marker here nil))))) (defun c-indent-defun () "Indent the current top-level declaration or macro syntactically. In the macro case this also has the effect of realigning any line continuation backslashes, unless `c-auto-align-backslashes' is nil." (interactive "*") - (let ((here (point-marker)) decl-limits case-fold-search) - (unwind-protect - (progn - (c-save-buffer-state nil - ;; We try to be line oriented, unless there are several - ;; declarations on the same line. - (if (looking-at c-syntactic-eol) - (c-backward-token-2 1 nil (c-point 'bol)) - (c-forward-token-2 0 nil (c-point 'eol))) - (setq decl-limits (c-declaration-limits nil))) - (if decl-limits - (c-indent-region (car decl-limits) - (cdr decl-limits)))) - (goto-char here) - (set-marker here nil)))) + (c-with-string-fences + (let ((here (point-marker)) decl-limits case-fold-search) + (unwind-protect + (progn + (c-save-buffer-state nil + ;; We try to be line oriented, unless there are several + ;; declarations on the same line. + (if (looking-at c-syntactic-eol) + (c-backward-token-2 1 nil (c-point 'bol)) + (c-forward-token-2 0 nil (c-point 'eol))) + (setq decl-limits (c-declaration-limits nil))) + (if decl-limits + (c-indent-region (car decl-limits) + (cdr decl-limits)))) + (goto-char here) + (set-marker here nil))))) (defun c-indent-region (start end &optional quiet) "Indent syntactically lines whose first char is between START and END inclusive. @@ -3734,9 +3758,10 @@ starting on the current line. Otherwise reindent just the current line." (interactive (list current-prefix-arg (c-region-is-active-p))) - (if region - (c-indent-region (region-beginning) (region-end)) - (c-indent-command arg))) + (c-with-string-fences + (if region + (c-indent-region (region-beginning) (region-end)) + (c-indent-command arg)))) ;; for progress reporting (defvar c-progress-info nil) @@ -4823,15 +4848,16 @@ If point is in any other situation, i.e. in normal code, do nothing. Optional prefix ARG means justify paragraph as well." (interactive "*P") - (let ((fill-paragraph-function - ;; Avoid infinite recursion. - (if (not (eq fill-paragraph-function 'c-fill-paragraph)) - fill-paragraph-function))) - (c-mask-paragraph t nil 'fill-paragraph arg)) - ;; Always return t. This has the effect that if filling isn't done - ;; above, it isn't done at all, and it's therefore effectively - ;; disabled in normal code. - t) + (c-with-string-fences + (let ((fill-paragraph-function + ;; Avoid infinite recursion. + (if (not (eq fill-paragraph-function 'c-fill-paragraph)) + fill-paragraph-function))) + (c-mask-paragraph t nil 'fill-paragraph arg)) + ;; Always return t. This has the effect that if filling isn't done + ;; above, it isn't done at all, and it's therefore effectively + ;; disabled in normal code. + t)) (defun c-do-auto-fill () ;; Do automatic filling if not inside a context where it should be @@ -4863,165 +4889,166 @@ If a fill prefix is specified, it overrides all the above." ;; used from auto-fill itself, that's normally disabled to avoid ;; unnecessary recursion. (interactive) - (let ((fill-prefix fill-prefix) - (do-line-break - (lambda () - (delete-horizontal-space) - (if soft - (insert-and-inherit ?\n) - (newline (if allow-auto-fill nil 1))))) - ;; Already know the literal type and limits when called from - ;; c-context-line-break. - (c-lit-limits c-lit-limits) - (c-lit-type c-lit-type) - (c-macro-start c-macro-start)) - - (c-save-buffer-state () - (when (not (eq c-auto-fill-prefix t)) - ;; Called from do-auto-fill. - (unless c-lit-limits - (setq c-lit-limits (c-literal-limits nil nil t))) - (unless c-lit-type - (setq c-lit-type (c-literal-type c-lit-limits))) - (if (memq (cond ((c-query-and-set-macro-start) 'cpp) - ((null c-lit-type) 'code) - (t c-lit-type)) - c-ignore-auto-fill) - (setq fill-prefix t) ; Used as flag in the cond. - (if (and (null c-auto-fill-prefix) - (eq c-lit-type 'c) - (<= (c-point 'bol) (car c-lit-limits))) - ;; The adaptive fill function has generated a prefix, but - ;; we're on the first line in a block comment so it'll be - ;; wrong. Ignore it to guess a better one below. - (setq fill-prefix nil) - (when (and (eq c-lit-type 'c++) - (not (string-match (concat "\\`[ \t]*" - c-line-comment-starter) - (or fill-prefix "")))) - ;; Kludge: If the function that adapted the fill prefix - ;; doesn't produce the required comment starter for line - ;; comments, then we ignore it. - (setq fill-prefix nil))) - ))) - - (cond ((eq fill-prefix t) - ;; A call from do-auto-fill which should be ignored. - ) - (fill-prefix - ;; A fill-prefix overrides anything. - (funcall do-line-break) - (insert-and-inherit fill-prefix)) - ((c-save-buffer-state () - (unless c-lit-limits - (setq c-lit-limits (c-literal-limits))) - (unless c-lit-type - (setq c-lit-type (c-literal-type c-lit-limits))) - (memq c-lit-type '(c c++))) - ;; Some sort of comment. - (if (or comment-multi-line - (save-excursion - (goto-char (car c-lit-limits)) - (end-of-line) - (< (point) (cdr c-lit-limits)))) - ;; Inside a comment that should be continued. - (let ((fill (c-save-buffer-state nil - (c-guess-fill-prefix - (setq c-lit-limits - (c-collect-line-comments c-lit-limits)) - c-lit-type))) - (pos (point)) - (comment-text-end - (or (and (eq c-lit-type 'c) - (save-excursion - (goto-char (- (cdr c-lit-limits) 2)) - (if (looking-at "\\*/") (point)))) - (cdr c-lit-limits)))) - ;; Skip forward past the fill prefix in case - ;; we're standing in it. - ;; - ;; FIXME: This doesn't work well in cases like - ;; - ;; /* Bla bla bla bla bla - ;; bla bla - ;; - ;; If point is on the 'B' then the line will be - ;; broken after "Bla b". - ;; - ;; If we have an empty comment, /* */, the next - ;; lot of code pushes point to the */. We fix - ;; this by never allowing point to end up to the - ;; right of where it started. - (while (and (< (current-column) (cdr fill)) - (not (eolp))) - (forward-char 1)) - (if (and (> (point) comment-text-end) - (> (c-point 'bol) (car c-lit-limits))) - (progn - ;; The skip takes us out of the (block) - ;; comment; insert the fill prefix at bol - ;; instead and keep the position. - (setq pos (copy-marker pos t)) - (beginning-of-line) - (insert-and-inherit (car fill)) - (if soft (insert-and-inherit ?\n) (newline 1)) - (goto-char pos) - (set-marker pos nil)) - ;; Don't break in the middle of a comment starter - ;; or ender. - (cond ((> (point) comment-text-end) - (goto-char comment-text-end)) - ((< (point) (+ (car c-lit-limits) 2)) - (goto-char (+ (car c-lit-limits) 2)))) - (funcall do-line-break) - (insert-and-inherit (car fill)) - (if (and (looking-at c-block-comment-ender-regexp) - (memq (char-before) '(?\ ?\t))) - (backward-char)))) ; can this hit the - ; middle of a TAB? - ;; Inside a comment that should be broken. - (let ((comment-start comment-start) - (comment-end comment-end) - col) - (if (eq c-lit-type 'c) - (unless (string-match "[ \t]*/\\*" comment-start) - (setq comment-start "/* " comment-end " */")) - (unless (string-match "[ \t]*//" comment-start) - (setq comment-start "// " comment-end ""))) - (setq col (save-excursion - (back-to-indentation) - (current-column))) - (funcall do-line-break) - (when (and comment-end (not (equal comment-end ""))) - (forward-char -1) - (insert-and-inherit comment-end) - (forward-char 1)) - ;; c-comment-indent may look at the current - ;; indentation, so let's start out with the same - ;; indentation as the previous one. - (indent-to col) - (insert-and-inherit comment-start) - (indent-for-comment)))) - ((c-query-and-set-macro-start) - ;; In a macro. - (unless (looking-at "[ \t]*\\\\$") - ;; Do not clobber the alignment of the line continuation - ;; slash; c-backslash-region might look at it. - (delete-horizontal-space)) - ;; Got an asymmetry here: In normal code this command - ;; doesn't indent the next line syntactically, and otoh a - ;; normal syntactically indenting newline doesn't continue - ;; the macro. - (c-newline-and-indent (if allow-auto-fill nil 1))) - (t - ;; Somewhere else in the code. - (let ((col (save-excursion + (c-with-string-fences + (let ((fill-prefix fill-prefix) + (do-line-break + (lambda () + (delete-horizontal-space) + (if soft + (insert-and-inherit ?\n) + (newline (if allow-auto-fill nil 1))))) + ;; Already know the literal type and limits when called from + ;; c-context-line-break. + (c-lit-limits c-lit-limits) + (c-lit-type c-lit-type) + (c-macro-start c-macro-start)) + + (c-save-buffer-state () + (when (not (eq c-auto-fill-prefix t)) + ;; Called from do-auto-fill. + (unless c-lit-limits + (setq c-lit-limits (c-literal-limits nil nil t))) + (unless c-lit-type + (setq c-lit-type (c-literal-type c-lit-limits))) + (if (memq (cond ((c-query-and-set-macro-start) 'cpp) + ((null c-lit-type) 'code) + (t c-lit-type)) + c-ignore-auto-fill) + (setq fill-prefix t) ; Used as flag in the cond. + (if (and (null c-auto-fill-prefix) + (eq c-lit-type 'c) + (<= (c-point 'bol) (car c-lit-limits))) + ;; The adaptive fill function has generated a prefix, but + ;; we're on the first line in a block comment so it'll be + ;; wrong. Ignore it to guess a better one below. + (setq fill-prefix nil) + (when (and (eq c-lit-type 'c++) + (not (string-match (concat "\\`[ \t]*" + c-line-comment-starter) + (or fill-prefix "")))) + ;; Kludge: If the function that adapted the fill prefix + ;; doesn't produce the required comment starter for line + ;; comments, then we ignore it. + (setq fill-prefix nil))) + ))) + + (cond ((eq fill-prefix t) + ;; A call from do-auto-fill which should be ignored. + ) + (fill-prefix + ;; A fill-prefix overrides anything. + (funcall do-line-break) + (insert-and-inherit fill-prefix)) + ((c-save-buffer-state () + (unless c-lit-limits + (setq c-lit-limits (c-literal-limits))) + (unless c-lit-type + (setq c-lit-type (c-literal-type c-lit-limits))) + (memq c-lit-type '(c c++))) + ;; Some sort of comment. + (if (or comment-multi-line + (save-excursion + (goto-char (car c-lit-limits)) + (end-of-line) + (< (point) (cdr c-lit-limits)))) + ;; Inside a comment that should be continued. + (let ((fill (c-save-buffer-state nil + (c-guess-fill-prefix + (setq c-lit-limits + (c-collect-line-comments c-lit-limits)) + c-lit-type))) + (pos (point)) + (comment-text-end + (or (and (eq c-lit-type 'c) + (save-excursion + (goto-char (- (cdr c-lit-limits) 2)) + (if (looking-at "\\*/") (point)))) + (cdr c-lit-limits)))) + ;; Skip forward past the fill prefix in case + ;; we're standing in it. + ;; + ;; FIXME: This doesn't work well in cases like + ;; + ;; /* Bla bla bla bla bla + ;; bla bla + ;; + ;; If point is on the 'B' then the line will be + ;; broken after "Bla b". + ;; + ;; If we have an empty comment, /* */, the next + ;; lot of code pushes point to the */. We fix + ;; this by never allowing point to end up to the + ;; right of where it started. + (while (and (< (current-column) (cdr fill)) + (not (eolp))) + (forward-char 1)) + (if (and (> (point) comment-text-end) + (> (c-point 'bol) (car c-lit-limits))) + (progn + ;; The skip takes us out of the (block) + ;; comment; insert the fill prefix at bol + ;; instead and keep the position. + (setq pos (copy-marker pos t)) (beginning-of-line) - (while (and (looking-at "[ \t]*\\\\?$") - (= (forward-line -1) 0))) - (current-indentation)))) - (funcall do-line-break) - (indent-to col)))))) + (insert-and-inherit (car fill)) + (if soft (insert-and-inherit ?\n) (newline 1)) + (goto-char pos) + (set-marker pos nil)) + ;; Don't break in the middle of a comment starter + ;; or ender. + (cond ((> (point) comment-text-end) + (goto-char comment-text-end)) + ((< (point) (+ (car c-lit-limits) 2)) + (goto-char (+ (car c-lit-limits) 2)))) + (funcall do-line-break) + (insert-and-inherit (car fill)) + (if (and (looking-at c-block-comment-ender-regexp) + (memq (char-before) '(?\ ?\t))) + (backward-char)))) ; can this hit the + ; middle of a TAB? + ;; Inside a comment that should be broken. + (let ((comment-start comment-start) + (comment-end comment-end) + col) + (if (eq c-lit-type 'c) + (unless (string-match "[ \t]*/\\*" comment-start) + (setq comment-start "/* " comment-end " */")) + (unless (string-match "[ \t]*//" comment-start) + (setq comment-start "// " comment-end ""))) + (setq col (save-excursion + (back-to-indentation) + (current-column))) + (funcall do-line-break) + (when (and comment-end (not (equal comment-end ""))) + (forward-char -1) + (insert-and-inherit comment-end) + (forward-char 1)) + ;; c-comment-indent may look at the current + ;; indentation, so let's start out with the same + ;; indentation as the previous one. + (indent-to col) + (insert-and-inherit comment-start) + (indent-for-comment)))) + ((c-query-and-set-macro-start) + ;; In a macro. + (unless (looking-at "[ \t]*\\\\$") + ;; Do not clobber the alignment of the line continuation + ;; slash; c-backslash-region might look at it. + (delete-horizontal-space)) + ;; Got an asymmetry here: In normal code this command + ;; doesn't indent the next line syntactically, and otoh a + ;; normal syntactically indenting newline doesn't continue + ;; the macro. + (c-newline-and-indent (if allow-auto-fill nil 1))) + (t + ;; Somewhere else in the code. + (let ((col (save-excursion + (beginning-of-line) + (while (and (looking-at "[ \t]*\\\\?$") + (= (forward-line -1) 0))) + (current-indentation)))) + (funcall do-line-break) + (indent-to col))))))) (defalias 'c-comment-line-break-function 'c-indent-new-comment-line) (make-obsolete 'c-comment-line-break-function 'c-indent-new-comment-line "21.1") @@ -5048,58 +5075,59 @@ When point is inside a string, only insert a backslash when it is also inside a preprocessor directive." (interactive "*") - (let* (c-lit-limits c-lit-type - (c-macro-start c-macro-start) - case-fold-search) - - (c-save-buffer-state () - (setq c-lit-limits (c-literal-limits nil nil t) - c-lit-type (c-literal-type c-lit-limits)) - (when (eq c-lit-type 'c++) - (setq c-lit-limits (c-collect-line-comments c-lit-limits))) - (c-query-and-set-macro-start)) - - (cond - ((or (eq c-lit-type 'c) - (and (eq c-lit-type 'c++) ; C++ comment, but not at the very end of it. - (< (save-excursion - (skip-chars-forward " \t") - (point)) - (1- (cdr c-lit-limits)))) - (and (numberp c-macro-start) ; Macro, but not at the very end of + (c-with-string-fences + (let* (c-lit-limits c-lit-type + (c-macro-start c-macro-start) + case-fold-search) + + (c-save-buffer-state () + (setq c-lit-limits (c-literal-limits nil nil t) + c-lit-type (c-literal-type c-lit-limits)) + (when (eq c-lit-type 'c++) + (setq c-lit-limits (c-collect-line-comments c-lit-limits))) + (c-query-and-set-macro-start)) + + (cond + ((or (eq c-lit-type 'c) + (and (eq c-lit-type 'c++) ; C++ comment, but not at the very end of it. + (< (save-excursion + (skip-chars-forward " \t") + (point)) + (1- (cdr c-lit-limits)))) + (and (numberp c-macro-start) ; Macro, but not at the very end of ; it, not in a string, and not in the ; cpp keyword. - (not (eq c-lit-type 'string)) - (or (not (looking-at "\\s *$")) - (eq (char-before) ?\\)) - (<= (save-excursion - (goto-char c-macro-start) - (if (looking-at c-opt-cpp-start) - (goto-char (match-end 0))) - (point)) - (point)))) - (let ((comment-multi-line t) - (fill-prefix nil)) - (c-indent-new-comment-line nil t))) - - ((eq c-lit-type 'string) - (if (and (numberp c-macro-start) - (not (eq (char-before) ?\\))) - (insert ?\\)) - (newline)) - - (t (delete-horizontal-space) - (newline) - ;; c-indent-line may look at the current indentation, so let's - ;; start out with the same indentation as the previous line. - (let ((col (save-excursion - (backward-char) - (forward-line 0) - (while (and (looking-at "[ \t]*\\\\?$") - (= (forward-line -1) 0))) - (current-indentation)))) - (indent-to col)) - (indent-according-to-mode))))) + (not (eq c-lit-type 'string)) + (or (not (looking-at "\\s *$")) + (eq (char-before) ?\\)) + (<= (save-excursion + (goto-char c-macro-start) + (if (looking-at c-opt-cpp-start) + (goto-char (match-end 0))) + (point)) + (point)))) + (let ((comment-multi-line t) + (fill-prefix nil)) + (c-indent-new-comment-line nil t))) + + ((eq c-lit-type 'string) + (if (and (numberp c-macro-start) + (not (eq (char-before) ?\\))) + (insert ?\\)) + (newline)) + + (t (delete-horizontal-space) + (newline) + ;; c-indent-line may look at the current indentation, so let's + ;; start out with the same indentation as the previous line. + (let ((col (save-excursion + (backward-char) + (forward-line 0) + (while (and (looking-at "[ \t]*\\\\?$") + (= (forward-line -1) 0))) + (current-indentation)))) + (indent-to col)) + (indent-according-to-mode)))))) (defun c-context-open-line () "Insert a line break suitable to the context and leave point before it. diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el index a127024355..54bedb4d9c 100644 --- a/lisp/progmodes/cc-defs.el +++ b/lisp/progmodes/cc-defs.el @@ -1562,6 +1562,27 @@ with value CHAR in the region [FROM to)." (c-put-char-property (point) ,property ,value) (forward-char))))) + +;; Miscellaneous macro(s) +(defvar c-string-fences-set-flag nil) +;; Non-nil when we have set string fences with `c-restore-string-fences'. +(defmacro c-with-string-fences (&rest forms) + ;; Restore the string fences, evaluate FORMS, then remove them again. It + ;; should only be used at the top level of "boundary" functions in CC Mode, + ;; i.e. those called from outside CC Mode which directly or indirectly need + ;; unbalanced string markers to have their string-fence syntax-table text + ;; properties. This includes all calls to `c-parse-state'. This macro will + ;; be invoked recursively; however the `c-string-fences-set-flag' mechanism + ;; should ensure consistency, when this happens. + `(unwind-protect + (progn + (unless c-string-fences-set-flag + (c-restore-string-fences)) + (let ((c-string-fences-set-flag t)) + ,@forms)) + (unless c-string-fences-set-flag + (c-clear-string-fences)))) + ;; Macros to put overlays (Emacs) or extents (XEmacs) on buffer text. ;; For our purposes, these are characterized by being possible to diff --git a/lisp/progmodes/cc-guess.el b/lisp/progmodes/cc-guess.el index ea5dd48986..584db86539 100644 --- a/lisp/progmodes/cc-guess.el +++ b/lisp/progmodes/cc-guess.el @@ -76,6 +76,8 @@ (cc-require 'cc-engine) (cc-require 'cc-styles) +(cc-bytecomp-defun c-restore-string-fences) +(cc-bytecomp-defun c-clear-string-fences) (defcustom c-guess-offset-threshold 10 @@ -225,11 +227,12 @@ guess is made from scratch. Note that the larger the region to guess in, the slower the guessing. So you can limit the region with `c-guess-region-max'." (interactive "r\nP") - (let ((accumulator (when accumulate c-guess-accumulator))) - (setq c-guess-accumulator (c-guess-examine start end accumulator)) - (let ((pair (c-guess-guess c-guess-accumulator))) - (setq c-guess-guessed-basic-offset (car pair) - c-guess-guessed-offsets-alist (cdr pair))))) + (c-with-string-fences + (let ((accumulator (when accumulate c-guess-accumulator))) + (setq c-guess-accumulator (c-guess-examine start end accumulator)) + (let ((pair (c-guess-guess c-guess-accumulator))) + (setq c-guess-guessed-basic-offset (car pair) + c-guess-guessed-offsets-alist (cdr pair)))))) (defun c-guess-examine (start end accumulator) diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index 957a0b8a7c..ae96cdbd2f 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -997,7 +997,8 @@ Note that the style variables are always made local to the buffer." ;; `c-before/after-change', frame 3 is the primitive invoking the change ;; hook. (memq (cadr (backtrace-frame 3)) - '(put-text-property remove-list-of-text-properties))) + '(put-text-property remove-text-properties + remove-list-of-text-properties))) (defun c-depropertize-CPP (beg end) ;; Remove the punctuation syntax-table text property from the CPP parts of @@ -1319,7 +1320,8 @@ Note that the style variables are always made local to the buffer." ;; balanced by another " is left with a '(1) syntax-table property. (when (and c-min-syn-tab-mkr c-max-syn-tab-mkr) - (let (s pos) + (c-save-buffer-state (s pos) ; Prevent text property stuff causing change + ; function invocation. (setq pos c-min-syn-tab-mkr) (while (and @@ -1342,7 +1344,8 @@ Note that the style variables are always made local to the buffer." (c-search-backward-char-property-with-value-on-char 'c-fl-syn-tab '(15) ?\" (max (- (point) 500) (point-min)))) - (not (equal (c-get-char-property (point) 'syntax-table) '(1)))) + (not (equal (c-get-char-property (point) 'syntax-table) + '(1)))) (setq pos (1+ pos)))) (while (< pos c-max-syn-tab-mkr) (setq pos @@ -1372,7 +1375,9 @@ Note that the style variables are always made local to the buffer." ;; Restore any syntax-table text properties which are "mirrored" by ;; c-fl-syn-tab text properties. (when (and c-min-syn-tab-mkr c-max-syn-tab-mkr) - (let ((pos c-min-syn-tab-mkr)) + (c-save-buffer-state ; Prevent text property stuff causing change function + ; invocation. + ((pos c-min-syn-tab-mkr)) (while (and (< pos c-max-syn-tab-mkr) @@ -2016,120 +2021,116 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ;; or a comment - "wrongly" removing a symbol from `c-found-types' ;; isn't critical. (unless (c-called-from-text-property-change-p) - (save-restriction - (widen) - ;; Clear the list of found types if we make a change at the start of the - ;; buffer, to make it easier to get rid of misspelled types and - ;; variables that have gotten recognized as types in malformed code. - (when (eq beg (point-min)) - (c-clear-found-types)) - (if c-just-done-before-change - ;; We have two consecutive calls to `before-change-functions' - ;; without an intervening `after-change-functions'. An example of - ;; this is bug #38691. To protect CC Mode, assume that the entire - ;; buffer has changed. - (setq beg (point-min) - end (point-max) - c-just-done-before-change 'whole-buffer) - (setq c-just-done-before-change t)) - ;; (c-new-BEG c-new-END) will be the region to fontify. - (setq c-new-BEG beg c-new-END end) - (setq c-maybe-stale-found-type nil) - ;; A workaround for syntax-ppss's failure to notice syntax-table text - ;; property changes. - (when (fboundp 'syntax-ppss) - (setq c-syntax-table-hwm most-positive-fixnum)) - (save-match-data - (widen) - (unwind-protect - (progn - (c-restore-string-fences) - (save-excursion - ;; Are we inserting/deleting stuff in the middle of an - ;; identifier? - (c-unfind-enclosing-token beg) - (c-unfind-enclosing-token end) - ;; Are we coalescing two tokens together, e.g. "fo o" - ;; -> "foo"? - (when (< beg end) - (c-unfind-coalesced-tokens beg end)) - (c-invalidate-sws-region-before beg end) - ;; Are we (potentially) disrupting the syntactic - ;; context which makes a type a type? E.g. by - ;; inserting stuff after "foo" in "foo bar;", or - ;; before "foo" in "typedef foo *bar;"? - ;; - ;; We search for appropriate c-type properties "near" - ;; the change. First, find an appropriate boundary - ;; for this property search. - (let (lim lim-2 - type type-pos - marked-id term-pos - (end1 - (or (and (eq (get-text-property end 'face) - 'font-lock-comment-face) - (previous-single-property-change end 'face)) - end))) - (when (>= end1 beg) ; Don't hassle about changes entirely in + (c-with-string-fences + (save-restriction + (widen) + ;; Clear the list of found types if we make a change at the start of the + ;; buffer, to make it easier to get rid of misspelled types and + ;; variables that have gotten recognized as types in malformed code. + (when (eq beg (point-min)) + (c-clear-found-types)) + (if c-just-done-before-change + ;; We have two consecutive calls to `before-change-functions' + ;; without an intervening `after-change-functions'. An example of + ;; this is bug #38691. To protect CC Mode, assume that the entire + ;; buffer has changed. + (setq beg (point-min) + end (point-max) + c-just-done-before-change 'whole-buffer) + (setq c-just-done-before-change t)) + ;; (c-new-BEG c-new-END) will be the region to fontify. + (setq c-new-BEG beg c-new-END end) + (setq c-maybe-stale-found-type nil) + ;; A workaround for syntax-ppss's failure to notice syntax-table text + ;; property changes. + (when (fboundp 'syntax-ppss) + (setq c-syntax-table-hwm most-positive-fixnum)) + (save-match-data + (save-excursion + ;; Are we inserting/deleting stuff in the middle of an + ;; identifier? + (c-unfind-enclosing-token beg) + (c-unfind-enclosing-token end) + ;; Are we coalescing two tokens together, e.g. "fo o" + ;; -> "foo"? + (when (< beg end) + (c-unfind-coalesced-tokens beg end)) + (c-invalidate-sws-region-before beg end) + ;; Are we (potentially) disrupting the syntactic + ;; context which makes a type a type? E.g. by + ;; inserting stuff after "foo" in "foo bar;", or + ;; before "foo" in "typedef foo *bar;"? + ;; + ;; We search for appropriate c-type properties "near" + ;; the change. First, find an appropriate boundary + ;; for this property search. + (let (lim lim-2 + type type-pos + marked-id term-pos + (end1 + (or (and (eq (get-text-property end 'face) + 'font-lock-comment-face) + (previous-single-property-change end 'face)) + end))) + (when (>= end1 beg) ; Don't hassle about changes entirely in ; comments. - ;; Find a limit for the search for a `c-type' property - ;; Point is currently undefined. A `goto-char' somewhere is needed. (2020-12-06). - (setq lim-2 (c-determine-limit 1000 (point) ; that is wrong. FIXME!!! (2020-12-06) - )) - (while - (and (/= (skip-chars-backward "^;{}" lim-2) 0) - (> (point) (point-min)) - (memq (c-get-char-property (1- (point)) 'face) - '(font-lock-comment-face font-lock-string-face)))) - (setq lim (max (point-min) (1- (point)))) - - ;; Look for the latest `c-type' property before end1 - (when (and (> end1 (point-min)) - (setq type-pos - (if (get-text-property (1- end1) 'c-type) - end1 - (previous-single-property-change end1 'c-type - nil lim)))) - (setq type (get-text-property (max (1- type-pos) lim) 'c-type)) - - (when (memq type '(c-decl-id-start c-decl-type-start)) - ;; Get the identifier, if any, that the property is on. - (goto-char (1- type-pos)) - (setq marked-id - (when (looking-at "\\(\\sw\\|\\s_\\)") - (c-beginning-of-current-token) - (buffer-substring-no-properties (point) type-pos))) - - (goto-char end1) - (setq lim-2 (c-determine-+ve-limit 1000)) - (skip-chars-forward "^;{}" lim-2) ; FIXME!!! loop for + ;; Find a limit for the search for a `c-type' property + ;; Point is currently undefined. A `goto-char' somewhere is needed. (2020-12-06). + (setq lim-2 (c-determine-limit 1000 (point) ; that is wrong. FIXME!!! (2020-12-06) + )) + (while + (and (/= (skip-chars-backward "^;{}" lim-2) 0) + (> (point) (point-min)) + (memq (c-get-char-property (1- (point)) 'face) + '(font-lock-comment-face font-lock-string-face)))) + (setq lim (max (point-min) (1- (point)))) + + ;; Look for the latest `c-type' property before end1 + (when (and (> end1 (point-min)) + (setq type-pos + (if (get-text-property (1- end1) 'c-type) + end1 + (previous-single-property-change end1 'c-type + nil lim)))) + (setq type (get-text-property (max (1- type-pos) lim) 'c-type)) + + (when (memq type '(c-decl-id-start c-decl-type-start)) + ;; Get the identifier, if any, that the property is on. + (goto-char (1- type-pos)) + (setq marked-id + (when (looking-at "\\(\\sw\\|\\s_\\)") + (c-beginning-of-current-token) + (buffer-substring-no-properties (point) type-pos))) + + (goto-char end1) + (setq lim-2 (c-determine-+ve-limit 1000)) + (skip-chars-forward "^;{}" lim-2) ; FIXME!!! loop for ; comment, maybe - (setq lim (point)) - (setq term-pos - (or (c-next-single-property-change end 'c-type nil lim) lim)) - (setq c-maybe-stale-found-type - (list type marked-id - type-pos term-pos - (buffer-substring-no-properties type-pos - term-pos) - (buffer-substring-no-properties beg end))))))) - - (if c-get-state-before-change-functions - (mapc (lambda (fn) - (funcall fn beg end)) - c-get-state-before-change-functions)) - - (c-laomib-invalidate-cache beg end))) - (c-clear-string-fences)))) - (c-truncate-lit-pos-cache beg) - ;; The following must be done here rather than in `c-after-change' - ;; because newly inserted parens would foul up the invalidation - ;; algorithm. - (c-invalidate-state-cache beg) - ;; The following must happen after the previous, which likely alters - ;; the macro cache. - (when c-opt-cpp-symbol - (c-invalidate-macro-cache beg end)))) + (setq lim (point)) + (setq term-pos + (or (c-next-single-property-change end 'c-type nil lim) lim)) + (setq c-maybe-stale-found-type + (list type marked-id + type-pos term-pos + (buffer-substring-no-properties type-pos + term-pos) + (buffer-substring-no-properties beg end))))))) + + (if c-get-state-before-change-functions + (mapc (lambda (fn) + (funcall fn beg end)) + c-get-state-before-change-functions)) + + (c-laomib-invalidate-cache beg end)))) + (c-truncate-lit-pos-cache beg) + ;; The following must be done here rather than in `c-after-change' + ;; because newly inserted parens would foul up the invalidation + ;; algorithm. + (c-invalidate-state-cache beg) + ;; The following must happen after the previous, which likely alters + ;; the macro cache. + (when c-opt-cpp-symbol + (c-invalidate-macro-cache beg end))))) (defvar c-in-after-change-fontification nil) (make-variable-buffer-local 'c-in-after-change-fontification) @@ -2181,51 +2182,48 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (save-restriction (save-match-data ; c-recognize-<>-arglists changes match-data (widen) - (unwind-protect - (progn - (c-restore-string-fences) - (when (> end (point-max)) - ;; Some emacsen might return positions past the end. This - ;; has been observed in Emacs 20.7 when rereading a buffer - ;; changed on disk (haven't been able to minimize it, but - ;; Emacs 21.3 appears to work). - (setq end (point-max)) - (when (> beg end) - (setq beg end))) - - ;; C-y is capable of spuriously converting category - ;; properties c--as-paren-syntax and - ;; c-cpp-delimiter into hard syntax-table properties. - ;; Remove these when it happens. - (when (eval-when-compile (memq 'category-properties c-emacs-features)) - (c-save-buffer-state () - (c-clear-char-property-with-value beg end 'syntax-table - c-<-as-paren-syntax) - (c-clear-char-property-with-value beg end 'syntax-table - c->-as-paren-syntax) - (c-clear-char-property-with-value beg end 'syntax-table nil))) - - (c-update-new-id end) - (c-trim-found-types beg end old-len) ; maybe we don't - ; need all of these. - (c-invalidate-sws-region-after beg end old-len) - ;; (c-invalidate-state-cache beg) ; moved to - ;; `c-before-change'. - (c-invalidate-find-decl-cache beg) - - (when c-recognize-<>-arglists - (c-after-change-check-<>-operators beg end)) - - (setq c-in-after-change-fontification t) - (save-excursion - (mapc (lambda (fn) - (funcall fn beg end old-len)) - c-before-font-lock-functions))) - (c-clear-string-fences)))))) + (c-with-string-fences + (when (> end (point-max)) + ;; Some emacsen might return positions past the end. This + ;; has been observed in Emacs 20.7 when rereading a buffer + ;; changed on disk (haven't been able to minimize it, but + ;; Emacs 21.3 appears to work). + (setq end (point-max)) + (when (> beg end) + (setq beg end))) + + ;; C-y is capable of spuriously converting category + ;; properties c--as-paren-syntax and + ;; c-cpp-delimiter into hard syntax-table properties. + ;; Remove these when it happens. + (when (eval-when-compile (memq 'category-properties c-emacs-features)) + (c-save-buffer-state () + (c-clear-char-property-with-value beg end 'syntax-table + c-<-as-paren-syntax) + (c-clear-char-property-with-value beg end 'syntax-table + c->-as-paren-syntax) + (c-clear-char-property-with-value beg end 'syntax-table nil))) + + (c-update-new-id end) + (c-trim-found-types beg end old-len) ; maybe we don't + ; need all of these. + (c-invalidate-sws-region-after beg end old-len) + ;; (c-invalidate-state-cache beg) ; moved to + ;; `c-before-change'. + (c-invalidate-find-decl-cache beg) + + (when c-recognize-<>-arglists + (c-after-change-check-<>-operators beg end)) + + (setq c-in-after-change-fontification t) + (save-excursion + (mapc (lambda (fn) + (funcall fn beg end old-len)) + c-before-font-lock-functions))))) ;; A workaround for syntax-ppss's failure to notice syntax-table text ;; property changes. - (when (fboundp 'syntax-ppss) - (syntax-ppss-flush-cache c-syntax-table-hwm))) + (when (fboundp 'syntax-ppss) + (syntax-ppss-flush-cache c-syntax-table-hwm))))) (defun c-doc-fl-decl-start (pos) ;; If the line containing POS is in a doc comment continued line (as defined @@ -2457,46 +2455,42 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (widen) (let (new-beg new-end new-region case-fold-search) (c-save-buffer-state nil - ;; Temporarily reapply the string fence syntax-table properties. - (unwind-protect - (progn - (c-restore-string-fences) - (if (and c-in-after-change-fontification - (< beg c-new-END) (> end c-new-BEG)) - ;; Region and the latest after-change fontification region overlap. - ;; Determine the upper and lower bounds of our adjusted region - ;; separately. - (progn - (if (<= beg c-new-BEG) - (setq c-in-after-change-fontification nil)) - (setq new-beg - (if (and (>= beg (c-point 'bol c-new-BEG)) - (<= beg c-new-BEG)) - ;; Either jit-lock has accepted `c-new-BEG', or has - ;; (probably) extended the change region spuriously - ;; to BOL, which position likely has a - ;; syntactically different position. To ensure - ;; correct fontification, we start at `c-new-BEG', - ;; assuming any characters to the left of - ;; `c-new-BEG' on the line do not require - ;; fontification. - c-new-BEG - (setq new-region (c-before-context-fl-expand-region beg end) - new-end (cdr new-region)) - (car new-region))) - (setq new-end - (if (and (>= end (c-point 'bol c-new-END)) - (<= end c-new-END)) - c-new-END - (or new-end - (cdr (c-before-context-fl-expand-region beg end)))))) - ;; Context (etc.) fontification. - (setq new-region (c-before-context-fl-expand-region beg end) - new-beg (car new-region) new-end (cdr new-region))) - ;; Finally invoke font lock's functionality. - (funcall (default-value 'font-lock-fontify-region-function) - new-beg new-end verbose)) - (c-clear-string-fences)))))) + (c-with-string-fences + (if (and c-in-after-change-fontification + (< beg c-new-END) (> end c-new-BEG)) + ;; Region and the latest after-change fontification region overlap. + ;; Determine the upper and lower bounds of our adjusted region + ;; separately. + (progn + (if (<= beg c-new-BEG) + (setq c-in-after-change-fontification nil)) + (setq new-beg + (if (and (>= beg (c-point 'bol c-new-BEG)) + (<= beg c-new-BEG)) + ;; Either jit-lock has accepted `c-new-BEG', or has + ;; (probably) extended the change region spuriously + ;; to BOL, which position likely has a + ;; syntactically different position. To ensure + ;; correct fontification, we start at `c-new-BEG', + ;; assuming any characters to the left of + ;; `c-new-BEG' on the line do not require + ;; fontification. + c-new-BEG + (setq new-region (c-before-context-fl-expand-region beg end) + new-end (cdr new-region)) + (car new-region))) + (setq new-end + (if (and (>= end (c-point 'bol c-new-END)) + (<= end c-new-END)) + c-new-END + (or new-end + (cdr (c-before-context-fl-expand-region beg end)))))) + ;; Context (etc.) fontification. + (setq new-region (c-before-context-fl-expand-region beg end) + new-beg (car new-region) new-end (cdr new-region))) + ;; Finally invoke font lock's functionality. + (funcall (default-value 'font-lock-fontify-region-function) + new-beg new-end verbose)))))) (defun c-after-font-lock-init () ;; Put on `font-lock-mode-hook'. This function ensures our after-change commit 45694a25948146e860738cb4e01de7e7e9aa91b0 Author: kobarity Date: Sun May 22 18:53:00 2022 +0200 Don't font-lock invalid invalid class/function names * lisp/progmodes/python.el (python-font-lock-keywords-level-1): Don't font-lock invalid invalid class/function names (bug#55573). diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index c1368364a9..9adbb82abf 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -540,9 +540,9 @@ the {...} holes that appear within f-strings." (setq ppss (syntax-ppss)))))) (defvar python-font-lock-keywords-level-1 - `((,(rx symbol-start "def" (1+ space) (group (1+ (or word ?_)))) + `((,(python-rx symbol-start "def" (1+ space) (group symbol-name)) (1 font-lock-function-name-face)) - (,(rx symbol-start "class" (1+ space) (group (1+ (or word ?_)))) + (,(python-rx symbol-start "class" (1+ space) (group symbol-name)) (1 font-lock-type-face))) "Font lock keywords to use in `python-mode' for level 1 decoration. diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el index a3f778bbbe..479d68a062 100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@ -214,6 +214,18 @@ aliqua." (should (string= (buffer-string) "\"\"")) (should (null (nth 3 (syntax-ppss)))))) +(ert-deftest python-font-lock-keywords-level-1-1 () + (python-tests-assert-faces + "def func():" + '((1 . font-lock-keyword-face) (4) + (5 . font-lock-function-name-face) (9)))) + +(ert-deftest python-font-lock-keywords-level-1-2 () + "Invalid function name should not be font-locked." + (python-tests-assert-faces + "def 1func():" + '((1 . font-lock-keyword-face) (4)))) + (ert-deftest python-font-lock-assignment-statement-1 () (python-tests-assert-faces "a, b, c = 1, 2, 3" commit 91bc24c46768aab4a851c87edaea05c7476ff779 Author: Stefan Monnier Date: Sun May 22 12:52:42 2022 -0400 mode-local: Deprecate buffer-local overrides * lisp/cedet/mode-local.el (mode-local-bind): Make all args mandatory. Deprecate the use of a nil `mode` argument. diff --git a/etc/NEWS b/etc/NEWS index 4331968ba7..0295fbf1f1 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -827,6 +827,10 @@ so automatically. * Changes in Specialized Modes and Packages in Emacs 29.1 +** CEDET +--- +*** Deprecate buffer-local function overrides for mode-local functions + ** Enriched Mode +++ diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el index ce37a28c35..0b24f71dc0 100644 --- a/lisp/cedet/mode-local.el +++ b/lisp/cedet/mode-local.el @@ -38,10 +38,12 @@ ;; user might wish to customize a given variable or function then ;; the existing customization mechanism should be used. +;; NOTE: `define-overloadable-function' and `define-mode-local-override' are +;; nowadays advantageously replaced by `cl-defgeneric' and `cl-defmethod' +;; (with a `&context (derived-mode )'). + ;; To Do: ;; Allow customization of a variable for a specific mode? -;; -;; Add macro for defining the '-default' functionality. ;;; Code: @@ -187,7 +189,7 @@ behaviors. Use the function `mode-local-bind' to define new bindings.") (defun mode-local-bind (bindings &optional plist mode) "Define BINDINGS in the specified environment. BINDINGS is a list of (VARIABLE . VALUE). -Optional argument PLIST is a property list each VARIABLE symbol will +Argument PLIST is a property list each VARIABLE symbol will be set to. The following properties have special meaning: - `constant-flag' if non-nil, prevent rebinding variables. @@ -195,13 +197,15 @@ be set to. The following properties have special meaning: - `override-flag' if non-nil, define override functions. The `override-flag' and `mode-variable-flag' properties are mutually -exclusive. +exclusive and exactly one of the two must be non-nil. + +Argument MODE must be a major mode symbol. +BINDINGS will be defined globally for this major mode. -If optional argument MODE is non-nil, it must be a major mode symbol. -BINDINGS will be defined globally for this major mode. If MODE is -nil, BINDINGS will be defined locally in the current buffer, in -variable `mode-local-symbol-table'. The later should be done in MODE -hook." +For backward compatibility, If MODE is nil, BINDINGS will be defined locally +in the current buffer, in variable `mode-local-symbol-table', but +this use is deprecated and will be removed." + (declare (advertised-calling-convention (bindings plist mode) "29.1")) ;; Check plist consistency (and (plist-get plist 'mode-variable-flag) (plist-get plist 'override-flag) @@ -217,6 +221,7 @@ hook." ;; Fail if trying to bind mode variables in local context! (if (plist-get plist 'mode-variable-flag) (error "Mode required to bind mode variables")) + (message "Obsolete use of nil MODE arg to mode-local-bind!") ;; Install in buffer local symbol table. Create a new one if ;; needed. (setq table (or mode-local-symbol-table @@ -412,6 +417,7 @@ Set each SYM to the value of its VAL, locally in buffers already in MODE, or in buffers switched to that mode. Return the value of the last VAL." (declare (debug (symbolp &rest symbolp form))) + (unless mode (error "Argument mode should be a major mode")) (when args (let (i ll bl sl tmp sym val) (setq i 0) @@ -598,6 +604,7 @@ BODY is the implementation of this function." (declare (doc-string 4) (indent defun) (debug (&define name symbolp lambda-list stringp def-body))) + (unless mode (error "Argument mode should be a major mode")) (let ((newname (intern (format "%s-%s" name mode)))) `(progn (eval-and-compile commit d2e0d1452b976a51579cf044257326850804c562 Author: Stefan Monnier Date: Sun May 22 12:22:40 2022 -0400 semantic-install-function-overrides: Declare obsolete * lisp/cedet/semantic/fw.el (semantic-install-function-overrides): Declare obsolete. diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el index b7c3461a4d..14ed3e97ed 100644 --- a/lisp/cedet/semantic/fw.el +++ b/lisp/cedet/semantic/fw.el @@ -277,6 +277,7 @@ If optional argument MODE is non-nil, it must be a major mode symbol. OVERRIDES will be installed globally for this major mode. If MODE is nil, OVERRIDES will be installed locally in the current buffer. This later installation should be done in MODE hook." + (declare (obsolete define-mode-local-override "29.1")) (mode-local-bind ;; Add the semantic- prefix to OVERLOAD short names. (mapcar diff --git a/lisp/cedet/semantic/grammar.el b/lisp/cedet/semantic/grammar.el index 74d4a229fa..d8cf6b2004 100644 --- a/lisp/cedet/semantic/grammar.el +++ b/lisp/cedet/semantic/grammar.el @@ -880,7 +880,7 @@ Lisp code." (unless (derived-mode-p 'emacs-lisp-mode) (emacs-lisp-mode)) -;;;; Header + Prologue + ;; Header + Prologue (insert header " \n;;; Prologue\n;;\n" @@ -892,7 +892,7 @@ Lisp code." (save-excursion -;;;; Declarations + ;; Declarations (insert " \n;;; Declarations\n;;\n") @@ -927,12 +927,12 @@ Lisp code." (semantic-grammar-setup-data)) "Setup the Semantic Parser.") -;;;; Analyzers + ;; Analyzers (insert " \n;;; Analyzers\n;;\n") (semantic-grammar-insert-defanalyzers) -;;;; Epilogue & Footer + ;; Epilogue & Footer (insert " \n;;; Epilogue\n;;\n" epilogue @@ -967,7 +967,7 @@ Lisp code." ;; have created this language for, and force them to call our ;; setup function again, refreshing all semantic data, and ;; enabling them to work with the new code just created. -;;;; FIXME? + ;; FIXME? ;; At this point, I don't know any user's defined setup code :-( ;; At least, what I can do for now, is to run the generated ;; parser-install function. commit 3294ad44ebcd024b4ada68d00bedca33acc52de6 Author: Stefan Monnier Date: Sun May 22 12:21:23 2022 -0400 wisent.el: Prefer `define-mode-local-override` * lisp/cedet/semantic/wisent.el (wisent--parse-stream): Rename from `wisent-parse-stream` and mark the old name obsolete. (semantic-parse-stream): Override with `define-mode-local-override`. * lisp/cedet/semantic/wisent/grammar.el (semantic-grammar-setupcode-builder): Don't override `semantic-parse-stream` manually here via `semantic-install-function-overrides`. * lisp/cedet/semantic/grm-wy-boot.el: Refresh. diff --git a/lisp/cedet/semantic/grm-wy-boot.el b/lisp/cedet/semantic/grm-wy-boot.el index 376fab89c2..6525a10443 100644 --- a/lisp/cedet/semantic/grm-wy-boot.el +++ b/lisp/cedet/semantic/grm-wy-boot.el @@ -422,8 +422,6 @@ (defun semantic-grammar-wy--install-parser () "Setup the Semantic Parser." - (semantic-install-function-overrides - '((semantic-parse-stream . wisent-parse-stream))) (setq semantic-parser-name "LALR" semantic--parse-table semantic-grammar-wy--parse-table semantic-debug-parser-source "grammar.wy" diff --git a/lisp/cedet/semantic/wisent.el b/lisp/cedet/semantic/wisent.el index 55eeef453e..d06028b48f 100644 --- a/lisp/cedet/semantic/wisent.el +++ b/lisp/cedet/semantic/wisent.el @@ -154,17 +154,25 @@ and will be collected in `semantic-lex' form: (SYMBOL START . END)." ;; Maybe the latter is faster because it eliminates a lot of function ;; call. ;; -(defun wisent-parse-stream (stream goal) +;; Emacs<29 generated grammars which manually setup `wisent-parse-stream' +;; as a buffer-local overload for `semantic-parse-stream', but we don't +;; need that now that we define a mode-local overload instead. +(define-obsolete-function-alias 'wisent-parse-stream + #'wisent--parse-stream "29.1" + "Recompile your grammars so they don't call `wisent-parse-stream' any more.") +(define-mode-local-override semantic-parse-stream semantic-grammar-mode + (stream goal) + "Parse STREAM using the Wisent LALR parser. +See `wisent--parse-stream'." + (wisent--parse-stream stream goal)) +(defun wisent--parse-stream (stream goal) "Parse STREAM using the Wisent LALR parser. GOAL is a nonterminal symbol to start parsing at. Return the list (STREAM SEMANTIC-STREAM) where STREAM are those elements of STREAM that have not been used. SEMANTIC-STREAM is the list of semantic tags found. The LALR parser automaton must be available in buffer local variable -`semantic--parse-table'. - -Must be installed by `semantic-install-function-overrides' to override -the standard function `semantic-parse-stream'." +`semantic--parse-table'." (let (wisent-lex-istream wisent-lex-lookahead la-elt cache) ;; IMPLEMENTATION NOTES: @@ -267,10 +275,7 @@ Optional arguments GOAL is a nonterminal symbol to start parsing at, DEPTH is the lexical depth to scan, and RETURNONERROR is a flag to stop parsing on syntax error, when non-nil. The LALR parser automaton must be available in buffer local variable -`semantic--parse-table'. - -Must be installed by `semantic-install-function-overrides' to override -the standard function `semantic-parse-region'." +`semantic--parse-table'." (if (or (< start (point-min)) (> end (point-max)) (< end start)) (error "Invalid bounds [%s %s] passed to `wisent-parse-region'" start end)) diff --git a/lisp/cedet/semantic/wisent/grammar.el b/lisp/cedet/semantic/wisent/grammar.el index a4104e333d..3d83ee197d 100644 --- a/lisp/cedet/semantic/wisent/grammar.el +++ b/lisp/cedet/semantic/wisent/grammar.el @@ -295,9 +295,7 @@ Return the expanded expression." wisent-grammar-mode () "Return the parser setup code." (format - "(semantic-install-function-overrides\n\ - '((semantic-parse-stream . wisent-parse-stream)))\n\ - (setq semantic-parser-name \"LALR\"\n\ + "(setq semantic-parser-name \"LALR\"\n\ semantic--parse-table %s\n\ semantic-debug-parser-source %S\n\ semantic-flex-keywords-obarray %s\n\ commit a1a6e6c5c44e0930784de67fc6b25c3cc43e0ee4 Author: Stefan Monnier Date: Sun May 22 12:13:28 2022 -0400 wisent/grammar.el: Prefer `define-mode-local-override` * lisp/cedet/semantic/wisent/grammar.el (semantic-grammar-parsetable-builder, semantic-grammar-setupcode-builder): Override with `define-mode-local-override`. (wisent-grammar-mode): Don't override them with `semantic-install-function-overrides`. diff --git a/lisp/cedet/semantic/wisent/grammar.el b/lisp/cedet/semantic/wisent/grammar.el index 5ca22bac86..a4104e333d 100644 --- a/lisp/cedet/semantic/wisent/grammar.el +++ b/lisp/cedet/semantic/wisent/grammar.el @@ -284,13 +284,15 @@ Return the expanded expression." (assocs (wisent-grammar-assocs))) (cons terminals (cons assocs nonterminals)))) -(defun wisent-grammar-parsetable-builder () +(define-mode-local-override semantic-grammar-parsetable-builder + wisent-grammar-mode () "Return the value of the parser table." `(wisent-compiled-grammar ,(wisent-grammar-grammar) ,(semantic-grammar-start))) -(defun wisent-grammar-setupcode-builder () +(define-mode-local-override semantic-grammar-setupcode-builder + wisent-grammar-mode () "Return the parser setup code." (format "(semantic-install-function-overrides\n\ @@ -322,10 +324,7 @@ Menu items are appended to the common grammar menu.") (define-derived-mode wisent-grammar-mode semantic-grammar-mode "WY" "Major mode for editing Wisent grammars." (semantic-grammar-setup-menu wisent-grammar-menu) - (setq-local semantic-grammar-require-form '(require 'semantic/wisent)) - (semantic-install-function-overrides - '((semantic-grammar-parsetable-builder . wisent-grammar-parsetable-builder) - (semantic-grammar-setupcode-builder . wisent-grammar-setupcode-builder)))) + (setq-local semantic-grammar-require-form '(require 'semantic/wisent))) (defvar-mode-local wisent-grammar-mode semantic-grammar-macros '( commit 2ca4925d2b9646493e90c660ce2b8a1bc4378e71 Author: Stefan Monnier Date: Sun May 22 12:10:47 2022 -0400 cedet/html.el: Prefer `define-mode-local-override` * lisp/cedet/semantic/html.el (semantic-tag-components): Override via `define-mode-local-override`. (semantic-default-html-setup): Don't override via `semantic-install-function-overrides`. diff --git a/lisp/cedet/semantic/html.el b/lisp/cedet/semantic/html.el index 718ce3c4c7..00e19dbc89 100644 --- a/lisp/cedet/semantic/html.el +++ b/lisp/cedet/semantic/html.el @@ -82,6 +82,11 @@ or tag :members (mapcar #'semantic-html-expand-tag chil))) (car (semantic--tag-expand tag)))) +(define-mode-local-override semantic-tag-components html-mode (tag) + "Return components belonging to TAG." + ;; Keep this η-regexp because `semantic-html-components' is called + ;; from elsewhere. + (semantic-html-components tag)) (defun semantic-html-components (tag) "Return components belonging to TAG." (semantic-tag-get-attribute tag :members)) @@ -245,12 +250,7 @@ tag with greater section value than LEVEL is found." senator-step-at-start-end-tag-classes '(section) senator-step-at-tag-classes '(section) semantic-stickyfunc-sticky-classes '(section) - ) - (semantic-install-function-overrides - '((semantic-tag-components . semantic-html-components) - ) - t) - ) + )) ;; `html-helper-mode' hasn't been updated since 2004, so it's not very ;; relevant nowadays. commit 35afd1f246cf2c56dd88ea56c8960fcf49d3a7c7 Author: Stefan Monnier Date: Sun May 22 11:22:29 2022 -0400 bovine/grammar.el: Prefer `define-mode-local-override` * lisp/cedet/semantic/bovine/grammar.el (semantic-grammar-parsetable-builder, semantic-grammar-setupcode-builder): Override with `define-mode-local-override`. (bovine-grammar-mode): Don't override them with `semantic-install-function-overrides`. diff --git a/lisp/cedet/semantic/bovine/grammar.el b/lisp/cedet/semantic/bovine/grammar.el index d478b12f64..67366ad445 100644 --- a/lisp/cedet/semantic/bovine/grammar.el +++ b/lisp/cedet/semantic/bovine/grammar.el @@ -260,7 +260,8 @@ QUOTEMODE is the mode in which quoted symbols are slurred." (insert ")\n"))) ) -(defun bovine-grammar-parsetable-builder () +(define-mode-local-override semantic-grammar-parsetable-builder + bovine-grammar-mode () "Return the parser table expression as a string value. The format of a bovine parser table is: @@ -409,7 +410,8 @@ The source directory is relative to some root in the load path." newdir)) (error (buffer-name)))) -(defun bovine-grammar-setupcode-builder () +(define-mode-local-override semantic-grammar-setupcode-builder + bovine-grammar-mode () "Return the text of the setup code." (format "(setq semantic--parse-table %s\n\ @@ -435,10 +437,7 @@ Menu items are appended to the common grammar menu.") ;;;###autoload (define-derived-mode bovine-grammar-mode semantic-grammar-mode "BY" "Major mode for editing Bovine grammars." - (semantic-grammar-setup-menu bovine-grammar-menu) - (semantic-install-function-overrides - '((semantic-grammar-parsetable-builder . bovine-grammar-parsetable-builder) - (semantic-grammar-setupcode-builder . bovine-grammar-setupcode-builder)))) + (semantic-grammar-setup-menu bovine-grammar-menu)) (add-to-list 'auto-mode-alist '("\\.by\\'" . bovine-grammar-mode)) @@ -461,7 +460,7 @@ Menu items are appended to the common grammar menu.") (defun bovine--make-parser-1 (infile &optional outdir) (if outdir (setq outdir (file-name-directory (expand-file-name outdir)))) ;; It would be nicer to use a temp-buffer rather than find-file-noselect. - ;; The only thing stopping us is bovine-grammar-setupcode-builder's + ;; The only thing stopping us is bovine's semantic-grammar-setupcode-builder's ;; use of (buffer-name). Perhaps that could be changed to ;; (file-name-nondirectory (buffer-file-name)) ? ;; (with-temp-buffer diff --git a/lisp/cedet/semantic/texi.el b/lisp/cedet/semantic/texi.el index 9b8dfef5f3..d005b7a854 100644 --- a/lisp/cedet/semantic/texi.el +++ b/lisp/cedet/semantic/texi.el @@ -61,10 +61,7 @@ IGNORE any arguments, always parse the whole buffer. Each tag returned is of the form: (\"NAME\" section (:members CHILDREN)) or - (\"NAME\" def) - -It is an override of `semantic-parse-region' and must be installed by the -function `semantic-install-function-overrides'." + (\"NAME\" def)" (mapcar #'semantic-texi-expand-tag (semantic-texi-parse-headings))) commit f166e2dfc07aa9b297537eff79e9951131125fba Author: Stefan Monnier Date: Sun May 22 11:13:27 2022 -0400 cedet/texi.el: prefer `define-mode-local-override` * lisp/cedet/semantic/texi.el (semantic-parse-region) (semantic-parse-changes): Override with `define-mode-local-override`. (semantic-default-texi-setup): Don't override them with `semantic-install-function-overrides`. diff --git a/lisp/cedet/semantic/texi.el b/lisp/cedet/semantic/texi.el index 1917bcb40a..9b8dfef5f3 100644 --- a/lisp/cedet/semantic/texi.el +++ b/lisp/cedet/semantic/texi.el @@ -55,7 +55,7 @@ The field position is the field number (based at 1) where the name of this section is.") ;;; Code: -(defun semantic-texi-parse-region (&rest _ignore) +(define-mode-local-override semantic-parse-region texinfo-mode (&rest _ignore) "Parse the current texinfo buffer for semantic tags. IGNORE any arguments, always parse the whole buffer. Each tag returned is of the form: @@ -68,7 +68,7 @@ function `semantic-install-function-overrides'." (mapcar #'semantic-texi-expand-tag (semantic-texi-parse-headings))) -(defun semantic-texi-parse-changes () +(define-mode-local-override semantic-parse-changes texinfo-mode () "Parse changes in the current texinfo buffer." ;; NOTE: For now, just schedule a full reparse. ;; To be implemented later. @@ -445,9 +445,6 @@ that start with that symbol." (defun semantic-default-texi-setup () "Set up a buffer for parsing of Texinfo files." ;; This will use our parser. - (semantic-install-function-overrides - '((semantic-parse-region . semantic-texi-parse-region) - (semantic-parse-changes . semantic-texi-parse-changes))) (setq semantic-parser-name "TEXI" ;; Setup a dummy parser table to enable parsing! semantic--parse-table t commit 42076e69867408a0d23c67643def6cfe1aba8a6e Author: Stefan Monnier Date: Sun May 22 10:48:58 2022 -0400 comp.el: Cosmetic changes * lisp/emacs-lisp/comp.el (comp-run-async-workers): Tweak code. (comp-run-async-workers): Don't set `buffer-read-only` directly. (native--compile-async): Fix misuse of "path". diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9ffb97bd47..83a81a1bad 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3926,22 +3926,36 @@ display a message." (file-newer-than-file-p source-file (comp-el-to-eln-filename source-file))) do (let* ((expr `((require 'comp) - ,(when (boundp 'backtrace-line-length) - `(setf backtrace-line-length ,backtrace-line-length)) - (setf comp-file-preloaded-p ,comp-file-preloaded-p - native-compile-target-directory ,native-compile-target-directory - native-comp-speed ,native-comp-speed - native-comp-debug ,native-comp-debug - native-comp-verbose ,native-comp-verbose - comp-libgccjit-reproducer ,comp-libgccjit-reproducer - comp-async-compilation t - native-comp-eln-load-path ',native-comp-eln-load-path - native-comp-compiler-options - ',native-comp-compiler-options - native-comp-driver-options - ',native-comp-driver-options - load-path ',load-path - warning-fill-column most-positive-fixnum) + (setq comp-async-compilation t) + (setq warning-fill-column most-positive-fixnum) + ,(let ((set (list 'setq))) + (dolist (var '(comp-file-preloaded-p + native-compile-target-directory + native-comp-speed + native-comp-debug + native-comp-verbose + comp-libgccjit-reproducer + native-comp-eln-load-path + native-comp-compiler-options + native-comp-driver-options + load-path + backtrace-line-length + ;; package-load-list + ;; package-user-dir + ;; package-directory-list + )) + (when (boundp var) + (push var set) + (push `',(symbol-value var) set))) + (nreverse set)) + ;; FIXME: Activating all packages would align the + ;; functionality offered with what is usually done + ;; for ELPA packages (and thus fix some compilation + ;; issues with some ELPA packages), but it's too + ;; blunt an instrument (e.g. we don't even know if + ;; we're compiling such an ELPA package at + ;; this point). + ;;(package-activate-all) ,native-comp-async-env-modifier-form (message "Compiling %s..." ,source-file) (comp--native-compile ,source-file ,(and load t)))) @@ -3994,7 +4008,7 @@ display a message." (run-hooks 'native-comp-async-all-done-hook) (with-current-buffer (get-buffer-create comp-async-buffer-name) (save-excursion - (let ((buffer-read-only nil)) + (let ((inhibit-read-only t)) (goto-char (point-max)) (insert "Compilation finished.\n")))) ;; `comp-deferred-pending-h' should be empty at this stage. @@ -4088,6 +4102,7 @@ LOAD and SELECTOR work as described in `native--compile-async'." native-comp-deferred-compilation-deny-list)))) (defun native--compile-async (files &optional recursively load selector) + ;; BEWARE, this function is also called directly from C. "Compile FILES asynchronously. FILES is one filename or a list of filenames or directories. @@ -4121,16 +4136,17 @@ bytecode definition was not changed in the meantime)." (unless (listp files) (setf files (list files))) (let (file-list) - (dolist (path files) - (cond ((file-directory-p path) + (dolist (file-or-dir files) + (cond ((file-directory-p file-or-dir) (dolist (file (if recursively (directory-files-recursively - path comp-valid-source-re) - (directory-files path t comp-valid-source-re))) + file-or-dir comp-valid-source-re) + (directory-files file-or-dir + t comp-valid-source-re))) (push file file-list))) - ((file-exists-p path) (push path file-list)) + ((file-exists-p file-or-dir) (push file-or-dir file-list)) (t (signal 'native-compiler-error - (list "Path not a file nor directory" path))))) + (list "Not a file nor directory" file-or-dir))))) (dolist (file file-list) (if-let ((entry (cl-find file comp-files-queue :key #'car :test #'string=))) ;; Most likely the byte-compiler has requested a deferred commit cc878319f911a63eaab9b8382d38671b67d8abf9 Author: Stefan Monnier Date: Sun May 22 10:35:02 2022 -0400 Run `minibuffer-exit-hook` in the right buffer * src/minibuf.c (run_exit_minibuf_hook): Take the minibuffer as arg and run the hook in that buffer. (read_minibuf): Adjust accordingly. diff --git a/src/minibuf.c b/src/minibuf.c index df82bcb121..3f06ce7e0e 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -265,7 +265,7 @@ without invoking the usual minibuffer commands. */) static void read_minibuf_unwind (void); static void minibuffer_unwind (void); -static void run_exit_minibuf_hook (void); +static void run_exit_minibuf_hook (Lisp_Object minibuf); /* Read a Lisp object from VAL and return it. If VAL is an empty @@ -749,7 +749,7 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, separately from read_minibuf_unwind because we need to make sure that read_minibuf_unwind is fully executed even if exit-minibuffer-hook signals an error. --Stef */ - record_unwind_protect_void (run_exit_minibuf_hook); + record_unwind_protect (run_exit_minibuf_hook, minibuffer); /* Now that we can restore all those variables, start changing them. */ @@ -1076,9 +1076,14 @@ static EMACS_INT minibuf_c_loop_level (EMACS_INT depth) } static void -run_exit_minibuf_hook (void) +run_exit_minibuf_hook (Lisp_Object minibuf) { + specpdl_ref count = SPECPDL_INDEX (); + record_unwind_current_buffer (); + if (BUFFER_LIVE_P (XBUFFER (minibuf))) + Fset_buffer (minibuf); safe_run_hooks (Qminibuffer_exit_hook); + unbind_to (count, Qnil); } /* This variable records the expired minibuffer's frame between the commit 5088ebc8eb7f5451be195481f00c73ba994efa52 Author: Michael Albinus Date: Sun May 22 14:48:30 2022 +0200 * lisp/window.el (display-buffer-avoid-small-windows): Fix :type. diff --git a/lisp/window.el b/lisp/window.el index 3fe48e2522..585c64e687 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -2492,7 +2492,7 @@ and no others." "If non-nil, windows that have fewer lines than this are avoided. This is used by `get-lru-window'. The value is interpreted in units of the frame's canonical line height, like `window-total-height' does." - :type '(choice nil number) + :type '(choice (const nil) number) :version "29.1" :group 'windows) commit 4c1af80322145159530a057d97a8828318e560c8 Author: Po Lu Date: Sun May 22 12:22:44 2022 +0000 Clean up Haiku code * src/haiku_support.cc (movement_locker, class EmacsWindow) (MouseMoved): Delete `movement_locker' and associated hack, since it's superseeded by some code in haiku_read_socket. (key_map, key_chars, dpy_color_space, popup_track_message) (alert_popup_value, grab_view, grab_view_locker) (drag_and_drop_in_progress): Write comments and fix initializers. * src/haikuterm.c (haiku_read_socket): Update comment. diff --git a/src/haiku_support.cc b/src/haiku_support.cc index 0c8e87154b..8b2015b37b 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -156,44 +156,45 @@ struct font_selection_dialog_message int size; }; +/* The color space of the main screen. B_NO_COLOR_SPACE means it has + not yet been computed. */ static color_space dpy_color_space = B_NO_COLOR_SPACE; -static key_map *key_map = NULL; -static char *key_chars = NULL; + +/* The keymap, or NULL if it has not been initialized. */ +static key_map *key_map; + +/* Indices of characters into the keymap. */ +static char *key_chars; + +/* Lock around keymap data, since it's touched from different + threads. */ static BLocker key_map_lock; /* The locking semantics of BWindows running in multiple threads are so complex that child frame state (which is the only state that is shared between different BWindows at runtime) does best with a single global lock. */ - static BLocker child_frame_lock; -/* A LeaveNotify event (well, the closest equivalent on Haiku, which - is a B_MOUSE_MOVED event with `transit' set to B_EXITED_VIEW) might - be sent out-of-order with regards to motion events from other - windows, such as when the mouse pointer rapidly moves from an - undecorated child frame to its parent. This can cause a failure to - clear the mouse face on the former if an event for the latter is - read by Emacs first and ends up showing the mouse face there. - - While this lock doesn't really ensure that the events will be - delivered in the correct order, it makes them arrive in the correct - order "most of the time" on my machine, which is good enough and - preferable to adding a lot of extra complexity to the event - handling code to sort motion events by their timestamps. - - Obviously this depends on the number of execution units that are - available, and the scheduling priority of each thread involved in - the input handling, but it will be good enough for most people. */ - -static BLocker movement_locker; - +/* Variable where the popup menu thread returns the chosen menu + item. */ static BMessage volatile *popup_track_message; + +/* Variable in which alert dialog threads return the selected button + number. */ static int32 volatile alert_popup_value; + +/* The current window ID. This is increased every time a frame is + created. */ static int current_window_id; -static void *grab_view = NULL; +/* The view that has the passive grab. */ +static void *grab_view; + +/* The locker for that variable. */ static BLocker grab_view_locker; + +/* Whether or not a drag-and-drop operation is in progress. */ static bool drag_and_drop_in_progress; /* Many places require us to lock the child frame data, and then lock @@ -1279,7 +1280,7 @@ class EmacsWindow : public BWindow } void - Zoom (BPoint o, float w, float h) + Zoom (BPoint origin, float width, float height) { struct haiku_zoom_event rq; @@ -1366,11 +1367,7 @@ class EmacsMenuBar : public BMenuBar rq.y = std::lrint (point.y); rq.window = this->Window (); - if (movement_locker.Lock ()) - { - haiku_write (MENU_BAR_LEFT, &rq); - movement_locker.Unlock (); - } + haiku_write (MENU_BAR_LEFT, &rq); } BMenuBar::MouseMoved (point, transit, msg); @@ -1713,8 +1710,11 @@ class EmacsView : public BView struct haiku_mouse_motion_event rq; int32 windowid; EmacsWindow *window; + BToolTip *tooltip; window = (EmacsWindow *) Window (); + tooltip = ToolTip (); + rq.just_exited_p = transit == B_EXITED_VIEW; rq.x = point.x; rq.y = point.y; @@ -1729,9 +1729,9 @@ class EmacsView : public BView else rq.dnd_message = false; - if (ToolTip ()) - ToolTip ()->SetMouseRelativeLocation (BPoint (-(point.x - tt_absl_pos.x), - -(point.y - tt_absl_pos.y))); + if (tooltip) + tooltip->SetMouseRelativeLocation (BPoint (-(point.x - tt_absl_pos.x), + -(point.y - tt_absl_pos.y))); if (!grab_view_locker.Lock ()) gui_abort ("Couldn't lock grab view locker"); @@ -1744,11 +1744,7 @@ class EmacsView : public BView grab_view_locker.Unlock (); - if (movement_locker.Lock ()) - { - haiku_write (MOUSE_MOTION, &rq); - movement_locker.Unlock (); - } + haiku_write (MOUSE_MOTION, &rq); } void @@ -2224,11 +2220,7 @@ class EmacsScrollBar : public BScrollBar rq.y = std::lrint (conv.y); rq.window = this->Window (); - if (movement_locker.Lock ()) - { - haiku_write (MENU_BAR_LEFT, &rq); - movement_locker.Unlock (); - } + haiku_write (MENU_BAR_LEFT, &rq); } if (in_overscroll) diff --git a/src/haikuterm.c b/src/haikuterm.c index 47cffded48..628ef2b026 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -3348,18 +3348,17 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) previous_help_echo_string = help_echo_string; help_echo_string = Qnil; - /* A LeaveNotify event (well, the closest equivalent on Haiku, which - is a B_MOUSE_MOVED event with `transit' set to B_EXITED_VIEW) might - be sent out-of-order with regards to motion events from other - windows, such as when the mouse pointer rapidly moves from an - undecorated child frame to its parent. This can cause a failure to - clear the mouse face on the former if an event for the latter is - read by Emacs first and ends up showing the mouse face there. - - In case the `movement_locker' (also see the comment - there) doesn't take care of the problem, work - around it by clearing the mouse face now, if it is - currently shown on a different frame. */ + /* A crossing event might be sent out-of-order with + regard to motion events from other windows, such as + when the mouse pointer rapidly moves from an + undecorated child frame to its parent. This can + cause a failure to clear the mouse face on the + former if an event for the latter is read by Emacs + first and ends up showing the mouse face there. + + Work around the problem by clearing the mouse face + now if it is currently shown on a different + frame. */ if (hlinfo->mouse_face_hidden || (f != hlinfo->mouse_face_mouse_frame commit 2b63fabcd3a42ce336400909ca0fb09ec23a88ba Author: kobarity Date: Sun May 22 13:26:34 2022 +0200 Fix two typos in comments in python.el * lisp/progmodes/python.el (python-font-lock-keywords-maximum-decoration): Fix typos in comments (bug#55557). diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 94297d4ea5..c1368364a9 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -678,7 +678,7 @@ sign in chained assignment." ;; and variants thereof ;; the cases ;; (a) = 5 - ;; [a] = 5 + ;; [a] = 5, ;; [*a] = 5, 6 ;; are handled separately below (,(python-font-lock-assignment-matcher @@ -708,7 +708,7 @@ sign in chained assignment." (1 font-lock-variable-name-face)) ;; special cases ;; (a) = 5 - ;; [a] = 5 + ;; [a] = 5, ;; [*a] = 5, 6 (,(python-font-lock-assignment-matcher (python-rx (or line-start ?\; ?=) (* space) commit 959d041677205a370b21bc89503fa1d7e5a9bd6b Author: Damien Cassou Date: Sun May 22 08:32:38 2022 +0200 Fix submit-emacs-patch submit-emacs-patch creates a new message and immediately inserts new lines without first moving the point to the message body. This doesn't work with notmuch (and its notmuch-user-agent symbol) because the point starts in the headers and nothing in Emacs specifies that the mua should move point to the body automatically. * lisp/mail/emacsbug.el (submit-emacs-patch): Make sure point is in the body before inserting new lines (bug#55571). diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el index 8cb4a00009..df2b7a7453 100644 --- a/lisp/mail/emacsbug.el +++ b/lisp/mail/emacsbug.el @@ -516,6 +516,7 @@ Message buffer where you can explain more about the patch." (view-mode 1) (button-mode 1)) (message-mail-other-window report-emacs-bug-address subject) + (message-goto-body) (insert "\n\n\n") (emacs-bug--system-description) (mml-attach-file file "text/patch" nil "attachment") commit 35d0190b0b91c085c73bbe6c2b8e93ea8288b589 Author: Lele Gaifax Date: Sun May 22 10:44:31 2022 +0200 Properly indent Python PEP634 match/case blocks Python 3.10 introduced the "structural pattern matching" syntax, and commit 139042eb8629e6fd49b2c3002a8fc4d1aabd174d told font-lock about the new keywords. This adds them also as block-start statements, to enable proper indentation of such blocks. * lisp/progmodes/python.el (python-rx): Add "match" and "case" as block-start keywords. * test/lisp/progmodes/python-tests.el (python-indent-after-match-block, python-indent-after-case-block): New tests to verify indentation of "match" and "case" blocks (bug#55572). diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 0761aaebdc..94297d4ea5 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -362,6 +362,8 @@ This variant of `rx' supports common Python named REGEXPS." `(rx-let ((block-start (seq symbol-start (or "def" "class" "if" "elif" "else" "try" "except" "finally" "for" "while" "with" + ;; Python 3.10+ PEP634 + "match" "case" ;; Python 3.5+ PEP492 (and "async" (+ space) (or "def" "for" "with"))) diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el index ee7b66610a..a3f778bbbe 100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@ -1516,6 +1516,31 @@ this is an arbitrarily (should (string= (buffer-substring-no-properties (point-min) (point-max)) expected))))) +(ert-deftest python-indent-after-match-block () + "Test PEP634 match." + (python-tests-with-temp-buffer + " +match foo: +" + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (goto-char (point-max)) + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-after-case-block () + "Test PEP634 case." + (python-tests-with-temp-buffer + " +match foo: + case 1: +" + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (goto-char (point-max)) + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 8)))) + ;;; Filling commit ae8b1b8fd476b8c6240c1337c0c51763d4879ac9 Author: Po Lu Date: Sun May 22 17:15:10 2022 +0800 Implement `display-monitors-changed-functions' on MS Windows * src/w32term.c (w32_read_socket): Handle WM_DISPLAYCHANGE by sending monitor change events. diff --git a/src/w32term.c b/src/w32term.c index da7ac37972..373c5b5f78 100644 --- a/src/w32term.c +++ b/src/w32term.c @@ -5912,6 +5912,29 @@ w32_read_socket (struct terminal *terminal, (short) HIWORD (msg.msg.lParam))); } + /* According to the MS documentation, this message is sent + to each window whenever a monitor is added, removed, or + has its resolution change. Detect duplicate events when + there are multiple frames by ensuring only one event is + put in the keyboard buffer at any given time. */ + { + union buffered_input_event *ev; + + ev = (kbd_store_ptr == kbd_buffer + ? kbd_buffer + KBD_BUFFER_SIZE - 1 + : kbd_store_ptr - 1); + + if (kbd_store_ptr != kbd_fetch_ptr + && ev->ie.kind == MONITORS_CHANGED_EVENT + && XTERMINAL (ev->ie.arg) == dpyinfo->terminal) + /* Don't store a MONITORS_CHANGED_EVENT if there is + already an undelivered event on the queue. */ + break; + + inev.kind = MONITORS_CHANGED_EVENT; + XSETTERMINAL (inev.arg, dpyinfo->terminal); + } + check_visibility = 1; break; commit 73df958411e2b1c55f3e91b1ed747de0b2bcd59d Author: Po Lu Date: Sun May 22 15:56:11 2022 +0800 Fix uninitialized use of xm drag receiver data * src/xterm.c (xm_read_drag_receiver_info): Just return if the protocol is invalid. Reported by Jashank Jeremy . diff --git a/src/xterm.c b/src/xterm.c index c6c0a2f915..60c17f0371 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1995,6 +1995,9 @@ xm_read_drag_receiver_info (struct x_display_info *dpyinfo, { data = (uint8_t *) tmp_data; + if (data[1] > XM_DRAG_PROTOCOL_VERSION) + return 1; + rec->byteorder = data[0]; rec->protocol = data[1]; rec->protocol_style = data[2]; @@ -2013,9 +2016,6 @@ xm_read_drag_receiver_info (struct x_display_info *dpyinfo, rec->byteorder = XM_BYTE_ORDER_CUR_FIRST; } - if (data[1] > XM_DRAG_PROTOCOL_VERSION) - rc = 0; - if (tmp_data) XFree (tmp_data); commit 9988047f476763424b1e763118da5aa489aa5d7d Author: Po Lu Date: Sun May 22 15:33:50 2022 +0800 Fix build with --enable-check-lisp-object-type * src/xterm.c (handle_one_xevent): Fix use of Fequal. Reported by Jashank Jeremy . diff --git a/src/xterm.c b/src/xterm.c index 0487259bf0..c6c0a2f915 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -20159,8 +20159,8 @@ handle_one_xevent (struct x_display_info *dpyinfo, current_monitors = Fx_display_monitor_attributes_list (inev.ie.arg); - if (Fequal (current_monitors, - dpyinfo->last_monitor_attributes_list)) + if (!NILP (Fequal (current_monitors, + dpyinfo->last_monitor_attributes_list))) inev.ie.kind = NO_EVENT; dpyinfo->last_monitor_attributes_list = current_monitors; commit d97a04628ab3e277dcf55d2e7c274181bb323fe0 Author: Eli Zaretskii Date: Sun May 22 10:23:35 2022 +0300 ; Fix documentation of Tagalog * lisp/leim/quail/philippine.el ("tagalog"): * lisp/language/philippine.el ("Tagalog"): Fix doc string. (Bug#55529) diff --git a/lisp/language/philippine.el b/lisp/language/philippine.el index 4feb8fab63..28c4616af9 100644 --- a/lisp/language/philippine.el +++ b/lisp/language/philippine.el @@ -34,7 +34,7 @@ (input-method . "tagalog") (sample-text . "Tagalog (ᜊᜌ᜔ᜊᜌᜒᜈ᜔) ᜃᜓᜋᜓᜐ᜔ᜆ") (documentation . "\ -Tagalog which uses the Baybayin script is supported in +Tagalog language using the Baybayin script is supported in this language environment."))) ;; Tagalog composition rules diff --git a/lisp/leim/quail/philippine.el b/lisp/leim/quail/philippine.el index 6f11b317d6..8d8db8be5e 100644 --- a/lisp/leim/quail/philippine.el +++ b/lisp/leim/quail/philippine.el @@ -22,15 +22,16 @@ ;;; Commentary: -;; This input method supports scripts like Tagalog, Hanunoo, Buhid and -;; Tagbanwa. +;; Input methods for Philippine languages. ;;; Code: (require 'quail) +;; This input method supports languages like Tagalog, Hanunoo, Buhid and +;; Tagbanwa, using the Baybayin script. (quail-define-package - "tagalog" "Tagalog" "ᜊ" nil "Baybayin phonetic input method." + "tagalog" "Tagalog" "ᜊ" nil "Tagalog phonetic input method." nil t t t t nil nil nil nil nil t) (quail-define-rules commit 97ca793651eb04cda2ba33ea5d5d546274f358f7 Author: समीर सिंह Sameer Singh Date: Fri May 20 03:37:38 2022 +0530 Add support for the Tagalog script * lisp/language/philippine.el ("Tagalog"): New language environment. Add composition rules for Tagalog. Add sample text and input method. * lisp/international/fontset.el (script-representative-chars) (setup-default-fontset): Support Tagalog. * lisp/leim/quail/philippine.el ("tagalog"): New input method. * lisp/loadup.el: Preload lisp/language/philippine.el. * etc/HELLO: Add a Tagalog greeting. * etc/NEWS: Announce the new language environment and its input method. (Bug#55529) diff --git a/etc/HELLO b/etc/HELLO index dc5ac9a28e..2c4377388c 100644 --- a/etc/HELLO +++ b/etc/HELLO @@ -90,6 +90,7 @@ Swedish (svenska) Hej / Goddag / Hallå Syloti Nagri (ꠍꠤꠟꠐꠤ ꠘꠣꠉꠞꠤ) ꠀꠌ꠆ꠍꠣꠟꠣꠝꠥ ꠀꠟꠣꠁꠇꠥꠝ / ꠘꠝꠡ꠆ꠇꠣꠞ Tamil (தமிழ்) வணக்கம் Telugu (తెలుగు) నమస్కారం +Tagalog (ᜊᜌ᜔ᜊᜌᜒᜈ᜔) ᜃᜓᜋᜓᜐ᜔ᜆ TaiViet (ꪁꪫꪱꪣ ꪼꪕ) ꪅꪰꪙꫂ ꪨꪮꫂ ꪁꪫꪱ / ꪅꪽ ꪨꪷ ꪁꪫꪱ Thai (ภาษาไทย) สวัสดีครับ / สวัสดีค่ะ Tibetan (བོད་སྐད་) བཀྲ་ཤིས་བདེ་ལེགས༎ diff --git a/etc/NEWS b/etc/NEWS index 190620619f..4331968ba7 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -810,6 +810,7 @@ corresponding language environments are: **** Siddham script and language environment **** Syloti Nagri script and language environment **** Modi script and language environment +**** Baybayin script and Tagalog language environment --- *** The "Oriya" language environment was renamed to "Odia". diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el index 40499f42d0..1fcad765a1 100644 --- a/lisp/international/fontset.el +++ b/lisp/international/fontset.el @@ -182,6 +182,7 @@ (canadian-aboriginal #x14C0) (ogham #x168F) (runic #x16A0) + (tagalog #x1700) (khmer #x1780) (mongolian #x1826) (tai-le #x1950) @@ -748,6 +749,7 @@ cham ogham runic + tagalog symbol braille yi diff --git a/lisp/language/philippine.el b/lisp/language/philippine.el new file mode 100644 index 0000000000..4feb8fab63 --- /dev/null +++ b/lisp/language/philippine.el @@ -0,0 +1,59 @@ +;;; philippine.el --- Philippine languages support -*- coding: utf-8; lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: समीर सिंह Sameer Singh +;; Keywords: multilingual, input method, i18n, Philippines + +;; 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 . + +;;; Commentary: + +;; This file contains definitions of Philippine language environments, and +;; setups for displaying the scripts used there. + +;;; Code: + +(set-language-info-alist + "Tagalog" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "tagalog") + (sample-text . "Tagalog (ᜊᜌ᜔ᜊᜌᜒᜈ᜔) ᜃᜓᜋᜓᜐ᜔ᜆ") + (documentation . "\ +Tagalog which uses the Baybayin script is supported in +this language environment."))) + +;; Tagalog composition rules +(let ((akshara "[\x1700-\x1711\x171F]") + (vowel "[\x1712\x1713]") + (virama "\x1714") + (pamudpod "\x1715")) + (set-char-table-range composition-function-table + '(#x1714 . #x1714) + (list (vector + ;; Akshara virama syllables + (concat akshara virama vowel "?") + 1 'font-shape-gstring))) + (set-char-table-range composition-function-table + '(#x1715 . #x1715) + (list (vector + ;; Akshara pamudpod syllables + (concat akshara pamudpod vowel "?") + 1 'font-shape-gstring)))) + +(provide 'philippine) +;;; philippine.el ends here diff --git a/lisp/leim/quail/philippine.el b/lisp/leim/quail/philippine.el new file mode 100644 index 0000000000..6f11b317d6 --- /dev/null +++ b/lisp/leim/quail/philippine.el @@ -0,0 +1,65 @@ +;;; philippine.el --- Quail package for inputting Philippine characters -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: समीर सिंह Sameer Singh +;; Keywords: multilingual, input method, i18n, Philippines + +;; 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 . + +;;; Commentary: + +;; This input method supports scripts like Tagalog, Hanunoo, Buhid and +;; Tagbanwa. + +;;; Code: + +(require 'quail) + +(quail-define-package + "tagalog" "Tagalog" "ᜊ" nil "Baybayin phonetic input method." + nil t t t t nil nil nil nil nil t) + +(quail-define-rules + ("q" ?₱) + ("w" ?ᜏ) + ("r" ?ᜍ) + ("R" ?ᜟ) + ("t" ?ᜆ) + ("y" ?ᜌ) + ("u" ?ᜓ) + ("U" ?ᜂ) + ("i" ?ᜒ) + ("I" ?ᜁ) + ("p" ?ᜉ) + ("a" ?ᜀ) + ("s" ?ᜐ) + ("d" ?ᜇ) + ("f" ?᜔) + ("g" ?ᜄ) + ("h" ?ᜑ) + ("j" ?᜵) + ("J" ?᜶) + ("k" ?ᜃ) + ("l" ?ᜎ) + ("v" ?᜕) + ("b" ?ᜊ) + ("n" ?ᜈ) + ("N" ?ᜅ) + ("m" ?ᜋ)) + +(provide 'philippine) +;;; philippine.el ends here diff --git a/lisp/loadup.el b/lisp/loadup.el index 6ca699f901..9f1da4c0f9 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -245,6 +245,7 @@ (load "language/khmer") (load "language/burmese") (load "language/cham") +(load "language/philippine") (load "indent") (let ((max-specpdl-size (max max-specpdl-size 1800)))