commit e13689d55f4e3d445cf0457178a1508c0bb054be (HEAD, refs/remotes/origin/master) Author: Po Lu Date: Wed Apr 27 06:13:18 2022 +0000 Fix quitting application from the Deskbar on Haiku * lisp/term/haiku-win.el (handle-save-session): Kill Emacs afterwards. diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index 51a6c3c501..403c737c11 100644 --- a/lisp/term/haiku-win.el +++ b/lisp/term/haiku-win.el @@ -378,7 +378,10 @@ take effect on menu items until the menu bar is updated again." (let ((cancel-shutdown t)) (unwind-protect (setq cancel-shutdown (emacs-session-save)) - (haiku-save-session-reply (not cancel-shutdown))))) + (haiku-save-session-reply (not cancel-shutdown))) + ;; The App Server will kill Emacs after receiving the reply, but + ;; the Deskbar will not, so kill ourself here. + (unless cancel-shutdown (kill-emacs)))) (provide 'haiku-win) (provide 'term/haiku-win) commit 0bea75c95a7e59c50be437956916cc0835655575 Author: Po Lu Date: Wed Apr 27 05:18:50 2022 +0000 Add simple session management support to Haiku * lisp/term/common-win.el (emacs-save-session-functions): Move from x-win.el to common-win.el. * lisp/term/haiku-win.el (haiku-save-session-reply) (emacs-session-save, handle-save-session): New functions. * lisp/term/x-win.el (emacs-save-session-functions): Delete. * src/haiku_font_support.cc (font_style_to_flags): * src/haiku_support.h (enum haiku_font_weight): Turn weight macros into enum. (struct haiku_font_pattern): Likewise. (struct haiku_session_manager_reply): New struct. * src/haiku_io.c (haiku_io_init): Create sm port. * src/haiku_support.cc (QuitRequested): Wait for reply from sm port. * src/haikufns.c (Fhaiku_save_session_reply): New function. (syms_of_haikufns): Define new subr. * src/haikuterm.c (haiku_read_socket): Send session management events. (haiku_term_init): Check new port. diff --git a/lisp/term/common-win.el b/lisp/term/common-win.el index 7a48fc04c6..b219014a73 100644 --- a/lisp/term/common-win.el +++ b/lisp/term/common-win.el @@ -419,6 +419,16 @@ the operating system.") (setq defined-colors (cons this-color defined-colors)))) defined-colors))) +;;;; Session management. + +(defvar emacs-save-session-functions nil + "Special hook run when a save-session event occurs. +The functions do not get any argument. +Functions can return non-nil to inform the session manager that the +window system shutdown should be aborted. + +See also `emacs-session-save'.") + (provide 'term/common-win) ;;; common-win.el ends here diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index c83e0a5c3d..51a6c3c501 100644 --- a/lisp/term/haiku-win.el +++ b/lisp/term/haiku-win.el @@ -358,6 +358,28 @@ take effect on menu items until the menu bar is updated again." (add-variable-watcher 'use-system-tooltips #'haiku-use-system-tooltips-watcher) + +;;;; Session management. + +(declare-function haiku-save-session-reply "haikufns.c") + +(defun emacs-session-save () + "SKIP: real doc in x-win.el." + (with-temp-buffer ; Saving sessions is not yet supported. + (condition-case nil + ;; A return of t means cancel the shutdown. + (run-hook-with-args-until-success + 'emacs-save-session-functions) + (error t)))) + +(defun handle-save-session (_event) + "SKIP: real doc in xsmfns.c." + (interactive "e") + (let ((cancel-shutdown t)) + (unwind-protect + (setq cancel-shutdown (emacs-session-save)) + (haiku-save-session-reply (not cancel-shutdown))))) + (provide 'haiku-win) (provide 'term/haiku-win) diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el index 4c6fcc904c..ca38a0a8c9 100644 --- a/lisp/term/x-win.el +++ b/lisp/term/x-win.el @@ -109,14 +109,6 @@ (setq x-session-previous-id (car x-invocation-args) x-invocation-args (cdr x-invocation-args))) -(defvar emacs-save-session-functions nil - "Special hook run when a save-session event occurs. -The functions do not get any argument. -Functions can return non-nil to inform the session manager that the -window system shutdown should be aborted. - -See also `emacs-session-save'.") - (defun emacs-session-filename (session-id) "Construct a filename to save the session in based on SESSION-ID. Return a filename in `user-emacs-directory', unless the session file diff --git a/src/haiku_font_support.cc b/src/haiku_font_support.cc index 8da2437d66..9acdd652e3 100644 --- a/src/haiku_font_support.cc +++ b/src/haiku_font_support.cc @@ -292,10 +292,11 @@ font_style_to_flags (char *st, struct haiku_font_pattern *pattern) { char *style = strdup (st); char *token; - pattern->weight = -1; + int tok = 0; + + pattern->weight = NO_WEIGHT; pattern->width = NO_WIDTH; pattern->slant = NO_SLANT; - int tok = 0; while ((token = std::strtok (!tok ? style : NULL, " ")) && tok < 3) { @@ -317,7 +318,7 @@ font_style_to_flags (char *st, struct haiku_font_pattern *pattern) if (pattern->width == NO_WIDTH) pattern->width = NORMAL_WIDTH; - if (pattern->weight == -1) + if (pattern->weight == NO_WEIGHT) pattern->weight = HAIKU_REGULAR; } else if (token && (!strcmp (token, "SemiBold") @@ -370,7 +371,7 @@ font_style_to_flags (char *st, struct haiku_font_pattern *pattern) tok++; } - if (pattern->weight != -1) + if (pattern->weight != NO_WEIGHT) pattern->specified |= FSPEC_WEIGHT; if (pattern->slant != NO_SLANT) pattern->specified |= FSPEC_SLANT; diff --git a/src/haiku_io.c b/src/haiku_io.c index 1830ac01e5..0db5d26314 100644 --- a/src/haiku_io.c +++ b/src/haiku_io.c @@ -40,10 +40,15 @@ port_id port_application_to_emacs; thread to Emacs. */ port_id port_popup_menu_to_emacs; +/* The port used to send replies to the application after a session + management event. */ +port_id port_emacs_to_session_manager; + void haiku_io_init (void) { port_application_to_emacs = create_port (PORT_CAP, "application emacs port"); + port_emacs_to_session_manager = create_port (1, "session manager port"); } static ssize_t diff --git a/src/haiku_support.cc b/src/haiku_support.cc index f19631a22a..b2edcd3099 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -453,8 +453,18 @@ class Emacs : public BApplication QuitRequested (void) { struct haiku_app_quit_requested_event rq; + struct haiku_session_manager_reply reply; + int32 reply_type; + haiku_write (APP_QUIT_REQUESTED_EVENT, &rq); - return 0; + + if (read_port (port_emacs_to_session_manager, + &reply_type, &reply, sizeof reply) < B_OK) + /* Return true so the system kills us, since there's no real + alternative if this read fails. */ + return true; + + return reply.quit_reply; } void diff --git a/src/haiku_support.h b/src/haiku_support.h index 6660b011a6..d442635476 100644 --- a/src/haiku_support.h +++ b/src/haiku_support.h @@ -286,6 +286,26 @@ enum haiku_font_language MAX_LANGUAGE /* This isn't a language. */ }; +enum haiku_font_weight + { + NO_WEIGHT = -1, + HAIKU_THIN = 0, + HAIKU_ULTRALIGHT = 20, + HAIKU_EXTRALIGHT = 40, + HAIKU_LIGHT = 50, + HAIKU_SEMI_LIGHT = 75, + HAIKU_REGULAR = 100, + HAIKU_SEMI_BOLD = 180, + HAIKU_BOLD = 200, + HAIKU_EXTRA_BOLD = 205, + HAIKU_ULTRA_BOLD = 210, + HAIKU_BOOK = 400, + HAIKU_HEAVY = 800, + HAIKU_ULTRA_HEAVY = 900, + HAIKU_BLACK = 1000, + HAIKU_MEDIUM = 2000, + }; + struct haiku_font_pattern { int specified; @@ -297,13 +317,13 @@ struct haiku_font_pattern struct haiku_font_pattern *next_family; haiku_font_family_or_style family; haiku_font_family_or_style style; - int weight; int mono_spacing_p; int want_chars_len; int need_one_of_len; enum haiku_font_slant slant; enum haiku_font_width width; enum haiku_font_language language; + enum haiku_font_weight weight; int *wanted_chars; int *need_one_of; @@ -349,21 +369,10 @@ struct haiku_menu_bar_state_event void *window; }; -#define HAIKU_THIN 0 -#define HAIKU_ULTRALIGHT 20 -#define HAIKU_EXTRALIGHT 40 -#define HAIKU_LIGHT 50 -#define HAIKU_SEMI_LIGHT 75 -#define HAIKU_REGULAR 100 -#define HAIKU_SEMI_BOLD 180 -#define HAIKU_BOLD 200 -#define HAIKU_EXTRA_BOLD 205 -#define HAIKU_ULTRA_BOLD 210 -#define HAIKU_BOOK 400 -#define HAIKU_HEAVY 800 -#define HAIKU_ULTRA_HEAVY 900 -#define HAIKU_BLACK 1000 -#define HAIKU_MEDIUM 2000 +struct haiku_session_manager_reply +{ + bool quit_reply; +}; #ifdef __cplusplus /* Haiku's built in Height and Width functions for calculating @@ -420,6 +429,7 @@ extern unsigned long haiku_get_pixel (haiku, int, int); extern port_id port_application_to_emacs; extern port_id port_popup_menu_to_emacs; +extern port_id port_emacs_to_session_manager; extern void haiku_io_init (void); extern void haiku_io_init_in_app_thread (void); diff --git a/src/haikufns.c b/src/haikufns.c index ae0f442a21..7ec6f576cf 100644 --- a/src/haikufns.c +++ b/src/haikufns.c @@ -66,6 +66,8 @@ static Lisp_Object tip_last_parms; static void haiku_explicitly_set_name (struct frame *, Lisp_Object, Lisp_Object); static void haiku_set_title (struct frame *, Lisp_Object, Lisp_Object); + +/* The number of references to an image cache. */ static ptrdiff_t image_cache_refcount; static Lisp_Object @@ -2604,7 +2606,7 @@ means that if both frames are visible and the display areas of these frames overlap, FRAME1 (partially) obscures FRAME2. Some window managers may refuse to restack windows. */) - (Lisp_Object frame1, Lisp_Object frame2, Lisp_Object above) + (Lisp_Object frame1, Lisp_Object frame2, Lisp_Object above) { struct frame *f1 = decode_window_system_frame (frame1); struct frame *f2 = decode_window_system_frame (frame2); @@ -2653,6 +2655,28 @@ Some window managers may refuse to restack windows. */) return Qnil; } +DEFUN ("haiku-save-session-reply", Fhaiku_save_session_reply, + Shaiku_save_session_reply, 1, 1, 0, + doc: /* Reply to a `save-session' event. +QUIT-REPLY means whether or not all files were saved and program +termination should proceed. + +Calls to this function must be balanced by the amount of +`save-session' events received. This is done automatically, so do not +call this function yourself. */) + (Lisp_Object quit_reply) +{ + struct haiku_session_manager_reply reply; + reply.quit_reply = !NILP (quit_reply); + + block_input (); + write_port (port_emacs_to_session_manager, 0, &reply, + sizeof reply); + unblock_input (); + + return Qnil; +} + frame_parm_handler haiku_frame_parm_handlers[] = { gui_set_autoraise, @@ -2750,6 +2774,7 @@ syms_of_haikufns (void) defsubr (&Shaiku_frame_list_z_order); defsubr (&Sx_display_save_under); defsubr (&Shaiku_frame_restack); + defsubr (&Shaiku_save_session_reply); tip_timer = Qnil; staticpro (&tip_timer); diff --git a/src/haikuterm.c b/src/haikuterm.c index 86266424c4..5d5e48c391 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -3662,6 +3662,9 @@ haiku_read_socket (struct terminal *terminal, struct input_event *hold_quit) break; } case APP_QUIT_REQUESTED_EVENT: + inev.kind = SAVE_SESSION_EVENT; + inev.arg = Qt; + break; case KEY_UP: case DUMMY_EVENT: default: @@ -3962,15 +3965,14 @@ haiku_term_init (void) void *name_buffer; block_input (); - Fset_input_interrupt_mode (Qt); + Fset_input_interrupt_mode (Qt); baud_rate = 19200; - dpyinfo = xzalloc (sizeof *dpyinfo); - haiku_io_init (); - if (port_application_to_emacs < B_OK) + if (port_application_to_emacs < B_OK + || port_emacs_to_session_manager < B_OK) emacs_abort (); color_file = Fexpand_file_name (build_string ("rgb.txt"), commit f1e11deca641c3fd6d571afb6b8618143a16d226 Author: Michael Albinus Date: Wed Apr 27 07:07:21 2022 +0200 ; Instrument tramp-test46-read-password diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index a5058f92ef..b27b735eb5 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -7308,7 +7308,8 @@ process sentinels. They shall not disturb each other." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-mock-p)) - (let ((pass "aaaa") + (tramp--test-instrument-test-case 10 + (let ((pass "secret") (mock-entry (copy-sequence (assoc "mock" tramp-methods))) mocked-input tramp-methods) ;; We must mock `read-string', in order to avoid interactive @@ -7354,7 +7355,7 @@ process sentinels. They shall not disturb each other." "machine %s port mock password %s" (file-remote-p tramp-test-temporary-file-directory 'host) pass) (let ((auth-sources `(,netrc-file))) - (should (file-exists-p tramp-test-temporary-file-directory))))))))) + (should (file-exists-p tramp-test-temporary-file-directory)))))))))) ;; This test is inspired by Bug#29163. (ert-deftest tramp-test47-auto-load () commit 8c2ea3a7086353ab2e62e70f8fc7567d8cd75f7a Author: Paul Eggert Date: Tue Apr 26 21:03:21 2022 -0700 Avoid change to desktop file format * lisp/desktop.el (desktop--get-file-modtime): New function. (desktop-save, desktop-read): Use it. diff --git a/lisp/desktop.el b/lisp/desktop.el index baa3f32970..f41a41c3c3 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -645,6 +645,14 @@ Only valid during frame saving & restoring; intended for internal use.") "When the desktop file was last modified to the knowledge of this Emacs. Used to detect desktop file conflicts.") +(defun desktop--get-file-modtime () + "Get desktop file modtime, in list form for desktop format version 208." + (setq desktop-file-modtime + (time-convert (file-attribute-modification-time + (file-attributes + (desktop-full-file-name))) + 'list))) + (defvar desktop-var-serdes-funs (list (list 'mark-ring @@ -1221,9 +1229,7 @@ no questions asked." (write-region (point-min) (point-max) (desktop-full-file-name) nil 'nomessage)) (setq desktop-file-checksum checksum) ;; We remember when it was modified (which is presumably just now). - (setq desktop-file-modtime (file-attribute-modification-time - (file-attributes - (desktop-full-file-name))))))))))) + (desktop--get-file-modtime)))))))) ;; ---------------------------------------------------------------------------- ;;;###autoload @@ -1332,9 +1338,7 @@ It returns t if a desktop file was loaded, nil otherwise. 'window-configuration-change-hook))) (desktop-auto-save-disable) ;; Evaluate desktop buffer and remember when it was modified. - (setq desktop-file-modtime (file-attribute-modification-time - (file-attributes - (desktop-full-file-name)))) + (desktop--get-file-modtime) (load (desktop-full-file-name) t t t) ;; If it wasn't already, mark it as in-use, to bother other ;; desktop instances. commit b568a41a5e7a8e0c81b688e46b6dc37fdbde80de Author: Paul Eggert Date: Tue Apr 26 18:10:51 2022 -0700 Be more compatible with older desktops * lisp/desktop.el (desktop-save): When comparing timestamps use time-equal-p instead of ‘equal’. diff --git a/lisp/desktop.el b/lisp/desktop.el index cd581e028b..baa3f32970 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -1121,7 +1121,7 @@ no questions asked." (file-attributes (desktop-full-file-name))))) (when (or (not new-modtime) ; nothing to overwrite - (equal desktop-file-modtime new-modtime) + (time-equal-p desktop-file-modtime new-modtime) (yes-or-no-p (if desktop-file-modtime (if (time-less-p desktop-file-modtime new-modtime) commit 655b3e009b8a01b027da16fbaf36f5cde14271fe Author: Po Lu Date: Wed Apr 27 09:10:18 2022 +0800 Clean up pointer blanking code * src/xterm.c (XTtoggle_invisible_pointer): Dispatch to correct function directly. (x_probe_xfixes_extension): Return directly based on dpyinfo. (xfixes_toggle_visible_pointer): Make conditional on `HAVE_XFIXES'. (make_invisible_cursor): Initialize `c' correctly. (x_toggle_visible_pointer): Handle cursor allocation failures. (x_free_frame_resources): Dispatch with XTtoggle_visible_pointer. (x_setup_pointer_blanking): Delete function. (x_term_init): Initialize blank cursor here instead. * src/xterm.h (struct x_display_info): New field `fixes_pointer_blanking'. diff --git a/src/xterm.c b/src/xterm.c index 56add92f8b..891a242012 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -8947,16 +8947,6 @@ XTflash (struct frame *f) unblock_input (); } - -static void -XTtoggle_invisible_pointer (struct frame *f, bool invisible) -{ - block_input (); - FRAME_DISPLAY_INFO (f)->toggle_visible_pointer (f, invisible); - unblock_input (); -} - - /* Make audible bell. */ static void @@ -9300,6 +9290,105 @@ x_new_focus_frame (struct x_display_info *dpyinfo, struct frame *frame) x_frame_rehighlight (dpyinfo); } +/* True if the display in DPYINFO supports a version of Xfixes + sufficient for pointer blanking. */ +#ifdef HAVE_XFIXES +static bool +x_probe_xfixes_extension (struct x_display_info *dpyinfo) +{ + return (dpyinfo->xfixes_supported_p + && dpyinfo->xfixes_major >= 4); +} +#endif /* HAVE_XFIXES */ + +/* Toggle mouse pointer visibility on frame F using the XFixes + extension. */ +#ifdef HAVE_XFIXES +static void +xfixes_toggle_visible_pointer (struct frame *f, bool invisible) + +{ + if (invisible) + XFixesHideCursor (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f)); + else + XFixesShowCursor (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f)); + f->pointer_invisible = invisible; +} +#endif /* HAVE_XFIXES */ + +/* Create invisible cursor on the X display referred by DPYINFO. */ +static Cursor +make_invisible_cursor (struct x_display_info *dpyinfo) +{ + Display *dpy = dpyinfo->display; + static char const no_data[] = { 0 }; + Pixmap pix; + XColor col; + Cursor c; + + c = None; + + x_catch_errors (dpy); + pix = XCreateBitmapFromData (dpy, dpyinfo->root_window, no_data, 1, 1); + if (!x_had_errors_p (dpy) && pix != None) + { + Cursor pixc; + col.pixel = 0; + col.red = col.green = col.blue = 0; + col.flags = DoRed | DoGreen | DoBlue; + pixc = XCreatePixmapCursor (dpy, pix, pix, &col, &col, 0, 0); + if (! x_had_errors_p (dpy) && pixc != None) + c = pixc; + XFreePixmap (dpy, pix); + } + + x_uncatch_errors (); + + return c; +} + +/* Toggle mouse pointer visibility on frame F by using an invisible + cursor. */ +static void +x_toggle_visible_pointer (struct frame *f, bool invisible) +{ + struct x_display_info *dpyinfo; + + dpyinfo = FRAME_DISPLAY_INFO (f); + + /* We could have gotten a BadAlloc error while creating the + invisible cursor. Try to create it again, but if that fails, + just give up. */ + if (dpyinfo->invisible_cursor == None) + dpyinfo->invisible_cursor = make_invisible_cursor (dpyinfo); + + if (dpyinfo->invisible_cursor == None) + invisible = false; + + if (invisible) + XDefineCursor (dpyinfo->display, FRAME_X_WINDOW (f), + dpyinfo->invisible_cursor); + else + XDefineCursor (dpyinfo->display, FRAME_X_WINDOW (f), + f->output_data.x->current_cursor); + + f->pointer_invisible = invisible; +} + +static void +XTtoggle_invisible_pointer (struct frame *f, bool invisible) +{ + block_input (); +#ifdef HAVE_XFIXES + if (FRAME_DISPLAY_INFO (f)->fixes_pointer_blanking + && x_probe_xfixes_extension (FRAME_DISPLAY_INFO (f))) + xfixes_toggle_visible_pointer (f, invisible); + else +#endif + x_toggle_visible_pointer (f, invisible); + unblock_input (); +} + /* Handle FocusIn and FocusOut state changes for FRAME. If FRAME has focus and there exists more than one frame, puts a FOCUS_IN_EVENT into *BUFP. */ @@ -22032,7 +22121,7 @@ x_free_frame_resources (struct frame *f) /* Always exit with visible pointer to avoid weird issue with Xfixes (Bug#17609). */ if (f->pointer_invisible) - FRAME_DISPLAY_INFO (f)->toggle_visible_pointer (f, 0); + XTtoggle_invisible_pointer (f, 0); /* We must free faces before destroying windows because some font-driver (e.g. xft) access a window while finishing a @@ -22652,100 +22741,6 @@ my_log_handler (const gchar *log_domain, GLogLevelFlags log_level, } #endif -/* Create invisible cursor on X display referred by DPYINFO. */ - -static Cursor -make_invisible_cursor (struct x_display_info *dpyinfo) -{ - Display *dpy = dpyinfo->display; - static char const no_data[] = { 0 }; - Pixmap pix; - XColor col; - Cursor c = 0; - - x_catch_errors (dpy); - pix = XCreateBitmapFromData (dpy, dpyinfo->root_window, no_data, 1, 1); - if (! x_had_errors_p (dpy) && pix != None) - { - Cursor pixc; - col.pixel = 0; - col.red = col.green = col.blue = 0; - col.flags = DoRed | DoGreen | DoBlue; - pixc = XCreatePixmapCursor (dpy, pix, pix, &col, &col, 0, 0); - if (! x_had_errors_p (dpy) && pixc != None) - c = pixc; - XFreePixmap (dpy, pix); - } - - x_uncatch_errors (); - - return c; -} - -/* True if DPY supports Xfixes extension >= 4. */ - -static bool -x_probe_xfixes_extension (Display *dpy) -{ -#ifdef HAVE_XFIXES - struct x_display_info *info - = x_display_info_for_display (dpy); - - return (info - && info->xfixes_supported_p - && info->xfixes_major >= 4); -#else - return false; -#endif /* HAVE_XFIXES */ -} - -/* Toggle mouse pointer visibility on frame F by using Xfixes functions. */ - -static void -xfixes_toggle_visible_pointer (struct frame *f, bool invisible) -{ -#ifdef HAVE_XFIXES - if (invisible) - XFixesHideCursor (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f)); - else - XFixesShowCursor (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f)); - f->pointer_invisible = invisible; -#else - emacs_abort (); -#endif /* HAVE_XFIXES */ -} - -/* Toggle mouse pointer visibility on frame F by using invisible cursor. */ - -static void -x_toggle_visible_pointer (struct frame *f, bool invisible) -{ - eassert (FRAME_DISPLAY_INFO (f)->invisible_cursor != 0); - if (invisible) - XDefineCursor (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), - FRAME_DISPLAY_INFO (f)->invisible_cursor); - else - XDefineCursor (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), - f->output_data.x->current_cursor); - f->pointer_invisible = invisible; -} - -/* Setup pointer blanking, prefer Xfixes if available. */ - -static void -x_setup_pointer_blanking (struct x_display_info *dpyinfo) -{ - /* FIXME: the brave tester should set EMACS_XFIXES because we're suspecting - X server bug, see https://debbugs.gnu.org/cgi/bugreport.cgi?bug=17609. */ - if (egetenv ("EMACS_XFIXES") && x_probe_xfixes_extension (dpyinfo->display)) - dpyinfo->toggle_visible_pointer = xfixes_toggle_visible_pointer; - else - { - dpyinfo->toggle_visible_pointer = x_toggle_visible_pointer; - dpyinfo->invisible_cursor = make_invisible_cursor (dpyinfo); - } -} - /* Current X display connection identifier. Incremented for each next connection established. */ static unsigned x_display_id; @@ -23630,7 +23625,10 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) gray_bits, gray_width, gray_height, 1, 0, 1); - x_setup_pointer_blanking (dpyinfo); + dpyinfo->invisible_cursor = make_invisible_cursor (dpyinfo); +#ifdef HAVE_XFIXES + dpyinfo->fixes_pointer_blanking = egetenv ("EMACS_XFIXES"); +#endif #ifdef HAVE_X_I18N xim_initialize (dpyinfo, resource_name); diff --git a/src/xterm.h b/src/xterm.h index 37dfa57947..65349834c9 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -321,8 +321,10 @@ struct x_display_info Unused if this display supports Xfixes extension. */ Cursor invisible_cursor; - /* Function used to toggle pointer visibility on this display. */ - void (*toggle_visible_pointer) (struct frame *, bool); +#ifdef HAVE_XFIXES + /* Whether or not to use Xfixes for pointer blanking. */ + bool fixes_pointer_blanking; +#endif #ifdef USE_GTK /* The GDK cursor for scroll bars and popup menus. */ commit 92e49944a39ce6372a80430f65913c4c8b531677 Author: Stefan Monnier Date: Tue Apr 26 17:09:03 2022 -0400 nadvice.el: Auto-generate the doc describing the "how" arg * lisp/emacs-lisp/nadvice.el (advice--make-how-alist): New macro. (advice--how-alist): Use it. (nadvice--make-docstring): New function. (add-function, advice-add): Use it to auto-generate the table describing the accepted values for `how`. diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index efc345c62c..b3778c07bc 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -48,31 +48,41 @@ (:copier advice--copy (car cdr how props))) car cdr how props) +(eval-when-compile + (defmacro advice--make-how-alist (&rest args) + `(list + ,@(mapcar + (lambda (arg) + (pcase-let ((`(,how . ,body) arg)) + `(list ,how + (oclosure-lambda (advice (how ,how)) (&rest r) + ,@body) + ,(replace-regexp-in-string + "\\" "FUNCTION" + (replace-regexp-in-string + "\\" "OLDFUN" + (format "%S" `(lambda (&rest r) ,@body)) + t t) + t t)))) + args)))) + ;;;; Lightweight advice/hook (defvar advice--how-alist - `((:around ,(oclosure-lambda (advice (how :around)) (&rest args) - (apply car cdr args))) - (:before ,(oclosure-lambda (advice (how :before)) (&rest args) - (apply car args) (apply cdr args))) - (:after ,(oclosure-lambda (advice (how :after)) (&rest args) - (apply cdr args) (apply car args))) - (:override ,(oclosure-lambda (advice (how :override)) (&rest args) - (apply car args))) - (:after-until ,(oclosure-lambda (advice (how :after-until)) (&rest args) - (or (apply cdr args) (apply car args)))) - (:after-while ,(oclosure-lambda (advice (how :after-while)) (&rest args) - (and (apply cdr args) (apply car args)))) - (:before-until ,(oclosure-lambda (advice (how :before-until)) (&rest args) - (or (apply car args) (apply cdr args)))) - (:before-while ,(oclosure-lambda (advice (how :before-while)) (&rest args) - (and (apply car args) (apply cdr args)))) - (:filter-args ,(oclosure-lambda (advice (how :filter-args)) (&rest args) - (apply cdr (funcall car args)))) - (:filter-return ,(oclosure-lambda (advice (how :filter-return)) (&rest args) - (funcall car (apply cdr args))))) + (advice--make-how-alist + (:around (apply car cdr r)) + (:before (apply car r) (apply cdr r)) + (:after (apply cdr r) (apply car r)) + (:override (apply car r)) + (:after-until (or (apply cdr r) (apply car r))) + (:after-while (and (apply cdr r) (apply car r))) + (:before-until (or (apply car r) (apply cdr r))) + (:before-while (and (apply car r) (apply cdr r))) + (:filter-args (apply cdr (funcall car r))) + (:filter-return (funcall car (apply cdr r)))) "List of descriptions of how to add a function. -Each element has the form (HOW OCL) where HOW is a keyword and -OCL is a \"prototype\" function of type `advice'.") +Each element has the form (HOW OCL DOC) where HOW is a keyword, +OCL is a \"prototype\" function of type `advice', and +DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") (defun advice--cd*r (f) (while (advice--p f) @@ -276,6 +286,29 @@ different, but `function-equal' will hopefully ignore those differences.") ((symbolp place) `(default-value ',place)) (t place)))) +(defun nadvice--make-docstring (sym) + (let* ((main (documentation (symbol-function sym) 'raw)) + (ud (help-split-fundoc main 'pcase)) + (doc (or (cdr ud) main)) + (col1width (apply #'max (mapcar (lambda (x) + (string-width (symbol-name (car x)))) + advice--how-alist))) + (table (mapconcat (lambda (x) + (format (format " %%-%ds %%s" col1width) + (car x) (nth 2 x))) + advice--how-alist "\n")) + (table (if global-prettify-symbols-mode + (replace-regexp-in-string "(lambda\\>" "(λ" table t t) + table)) + (combined-doc + (if (not (string-match "<<>>" doc)) + doc + (replace-match table t t doc)))) + (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))) + +(put 'add-function 'function-documentation + '(nadvice--make-docstring 'add-function)) + ;;;###autoload (defmacro add-function (how place function &optional props) ;; TODO: @@ -292,16 +325,7 @@ FUNCTION describes the code to add. HOW describes how to add it. HOW can be explained by showing the resulting new function, as the result of combining FUNCTION and the previous value of PLACE, which we call OLDFUN here: -`:before' (lambda (&rest r) (apply FUNCTION r) (apply OLDFUN r)) -`:after' (lambda (&rest r) (prog1 (apply OLDFUN r) (apply FUNCTION r))) -`:around' (lambda (&rest r) (apply FUNCTION OLDFUN r)) -`:override' (lambda (&rest r) (apply FUNCTION r)) -`:before-while' (lambda (&rest r) (and (apply FUNCTION r) (apply OLDFUN r))) -`:before-until' (lambda (&rest r) (or (apply FUNCTION r) (apply OLDFUN r))) -`:after-while' (lambda (&rest r) (and (apply OLDFUN r) (apply FUNCTION r))) -`:after-until' (lambda (&rest r) (or (apply OLDFUN r) (apply FUNCTION r))) -`:filter-args' (lambda (&rest r) (apply OLDFUN (funcall FUNCTION r))) -`:filter-return'(lambda (&rest r) (funcall FUNCTION (apply OLDFUN r))) +<<>> If FUNCTION was already added, do nothing. PROPS is an alist of additional properties, among which the following have a special meaning: @@ -458,11 +482,16 @@ of the piece of advice." (put symbol 'advice--pending (advice--subst-main oldadv nil))) (funcall fsetfun symbol newdef)))) +(put 'advice-add 'function-documentation + '(nadvice--make-docstring 'advice-add)) + ;;;###autoload (defun advice-add (symbol how function &optional props) "Like `add-function' but for the function named SYMBOL. Contrary to `add-function', this will properly handle the cases where SYMBOL -is defined as a macro, alias, command, ..." +is defined as a macro, alias, command, ... +HOW can be one of: +<<>>" ;; TODO: ;; - record the advice location, to display in describe-function. ;; - change all defadvice in lisp/**/*.el. @@ -483,7 +512,7 @@ is defined as a macro, alias, command, ..." (get symbol 'advice--pending)) (t (symbol-function symbol))) function props) - ;; FIXME: We could use a defmethod on `function-docstring' instead, + ;; FIXME: We could use a defmethod on `function-documentation' instead, ;; except when (or (not nf) (autoloadp nf))! (put symbol 'function-documentation `(advice--make-docstring ',symbol)) (add-function :around (get symbol 'defalias-fset-function) commit f30625943edefbd88ebf84acbc254ed88db27beb Author: Stefan Monnier Date: Tue Apr 26 16:39:41 2022 -0400 nadvice.el: Use OClosures * lisp/emacs-lisp/nadvice.el (advice): New OClosure type. (advice--how-alist): Make it hold prototype OClosures rather than bytecode strings. (advice--bytecodes): Delete var. (advice--where): Make it an obsolete alias of new `advice--how`. (oclosure-interactive-form, cl-print-object) : New methods. (advice--make-1): Delete function. (advice--make): Use `advice-copy` and `advice-cons`. (advice--tweak): Use `advice-cons`. (add-function, advice-add): Rename `where` arg to `how`. * lisp/emacs-lisp/cl-print.el (cl-print-object) <:extra "nadvice">: Remove now-redundant ad-hoc method. * test/lisp/emacs-lisp/nadvice-tests.el (advice-test-print): New test. diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index 457ef506bc..30d7e6525a 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -221,27 +221,6 @@ into a button whose action shows the function's disassembly.") 'byte-code-function object))))) (princ ")" stream)) -;; This belongs in nadvice.el, of course, but some load-ordering issues make it -;; complicated: cl-generic uses macros from cl-macs and cl-macs uses advice-add -;; from nadvice, so nadvice needs to be loaded before cl-generic and hence -;; can't use cl-defmethod. -(cl-defmethod cl-print-object :extra "nadvice" - ((object compiled-function) stream) - (if (not (advice--p object)) - (cl-call-next-method) - (princ "#f(advice-wrapper " stream) - (when (fboundp 'advice--how) - (princ (advice--how object) stream) - (princ " " stream)) - (cl-print-object (advice--cdr object) stream) - (princ " " stream) - (cl-print-object (advice--car object) stream) - (let ((props (advice--props object))) - (when props - (princ " " stream) - (cl-print-object props stream))) - (princ ")" stream))) - ;; This belongs in oclosure.el, of course, but some load-ordering issues make it ;; complicated. (cl-defmethod cl-print-object ((object accessor) stream) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index be6eafd1b6..efc345c62c 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -42,36 +42,37 @@ ;; as this one), so we have to do it by hand! (push (purecopy '(nadvice 1 0)) package--builtin-versions) +(oclosure-define (advice + (:predicate advice--p) + (:copier advice--cons (cdr)) + (:copier advice--copy (car cdr how props))) + car cdr how props) + ;;;; Lightweight advice/hook (defvar advice--how-alist - '((:around "\300\301\302\003#\207" 5) - (:before "\300\301\002\"\210\300\302\002\"\207" 4) - (:after "\300\302\002\"\300\301\003\"\210\207" 5) - (:override "\300\301\002\"\207" 4) - (:after-until "\300\302\002\"\206\013\000\300\301\002\"\207" 4) - (:after-while "\300\302\002\"\205\013\000\300\301\002\"\207" 4) - (:before-until "\300\301\002\"\206\013\000\300\302\002\"\207" 4) - (:before-while "\300\301\002\"\205\013\000\300\302\002\"\207" 4) - (:filter-args "\300\302\301\003!\"\207" 5) - (:filter-return "\301\300\302\003\"!\207" 5)) + `((:around ,(oclosure-lambda (advice (how :around)) (&rest args) + (apply car cdr args))) + (:before ,(oclosure-lambda (advice (how :before)) (&rest args) + (apply car args) (apply cdr args))) + (:after ,(oclosure-lambda (advice (how :after)) (&rest args) + (apply cdr args) (apply car args))) + (:override ,(oclosure-lambda (advice (how :override)) (&rest args) + (apply car args))) + (:after-until ,(oclosure-lambda (advice (how :after-until)) (&rest args) + (or (apply cdr args) (apply car args)))) + (:after-while ,(oclosure-lambda (advice (how :after-while)) (&rest args) + (and (apply cdr args) (apply car args)))) + (:before-until ,(oclosure-lambda (advice (how :before-until)) (&rest args) + (or (apply car args) (apply cdr args)))) + (:before-while ,(oclosure-lambda (advice (how :before-while)) (&rest args) + (and (apply car args) (apply cdr args)))) + (:filter-args ,(oclosure-lambda (advice (how :filter-args)) (&rest args) + (apply cdr (funcall car args)))) + (:filter-return ,(oclosure-lambda (advice (how :filter-return)) (&rest args) + (funcall car (apply cdr args))))) "List of descriptions of how to add a function. -Each element has the form (HOW BYTECODE STACK) where: - HOW is a keyword indicating where the function is added. - BYTECODE is the corresponding byte-code that will be used. - STACK is the amount of stack space needed by the byte-code.") - -(defvar advice--bytecodes (mapcar #'cadr advice--how-alist)) - -(defun advice--p (object) - (and (byte-code-function-p object) - (eq 128 (aref object 0)) - (memq (length object) '(5 6)) - (memq (aref object 1) advice--bytecodes) - (eq #'apply (aref (aref object 2) 0)))) - -(defsubst advice--car (f) (aref (aref f 2) 1)) -(defsubst advice--cdr (f) (aref (aref f 2) 2)) -(defsubst advice--props (f) (aref (aref f 2) 3)) +Each element has the form (HOW OCL) where HOW is a keyword and +OCL is a \"prototype\" function of type `advice'.") (defun advice--cd*r (f) (while (advice--p f) @@ -79,12 +80,6 @@ Each element has the form (HOW BYTECODE STACK) where: f) (define-obsolete-function-alias 'advice--where #'advice--how "29.1") -(defun advice--how (f) - (let ((bytecode (aref f 1)) - (how nil)) - (dolist (elem advice--how-alist) - (if (eq bytecode (cadr elem)) (setq how (car elem)))) - how)) (defun advice--make-single-doc (flist function macrop) (let ((how (advice--how flist))) @@ -181,17 +176,26 @@ Each element has the form (HOW BYTECODE STACK) where: `(funcall ',fspec ',(cadr ifm)) (cadr (or iff ifm))))) -(defun advice--make-1 (byte-code stack-depth function main props) - "Build a function value that adds FUNCTION to MAIN." - (let ((adv-sig (gethash main advertised-signature-table)) - (advice - (apply #'make-byte-code 128 byte-code - (vector #'apply function main props) stack-depth nil - (and (or (commandp function) (commandp main)) - (list (advice--make-interactive-form - function main)))))) - (when adv-sig (puthash advice adv-sig advertised-signature-table)) - advice)) + +(cl-defmethod oclosure-interactive-form ((ad advice) &optional _) + (let ((car (advice--car ad)) + (cdr (advice--cdr ad))) + (when (or (commandp car) (commandp cdr)) + `(interactive ,(advice--make-interactive-form car cdr))))) + +(cl-defmethod cl-print-object ((object advice) stream) + (cl-assert (advice--p object)) + (princ "#f(advice " stream) + (cl-print-object (advice--car object) stream) + (princ " " stream) + (princ (advice--how object) stream) + (princ " " stream) + (cl-print-object (advice--cdr object) stream) + (let ((props (advice--props object))) + (when props + (princ " " stream) + (cl-print-object props stream))) + (princ ")" stream)) (defun advice--make (how function main props) "Build a function value that adds FUNCTION to MAIN at HOW. @@ -202,12 +206,11 @@ HOW is a symbol to select an entry in `advice--how-alist'." (if (and md (> fd md)) ;; `function' should go deeper. (let ((rest (advice--make how function (advice--cdr main) props))) - (advice--make-1 (aref main 1) (aref main 3) - (advice--car main) rest (advice--props main))) - (let ((desc (assq how advice--how-alist))) - (unless desc (error "Unknown add-function location `%S'" how)) - (advice--make-1 (nth 1 desc) (nth 2 desc) - function main props))))) + (advice--cons main rest)) + (let ((proto (assq how advice--how-alist))) + (unless proto (error "Unknown add-function location `%S'" how)) + (advice--copy (cadr proto) + function main how props))))) (defun advice--member-p (function use-name definition) (let ((found nil)) @@ -233,8 +236,7 @@ HOW is a symbol to select an entry in `advice--how-alist'." (if val (car val) (let ((nrest (advice--tweak rest tweaker))) (if (eq rest nrest) flist - (advice--make-1 (aref flist 1) (aref flist 3) - first nrest props)))))))) + (advice--cons flist nrest)))))))) ;;;###autoload (defun advice--remove-function (flist function) @@ -286,7 +288,7 @@ different, but `function-equal' will hopefully ignore those differences.") ;; :before-until is like add-hook on run-hook-with-args-until-success. ;; Same with :after-* but for (add-hook ... 'append). "Add a piece of advice on the function stored at PLACE. -FUNCTION describes the code to add. HOW describes where to add it. +FUNCTION describes the code to add. HOW describes how to add it. HOW can be explained by showing the resulting new function, as the result of combining FUNCTION and the previous value of PLACE, which we call OLDFUN here: diff --git a/test/lisp/emacs-lisp/nadvice-tests.el b/test/lisp/emacs-lisp/nadvice-tests.el index 1185bee447..a675986b90 100644 --- a/test/lisp/emacs-lisp/nadvice-tests.el +++ b/test/lisp/emacs-lisp/nadvice-tests.el @@ -204,6 +204,15 @@ function being an around advice." (remove-function (var sm-test10) sm-advice) (should (equal (funcall sm-test10 5) 15)))) +(ert-deftest advice-test-print () + (let ((x (list 'cdr))) + (add-function :after (car x) 'car) + (should (equal (cl-prin1-to-string (car x)) + "#f(advice car :after cdr)")) + (add-function :before (car x) 'first) + (should (equal (cl-prin1-to-string (car x)) + "#f(advice first :before #f(advice car :after cdr))")))) + ;; Local Variables: ;; no-byte-compile: t ;; End: commit bc9be5449e1127bc1b05a6cad8471c6eba52c8e9 Author: Stefan Monnier Date: Tue Apr 26 16:28:54 2022 -0400 nadvice.el: Rename "where" to "how" * lisp/emacs-lisp/nadvice.el (advice--how-alist): Rename from `advice--where-alist`. (advice--how): Rename from `advice--where` and keep obsolete alias. (add-function, advice-add): Rename `where` arg to `how`. * lisp/emacs-lisp/cl-print.el (cl-print-object): Use `advice--how` name. diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index eaf2532da3..457ef506bc 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -230,8 +230,8 @@ into a button whose action shows the function's disassembly.") (if (not (advice--p object)) (cl-call-next-method) (princ "#f(advice-wrapper " stream) - (when (fboundp 'advice--where) - (princ (advice--where object) stream) + (when (fboundp 'advice--how) + (princ (advice--how object) stream) (princ " " stream)) (cl-print-object (advice--cdr object) stream) (princ " " stream) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 77e140dda1..be6eafd1b6 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -43,7 +43,7 @@ (push (purecopy '(nadvice 1 0)) package--builtin-versions) ;;;; Lightweight advice/hook -(defvar advice--where-alist +(defvar advice--how-alist '((:around "\300\301\302\003#\207" 5) (:before "\300\301\002\"\210\300\302\002\"\207" 4) (:after "\300\302\002\"\300\301\003\"\210\207" 5) @@ -55,12 +55,12 @@ (:filter-args "\300\302\301\003!\"\207" 5) (:filter-return "\301\300\302\003\"!\207" 5)) "List of descriptions of how to add a function. -Each element has the form (WHERE BYTECODE STACK) where: - WHERE is a keyword indicating where the function is added. +Each element has the form (HOW BYTECODE STACK) where: + HOW is a keyword indicating where the function is added. BYTECODE is the corresponding byte-code that will be used. STACK is the amount of stack space needed by the byte-code.") -(defvar advice--bytecodes (mapcar #'cadr advice--where-alist)) +(defvar advice--bytecodes (mapcar #'cadr advice--how-alist)) (defun advice--p (object) (and (byte-code-function-p object) @@ -78,19 +78,20 @@ Each element has the form (WHERE BYTECODE STACK) where: (setq f (advice--cdr f))) f) -(defun advice--where (f) +(define-obsolete-function-alias 'advice--where #'advice--how "29.1") +(defun advice--how (f) (let ((bytecode (aref f 1)) - (where nil)) - (dolist (elem advice--where-alist) - (if (eq bytecode (cadr elem)) (setq where (car elem)))) - where)) + (how nil)) + (dolist (elem advice--how-alist) + (if (eq bytecode (cadr elem)) (setq how (car elem)))) + how)) (defun advice--make-single-doc (flist function macrop) - (let ((where (advice--where flist))) + (let ((how (advice--how flist))) (concat (format "This %s has %s advice: " (if macrop "macro" "function") - where) + how) (let ((fun (advice--car flist))) (if (symbolp fun) (format-message "`%S'." fun) (let* ((name (cdr (assq 'name (advice--props flist)))) @@ -192,19 +193,19 @@ Each element has the form (WHERE BYTECODE STACK) where: (when adv-sig (puthash advice adv-sig advertised-signature-table)) advice)) -(defun advice--make (where function main props) - "Build a function value that adds FUNCTION to MAIN at WHERE. -WHERE is a symbol to select an entry in `advice--where-alist'." +(defun advice--make (how function main props) + "Build a function value that adds FUNCTION to MAIN at HOW. +HOW is a symbol to select an entry in `advice--how-alist'." (let ((fd (or (cdr (assq 'depth props)) 0)) (md (if (advice--p main) (or (cdr (assq 'depth (advice--props main))) 0)))) (if (and md (> fd md)) ;; `function' should go deeper. - (let ((rest (advice--make where function (advice--cdr main) props))) + (let ((rest (advice--make how function (advice--cdr main) props))) (advice--make-1 (aref main 1) (aref main 3) (advice--car main) rest (advice--props main))) - (let ((desc (assq where advice--where-alist))) - (unless desc (error "Unknown add-function location `%S'" where)) + (let ((desc (assq how advice--how-alist))) + (unless desc (error "Unknown add-function location `%S'" how)) (advice--make-1 (nth 1 desc) (nth 2 desc) function main props))))) @@ -274,9 +275,9 @@ different, but `function-equal' will hopefully ignore those differences.") (t place)))) ;;;###autoload -(defmacro add-function (where place function &optional props) +(defmacro add-function (how place function &optional props) ;; TODO: - ;; - maybe let `where' specify some kind of predicate and use it + ;; - maybe let `how' specify some kind of predicate and use it ;; to implement things like mode-local or eieio-defmethod. ;; Of course, that only makes sense if the predicates of all advices can ;; be combined and made more efficient. @@ -285,8 +286,8 @@ different, but `function-equal' will hopefully ignore those differences.") ;; :before-until is like add-hook on run-hook-with-args-until-success. ;; Same with :after-* but for (add-hook ... 'append). "Add a piece of advice on the function stored at PLACE. -FUNCTION describes the code to add. WHERE describes where to add it. -WHERE can be explained by showing the resulting new function, as the +FUNCTION describes the code to add. HOW describes where to add it. +HOW can be explained by showing the resulting new function, as the result of combining FUNCTION and the previous value of PLACE, which we call OLDFUN here: `:before' (lambda (&rest r) (apply FUNCTION r) (apply OLDFUN r)) @@ -326,13 +327,13 @@ is also interactive. There are 3 cases: ;;(indent 2) (debug (form [&or symbolp ("local" form) ("var" sexp) gv-place] form &optional form))) - `(advice--add-function ,where (gv-ref ,(advice--normalize-place place)) + `(advice--add-function ,how (gv-ref ,(advice--normalize-place place)) ,function ,props)) (declare-function comp-subr-trampoline-install "comp") ;;;###autoload -(defun advice--add-function (where ref function props) +(defun advice--add-function (how ref function props) (when (and (featurep 'native-compile) (subr-primitive-p (gv-deref ref))) (let ((subr-name (intern (subr-name (gv-deref ref))))) @@ -357,7 +358,7 @@ is also interactive. There are 3 cases: (advice--remove-function (gv-deref ref) (or name (advice--car a))))) (setf (gv-deref ref) - (advice--make where function (gv-deref ref) props)))) + (advice--make how function (gv-deref ref) props)))) ;;;###autoload (defmacro remove-function (place function) @@ -456,7 +457,7 @@ of the piece of advice." (funcall fsetfun symbol newdef)))) ;;;###autoload -(defun advice-add (symbol where function &optional props) +(defun advice-add (symbol how function &optional props) "Like `add-function' but for the function named SYMBOL. Contrary to `add-function', this will properly handle the cases where SYMBOL is defined as a macro, alias, command, ..." @@ -467,18 +468,18 @@ is defined as a macro, alias, command, ..." (let* ((f (symbol-function symbol)) (nf (advice--normalize symbol f))) (unless (eq f nf) (fset symbol nf)) - (add-function where (cond - ((eq (car-safe nf) 'macro) (cdr nf)) - ;; Reasons to delay installation of the advice: - ;; - If the function is not yet defined, installing - ;; the advice would affect `fboundp'ness. - ;; - the symbol-function slot of an autoloaded - ;; function is not itself a function value. - ;; - `autoload' does nothing if the function is - ;; not an autoload or undefined. - ((or (not nf) (autoloadp nf)) - (get symbol 'advice--pending)) - (t (symbol-function symbol))) + (add-function how (cond + ((eq (car-safe nf) 'macro) (cdr nf)) + ;; Reasons to delay installation of the advice: + ;; - If the function is not yet defined, installing + ;; the advice would affect `fboundp'ness. + ;; - the symbol-function slot of an autoloaded + ;; function is not itself a function value. + ;; - `autoload' does nothing if the function is + ;; not an autoload or undefined. + ((or (not nf) (autoloadp nf)) + (get symbol 'advice--pending)) + (t (symbol-function symbol))) function props) ;; FIXME: We could use a defmethod on `function-docstring' instead, ;; except when (or (not nf) (autoloadp nf))! @@ -517,12 +518,12 @@ See `advice-add' and `add-function' for explanation on the arguments. Note if NAME is nil the advice is anonymous; otherwise it is named `SYMBOL@NAME'. -\(fn SYMBOL (WHERE LAMBDA-LIST &optional NAME DEPTH) &rest BODY)" +\(fn SYMBOL (HOW LAMBDA-LIST &optional NAME DEPTH) &rest BODY)" (declare (indent 2) (doc-string 3) (debug (sexp sexp def-body))) (or (listp args) (signal 'wrong-type-argument (list 'listp args))) (or (<= 2 (length args) 4) (signal 'wrong-number-of-arguments (list 2 4 (length args)))) - (let* ((where (nth 0 args)) + (let* ((how (nth 0 args)) (lambda-list (nth 1 args)) (name (nth 2 args)) (depth (nth 3 args)) @@ -532,7 +533,7 @@ otherwise it is named `SYMBOL@NAME'. (intern (format "%s@%s" symbol name))) (t (error "Unrecognized name spec `%S'" name))))) `(prog1 ,@(and (symbolp advice) `((defun ,advice ,lambda-list ,@body))) - (advice-add ',symbol ,where #',advice ,@(and props `(',props)))))) + (advice-add ',symbol ,how #',advice ,@(and props `(',props)))))) (defun advice-mapc (fun symbol) "Apply FUN to every advice function in SYMBOL. commit 4dba7c31a225950198482fe1eb558aac7a36d964 Author: Stefan Monnier Date: Tue Apr 26 17:31:13 2022 -0400 Use `advice--cd*r` where applicable * lisp/emacs-lisp/bytecomp.el (byte-compile--function-signature): * lisp/emacs-lisp/advice.el (ad-get-orig-definition): * lisp/help.el (help-function-arglist): Use `advice--cd*r`. diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 8e43ae6807..86a42b208e 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1814,8 +1814,7 @@ Redefining advices affect the construction of an advised definition." (if (symbolp function) (setq function (if (fboundp function) (advice--strip-macro (symbol-function function))))) - (while (advice--p function) (setq function (advice--cdr function))) - function) + (advice--cd*r function)) (defun ad-clear-advicefunname-definition (function) (let ((advicefunname (ad-get-advice-info-field function 'advicefunname))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 28237d67d2..c0dffe544c 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1439,7 +1439,7 @@ when printing the error message." (and (eq 'macro (car-safe f)) (setq f (cdr f))) ;; Advice wrappers have "catch all" args, so fetch the actual underlying ;; function to find the real arguments. - (while (advice--p f) (setq f (advice--cdr f))) + (setq f (advice--cd*r f)) (if (eq (car-safe f) 'declared) (byte-compile-arglist-signature (nth 1 f)) (condition-case nil diff --git a/lisp/help.el b/lisp/help.el index c5de59d6bc..2d08ceb86c 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -2039,7 +2039,7 @@ the same names as used in the original source code, when possible." (if (and (symbolp def) (fboundp def)) (setq def (indirect-function def))) ;; Advice wrappers have "catch all" args, so fetch the actual underlying ;; function to find the real arguments. - (while (advice--p def) (setq def (advice--cdr def))) + (setq def (advice--cd*r def)) ;; If definition is a macro, find the function inside it. (if (eq (car-safe def) 'macro) (setq def (cdr def))) (cond commit 21112e3683dd7c1f88028bac4b1835204b8e30f8 Author: Stefan Monnier Date: Tue Apr 26 17:30:29 2022 -0400 Pretty print OClosure slot accessors * lisp/emacs-lisp/oclosure.el (oclosure--accessor-cl-print): New function. * lisp/emacs-lisp/cl-print.el (cl-print-object) : New method. * test/lisp/emacs-lisp/nadvice-tests.el (advice-test-call-interactively): Avoid `defun` within a function. diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index 2aade140e2..eaf2532da3 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -242,6 +242,12 @@ into a button whose action shows the function's disassembly.") (cl-print-object props stream))) (princ ")" stream))) +;; This belongs in oclosure.el, of course, but some load-ordering issues make it +;; complicated. +(cl-defmethod cl-print-object ((object accessor) stream) + ;; FIXME: η-reduce! + (oclosure--accessor-cl-print object stream)) + (cl-defmethod cl-print-object ((object cl-structure-object) stream) (if (and cl-print--depth (natnump print-level) (> cl-print--depth print-level)) diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index 90811199f2..cb8c59b05a 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -505,6 +505,13 @@ This has 2 uses: "OClosure function to access a specific slot of an object." type slot) +(defun oclosure--accessor-cl-print (object stream) + (princ "#f(accessor " stream) + (prin1 (accessor--type object) stream) + (princ "." stream) + (prin1 (accessor--slot object) stream) + (princ ")" stream)) + (defun oclosure--accessor-docstring (f) ;; This would like to be a (cl-defmethod function-documentation ...) ;; but for circularity reason the defmethod is in `simple.el'. diff --git a/test/lisp/emacs-lisp/nadvice-tests.el b/test/lisp/emacs-lisp/nadvice-tests.el index f21624cfd8..1185bee447 100644 --- a/test/lisp/emacs-lisp/nadvice-tests.el +++ b/test/lisp/emacs-lisp/nadvice-tests.el @@ -153,13 +153,13 @@ function being an around advice." (ert-deftest advice-test-call-interactively () "Check interaction between advice on call-interactively and called-interactively-p." - (defun sm-test7.4 () (interactive) (cons 1 (called-interactively-p))) - (let ((old (symbol-function 'call-interactively))) + (let ((sm-test7.4 (lambda () (interactive) (cons 1 (called-interactively-p)))) + (old (symbol-function 'call-interactively))) (unwind-protect (progn (advice-add 'call-interactively :before #'ignore) - (should (equal (sm-test7.4) '(1 . nil))) - (should (equal (call-interactively 'sm-test7.4) '(1 . t)))) + (should (equal (funcall sm-test7.4) '(1 . nil))) + (should (equal (call-interactively sm-test7.4) '(1 . t)))) (advice-remove 'call-interactively #'ignore) (should (eq (symbol-function 'call-interactively) old))))) commit d35b6a49b33b534f7653bec4d03ab2513a15dc4f Author: Paul Eggert Date: Mon Apr 25 17:57:50 2022 -0700 Fix gnus-html-image-cache-ttl FIXME * lisp/gnus/gnus-html.el (gnus-html-image-cache-ttl): Make it a seconds count. diff --git a/etc/NEWS b/etc/NEWS index 19434ec85b..a2818c8bf7 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -940,6 +940,12 @@ representation as emojis. Configuration is very similar to the notmuch and namazu backends. It supports the unified search syntax. +--- +*** gnus-html-image-cache-ttl is now a seconds count. +Formerly it was a pair of numbers (A B) that represented 65536*A + B, +to cater to older Emacs implementations that lacked bignums. +The older form still works but is undocumented. + ** EIEIO +++ diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el index 8b2200af54..87f3ee6362 100644 --- a/lisp/gnus/gnus-html.el +++ b/lisp/gnus/gnus-html.el @@ -40,15 +40,11 @@ (require 'help-fns) (require 'url-queue) -(defcustom gnus-html-image-cache-ttl (days-to-time 7) - "Time used to determine if we should use images from the cache." - :version "24.1" +(defcustom gnus-html-image-cache-ttl (time-convert (days-to-time 7) 'integer) + "Number of seconds used to determine if we should use images from the cache." + :version "29.1" :group 'gnus-art - ;; FIXME hardly the friendliest type. The allowed value is actually - ;; any time value, but we are assuming no-one cares about USEC and - ;; PSEC here. It would be better to make it a number of seconds. - :type '(choice (cons integer integer) - (list integer integer))) + :type 'number) (defcustom gnus-html-image-automatic-caching t "Whether automatically cache retrieve images." commit 516ff422c54b79099841bb59d34da467f3f9a34e Author: Alex Schroeder Date: Sun Apr 24 13:33:09 2022 +0200 Fix error in rcirc for IRC tags without values * src/lisp/net/rcirc.el (rcirc-process-server-response-1): If the optional value for a tag is not present, do not call replace-regexp-in-string on it. If (match-string 2 tag) is nil, the STRING argument for the replace-regexp-in-string is nil, which results in an error. diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 31888f3913..0d30b34922 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -1082,17 +1082,18 @@ Note that the messages are stored in reverse order.") ;; expression and `rcirc-process-regexp'. (error "Malformed tag %S" tag)) (cons (match-string 1 tag) - (replace-regexp-in-string - (rx (* ?\\ ?\\) ?\\ (any ?: ?s ?\\ ?r ?n)) - (lambda (rep) - (concat (substring rep 0 -2) - (cl-case (aref rep (1- (length rep))) - (?: ";") - (?s " ") - (?\\ "\\\\") - (?r "\r") - (?n "\n")))) - (match-string 2 tag)))) + (when (match-string 2 tag) + (replace-regexp-in-string + (rx (* ?\\ ?\\) ?\\ (any ?: ?s ?\\ ?r ?n)) + (lambda (rep) + (concat (substring rep 0 -2) + (cl-case (aref rep (1- (length rep))) + (?: ";") + (?s " ") + (?\\ "\\\\") + (?r "\r") + (?n "\n")))) + (match-string 2 tag))))) (split-string tag-data ";")))) rcirc-message-tags)) (user (match-string 3 text)) commit bffc4cb39dc7b83fc4a1bffd23eeed2774b79444 Author: Stefan Monnier Date: Tue Apr 26 10:36:52 2022 -0400 New generic function `oclosure-interactive-form` It's used by `interactive-form` when it encounters an OClosure. This lets one compute the `interactive-form` of OClosures dynamically by adding appropriate methods. This does not include support for `command-modes` for Oclosures. * lisp/simple.el (oclosure-interactive-form): New generic function. * src/data.c (Finteractive_form): Delegate to `oclosure-interactive-form` if the arg is an OClosure. (syms_of_data): New symbol `Qoclosure_interactive_form`. * src/eval.c (Fcommandp): Delegate to `interactive-form` if the arg is an OClosure. * src/lisp.h (VALID_DOCSTRING_P): New function, extracted from `store_function_docstring`. * src/doc.c (store_function_docstring): Use it. * lisp/kmacro.el (kmacro): Don't carry any interactive form. (oclosure-interactive-form) : New method, instead. * test/lisp/emacs-lisp/oclosure-tests.el (oclosure-interactive-form) : New method. (oclosure-test-interactive-form): New test. * doc/lispref/commands.texi (Using Interactive): Document `oclosure-interactive-form`. diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index ace0c02551..6c60216796 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -312,6 +312,25 @@ If @var{function} is an interactively callable function specifies how to compute its arguments. Otherwise, the value is @code{nil}. If @var{function} is a symbol, its function definition is used. +When called on an OClosure, the work is delegated to the generic +function @code{oclosure-interactive-form}. +@end defun + +@defun oclosure-interactive-form function +Just like @code{interactive-form}, this function takes a command and +returns its interactive form. The difference is that it is a generic +function and it is only called when @var{function} is an OClosure. +The purpose is to make it possible for some OClosure types to compute +their interactive forms dynamically instead of carrying it in one of +their slots. + +This is used for example for @code{kmacro} functions in order to +reduce their memory size, since they all share the same interactive +form. It is also used for @code{advice} functions, where the +interactive form is computed from the interactive forms of its +components, so as to make this computation more lazily and to +correctly adjust the interactive form when one of its component's +is redefined. @end defun @node Interactive Codes diff --git a/etc/NEWS b/etc/NEWS index dc2e7c616a..19434ec85b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1345,6 +1345,11 @@ remote host are shown. Alternatively, the user option Allows the creation of "functions with slots" or "function objects" via the macros 'oclosure-define' and 'oclosure-lambda'. +*** New generic function 'oclosure-interactive-form'. +Used by 'interactive-form' when called on an OClosure. +This allows specific OClosure types to compute their interactive specs +on demand rather than precompute them when created. + --- ** New theme 'leuven-dark'. This is a dark version of the 'leuven' theme. diff --git a/lisp/kmacro.el b/lisp/kmacro.el index 8a9d89929e..5476c2395c 100644 --- a/lisp/kmacro.el +++ b/lisp/kmacro.el @@ -820,13 +820,14 @@ KEYS should be a vector or a string that obeys `key-valid-p'." (counter (or counter 0)) (format (or format "%d"))) (&optional arg) - (interactive "p") ;; Use counter and format specific to the macro on the ring! (let ((kmacro-counter counter) (kmacro-counter-format-start format)) (execute-kbd-macro keys arg #'kmacro-loop-setup-function) (setq counter kmacro-counter)))) +(cl-defmethod oclosure-interactive-form ((_ kmacro)) '(interactive "p")) + ;;;###autoload (defun kmacro-lambda-form (mac &optional counter format) ;; Apparently, there are two different ways this is called: diff --git a/lisp/simple.el b/lisp/simple.el index 1ff101cfcd..d638e641c3 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2389,6 +2389,17 @@ function as needed." (cl-defmethod function-documentation ((function accessor)) (oclosure--accessor-docstring function)) ;; FIXME: η-reduce! +;; This should be in `oclosure.el' but that file is loaded before `cl-generic'. +(cl-defgeneric oclosure-interactive-form (_function) + "Return the interactive form of FUNCTION or nil if none. +This is called by `interactive-form' when invoked on OClosures. +It should return either nil or a two-element list of the form (interactive FORM) +where FORM is like the first arg of the `interactive' special form. +Add your methods to this generic function, but always call `interactive-form' +instead." + ;; (interactive-form function) + nil) + (defun command-execute (cmd &optional record-flag keys special) ;; BEWARE: Called directly from the C code. "Execute CMD as an editor command. diff --git a/src/callint.c b/src/callint.c index 31919d6bb8..92bfaf8d39 100644 --- a/src/callint.c +++ b/src/callint.c @@ -315,7 +315,7 @@ invoke it (via an `interactive' spec that contains, for instance, an Lisp_Object up_event = Qnil; /* Set SPECS to the interactive form, or barf if not interactive. */ - Lisp_Object form = Finteractive_form (function); + Lisp_Object form = call1 (Qinteractive_form, function); if (! CONSP (form)) wrong_type_argument (Qcommandp, function); Lisp_Object specs = Fcar (XCDR (form)); diff --git a/src/data.c b/src/data.c index 72af8a6648..0347ff363c 100644 --- a/src/data.c +++ b/src/data.c @@ -1072,6 +1072,7 @@ Value, if non-nil, is a list (interactive SPEC). */) (Lisp_Object cmd) { Lisp_Object fun = indirect_function (cmd); /* Check cycles. */ + bool genfun = false; if (NILP (fun)) return Qnil; @@ -1104,15 +1105,17 @@ Value, if non-nil, is a list (interactive SPEC). */) if (PVSIZE (fun) > COMPILED_INTERACTIVE) { Lisp_Object form = AREF (fun, COMPILED_INTERACTIVE); - if (VECTORP (form)) - /* The vector form is the new form, where the first - element is the interactive spec, and the second is the - command modes. */ - return list2 (Qinteractive, AREF (form, 0)); - else - /* Old form -- just the interactive spec. */ - return list2 (Qinteractive, form); + /* The vector form is the new form, where the first + element is the interactive spec, and the second is the + command modes. */ + return list2 (Qinteractive, VECTORP (form) ? AREF (form, 0) : form); } + else if (PVSIZE (fun) > COMPILED_DOC_STRING) + { + Lisp_Object doc = AREF (fun, COMPILED_DOC_STRING); + /* An invalid "docstring" is a sign that we have an OClosure. */ + genfun = !(NILP (doc) || VALID_DOCSTRING_P (doc)); + } } #ifdef HAVE_MODULES else if (MODULE_FUNCTIONP (fun)) @@ -1135,13 +1138,21 @@ Value, if non-nil, is a list (interactive SPEC). */) if (EQ (funcar, Qclosure)) form = Fcdr (form); Lisp_Object spec = Fassq (Qinteractive, form); - if (NILP (Fcdr (Fcdr (spec)))) + if (NILP (spec) && VALID_DOCSTRING_P (CAR_SAFE (form))) + /* A "docstring" is a sign that we may have an OClosure. */ + genfun = true; + else if (NILP (Fcdr (Fcdr (spec)))) return spec; else return list2 (Qinteractive, Fcar (Fcdr (spec))); } } - return Qnil; + if (genfun + /* Avoid burping during bootstrap. */ + && !NILP (Fsymbol_function (Qoclosure_interactive_form))) + return call1 (Qoclosure_interactive_form, fun); + else + return Qnil; } DEFUN ("command-modes", Fcommand_modes, Scommand_modes, 1, 1, 0, @@ -4123,6 +4134,7 @@ syms_of_data (void) DEFSYM (Qchar_table_p, "char-table-p"); DEFSYM (Qvector_or_char_table_p, "vector-or-char-table-p"); DEFSYM (Qfixnum_or_symbol_with_pos_p, "fixnum-or-symbol-with-pos-p"); + DEFSYM (Qoclosure_interactive_form, "oclosure-interactive-form"); DEFSYM (Qsubrp, "subrp"); DEFSYM (Qunevalled, "unevalled"); diff --git a/src/doc.c b/src/doc.c index 5326195c6a..71e66853b0 100644 --- a/src/doc.c +++ b/src/doc.c @@ -469,9 +469,7 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) if (PVSIZE (fun) > COMPILED_DOC_STRING /* Don't overwrite a non-docstring value placed there, * such as the symbols used for Oclosures. */ - && (FIXNUMP (AREF (fun, COMPILED_DOC_STRING)) - || STRINGP (AREF (fun, COMPILED_DOC_STRING)) - || CONSP (AREF (fun, COMPILED_DOC_STRING)))) + && VALID_DOCSTRING_P (AREF (fun, COMPILED_DOC_STRING))) ASET (fun, COMPILED_DOC_STRING, make_fixnum (offset)); else { diff --git a/src/eval.c b/src/eval.c index 37bc03465c..77ec47e2b7 100644 --- a/src/eval.c +++ b/src/eval.c @@ -2032,8 +2032,7 @@ then strings and vectors are not accepted. */) (Lisp_Object function, Lisp_Object for_call_interactively) { register Lisp_Object fun; - register Lisp_Object funcar; - Lisp_Object if_prop = Qnil; + bool genfun = false; /* If true, we should consult `interactive-form'. */ fun = function; @@ -2041,52 +2040,89 @@ then strings and vectors are not accepted. */) if (NILP (fun)) return Qnil; - /* Check an `interactive-form' property if present, analogous to the - function-documentation property. */ - fun = function; - while (SYMBOLP (fun)) - { - Lisp_Object tmp = Fget (fun, Qinteractive_form); - if (!NILP (tmp)) - if_prop = Qt; - fun = Fsymbol_function (fun); - } - /* Emacs primitives are interactive if their DEFUN specifies an interactive spec. */ if (SUBRP (fun)) - return XSUBR (fun)->intspec.string ? Qt : if_prop; - + { + if (XSUBR (fun)->intspec.string) + return Qt; + } /* Bytecode objects are interactive if they are long enough to have an element whose index is COMPILED_INTERACTIVE, which is where the interactive spec is stored. */ else if (COMPILEDP (fun)) - return (PVSIZE (fun) > COMPILED_INTERACTIVE ? Qt : if_prop); + { + if (PVSIZE (fun) > COMPILED_INTERACTIVE) + return Qt; + else if (PVSIZE (fun) > COMPILED_DOC_STRING) + { + Lisp_Object doc = AREF (fun, COMPILED_DOC_STRING); + /* An invalid "docstring" is a sign that we have an OClosure. */ + genfun = !(NILP (doc) || VALID_DOCSTRING_P (doc)); + } + } #ifdef HAVE_MODULES /* Module functions are interactive if their `interactive_form' field is non-nil. */ else if (MODULE_FUNCTIONP (fun)) - return NILP (module_function_interactive_form (XMODULE_FUNCTION (fun))) - ? if_prop - : Qt; + { + if (!NILP (module_function_interactive_form (XMODULE_FUNCTION (fun)))) + return Qt; + } #endif /* Strings and vectors are keyboard macros. */ - if (STRINGP (fun) || VECTORP (fun)) + else if (STRINGP (fun) || VECTORP (fun)) return (NILP (for_call_interactively) ? Qt : Qnil); /* Lists may represent commands. */ - if (!CONSP (fun)) + else if (!CONSP (fun)) return Qnil; - funcar = XCAR (fun); - if (EQ (funcar, Qclosure)) - return (!NILP (Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun))))) - ? Qt : if_prop); - else if (EQ (funcar, Qlambda)) - return !NILP (Fassq (Qinteractive, Fcdr (XCDR (fun)))) ? Qt : if_prop; - else if (EQ (funcar, Qautoload)) - return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop; + else + { + Lisp_Object funcar = XCAR (fun); + if (EQ (funcar, Qautoload)) + { + if (!NILP (Fcar (Fcdr (Fcdr (XCDR (fun)))))) + return Qt; + } + else + { + Lisp_Object body = CDR_SAFE (XCDR (fun)); + if (EQ (funcar, Qclosure)) + body = CDR_SAFE (body); + else if (!EQ (funcar, Qlambda)) + return Qnil; + if (!NILP (Fassq (Qinteractive, body))) + return Qt; + else if (VALID_DOCSTRING_P (CAR_SAFE (body))) + /* A "docstring" is a sign that we may have an OClosure. */ + genfun = true; + } + } + + /* By now, if it's not a function we already returned nil. */ + + /* Check an `interactive-form' property if present, analogous to the + function-documentation property. */ + fun = function; + while (SYMBOLP (fun)) + { + Lisp_Object tmp = Fget (fun, Qinteractive_form); + if (!NILP (tmp)) + error ("Found an 'interactive-form' property!"); + fun = Fsymbol_function (fun); + } + + /* If there's no immediate interactive form but it's an OClosure, + then delegate to the generic-function in case it has + a type-specific interactive-form. */ + if (genfun) + { + Lisp_Object iform = call1 (Qinteractive_form, fun); + return NILP (iform) ? Qnil : Qt; + } else return Qnil; } diff --git a/src/lisp.h b/src/lisp.h index 75f369f524..1ad89fc468 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2185,6 +2185,16 @@ XSUBR (Lisp_Object a) return &XUNTAG (a, Lisp_Vectorlike, union Aligned_Lisp_Subr)->s; } +/* Return whether a value might be a valid docstring. + Used to distinguish the presence of non-docstring in the docstring slot, + as in the case of OClosures. */ +INLINE bool +VALID_DOCSTRING_P (Lisp_Object doc) +{ + return FIXNUMP (doc) || STRINGP (doc) + || (CONSP (doc) && STRINGP (XCAR (doc)) && FIXNUMP (XCDR (doc))); +} + enum char_table_specials { /* This is the number of slots that every char table must have. This diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el index b6bdebc0a2..b3a921826b 100644 --- a/test/lisp/emacs-lisp/oclosure-tests.el +++ b/test/lisp/emacs-lisp/oclosure-tests.el @@ -106,6 +106,27 @@ (and (eq 'error (car err)) (string-match "Duplicate slot: fst$" (cadr err))))))) +(cl-defmethod oclosure-interactive-form ((ot oclosure-test)) + (let ((snd (oclosure-test--snd ot))) + (if (stringp snd) (list 'interactive snd)))) + +(ert-deftest oclosure-test-interactive-form () + (should (equal (interactive-form + (oclosure-lambda (oclosure-test (fst 1) (snd 2)) () fst)) + nil)) + (should (equal (interactive-form + (oclosure-lambda (oclosure-test (fst 1) (snd 2)) () + (interactive "r") + fst)) + '(interactive "r"))) + (should (equal (interactive-form + (oclosure-lambda (oclosure-test (fst 1) (snd "P")) () fst)) + '(interactive "P"))) + (should (not (commandp + (oclosure-lambda (oclosure-test (fst 1) (snd 2)) () fst)))) + (should (commandp + (oclosure-lambda (oclosure-test (fst 1) (snd "P")) () fst)))) + (oclosure-define (oclosure-test-mut (:parent oclosure-test) (:copier oclosure-test-mut-copy)) commit 756b7cf5d9a817503437b3e8a9e8d912b7ee6c75 Author: Lars Ingebrigtsen Date: Tue Apr 26 15:32:45 2022 +0200 Mention caveats in the map-delete doc string * lisp/emacs-lisp/map.el (map-delete): Mention how this has to be used for lists (bug#25929). diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index c53f253f87..8c67d7c7a2 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -175,7 +175,17 @@ MAP can be an alist, plist, hash-table, or array." (cl-defgeneric map-delete (map key) "Delete KEY in-place from MAP and return MAP. -Keys not present in MAP are ignored.") +Keys not present in MAP are ignored. + +Note that if MAP is a list (either alist or plist), and you're +deleting the final element in the list, the list isn't actually +destructively modified (but the return value will reflect the +deletion). So if you're using this method on a list, you have to +say + + (setq map (map-delete map key)) + +for this to work reliably.") (cl-defmethod map-delete ((map list) key) ;; FIXME: Signal map-not-inplace i.s.o returning a different list? commit 0936bfcd77a671b8dce4ebcdc3e916622d68a865 Author: Po Lu Date: Tue Apr 26 20:43:15 2022 +0800 Fix EWMH window activation * src/xterm.c (x_ewmh_activate_frame): Add missing fields of message. (bug#55122) diff --git a/src/xterm.c b/src/xterm.c index 16d0ce6707..56add92f8b 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -21479,8 +21479,10 @@ x_ewmh_activate_frame (struct frame *f) /* See the documentation at https://specifications.freedesktop.org/wm-spec/wm-spec-latest.html for more details on the format of this message. */ + msg.xclient.type = ClientMessage; msg.xclient.window = FRAME_OUTER_WINDOW (f); msg.xclient.message_type = dpyinfo->Xatom_net_active_window; + msg.xclient.format = 32; msg.xclient.data.l[0] = 1; msg.xclient.data.l[1] = dpyinfo->last_user_time; msg.xclient.data.l[2] = (!dpyinfo->x_focus_frame commit a38b7d3e90af0b4421965ece5ccd888b095e0186 Author: Lars Ingebrigtsen Date: Tue Apr 26 14:32:07 2022 +0200 Tweak interactive use of delete-windows-on * lisp/window.el (delete-windows-on): Make prompting better, and allow specifying only the current frame interactively (bug#34749). diff --git a/lisp/window.el b/lisp/window.el index c15f14cc61..dc33eb8a12 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -5007,7 +5007,11 @@ minibuffer window or is dedicated to its buffer." BUFFER-OR-NAME may be a buffer or the name of an existing buffer and defaults to the current buffer. -Interactively, prompt for the buffer. +Interactively, this command will prompt for the buffer name. A +prefix argument of 0 (zero) means that only windows in the +current terminal's frames will be deleted. Any other prefix +argument means that only windows in the current frame will be +deleted. The following non-nil values of the optional argument FRAME have special meanings: @@ -5044,7 +5048,21 @@ If the buffer specified by BUFFER-OR-NAME is shown in a minibuffer window, do nothing for that window. For any window that does not show that buffer, remove the buffer from that window's lists of previous and next buffers." - (interactive "bDelete windows on (buffer):\nP") + (interactive + (let ((frame (cond + ((and (numberp current-prefix-arg) + (zerop current-prefix-arg)) + 0) + (current-prefix-arg t)))) + (list (read-buffer "Delete windows on (buffer): " + nil nil + (lambda (buf) + (get-buffer-window + (if (consp buf) (car buf) buf) + (cond + ((null frame) t) + ((numberp frame) frame))))) + frame))) (let ((buffer (window-normalize-buffer buffer-or-name)) ;; Handle the "inverted" meaning of the FRAME argument wrt other ;; `window-list-1' based function. commit 631a8ae9ee9c79b420cadb188d65503a3eea9b16 Author: Lars Ingebrigtsen Date: Tue Apr 26 13:27:17 2022 +0200 Make `C RET' work in archive-mode * lisp/arc-mode.el (archive-copy-file): Fix the default value (when the user hits RET) (bug#55123). diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index f1a3735d2c..1c5faa1152 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -1063,7 +1063,8 @@ NEW-NAME." #'archive--file-desc-ext-file-name (or (archive-get-marked ?*) (list (archive-get-descr)))))) (list names - (read-file-name (format "Copy %s to: " (string-join names ", ")))))) + (read-file-name (format "Copy %s to: " (string-join names ", ")) + nil default-directory)))) (unless (consp files) (setq files (list files))) (when (and (> (length files) 1) commit dd5ca0eaf2604bcf712c91e43bde723687a64e29 Author: Lars Ingebrigtsen Date: Tue Apr 26 13:23:51 2022 +0200 Make new menu *Help* output be more resilient * lisp/help-fns.el (help-fns--insert-menu-bindings): Only insert the heading if it turns out that we actually find the menu. (help-fns--insert-bindings): Tweak calling convention. diff --git a/etc/NEWS b/etc/NEWS index e97f545dda..dc2e7c616a 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -434,7 +434,7 @@ following bindings: This has been changed to: It is bound to and C-x C-f. - It can also be invoked from the menu: File → Visit New File.... + It can also be invoked from the menu: File → Visit New File... +++ *** The 'C-h .' command now accepts a prefix argument. diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 4599980166..67045bb4d6 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -565,11 +565,10 @@ the C sources, too." (insert "\n")) (when menus (let ((start (point))) - (insert (concat "It can " - (and keys "also ") - "be invoked from the menu: ")) - (help-fns--insert-menu-bindings menus) - (insert ".") + (help-fns--insert-menu-bindings + menus + (concat "It can " (and keys "also ") + "be invoked from the menu: ")) (fill-region-as-paragraph start (point)))) (ensure-empty-lines))))))) @@ -582,7 +581,7 @@ the C sources, too." (insert (help--key-description-fontified key))) keys)) -(defun help-fns--insert-menu-bindings (menus) +(defun help-fns--insert-menu-bindings (menus heading) (seq-do-indexed (lambda (menu i) (insert @@ -593,12 +592,15 @@ the C sources, too." (start (point))) (seq-do-indexed (lambda (entry level) - (when (> level 0) - (insert - (if (char-displayable-p ?→) - " → " - " => "))) - (let ((elem (assq entry (cdr map)))) + (when-let ((elem (assq entry (cdr map)))) + (when heading + (insert heading) + (setq heading nil)) + (when (> level 0) + (insert + (if (char-displayable-p ?→) + " → " + " => "))) (if (eq (nth 1 elem) 'menu-item) (progn (insert (nth 2 elem)) commit ae877d551155000dffdbcd1b90d682967c6988d0 Author: Lars Ingebrigtsen Date: Tue Apr 26 12:39:13 2022 +0200 Add new user option flymake-mode-line-lighter * doc/misc/flymake.texi (Customizable variables): Document it. * lisp/progmodes/flymake.el (flymake-mode-line-lighter): New user option (bug#55115). (flymake--mode-line-title): Use it. diff --git a/doc/misc/flymake.texi b/doc/misc/flymake.texi index 0db02608dd..953e4605e9 100644 --- a/doc/misc/flymake.texi +++ b/doc/misc/flymake.texi @@ -265,6 +265,9 @@ This section summarizes customization variables used for the configuration of the Flymake user interface. @vtable @code +@item flymake-mode-line-lighter +The name of the mode. Defaults to @samp{Flymake}. + @item flymake-mode-line-format Format to use for the Flymake mode line indicator. diff --git a/etc/NEWS b/etc/NEWS index 40e914cd32..e97f545dda 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -669,6 +669,11 @@ script that was used in ancient South Asia. A new input method, * Changes in Specialized Modes and Packages in Emacs 29.1 +** Flymake + ++++ +*** New user option 'flymake-mode-line-lighter'. + +++ ** New minor mode 'word-wrap-whitespace-mode' for extending 'word-wrap'. This mode switches 'word-wrap' on, and breaks on all the whitespace diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 8cbebe78fe..b5f4fff3c3 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -1358,6 +1358,11 @@ This is a suitable place for placing the `flymake-error-counter', Separating each of these with space is not necessary." :type '(repeat (choice string symbol))) +(defcustom flymake-mode-line-lighter "Flymake" + "The string to use in the Flymake mode line." + :type 'string + :version "29.1") + (defvar flymake-mode-line-title '(:eval (flymake--mode-line-title)) "Mode-line construct to show Flymake's mode name and menu.") @@ -1386,7 +1391,7 @@ correctly.") (defun flymake--mode-line-title () `(:propertize - "Flymake" + ,flymake-mode-line-lighter mouse-face mode-line-highlight help-echo ,(lambda (&rest _) commit e98b7d6ba2c8634c82f49ee18fd8b91b1b83a187 Author: Lars Ingebrigtsen Date: Tue Apr 26 12:11:49 2022 +0200 Improve documentation for t value for reusable-frames * doc/lispref/windows.texi (Buffer Display Action Alists): Note that the t value is rarely a good one (bug#55103). diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi index abc8adae83..0b3fa0c8b5 100644 --- a/doc/lispref/windows.texi +++ b/doc/lispref/windows.texi @@ -2966,13 +2966,14 @@ follows: @code{nil} means consider only windows on the selected frame. (Actually, the last frame used that is not a minibuffer-only frame.) @item -@code{t} means consider windows on all frames. -@item @code{visible} means consider windows on all visible frames. @item 0 means consider windows on all visible or iconified frames. @item A frame means consider windows on that frame only. +@item +@code{t} means consider windows on all frames. (Note that this value +is rarely the right thing to use---it might also return a tooltip frame.) @end itemize Note that the meaning of @code{nil} differs slightly from that of the