commit d664969544b13fe93a548c9908ce566f9b5cde9c (HEAD, refs/remotes/origin/master) Author: Yuan Fu Date: Thu Apr 13 19:18:52 2023 -0700 Fix tree-sitter test * test/src/treesit-tests.el: (treesit-search-forward-predicate-invalid-predicate): Fix test. diff --git a/test/src/treesit-tests.el b/test/src/treesit-tests.el index 34f9f15beaa..ecdee3c26e4 100644 --- a/test/src/treesit-tests.el +++ b/test/src/treesit-tests.el @@ -378,13 +378,13 @@ treesit-search-forward-predicate-invalid-predicate "Test tree-sitter's ability to detect invalid predicates." (skip-unless (treesit-language-available-p 'json)) (treesit--ert-search-setup - (dolist (pred '( 1 (not 1) (not "2" "3") (or) (or 1))) + (dolist (pred '( 1 (not 1) (not "2" "3") (or) (or 1) 'a)) (should-error (treesit-search-forward (treesit-node-child array 0) pred) :type 'treesit-invalid-predicate)) (should-error (treesit-search-forward (treesit-node-child array 0) - 'not-a-function) - :type 'void-function))) + (lambda (node) (car node))) + :type 'wrong-type-argument))) (ert-deftest treesit-cursor-helper-with-missing-node () "Test treesit_cursor_helper with a missing node." commit de34de3b35cbe1da6fb035b93081e0564b3c7b3f Author: Yuan Fu Date: Thu Apr 13 18:45:07 2023 -0700 Fix previous commit on tree-sitter * src/treesit.c: (treesit_traverse_validate_predicate): Don't accept symbols. (treesit_traverse_match_predicate): Don't accept symbols, and use correct variable for the regexp and pred check. * test/src/treesit-tests.el: (treesit-search-forward-predicate): Fix the test. diff --git a/src/treesit.c b/src/treesit.c index 45b5ab15390..d0d9c50c14f 100644 --- a/src/treesit.c +++ b/src/treesit.c @@ -3148,9 +3148,7 @@ treesit_traverse_validate_predicate (Lisp_Object pred, { if (STRINGP (pred)) return true; - /* We want to allow cl-labels-defined functions, so we allow - symbols. */ - else if (FUNCTIONP (pred) || SYMBOLP (pred)) + else if (FUNCTIONP (pred)) return true; else if (CONSP (pred)) { @@ -3194,8 +3192,7 @@ treesit_traverse_validate_predicate (Lisp_Object pred, } return true; } - /* We allow the function to be a symbol to support cl-label. */ - else if (STRINGP (car) && (FUNCTIONP (cdr) || SYMBOLP (cdr))) + else if (STRINGP (car) && FUNCTIONP (cdr)) return true; } *signal_data = list2 (build_string ("Invalid predicate, see TODO for " @@ -3230,9 +3227,7 @@ treesit_traverse_match_predicate (TSTreeCursor *cursor, Lisp_Object pred, const char *type = ts_node_type (node); return fast_c_string_match (pred, type, strlen (type)) >= 0; } - /* We want to allow cl-labels-defined functions, so we allow - symbols. */ - else if (FUNCTIONP (pred) || SYMBOLP (pred)) + else if (FUNCTIONP (pred)) { Lisp_Object lisp_node = make_treesit_node (parser, node); return !NILP (CALLN (Ffuncall, pred, lisp_node)); @@ -3255,17 +3250,15 @@ treesit_traverse_match_predicate (TSTreeCursor *cursor, Lisp_Object pred, } return false; } - /* We want to allow cl-labels-defined functions, so we allow - symbols. */ - else if (STRINGP (car) && (FUNCTIONP (cdr) || SYMBOLP (cdr))) + else if (STRINGP (car) && FUNCTIONP (cdr)) { /* A bit of code duplication here, but should be fine. */ const char *type = ts_node_type (node); - if (!(fast_c_string_match (pred, type, strlen (type)) >= 0)) + if (!(fast_c_string_match (car, type, strlen (type)) >= 0)) return false; Lisp_Object lisp_node = make_treesit_node (parser, node); - if (NILP (CALLN (Ffuncall, pred, lisp_node))) + if (NILP (CALLN (Ffuncall, cdr, lisp_node))) return false; return true; diff --git a/test/src/treesit-tests.el b/test/src/treesit-tests.el index 26a21c34152..34f9f15beaa 100644 --- a/test/src/treesit-tests.el +++ b/test/src/treesit-tests.el @@ -363,11 +363,12 @@ treesit-search-forward-predicate while cursor do (should (equal (treesit-node-text cursor) text))) ;; Test (regexp . function) - (cl-labels ((is-odd (string) - (and (eq 1 (length string)) - (cl-oddp (string-to-number string))))) + (let ((is-odd (lambda (node) + (let ((string (treesit-node-text node))) + (and (eq 1 (length string)) + (cl-oddp (string-to-number string))))))) (cl-loop for cursor = (treesit-node-child array 0) - then (treesit-search-forward cursor '("number" . is-odd) + then (treesit-search-forward cursor `("number" . ,is-odd) nil t) for text in '("[" "1" "3" "5" "7" "9") while cursor commit 3ef54c64fa8e7236458228db09fe7192350cbeb6 Author: Andrew G Cohen Date: Fri Apr 14 08:42:29 2023 +0800 Fix and cleanup nnselect-push-info * lisp/gnus/nnselect.el (nnselect-push-info): Don't update backend marks when quit-config is not nil since gnus-update-marks has already been called. Move checking for unread articles outside the gnus-atomic block so it may be interrupted. Replace let* with let. Cleanup code. diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index 57a833de9bf..4eaaffe34a5 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -885,13 +885,14 @@ nnselect-search-thread -(defun nnselect-push-info (_group) +(defun nnselect-push-info (group) "Copy mark-lists from GROUP to the originating groups." (let ((select-unreads (numbers-by-group gnus-newsgroup-unreads)) (select-reads (numbers-by-group (gnus-sorted-difference gnus-newsgroup-articles gnus-newsgroup-unreads))) (select-unseen (numbers-by-group gnus-newsgroup-unseen)) + (quit-config (gnus-group-quit-config group)) (gnus-newsgroup-active nil) mark-list) ;; collect the set of marked article lists categorized by ;; originating groups @@ -903,124 +904,120 @@ nnselect-push-info (unless (eq 'tuple mark-type) (setq type-list (range-list-intersection gnus-newsgroup-articles type-list))) - (push (cons - type - (numbers-by-group type-list mark-type)) + (push (cons type (numbers-by-group type-list mark-type)) mark-list)))) ;; now work on each originating group one at a time (pcase-dolist (`(,artgroup . ,artlist) - (numbers-by-group gnus-newsgroup-articles)) + (numbers-by-group gnus-newsgroup-articles)) (setq artlist (sort artlist #'<)) - (let* ((group-info (gnus-get-info artgroup)) - (old-unread (gnus-list-of-unread-articles artgroup)) - newmarked delta-marks) - (when group-info - ;; iterate over mark lists for this group - (pcase-dolist (`(,_mark . ,type) gnus-article-mark-lists) - (let ((list (cdr (assoc artgroup (alist-get type mark-list)))) - (mark-type (gnus-article-mark-to-type type))) - - ;; When the backend can store marks we collect any - ;; changes. Unlike a normal group the mark lists only - ;; include marks for articles we retrieved. - (when (and (gnus-check-backend-function - 'request-set-mark gnus-newsgroup-name) - (not (gnus-article-unpropagatable-p type))) - (let* ((old (range-list-intersection - artlist - (alist-get type (gnus-info-marks group-info)))) - (del (range-remove (copy-tree old) list)) - (add (range-remove (copy-tree list) old))) - (when add (push (list add 'add (list type)) delta-marks)) - (when del - ;; Don't delete marks from outside the active range. - ;; This shouldn't happen, but is a sanity check. - (setq del (range-intersection - (gnus-active artgroup) del)) - (push (list del 'del (list type)) delta-marks)))) - - ;; Marked sets are of mark-type 'tuple, 'list, or - ;; 'range. We merge the lists with what is already in - ;; the original info to get full list of new marks. We - ;; do this by removing all the articles we retrieved - ;; from the full list, and then add back in the newly - ;; marked ones. - (cond - ((eq mark-type 'tuple) - ;; Get rid of the entries that have the default - ;; score. - (when (and list (eq type 'score) gnus-save-score) - (let* ((arts list) - (prev (cons nil list)) - (all prev)) - (while arts - (if (or (not (consp (car arts))) - (= (cdar arts) gnus-summary-default-score)) - (setcdr prev (cdr arts)) - (setq prev arts)) - (setq arts (cdr arts))) - (setq list (cdr all)))) - ;; now merge with the original list and sort just to - ;; make sure - (setq - list (sort + (let ((group-info (gnus-get-info artgroup)) + (old-unread (gnus-list-of-unread-articles artgroup)) + (rsm (gnus-check-backend-function 'request-set-mark artgroup)) + newmarked delta-marks) + (when group-info + ;; iterate over mark lists for this group + (pcase-dolist (`(,_mark . ,type) gnus-article-mark-lists) + (let ((list (cdr (assoc artgroup (alist-get type mark-list)))) + (mark-type (gnus-article-mark-to-type type)) + (group-marks (alist-get type (gnus-info-marks group-info)))) + + ;; When the backend can store marks we collect any + ;; changes. Unlike a normal group the mark lists only + ;; include marks for articles we retrieved. If there is + ;; no quit-config then gnus-update-marks has already + ;; been called to handle this. + (when (and quit-config rsm + (not (gnus-article-unpropagatable-p type))) + (let* ((old (range-list-intersection + artlist group-marks)) + (del (range-remove (copy-tree old) list)) + (add (range-remove (copy-tree list) old))) + (when add (push (list add 'add (list type)) delta-marks)) + (when del + ;; Don't delete marks from outside the active range. + ;; This shouldn't happen, but is a sanity check. + (setq del (range-intersection (gnus-active artgroup) del)) + (push (list del 'del (list type)) delta-marks)))) + + ;; Marked sets are of mark-type 'tuple, 'list, or + ;; 'range. We merge the lists with what is already in + ;; the original info to get full list of new marks. We + ;; do this by removing all the articles we retrieved + ;; from the full list, and then add back in the newly + ;; marked ones. + (cond + ((eq mark-type 'tuple) + ;; Get rid of the entries that have the default + ;; score. + (when (and list (eq type 'score) gnus-save-score) + (let* ((arts list) + (prev (cons nil list)) + (all prev)) + (while arts + (if (or (not (consp (car arts))) + (= (cdar arts) gnus-summary-default-score)) + (setcdr prev (cdr arts)) + (setq prev arts)) + (setq arts (cdr arts))) + (setq list (cdr all)))) + ;; now merge with the original list and sort just to + ;; make sure + (setq list + (sort (map-merge - 'alist list + 'alist list (delq nil (mapcar (lambda (x) (unless (memq (car x) artlist) x)) - (alist-get type (gnus-info-marks group-info))))) + group-marks))) 'car-less-than-car))) - (t - (setq list - (range-compress-list - (gnus-sorted-union - (gnus-sorted-difference - (gnus-uncompress-sequence - (alist-get type (gnus-info-marks group-info))) - artlist) - (sort list #'<))))) - - ;; When exiting the group, everything that's previously been - ;; unseen is now seen. - (when (eq type 'seen) - (setq list (range-concat - list (cdr (assoc artgroup select-unseen)))))) - - (when (or list (eq type 'unexist)) - (push (cons type list) newmarked)))) ;; end of mark-type loop - - (when delta-marks - (unless (gnus-check-group artgroup) - (error "Can't open server for %s" artgroup)) - (gnus-request-set-mark artgroup delta-marks)) - - (gnus-atomic-progn - (gnus-info-set-marks group-info newmarked) - ;; Cut off the end of the info if there's nothing else there. - (let ((i 5)) - (while (and (> i 2) - (not (nth i group-info))) - (when (nthcdr (cl-decf i) group-info) - (setcdr (nthcdr i group-info) nil)))) - - ;; update read and unread - (gnus-update-read-articles - artgroup - (range-uncompress - (range-add-list - (range-remove - old-unread - (cdr (assoc artgroup select-reads))) - (sort (cdr (assoc artgroup select-unreads)) #'<)))) - (gnus-get-unread-articles-in-group - group-info (gnus-active artgroup) t)) - (gnus-group-update-group - artgroup t - (equal group-info - (setq group-info (copy-sequence (gnus-get-info artgroup)) - group-info - (delq (gnus-info-params group-info) group-info))))))))) + (t + (setq list + (range-compress-list + (gnus-sorted-union + (gnus-sorted-difference + (gnus-uncompress-sequence group-marks) + artlist) + (sort list #'<)))) + + ;; When exiting the group, everything that's previously been + ;; unseen is now seen. + (when (eq type 'seen) + (setq list (range-concat + list (cdr (assoc artgroup select-unseen))))))) + + (when (or list (eq type 'unexist)) + (push (cons type list) newmarked)))) ;; end of mark-type loop + (when delta-marks + (unless (gnus-check-group artgroup) + (error "Can't open server for %s" artgroup)) + (gnus-request-set-mark artgroup delta-marks)) + (gnus-atomic-progn + (gnus-info-set-marks group-info newmarked) + ;; Cut off the end of the info if there's nothing else there. + (let ((i 5)) + (while (and (> i 2) + (not (nth i group-info))) + (when (nthcdr (cl-decf i) group-info) + (setcdr (nthcdr i group-info) nil)))) + + ;; update read and unread + (gnus-update-read-articles + artgroup + (range-uncompress + (range-add-list + (range-remove + old-unread + (cdr (assoc artgroup select-reads))) + (sort (cdr (assoc artgroup select-unreads)) #'<))))) + (gnus-get-unread-articles-in-group + group-info (gnus-active artgroup) t) + (gnus-group-update-group + artgroup t + (equal group-info + (setq group-info (copy-sequence (gnus-get-info artgroup)) + group-info + (delq (gnus-info-params group-info) group-info))))))))) (declare-function gnus-registry-get-id-key "gnus-registry" (id key)) commit 2c3ca78e811b288aa4801f78c11ba9ddf9ffe02c Author: Po Lu Date: Fri Apr 14 08:01:12 2023 +0800 Fix bugs in treesit.o * src/treesit.c (treesit_traverse_match_predicate): Remove redundant cast. (treesit_search_forward, treesit_traverse_cleanup_cursor) (Ftreesit_search_subtree, Ftreesit_search_forward) (Ftreesit_induce_sparse_tree): Fix coding style and specpdl unwinding. diff --git a/src/treesit.c b/src/treesit.c index 09d998b56c8..45b5ab15390 100644 --- a/src/treesit.c +++ b/src/treesit.c @@ -3243,10 +3243,8 @@ treesit_traverse_match_predicate (TSTreeCursor *cursor, Lisp_Object pred, Lisp_Object cdr = XCDR (pred); if (EQ (car, Qnot)) - { - return !treesit_traverse_match_predicate (cursor, XCAR (cdr), - parser, named); - } + return !treesit_traverse_match_predicate (cursor, XCAR (cdr), + parser, named); else if (EQ (car, Qor)) { FOR_EACH_TAIL (cdr) @@ -3287,6 +3285,7 @@ treesit_traverse_match_predicate (TSTreeCursor *cursor, Lisp_Object pred, forward, false backward. If SKIP_ROOT is true, don't match ROOT. This function may signal if the predicate function signals. */ + static bool treesit_search_dfs (TSTreeCursor *cursor, Lisp_Object pred, Lisp_Object parser, @@ -3325,6 +3324,7 @@ treesit_search_dfs (TSTreeCursor *cursor, position is undefined. This function may signal if the predicate function signals. */ + static bool treesit_search_forward (TSTreeCursor *cursor, Lisp_Object pred, Lisp_Object parser, @@ -3334,8 +3334,7 @@ treesit_search_forward (TSTreeCursor *cursor, nodes. This way repeated call of this function traverses each node in the tree once and only once: - (while node (setq node (treesit-search-forward node))) - */ + (while node (setq node (treesit-search-forward node))) */ bool initial = true; while (true) { @@ -3362,10 +3361,12 @@ treesit_search_forward (TSTreeCursor *cursor, } } -/** Cleanup function for cursor. */ -static void treesit_traverse_cleanup_cursor(void *cursor) +/* Clean up the given tree cursor CURSOR. */ + +static void +treesit_traverse_cleanup_cursor (void *cursor) { - ts_tree_cursor_delete ((TSTreeCursor *) cursor); + ts_tree_cursor_delete (cursor); } DEFUN ("treesit-search-subtree", @@ -3421,10 +3422,7 @@ DEFUN ("treesit-search-subtree", return_value = make_treesit_node (parser, node); } - unbind_to (count, Qnil); - - ts_tree_cursor_delete (&cursor); - return return_value; + return unbind_to (count, return_value); } DEFUN ("treesit-search-forward", @@ -3486,10 +3484,7 @@ DEFUN ("treesit-search-forward", return_value = make_treesit_node (parser, node); } - unbind_to (count, Qnil); - - ts_tree_cursor_delete (&cursor); - return return_value; + return unbind_to (count, return_value); } /* Recursively traverse the tree under CURSOR, and append the result @@ -3616,8 +3611,8 @@ DEFUN ("treesit-induce-sparse-tree", unbind_to (count, Qnil); - ts_tree_cursor_delete (&cursor); Fsetcdr (parent, Fnreverse (Fcdr (parent))); + if (NILP (Fcdr (parent))) return Qnil; else commit 361c5fc2d8e52d70aa58956c57eaef9495881197 Author: Yuan Fu Date: Thu Apr 13 15:03:05 2023 -0700 Support more predicates in tree-sitter search functions Right now we support regexp strings and predicate functions for the PRED argument. This change adds support for (not ...) (or ...) and (regexp . pred) predicates. I still need to find a place to document the supported shapes of a predicate. * src/treesit.c (treesit_traverse_validate_predicate): New function. (treesit_traverse_match_predicate): Support more predicate shapes. (treesit_search_dfs): (treesit_search_forward) (treesit_build_sparse_tree): Fix docstring (unrelated to this change). (Ftreesit_search_subtree) (Ftreesit_search_forward) (Ftreesit_induce_sparse_tree): Use the new function to validate predicate shape. (syms_of_treesit): New error Qtreesit_invalid_predicate. * test/src/treesit-tests.el: (treesit--ert-search-setup): Add edebug declaration. (treesit-search-forward-predicate) (treesit-search-forward-predicate-invalid-predicate): New tests. diff --git a/src/treesit.c b/src/treesit.c index 76d1dc8ccf4..09d998b56c8 100644 --- a/src/treesit.c +++ b/src/treesit.c @@ -3139,10 +3139,84 @@ treesit_traverse_child_helper (TSTreeCursor *cursor, } } -/* Return true if the node at CURSOR matches PRED. PRED can be a - string or a function. This function assumes PRED is either a - string or a function. If NAMED is true, also check that the node - is named. */ +/* Validate the PRED passed to treesit_traverse_match_predicate. If + there's an error, set SIGNAL_DATA to something signal accepts, and + return false, otherwise return true. */ +static bool +treesit_traverse_validate_predicate (Lisp_Object pred, + Lisp_Object *signal_data) +{ + if (STRINGP (pred)) + return true; + /* We want to allow cl-labels-defined functions, so we allow + symbols. */ + else if (FUNCTIONP (pred) || SYMBOLP (pred)) + return true; + else if (CONSP (pred)) + { + Lisp_Object car = XCAR (pred); + Lisp_Object cdr = XCDR (pred); + if (EQ (car, Qnot)) + { + if (!CONSP (cdr)) + { + *signal_data = list2 (build_string ("Invalide `not' " + "predicate"), + pred); + return false; + } + /* At this point CDR must be a cons. */ + if (XFIXNUM (Flength (cdr)) != 1) + { + *signal_data = list2 (build_string ("`not' can only " + "have one argument"), + pred); + return false; + } + return treesit_traverse_validate_predicate (XCAR (cdr), + signal_data); + } + else if (EQ (car, Qor)) + { + if (!CONSP (cdr) || NILP (cdr)) + { + *signal_data = list2 (build_string ("`or' must have a list " + "of patterns as " + "arguments "), + pred); + return false; + } + FOR_EACH_TAIL (cdr) + { + if (!treesit_traverse_validate_predicate (XCAR (cdr), + signal_data)) + return false; + } + return true; + } + /* We allow the function to be a symbol to support cl-label. */ + else if (STRINGP (car) && (FUNCTIONP (cdr) || SYMBOLP (cdr))) + return true; + } + *signal_data = list2 (build_string ("Invalid predicate, see TODO for " + "valid forms of predicate"), + pred); + return false; +} + +/* Return true if the node at CURSOR matches PRED. PRED can be a lot + of things: + + PRED := string | function | (string . function) + | (or PRED...) | (not PRED) + + See docstring of treesit-search-forward and friends for the meaning + of each shape. + + This function assumes PRED is in one of its valid forms. If NAMED + is true, also check that the node is named. + + This function may signal if the predicate function signals. */ static bool treesit_traverse_match_predicate (TSTreeCursor *cursor, Lisp_Object pred, Lisp_Object parser, bool named) @@ -3156,24 +3230,63 @@ treesit_traverse_match_predicate (TSTreeCursor *cursor, Lisp_Object pred, const char *type = ts_node_type (node); return fast_c_string_match (pred, type, strlen (type)) >= 0; } - else + /* We want to allow cl-labels-defined functions, so we allow + symbols. */ + else if (FUNCTIONP (pred) || SYMBOLP (pred)) { Lisp_Object lisp_node = make_treesit_node (parser, node); return !NILP (CALLN (Ffuncall, pred, lisp_node)); } + else if (CONSP (pred)) + { + Lisp_Object car = XCAR (pred); + Lisp_Object cdr = XCDR (pred); + + if (EQ (car, Qnot)) + { + return !treesit_traverse_match_predicate (cursor, XCAR (cdr), + parser, named); + } + else if (EQ (car, Qor)) + { + FOR_EACH_TAIL (cdr) + { + if (treesit_traverse_match_predicate (cursor, XCAR (cdr), + parser, named)) + return true; + } + return false; + } + /* We want to allow cl-labels-defined functions, so we allow + symbols. */ + else if (STRINGP (car) && (FUNCTIONP (cdr) || SYMBOLP (cdr))) + { + /* A bit of code duplication here, but should be fine. */ + const char *type = ts_node_type (node); + if (!(fast_c_string_match (pred, type, strlen (type)) >= 0)) + return false; + + Lisp_Object lisp_node = make_treesit_node (parser, node); + if (NILP (CALLN (Ffuncall, pred, lisp_node))) + return false; + + return true; + } + } + /* Returning false is better than UB. */ + return false; } -/* Traverse the parse tree starting from CURSOR. PRED can be a - function (takes a node and returns nil/non-nil), or a string - (treated as regexp matching the node's type, must be all single - byte characters). If the node satisfies PRED, leave CURSOR on that - node and return true. If no node satisfies PRED, move CURSOR back - to starting position and return false. +/* Traverse the parse tree starting from CURSOR. See TODO for the + shapes PRED can have. If the node satisfies PRED, leave CURSOR on + that node and return true. If no node satisfies PRED, move CURSOR + back to starting position and return false. LIMIT is the number of levels we descend in the tree. FORWARD controls the direction in which we traverse the tree, true means forward, false backward. If SKIP_ROOT is true, don't match ROOT. - */ + + This function may signal if the predicate function signals. */ static bool treesit_search_dfs (TSTreeCursor *cursor, Lisp_Object pred, Lisp_Object parser, @@ -3209,7 +3322,9 @@ treesit_search_dfs (TSTreeCursor *cursor, START. PRED, PARSER, NAMED, FORWARD are the same as in ts_search_subtree. If a match is found, leave CURSOR at that node, and return true, if no match is found, return false, and CURSOR's - position is undefined. */ + position is undefined. + + This function may signal if the predicate function signals. */ static bool treesit_search_forward (TSTreeCursor *cursor, Lisp_Object pred, Lisp_Object parser, @@ -3272,11 +3387,13 @@ DEFUN ("treesit-search-subtree", Lisp_Object all, Lisp_Object depth) { CHECK_TS_NODE (node); - CHECK_TYPE (STRINGP (predicate) || FUNCTIONP (predicate), - list3 (Qor, Qstringp, Qfunctionp), predicate); CHECK_SYMBOL (all); CHECK_SYMBOL (backward); + Lisp_Object signal_data = Qnil; + if (!treesit_traverse_validate_predicate (predicate, &signal_data)) + xsignal1 (Qtreesit_invalid_predicate, signal_data); + /* We use a default limit of 1000. See bug#59426 for the discussion. */ ptrdiff_t the_limit = treesit_recursion_limit; @@ -3344,11 +3461,13 @@ DEFUN ("treesit-search-forward", Lisp_Object all) { CHECK_TS_NODE (start); - CHECK_TYPE (STRINGP (predicate) || FUNCTIONP (predicate), - list3 (Qor, Qstringp, Qfunctionp), predicate); CHECK_SYMBOL (all); CHECK_SYMBOL (backward); + Lisp_Object signal_data = Qnil; + if (!treesit_traverse_validate_predicate (predicate, &signal_data)) + xsignal1 (Qtreesit_invalid_predicate, signal_data); + treesit_initialize (); Lisp_Object parser = XTS_NODE (start)->parser; @@ -3376,7 +3495,9 @@ DEFUN ("treesit-search-forward", /* Recursively traverse the tree under CURSOR, and append the result subtree to PARENT's cdr. See more in Ftreesit_induce_sparse_tree. Note that the top-level children list is reversed, because - reasons. */ + reasons. + + This function may signal if the predicate function signals. */ static void treesit_build_sparse_tree (TSTreeCursor *cursor, Lisp_Object parent, Lisp_Object pred, Lisp_Object process_fn, @@ -3462,8 +3583,10 @@ DEFUN ("treesit-induce-sparse-tree", Lisp_Object depth) { CHECK_TS_NODE (root); - CHECK_TYPE (STRINGP (predicate) || FUNCTIONP (predicate), - list3 (Qor, Qstringp, Qfunctionp), predicate); + + Lisp_Object signal_data = Qnil; + if (!treesit_traverse_validate_predicate (predicate, &signal_data)) + xsignal1 (Qtreesit_invalid_predicate, signal_data); if (!NILP (process_fn)) CHECK_TYPE (FUNCTIONP (process_fn), Qfunctionp, process_fn); @@ -3595,6 +3718,7 @@ syms_of_treesit (void) DEFSYM (Qoutdated, "outdated"); DEFSYM (Qhas_error, "has-error"); DEFSYM (Qlive, "live"); + DEFSYM (Qnot, "not"); DEFSYM (QCanchor, ":anchor"); DEFSYM (QCequal, ":equal"); @@ -3619,6 +3743,7 @@ syms_of_treesit (void) "user-emacs-directory"); DEFSYM (Qtreesit_parser_deleted, "treesit-parser-deleted"); DEFSYM (Qtreesit_pattern_expand, "treesit-pattern-expand"); + DEFSYM (Qtreesit_invalid_predicate, "treesit-invalid-predicate"); DEFSYM (Qor, "or"); @@ -3646,6 +3771,9 @@ syms_of_treesit (void) define_error (Qtreesit_parser_deleted, "This parser is deleted and cannot be used", Qtreesit_error); + define_error (Qtreesit_invalid_predicate, + "Invalid predicate, see TODO for valid forms for a predicate", + Qtreesit_error); DEFVAR_LISP ("treesit-load-name-override-list", Vtreesit_load_name_override_list, diff --git a/test/src/treesit-tests.el b/test/src/treesit-tests.el index ac5e6f1e08c..26a21c34152 100644 --- a/test/src/treesit-tests.el +++ b/test/src/treesit-tests.el @@ -257,6 +257,7 @@ treesit-search-subtree (defmacro treesit--ert-search-setup (&rest body) "Setup macro used by `treesit-search-forward' and friends. BODY is the test body." + (declare (debug (&rest form))) `(with-temp-buffer (let (parser root array) (progn @@ -332,6 +333,58 @@ treesit-search-backward-named-only do (should (equal (treesit-node-text cursor) text))))) +(ert-deftest treesit-search-forward-predicate () + "Test various form of supported predicates in search functions." + (skip-unless (treesit-language-available-p 'json)) + (treesit--ert-search-setup + ;; The following tests are adapted from `treesit-search-forward'. + + ;; Test `or' + (cl-loop for cursor = (treesit-node-child array 0) + then (treesit-search-forward cursor `(or "number" ,(rx "[")) + nil t) + for text in '("[" "[" "1" "2" "3" + "[" "4" "5" "6" + "[" "7" "8" "9") + while cursor + do (should (equal (treesit-node-text cursor) text))) + ;; Test `not' and `or' + (cl-loop for cursor = (treesit-node-child array 0) + then (treesit-search-forward cursor + `(not (or "number" ,(rx "["))) + nil t) + for text in '("[" "," "," "]" + "[1,2,3]" "," + "," "," "]" + "[4,5,6]" "," + "," "," "]" + "[7,8,9]" "]" + "[[1,2,3], [4,5,6], [7,8,9]]") + while cursor + do (should (equal (treesit-node-text cursor) text))) + ;; Test (regexp . function) + (cl-labels ((is-odd (string) + (and (eq 1 (length string)) + (cl-oddp (string-to-number string))))) + (cl-loop for cursor = (treesit-node-child array 0) + then (treesit-search-forward cursor '("number" . is-odd) + nil t) + for text in '("[" "1" "3" "5" "7" "9") + while cursor + do (should (equal (treesit-node-text cursor) text)))))) + +(ert-deftest treesit-search-forward-predicate-invalid-predicate () + "Test tree-sitter's ability to detect invalid predicates." + (skip-unless (treesit-language-available-p 'json)) + (treesit--ert-search-setup + (dolist (pred '( 1 (not 1) (not "2" "3") (or) (or 1))) + (should-error (treesit-search-forward (treesit-node-child array 0) + pred) + :type 'treesit-invalid-predicate)) + (should-error (treesit-search-forward (treesit-node-child array 0) + 'not-a-function) + :type 'void-function))) + (ert-deftest treesit-cursor-helper-with-missing-node () "Test treesit_cursor_helper with a missing node." (skip-unless (treesit-language-available-p 'json)) commit a5eb9f6ad4e6f5a2819b540a477f1e889f6ef355 Author: Yuan Fu Date: Thu Apr 13 14:36:46 2023 -0700 Catch signals produced by PRED in tree-sitter search functions Earlier we switched to using cursors rather than nodes to traverse the parse tree. Because cursors need cleanup, we have to catch signals thrown by the predicate functions and free the cursor. Failing to do this will result in leaking the cursor whenever the predicate function signals in a search function. This change fixes the leak. * src/treesit.c (treesit_traverse_cleanup_cursor): New function. (Ftreesit_search_subtree) (Ftreesit_search_forward) (Ftreesit_induce_sparse_tree): Catch signals. diff --git a/src/treesit.c b/src/treesit.c index fd5fda78133..76d1dc8ccf4 100644 --- a/src/treesit.c +++ b/src/treesit.c @@ -3247,6 +3247,12 @@ treesit_search_forward (TSTreeCursor *cursor, } } +/** Cleanup function for cursor. */ +static void treesit_traverse_cleanup_cursor(void *cursor) +{ + ts_tree_cursor_delete ((TSTreeCursor *) cursor); +} + DEFUN ("treesit-search-subtree", Ftreesit_search_subtree, Streesit_search_subtree, 2, 5, 0, @@ -3288,12 +3294,18 @@ DEFUN ("treesit-search-subtree", if (!treesit_cursor_helper (&cursor, XTS_NODE (node)->node, parser)) return return_value; + specpdl_ref count = SPECPDL_INDEX (); + record_unwind_protect_ptr (treesit_traverse_cleanup_cursor, &cursor); + if (treesit_search_dfs (&cursor, predicate, parser, NILP (backward), NILP (all), the_limit, false)) { TSNode node = ts_tree_cursor_current_node (&cursor); return_value = make_treesit_node (parser, node); } + + unbind_to (count, Qnil); + ts_tree_cursor_delete (&cursor); return return_value; } @@ -3345,12 +3357,18 @@ DEFUN ("treesit-search-forward", if (!treesit_cursor_helper (&cursor, XTS_NODE (start)->node, parser)) return return_value; + specpdl_ref count = SPECPDL_INDEX (); + record_unwind_protect_ptr (treesit_traverse_cleanup_cursor, &cursor); + if (treesit_search_forward (&cursor, predicate, parser, NILP (backward), NILP (all))) { TSNode node = ts_tree_cursor_current_node (&cursor); return_value = make_treesit_node (parser, node); } + + unbind_to (count, Qnil); + ts_tree_cursor_delete (&cursor); return return_value; } @@ -3467,8 +3485,14 @@ DEFUN ("treesit-induce-sparse-tree", to use treesit_cursor_helper. */ TSTreeCursor cursor = ts_tree_cursor_new (XTS_NODE (root)->node); + specpdl_ref count = SPECPDL_INDEX (); + record_unwind_protect_ptr (treesit_traverse_cleanup_cursor, &cursor); + treesit_build_sparse_tree (&cursor, parent, predicate, process_fn, the_limit, parser); + + unbind_to (count, Qnil); + ts_tree_cursor_delete (&cursor); Fsetcdr (parent, Fnreverse (Fcdr (parent))); if (NILP (Fcdr (parent))) commit dff254946a72db1d592e6e2f71f85786e5e5bdec Author: Yuan Fu Date: Thu Apr 13 00:52:17 2023 -0700 Fix tree-sitter tests After 2ce27563ecc, treesit--navigate-things takes a TACTIC argument instead of using treesit-defun-tactic, so the tests need to change from binding treesit-defun-tactic to passing the tactic argument, which is what this change does. * test/src/treesit-tests.el: (treesit--ert-insert-and-parse-marker): New argument TACTIC. (treesit-defun-navigation-nested-1) (treesit-defun-navigation-nested-2) (treesit-defun-navigation-nested-3) (treesit-defun-navigation-top-level): Pass TACTIC argument. diff --git a/test/src/treesit-tests.el b/test/src/treesit-tests.el index 468cd221ef9..ac5e6f1e08c 100644 --- a/test/src/treesit-tests.el +++ b/test/src/treesit-tests.el @@ -831,7 +831,7 @@ treesit--ert-collect-positions (funcall fn))))) (defun treesit--ert-test-defun-navigation - (init program master &optional opening closing) + (init program master tactic &optional opening closing) "Run defun navigation tests on PROGRAM and MASTER. INIT is a setup function that runs right after this function @@ -843,6 +843,8 @@ treesit--ert-test-defun-navigation corresponding navigation should stop at (after running `treesit-defun-skipper'). +TACTIC is the same as in `treesit--navigate-thing'. + OPENING and CLOSING are the same as in `treesit--ert-insert-and-parse-marker', by default they are \"[\" and \"]\"." @@ -873,7 +875,7 @@ treesit--ert-test-defun-navigation (if-let ((pos (funcall #'treesit--navigate-thing (point) (car conf) (cdr conf) - regexp pred))) + regexp pred tactic))) (save-excursion (goto-char pos) (funcall treesit-defun-skipper) @@ -1025,43 +1027,42 @@ treesit-defun-navigation-nested-1 "Test defun navigation." (skip-unless (treesit-language-available-p 'python)) ;; Nested defun navigation - (let ((treesit-defun-tactic 'nested)) - (require 'python) - (treesit--ert-test-defun-navigation - 'python-ts-mode - treesit--ert-defun-navigation-python-program - treesit--ert-defun-navigation-nested-master))) + (require 'python) + (treesit--ert-test-defun-navigation + 'python-ts-mode + treesit--ert-defun-navigation-python-program + treesit--ert-defun-navigation-nested-master + 'nested)) (ert-deftest treesit-defun-navigation-nested-2 () "Test defun navigation using `js-ts-mode'." (skip-unless (treesit-language-available-p 'javascript)) ;; Nested defun navigation - (let ((treesit-defun-tactic 'nested)) - (require 'js) - (treesit--ert-test-defun-navigation - 'js-ts-mode - treesit--ert-defun-navigation-js-program - treesit--ert-defun-navigation-nested-master))) + (require 'js) + (treesit--ert-test-defun-navigation + 'js-ts-mode + treesit--ert-defun-navigation-js-program + treesit--ert-defun-navigation-nested-master + 'nested)) (ert-deftest treesit-defun-navigation-nested-3 () "Test defun navigation using `bash-ts-mode'." (skip-unless (treesit-language-available-p 'bash)) ;; Nested defun navigation - (let ((treesit-defun-tactic 'nested)) - (treesit--ert-test-defun-navigation - (lambda () - (treesit-parser-create 'bash) - (setq-local treesit-defun-type-regexp "function_definition")) - treesit--ert-defun-navigation-bash-program - treesit--ert-defun-navigation-nested-master))) + (treesit--ert-test-defun-navigation + (lambda () + (treesit-parser-create 'bash) + (setq-local treesit-defun-type-regexp "function_definition")) + treesit--ert-defun-navigation-bash-program + treesit--ert-defun-navigation-nested-master + 'nested)) (ert-deftest treesit-defun-navigation-nested-4 () "Test defun navigation using Elixir. This tests bug#60355." (skip-unless (treesit-language-available-p 'elixir)) ;; Nested defun navigation - (let ((treesit-defun-tactic 'nested) - (pred (lambda (node) + (let ((pred (lambda (node) (member (treesit-node-text (treesit-node-child-by-field-name node "target")) '("def" "defmodule"))))) @@ -1070,18 +1071,19 @@ treesit-defun-navigation-nested-4 (treesit-parser-create 'elixir) (setq-local treesit-defun-type-regexp `("call" . ,pred))) treesit--ert-defun-navigation-elixir-program - treesit--ert-defun-navigation-nested-master))) + treesit--ert-defun-navigation-nested-master + 'nested))) (ert-deftest treesit-defun-navigation-top-level () "Test top-level only defun navigation." (skip-unless (treesit-language-available-p 'python)) ;; Nested defun navigation - (let ((treesit-defun-tactic 'top-level)) - (require 'python) - (treesit--ert-test-defun-navigation - 'python-ts-mode - treesit--ert-defun-navigation-python-program - treesit--ert-defun-navigation-top-level-master))) + (require 'python) + (treesit--ert-test-defun-navigation + 'python-ts-mode + treesit--ert-defun-navigation-python-program + treesit--ert-defun-navigation-top-level-master + 'top-level)) ;; TODO ;; - Functions in treesit.el commit 80f6c1027fd054d9126599322bcfd1f30f3f1076 Author: Mattias Engdegård Date: Thu Apr 13 21:38:47 2023 +0200 ; * doc/misc/flymake.texi (Customizable variables): fix broken list diff --git a/doc/misc/flymake.texi b/doc/misc/flymake.texi index 304a7d29ece..b6a540a6ea3 100644 --- a/doc/misc/flymake.texi +++ b/doc/misc/flymake.texi @@ -320,7 +320,6 @@ Customizable variables @item flymake-wrap-around If non-@code{nil}, moving to errors with @code{flymake-goto-next-error} and @code{flymake-goto-prev-error} wraps around buffer boundaries. -@end vtable @item flymake-show-diagnostics-at-end-of-line If non-@code{nil}, show summarized descriptions of diagnostics at the commit 6a7532cfcb913cc20ec156492b415e84d56fd11a Author: Mattias Engdegård Date: Thu Apr 13 20:21:11 2023 +0200 Faster and less wrong cl-defsubst inlining Always have inlining of functions defined by `cl-defsubst` let-bind arguments instead of making incorrect guesses when it might be safe to substitute them and then botching the substitution. This change generally results in better and safer code for all callers, in particular `cl-defstruct` constructors, accessors and mutators. * lisp/emacs-lisp/cl-macs.el (cl-defsubst): Remove outdated comment. (cl--defsubst-expand): Simplify: always let-bind. (cl--sublis): Remove. (cl-defstruct): Simplify: remove old hack that is no longer needed. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 41fc3b9f335..5382e0a0a52 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2891,45 +2891,14 @@ cl-defsubst ,(format "compiler-macro for inlining `%s'." name) (cl--defsubst-expand ',argns '(cl-block ,name ,@(cdr (macroexp-parse-body body))) - ;; We used to pass `simple' as - ;; (not (or unsafe (cl-expr-access-order pbody argns))) - ;; But this is much too simplistic since it - ;; does not pay attention to the argvs (and - ;; cl-expr-access-order itself is also too naive). nil ,(and (memq '&key args) 'cl-whole) nil ,@argns))) (cl-defun ,name ,args ,@body)))) -(defun cl--defsubst-expand (argns body simple whole _unsafe &rest argvs) - (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole - (if (cl--simple-exprs-p argvs) (setq simple t)) - (let* ((substs ()) - (lets (delq nil - (cl-mapcar (lambda (argn argv) - (if (or simple (macroexp-const-p argv)) - (progn (push (cons argn argv) substs) - nil) - (list argn argv))) - argns argvs)))) - ;; FIXME: `sublis/subst' will happily substitute the symbol - ;; `argn' in places where it's not used as a reference - ;; to a variable. - ;; FIXME: `sublis/subst' will happily copy `argv' to a different - ;; scope, leading to name capture. - (setq body (cond ((null substs) body) - ((null (cdr substs)) - (cl-subst (cdar substs) (caar substs) body)) - (t (cl--sublis substs body)))) - (if lets `(let ,lets ,body) body)))) - -(defun cl--sublis (alist tree) - "Perform substitutions indicated by ALIST in TREE (non-destructively)." - (let ((x (assq tree alist))) - (cond - (x (cdr x)) - ((consp tree) - (cons (cl--sublis alist (car tree)) (cl--sublis alist (cdr tree)))) - (t tree)))) +(defun cl--defsubst-expand (argns body _simple whole _unsafe &rest argvs) + (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) + whole + `(let ,(cl-mapcar #'list argns argvs) ,body))) ;;; Structures. @@ -3244,19 +3213,8 @@ cl-defstruct (let* ((anames (cl--arglist-args args)) (make (cl-mapcar (lambda (s d) (if (memq s anames) s d)) slots defaults)) - ;; `cl-defsubst' is fundamentally broken: it substitutes - ;; its arguments into the body's `sexp' much too naively - ;; when inlinling, which results in various problems. - ;; For example it generates broken code if your - ;; argument's name happens to be the same as some - ;; function used within the body. - ;; E.g. (cl-defsubst sm-foo (list) (list list)) - ;; will expand `(sm-foo 1)' to `(1 1)' rather than to `(list t)'! - ;; Try to catch this known case! - (con-fun (or type #'record)) - (unsafe-cl-defsubst - (or (memq con-fun args) (assq con-fun args)))) - (push `(,(if unsafe-cl-defsubst 'cl-defun cldefsym) ,cname + (con-fun (or type #'record))) + (push `(,cldefsym ,cname (&cl-defs (nil ,@descs) ,@args) ,(if (stringp doc) doc (format "Constructor for objects of type `%s'." name)) commit 83b5e9cd24ddcbb04dbd5db9a07248ff7fa301ab Author: João Távora Date: Thu Apr 13 11:46:12 2023 +0100 Eldoc: don't overdisplay if using eldoc-documentation-compose bug#62816 This is about a particular value for 'eldoc-documentation-strategy', 'eldoc-documentation-compose'. Its helper 'eldoc--documentation-compose-1' was buggy. It created the callback for all the backends in 'eldoc-documentation-functions', but arranged so that it could potentially be invoked immediately and trigger display, half-defeating the purpose of the "patience" and causing blinking in the echo area. Now it creates all the callbacks beforehand and only then passes them to the corresponding members of eldoc-documentation-functions. This sets up the correct state in eldoc--invoke-strategy. * lisp/emacs-lisp/eldoc.el (eldoc--documentation-compose-1): Delete. (eldoc-documentation-compose) (eldoc-documentation-compose-eagerly): Rework. diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 1eb0d38c5ce..18d3eb37af3 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -681,29 +681,34 @@ eldoc-documentation-default (lambda (f) (funcall f (eldoc--make-callback :eager f))))) -(defun eldoc--documentation-compose-1 (eagerlyp) - "Helper function for composing multiple doc strings. -If EAGERLYP is non-nil show documentation as soon as possible, -else wait for all doc strings." - (run-hook-wrapped 'eldoc-documentation-functions - (lambda (f) - (let* ((callback (eldoc--make-callback - (if eagerlyp :eager :patient) - f)) - (str (funcall f callback))) - (if (or (null str) (stringp str)) (funcall callback str)) - nil))) - t) - (defun eldoc-documentation-compose () "Show multiple documentation strings together after waiting for all of them. This is meant to be used as a value for `eldoc-documentation-strategy'." - (eldoc--documentation-compose-1 nil)) + (let (fns-and-callbacks) + ;; Make all the callbacks, setting up state inside + ;; `eldoc--invoke-strategy' to know how many callbacks to wait for + ;; before displaying the result (bug#62816). + (run-hook-wrapped 'eldoc-documentation-functions + (lambda (f) + (push (cons f (eldoc--make-callback :patient f)) + fns-and-callbacks) + nil)) + ;; Now call them. The last one will trigger the display. + (cl-loop for (f . callback) in fns-and-callbacks + for str = (funcall f callback) + when (or (null str) (stringp str)) do (funcall callback str))) + t) (defun eldoc-documentation-compose-eagerly () "Show multiple documentation strings one by one as soon as possible. This is meant to be used as a value for `eldoc-documentation-strategy'." - (eldoc--documentation-compose-1 t)) + (run-hook-wrapped 'eldoc-documentation-functions + (lambda (f) + (let* ((callback (eldoc--make-callback :eager f)) + (str (funcall f callback))) + (if (or (null str) (stringp str)) (funcall callback str)) + nil))) + t) (defun eldoc-documentation-enthusiast () "Show most important documentation string produced so far. commit a74403adda0d67b6f0430d1c038a7c96579f3450 Author: João Távora Date: Thu Apr 13 10:01:27 2023 +0100 Eglot: fix LSP "languageId" detection This sweeping fix has been planned for a while, but a user recently hit this bug as described in https://github.com/joaotavora/eglot/discussions/1206. More and more servers today are "multi-language", meaning can handle more than one file type. This relies on the ':languageId' string being set to the correct value for every buffer managed by Eglot (TextDocumentItem in LSP parlance). Previously this string was calculated based on an imperfect heuristic and was wrong quite often. Many servers don't even care but some others do, so we have to fix it. * lisp/progmodes/eglot.el (eglot-lsp-server): Remove slots 'major-modes' and 'language-id'. Add slot 'languages'. (eglot--major-modes, eglot--language-ids): New helpers. (eglot--lookup-mode): Simplify or maybe complicate. (eglot--guess-contact): Use new eglot--looup-mode. Change return value. (eglot): Rework docstring. (eglot-reconnect): Use eglot--language-ids, not id. (eglot--connect): Setup eglot--languages slot in server. (eglot--TextDocumentItem): Finally, get correct language id. * test/lisp/progmodes/eglot-tests.el (eglot--guessing-contact): Enhance macro. (eglot-test-server-programs-guess-lang): Update test. diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index 3f00281e155..c4f773c8426 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -844,12 +844,9 @@ eglot-lsp-server :documentation "Short nickname for the associated project." :accessor eglot--project-nickname :reader eglot-project-nickname) - (major-modes - :documentation "Major modes server is responsible for in a given project." - :accessor eglot--major-modes) - (language-id - :documentation "Language ID string for the mode." - :accessor eglot--language-id) + (languages + :documentation "Alist ((MODE . LANGUAGE-ID-STRING)...) of managed languages." + :accessor eglot--languages) (capabilities :documentation "JSON object containing server capabilities." :accessor eglot--capabilities) @@ -884,6 +881,12 @@ eglot-lsp-server :documentation "Represents a server. Wraps a process for LSP communication.") +(defun eglot--major-modes (s) "Major modes server S is responsible for." + (mapcar #'car (eglot--languages s))) + +(defun eglot--language-ids (s) "LSP Language ID strings for server S's modes." + (mapcar #'cdr (eglot--languages s))) + (cl-defmethod initialize-instance :before ((_server eglot-lsp-server) &optional args) (cl-remf args :initializationOptions)) @@ -969,42 +972,44 @@ eglot-command-history (defun eglot--lookup-mode (mode) "Lookup `eglot-server-programs' for MODE. -Return (MANAGED-MODES LANGUAGE-ID CONTACT-PROXY). +Return (LANGUAGES . CONTACT-PROXY). MANAGED-MODES is a list with MODE as its first element. Subsequent elements are other major modes also potentially managed by the server that is to manage MODE. -If not specified in `eglot-server-programs' (which see), -LANGUAGE-ID is determined from MODE's name. +LANGUAGE-IDS is a list of the same length as MANAGED-MODES. Each +elem is derived from the corresponding mode name, if not +specified in `eglot-server-programs' (which see). CONTACT-PROXY is the value of the corresponding `eglot-server-programs' entry." - (cl-loop - for (modes . contact) in eglot-server-programs - for mode-symbols = (cons mode - (delete mode - (mapcar #'car - (mapcar #'eglot--ensure-list - (eglot--ensure-list modes))))) - thereis (cl-some - (lambda (spec) - (cl-destructuring-bind (probe &key language-id &allow-other-keys) - (eglot--ensure-list spec) - (and (provided-mode-derived-p mode probe) - (list - mode-symbols - (or language-id - (or (get mode 'eglot-language-id) - (get spec 'eglot-language-id) - (string-remove-suffix "-mode" (symbol-name mode)))) - contact)))) - (if (or (symbolp modes) (keywordp (cadr modes))) - (list modes) modes)))) + (cl-flet ((languages (main-mode-sym specs) + (let* ((res + (mapcar (jsonrpc-lambda (sym &key language-id &allow-other-keys) + (cons sym + (or language-id + (or (get sym 'eglot-language-id) + (replace-regexp-in-string + "\\(?:-ts\\)?-mode$" "" + (symbol-name sym)))))) + specs)) + (head (cl-find main-mode-sym res :key #'car))) + (cons head (delq head res))))) + (cl-loop + for (modes . contact) in eglot-server-programs + for specs = (mapcar #'eglot--ensure-list + (if (or (symbolp modes) (keywordp (cadr modes))) + (list modes) modes)) + thereis (cl-some (lambda (spec) + (cl-destructuring-bind (sym &key &allow-other-keys) spec + (and (provided-mode-derived-p mode sym) + (cons (languages sym specs) contact)))) + specs)))) (defun eglot--guess-contact (&optional interactive) "Helper for `eglot'. -Return (MANAGED-MODE PROJECT CLASS CONTACT LANG-ID). If INTERACTIVE is +Return (MANAGED-MODES PROJECT CLASS CONTACT LANG-IDS). If INTERACTIVE is non-nil, maybe prompt user, else error as soon as something can't be guessed." (let* ((guessed-mode (if buffer-file-name major-mode)) @@ -1022,11 +1027,10 @@ eglot--guess-contact ((not guessed-mode) (eglot--error "Can't guess mode to manage for `%s'" (current-buffer))) (t guessed-mode))) - (triplet (eglot--lookup-mode main-mode)) - (managed-modes (car triplet)) - (language-id (or (cadr triplet) - (string-remove-suffix "-mode" (symbol-name guessed-mode)))) - (guess (caddr triplet)) + (languages-and-contact (eglot--lookup-mode main-mode)) + (managed-modes (mapcar #'car (car languages-and-contact))) + (language-ids (mapcar #'cdr (car languages-and-contact))) + (guess (cdr languages-and-contact)) (guess (if (functionp guess) (funcall guess interactive) guess)) @@ -1074,7 +1078,7 @@ eglot--guess-contact full-program-invocation 'eglot-command-history))) guess))) - (list managed-modes (eglot--current-project) class contact language-id))) + (list managed-modes (eglot--current-project) class contact language-ids))) (defvar eglot-lsp-context) (put 'eglot-lsp-context 'variable-documentation @@ -1092,24 +1096,25 @@ eglot--current-project `(transient . ,(expand-file-name default-directory))))) ;;;###autoload -(defun eglot (managed-major-mode project class contact language-id +(defun eglot (managed-major-modes project class contact language-ids &optional _interactive) - "Start LSP server in support of PROJECT's buffers under MANAGED-MAJOR-MODE. + "Start LSP server for PROJECT's buffers under MANAGED-MAJOR-MODES. -This starts a Language Server Protocol (LSP) server suitable for the -buffers of PROJECT whose `major-mode' is MANAGED-MAJOR-MODE. -CLASS is the class of the LSP server to start and CONTACT specifies -how to connect to the server. +This starts a Language Server Protocol (LSP) server suitable for +the buffers of PROJECT whose `major-mode' is among +MANAGED-MAJOR-MODES. CLASS is the class of the LSP server to +start and CONTACT specifies how to connect to the server. -Interactively, the command attempts to guess MANAGED-MAJOR-MODE -from the current buffer's `major-mode', CLASS and CONTACT from -`eglot-server-programs' looked up by the major mode, and PROJECT from -`project-find-functions'. The search for active projects in this -context binds `eglot-lsp-context' (which see). +Interactively, the command attempts to guess MANAGED-MAJOR-MODES, +CLASS, CONTACT, and LANGUAGE-IDS from `eglot-server-programs', +according to the current buffer's `major-mode'. PROJECT is +guessed from `project-find-functions'. The search for active +projects in this context binds `eglot-lsp-context' (which see). -If it can't guess, it prompts the user for the mode and the server. -With a single \\[universal-argument] prefix arg, it always prompts for COMMAND. -With two \\[universal-argument], it also always prompts for MANAGED-MAJOR-MODE. +If it can't guess, it prompts the user for the mode and the +server. With a single \\[universal-argument] prefix arg, it +always prompts for COMMAND. With two \\[universal-argument], it +also always prompts for MANAGED-MAJOR-MODE. The LSP server of CLASS is started (or contacted) via CONTACT. If this operation is successful, current *and future* file @@ -1127,8 +1132,8 @@ eglot keyword-value plist used to initialize CLASS or a plain list as described in `eglot-server-programs', which see. -LANGUAGE-ID is the language ID string to send to the server for -MANAGED-MAJOR-MODE, which matters to a minority of servers. +LANGUAGE-IDS is a list of language ID string to send to the +server for each element in MANAGED-MAJOR-MODES. INTERACTIVE is ignored and provided for backward compatibility." (interactive @@ -1139,8 +1144,9 @@ eglot (user-error "[eglot] Connection attempt aborted by user.")) (prog1 (append (eglot--guess-contact t) '(t)) (when current-server (ignore-errors (eglot-shutdown current-server)))))) - (eglot--connect (eglot--ensure-list managed-major-mode) - project class contact language-id)) + (eglot--connect (eglot--ensure-list managed-major-modes) + project class contact + (eglot--ensure-list language-ids))) (defun eglot-reconnect (server &optional interactive) "Reconnect to SERVER. @@ -1152,7 +1158,7 @@ eglot-reconnect (eglot--project server) (eieio-object-class-name server) (eglot--saved-initargs server) - (eglot--language-id server)) + (eglot--language-ids server)) (eglot--message "Reconnected!")) (defvar eglot--managed-mode) ; forward decl @@ -1225,8 +1231,8 @@ eglot--cmd (defvar-local eglot--cached-server nil "A cached reference to the current Eglot server.") -(defun eglot--connect (managed-modes project class contact language-id) - "Connect to MANAGED-MODES, LANGUAGE-ID, PROJECT, CLASS and CONTACT. +(defun eglot--connect (managed-modes project class contact language-ids) + "Connect to MANAGED-MODES, LANGUAGE-IDS, PROJECT, CLASS and CONTACT. This docstring appeases checkdoc, that's all." (let* ((default-directory (project-root project)) (nickname (project-name project)) @@ -1299,8 +1305,9 @@ eglot--connect (setf (eglot--saved-initargs server) initargs) (setf (eglot--project server) project) (setf (eglot--project-nickname server) nickname) - (setf (eglot--major-modes server) (eglot--ensure-list managed-modes)) - (setf (eglot--language-id server) language-id) + (setf (eglot--languages server) + (cl-loop for m in managed-modes for l in language-ids + collect (cons m l))) (setf (eglot--inferior-process server) autostart-inferior-process) (run-hook-with-args 'eglot-server-initialized-hook server) ;; Now start the handshake. To honor `eglot-sync-connect' @@ -2354,7 +2361,7 @@ eglot--TextDocumentItem (append (eglot--VersionedTextDocumentIdentifier) (list :languageId - (eglot--language-id (eglot--current-server-or-lose)) + (alist-get major-mode (eglot--languages (eglot--current-server-or-lose))) :text (eglot--widening (buffer-substring-no-properties (point-min) (point-max)))))) diff --git a/test/lisp/progmodes/eglot-tests.el b/test/lisp/progmodes/eglot-tests.el index efb0f4d8844..d96ba2ebf07 100644 --- a/test/lisp/progmodes/eglot-tests.el +++ b/test/lisp/progmodes/eglot-tests.el @@ -1041,7 +1041,8 @@ eglot-test-dcase-issue-452 (cl-defmacro eglot--guessing-contact ((interactive-sym prompt-args-sym guessed-class-sym guessed-contact-sym - &optional guessed-lang-id-sym) + &optional guessed-major-modes-sym + guessed-lang-ids-sym) &body body) "Guess LSP contact with `eglot--guessing-contact', evaluate BODY. @@ -1051,10 +1052,10 @@ eglot--guessing-contact If the user would have been prompted, PROMPT-ARGS-SYM is bound to the list of arguments that would have been passed to `read-shell-command', else nil. GUESSED-CLASS-SYM, -GUESSED-CONTACT-SYM and GUESSED-LANG-ID-SYM are bound to the -useful return values of `eglot--guess-contact'. Unless the -server program evaluates to \"a-missing-executable.exe\", this -macro will assume it exists." +GUESSED-CONTACT-SYM, GUESSED-LANG-IDS-SYM and +GUESSED-MAJOR-MODES-SYM are bound to the useful return values of +`eglot--guess-contact'. Unless the server program evaluates to +\"a-missing-executable.exe\", this macro will assume it exists." (declare (indent 1) (debug t)) (let ((i-sym (cl-gensym))) `(dolist (,i-sym '(nil t)) @@ -1070,8 +1071,9 @@ eglot--guessing-contact `(lambda (&rest args) (setq ,prompt-args-sym args) "") `(lambda (&rest _dummy) "")))) (cl-destructuring-bind - (_ _ ,guessed-class-sym ,guessed-contact-sym - ,(or guessed-lang-id-sym '_)) + (,(or guessed-major-modes-sym '_) + _ ,guessed-class-sym ,guessed-contact-sym + ,(or guessed-lang-ids-sym '_)) (eglot--guess-contact ,i-sym) ,@body)))))) @@ -1166,16 +1168,17 @@ eglot-test-server-programs-function (ert-deftest eglot-test-server-programs-guess-lang () (let ((major-mode 'foo-mode)) (let ((eglot-server-programs '((foo-mode . ("prog-executable"))))) - (eglot--guessing-contact (_ nil _ _ guessed-lang) - (should (equal guessed-lang "foo")))) + (eglot--guessing-contact (_ nil _ _ _ guessed-langs) + (should (equal guessed-langs '("foo"))))) (let ((eglot-server-programs '(((foo-mode :language-id "bar") . ("prog-executable"))))) - (eglot--guessing-contact (_ nil _ _ guessed-lang) - (should (equal guessed-lang "bar")))) + (eglot--guessing-contact (_ nil _ _ _ guessed-langs) + (should (equal guessed-langs '("bar"))))) (let ((eglot-server-programs '(((baz-mode (foo-mode :language-id "bar")) . ("prog-executable"))))) - (eglot--guessing-contact (_ nil _ _ guessed-lang) - (should (equal guessed-lang "bar")))))) + (eglot--guessing-contact (_ nil _ _ modes guessed-langs) + (should (equal guessed-langs '("bar" "baz"))) + (should (equal modes '(foo-mode baz-mode))))))) (defun eglot--glob-match (glob str) (funcall (eglot--glob-compile glob t t) str)) commit d45f450cff757ed520a7ee36c632ab62387c7bc9 Author: João Távora Date: Thu Mar 2 22:55:31 2023 +0000 Flymake: add new flymake-show-diagnostics-at-end-of-line option Some editors have this. Depending on your preference, this can either be wildly distracting and easily confused with actual code, or a significant early aid that relieves you from moving around or reaching for the mouse to consult an error message. To be safe, hide this behind a customization variable and keep it disabled. Personally, I find it less obstrusive and more helpful than expected. * lisp/progmodes/flymake.el (flymake--delete-overlay): New helper. (flymake--highlight-line): Handle flymake-show-diagnostics-at-end-of-line. (flymake--clear-foreign-diags): Use flymake--delete-overlay. (flymake--publish-diagnostics): Use flymake--delete-overlay. (flymake-mode): Use flymake--delete-overlay. (flymake-error-echo) (flymake-warning-echo, flymake-note-echo): New faces. (flymake-show-diagnostics-at-end-of-line): New option. (Version): Bump to 1.3.4 * doc/misc/flymake.texi: (Finding diagnostics): Mention flymake-show-diagnostics-at-end-of-line. (Customizable variables): Mention flymake-show-diagnostics-at-end-of-line and a few more relevant faces. * etc/NEWS (Flymake): Mention flymake-show-diagnostics-at-end-of-line. diff --git a/doc/misc/flymake.texi b/doc/misc/flymake.texi index 13616f39f16..304a7d29ece 100644 --- a/doc/misc/flymake.texi +++ b/doc/misc/flymake.texi @@ -1,7 +1,7 @@ \input texinfo @c -*- mode: texinfo; coding: utf-8 -*- @comment %**start of header @setfilename ../../info/flymake.info -@set VERSION 1.3.3 +@set VERSION 1.3.4 @set UPDATED April 2023 @settitle GNU Flymake @value{VERSION} @include docstyle.texi @@ -142,6 +142,12 @@ Finding diagnostics is. Alternatively, place point on the highlighted regions and use the commands @code{eldoc} or @code{display-local-help}. +Another easy way to get instant access to the diagnostic text is to +set @code{flymake-show-diagnostics-at-end-of-line} to a non-@code{nil} +value. This makes the diagnostic messages appear at the end of the +line where the regular annotation is located (@pxref{Customizable +variables}) + @cindex next and previous diagnostic If the diagnostics are outside the visible region of the buffer, @code{flymake-goto-next-error} and @code{flymake-goto-prev-error} are @@ -316,6 +322,23 @@ Customizable variables @code{flymake-goto-prev-error} wraps around buffer boundaries. @end vtable +@item flymake-show-diagnostics-at-end-of-line +If non-@code{nil}, show summarized descriptions of diagnostics at the +end of the line. Depending on your preference, this can either be +distracting and easily confused with actual code, or a significant +early aid that relieves you from moving around or reaching for the +mouse to consult an error message. + +@item flymake-error-eol +A custom face for summarizing diagnostic error messages. + +@item flymake-warning-eol +A custom face for summarizing diagnostic warning messages. + +@item flymake-note-eol +A custom face for summarizing diagnostic notes. +@end vtable + @node Extending Flymake @chapter Extending Flymake @cindex extending flymake diff --git a/etc/NEWS b/etc/NEWS index 5e1fd76e99e..611dcf3dc7d 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -259,13 +259,21 @@ following to your init file: #'shortdoc-help-fns-examples-function) ** Package - --- *** New user option 'package-vc-register-as-project'. When non-nil, it will automatically register every package as a project, that you can quickly select using 'project-switch-project' ('C-x p p'). +** Flymake ++++ +*** New user option 'flymake-show-diagnostics-at-end-of-line'. +When non-nil, Flymake shows summarized descriptions of diagnostics at +the end of the line. Depending on your preference, this can either be +distracting and easily confused with actual code, or a significant +early aid that relieves you from moving the buffer or reaching for the +mouse to consult an error message. + * New Modes and Packages in Emacs 30.1 diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index c751e5bd432..f2fe97cb773 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -4,7 +4,7 @@ ;; Author: Pavel Kobyakov ;; Maintainer: João Távora -;; Version: 1.3.3 +;; Version: 1.3.4 ;; Keywords: c languages tools ;; Package-Requires: ((emacs "26.1") (eldoc "1.14.0") (project "0.7.1")) @@ -431,6 +431,26 @@ flymake-note "Face used for marking note regions." :version "26.1") +(defface flymake-error-echo + '((t :inherit compilation-error)) + "Face used for showing summarized descriptions of errors." + :package-version '("Flymake" . "1.3.4")) + +(defface flymake-warning-echo + '((t :inherit compilation-warning)) + "Face used for showing summarized descriptions of warnings." + :package-version '("Flymake" . "1.3.4")) + +(defface flymake-note-echo + '((t :inherit flymake-note)) + "Face used for showing summarized descriptions of notes." + :package-version '("Flymake" . "1.3.4")) + +(defcustom flymake-show-diagnostics-at-end-of-line nil + "If non-nil, add diagnostic summary messages at end-of-line." + :type 'boolean + :package-version '("Flymake" . "1.3.4")) + (define-obsolete-face-alias 'flymake-warnline 'flymake-warning "26.1") (define-obsolete-face-alias 'flymake-errline 'flymake-error "26.1") @@ -584,22 +604,25 @@ flymake-diagnostic-types-alist (put 'flymake-error 'face 'flymake-error) (put 'flymake-error 'flymake-bitmap 'flymake-error-bitmap) (put 'flymake-error 'severity (warning-numeric-level :error)) -(put 'flymake-error 'mode-line-face 'compilation-error) -(put 'flymake-error 'echo-face 'error) +(put 'flymake-error 'mode-line-face 'flymake-error-echo) +(put 'flymake-error 'echo-face 'flymake-error-echo) +(put 'flymake-error 'eol-face 'flymake-error-echo) (put 'flymake-error 'flymake-type-name "error") (put 'flymake-warning 'face 'flymake-warning) (put 'flymake-warning 'flymake-bitmap 'flymake-warning-bitmap) (put 'flymake-warning 'severity (warning-numeric-level :warning)) -(put 'flymake-warning 'mode-line-face 'compilation-warning) -(put 'flymake-warning 'echo-face 'warning) +(put 'flymake-warning 'mode-line-face 'flymake-warning-echo) +(put 'flymake-warning 'echo-face 'flymake-warning-echo) +(put 'flymake-warning 'eol-face 'flymake-warning-echo) (put 'flymake-warning 'flymake-type-name "warning") (put 'flymake-note 'face 'flymake-note) (put 'flymake-note 'flymake-bitmap 'flymake-note-bitmap) (put 'flymake-note 'severity (warning-numeric-level :debug)) -(put 'flymake-note 'mode-line-face 'compilation-info) -(put 'flymake-note 'echo-face 'compilation-info) +(put 'flymake-note 'mode-line-face 'flymake-note-echo) +(put 'flymake-note 'echo-face 'flymake-note-echo) +(put 'flymake-note 'eol-face 'flymake-note-echo) (put 'flymake-note 'flymake-type-name "note") (defun flymake--lookup-type-property (type prop &optional default) @@ -656,6 +679,12 @@ flymake--equal-diagnostic-p flymake-diagnostic-text) always (equal (funcall comp a) (funcall comp b))))) +(defun flymake--delete-overlay (ov) + "Like `delete-overlay', delete OV, but do some more stuff." + (let ((eolov (overlay-get ov 'eol-ov))) + (when eolov (delete-overlay eolov)) + (delete-overlay ov))) + (cl-defun flymake--highlight-line (diagnostic &optional foreign) "Attempt to overlay DIAGNOSTIC in current buffer. @@ -695,6 +724,7 @@ flymake--highlight-line ;; diagnostic is already registered in the same place, which only ;; happens for clashes between domestic and foreign diagnostics (cl-loop for e in (flymake-diagnostics beg end) + for eov = (flymake--diag-overlay e) when (flymake--equal-diagnostic-p e diagnostic) ;; FIXME. This is an imperfect heuristic. Ideally, we'd ;; want to delete no overlays and keep annotating the @@ -710,7 +740,7 @@ flymake--highlight-line (flymake--diag-orig-beg e) (flymake--diag-end e) (flymake--diag-orig-end e)) - (delete-overlay (flymake--diag-overlay e)))) + (flymake--delete-overlay eov))) (setq ov (make-overlay end beg)) (setf (flymake--diag-beg diagnostic) (overlay-start ov) (flymake--diag-end diagnostic) (overlay-end ov)) @@ -728,6 +758,37 @@ flymake--highlight-line (flymake--lookup-type-property type 'flymake-overlay-control)) (alist-get type flymake-diagnostic-types-alist)) do (overlay-put ov ov-prop value)) + ;; Handle `flymake-show-diagnostics-at-end-of-line' + ;; + (when-let ((eol-face (and flymake-show-diagnostics-at-end-of-line + (flymake--lookup-type-property type 'eol-face)))) + (save-excursion + (goto-char (overlay-start ov)) + (let* ((start (line-end-position)) + (end (min (1+ start) (point-max))) + (eolov (car + (cl-remove-if-not + (lambda (o) (overlay-get o 'flymake-source-ovs)) + (overlays-at start)))) + (bs (flymake-diagnostic-oneliner diagnostic t))) + (setq bs (propertize bs 'face eol-face)) + ;; FIXME: 1. no checking if there are unexpectedly more than + ;; one eolov at point. 2. The first regular source ov to + ;; die also kills the eolov (very rare this matters, but + ;; could be improved). + (cond (eolov + (overlay-put eolov 'before-string + (concat (overlay-get eolov 'before-string) " " bs)) + (overlay-put eolov 'flymake-source-ovs + (cons ov (overlay-get eolov 'flymake-source-ovs)))) + (t + (setq eolov (make-overlay start end nil t nil)) + (setq bs (concat " " bs)) + (put-text-property 0 1 'cursor t bs) + (overlay-put eolov 'before-string bs) + (overlay-put eolov 'evaporate (not (= start end))) + (overlay-put eolov 'flymake-source-ovs (list ov)) + (overlay-put ov 'eol-ov eolov)))))) ;; Now ensure some essential defaults are set ;; (cl-flet ((default-maybe @@ -743,6 +804,8 @@ flymake--highlight-line 'flymake-bitmap (alist-get 'bitmap (alist-get type ; backward compat flymake-diagnostic-types-alist))))) + ;; (default-maybe 'after-string + ;; (flymake--diag-text diagnostic)) (default-maybe 'help-echo (lambda (window _ov pos) (with-selected-window window @@ -873,7 +936,7 @@ flymake--clear-foreign-diags (maphash (lambda (_buffer diags) (cl-loop for d in diags when (flymake--diag-overlay d) - do (delete-overlay it))) + do (flymake--delete-overlay it))) (flymake--state-foreign-diags state)) (clrhash (flymake--state-foreign-diags state))) @@ -900,7 +963,7 @@ flymake--publish-diagnostics (flymake--intersects-p (overlay-start ov) (overlay-end ov) (car region) (cdr region))) - do (delete-overlay ov) + do (flymake--delete-overlay ov) else collect diag into surviving finally (setf (flymake--state-diags state) surviving))) @@ -909,7 +972,7 @@ flymake--publish-diagnostics (not (flymake--state-reported-p state)) (cl-loop for diag in (flymake--state-diags state) for ov = (flymake--diag-overlay diag) - when ov do (delete-overlay ov)) + when ov do (flymake--delete-overlay ov)) (setf (flymake--state-diags state) nil) ;; Also clear all overlays for `foreign-diags' in all other ;; buffers. @@ -1153,7 +1216,7 @@ flymake-mode ;; existing diagnostic overlays, lest we forget them by blindly ;; reinitializing `flymake--state' in the next line. ;; See https://github.com/joaotavora/eglot/issues/223. - (mapc #'delete-overlay (flymake--overlays)) + (mapc #'flymake--delete-overlay (flymake--overlays)) (setq flymake--state (make-hash-table)) (setq flymake--recent-changes nil) @@ -1200,7 +1263,7 @@ flymake-mode (when flymake-timer (cancel-timer flymake-timer) (setq flymake-timer nil)) - (mapc #'delete-overlay (flymake--overlays)) + (mapc #'flymake--delete-overlay (flymake--overlays)) (when flymake--state (maphash (lambda (_backend state) (flymake--clear-foreign-diags state)) commit d590af749f18ea3b82e46bb498568c77a2640d29 Author: Mattias Engdegård Date: Thu Apr 13 17:35:45 2023 +0200 Stronger checking in line-number-at-pos tests * test/lisp/simple-tests.el (line-number-at-pos-keeps-restriction) (line-number-at-pos-keeps-point): Check all return values. diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el index 28d8120f143..7dabb735522 100644 --- a/test/lisp/simple-tests.el +++ b/test/lisp/simple-tests.el @@ -839,7 +839,7 @@ line-number-at-pos-keeps-restriction (forward-line 2) (narrow-to-region (pos-bol) (pos-eol)) (should (equal (line-number-at-pos) 1)) - (line-number-at-pos nil t) + (should (equal (line-number-at-pos nil t) 3)) (should (equal (line-number-at-pos) 1)))) (ert-deftest line-number-at-pos-keeps-point () @@ -849,8 +849,8 @@ line-number-at-pos-keeps-point (goto-char (point-min)) (forward-line 2) (setq pos (point)) - (line-number-at-pos) - (line-number-at-pos nil t) + (should (equal (line-number-at-pos) 3)) + (should (equal (line-number-at-pos nil t) 3)) (should (equal pos (point)))))) (ert-deftest line-number-at-pos-when-passing-point () commit abb43a62365b378b27a85456db42dfa34d2ad760 Author: Mattias Engdegård Date: Thu Apr 13 17:25:25 2023 +0200 Stop pretending that specpdl overflow can ever occur * src/eval.c (grow_specpdl_allocation): Remove impossible error. * src/data.c (syms_of_data): Note obsolence of `excessive-variable-binding`. diff --git a/src/data.c b/src/data.c index 8dc5000424e..4ab37e86ce5 100644 --- a/src/data.c +++ b/src/data.c @@ -4217,10 +4217,11 @@ #define PUT_ERROR(sym, tail, msg) \ Fput (Qrecursion_error, Qerror_message, build_pure_c_string ("Excessive recursive calling error")); - PUT_ERROR (Qexcessive_variable_binding, recursion_tail, - "Variable binding depth exceeds max-specpdl-size"); PUT_ERROR (Qexcessive_lisp_nesting, recursion_tail, "Lisp nesting exceeds `max-lisp-eval-depth'"); + /* Error obsolete (from 29.1), kept for compatibility. */ + PUT_ERROR (Qexcessive_variable_binding, recursion_tail, + "Variable binding depth exceeds max-specpdl-size"); /* Types that type-of returns. */ DEFSYM (Qinteger, "integer"); diff --git a/src/eval.c b/src/eval.c index 1a4d3ad0307..545a280ae91 100644 --- a/src/eval.c +++ b/src/eval.c @@ -2373,8 +2373,7 @@ grow_specpdl_allocation (void) union specbinding *pdlvec = specpdl - 1; ptrdiff_t size = specpdl_end - specpdl; ptrdiff_t pdlvecsize = size + 1; - if (max_size <= size) - xsignal0 (Qexcessive_variable_binding); /* Can't happen, essentially. */ + eassert (max_size > size); pdlvec = xpalloc (pdlvec, &pdlvecsize, 1, max_size + 1, sizeof *specpdl); specpdl = pdlvec + 1; specpdl_end = specpdl + pdlvecsize - 1; commit df4a6342fa439de49451f6c48c7bfe639e8a3d6e Author: Mattias Engdegård Date: Thu Apr 13 14:08:28 2023 +0200 ; reorder function effect-declaration lists * lisp/emacs-lisp/byte-opt.el (side-effect-free-fns) (side-effect-and-error-free-fns, pure-fns): Group by file. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index f8ebbaabd95..2bdd3375728 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1636,200 +1636,231 @@ byte-optimize-set ;; I wonder if I missed any :-\) (let ((side-effect-free-fns - '(% * + - / /= 1+ 1- < <= = > >= abs acos - active-minibuffer-window all-threads - append aref ash asin atan - assoc-string assq - bare-symbol - base64-decode-string base64-encode-string base64url-encode-string - bool-vector-count-consecutive bool-vector-count-population - bool-vector-subsetp - boundp + '( + ;; alloc.c + make-bool-vector make-byte-code make-list make-record make-string + make-symbol make-vector + ;; buffer.c buffer-base-buffer buffer-chars-modified-tick buffer-file-name buffer-local-value buffer-local-variables buffer-modified-p - buffer-modified-tick buffer-name buffer-substring - buffer-substring-no-properties - buffer-text-pixel-size - byte-to-string byte-to-position - capitalize car-less-than-car car category-docstring - category-set-mnemonics cdr ceiling - char-after char-before char-category-set char-equal - char-syntax char-to-string char-width - compare-buffer-substrings compare-strings - concat condition-mutex condition-name - controlling-tty-p coordinates-in-window-p - copy-category-table copy-alist copy-hash-table copy-keymap - copy-marker copy-sequence copy-syntax-table - copysign cos - current-bidi-paragraph-direction - current-time-string current-time-zone - decode-char - decode-time default-boundp default-value - directory-name-p - documentation downcase - elt encode-char exp expt encode-time error-message-string - fboundp fceiling featurep ffloor - file-directory-p file-exists-p file-locked-p file-name-absolute-p - file-name-concat - file-newer-than-file-p file-readable-p file-symlink-p file-writable-p - float float-time floor - format format-message format-network-address format-time-string - frame-ancestor-p frame-bottom-divider-width - frame-char-height frame-char-width - frame-child-frame-border-width frame-internal-border-width - frame-native-height frame-native-width frame-first-window frame-focus - frame-fringe-width - frame-parameters frame-parameter frame-parent - frame-pointer-visible-p frame-position - frame-right-divider-width - frame-root-window frame-scale-factor - frame-scroll-bar-height frame-scroll-bar-width - frame-selected-window frame-terminal frame-text-cols frame-text-lines - frame-text-height frame-text-width - frame-total-cols frame-total-lines - frame-visible-p frame-window-state-change - fringe-bitmaps-at-pos - fround ftruncate - get gethash get-buffer get-buffer-process get-buffer-window - get-char-property get-char-property-and-overlay - get-display-property get-process - get-text-property get-unused-category get-variable-watchers - group-name - hash-table-count hash-table-rehash-size hash-table-rehash-threshold - hash-table-size hash-table-test hash-table-weakness - indirect-variable innermost-minibuffer-p intern-soft invisible-p isnan - keymap-parent keymap-prompt - ldexp - length length< length> length= - line-beginning-position line-end-position - line-number-at-pos line-pixel-height - local-variable-if-set-p local-variable-p locale-info - log logand logb logcount logior lognot logxor - lookup-image-map - make-bool-vector make-byte-code make-category-set make-char-table - make-hash-table make-keymap make-list make-record make-sparse-keymap - make-string make-symbol make-vector - marker-buffer marker-insertion-type marker-position max - match-beginning match-end - matching-paren - member memq memql min minibuffer-innermost-command-loop-p - minibuffer-selected-window minibuffer-window minibufferp - mod multibyte-char-to-unibyte mutex-name - next-char-property-change next-frame next-overlay-change - next-property-change next-single-char-property-change - next-single-property-change - next-window ngettext nth nthcdr number-to-string - object-intervals + buffer-modified-tick buffer-name get-buffer next-overlay-change overlay-buffer overlay-end overlay-get overlay-properties - overlay-start overlays-at overlays-in - posn-at-point posn-at-x-y position-symbol - pos-bol pos-eol - prefix-numeric-value - previous-char-property-change previous-frame previous-overlay-change - previous-property-change - previous-single-char-property-change previous-single-property-change - previous-window - prin1-to-string + overlay-start overlays-at overlays-in previous-overlay-change + ;; callint.c + prefix-numeric-value + ;; casefiddle.c + capitalize downcase upcase upcase-initials + ;; category.c + category-docstring category-set-mnemonics char-category-set + copy-category-table get-unused-category make-category-set + ;; character.c + char-width multibyte-char-to-unibyte string unibyte-char-to-multibyte + ;; charset.c + decode-char encode-char + ;; chartab.c + make-char-table + ;; data.c + % * + - / /= 1+ 1- < <= = > >= + aref ash bare-symbol + bool-vector-count-consecutive bool-vector-count-population + bool-vector-subsetp + boundp car cdr default-boundp default-value fboundp + get-variable-watchers indirect-variable + local-variable-if-set-p local-variable-p + logand logcount logior lognot logxor max min mod + number-to-string position-symbol string-to-number + subr-arity subr-name subr-native-lambda-list subr-type + symbol-function symbol-name symbol-plist symbol-value + symbol-with-pos-pos variable-binding-locus + ;; doc.c + documentation + ;; editfns.c + buffer-substring buffer-substring-no-properties + byte-to-position byte-to-string + char-after char-before char-equal char-to-string + compare-buffer-substrings + format format-message + group-name + line-beginning-position line-end-position ngettext pos-bol pos-eol + propertize region-beginning region-end string-to-char + user-full-name user-login-name + ;; fileio.c + car-less-than-car directory-name-p file-directory-p file-exists-p + file-name-absolute-p file-name-concat file-newer-than-file-p + file-readable-p file-symlink-p file-writable-p + ;; filelock.c + file-locked-p + ;; floatfns.c + abs acos asin atan ceiling copysign cos exp expt fceiling ffloor + float floor fround ftruncate isnan ldexp log logb round sin sqrt tan + truncate + ;; fns.c + append assq + base64-decode-string base64-encode-string base64url-encode-string + compare-strings concat copy-alist copy-hash-table copy-sequence elt + featurep get + gethash hash-table-count hash-table-rehash-size + hash-table-rehash-threshold hash-table-size hash-table-test + hash-table-weakness + length length< length= length> + line-number-at-pos locale-info make-hash-table + member memq memql nth nthcdr + object-intervals rassoc rassq reverse + string-as-multibyte string-as-unibyte string-bytes string-distance + string-equal string-lessp string-make-multibyte string-make-unibyte + string-search string-to-multibyte substring substring-no-properties + sxhash-eq sxhash-eql sxhash-equal sxhash-equal-including-properties + take vconcat + ;; frame.c + frame-ancestor-p frame-bottom-divider-width frame-char-height + frame-char-width frame-child-frame-border-width frame-focus + frame-fringe-width frame-internal-border-width frame-native-height + frame-native-width frame-parameter frame-parameters frame-parent + frame-pointer-visible-p frame-position frame-right-divider-width + frame-scale-factor frame-scroll-bar-height frame-scroll-bar-width + frame-text-cols frame-text-height frame-text-lines frame-text-width + frame-total-cols frame-total-lines frame-visible-p + frame-window-state-change next-frame previous-frame + tool-bar-pixel-width window-system + ;; fringe.c + fringe-bitmaps-at-pos + ;; keyboard.c + posn-at-point posn-at-x-y + ;; keymap.c + copy-keymap keymap-parent keymap-prompt make-keymap make-sparse-keymap + ;; lread.c + intern-soft read-from-string + ;; marker.c + copy-marker marker-buffer marker-insertion-type marker-position + ;; minibuf.c + active-minibuffer-window assoc-string innermost-minibuffer-p + minibuffer-innermost-command-loop-p minibufferp + ;; print.c + error-message-string prin1-to-string + ;; process.c + format-network-address get-buffer-process get-process process-buffer process-coding-system process-command process-filter - process-id process-inherit-coding-system-flag - process-mark process-name process-plist - process-query-on-exit-flag process-running-child-p process-sentinel - process-thread process-tty-name process-type - propertize - rassq rassoc read-from-string - regexp-quote region-beginning region-end reverse round - sin + process-id process-inherit-coding-system-flag process-mark + process-name process-plist process-query-on-exit-flag + process-running-child-p process-sentinel process-thread + process-tty-name process-type + ;; search.c + match-beginning match-end regexp-quote + ;; sqlite.c sqlite-columns sqlite-more-p sqlite-version - sqrt string string-bytes string-distance string-equal string-lessp - string-search string-to-char - string-to-number string-to-syntax subr-arity subr-name - substring substring-no-properties - sxhash-equal sxhash-eq sxhash-eql sxhash-equal-including-properties - symbol-function symbol-name symbol-plist symbol-value - symbol-with-pos-pos + ;; syntax.c + char-syntax copy-syntax-table matching-paren string-to-syntax syntax-class-to-char - string-make-unibyte - string-make-multibyte string-as-multibyte string-as-unibyte - string-to-multibyte - subr-native-lambda-list subr-type - tab-bar-height - take tan - terminal-list terminal-live-p terminal-name + ;; term.c + controlling-tty-p tty-display-color-cells tty-display-color-p + tty-top-frame tty-type + ;; terminal.c + frame-terminal terminal-list terminal-live-p terminal-name terminal-parameter terminal-parameters + ;; textprop.c + get-char-property get-char-property-and-overlay get-text-property + next-char-property-change next-property-change + next-single-char-property-change next-single-property-change + previous-char-property-change previous-property-change + previous-single-char-property-change previous-single-property-change text-properties-at text-property-any text-property-not-all - thread-live-p thread-name - time-add time-convert time-equal-p time-less-p time-subtract - tool-bar-height tool-bar-pixel-width truncate - tty-display-color-cells tty-display-color-p tty-top-frame tty-type - unibyte-char-to-multibyte upcase upcase-initials user-full-name - user-login-name - variable-binding-locus vconcat - window-at window-body-height - window-body-width window-buffer window-dedicated-p window-display-table - window-combination-limit window-configuration-equal-p window-frame - window-fringes window-hscroll - window-left-child window-left-column window-margins window-minibuffer-p - window-next-buffers window-next-sibling window-new-normal - window-new-total window-normal-size window-parameter window-parameters - window-parent window-point window-prev-buffers - window-prev-sibling window-scroll-bars - window-start window-system window-text-height - window-text-pixel-size - window-top-child window-top-line - window-total-height window-total-width window-use-time window-vscroll - )) + ;; thread.c + all-threads condition-mutex condition-name mutex-name thread-live-p + thread-name + ;; timefns.c + current-time-string current-time-zone decode-time encode-time + float-time format-time-string time-add time-convert time-equal-p + time-less-p time-subtract + ;; window.c + coordinates-in-window-p frame-first-window frame-root-window + frame-selected-window get-buffer-window minibuffer-selected-window + minibuffer-window next-window previous-window window-at + window-body-height window-body-width window-buffer + window-combination-limit window-configuration-equal-p + window-dedicated-p window-display-table window-frame window-fringes + window-hscroll window-left-child window-left-column window-margins + window-minibuffer-p window-new-normal window-new-total + window-next-buffers window-next-sibling window-normal-size + window-parameter window-parameters window-parent window-point + window-prev-buffers window-prev-sibling window-scroll-bars + window-start window-text-height window-top-child window-top-line + window-total-height window-total-width window-use-time window-vscroll + ;; xdisp.c + buffer-text-pixel-size current-bidi-paragraph-direction + get-display-property invisible-p line-pixel-height lookup-image-map + tab-bar-height tool-bar-height window-text-pixel-size + )) (side-effect-and-error-free-fns - '(arrayp atom - bare-symbol-p bobp bolp bool-vector bool-vector-p - buffer-list buffer-live-p buffer-size buffer-string bufferp - byte-code-function-p byteorder - car-safe case-table-p category-table category-table-p cdr-safe - char-or-string-p char-table-p characterp - charsetp commandp condition-variable-p cons consp - current-buffer current-case-table current-column current-global-map - current-idle-time current-indentation current-input-mode - current-local-map current-message current-minor-mode-maps - current-thread current-time + '( + ;; alloc.c + bool-vector cons list make-marker purecopy record vector + ;; buffer.c + buffer-list buffer-live-p current-buffer overlay-lists overlayp + ;; casetab.c + case-table-p current-case-table standard-case-table + ;; category.c + category-table category-table-p make-category-table + standard-category-table + ;; character.c + characterp max-char + ;; charset.c + charsetp + ;; data.c + arrayp atom bare-symbol-p bool-vector-p bufferp byte-code-function-p + byteorder car-safe cdr-safe char-or-string-p char-table-p + condition-variable-p consp eq floatp indirect-function + integer-or-marker-p integerp keywordp listp markerp + module-function-p multibyte-string-p mutexp natnump nlistp null + number-or-marker-p numberp recordp remove-pos-from-symbol + sequencep stringp subr-native-elisp-p subrp symbol-with-pos-p symbolp + threadp type-of user-ptrp vector-or-char-table-p vectorp wholenump + ;; editfns.c + bobp bolp buffer-size buffer-string current-message emacs-pid + eobp eolp following-char gap-position gap-size group-gid + group-real-gid mark-marker point point-marker point-max point-min + position-bytes preceding-char system-name + user-real-login-name user-real-uid user-uid + ;; emacs.c + invocation-directory invocation-name + ;; eval.c + commandp functionp + ;; fileio.c default-file-modes - emacs-pid eobp eolp eq equal eql - floatp following-char - frame-list frame-live-p framep functionp - gap-position gap-size - group-gid group-real-gid - hash-table-p - identity imagep indirect-function integerp integer-or-marker-p - invocation-directory invocation-name - keymapp keywordp - last-nonminibuffer-frame list listp - long-line-optimizations-p - make-category-table make-marker mark-marker markerp max-char - minibuffer-contents minibuffer-contents-no-properties - minibuffer-depth minibuffer-prompt minibuffer-prompt-end - module-function-p multibyte-string-p mutexp - natnump nlistp null number-or-marker-p numberp - old-selected-frame overlay-lists overlayp - point point-marker point-min point-max position-bytes - preceding-char - processp process-list - proper-list-p purecopy - recent-keys record recordp recursion-depth - remove-pos-from-symbol - safe-length secure-hash-algorithms - selected-frame selected-window sequencep signal-names + ;; fns.c + eql equal hash-table-p identity proper-list-p safe-length + secure-hash-algorithms + ;; frame.c + frame-list frame-live-p framep last-nonminibuffer-frame + old-selected-frame selected-frame visible-frame-list + ;; image.c + imagep + ;; indent.c + current-column current-indentation + ;; keyboard.c + current-idle-time current-input-mode recent-keys recursion-depth + this-command-keys this-command-keys-vector this-single-command-keys + this-single-command-raw-keys + ;; keymap.c + current-global-map current-local-map current-minor-mode-maps keymapp + ;; minibuf.c + minibuffer-contents minibuffer-contents-no-properties minibuffer-depth + minibuffer-prompt minibuffer-prompt-end + ;; process.c + process-list processp signal-names waiting-for-user-input-p + ;; sqlite.c sqlite-available-p sqlitep - standard-case-table standard-category-table standard-syntax-table - stringp - subr-native-elisp-p subrp - symbol-with-pos-p symbolp - syntax-table syntax-table-p system-name - this-command-keys this-command-keys-vector this-single-command-keys - this-single-command-raw-keys threadp type-of - user-ptrp - user-real-login-name user-real-uid user-uid - vector vector-or-char-table-p vectorp visible-frame-list - waiting-for-user-input-p - wholenump window-configuration-p window-live-p - window-valid-p windowp))) + ;; syntax.c + standard-syntax-table syntax-table syntax-table-p + ;; thread.c + current-thread + ;; timefns.c + current-time + ;; window.c + selected-window window-configuration-p window-live-p window-valid-p + windowp + ;; xdisp.c + long-line-optimizations-p + ))) (while side-effect-free-fns (put (car side-effect-free-fns) 'side-effect-free t) (setq side-effect-free-fns (cdr side-effect-free-fns))) @@ -1854,45 +1885,34 @@ byte-optimize-set ;; values if a marker is moved. (let ((pure-fns - '(concat regexp-quote - string-to-char string-to-syntax symbol-name - eq eql - = /= < <= >= > min max - + - * / % mod abs ash 1+ 1- sqrt - logand logior lognot logxor logcount - copysign isnan ldexp float logb - floor ceiling round truncate - ffloor fceiling fround ftruncate - string-equal string-lessp - string-search - consp atom listp nlistp proper-list-p - sequencep arrayp vectorp stringp bool-vector-p hash-table-p recordp - multibyte-string-p char-table-p vector-or-char-table-p - threadp mutexp condition-variable-p - null - numberp integerp floatp natnump characterp - integer-or-marker-p number-or-marker-p char-or-string-p - symbolp keywordp bufferp markerp - bare-symbol remove-pos-from-symbol - type-of - identity - - ;; The following functions are pure up to mutation of their - ;; arguments. This is pure enough for the purposes of - ;; constant folding, but not necessarily for all kinds of - ;; code motion. - car cdr car-safe cdr-safe nth nthcdr take - equal - length safe-length - memq memql member - ;; `assoc' and `assoc-default' are excluded since they are - ;; impure if the test function is (consider `string-match'). - assq rassq rassoc - aref elt - length< length> length= string-bytes string-distance - base64-decode-string base64-encode-string base64url-encode-string - bool-vector-subsetp - bool-vector-count-population bool-vector-count-consecutive + '( + ;; character.c + characterp + ;; data.c + % * + - / /= 1+ 1- < <= = > >= aref arrayp ash atom bare-symbol + bool-vector-count-consecutive bool-vector-count-population + bool-vector-p bool-vector-subsetp + bufferp car car-safe cdr cdr-safe char-or-string-p char-table-p + condition-variable-p consp eq floatp integer-or-marker-p integerp + keywordp listp logand logcount logior lognot logxor markerp max min + mod multibyte-string-p mutexp natnump nlistp null number-or-marker-p + numberp recordp remove-pos-from-symbol sequencep stringp symbol-name + symbolp threadp type-of vector-or-char-table-p vectorp + ;; editfns.c + string-to-char + ;; floatfns.c + abs ceiling copysign fceiling ffloor float floor fround ftruncate + isnan ldexp logb round sqrt truncate + ;; fns.c + assq base64-decode-string base64-encode-string base64url-encode-string + concat elt eql equal hash-table-p identity length length< length= + length> member memq memql nth nthcdr proper-list-p rassoc rassq + safe-length string-bytes string-distance string-equal string-lessp + string-search take + ;; search.c + regexp-quote + ;; syntax.c + string-to-syntax ))) (while pure-fns (put (car pure-fns) 'pure t) commit feef1a0592d2f56bfae1718ae6f83f8f66393fb3 Author: Mattias Engdegård Date: Wed Apr 12 12:20:12 2023 +0200 Update effect declarations for many built-in functions * lisp/emacs-lisp/byte-opt.el (side-effect-free-fns) (side-effect-and-error-free-fns, pure-fns): Add many functions. * lisp/subr.el (copy-tree): Declare error-free. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index c9c94f51ef0..f8ebbaabd95 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1636,97 +1636,198 @@ byte-optimize-set ;; I wonder if I missed any :-\) (let ((side-effect-free-fns - '(% * + - / /= 1+ 1- < <= = > >= abs acos append aref ash asin atan - assq + '(% * + - / /= 1+ 1- < <= = > >= abs acos + active-minibuffer-window all-threads + append aref ash asin atan + assoc-string assq + bare-symbol base64-decode-string base64-encode-string base64url-encode-string bool-vector-count-consecutive bool-vector-count-population bool-vector-subsetp - boundp buffer-file-name buffer-local-variables buffer-modified-p - buffer-substring - capitalize car-less-than-car car cdr ceiling char-after char-before - char-equal char-to-string char-width compare-strings - window-configuration-equal-p concat coordinates-in-window-p - copy-alist copy-sequence copy-marker copysign cos + boundp + buffer-base-buffer buffer-chars-modified-tick buffer-file-name + buffer-local-value buffer-local-variables buffer-modified-p + buffer-modified-tick buffer-name buffer-substring + buffer-substring-no-properties + buffer-text-pixel-size + byte-to-string byte-to-position + capitalize car-less-than-car car category-docstring + category-set-mnemonics cdr ceiling + char-after char-before char-category-set char-equal + char-syntax char-to-string char-width + compare-buffer-substrings compare-strings + concat condition-mutex condition-name + controlling-tty-p coordinates-in-window-p + copy-category-table copy-alist copy-hash-table copy-keymap + copy-marker copy-sequence copy-syntax-table + copysign cos + current-bidi-paragraph-direction current-time-string current-time-zone decode-char - decode-time default-boundp default-value documentation downcase + decode-time default-boundp default-value + directory-name-p + documentation downcase elt encode-char exp expt encode-time error-message-string fboundp fceiling featurep ffloor file-directory-p file-exists-p file-locked-p file-name-absolute-p file-name-concat file-newer-than-file-p file-readable-p file-symlink-p file-writable-p - float float-time floor format format-message format-time-string - frame-first-window frame-root-window frame-selected-window - frame-visible-p fround ftruncate - get gethash get-buffer get-buffer-window get-file-buffer - hash-table-count - intern-soft isnan - keymap-parent + float float-time floor + format format-message format-network-address format-time-string + frame-ancestor-p frame-bottom-divider-width + frame-char-height frame-char-width + frame-child-frame-border-width frame-internal-border-width + frame-native-height frame-native-width frame-first-window frame-focus + frame-fringe-width + frame-parameters frame-parameter frame-parent + frame-pointer-visible-p frame-position + frame-right-divider-width + frame-root-window frame-scale-factor + frame-scroll-bar-height frame-scroll-bar-width + frame-selected-window frame-terminal frame-text-cols frame-text-lines + frame-text-height frame-text-width + frame-total-cols frame-total-lines + frame-visible-p frame-window-state-change + fringe-bitmaps-at-pos + fround ftruncate + get gethash get-buffer get-buffer-process get-buffer-window + get-char-property get-char-property-and-overlay + get-display-property get-process + get-text-property get-unused-category get-variable-watchers + group-name + hash-table-count hash-table-rehash-size hash-table-rehash-threshold + hash-table-size hash-table-test hash-table-weakness + indirect-variable innermost-minibuffer-p intern-soft invisible-p isnan + keymap-parent keymap-prompt ldexp length length< length> length= - line-beginning-position line-end-position pos-bol pos-eol + line-beginning-position line-end-position + line-number-at-pos line-pixel-height local-variable-if-set-p local-variable-p locale-info log logand logb logcount logior lognot logxor - make-byte-code make-list make-string make-symbol marker-buffer max + lookup-image-map + make-bool-vector make-byte-code make-category-set make-char-table + make-hash-table make-keymap make-list make-record make-sparse-keymap + make-string make-symbol make-vector + marker-buffer marker-insertion-type marker-position max match-beginning match-end - member memq memql min minibuffer-selected-window minibuffer-window - mod multibyte-char-to-unibyte next-window nth nthcdr number-to-string - prefix-numeric-value previous-window prin1-to-string propertize + matching-paren + member memq memql min minibuffer-innermost-command-loop-p + minibuffer-selected-window minibuffer-window minibufferp + mod multibyte-char-to-unibyte mutex-name + next-char-property-change next-frame next-overlay-change + next-property-change next-single-char-property-change + next-single-property-change + next-window ngettext nth nthcdr number-to-string + object-intervals + overlay-buffer overlay-end overlay-get overlay-properties + overlay-start overlays-at overlays-in + posn-at-point posn-at-x-y position-symbol + pos-bol pos-eol + prefix-numeric-value + previous-char-property-change previous-frame previous-overlay-change + previous-property-change + previous-single-char-property-change previous-single-property-change + previous-window + prin1-to-string + process-buffer process-coding-system process-command process-filter + process-id process-inherit-coding-system-flag + process-mark process-name process-plist + process-query-on-exit-flag process-running-child-p process-sentinel + process-thread process-tty-name process-type + propertize rassq rassoc read-from-string regexp-quote region-beginning region-end reverse round - sin sqrt string string-equal string-lessp + sin + sqlite-columns sqlite-more-p sqlite-version + sqrt string string-bytes string-distance string-equal string-lessp string-search string-to-char - string-to-number string-to-syntax substring substring-no-properties - sxhash-equal sxhash-eq sxhash-eql - symbol-function symbol-name symbol-plist symbol-value + string-to-number string-to-syntax subr-arity subr-name + substring substring-no-properties + sxhash-equal sxhash-eq sxhash-eql sxhash-equal-including-properties + symbol-function symbol-name symbol-plist symbol-value + symbol-with-pos-pos + syntax-class-to-char string-make-unibyte string-make-multibyte string-as-multibyte string-as-unibyte string-to-multibyte - take tan time-convert truncate - unibyte-char-to-multibyte upcase user-full-name + subr-native-lambda-list subr-type + tab-bar-height + take tan + terminal-list terminal-live-p terminal-name + terminal-parameter terminal-parameters + text-properties-at text-property-any text-property-not-all + thread-live-p thread-name + time-add time-convert time-equal-p time-less-p time-subtract + tool-bar-height tool-bar-pixel-width truncate + tty-display-color-cells tty-display-color-p tty-top-frame tty-type + unibyte-char-to-multibyte upcase upcase-initials user-full-name user-login-name - vconcat + variable-binding-locus vconcat window-at window-body-height window-body-width window-buffer window-dedicated-p window-display-table - window-combination-limit window-frame window-fringes - window-hscroll + window-combination-limit window-configuration-equal-p window-frame + window-fringes window-hscroll window-left-child window-left-column window-margins window-minibuffer-p window-next-buffers window-next-sibling window-new-normal window-new-total window-normal-size window-parameter window-parameters window-parent window-point window-prev-buffers window-prev-sibling window-scroll-bars - window-start window-text-height window-top-child window-top-line + window-start window-system window-text-height + window-text-pixel-size + window-top-child window-top-line window-total-height window-total-width window-use-time window-vscroll )) (side-effect-and-error-free-fns '(arrayp atom - bobp bolp bool-vector-p - buffer-list buffer-size buffer-string bufferp - byte-code-function-p - car-safe case-table-p cdr-safe char-or-string-p characterp - charsetp commandp cons consp - current-buffer current-global-map current-indentation - current-local-map current-minor-mode-maps current-time - eobp eolp eq equal eql - floatp following-char framep + bare-symbol-p bobp bolp bool-vector bool-vector-p + buffer-list buffer-live-p buffer-size buffer-string bufferp + byte-code-function-p byteorder + car-safe case-table-p category-table category-table-p cdr-safe + char-or-string-p char-table-p characterp + charsetp commandp condition-variable-p cons consp + current-buffer current-case-table current-column current-global-map + current-idle-time current-indentation current-input-mode + current-local-map current-message current-minor-mode-maps + current-thread current-time + default-file-modes + emacs-pid eobp eolp eq equal eql + floatp following-char + frame-list frame-live-p framep functionp + gap-position gap-size + group-gid group-real-gid hash-table-p - identity indirect-function integerp integer-or-marker-p + identity imagep indirect-function integerp integer-or-marker-p invocation-directory invocation-name keymapp keywordp - list listp - make-marker mark-marker markerp max-char + last-nonminibuffer-frame list listp + long-line-optimizations-p + make-category-table make-marker mark-marker markerp max-char + minibuffer-contents minibuffer-contents-no-properties + minibuffer-depth minibuffer-prompt minibuffer-prompt-end + module-function-p multibyte-string-p mutexp natnump nlistp null number-or-marker-p numberp - overlayp - point point-marker point-min point-max preceding-char - processp proper-list-p - recent-keys recursion-depth - safe-length selected-frame selected-window sequencep - standard-case-table standard-syntax-table stringp subrp symbolp - syntax-table syntax-table-p + old-selected-frame overlay-lists overlayp + point point-marker point-min point-max position-bytes + preceding-char + processp process-list + proper-list-p purecopy + recent-keys record recordp recursion-depth + remove-pos-from-symbol + safe-length secure-hash-algorithms + selected-frame selected-window sequencep signal-names + sqlite-available-p sqlitep + standard-case-table standard-category-table standard-syntax-table + stringp + subr-native-elisp-p subrp + symbol-with-pos-p symbolp + syntax-table syntax-table-p system-name this-command-keys this-command-keys-vector this-single-command-keys - this-single-command-raw-keys type-of - user-real-login-name user-real-uid user-uid - vector vectorp visible-frame-list + this-single-command-raw-keys threadp type-of + user-ptrp + user-real-login-name user-real-uid user-uid + vector vector-or-char-table-p vectorp visible-frame-list + waiting-for-user-input-p wholenump window-configuration-p window-live-p window-valid-p windowp))) (while side-effect-free-fns @@ -1765,11 +1866,14 @@ byte-optimize-set string-equal string-lessp string-search consp atom listp nlistp proper-list-p - sequencep arrayp vectorp stringp bool-vector-p hash-table-p + sequencep arrayp vectorp stringp bool-vector-p hash-table-p recordp + multibyte-string-p char-table-p vector-or-char-table-p + threadp mutexp condition-variable-p null numberp integerp floatp natnump characterp integer-or-marker-p number-or-marker-p char-or-string-p - symbolp keywordp + symbolp keywordp bufferp markerp + bare-symbol remove-pos-from-symbol type-of identity @@ -1785,6 +1889,7 @@ byte-optimize-set ;; impure if the test function is (consider `string-match'). assq rassq rassoc aref elt + length< length> length= string-bytes string-distance base64-decode-string base64-encode-string base64url-encode-string bool-vector-subsetp bool-vector-count-population bool-vector-count-consecutive diff --git a/lisp/subr.el b/lisp/subr.el index cbddfa620a8..f90026534e8 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -829,7 +829,7 @@ copy-tree If TREE is a cons cell, this recursively copies both its car and its cdr. Contrast to `copy-sequence', which copies only along the cdrs. With second argument VECP, this copies vectors as well as conses." - (declare (side-effect-free t)) + (declare (side-effect-free error-free)) (if (consp tree) (let (result) (while (consp tree)