commit 4ac4cec652ffaca4333d8f297b8a6c0e5bd79c68 (HEAD, refs/remotes/origin/master) Author: Gerd Möllmann Date: Sat Mar 9 15:06:29 2024 +0100 Prevent freezes on macOS (bug#69561) * src/nsterm.m (ns_select_1): Store pending input_events. Always call [NSApp run]. diff --git a/src/nsterm.m b/src/nsterm.m index f094b145fe3..f161edc4ac2 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -4739,12 +4739,15 @@ Function modeled after x_draw_glyph_string_box (). check_native_fs (); #endif - if (hold_event_q.nr > 0 && !run_loop_only) + /* If there are input events pending, store them so that Emacs can + recognize C-g. (And we must make sure [NSApp run] is called in + this function, so that C-g has a chance to land in + hold_event_q.) */ + if (hold_event_q.nr > 0) { - /* We already have events pending. */ - raise (SIGIO); - errno = EINTR; - return -1; + for (int i = 0; i < hold_event_q.nr; ++i) + kbd_buffer_store_event_hold (&hold_event_q.q[i], NULL); + hold_event_q.nr = 0; } eassert (nfds <= FD_SETSIZE); @@ -4757,8 +4760,8 @@ Function modeled after x_draw_glyph_string_box (). if (NSApp == nil || ![NSThread isMainThread] || (timeout && timeout->tv_sec == 0 && timeout->tv_nsec == 0)) - return thread_select (pselect, nfds, readfds, writefds, - exceptfds, timeout, sigmask); + thread_select (pselect, nfds, readfds, writefds, + exceptfds, timeout, sigmask); else { struct timespec t = {0, 0}; commit 6b40d557c4a9a4152565c1a1b0da49a1aaaec84f Author: Po Lu Date: Wed Mar 13 10:59:39 2024 +0800 Port more notification senders to non-XDG systems * doc/lispref/os.texi (Desktop Notifications): Document that `:timeout' is now implemented. * java/org/gnu/emacs/EmacsDesktopNotification.java (EmacsDesktopNotification): New field delay. (display1): Set delay on Android 8.0 and up. * lisp/erc/erc-desktop-notifications.el (erc-notifications-notify): Call Android or Haiku notification functions on those systems. * lisp/gnus/gnus-notifications.el (gnus-notifications-action) (gnus-notification-close): Remove dismissed notifications from the notification to message map. (gnus-notifications-notify): Call android-notifications-notify if possible. * src/androidselect.c (android_init_emacs_desktop_notification): Update accordingly. (android_notifications_notify_1): New argument TIMEOUT. (Fandroid_notifications_notify): New argument QCtimeout. (syms_of_androidselect) : New symbol. diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index 435886320fd..3ba3da459bf 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -3244,6 +3244,7 @@ of parameters analogous to its namesake in @item :on-action @var{on-action} @item :on-cancel @var{on-close} @item :actions @var{actions} +@item :timeout @var{timeout} @item :resident @var{resident} These have the same meaning as they do when used in calls to @code{notifications-notify}, except that no more than three non-default diff --git a/java/org/gnu/emacs/EmacsDesktopNotification.java b/java/org/gnu/emacs/EmacsDesktopNotification.java index d05ed2e6203..d00b9f2ea22 100644 --- a/java/org/gnu/emacs/EmacsDesktopNotification.java +++ b/java/org/gnu/emacs/EmacsDesktopNotification.java @@ -83,11 +83,16 @@ public final class EmacsDesktopNotification notification. */ public final String[] actions, titles; + /* Delay in miliseconds after which this notification should be + automatically dismissed. */ + public final long delay; + public EmacsDesktopNotification (String title, String content, String group, String tag, int icon, int importance, - String[] actions, String[] titles) + String[] actions, String[] titles, + long delay) { this.content = content; this.title = title; @@ -97,6 +102,7 @@ public final class EmacsDesktopNotification this.importance = importance; this.actions = actions; this.titles = titles; + this.delay = delay; } @@ -191,6 +197,8 @@ public final class EmacsDesktopNotification builder.setContentTitle (title); builder.setContentText (content); builder.setSmallIcon (icon); + builder.setTimeoutAfter (delay); + insertActions (context, builder); notification = builder.build (); } diff --git a/lisp/erc/erc-desktop-notifications.el b/lisp/erc/erc-desktop-notifications.el index 2e905097f97..9bb89fbfc81 100644 --- a/lisp/erc/erc-desktop-notifications.el +++ b/lisp/erc/erc-desktop-notifications.el @@ -54,6 +54,9 @@ (defvar dbus-debug) ; used in the macroexpansion of dbus-ignore-errors +(declare-function haiku-notifications-notify "haikuselect.c") +(declare-function android-notifications-notify "androidselect.c") + (defun erc-notifications-notify (nick msg &optional privp) "Notify that NICK send some MSG, where PRIVP should be non-nil for PRIVMSGs. This will replace the last notification sent with this function." @@ -64,14 +67,19 @@ This will replace the last notification sent with this function." (let* ((channel (if privp (erc-get-buffer nick) (current-buffer))) (title (format "%s in %s" (xml-escape-string nick t) channel)) (body (xml-escape-string (erc-controls-strip msg) t))) - (notifications-notify :bus erc-notifications-bus - :title title - :body body - :replaces-id erc-notifications-last-notification - :app-icon erc-notifications-icon - :actions '("default" "Switch to buffer") - :on-action (lambda (&rest _) - (pop-to-buffer channel))))))) + (funcall (cond ((featurep 'android) + #'android-notifications-notify) + ((featurep 'haiku) + #'haiku-notifications-notify) + (t #'notifications-notify)) + :bus erc-notifications-bus + :title title + :body body + :replaces-id erc-notifications-last-notification + :app-icon erc-notifications-icon + :actions '("default" "Switch to buffer") + :on-action (lambda (&rest _) + (pop-to-buffer channel))))))) (defun erc-notifications-PRIVMSG (_proc parsed) (let ((nick (car (erc-parse-user (erc-response.sender parsed)))) diff --git a/lisp/gnus/gnus-notifications.el b/lisp/gnus/gnus-notifications.el index f34f5ea0e26..9ef21c91627 100644 --- a/lisp/gnus/gnus-notifications.el +++ b/lisp/gnus/gnus-notifications.el @@ -83,27 +83,46 @@ not get notifications." group (delq article (gnus-list-of-unread-articles group))) ;; gnus-group-refresh-group - (gnus-group-update-group group))))))) + (gnus-group-update-group group)))))) + ;; Notifications are removed unless otherwise specified once they (or + ;; an action of theirs) are selected + (assoc-delete-all id gnus-notifications-id-to-msg)) + +(defun gnus-notification-close (id reason) + "Remove ID from the alist of notification identifiers to messages. +REASON is ignored." + (assoc-delete-all id gnus-notifications-id-to-msg)) (defun gnus-notifications-notify (from subject photo-file) "Send a notification about a new mail. Return a notification id if any, or t on success." - (if (fboundp 'notifications-notify) + (if (featurep 'android) (gnus-funcall-no-warning - 'notifications-notify + 'android-notifications-notify :title from :body subject :actions '("read" "Read" "mark-read" "Mark As Read") :on-action 'gnus-notifications-action - :app-icon (gnus-funcall-no-warning - 'image-search-load-path "gnus/gnus.png") - :image-path photo-file - :app-name "Gnus" - :category "email.arrived" + :on-close 'gnus-notifications-close + :group "Email arrivals" :timeout gnus-notifications-timeout) - (message "New message from %s: %s" from subject) - ;; Don't return an id - t)) + (if (fboundp 'notifications-notify) + (gnus-funcall-no-warning + 'notifications-notify + :title from + :body subject + :actions '("read" "Read" "mark-read" "Mark As Read") + :on-action 'gnus-notifications-action + :on-close 'gnus-notifications-close + :app-icon (gnus-funcall-no-warning + 'image-search-load-path "gnus/gnus.png") + :image-path photo-file + :app-name "Gnus" + :category "email.arrived" + :timeout gnus-notifications-timeout) + (message "New message from %s: %s" from subject) + ;; Don't return an id + t))) (declare-function gravatar-retrieve-synchronously "gravatar.el" (mail-address)) diff --git a/src/androidselect.c b/src/androidselect.c index 521133976a7..87dd2c3d079 100644 --- a/src/androidselect.c +++ b/src/androidselect.c @@ -526,7 +526,7 @@ android_init_emacs_desktop_notification (void) FIND_METHOD (init, "", "(Ljava/lang/String;" "Ljava/lang/String;Ljava/lang/String;" "Ljava/lang/String;II[Ljava/lang/String;" - "[Ljava/lang/String;)V"); + "[Ljava/lang/String;J)V"); FIND_METHOD (display, "display", "()V"); #undef FIND_METHOD } @@ -567,16 +567,17 @@ android_locate_icon (const char *name) } /* Display a desktop notification with the provided TITLE, BODY, - REPLACES_ID, GROUP, ICON, URGENCY, ACTIONS, RESIDENT, ACTION_CB and - CLOSE_CB. Return an identifier for the resulting notification. */ + REPLACES_ID, GROUP, ICON, URGENCY, ACTIONS, TIMEOUT, RESIDENT, + ACTION_CB and CLOSE_CB. Return an identifier for the resulting + notification. */ static intmax_t android_notifications_notify_1 (Lisp_Object title, Lisp_Object body, Lisp_Object replaces_id, Lisp_Object group, Lisp_Object icon, Lisp_Object urgency, Lisp_Object actions, - Lisp_Object resident, Lisp_Object action_cb, - Lisp_Object close_cb) + Lisp_Object timeout, Lisp_Object resident, + Lisp_Object action_cb, Lisp_Object close_cb) { static intmax_t counter; intmax_t id; @@ -593,6 +594,7 @@ android_notifications_notify_1 (Lisp_Object title, Lisp_Object body, jint nitems, i; jstring item; Lisp_Object length; + jlong timeout_val; if (EQ (urgency, Qlow)) type = 2; /* IMPORTANCE_LOW */ @@ -603,6 +605,23 @@ android_notifications_notify_1 (Lisp_Object title, Lisp_Object body, else signal_error ("Invalid notification importance given", urgency); + /* Decode the timeout. */ + + timeout_val = 0; + + if (!NILP (timeout)) + { + CHECK_INTEGER (timeout); + + if (!integer_to_intmax (timeout, &id) + || id > TYPE_MAXIMUM (jlong) + || id < TYPE_MINIMUM (jlong)) + signal_error ("Invalid timeout", timeout); + + if (id > 0) + timeout_val = id; + } + nitems = 0; /* If ACTIONS is provided, split it into two arrays of Java strings @@ -714,7 +733,8 @@ android_notifications_notify_1 (Lisp_Object title, Lisp_Object body, notification_class.init, title1, body1, group1, identifier1, icon1, type, - action_keys, action_titles); + action_keys, action_titles, + timeout_val); android_exception_check_6 (title1, body1, group1, identifier1, action_titles, action_keys); @@ -723,12 +743,8 @@ android_notifications_notify_1 (Lisp_Object title, Lisp_Object body, ANDROID_DELETE_LOCAL_REF (body1); ANDROID_DELETE_LOCAL_REF (group1); ANDROID_DELETE_LOCAL_REF (identifier1); - - if (action_keys) - ANDROID_DELETE_LOCAL_REF (action_keys); - - if (action_titles) - ANDROID_DELETE_LOCAL_REF (action_titles); + ANDROID_DELETE_LOCAL_REF (action_keys); + ANDROID_DELETE_LOCAL_REF (action_titles); /* Display the notification. */ (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, @@ -769,8 +785,14 @@ keywords is understood: The action for which CALLBACK is called when the notification itself is selected is named "default", its existence is implied, and its TITLE is ignored. - No more than three actions can be defined, not - counting any action with "default" as its key. + No more than three actions defined here will be + displayed, not counting any with "default" as its + key. + :timeout Number of miliseconds from the display of the + notification at which it will be automatically + dismissed, or a value of zero or smaller if it + is to remain until user action is taken to dismiss + it. :resident When set the notification will not be automatically dismissed when it or an action is selected. :on-action Function to call when an action is invoked. @@ -780,12 +802,15 @@ keywords is understood: with the notification id and the symbol `undefined' for arguments. -The notification group is ignored on Android 7.1 and earlier versions -of Android. Outside such older systems, it identifies a category that -will be displayed in the system Settings menu, and the urgency -provided always extends to affect all notifications displayed within -that category. If the group is not provided, it defaults to the -string "Desktop Notifications". +The notification group and timeout are ignored on Android 7.1 and +earlier versions of Android. On more recent versions, the urgency +identifies a category that will be displayed in the system Settings +menu, and the urgency provided always extends to affect all +notifications displayed within that category, though it may be ignored +if higher than any previously-specified urgency or if the user have +already configured a different urgency for this category from Settings. +If the group is not provided, it defaults to the string "Desktop +Notifications" with the urgency suffixed. Each caller should strive to provide one unchanging combination of notification group and urgency for each kind of notification it sends, @@ -795,8 +820,8 @@ first notification sent to its notification group. The provided icon should be the name of a "drawable resource" present within the "android.R.drawable" class designating an icon with a -transparent background. If no icon is provided (or the icon is absent -from this system), it defaults to "ic_dialog_alert". +transparent background. Should no icon be provided (or the icon is +absent from this system), it defaults to "ic_dialog_alert". Actions specified with :actions cannot be displayed on Android 4.0 and earlier versions of the system. @@ -814,17 +839,18 @@ this function. usage: (android-notifications-notify &rest ARGS) */) (ptrdiff_t nargs, Lisp_Object *args) { - Lisp_Object title, body, replaces_id, group, urgency, resident; + Lisp_Object title, body, replaces_id, group, urgency, timeout, resident; Lisp_Object icon; Lisp_Object key, value, actions, action_cb, close_cb; ptrdiff_t i; + AUTO_STRING (default_icon, "ic_dialog_alert"); if (!android_init_gui) error ("No Android display connection!"); /* Clear each variable above. */ title = body = replaces_id = group = icon = urgency = actions = Qnil; - resident = action_cb = close_cb = Qnil; + timeout = resident = action_cb = close_cb = Qnil; /* If NARGS is odd, error. */ @@ -852,6 +878,8 @@ usage: (android-notifications-notify &rest ARGS) */) icon = value; else if (EQ (key, QCactions)) actions = value; + else if (EQ (key, QCtimeout)) + timeout = value; else if (EQ (key, QCresident)) resident = value; else if (EQ (key, QCon_action)) @@ -874,16 +902,19 @@ usage: (android-notifications-notify &rest ARGS) */) urgency = Qlow; if (NILP (group)) - group = build_string ("Desktop Notifications"); + { + AUTO_STRING (format, "Desktop Notifications (%s importance)"); + group = CALLN (Fformat, format, urgency); + } if (NILP (icon)) - icon = build_string ("ic_dialog_alert"); + icon = default_icon; else CHECK_STRING (icon); return make_int (android_notifications_notify_1 (title, body, replaces_id, group, icon, urgency, - actions, resident, + actions, timeout, resident, action_cb, close_cb)); } @@ -1001,6 +1032,7 @@ syms_of_androidselect (void) DEFSYM (QCurgency, ":urgency"); DEFSYM (QCicon, ":icon"); DEFSYM (QCactions, ":actions"); + DEFSYM (QCtimeout, ":timeout"); DEFSYM (QCresident, ":resident"); DEFSYM (QCon_action, ":on-action"); DEFSYM (QCon_close, ":on-close"); commit 4afafa03704aab0c21e4cb4f028256ecead5f795 Author: Stefan Monnier Date: Tue Mar 12 16:09:23 2024 -0400 Try and avoid hardcoding lists of function types * lisp/bind-key.el (bind-key--get-binding-description): Show docstrings for compiled functions also. Don't hardcode knowledge about various particular kinds of functions. * lisp/emacs-lisp/bytecomp.el (display-call-tree): Remove special support for functions with a `byte-code` body since we never generate that nowadays. Don't hardcode knowledge about various particular kinds of functions. diff --git a/lisp/bind-key.el b/lisp/bind-key.el index 378ad69b2bc..1e59c75566a 100644 --- a/lisp/bind-key.el +++ b/lisp/bind-key.el @@ -453,31 +453,27 @@ other modes. See `override-global-mode'." (macroexp-progn (bind-keys-form args 'override-global-map))) (defun bind-key--get-binding-description (elem) - (cond - ((listp elem) + (let (doc) (cond - ((memq (car elem) '(lambda function)) - (if (and bind-key-describe-special-forms - (stringp (nth 2 elem))) - (nth 2 elem) - "#")) - ((eq 'closure (car elem)) - (if (and bind-key-describe-special-forms - (stringp (nth 3 elem))) - (nth 3 elem) - "#")) - ((eq 'keymap (car elem)) - "#") + ((symbolp elem) + (cond + ((and bind-key-describe-special-forms (keymapp elem) + ;; FIXME: Is this really ever better than the symbol-name? + ;; FIXME: `variable-documentation' describe what's in + ;; elem's `symbol-value', whereas `elem' here stands for + ;; its `symbol-function'. + (stringp (setq doc (get elem 'variable-documentation)))) + doc) + (t elem))) + ((and bind-key-describe-special-forms (functionp elem) + (stringp (setq doc (documentation elem)))) + doc) ;;FIXME: Keep only the first line? + ((consp elem) + (if (symbolp (car elem)) + (format "#<%s>" (car elem)) + elem)) (t - elem))) - ;; must be a symbol, non-symbol keymap case covered above - ((and bind-key-describe-special-forms (keymapp elem)) - (let ((doc (get elem 'variable-documentation))) - (if (stringp doc) doc elem))) - ((symbolp elem) - elem) - (t - "#"))) + (format "#<%s>" (type-of elem)))))) (defun bind-key--compare-keybindings (l r) (let* ((regex bind-key-segregation-regexp) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index cf0e6d600dd..7af568cfe34 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -5536,23 +5536,14 @@ invoked interactively." (if (null f) " ";; shouldn't insert nil then, actually -sk " ")) - ((subrp (setq f (symbol-function f))) - " ") - ((symbolp f) + ((symbolp (setq f (symbol-function f))) ;; An alias. (format " ==> %s" f)) - ((byte-code-function-p f) - "") ((not (consp f)) - "") + (format " <%s>" (type-of f))) ((eq 'macro (car f)) - (if (or (compiled-function-p (cdr f)) - ;; FIXME: Can this still happen? - (assq 'byte-code (cdr (cdr (cdr f))))) + (if (compiled-function-p (cdr f)) " " " ")) - ((assq 'byte-code (cdr (cdr f))) - ;; FIXME: Can this still happen? - "") ((eq 'lambda (car f)) "") (t "???")) commit 8df673907781bce8b080b91b056cb9987587387c Author: Stefan Monnier Date: Tue Mar 12 15:43:43 2024 -0400 Cleanup some type predicates Use the new `cl--define-built-in-type` to reduce the manually maintained list of built-in type predicates. Also tweak docstrings to use "supertype" rather than "super type", since it seems to be what we use elsewhere. * lisp/subr.el (special-form-p): Remove redundant `fboundp` test. (compiled-function-p): Don'Return nil for subrs that aren't functions. * lisp/emacs-lisp/cl-macs.el (type predicates): Trim down the list. * lisp/emacs-lisp/cl-preloaded.el (cl--define-built-in-type): Register the corresponding predicate if applicable. (atom, null): Specify the predicate name explicitly. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index be477b7a6df..129b83c61b9 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3463,45 +3463,12 @@ Of course, we really can't know that for sure, so it's just a heuristic." ;; Please keep it in sync with `comp-known-predicates'. (pcase-dolist (`(,type . ,pred) ;; Mostly kept in alphabetical order. - '((array . arrayp) - (atom . atom) - (base-char . characterp) - (bignum . bignump) - (boolean . booleanp) - (bool-vector . bool-vector-p) - (buffer . bufferp) - (byte-code-function . byte-code-function-p) - (character . natnump) - (char-table . char-table-p) - (command . commandp) - (compiled-function . compiled-function-p) - (hash-table . hash-table-p) - (cons . consp) - (fixnum . fixnump) - (float . floatp) - (frame . framep) - (function . functionp) - (integer . integerp) - (keyword . keywordp) - (list . listp) - (marker . markerp) - (natnum . natnump) - (number . numberp) - (null . null) - (obarray . obarrayp) - (overlay . overlayp) - (process . processp) - (real . numberp) - (sequence . sequencep) - (subr . subrp) - (string . stringp) - (symbol . symbolp) - (symbol-with-pos . symbol-with-pos-p) - (vector . vectorp) - (window . windowp) - ;; FIXME: Do we really want to consider these types? - (number-or-marker . number-or-marker-p) - (integer-or-marker . integer-or-marker-p) + ;; These aren't defined via `cl--define-built-in-type'. + '((base-char . characterp) ;Could be subtype of `fixnum'. + (character . natnump) ;Could be subtype of `fixnum'. + (command . commandp) ;Subtype of closure & subr. + (natnum . natnump) ;Subtype of fixnum & bignum. + (real . numberp) ;Not clear where it would fit. )) (put type 'cl-deftype-satisfies pred)) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 5743684fa89..515aa99549d 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -308,7 +308,7 @@ (:copier nil)) ) -(defmacro cl--define-built-in-type (name parents &optional docstring &rest _slots) +(defmacro cl--define-built-in-type (name parents &optional docstring &rest slots) ;; `slots' is currently unused, but we could make it take ;; a list of "slot like properties" together with the corresponding ;; accessor, and then we could maybe even make `slot-value' work @@ -317,15 +317,26 @@ (unless (listp parents) (setq parents (list parents))) (unless (or parents (eq name t)) (error "Missing parents for %S: %S" name parents)) - `(progn - (put ',name 'cl--class - (built-in-class--make ',name ,docstring - (mapcar (lambda (type) - (let ((class (get type 'cl--class))) - (unless class - (error "Unknown type: %S" type)) - class)) - ',parents))))) + (let ((predicate (intern-soft (format + (if (string-match "-" (symbol-name name)) + "%s-p" "%sp") + name)))) + (unless (fboundp predicate) (setq predicate nil)) + (while (keywordp (car slots)) + (let ((kw (pop slots)) (val (pop slots))) + (pcase kw + (:predicate (setq predicate val)) + (_ (error "Unknown keyword arg: %S" kw))))) + `(progn + ,(if predicate `(put ',name 'cl-deftype-satisfies #',predicate)) + (put ',name 'cl--class + (built-in-class--make ',name ,docstring + (mapcar (lambda (type) + (let ((class (get type 'cl--class))) + (unless class + (error "Unknown type: %S" type)) + class)) + ',parents)))))) ;; FIXME: Our type DAG has various quirks: ;; - `subr' says it's a `compiled-function' but that's not true @@ -336,8 +347,9 @@ ;; so the DAG of OClosure types is "orthogonal" to the distinction ;; between interpreted and compiled functions. -(cl--define-built-in-type t nil "The type of everything.") -(cl--define-built-in-type atom t "The type of anything but cons cells.") +(cl--define-built-in-type t nil "Abstract supertype of everything.") +(cl--define-built-in-type atom t "Abstract supertype of anything but cons cells." + :predicate atom) (cl--define-built-in-type tree-sitter-compiled-query atom) (cl--define-built-in-type tree-sitter-node atom) @@ -358,7 +370,7 @@ (cl--define-built-in-type window-configuration atom) (cl--define-built-in-type overlay atom) (cl--define-built-in-type number-or-marker atom - "Abstract super type of both `number's and `marker's.") + "Abstract supertype of both `number's and `marker's.") (cl--define-built-in-type symbol atom "Type of symbols." ;; Example of slots we could document. It would be desirable to @@ -373,14 +385,14 @@ (cl--define-built-in-type obarray atom) (cl--define-built-in-type native-comp-unit atom) -(cl--define-built-in-type sequence t "Abstract super type of sequences.") +(cl--define-built-in-type sequence t "Abstract supertype of sequences.") (cl--define-built-in-type list sequence) -(cl--define-built-in-type array (sequence atom) "Abstract super type of arrays.") +(cl--define-built-in-type array (sequence atom) "Abstract supertype of arrays.") (cl--define-built-in-type number (number-or-marker) - "Abstract super type of numbers.") + "Abstract supertype of numbers.") (cl--define-built-in-type float (number)) (cl--define-built-in-type integer-or-marker (number-or-marker) - "Abstract super type of both `integer's and `marker's.") + "Abstract supertype of both `integer's and `marker's.") (cl--define-built-in-type integer (number integer-or-marker)) (cl--define-built-in-type marker (integer-or-marker)) (cl--define-built-in-type bignum (integer) @@ -404,13 +416,14 @@ For this build of Emacs it's %dbit." "Type of special arrays that are indexed by characters.") (cl--define-built-in-type string (array)) (cl--define-built-in-type null (boolean list) ;FIXME: `atom' comes before `list'? - "Type of the nil value.") + "Type of the nil value." + :predicate null) (cl--define-built-in-type cons (list) "Type of cons cells." ;; Example of slots we could document. (car car) (cdr cdr)) (cl--define-built-in-type function (atom) - "Abstract super type of function values.") + "Abstract supertype of function values.") (cl--define-built-in-type compiled-function (function) "Abstract type of functions that have been compiled.") (cl--define-built-in-type byte-code-function (compiled-function) diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index 977d5735171..4da8e61aaa7 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -437,7 +437,7 @@ This has 2 uses: - For compiled code, this is used as a marker which cconv uses to check that immutable fields are indeed not mutated." (if (byte-code-function-p oclosure) - ;; Actually, this should never happen since the `cconv.el' should have + ;; Actually, this should never happen since `cconv.el' should have ;; optimized away the call to this function. oclosure ;; For byte-coded functions, we store the type as a symbol in the docstring diff --git a/lisp/subr.el b/lisp/subr.el index ce933e3bfdc..38a3f6edb34 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -4494,8 +4494,7 @@ Otherwise, return nil." (defun special-form-p (object) "Non-nil if and only if OBJECT is a special form." (declare (side-effect-free error-free)) - (if (and (symbolp object) (fboundp object)) - (setq object (indirect-function object))) + (if (symbolp object) (setq object (indirect-function object))) (and (subrp object) (eq (cdr (subr-arity object)) 'unevalled))) (defun plistp (object) @@ -4517,7 +4516,8 @@ Otherwise, return nil." Does not distinguish between functions implemented in machine code or byte-code." (declare (side-effect-free error-free)) - (or (subrp object) (byte-code-function-p object))) + (or (and (subrp object) (not (eq 'unevalled (cdr (subr-arity object))))) + (byte-code-function-p object))) (defun field-at-pos (pos) "Return the field at position POS, taking stickiness etc into account." commit 3e96dd4f8851a45c66ebc9b8666ae449cc4c2725 Author: Stefan Monnier Date: Tue Mar 12 12:00:17 2024 -0400 cl-generic: Signal an error when a type specializer won't work * lisp/emacs-lisp/cl-generic.el (cl--generic--unreachable-types): New var. (cl-generic-generalizers :extra "typeof"): Use it to signal an error for those types we can't handle. diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 84eb800ec24..613ecf82a92 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -1332,6 +1332,12 @@ These match if the argument is `eql' to VAL." ;;; Dispatch on "normal types". +(defconst cl--generic--unreachable-types + ;; FIXME: Try to make that list empty? + '(fixnum bignum boolean keyword + special-form subr-primitive subr-native-elisp) + "Built-in classes on which we cannot dispatch for technical reasons.") + (defun cl--generic-type-specializers (tag &rest _) (and (symbolp tag) (let ((class (cl--find-class tag))) @@ -1352,6 +1358,8 @@ This currently works for built-in types and types built on top of records." (and (symbolp type) (not (eq type t)) ;; Handled by the `t-generalizer'. (let ((class (cl--find-class type))) + (when (memq type cl--generic--unreachable-types) + (error "Dispatch on %S is currently not supported" type)) (memq (type-of class) '(built-in-class cl-structure-class eieio--class))) (list cl--generic-typeof-generalizer)) commit 0cc44094613530744d3650e4a169335374d6727b Author: Eli Zaretskii Date: Tue Mar 12 15:30:18 2024 +0200 ; * admin/MAINTAINERS: Add Daniel Pettersson. diff --git a/admin/MAINTAINERS b/admin/MAINTAINERS index f59c684e81f..ec719744339 100644 --- a/admin/MAINTAINERS +++ b/admin/MAINTAINERS @@ -360,6 +360,9 @@ Po Lu X11 and GTK xwidget support in src/xwidget.c Precision pixel scrolling in lisp/pixel-scroll.el +Daniel Pettersson + lisp/jsonrpc.el + ============================================================================== 3. Externally maintained packages. ============================================================================== commit 7c552b22e64fa9173557e3511aa4e37ac1d5ea59 Author: Daniel Pettersson Date: Wed Feb 28 13:03:56 2024 +0100 Jsonrpc: improve performance of process filter function `run-at-time' keeps `timer-list' list sorted by inserting each timer based on the timer value. This means that `timer--time-less-p' needs is executed ~N*N/2 times for each N pending messages. This means that jsonrpc becomes unusable for connections that generate a lot messages at the same time. * lisp/jsonrpc.el (Version): Bump to 1.0.25. (jsonrpc--process-filter): Improve performance by activating timers in a different order. (Bug#69241) diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 14fe0447008..5037d8c5b2b 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -4,7 +4,7 @@ ;; Author: João Távora ;; Keywords: processes, languages, extensions -;; Version: 1.0.24 +;; Version: 1.0.25 ;; Package-Requires: ((emacs "25.2")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -760,10 +760,11 @@ With optional CLEANUP, kill any associated buffers." (setq message (plist-put message :jsonrpc-json (buffer-string))) - (process-put proc 'jsonrpc-mqueue - (nconc (process-get proc - 'jsonrpc-mqueue) - (list message))))) + ;; Put new messages at the front of the queue, + ;; this is correct as the order is reversed + ;; before putting the timers on `timer-list'. + (push message + (process-get proc 'jsonrpc-mqueue)))) (goto-char message-end) (let ((inhibit-read-only t)) (delete-region (point-min) (point))) @@ -782,11 +783,20 @@ With optional CLEANUP, kill any associated buffers." ;; non-locally (typically the reply to a request), so do ;; this all this processing in top-level loops timer. (cl-loop + ;; `timer-activate' orders timers by time, which is an + ;; very expensive operation when jsonrpc-mqueue is large, + ;; therefore the time object is reused for each timer + ;; created. + with time = (current-time) for msg = (pop (process-get proc 'jsonrpc-mqueue)) while msg - do (run-at-time 0 nil - (lambda (m) (with-temp-buffer - (jsonrpc-connection-receive conn m))) - msg))))))) + do (let ((timer (timer-create))) + (timer-set-time timer time) + (timer-set-function timer + (lambda (conn msg) + (with-temp-buffer + (jsonrpc-connection-receive conn msg))) + (list conn msg)) + (timer-activate timer)))))))) (defun jsonrpc--remove (conn id &optional deferred-spec) "Cancel CONN's continuations for ID, including its timer, if it exists. commit d5773276fb1671da619eeee2c316098d6b1c25c4 Author: Stefan Monnier Date: Tue Mar 12 08:48:09 2024 -0400 (comp-known-predicates): Fix overly optimistic `functionp` * lisp/emacs-lisp/comp.el (comp-known-predicates): `functionp` can also be true for `cons` objects. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 21e2bb01ed0..9c2182092cb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -202,7 +202,7 @@ Useful to hook into pass checkers.") (consp . cons) (floatp . float) (framep . frame) - (functionp . (or function symbol)) + (functionp . (or function symbol cons)) (hash-table-p . hash-table) (integer-or-marker-p . integer-or-marker) (integerp . integer) @@ -244,6 +244,7 @@ Useful to hook into pass checkers.") (defun comp--pred-to-cstr (predicate) "Given PREDICATE, return the corresponding constraint." + ;; FIXME: Unify those two hash tables? (or (gethash predicate comp-known-predicates-h) (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt))))