commit 75f04848a653e70f12f0e5a62b756c5bba0dd204 (HEAD, refs/remotes/origin/master) Author: Mattias Engdegård Date: Sun Mar 12 17:00:25 2023 +0100 Repair and speed up safe-copy-tree and make it internal (bug#61962) There is no particular requirement for safe-copy-tree so let's make it internal for now. The new implementation is faster and more correct. * doc/lispref/lists.texi (Building Lists): * etc/NEWS: Remove doc and announcement. * lisp/subr.el (safe-copy-tree--seen, safe-copy-tree--1) (safe-copy-tree): Remove old version. * lisp/emacs-lisp/bytecomp.el (bytecomp--copy-tree-seen) (bytecomp--copy-tree-1, bytecomp--copy-tree): Add new version. (byte-compile-initial-macro-environment): Use it. * test/lisp/subr-tests.el (subr--safe-copy-tree): * test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp--copy-tree): Move and improve tests. diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi index 3478049c84f..a509325854f 100644 --- a/doc/lispref/lists.texi +++ b/doc/lispref/lists.texi @@ -708,19 +708,6 @@ Building Lists their elements). This function cannot cope with circular lists. @end defun -@defun safe-copy-tree tree &optional vecp -This function returns a copy of the tree @var{tree}. If @var{tree} is -a cons cell, this make a new cons cell with the same @sc{car} and -@sc{cdr}, then recursively copies the @sc{car} and @sc{cdr} in the -same way. - -Normally, when @var{tree} is anything other than a cons cell, -@code{copy-tree} simply returns @var{tree}. However, if @var{vecp} is -non-@code{nil}, it copies vectors and records too (and operates -recursively on their elements). This function handles circular lists -and vectors, and is thus slower than @code{copy-tree} for typical cases. -@end defun - @defun flatten-tree tree This function returns a ``flattened'' copy of @var{tree}, that is, a list containing all the non-@code{nil} terminal nodes, or leaves, of diff --git a/etc/NEWS b/etc/NEWS index e31203689e3..3b02e85b691 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -391,11 +391,6 @@ was to catch all errors, add an explicit handler for 'error', or use This warning can be suppressed using 'with-suppressed-warnings' with the warning name 'suspicious'. -+++ -** New function 'safe-copy-tree' -This function is a version of copy-tree which handles circular lists -and circular vectors/records. - +++ ** New function 'file-user-uid'. This function is like 'user-uid', but is aware of file name handlers, diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 12850c27b88..a122e81ba3c 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -495,6 +495,42 @@ byte-compile-recurse-toplevel (cdr form))) (funcall non-toplevel-case form))) + +(defvar bytecomp--copy-tree-seen) + +(defun bytecomp--copy-tree-1 (tree) + ;; TREE must be a cons. + (or (gethash tree bytecomp--copy-tree-seen) + (let* ((next (cdr tree)) + (result (cons nil next)) + (copy result)) + (while (progn + (puthash tree copy bytecomp--copy-tree-seen) + (let ((a (car tree))) + (setcar copy (if (consp a) + (bytecomp--copy-tree-1 a) + a))) + (and (consp next) + (let ((tail (gethash next bytecomp--copy-tree-seen))) + (if tail + (progn (setcdr copy tail) + nil) + (setq tree next) + (setq next (cdr next)) + (let ((prev copy)) + (setq copy (cons nil next)) + (setcdr prev copy) + t)))))) + result))) + +(defun bytecomp--copy-tree (tree) + "Make a copy of TREE, preserving any circular structure therein. +Only conses are traversed and duplicated, not arrays or any other structure." + (if (consp tree) + (let ((bytecomp--copy-tree-seen (make-hash-table :test #'eq))) + (bytecomp--copy-tree-1 tree)) + tree)) + (defconst byte-compile-initial-macro-environment `( ;; (byte-compiler-options . (lambda (&rest forms) @@ -534,7 +570,7 @@ byte-compile-initial-macro-environment form macroexpand-all-environment))) (eval (byte-run-strip-symbol-positions - (safe-copy-tree expanded)) + (bytecomp--copy-tree expanded)) lexical-binding) expanded))))) (with-suppressed-warnings diff --git a/lisp/subr.el b/lisp/subr.el index 40bec544b73..8aedce934d1 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -846,61 +846,6 @@ copy-tree tree) tree))) -(defvar safe-copy-tree--seen nil - "A hash table for conses/vectors/records already seen by safe-copy-tree-1. -Its key is a cons or vector/record seen by the algorithm, and its -value is the corresponding cons/vector/record in the copy.") - -(defun safe-copy-tree--1 (tree &optional vecp) - "Make a copy of TREE, taking circular structure into account. -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 and records as well as conses." - (cond - ((gethash tree safe-copy-tree--seen)) - ((consp tree) - (let* ((result (cons (car tree) (cdr tree))) - (newcons result) - hash) - (while (and (not hash) (consp tree)) - (if (setq hash (gethash tree safe-copy-tree--seen)) - (setq newcons hash) - (puthash tree newcons safe-copy-tree--seen)) - (setq tree newcons) - (unless hash - (if (or (consp (car tree)) - (and vecp (or (vectorp (car tree)) (recordp (car tree))))) - (let ((newcar (safe-copy-tree--1 (car tree) vecp))) - (setcar tree newcar))) - (setq newcons (if (consp (cdr tree)) - (cons (cadr tree) (cddr tree)) - (cdr tree))) - (setcdr tree newcons) - (setq tree (cdr tree)))) - (nconc result - (if (and vecp (or (vectorp tree) (recordp tree))) - (safe-copy-tree--1 tree vecp) tree)))) - ((and vecp (or (vectorp tree) (recordp tree))) - (let* ((newvec (copy-sequence tree)) - (i (length newvec))) - (puthash tree newvec safe-copy-tree--seen) - (setq tree newvec) - (while (>= (setq i (1- i)) 0) - (aset tree i (safe-copy-tree--1 (aref tree i) vecp))) - tree)) - (t tree))) - -(defun safe-copy-tree (tree &optional vecp) - "Make a copy of TREE, taking circular structure into account. -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 and records as well as conses." - (setq safe-copy-tree--seen (make-hash-table :test #'eq)) - (unwind-protect - (safe-copy-tree--1 tree vecp) - (clrhash safe-copy-tree--seen) - (setq safe-copy-tree--seen nil))) - ;;;; Various list-search functions. diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 10b009a261c..2cd4dd75742 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -1850,6 +1850,34 @@ byte-compile-file/no-byte-compile (should (eq (byte-compile-file src-file) 'no-byte-compile)) (should-not (file-exists-p dest-file)))) +(ert-deftest bytecomp--copy-tree () + (should (null (bytecomp--copy-tree nil))) + (let ((print-circle t)) + (let* ((x '(1 2 (3 4))) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + "((1 2 (3 4)) (1 2 (3 4)))"))) + (let* ((x '#1=(a #1#)) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + "(#1=(a #1#) #2=(a #2#))"))) + (let* ((x '#1=(#1# a)) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + "(#1=(#1# a) #2=(#2# a))"))) + (let* ((x '((a . #1=(b)) #1#)) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + "(((a . #1=(b)) #1#) ((a . #2=(b)) #2#))"))) + (let* ((x '#1=(a #2=(#1# b . #3=(#2# c . #1#)) (#3# d))) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + (concat + "(" + "#1=(a #2=(#1# b . #3=(#2# c . #1#)) (#3# d))" + " " + "#4=(a #5=(#4# b . #6=(#5# c . #4#)) (#6# d))" + ")")))))) ;; Local Variables: ;; no-byte-compile: t diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 37fe09c1716..050ee22ac18 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -1205,31 +1205,5 @@ subr--delete-consecutive-dups (should (equal a-dedup '("a" "b" "a" "b" "c"))) (should (eq a a-dedup)))) -(ert-deftest subr--safe-copy-tree () - (should (null (safe-copy-tree nil))) - (let* ((foo '(1 2 (3 4))) (bar (safe-copy-tree foo))) - (should (equal bar foo)) - (should-not (eq bar foo)) - (should-not (eq (caddr bar) (caddr foo)))) - (let* ((foo '#1=(a #1#)) (bar (safe-copy-tree foo))) - (should (eq (car bar) (car foo))) -; (should-not (proper-list-p bar)) - (should (eq (caadr bar) (caadr foo))) - (should (eq (caadr bar) 'a))) - (let* ((foo [1 2 3 4]) (bar (safe-copy-tree foo))) - (should (eq bar foo))) - (let* ((foo [1 (2 3) 4]) (bar (safe-copy-tree foo t))) - (should-not (eq bar foo)) - (should (equal bar foo)) - (should-not (eq (aref bar 1) (aref foo 1)))) - (let* ((foo [1 [2 3] 4]) (bar (safe-copy-tree foo t))) - (should (equal bar foo)) - (should-not (eq bar foo)) - (should-not (eq (aref bar 1) (aref foo 1)))) - (let* ((foo (record 'foo 1 "two" 3)) (bar (safe-copy-tree foo t))) - (should (equal bar foo)) - (should-not (eq bar foo)) - (should (eq (aref bar 2) (aref foo 2))))) - (provide 'subr-tests) ;;; subr-tests.el ends here commit f5f13495f5dac4148c1da8b0ba18c22daf77bb04 Author: Michael Albinus Date: Sun Mar 12 17:21:57 2023 +0100 Make Tramp file name completion more quiet for all backends * lisp/net/tramp-adb.el (tramp-adb-handle-file-name-all-completions): * lisp/net/tramp-archive.el (tramp-archive-handle-file-name-all-completions): * lisp/net/tramp-crypt.el (tramp-crypt-handle-file-name-all-completions): * lisp/net/tramp-fuse.el (tramp-fuse-handle-file-name-all-completions): * lisp/net/tramp-gvfs.el (tramp-gvfs-handle-file-name-all-completions): * lisp/net/tramp-sh.el (tramp-sh-handle-file-name-all-completions): * lisp/net/tramp-smb.el (tramp-smb-handle-file-name-all-completions): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-handle-file-name-all-completions): Return nil when DIRECTORY is missing. (Bug#61890) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index f8c38859477..64f45e7958d 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -432,31 +432,32 @@ tramp-adb-handle-delete-file (defun tramp-adb-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (all-completions - filename - (with-parsed-tramp-file-name (expand-file-name directory) nil - (with-tramp-file-property v localname "file-name-all-completions" - (tramp-adb-send-command - v (format "%s -a %s | cat" - (tramp-adb-get-ls-command v) - (tramp-shell-quote-argument localname))) - (mapcar - (lambda (f) - (if (file-directory-p (expand-file-name f directory)) - (file-name-as-directory f) - f)) - (with-current-buffer (tramp-get-buffer v) - (delete-dups - (append - ;; On some file systems like "sdcard", "." and ".." are - ;; not included. We fix this by `delete-dups'. - '("." "..") - (delq - nil - (mapcar - (lambda (l) - (and (not (string-match-p (rx bol (* blank) eol) l)) l)) - (split-string (buffer-string) "\n"))))))))))) + (ignore-error file-missing + (all-completions + filename + (with-parsed-tramp-file-name (expand-file-name directory) nil + (with-tramp-file-property v localname "file-name-all-completions" + (tramp-adb-send-command + v (format "%s -a %s | cat" + (tramp-adb-get-ls-command v) + (tramp-shell-quote-argument localname))) + (mapcar + (lambda (f) + (if (file-directory-p (expand-file-name f directory)) + (file-name-as-directory f) + f)) + (with-current-buffer (tramp-get-buffer v) + (delete-dups + (append + ;; On some file systems like "sdcard", "." and ".." are + ;; not included. We fix this by `delete-dups'. + '("." "..") + (delq + nil + (mapcar + (lambda (l) + (and (not (string-match-p (rx bol (* blank) eol) l)) l)) + (split-string (buffer-string) "\n")))))))))))) (defun tramp-adb-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 97adb36c4af..c2175612fa8 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -650,7 +650,9 @@ tramp-archive-handle-file-local-copy (defun tramp-archive-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for file archives." - (file-name-all-completions filename (tramp-archive-gvfs-file-name directory))) + (ignore-error file-missing + (file-name-all-completions + filename (tramp-archive-gvfs-file-name directory)))) (defun tramp-archive-handle-file-readable-p (filename) "Like `file-readable-p' for file archives." diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index afd3166d161..d0f1f1b8184 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -730,18 +730,19 @@ tramp-crypt-handle-file-locked-p (defun tramp-crypt-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (all-completions - filename - (let* (completion-regexp-list - tramp-crypt-enabled - (directory (file-name-as-directory directory)) - (enc-dir (tramp-crypt-encrypt-file-name directory))) - (mapcar - (lambda (x) - (substring - (tramp-crypt-decrypt-file-name (concat enc-dir x)) - (length directory))) - (file-name-all-completions "" enc-dir))))) + (ignore-error file-missing + (all-completions + filename + (let* (completion-regexp-list + tramp-crypt-enabled + (directory (file-name-as-directory directory)) + (enc-dir (tramp-crypt-encrypt-file-name directory))) + (mapcar + (lambda (x) + (substring + (tramp-crypt-decrypt-file-name (concat enc-dir x)) + (length directory))) + (file-name-all-completions "" enc-dir)))))) (defun tramp-crypt-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el index b846caadc18..8112e564a2c 100644 --- a/lisp/net/tramp-fuse.el +++ b/lisp/net/tramp-fuse.el @@ -98,20 +98,21 @@ tramp-fuse-handle-file-executable-p (defun tramp-fuse-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." (tramp-fuse-remove-hidden-files - (all-completions - filename - (delete-dups - (append - (file-name-all-completions - filename (tramp-fuse-local-file-name directory)) - ;; Some storage systems do not return "." and "..". - (let (result) - (dolist (item '(".." ".") result) - (when (string-prefix-p filename item) - (catch 'match - (dolist (elt completion-regexp-list) - (unless (string-match-p elt item) (throw 'match nil))) - (setq result (cons (concat item "/") result))))))))))) + (ignore-error file-missing + (all-completions + filename + (delete-dups + (append + (file-name-all-completions + filename (tramp-fuse-local-file-name directory)) + ;; Some storage systems do not return "." and "..". + (let (result) + (dolist (item '(".." ".") result) + (when (string-prefix-p filename item) + (catch 'match + (dolist (elt completion-regexp-list) + (unless (string-match-p elt item) (throw 'match nil))) + (setq result (cons (concat item "/") result)))))))))))) ;; This function isn't used. (defun tramp-fuse-handle-insert-directory diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index b9639c1e7f7..266724c587f 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -1418,16 +1418,19 @@ tramp-gvfs-handle-file-executable-p (defun tramp-gvfs-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." (unless (tramp-compat-string-search "/" filename) - (all-completions - filename - (with-parsed-tramp-file-name (expand-file-name directory) nil - (with-tramp-file-property v localname "file-name-all-completions" - (let ((result '("./" "../"))) - ;; Get a list of directories and files. - (dolist (item (tramp-gvfs-get-directory-attributes directory) result) - (if (string-equal (cdr (assoc "type" item)) "directory") - (push (file-name-as-directory (car item)) result) - (push (car item) result))))))))) + (ignore-error file-missing + (all-completions + filename + (with-parsed-tramp-file-name (expand-file-name directory) nil + (with-tramp-file-property v localname "file-name-all-completions" + (let ((result '("./" "../"))) + ;; Get a list of directories and files. + (dolist (item + (tramp-gvfs-get-directory-attributes directory) + result) + (if (string-equal (cdr (assoc "type" item)) "directory") + (push (file-name-as-directory (car item)) result) + (push (car item) result)))))))))) (defun tramp-gvfs-handle-file-notify-add-watch (file-name flags _callback) "Like `file-notify-add-watch' for Tramp files." diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 3ae5208154a..a854ff42b0d 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1767,41 +1767,43 @@ tramp-sh-handle-file-name-all-completions (with-parsed-tramp-file-name (expand-file-name directory) nil (when (and (not (tramp-compat-string-search "/" filename)) (tramp-connectable-p v)) - (all-completions - filename - (with-tramp-file-property v localname "file-name-all-completions" - (let (result) - ;; Get a list of directories and files, including reliably - ;; tagging the directories with a trailing "/". Because I - ;; rock. --daniel@danann.net - (when (tramp-send-command-and-check - v - (if (tramp-get-remote-perl v) - (progn - (tramp-maybe-send-script - v tramp-perl-file-name-all-completions - "tramp_perl_file_name_all_completions") - (format "tramp_perl_file_name_all_completions %s" - (tramp-shell-quote-argument localname))) - - (format (concat - "cd %s 2>&1 && %s -a 2>%s" - " | while IFS= read f; do" - " if %s -d \"$f\" 2>%s;" - " then \\echo \"$f/\"; else \\echo \"$f\"; fi;" - " done") - (tramp-shell-quote-argument localname) - (tramp-get-ls-command v) - (tramp-get-remote-null-device v) - (tramp-get-test-command v) - (tramp-get-remote-null-device v)))) - - ;; Now grab the output. - (with-current-buffer (tramp-get-buffer v) - (goto-char (point-max)) - (while (zerop (forward-line -1)) - (push (buffer-substring (point) (line-end-position)) result))) - result))))))) + (unless (tramp-compat-string-search "/" filename) + (ignore-error file-missing + (all-completions + filename + (with-tramp-file-property v localname "file-name-all-completions" + (let (result) + ;; Get a list of directories and files, including + ;; reliably tagging the directories with a trailing "/". + ;; Because I rock. --daniel@danann.net + (when (tramp-send-command-and-check + v + (if (tramp-get-remote-perl v) + (progn + (tramp-maybe-send-script + v tramp-perl-file-name-all-completions + "tramp_perl_file_name_all_completions") + (format "tramp_perl_file_name_all_completions %s" + (tramp-shell-quote-argument localname))) + + (format (concat + "cd %s 2>&1 && %s -a 2>%s" + " | while IFS= read f; do" + " if %s -d \"$f\" 2>%s;" + " then \\echo \"$f/\"; else \\echo \"$f\"; fi;" + " done") + (tramp-shell-quote-argument localname) + (tramp-get-ls-command v) + (tramp-get-remote-null-device v) + (tramp-get-test-command v) + (tramp-get-remote-null-device v)))) + + ;; Now grab the output. + (with-current-buffer (tramp-get-buffer v) + (goto-char (point-max)) + (while (zerop (forward-line -1)) + (push (buffer-substring (point) (line-end-position)) result))) + result))))))))) ;; cp, mv and ln diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 2a69465224f..1aa4520eeb6 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -976,18 +976,20 @@ tramp-smb-handle-file-local-copy ;; files. (defun tramp-smb-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (all-completions - filename - (with-parsed-tramp-file-name (expand-file-name directory) nil - (with-tramp-file-property v localname "file-name-all-completions" - (delete-dups - (mapcar - (lambda (x) - (list - (if (tramp-compat-string-search "d" (nth 1 x)) - (file-name-as-directory (nth 0 x)) - (nth 0 x)))) - (tramp-smb-get-file-entries directory))))))) + (ignore-error file-missing + (all-completions + filename + (when (file-directory-p directory) + (with-parsed-tramp-file-name (expand-file-name directory) nil + (with-tramp-file-property v localname "file-name-all-completions" + (delete-dups + (mapcar + (lambda (x) + (list + (if (tramp-compat-string-search "d" (nth 1 x)) + (file-name-as-directory (nth 0 x)) + (nth 0 x)))) + (tramp-smb-get-file-entries directory))))))))) (defun tramp-smb-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index fa1689d6851..abb9afc570b 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -460,26 +460,27 @@ tramp-sudoedit-handle-file-exists-p (defun tramp-sudoedit-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (all-completions - filename - (with-parsed-tramp-file-name (expand-file-name directory) nil - (with-tramp-file-property v localname "file-name-all-completions" - (tramp-sudoedit-send-command - v "ls" "-a1" "--quoting-style=literal" "--show-control-chars" - (if (tramp-string-empty-or-nil-p localname) - "" (file-name-unquote localname))) - (mapcar - (lambda (f) - (if (ignore-errors (file-directory-p (expand-file-name f directory))) - (file-name-as-directory f) - f)) - (delq - nil + (ignore-error file-missing + (all-completions + filename + (with-parsed-tramp-file-name (expand-file-name directory) nil + (with-tramp-file-property v localname "file-name-all-completions" + (tramp-sudoedit-send-command + v "ls" "-a1" "--quoting-style=literal" "--show-control-chars" + (if (tramp-string-empty-or-nil-p localname) + "" (file-name-unquote localname))) (mapcar - (lambda (l) (and (not (string-match-p (rx bol (* blank) eol) l)) l)) - (split-string - (tramp-get-buffer-string (tramp-get-connection-buffer v)) - "\n" 'omit)))))))) + (lambda (f) + (if (ignore-errors (file-directory-p (expand-file-name f directory))) + (file-name-as-directory f) + f)) + (delq + nil + (mapcar + (lambda (l) (and (not (string-match-p (rx bol (* blank) eol) l)) l)) + (split-string + (tramp-get-buffer-string (tramp-get-connection-buffer v)) + "\n" 'omit))))))))) (defun tramp-sudoedit-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." commit e87431eda0a73c15865deb554cdb3ba13b7767f6 Author: Eli Zaretskii Date: Sun Mar 12 17:43:40 2023 +0200 ; NEWS markings. diff --git a/etc/NEWS b/etc/NEWS index 662d2ad52b7..e31203689e3 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -248,9 +248,11 @@ following to you init file: An optional major mode based on the tree-sitter library for editing HTML files. +--- *** New major mode heex-ts-mode'. A major mode based on the tree-sitter library for editing HEEx files. +--- *** New major mode elixir-ts-mode'. A major mode based on the tree-sitter library for editing Elixir files. commit d965d030879d9ca4ef5098cb4e2e7c56128b904b Author: Wilhelm H Kirschbaum Date: Sun Mar 12 17:10:43 2023 +0200 Add elixir-ts-mode (Bug#61996) * etc/NEWS: Mention the new mode. * lisp/progmodes/elixir-ts-mode.el: New file. * test/lisp/progmodes/elixir-ts-mode-tests.el: New file. * test/lisp/progmodes/elixir-ts-mode-resources/indent.erts: New file. * admin/notes/tree-sitter/build-module/batch.sh: * admin/notes/tree-sitter/build-module/build.sh: Add Elixir support. * lisp/progmodes/eglot.el (eglot-server-programs): Add elixir-ts-mode. diff --git a/admin/notes/tree-sitter/build-module/batch.sh b/admin/notes/tree-sitter/build-module/batch.sh index 8b0072782e8..1d4076564dc 100755 --- a/admin/notes/tree-sitter/build-module/batch.sh +++ b/admin/notes/tree-sitter/build-module/batch.sh @@ -8,6 +8,7 @@ languages= 'css' 'c-sharp' 'dockerfile' + 'elixir' 'go' 'go-mod' 'heex' diff --git a/admin/notes/tree-sitter/build-module/build.sh b/admin/notes/tree-sitter/build-module/build.sh index 78ecfb5bc82..0832875168b 100755 --- a/admin/notes/tree-sitter/build-module/build.sh +++ b/admin/notes/tree-sitter/build-module/build.sh @@ -31,6 +31,9 @@ grammardir= "cmake") org="uyha" ;; + "elixir") + org="elixir-lang" + ;; "go-mod") # The parser is called "gomod". lang="gomod" diff --git a/etc/NEWS b/etc/NEWS index 682928afa8e..662d2ad52b7 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -251,6 +251,10 @@ HTML files. *** New major mode heex-ts-mode'. A major mode based on the tree-sitter library for editing HEEx files. +*** New major mode elixir-ts-mode'. +A major mode based on the tree-sitter library for editing Elixir +files. + --- ** The highly accessible Modus themes collection has six items. The 'modus-operandi' and 'modus-vivendi' are the main themes that have diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index 2f8d2002cd3..7b2341f3f49 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -221,7 +221,7 @@ eglot-server-programs ((java-mode java-ts-mode) . ("jdtls")) (dart-mode . ("dart" "language-server" "--client-id" "emacs.eglot-dart")) - (elixir-mode . ("language_server.sh")) + ((elixir-ts-mode elixir-mode) . ("language_server.sh")) (ada-mode . ("ada_language_server")) (scala-mode . ,(eglot-alternatives '("metals" "metals-emacs"))) diff --git a/lisp/progmodes/elixir-ts-mode.el b/lisp/progmodes/elixir-ts-mode.el new file mode 100644 index 00000000000..8adf647b081 --- /dev/null +++ b/lisp/progmodes/elixir-ts-mode.el @@ -0,0 +1,634 @@ +;;; elixir-ts-mode.el --- Major mode for Elixir with tree-sitter support -*- lexical-binding: t; -*- + +;; Copyright (C) 2022-2023 Free Software Foundation, Inc. + +;; Author: Wilhelm H Kirschbaum +;; Created: November 2022 +;; Keywords: elixir languages tree-sitter + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; This package provides `elixir-ts-mode' which is a major mode for editing +;; Elixir files and embedded HEEx templates that uses Tree Sitter to parse +;; the language. +;; +;; This package is compatible with and was tested against the tree-sitter grammar +;; for Elixir found at https://github.com/elixir-lang/tree-sitter-elixir. +;; +;; Features +;; +;; * Indent +;; +;; `elixir-ts-mode' tries to replicate the indentation provided by +;; mix format, but will come with some minor differences. +;; +;; * IMenu +;; * Navigation +;; * Which-fun + +;;; Code: + +(require 'treesit) +(require 'heex-ts-mode) +(eval-when-compile (require 'rx)) + +(declare-function treesit-parser-create "treesit.c") +(declare-function treesit-node-child "treesit.c") +(declare-function treesit-node-type "treesit.c") +(declare-function treesit-node-child-by-field-name "treesit.c") +(declare-function treesit-parser-language "treesit.c") +(declare-function treesit-parser-included-ranges "treesit.c") +(declare-function treesit-parser-list "treesit.c") +(declare-function treesit-node-parent "treesit.c") +(declare-function treesit-node-start "treesit.c") +(declare-function treesit-query-compile "treesit.c") +(declare-function treesit-node-eq "treesit.c") +(declare-function treesit-node-prev-sibling "treesit.c") + +(defgroup elixir-ts nil + "Major mode for editing Elixir code." + :prefix "elixir-ts-" + :group 'languages) + +(defcustom elixir-ts-indent-offset 2 + "Indentation of Elixir statements." + :version "30.1" + :type 'integer + :safe 'integerp + :group 'elixir-ts) + +(defface elixir-ts-font-comment-doc-identifier-face + '((t (:inherit font-lock-doc-face))) + "Face used for @comment.doc tags in Elixir files.") + +(defface elixir-ts-font-comment-doc-attribute-face + '((t (:inherit font-lock-doc-face))) + "Face used for @comment.doc.__attribute__ tags in Elixir files.") + +(defface elixir-ts-font-sigil-name-face + '((t (:inherit font-lock-string-face))) + "Face used for @__name__ tags in Elixir files.") + +(defconst elixir-ts--sexp-regexp + (rx bol + (or "call" "stab_clause" "binary_operator" "list" "tuple" "map" "pair" + "sigil" "string" "atom" "pair" "alias" "arguments" "atom" "identifier" + "boolean" "quoted_content") + eol)) + +(defconst elixir-ts--test-definition-keywords + '("describe" "test")) + +(defconst elixir-ts--definition-keywords + '("def" "defdelegate" "defexception" "defguard" "defguardp" + "defimpl" "defmacro" "defmacrop" "defmodule" "defn" "defnp" + "defoverridable" "defp" "defprotocol" "defstruct")) + +(defconst elixir-ts--definition-keywords-re + (concat "^" (regexp-opt elixir-ts--definition-keywords) "$")) + +(defconst elixir-ts--kernel-keywords + '("alias" "case" "cond" "else" "for" "if" "import" "quote" + "raise" "receive" "require" "reraise" "super" "throw" "try" + "unless" "unquote" "unquote_splicing" "use" "with")) + +(defconst elixir-ts--kernel-keywords-re + (concat "^" (regexp-opt elixir-ts--kernel-keywords) "$")) + +(defconst elixir-ts--builtin-keywords + '("__MODULE__" "__DIR__" "__ENV__" "__CALLER__" "__STACKTRACE__")) + +(defconst elixir-ts--builtin-keywords-re + (concat "^" (regexp-opt elixir-ts--builtin-keywords) "$")) + +(defconst elixir-ts--doc-keywords + '("moduledoc" "typedoc" "doc")) + +(defconst elixir-ts--doc-keywords-re + (concat "^" (regexp-opt elixir-ts--doc-keywords) "$")) + +(defconst elixir-ts--reserved-keywords + '("when" "and" "or" "not" "in" + "not in" "fn" "do" "end" "catch" "rescue" "after" "else")) + +(defconst elixir-ts--reserved-keywords-re + (concat "^" (regexp-opt elixir-ts--reserved-keywords) "$")) + +(defconst elixir-ts--reserved-keywords-vector + (apply #'vector elixir-ts--reserved-keywords)) + +(defvar elixir-ts--capture-anonymous-function-end + (when (treesit-available-p) + (treesit-query-compile 'elixir '((anonymous_function "end" @end))))) + +(defvar elixir-ts--capture-operator-parent + (when (treesit-available-p) + (treesit-query-compile 'elixir '((binary_operator operator: _ @val))))) + +(defvar elixir-ts--syntax-table + (let ((table (make-syntax-table))) + (modify-syntax-entry ?| "." table) + (modify-syntax-entry ?- "." table) + (modify-syntax-entry ?+ "." table) + (modify-syntax-entry ?* "." table) + (modify-syntax-entry ?/ "." table) + (modify-syntax-entry ?< "." table) + (modify-syntax-entry ?> "." table) + (modify-syntax-entry ?_ "_" table) + (modify-syntax-entry ?? "w" table) + (modify-syntax-entry ?~ "w" table) + (modify-syntax-entry ?! "_" table) + (modify-syntax-entry ?' "\"" table) + (modify-syntax-entry ?\" "\"" table) + (modify-syntax-entry ?# "<" table) + (modify-syntax-entry ?\n ">" table) + (modify-syntax-entry ?\( "()" table) + (modify-syntax-entry ?\) ")(" table) + (modify-syntax-entry ?\{ "(}" table) + (modify-syntax-entry ?\} "){" table) + (modify-syntax-entry ?\[ "(]" table) + (modify-syntax-entry ?\] ")[" table) + (modify-syntax-entry ?: "'" table) + (modify-syntax-entry ?@ "'" table) + table) + "Syntax table for `elixir-ts-mode'.") + +(defun elixir-ts--argument-indent-offset (node _parent &rest _) + "Return the argument offset position for NODE." + (if (treesit-node-prev-sibling node t) 0 elixir-ts-indent-offset)) + +(defun elixir-ts--argument-indent-anchor (node parent &rest _) + "Return the argument anchor position for NODE and PARENT." + (let ((first-sibling (treesit-node-child parent 0 t))) + (if (and first-sibling (not (treesit-node-eq first-sibling node))) + (treesit-node-start first-sibling) + (elixir-ts--parent-expression-start node parent)))) + +(defun elixir-ts--parent-expression-start (_node parent &rest _) + "Return the indentation expression start for NODE and PARENT." + ;; If the parent is the first expression on the line return the + ;; parent start of node position, otherwise use the parent call + ;; start if available. + (if (eq (treesit-node-start parent) + (save-excursion + (goto-char (treesit-node-start parent)) + (back-to-indentation) + (point))) + (treesit-node-start parent) + (let ((expr-parent + (treesit-parent-until + parent + (lambda (n) + (member (treesit-node-type n) + '("call" "binary_operator" "keywords" "list")))))) + (save-excursion + (goto-char (treesit-node-start expr-parent)) + (back-to-indentation) + (if (looking-at "|>") + (point) + (treesit-node-start expr-parent)))))) + +(defvar elixir-ts--indent-rules + (let ((offset elixir-ts-indent-offset)) + `((elixir + ((parent-is "^source$") column-0 0) + ((parent-is "^string$") parent-bol 0) + ((parent-is "^quoted_content$") + (lambda (_n parent bol &rest _) + (save-excursion + (back-to-indentation) + (if (bolp) + (progn + (goto-char (treesit-node-start parent)) + (back-to-indentation) + (point)) + (point)))) + 0) + ((node-is "^|>$") parent-bol 0) + ((node-is "^|$") parent-bol 0) + ((node-is "^]$") ,'elixir-ts--parent-expression-start 0) + ((node-is "^}$") ,'elixir-ts--parent-expression-start 0) + ((node-is "^)$") ,'elixir-ts--parent-expression-start 0) + ((node-is "^else_block$") grand-parent 0) + ((node-is "^catch_block$") grand-parent 0) + ((node-is "^rescue_block$") grand-parent 0) + ((node-is "^after_block$") grand-parent 0) + ((parent-is "^else_block$") parent ,offset) + ((parent-is "^catch_block$") parent ,offset) + ((parent-is "^rescue_block$") parent ,offset) + ((parent-is "^rescue_block$") parent ,offset) + ((parent-is "^after_block$") parent ,offset) + ((parent-is "^access_call$") + ,'elixir-ts--argument-indent-anchor + ,'elixir-ts--argument-indent-offset) + ((parent-is "^tuple$") + ,'elixir-ts--argument-indent-anchor + ,'elixir-ts--argument-indent-offset) + ((parent-is "^list$") + ,'elixir-ts--argument-indent-anchor + ,'elixir-ts--argument-indent-offset) + ((parent-is "^pair$") parent ,offset) + ((parent-is "^map_content$") parent-bol 0) + ((parent-is "^map$") ,'elixir-ts--parent-expression-start ,offset) + ((node-is "^stab_clause$") parent-bol ,offset) + ((query ,elixir-ts--capture-operator-parent) grand-parent 0) + ((node-is "^when$") parent 0) + ((node-is "^keywords$") parent-bol ,offset) + ((parent-is "^body$") + (lambda (node parent _) + (save-excursion + ;; The grammar adds a comment outside of the body, so we have to indent + ;; to the grand-parent if it is available. + (goto-char (treesit-node-start + (or (treesit-node-parent parent) (parent)))) + (back-to-indentation) + (point))) + ,offset) + ((parent-is "^arguments$") + ,'elixir-ts--argument-indent-anchor + ,'elixir-ts--argument-indent-offset) + ;; Handle incomplete maps when parent is ERROR. + ((n-p-gp "^binary_operator$" "ERROR" nil) parent-bol 0) + ;; When there is an ERROR, just indent to prev-line. + ((parent-is "ERROR") prev-line 0) + ((node-is "^binary_operator$") + (lambda (node parent &rest _) + (let ((top-level + (treesit-parent-while + node + (lambda (node) + (equal (treesit-node-type node) + "binary_operator"))))) + (if (treesit-node-eq top-level node) + (elixir-ts--parent-expression-start node parent) + (treesit-node-start top-level)))) + (lambda (node parent _) + (cond + ((equal (treesit-node-type parent) "do_block") + ,offset) + ((equal (treesit-node-type parent) "binary_operator") + ,offset) + (t 0)))) + ((parent-is "^binary_operator$") + (lambda (node parent bol &rest _) + (treesit-node-start + (treesit-parent-while + parent + (lambda (node) + (equal (treesit-node-type node) "binary_operator"))))) + ,offset) + ((node-is "^pair$") first-sibling 0) + ((query ,elixir-ts--capture-anonymous-function-end) parent-bol 0) + ((node-is "^end$") standalone-parent 0) + ((parent-is "^do_block$") grand-parent ,offset) + ((parent-is "^anonymous_function$") + elixir-ts--treesit-anchor-grand-parent-bol ,offset) + ((parent-is "^else_block$") parent ,offset) + ((parent-is "^rescue_block$") parent ,offset) + ((parent-is "^catch_block$") parent ,offset) + ((parent-is "^keywords$") parent-bol 0) + ((node-is "^call$") parent-bol ,offset) + ((node-is "^comment$") parent-bol ,offset))))) + +(defvar elixir-ts--font-lock-settings + (treesit-font-lock-rules + :language 'elixir + :feature 'elixir-comment + '((comment) @font-lock-comment-face) + + :language 'elixir + :feature 'elixir-string + :override t + '([(string) (charlist)] @font-lock-string-face) + + :language 'elixir + :feature 'elixir-string-interpolation + :override t + '((string + [ + quoted_end: _ @font-lock-string-face + quoted_start: _ @font-lock-string-face + (quoted_content) @font-lock-string-face + (interpolation + "#{" @font-lock-regexp-grouping-backslash "}" + @font-lock-regexp-grouping-backslash) + ]) + (charlist + [ + quoted_end: _ @font-lock-string-face + quoted_start: _ @font-lock-string-face + (quoted_content) @font-lock-string-face + (interpolation + "#{" @font-lock-regexp-grouping-backslash "}" + @font-lock-regexp-grouping-backslash) + ])) + + :language 'elixir + :feature 'elixir-keyword + `(,elixir-ts--reserved-keywords-vector + @font-lock-keyword-face + (binary_operator + operator: _ @font-lock-keyword-face + (:match ,elixir-ts--reserved-keywords-re @font-lock-keyword-face))) + + :language 'elixir + :feature 'elixir-doc + :override t + `((unary_operator + operator: "@" @elixir-ts-font-comment-doc-attribute-face + operand: (call + target: (identifier) @elixir-ts-font-comment-doc-identifier-face + ;; Arguments can be optional, so adding another + ;; entry without arguments. + ;; If we don't handle then we don't apply font + ;; and the non doc fortification query will take specify + ;; a more specific font which takes precedence. + (arguments + [ + (string) @font-lock-doc-face + (charlist) @font-lock-doc-face + (sigil) @font-lock-doc-face + (boolean) @font-lock-doc-face + ])) + (:match ,elixir-ts--doc-keywords-re + @elixir-ts-font-comment-doc-identifier-face)) + (unary_operator + operator: "@" @elixir-ts-font-comment-doc-attribute-face + operand: (call + target: (identifier) @elixir-ts-font-comment-doc-identifier-face) + (:match ,elixir-ts--doc-keywords-re + @elixir-ts-font-comment-doc-identifier-face))) + + :language 'elixir + :feature 'elixir-unary-operator + `((unary_operator operator: "@" @font-lock-preprocessor-face + operand: [ + (identifier) @font-lock-preprocessor-face + (call target: (identifier) + @font-lock-preprocessor-face) + (boolean) @font-lock-preprocessor-face + (nil) @font-lock-preprocessor-face + ]) + + (unary_operator operator: "&") @font-lock-function-name-face + (operator_identifier) @font-lock-operator-face) + + :language 'elixir + :feature 'elixir-operator + '((binary_operator operator: _ @font-lock-operator-face) + (dot operator: _ @font-lock-operator-face) + (stab_clause operator: _ @font-lock-operator-face) + + [(boolean) (nil)] @font-lock-constant-face + [(integer) (float)] @font-lock-number-face + (alias) @font-lock-type-face + (call target: (dot left: (atom) @font-lock-type-face)) + (char) @font-lock-constant-face + [(atom) (quoted_atom)] @font-lock-type-face + [(keyword) (quoted_keyword)] @font-lock-builtin-face) + + :language 'elixir + :feature 'elixir-call + `((call + target: (identifier) @font-lock-keyword-face + (:match ,elixir-ts--definition-keywords-re @font-lock-keyword-face)) + (call + target: (identifier) @font-lock-keyword-face + (:match ,elixir-ts--kernel-keywords-re @font-lock-keyword-face)) + (call + target: [(identifier) @font-lock-function-name-face + (dot right: (identifier) @font-lock-keyword-face)]) + (call + target: (identifier) @font-lock-keyword-face + (arguments + [ + (identifier) @font-lock-keyword-face + (binary_operator + left: (identifier) @font-lock-keyword-face + operator: "when") + ]) + (:match ,elixir-ts--definition-keywords-re @font-lock-keyword-face)) + (call + target: (identifier) @font-lock-keyword-face + (arguments + (binary_operator + operator: "|>" + right: (identifier))) + (:match ,elixir-ts--definition-keywords-re @font-lock-keyword-face))) + + :language 'elixir + :feature 'elixir-constant + `((binary_operator operator: "|>" right: (identifier) + @font-lock-function-name-face) + ((identifier) @font-lock-keyword-face + (:match ,elixir-ts--builtin-keywords-re + @font-lock-keyword-face)) + ((identifier) @font-lock-comment-face + (:match "^_" @font-lock-comment-face)) + (identifier) @font-lock-function-name-face + ["%"] @font-lock-keyward-face + ["," ";"] @font-lock-keyword-face + ["(" ")" "[" "]" "{" "}" "<<" ">>"] @font-lock-keyword-face) + + :language 'elixir + :feature 'elixir-sigil + :override t + `((sigil + (sigil_name) @elixir-ts-font-sigil-name-face + quoted_start: _ @font-lock-string-face + quoted_end: _ @font-lock-string-face + (:match "^[sSwWpP]$" @elixir-ts-font-sigil-name-face)) + @font-lock-string-face + (sigil + (sigil_name) @elixir-ts-font-sigil-name-face + quoted_start: _ @font-lock-regex-face + quoted_end: _ @font-lock-regex-face + (:match "^[rR]$" @elixir-ts-font-sigil-name-face)) + @font-lock-regex-face + (sigil + "~" @font-lock-string-face + (sigil_name) @elixir-ts-font-sigil-name-face + quoted_start: _ @font-lock-string-face + quoted_end: _ @font-lock-string-face + (:match "^[HF]$" @elixir-ts-font-sigil-name-face))) + + :language 'elixir + :feature 'elixir-string-escape + :override t + `((escape_sequence) @font-lock-regexp-grouping-backslash)) + "Tree-sitter font-lock settings.") + +(defvar elixir-ts--treesit-range-rules + (when (treesit-available-p) + (treesit-range-rules + :embed 'heex + :host 'elixir + '((sigil (sigil_name) @name (:match "^[HF]$" @name) (quoted_content) @heex))))) + +(defun elixir-ts--forward-sexp (&optional arg) + "Move forward across one balanced expression (sexp). +With ARG, do it many times. Negative ARG means move backward." + (or arg (setq arg 1)) + (funcall + (if (> arg 0) #'treesit-end-of-thing #'treesit-beginning-of-thing) + (if (eq (treesit-language-at (point)) 'heex) + heex-ts--sexp-regexp + elixir-ts--sexp-regexp) + (abs arg))) + +(defun elixir-ts--treesit-anchor-grand-parent-bol (_n parent &rest _) + "Return the beginning of non-space characters for the parent node of PARENT." + (save-excursion + (goto-char (treesit-node-start (treesit-node-parent parent))) + (back-to-indentation) + (point))) + +(defun elixir-ts--treesit-language-at-point (point) + "Return the language at POINT." + (let* ((range nil) + (language-in-range + (cl-loop + for parser in (treesit-parser-list) + do (setq range + (cl-loop + for range in (treesit-parser-included-ranges parser) + if (and (>= point (car range)) (<= point (cdr range))) + return parser)) + if range + return (treesit-parser-language parser)))) + (if (null language-in-range) + (when-let ((parser (car (treesit-parser-list)))) + (treesit-parser-language parser)) + language-in-range))) + +(defun elixir-ts--defun-p (node) + "Return non-nil when NODE is a defun." + (member (treesit-node-text + (treesit-node-child-by-field-name node "target")) + (append + elixir-ts--definition-keywords + elixir-ts--test-definition-keywords))) + +(defun elixir-ts--defun-name (node) + "Return the name of the defun NODE. +Return nil if NODE is not a defun node or doesn't have a name." + (pcase (treesit-node-type node) + ("call" (let ((node-child + (treesit-node-child (treesit-node-child node 1) 0))) + (pcase (treesit-node-type node-child) + ("alias" (treesit-node-text node-child t)) + ("call" (treesit-node-text + (treesit-node-child-by-field-name node-child "target") t)) + ("binary_operator" + (treesit-node-text + (treesit-node-child-by-field-name + (treesit-node-child-by-field-name node-child "left") "target") + t)) + ("identifier" + (treesit-node-text node-child t)) + (_ nil)))) + (_ nil))) + +;;;###autoload +(define-derived-mode elixir-ts-mode prog-mode "Elixir" + "Major mode for editing Elixir, powered by tree-sitter." + :group 'elixir-ts + :syntax-table elixir-ts--syntax-table + + ;; Comments + (setq-local comment-start "# ") + (setq-local comment-start-skip + (rx "#" (* (syntax whitespace)))) + + (setq-local comment-end "") + (setq-local comment-end-skip + (rx (* (syntax whitespace)) + (group (or (syntax comment-end) "\n")))) + + ;; Compile + (setq-local compile-command "mix") + + (when (treesit-ready-p 'elixir) + ;; The HEEx parser has to be created first for elixir to ensure elixir + ;; is the first language when looking for treesit ranges. + (if (treesit-ready-p 'heex) + (treesit-parser-create 'heex)) + + (treesit-parser-create 'elixir) + + (setq-local treesit-language-at-point-function + 'elixir-ts--treesit-language-at-point) + + ;; Font-lock. + (setq-local treesit-font-lock-settings elixir-ts--font-lock-settings) + (setq-local treesit-font-lock-feature-list + '(( elixir-comment elixir-constant elixir-doc ) + ( elixir-string elixir-keyword elixir-unary-operator + elixir-call elixir-operator ) + ( elixir-sigil elixir-string-escape elixir-string-interpolation))) + + ;; Imenu. + (setq-local treesit-simple-imenu-settings + '((nil "\\`call\\'" elixir-ts--defun-p nil))) + + ;; Indent. + (setq-local treesit-simple-indent-rules elixir-ts--indent-rules) + + ;; Navigation + (setq-local forward-sexp-function #'elixir-ts--forward-sexp) + (setq-local treesit-defun-type-regexp + '("call" . elixir-ts--defun-p)) + + (setq-local treesit-defun-name-function #'elixir-ts--defun-name) + + ;; Embedded Heex + (when (treesit-ready-p 'heex) + (setq-local treesit-range-settings elixir-ts--treesit-range-rules) + + (setq-local treesit-simple-indent-rules + (append treesit-simple-indent-rules heex-ts--indent-rules)) + + (setq-local treesit-font-lock-settings + (append treesit-font-lock-settings + heex-ts--font-lock-settings)) + + (setq-local treesit-simple-indent-rules + (append treesit-simple-indent-rules + heex-ts--indent-rules)) + + (setq-local treesit-font-lock-feature-list + '(( elixir-comment elixir-constant elixir-doc + heex-comment heex-keyword heex-doctype ) + ( elixir-string elixir-keyword elixir-unary-operator + elixir-call elixir-operator + heex-component heex-tag heex-attribute heex-string) + ( elixir-sigil elixir-string-escape + elixir-string-interpolation )))) + + (treesit-major-mode-setup))) + +(if (treesit-ready-p 'elixir) + (progn + (add-to-list 'auto-mode-alist '("\\.elixir\\'" . elixir-ts-mode)) + (add-to-list 'auto-mode-alist '("\\.ex\\'" . elixir-ts-mode)) + (add-to-list 'auto-mode-alist '("\\.exs\\'" . elixir-ts-mode)) + (add-to-list 'auto-mode-alist '("mix\\.lock" . elixir-ts-mode)))) + +(provide 'elixir-ts-mode) + +;;; elixir-ts-mode.el ends here diff --git a/test/lisp/progmodes/elixir-ts-mode-resources/indent.erts b/test/lisp/progmodes/elixir-ts-mode-resources/indent.erts new file mode 100644 index 00000000000..748455cc3f2 --- /dev/null +++ b/test/lisp/progmodes/elixir-ts-mode-resources/indent.erts @@ -0,0 +1,308 @@ +Code: + (lambda () + (setq indent-tabs-mode nil) + (elixir-ts-mode) + (indent-region (point-min) (point-max))) + +Point-Char: $ + +Name: Basic modules + +=-= + defmodule Foobar do +def bar() do +"one" + end + end +=-= +defmodule Foobar do + def bar() do + "one" + end +end +=-=-= + +Name: Map + +=-= +map = %{ + "a" => 1, + "b" => 2 +} +=-=-= + +Name: Map in function def + +=-= +def foobar() do + %{ + one: "one", + two: "two", + three: "three", + four: "four" + } +end +=-=-= + +Name: Map in tuple + +=-= +def foo() do + {:ok, + %{ + state + | extra_arguments: extra_arguments, + max_children: max_children, + max_restarts: max_restarts, + max_seconds: max_seconds, + strategy: strategy + }} +end +=-=-= + +Name: Nested maps + +=-= +%{ + foo: "bar", + bar: %{ + foo: "bar" + } +} + +def foo() do + %{ + foo: "bar", + bar: %{ + foo: "bar" + } + } +end +=-=-= + +Name: Block assignments + +=-= +foo = + if true do + "yes" + else + "no" + end +=-=-= + +Name: Function rescue + +=-= +def foo do + "bar" +rescue + e -> + "bar" +end +=-=-= + +Name: With statement +=-= +with one <- one(), + two <- two(), + {:ok, value} <- get_value(one, two) do + {:ok, value} +else + {:error, %{"Message" => message}} -> + {:error, message} +end +=-=-= + +Name: Pipe statements with fn + +=-= +[1, 2] +|> Enum.map(fn num -> + num + 1 +end) +=-=-= + +Name: Pipe statements stab clases + +=-= +[1, 2] +|> Enum.map(fn + x when x < 10 -> x * 2 + x -> x * 3 +end) +=-=-= + +Name: Pipe statements params + +=-= +[1, 2] +|> foobar( + :one, + :two, + :three, + :four +) +=-=-= + +Name: Parameter maps + +=-= +def something(%{ + one: :one, + two: :two + }) do + {:ok, "done"} +end +=-=-= + +Name: Binary operator in else block + +=-= +defp foobar() do + if false do + :foo + else + :bar |> foo + end +end +=-=-= + +Name: Tuple indentation + +=-= +tuple = { + :one, + :two +} + +{ + :one, + :two +} +=-=-= + +Name: Spec and method + +=-= +@spec foobar( + t, + acc, + (one, something -> :bar | far), + (two -> :bar | far) + ) :: any() + when chunk: any +def foobar(enumerable, acc, chunk_fun, after_fun) do + {_, {res, acc}} = + case after_fun.(acc) do + {:one, "one"} -> + "one" + + {:two, "two"} -> + "two" + end +end +=-=-= + +Name: Spec with multi-line result + +=-= +@type result :: + {:done, term} + | {:two} + | {:one} + +@type result :: + { + :done, + term + } + | {:two} + | {:one} + +@type boo_bar :: + (foo :: pos_integer, bar :: pos_integer -> any()) + +@spec foo_bar( + t, + (foo -> any), + (() -> any) | (foo, foo -> boolean) | module() + ) :: any + when foo: any +def foo(one, fun, other) +=-=-= + +Name: String concatenation in call + +=-= +IO.warn( + "one" <> + "two" <> + "bar" +) + +IO.warn( + "foo" <> + "bar" +) +=-=-= + +Name: Incomplete tuple + +=-= +map = { +:foo + +=-= +map = { + :foo + +=-=-= + +Name: Incomplete map + +=-= +map = %{ + "a" => "a", +=-=-= + +Name: Incomplete list + +=-= +map = [ +:foo + +=-= +map = [ + :foo + +=-=-= + +Name: String concatenation + +=-= +"one" <> + "two" <> + "three" <> + "four" +=-=-= + +Name: Tuple with same line first node + +=-= +{:one, + :two} + +{:ok, + fn one -> + one + |> String.upcase(one) + end} +=-=-= + +Name: Long tuple + +=-= +{"January", "February", "March", "April", "May", "June", "July", "August", "September", + "October", "November", "December"} +=-=-= diff --git a/test/lisp/progmodes/elixir-ts-mode-tests.el b/test/lisp/progmodes/elixir-ts-mode-tests.el new file mode 100644 index 00000000000..8e546ad5cc6 --- /dev/null +++ b/test/lisp/progmodes/elixir-ts-mode-tests.el @@ -0,0 +1,31 @@ +;;; c-ts-mode-tests.el --- Tests for Tree-sitter-based C mode -*- lexical-binding: t; -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'ert-x) +(require 'treesit) + +(ert-deftest elixir-ts-mode-test-indentation () + (skip-unless (and (treesit-ready-p 'elixir) (treesit-ready-p 'heex))) + (ert-test-erts-file (ert-resource-file "indent.erts"))) + +(provide 'elixir-ts-mode-tests) +;;; elixir-ts-mode-tests.el ends here commit 802e64922bcee40c8362b9627aa33a0de0c068d7 Author: Wilhelm H Kirschbaum Date: Sun Mar 12 17:08:50 2023 +0200 Add heex-ts-mode (Bug#61996) * etc/NEWS: Mention the new mode. * lisp/progmodes/heex-ts-mode.el: New file. * test/lisp/progmodes/heex-ts-mode-tests.el: New file. * test/lisp/progmodes/heex-ts-mode-resources/indent.erts: New file. * admin/notes/tree-sitter/build-module/batch.sh: * admin/notes/tree-sitter/build-module/build.sh: Add HEEx support. diff --git a/admin/notes/tree-sitter/build-module/batch.sh b/admin/notes/tree-sitter/build-module/batch.sh index 58272c74549..8b0072782e8 100755 --- a/admin/notes/tree-sitter/build-module/batch.sh +++ b/admin/notes/tree-sitter/build-module/batch.sh @@ -10,6 +10,7 @@ languages= 'dockerfile' 'go' 'go-mod' + 'heex' 'html' 'javascript' 'json' diff --git a/admin/notes/tree-sitter/build-module/build.sh b/admin/notes/tree-sitter/build-module/build.sh index 9dc674237ca..78ecfb5bc82 100755 --- a/admin/notes/tree-sitter/build-module/build.sh +++ b/admin/notes/tree-sitter/build-module/build.sh @@ -36,6 +36,9 @@ grammardir= lang="gomod" org="camdencheek" ;; + "heex") + org="phoenixframework" + ;; "typescript") sourcedir="tree-sitter-typescript/typescript/src" grammardir="tree-sitter-typescript/typescript" diff --git a/etc/NEWS b/etc/NEWS index e43aac614c9..682928afa8e 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -248,6 +248,9 @@ following to you init file: An optional major mode based on the tree-sitter library for editing HTML files. +*** New major mode heex-ts-mode'. +A major mode based on the tree-sitter library for editing HEEx files. + --- ** The highly accessible Modus themes collection has six items. The 'modus-operandi' and 'modus-vivendi' are the main themes that have diff --git a/lisp/progmodes/heex-ts-mode.el b/lisp/progmodes/heex-ts-mode.el new file mode 100644 index 00000000000..68a537b9229 --- /dev/null +++ b/lisp/progmodes/heex-ts-mode.el @@ -0,0 +1,185 @@ +;;; heex-ts-mode.el --- Major mode for Heex with tree-sitter support -*- lexical-binding: t; -*- + +;; Copyright (C) 2022-2023 Free Software Foundation, Inc. + +;; Author: Wilhelm H Kirschbaum +;; Created: November 2022 +;; Keywords: elixir languages tree-sitter + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; This package provides `heex-ts-mode' which is a major mode for editing +;; HEEx files that uses Tree Sitter to parse the language. +;; +;; This package is compatible with and was tested against the tree-sitter grammar +;; for HEEx found at https://github.com/phoenixframework/tree-sitter-heex. + +;;; Code: + +(require 'treesit) +(eval-when-compile (require 'rx)) + +(declare-function treesit-parser-create "treesit.c") +(declare-function treesit-node-child "treesit.c") +(declare-function treesit-node-type "treesit.c") +(declare-function treesit-node-start "treesit.c") + +(defgroup heex-ts nil + "Major mode for editing HEEx code." + :prefix "heex-ts-" + :group 'langauges) + +(defcustom heex-ts-indent-offset 2 + "Indentation of HEEx statements." + :version "30.1" + :type 'integer + :safe 'integerp + :group 'heex-ts) + +(defconst heex-ts--sexp-regexp + (rx bol + (or "directive" "tag" "component" "slot" + "attribute" "attribute_value" "quoted_attribute_value") + eol)) + +;; There seems to be no parent directive block for tree-sitter-heex, +;; so we ignore them for now until we learn how to query them. +;; https://github.com/phoenixframework/tree-sitter-heex/issues/28 +(defvar heex-ts--indent-rules + (let ((offset heex-ts-indent-offset)) + `((heex + ((parent-is "fragment") + (lambda (node parent &rest _) + ;; If HEEx is embedded indent to parent + ;; otherwise indent to the bol. + (if (eq (treesit-language-at (point-min)) 'heex) + (point-min) + (save-excursion + (goto-char (treesit-node-start parent)) + (back-to-indentation) + (point)) + )) 0) + ((node-is "end_tag") parent-bol 0) + ((node-is "end_component") parent-bol 0) + ((node-is "end_slot") parent-bol 0) + ((node-is "/>") parent-bol 0) + ((node-is ">") parent-bol 0) + ((parent-is "comment") prev-adaptive-prefix 0) + ((parent-is "component") parent-bol ,offset) + ((parent-is "tag") parent-bol ,offset) + ((parent-is "start_tag") parent-bol ,offset) + ((parent-is "component") parent-bol ,offset) + ((parent-is "start_component") parent-bol ,offset) + ((parent-is "slot") parent-bol ,offset) + ((parent-is "start_slot") parent-bol ,offset) + ((parent-is "self_closing_tag") parent-bol ,offset) + (no-node parent-bol ,offset))))) + +(defvar heex-ts--font-lock-settings + (when (treesit-available-p) + (treesit-font-lock-rules + :language 'heex + :feature 'heex-comment + '((comment) @font-lock-comment-face) + :language 'heex + :feature 'heex-doctype + '((doctype) @font-lock-doc-face) + :language 'heex + :feature 'heex-tag + `([(tag_name) (slot_name)] @font-lock-function-name-face) + :language 'heex + :feature 'heex-attribute + `((attribute_name) @font-lock-variable-name-face) + :language 'heex + :feature 'heex-keyword + `((special_attribute_name) @font-lock-keyword-face) + :language 'heex + :feature 'heex-string + `([(attribute_value) (quoted_attribute_value)] @font-lock-constant-face) + :language 'heex + :feature 'heex-component + `([ + (component_name) @font-lock-function-name-face + (module) @font-lock-keyword-face + (function) @font-lock-keyword-face + "." @font-lock-keyword-face + ]))) + "Tree-sitter font-lock settings.") + +(defun heex-ts--defun-name (node) + "Return the name of the defun NODE. +Return nil if NODE is not a defun node or doesn't have a name." + (pcase (treesit-node-type node) + ((or "component" "slot" "tag") + (string-trim + (treesit-node-text + (treesit-node-child (treesit-node-child node 0) 1) nil))) + (_ nil))) + +(defun heex-ts--forward-sexp (&optional arg) + "Move forward across one balanced expression (sexp). +With ARG, do it many times. Negative ARG means move backward." + (or arg (setq arg 1)) + (funcall + (if (> arg 0) #'treesit-end-of-thing #'treesit-beginning-of-thing) + heex-ts--sexp-regexp + (abs arg))) + +;;;###autoload +(define-derived-mode heex-ts-mode html-mode "HEEx" + "Major mode for editing HEEx, powered by tree-sitter." + :group 'heex-ts + + (when (treesit-ready-p 'heex) + (treesit-parser-create 'heex) + + ;; Comments + (setq-local treesit-text-type-regexp + (regexp-opt '("comment" "text"))) + + (setq-local forward-sexp-function #'heex-ts--forward-sexp) + + ;; Navigation. + (setq-local treesit-defun-type-regexp + (rx bol (or "component" "tag" "slot") eol)) + (setq-local treesit-defun-name-function #'heex-ts--defun-name) + + ;; Imenu + (setq-local treesit-simple-imenu-settings + '(("Component" "\\`component\\'" nil nil) + ("Slot" "\\`slot\\'" nil nil) + ("Tag" "\\`tag\\'" nil nil))) + + (setq-local treesit-font-lock-settings heex-ts--font-lock-settings) + + (setq-local treesit-simple-indent-rules heex-ts--indent-rules) + + (setq-local treesit-font-lock-feature-list + '(( heex-comment heex-keyword heex-doctype ) + ( heex-component heex-tag heex-attribute heex-string ) + () ())) + + (treesit-major-mode-setup))) + +(if (treesit-ready-p 'heex) + ;; Both .heex and the deprecated .leex files should work + ;; with the tree-sitter-heex grammar. + (add-to-list 'auto-mode-alist '("\\.[hl]?eex\\'" . heex-ts-mode))) + +(provide 'heex-ts-mode) +;;; heex-ts-mode.el ends here diff --git a/test/lisp/progmodes/heex-ts-mode-resources/indent.erts b/test/lisp/progmodes/heex-ts-mode-resources/indent.erts new file mode 100644 index 00000000000..500ddb2b536 --- /dev/null +++ b/test/lisp/progmodes/heex-ts-mode-resources/indent.erts @@ -0,0 +1,47 @@ +Code: + (lambda () + (setq indent-tabs-mode nil) + (heex-ts-mode) + (indent-region (point-min) (point-max))) + +Point-Char: $ + +Name: Tag + +=-= +
+ div +
+=-= +
+ div +
+=-=-= + +Name: Component + +=-= + + foobar + +=-= + + foobar + +=-=-= + +Name: Slots + +=-= + + <:bar> + foobar + + +=-= + + <:bar> + foobar + + +=-=-= diff --git a/test/lisp/progmodes/heex-ts-mode-tests.el b/test/lisp/progmodes/heex-ts-mode-tests.el new file mode 100644 index 00000000000..b59126e136a --- /dev/null +++ b/test/lisp/progmodes/heex-ts-mode-tests.el @@ -0,0 +1,9 @@ +(require 'ert) +(require 'ert-x) +(require 'treesit) + +(ert-deftest heex-ts-mode-test-indentation () + (skip-unless (treesit-ready-p 'heex)) + (ert-test-erts-file (ert-resource-file "indent.erts"))) + +(provide 'heex-ts-mode-tests) commit d19416d15c29368112fba9a7437930abcec9af3b Author: Daniel Martín Date: Sun Mar 12 13:38:34 2023 +0100 Fix pluralization in shortdoc-help-fns-examples-function * lisp/emacs-lisp/shortdoc.el (shortdoc-help-fns-examples-function): Implement a better logic to pluralize "Example", by counting the number of arrow characters in the example string. (Bug#61877) * test/lisp/emacs-lisp/shortdoc-tests.el (shortdoc-help-fns-examples-function-test): Add a test. diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 6e3ebc7c6a2..9a6f5dd12ce 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -1621,13 +1621,38 @@ shortdoc-help-fns-examples-function You can add this function to the `help-fns-describe-function-functions' hook to show examples of using FUNCTION in *Help* buffers produced by \\[describe-function]." - (let ((examples (shortdoc-function-examples function)) - (times 0)) + (let* ((examples (shortdoc-function-examples function)) + (num-examples (length examples)) + (times 0)) (dolist (example examples) (when (zerop times) - (if (eq (length examples) 1) - (insert "\n Example:\n\n") - (insert "\n Examples:\n\n"))) + (if (> num-examples 1) + (insert "\n Examples:\n\n") + ;; Some functions have more than one example per group. + ;; Count the number of arrows to know if we need to + ;; pluralize "Example". + (let* ((text (cdr example)) + (count 0) + (pos 0) + (end (length text)) + (double-arrow (if (char-displayable-p ?⇒) + " ⇒" + " =>")) + (double-arrow-example (if (char-displayable-p ?⇒) + " e.g. ⇒" + " e.g. =>")) + (single-arrow (if (char-displayable-p ?→) + " →" + " ->"))) + (while (and (< pos end) + (or (string-match double-arrow text pos) + (string-match double-arrow-example text pos) + (string-match single-arrow text pos))) + (setq count (1+ count) + pos (match-end 0))) + (if (> count 1) + (insert "\n Examples:\n\n") + (insert "\n Example:\n\n"))))) (setq times (1+ times)) (insert " ") (insert (cdr example)) diff --git a/test/lisp/emacs-lisp/shortdoc-tests.el b/test/lisp/emacs-lisp/shortdoc-tests.el index a65a4a5ddc3..d2dfbc66864 100644 --- a/test/lisp/emacs-lisp/shortdoc-tests.el +++ b/test/lisp/emacs-lisp/shortdoc-tests.el @@ -75,6 +75,21 @@ shortdoc-function-examples-test (should (equal '((regexp . "(string-match-p \"^[fo]+\" \"foobar\")\n => 0")) (shortdoc-function-examples 'string-match-p)))) +(ert-deftest shortdoc-help-fns-examples-function-test () + "Test that `shortdoc-help-fns-examples-function' correctly prints ELisp function examples." + (with-temp-buffer + (shortdoc-help-fns-examples-function 'string-fill) + (should (equal "\n Examples:\n\n (string-fill \"Three short words\" 12)\n => \"Three short\\nwords\"\n (string-fill \"Long-word\" 3)\n => \"Long-word\"\n\n" + (buffer-substring-no-properties (point-min) (point-max)))) + (erase-buffer) + (shortdoc-help-fns-examples-function 'assq) + (should (equal "\n Examples:\n\n (assq 'foo '((foo . bar) (zot . baz)))\n => (foo . bar)\n\n (assq 'b '((a . 1) (b . 2)))\n => (b . 2)\n\n" + (buffer-substring-no-properties (point-min) (point-max)))) + (erase-buffer) + (shortdoc-help-fns-examples-function 'string-trim) + (should (equal "\n Example:\n\n (string-trim \" foo \")\n => \"foo\"\n\n" + (buffer-substring-no-properties (point-min) (point-max)))))) + (provide 'shortdoc-tests) ;;; shortdoc-tests.el ends here commit 9191fd50d242cde5256b876dd756ffbc6f46db90 Author: Eli Zaretskii Date: Sun Mar 12 10:25:10 2023 +0200 ; Fix last change * lisp/emacs-lisp/shortdoc.el (shortdoc-help-fns-examples-function) (shortdoc-function-examples): Fix compilation warning and add an empty line before the examples. * lisp/emacs-lisp/shortdoc.el (shortdoc--insert-group-in-buffer) (shortdoc-function-examples) (shortdoc-help-fns-examples-function): * etc/NEWS: * doc/lispref/help.texi (Documentation Groups): * doc/emacs/help.texi (Name Help): Improve documentation of the last change. (Bug#61877) diff --git a/doc/emacs/help.texi b/doc/emacs/help.texi index 10c007eb635..945e12a05d2 100644 --- a/doc/emacs/help.texi +++ b/doc/emacs/help.texi @@ -316,10 +316,11 @@ Name Help by using the @kbd{M-x shortdoc} command. This will prompt you for an area of interest, e.g., @code{string}, and pop you to a buffer where many of the functions relevant for handling strings are listed. -Here's an example you can include in your initialization file -(@pxref{Init File}) that uses @code{shortdoc} to insert Emacs Lisp -function examples into regular @file{*Help*} buffers when you use -@kbd{C-h f}: + +You can also request that documentation of functions and commands +shown in @file{*Help*} buffers popped by @kbd{C-h f} includes examples +of their use. To that end, add the following to your initialization +file (@pxref{Init File}): @example (add-hook 'help-fns-describe-function-functions diff --git a/doc/lispref/help.texi b/doc/lispref/help.texi index 3175f66122e..d5e4e1c31d3 100644 --- a/doc/lispref/help.texi +++ b/doc/lispref/help.texi @@ -995,23 +995,23 @@ Documentation Groups @defun shortdoc-function-examples function This function returns all shortdoc examples for @var{function}. The -result is an alist with items of the form - -@example -(@var{group} . @var{examples}) -@end example - -@noindent -where @var{group} is a documentation group where @var{function} -appears in and @var{examples} is a string with the examples of use of -@var{function} defined in @var{group}. +return value is an alist with items of the form +@w{@code{(@var{group} . @var{examples})}}, where @var{group} is a +documentation group where @var{function} appears, and @var{examples} +is a string with the examples of @var{function}s use as defined in +@var{group}. @code{shortdoc-function-examples} returns @code{nil} if @var{function} -is not a function or if it doesn’t contain shortdoc information. +is not a function or if it doesn't have any shortdoc examples. @end defun +@vindex help-fns-describe-function-functions @defun shortdoc-help-fns-examples-function function -This function queries the registered documentation groups and inserts -examples of use of a given Emacs Lisp function into the current -buffer. +This function queries the registered shortdoc groups and inserts +examples of use of a given Emacs Lisp @var{function} into the current +buffer. It is suitable for addition to the +@code{help-fns-describe-function-functions} hook, in which case +examples from shortdoc of using a function will be displayed in the +@file{*Help*} buffer when the documentation of the function is +requested. @end defun diff --git a/etc/NEWS b/etc/NEWS index 5f51b801774..e43aac614c9 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -224,15 +224,15 @@ This replaces 'doc-view-svg-foreground' and 'doc-view-svg-background'. +++ *** New function 'shortdoc-function-examples'. -This function queries the registered documentation groups and returns -examples of use of a given Emacs Lisp function. +This function returns examples of use of a given Emacs Lisp function +from the available shortdoc information. +++ *** New function 'shortdoc-help-fns-examples-function'. -This function queries the registered documentation groups and inserts -examples of use of a given Emacs Lisp function into the current -buffer. If you want to insert Emacs Lisp function examples into -regular *Help* buffers when you use 'describe-function', add the +This function inserts into the current buffer examples of use of a +given Emacs Lisp function, which it gleans from the shortdoc +information. If you want 'describe-function' ('C-h f') to insert +examples of using the function into regular *Help* buffers, add the following to you init file: (add-hook 'help-fns-describe-function-functions diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index cf66a43fc35..6e3ebc7c6a2 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -1455,7 +1455,8 @@ shortdoc-display-group (beginning-of-line))) (defun shortdoc--insert-group-in-buffer (group &optional buf) - "Insert a short documentation summary for functions in GROUP in buffer BUF." + "Insert a short documentation summary for functions in GROUP in buffer BUF. +BUF defaults to the current buffer if nil or omitted." (with-current-buffer (or buf (current-buffer)) (let ((inhibit-read-only t) (prev nil)) @@ -1593,10 +1594,10 @@ shortdoc--display-function (defun shortdoc-function-examples (function) "Return all shortdoc examples for FUNCTION. The result is an alist with items of the form (GROUP . EXAMPLES), -where GROUP is a shortdoc group where FUNCTION appears in and +where GROUP is a shortdoc group where FUNCTION appears, and EXAMPLES is a string with the usage examples of FUNCTION defined in GROUP. Return nil if FUNCTION is not a function or if it -doesn't contain shortdoc information." +doesn't has any shortdoc information." (let ((groups (and (symbolp function) (shortdoc-function-groups function))) (examples nil)) @@ -1605,28 +1606,28 @@ shortdoc-function-examples (with-temp-buffer (shortdoc--insert-group-in-buffer group) (goto-char (point-min)) - (setq match (text-property-search-forward - 'shortdoc-example function t)) - (push `(,group . ,(string-trim - (buffer-substring-no-properties - (prop-match-beginning match) - (prop-match-end match)))) - examples))) + (let ((match (text-property-search-forward + 'shortdoc-example function t))) + (push `(,group . ,(string-trim + (buffer-substring-no-properties + (prop-match-beginning match) + (prop-match-end match)))) + examples)))) groups) examples)) (defun shortdoc-help-fns-examples-function (function) "Insert Emacs Lisp examples for FUNCTION into the current buffer. -You can add this function to the -`help-fns-describe-function-functions' list to show function -example documentation in *Help* buffers." +You can add this function to the `help-fns-describe-function-functions' +hook to show examples of using FUNCTION in *Help* buffers produced +by \\[describe-function]." (let ((examples (shortdoc-function-examples function)) (times 0)) (dolist (example examples) (when (zerop times) (if (eq (length examples) 1) - (insert " Example:\n\n") - (insert " Examples:\n\n"))) + (insert "\n Example:\n\n") + (insert "\n Examples:\n\n"))) (setq times (1+ times)) (insert " ") (insert (cdr example)) commit 29227e7c19100bed30b3410b399ee6a2c1ca7213 Author: Daniel Martín Date: Tue Feb 28 23:15:40 2023 +0100 Add functions to query Emacs Lisp examples registered in shortdoc * lisp/emacs-lisp/shortdoc.el (shortdoc--display-function): Add a new shortdoc-example text property so that ELisp examples can be searched for later. (shortdoc--insert-group-in-buffer): New function extracted from the buffer insertion code in 'shortdoc-display-group'. (shortdoc-display-group): Implement in terms of 'shortdoc--insert-group-in-buffer'. (shortdoc-function-examples): New function that returns an alist of Emacs Lisp examples from shortdoc. (shortdoc-help-fns-examples-function): New function to insert Emacs Lisp function examples in *Help* buffers, if added to 'help-fns-describe-function-functions'. * test/lisp/emacs-lisp/shortdoc-tests.el (shortdoc-function-examples-test): Test it. * doc/emacs/help.texi (Name Help): Document in the user manual. * doc/lispref/help.texi (Documentation Groups): Document it. * etc/NEWS: Advertise it. (Bug#61877) diff --git a/doc/emacs/help.texi b/doc/emacs/help.texi index 2513e6be271..10c007eb635 100644 --- a/doc/emacs/help.texi +++ b/doc/emacs/help.texi @@ -316,6 +316,15 @@ Name Help by using the @kbd{M-x shortdoc} command. This will prompt you for an area of interest, e.g., @code{string}, and pop you to a buffer where many of the functions relevant for handling strings are listed. +Here's an example you can include in your initialization file +(@pxref{Init File}) that uses @code{shortdoc} to insert Emacs Lisp +function examples into regular @file{*Help*} buffers when you use +@kbd{C-h f}: + +@example +(add-hook 'help-fns-describe-function-functions + #'shortdoc-help-fns-examples-function) +@end example @kindex C-h v @findex describe-variable diff --git a/doc/lispref/help.texi b/doc/lispref/help.texi index 59b6b6dab1d..3175f66122e 100644 --- a/doc/lispref/help.texi +++ b/doc/lispref/help.texi @@ -989,3 +989,29 @@ Documentation Groups If @var{group} doesn't exist, it will be created. If @var{section} doesn't exist, it will be added to the end of the function group. @end defun + +You can also query the examples of use of functions defined in +shortdoc groups. + +@defun shortdoc-function-examples function +This function returns all shortdoc examples for @var{function}. The +result is an alist with items of the form + +@example +(@var{group} . @var{examples}) +@end example + +@noindent +where @var{group} is a documentation group where @var{function} +appears in and @var{examples} is a string with the examples of use of +@var{function} defined in @var{group}. + +@code{shortdoc-function-examples} returns @code{nil} if @var{function} +is not a function or if it doesn’t contain shortdoc information. +@end defun + +@defun shortdoc-help-fns-examples-function function +This function queries the registered documentation groups and inserts +examples of use of a given Emacs Lisp function into the current +buffer. +@end defun diff --git a/etc/NEWS b/etc/NEWS index 13d073c7fb8..5f51b801774 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -220,6 +220,24 @@ asynchronously (which is the default behavior). *** New face 'doc-view-svg-face'. This replaces 'doc-view-svg-foreground' and 'doc-view-svg-background'. +** Shortdoc + ++++ +*** New function 'shortdoc-function-examples'. +This function queries the registered documentation groups and returns +examples of use of a given Emacs Lisp function. + ++++ +*** New function 'shortdoc-help-fns-examples-function'. +This function queries the registered documentation groups and inserts +examples of use of a given Emacs Lisp function into the current +buffer. If you want to insert Emacs Lisp function examples into +regular *Help* buffers when you use 'describe-function', add the +following to you init file: + + (add-hook 'help-fns-describe-function-functions + #'shortdoc-help-fns-examples-function) + * New Modes and Packages in Emacs 30.1 diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index c49960c2ee6..cf66a43fc35 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -1443,45 +1443,51 @@ shortdoc-display-group (setq group (intern group))) (unless (assq group shortdoc--groups) (error "No such documentation group %s" group)) - (funcall (if same-window - #'pop-to-buffer-same-window - #'pop-to-buffer) - (format "*Shortdoc %s*" group)) - (let ((inhibit-read-only t) - (prev nil)) - (erase-buffer) - (shortdoc-mode) - (button-mode) - (mapc - (lambda (data) - (cond - ((stringp data) - (setq prev nil) - (unless (bobp) - (insert "\n")) - (insert (propertize - (substitute-command-keys data) - 'face 'shortdoc-heading - 'shortdoc-section t - 'outline-level 1)) - (insert (propertize - "\n\n" - 'face 'shortdoc-heading - 'shortdoc-section t))) - ;; There may be functions not yet defined in the data. - ((fboundp (car data)) - (when prev - (insert (make-separator-line) - ;; This helps with hidden outlines (bug#53981) - (propertize "\n" 'face '(:height 0)))) - (setq prev t) - (shortdoc--display-function data)))) - (cdr (assq group shortdoc--groups)))) + (let ((buf (get-buffer-create (format "*Shortdoc %s*" group)))) + (shortdoc--insert-group-in-buffer group buf) + (funcall (if same-window + #'pop-to-buffer-same-window + #'pop-to-buffer) + buf)) (goto-char (point-min)) (when function (text-property-search-forward 'shortdoc-function function t) (beginning-of-line))) +(defun shortdoc--insert-group-in-buffer (group &optional buf) + "Insert a short documentation summary for functions in GROUP in buffer BUF." + (with-current-buffer (or buf (current-buffer)) + (let ((inhibit-read-only t) + (prev nil)) + (erase-buffer) + (shortdoc-mode) + (button-mode) + (mapc + (lambda (data) + (cond + ((stringp data) + (setq prev nil) + (unless (bobp) + (insert "\n")) + (insert (propertize + (substitute-command-keys data) + 'face 'shortdoc-heading + 'shortdoc-section t + 'outline-level 1)) + (insert (propertize + "\n\n" + 'face 'shortdoc-heading + 'shortdoc-section t))) + ;; There may be functions not yet defined in the data. + ((fboundp (car data)) + (when prev + (insert (make-separator-line) + ;; This helps with hidden outlines (bug#53981) + (propertize "\n" 'face '(:height 0)))) + (setq prev t) + (shortdoc--display-function data)))) + (cdr (assq group shortdoc--groups)))))) + ;;;###autoload (defalias 'shortdoc #'shortdoc-display-group) @@ -1521,7 +1527,8 @@ shortdoc--display-function "=>")) (single-arrow (if (char-displayable-p ?→) "→" - "->"))) + "->")) + (start-example (point))) (cl-loop for (type value) on data by #'cddr do (cl-case type @@ -1572,7 +1579,8 @@ shortdoc--display-function (:eg-result-string (insert " e.g. " double-arrow " ") (princ value (current-buffer)) - (insert "\n"))))) + (insert "\n")))) + (add-text-properties start-example (point) `(shortdoc-example ,function))) ;; Insert the arglist after doing the evals, in case that's pulled ;; in the function definition. (save-excursion @@ -1582,6 +1590,48 @@ shortdoc--display-function (insert " " (symbol-name param))) (add-face-text-property arglist-start (point) 'shortdoc-section t)))) +(defun shortdoc-function-examples (function) + "Return all shortdoc examples for FUNCTION. +The result is an alist with items of the form (GROUP . EXAMPLES), +where GROUP is a shortdoc group where FUNCTION appears in and +EXAMPLES is a string with the usage examples of FUNCTION defined +in GROUP. Return nil if FUNCTION is not a function or if it +doesn't contain shortdoc information." + (let ((groups (and (symbolp function) + (shortdoc-function-groups function))) + (examples nil)) + (mapc + (lambda (group) + (with-temp-buffer + (shortdoc--insert-group-in-buffer group) + (goto-char (point-min)) + (setq match (text-property-search-forward + 'shortdoc-example function t)) + (push `(,group . ,(string-trim + (buffer-substring-no-properties + (prop-match-beginning match) + (prop-match-end match)))) + examples))) + groups) + examples)) + +(defun shortdoc-help-fns-examples-function (function) + "Insert Emacs Lisp examples for FUNCTION into the current buffer. +You can add this function to the +`help-fns-describe-function-functions' list to show function +example documentation in *Help* buffers." + (let ((examples (shortdoc-function-examples function)) + (times 0)) + (dolist (example examples) + (when (zerop times) + (if (eq (length examples) 1) + (insert " Example:\n\n") + (insert " Examples:\n\n"))) + (setq times (1+ times)) + (insert " ") + (insert (cdr example)) + (insert "\n\n")))) + (defun shortdoc-function-groups (function) "Return all shortdoc groups FUNCTION appears in." (cl-loop for group in shortdoc--groups diff --git a/test/lisp/emacs-lisp/shortdoc-tests.el b/test/lisp/emacs-lisp/shortdoc-tests.el index 516d095767f..a65a4a5ddc3 100644 --- a/test/lisp/emacs-lisp/shortdoc-tests.el +++ b/test/lisp/emacs-lisp/shortdoc-tests.el @@ -65,6 +65,16 @@ shortdoc-all-groups-work (when buf (kill-buffer buf)))))) +(ert-deftest shortdoc-function-examples-test () + "Test the extraction of usage examples of some Elisp functions." + (should (equal '((list . "(delete 2 (list 1 2 3 4))\n => (1 3 4)\n (delete \"a\" (list \"a\" \"b\" \"c\" \"d\"))\n => (\"b\" \"c\" \"d\")")) + (shortdoc-function-examples 'delete))) + (should (equal '((alist . "(assq 'foo '((foo . bar) (zot . baz)))\n => (foo . bar)") + (list . "(assq 'b '((a . 1) (b . 2)))\n => (b . 2)")) + (shortdoc-function-examples 'assq))) + (should (equal '((regexp . "(string-match-p \"^[fo]+\" \"foobar\")\n => 0")) + (shortdoc-function-examples 'string-match-p)))) + (provide 'shortdoc-tests) ;;; shortdoc-tests.el ends here commit 31f18480ca7291070837a305c64685c3e76afde3 Author: Jim Porter Date: Sat Mar 11 23:51:20 2023 -0800 ; Fix typo in docstring * test/lisp/eshell/em-cmpl-tests.el (em-cmpl-test/variable-assign-completion/non-assignment): Fix typo. diff --git a/test/lisp/eshell/em-cmpl-tests.el b/test/lisp/eshell/em-cmpl-tests.el index b60faab9114..ea907f1945d 100644 --- a/test/lisp/eshell/em-cmpl-tests.el +++ b/test/lisp/eshell/em-cmpl-tests.el @@ -261,7 +261,7 @@ em-cmpl-test/variable-assign-completion/non-assignment "Test completion of things that look like variable assignment, but aren't. For example, the second argument in \"tar --directory=dir\" looks like it could be a variable assignment, but it's not. We should -let `pcomplete-tar' handle it instead. +let `pcomplete/tar' handle it instead. See ." (with-temp-eshell commit 9199fa00caa69dd834cceac998e20fcc55cac9d3 Author: Jim Porter Date: Tue Jan 24 21:22:06 2023 -0800 Add support for completing special references (e.g. buffers) in Eshell * lisp/eshell/em-cmpl.el (eshell-complete-parse-arguments): Handle special references. * lisp/eshell/em-arg.el (eshell-parse-special-reference): Ensure point is just after the "#<" when incomplete, and handle backslash escapes more thoroughly. (eshell-complete-special-reference): New function. * test/lisp/eshell/esh-arg-tests.el (esh-arg-test/special-reference/default) (esh-arg-test/special-reference/buffer) (esh-arg-test/special-reference/special): * test/lisp/eshell/em-cmpl-tests.el (em-cmpl-test/special-ref-completion/type) (em-cmpl-test/special-ref-completion/implicit-buffer) (em-cmpl-test/special-ref-completion/buffer): New tests. diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el index 5dfd10d6e4c..b65652019d4 100644 --- a/lisp/eshell/em-cmpl.el +++ b/lisp/eshell/em-cmpl.el @@ -317,7 +317,7 @@ eshell-complete-parse-arguments (eshell--pcomplete-insert-tab)) (let ((end (point-marker)) (begin (save-excursion (beginning-of-line) (point))) - args posns delim) + args posns delim incomplete-arg) (when (and pcomplete-allow-modifications (memq this-command '(pcomplete-expand pcomplete-expand-and-complete))) @@ -332,10 +332,11 @@ eshell-complete-parse-arguments (cond ((member (car delim) '("{" "${" "$<")) (setq begin (1+ (cadr delim)) args (eshell-parse-arguments begin end))) - ((member (car delim) '("$'" "$\"")) + ((member (car delim) '("$'" "$\"" "#<")) ;; Add the (incomplete) argument to our arguments, and ;; note its position. - (setq args (append (nth 2 delim) (list (car delim)))) + (setq args (append (nth 2 delim) (list (car delim))) + incomplete-arg t) (push (- (nth 1 delim) 2) posns)) ((member (car delim) '("(" "$(")) (throw 'pcompleted (elisp-completion-at-point))) @@ -362,7 +363,8 @@ eshell-complete-parse-arguments (setq args (nthcdr (1+ new-start) args) posns (nthcdr (1+ new-start) posns)))) (cl-assert (= (length args) (length posns))) - (when (and args (eq (char-syntax (char-before end)) ? ) + (when (and args (not incomplete-arg) + (eq (char-syntax (char-before end)) ? ) (not (eq (char-before (1- end)) ?\\))) (nconc args (list "")) (nconc posns (list (point)))) diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el index cb0b2e0938c..aa1e8f77ea5 100644 --- a/lisp/eshell/esh-arg.el +++ b/lisp/eshell/esh-arg.el @@ -28,6 +28,9 @@ ;;; Code: (require 'esh-util) +(require 'esh-module) + +(require 'pcomplete) (eval-when-compile (require 'cl-lib)) @@ -175,7 +178,11 @@ eshell-arg-initialize "Initialize the argument parsing code." (eshell-arg-mode) (setq-local eshell-inside-quote-regexp nil) - (setq-local eshell-outside-quote-regexp nil)) + (setq-local eshell-outside-quote-regexp nil) + + (when (eshell-using-module 'eshell-cmpl) + (add-hook 'pcomplete-try-first-hook + #'eshell-complete-special-reference nil t))) (defun eshell-insert-buffer-name (buffer-name) "Insert BUFFER-NAME into the current buffer at point." @@ -506,21 +513,28 @@ eshell-parse-special-reference \"buffer\"." (when (and (not eshell-current-argument) (not eshell-current-quoted) - (looking-at "#<\\(\\(buffer\\|process\\)\\s-\\)?")) + (looking-at (rx "#<" (? (group (or "buffer" "process")) + space)))) (let ((here (point))) (goto-char (match-end 0)) ;; Go to the end of the match. - (let ((buffer-p (if (match-string 1) - (string= (match-string 2) "buffer") - t)) ;; buffer-p is non-nil by default. + (let ((buffer-p (if (match-beginning 1) + (equal (match-string 1) "buffer") + t)) ; With no type keyword, assume we want a buffer. (end (eshell-find-delimiter ?\< ?\>))) (when (not end) + (when (match-beginning 1) + (goto-char (match-beginning 1))) (throw 'eshell-incomplete "#<")) (if (eshell-arg-delimiter (1+ end)) (prog1 - (list (if buffer-p 'get-buffer-create 'get-process) - (replace-regexp-in-string - (rx "\\" (group (or "\\" "<" ">"))) "\\1" - (buffer-substring-no-properties (point) end))) + (list (if buffer-p #'get-buffer-create #'get-process) + ;; FIXME: We should probably parse this as a + ;; real Eshell argument so that we get the + ;; benefits of quoting, variable-expansion, etc. + (string-trim-right + (replace-regexp-in-string + (rx "\\" (group anychar)) "\\1" + (buffer-substring-no-properties (point) end)))) (goto-char (1+ end))) (ignore (goto-char here))))))) @@ -574,5 +588,41 @@ eshell-prepare-splice (when splicep grouped-args))) +;;;_* Special ref completion + +(defun eshell-complete-special-reference () + "If there is a special reference, complete it." + (let ((arg (pcomplete-actual-arg))) + (when (string-match + (rx string-start + "#<" (? (group (or "buffer" "process")) space) + (group (* anychar)) + string-end) + arg) + (let ((all-results (if (equal (match-string 1 arg) "process") + (mapcar #'process-name (process-list)) + (mapcar #'buffer-name (buffer-list)))) + (saw-type (match-beginning 1))) + (unless saw-type + ;; Include the special reference types as completion options. + (setq all-results (append '("buffer" "process") all-results))) + (setq pcomplete-stub (replace-regexp-in-string + (rx "\\" (group anychar)) "\\1" + (substring arg (match-beginning 2)))) + ;; When finished with completion, add a trailing ">" (unless + ;; we just completed the initial "buffer" or "process" + ;; keyword). + (add-function + :before (var pcomplete-exit-function) + (lambda (value status) + (when (and (eq status 'finished) + (or saw-type + (not (member value '("buffer" "process"))))) + (if (looking-at ">") + (goto-char (match-end 0)) + (insert ">"))))) + (throw 'pcomplete-completions + (all-completions pcomplete-stub all-results)))))) + (provide 'esh-arg) ;;; esh-arg.el ends here diff --git a/test/lisp/eshell/em-cmpl-tests.el b/test/lisp/eshell/em-cmpl-tests.el index be2199c0464..b60faab9114 100644 --- a/test/lisp/eshell/em-cmpl-tests.el +++ b/test/lisp/eshell/em-cmpl-tests.el @@ -176,6 +176,46 @@ em-cmpl-test/lisp-function-completion (should (equal (eshell-insert-and-complete "echo (eshell/ech") "echo (eshell/echo")))) +(ert-deftest em-cmpl-test/special-ref-completion/type () + "Test completion of the start of special references like \"#." + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo hi > # # # #\". +See ." + (let (bufname) + (with-temp-buffer + (setq bufname (rename-buffer "my-buffer" t)) + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo hi > # #<%s> " bufname)))) + (setq bufname (rename-buffer "another buffer" t)) + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo hi > # #<%s> " + (string-replace " " "\\ " bufname)))))))) + +(ert-deftest em-cmpl-test/special-ref-completion/buffer () + "Test completion of special references like \"#\". +See ." + (let (bufname) + (with-temp-buffer + (setq bufname (rename-buffer "my-buffer" t)) + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo hi > # # " bufname)))) + (setq bufname (rename-buffer "another buffer" t)) + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo hi > # # " + (string-replace " " "\\ " bufname)))))))) + (ert-deftest em-cmpl-test/variable-ref-completion () "Test completion of variable references like \"$var\". See ." diff --git a/test/lisp/eshell/esh-arg-tests.el b/test/lisp/eshell/esh-arg-tests.el index 918ad3a949f..c883db3907f 100644 --- a/test/lisp/eshell/esh-arg-tests.el +++ b/test/lisp/eshell/esh-arg-tests.el @@ -102,4 +102,34 @@ esh-arg-test/escape-quoted/newline (eshell-match-command-output "echo \"hi\\\nthere\"" "hithere\n"))) +(ert-deftest esh-arg-test/special-reference/default () + "Test that \"#\" refers to the buffer \"buf\"." + (with-temp-buffer + (rename-buffer "my-buffer" t) + (eshell-command-result-equal + (format "echo #<%s>" (buffer-name)) + (current-buffer)))) + +(ert-deftest esh-arg-test/special-reference/buffer () + "Test that \"#\" refers to the buffer \"buf\"." + (with-temp-buffer + (rename-buffer "my-buffer" t) + (eshell-command-result-equal + (format "echo #" (buffer-name)) + (current-buffer)))) + +(ert-deftest esh-arg-test/special-reference/special () + "Test that \"#<...>\" works correctly when escaping special characters." + (with-temp-buffer + (rename-buffer "" t) + (let ((escaped-bufname (replace-regexp-in-string + (rx (group (or "\\" "<" ">" space))) "\\\\\\1" + (buffer-name)))) + (eshell-command-result-equal + (format "echo #<%s>" escaped-bufname) + (current-buffer)) + (eshell-command-result-equal + (format "echo #" escaped-bufname) + (current-buffer))))) + ;; esh-arg-tests.el ends here commit b8e7061232f9a5b06af70031dcc4b48c6575a364 Author: Mattias Engdegård Date: Fri Mar 10 17:10:30 2023 +0100 Remove recursion from character escape handling in reader This cures a C stack overflow when reading certain long (crafted) strings (bug#62039) and improves performance of reading escaped characters in character and string literals. Reported by Bruno Haible. * src/lread.c (invalid_escape_syntax_error): New. (read_escape): Rename to... (read_char_escape): ...this. Remove recursion. Pass read-ahead char as argument. Improve code performance and clarity. (read_char_literal, read_string_literal): Update calls. * test/src/lread-tests.el (lread-char-modifiers) (lread-many-modifiers): Add test cases. diff --git a/src/lread.c b/src/lread.c index d0dc85f51c8..273120315df 100644 --- a/src/lread.c +++ b/src/lread.c @@ -2639,154 +2639,137 @@ character_name_to_code (char const *name, ptrdiff_t name_len, Unicode 9.0.0 the maximum is 83, so this should be safe. */ enum { UNICODE_CHARACTER_NAME_LENGTH_BOUND = 200 }; -/* Read a \-escape sequence, assuming we already read the `\'. - If the escape sequence forces unibyte, return eight-bit char. */ +static AVOID +invalid_escape_syntax_error (void) +{ + error ("Invalid escape character syntax"); +} +/* Read a character escape sequence, assuming we just read a backslash + and one more character (next_char). */ static int -read_escape (Lisp_Object readcharfun) +read_char_escape (Lisp_Object readcharfun, int next_char) { - int c = READCHAR; - /* \u allows up to four hex digits, \U up to eight. Default to the - behavior for \u, and change this value in the case that \U is seen. */ - int unicode_hex_count = 4; + int modifiers = 0; + ptrdiff_t ncontrol = 0; + int chr; + + again: ; + int c = next_char; + int unicode_hex_count; + int mod; switch (c) { case -1: end_of_file_error (); - case 'a': - return '\007'; - case 'b': - return '\b'; - case 'd': - return 0177; - case 'e': - return 033; - case 'f': - return '\f'; - case 'n': - return '\n'; - case 'r': - return '\r'; - case 't': - return '\t'; - case 'v': - return '\v'; + case 'a': chr = '\a'; break; + case 'b': chr = '\b'; break; + case 'd': chr = 127; break; + case 'e': chr = 27; break; + case 'f': chr = '\f'; break; + case 'n': chr = '\n'; break; + case 'r': chr = '\r'; break; + case 't': chr = '\t'; break; + case 'v': chr = '\v'; break; case '\n': /* ?\LF is an error; it's probably a user mistake. */ error ("Invalid escape character syntax"); - case 'M': - c = READCHAR; - if (c != '-') - error ("Invalid escape character syntax"); - c = READCHAR; - if (c == '\\') - c = read_escape (readcharfun); - return c | meta_modifier; - - case 'S': - c = READCHAR; - if (c != '-') - error ("Invalid escape character syntax"); - c = READCHAR; - if (c == '\\') - c = read_escape (readcharfun); - return c | shift_modifier; - - case 'H': - c = READCHAR; - if (c != '-') - error ("Invalid escape character syntax"); - c = READCHAR; - if (c == '\\') - c = read_escape (readcharfun); - return c | hyper_modifier; + /* \M-x etc: set modifier bit and parse the char to which it applies, + allowing for chains such as \M-\S-\A-\H-\s-\C-q. */ + case 'M': mod = meta_modifier; goto mod_key; + case 'S': mod = shift_modifier; goto mod_key; + case 'H': mod = hyper_modifier; goto mod_key; + case 'A': mod = alt_modifier; goto mod_key; + case 's': mod = super_modifier; goto mod_key; - case 'A': - c = READCHAR; - if (c != '-') - error ("Invalid escape character syntax"); - c = READCHAR; - if (c == '\\') - c = read_escape (readcharfun); - return c | alt_modifier; - - case 's': - c = READCHAR; - if (c != '-') - { - UNREAD (c); - return ' '; - } - c = READCHAR; - if (c == '\\') - c = read_escape (readcharfun); - return c | super_modifier; + mod_key: + { + int c1 = READCHAR; + if (c1 != '-') + { + if (c == 's') + { + /* \s not followed by a hyphen is SPC. */ + UNREAD (c1); + chr = ' '; + break; + } + else + /* \M, \S, \H, \A not followed by a hyphen is an error. */ + invalid_escape_syntax_error (); + } + modifiers |= mod; + c1 = READCHAR; + if (c1 == '\\') + { + next_char = READCHAR; + goto again; + } + chr = c1; + break; + } + /* Control modifiers (\C-x or \^x) are messy and not actually idempotent. + For example, ?\C-\C-a = ?\C-\001 = 0x4000001. + Keep a count of them and apply them separately. */ case 'C': - c = READCHAR; - if (c != '-') - error ("Invalid escape character syntax"); + { + int c1 = READCHAR; + if (c1 != '-') + invalid_escape_syntax_error (); + } FALLTHROUGH; + /* The prefixes \C- and \^ are equivalent. */ case '^': - c = READCHAR; - if (c == '\\') - c = read_escape (readcharfun); - if ((c & ~CHAR_MODIFIER_MASK) == '?') - return 0177 | (c & CHAR_MODIFIER_MASK); - else if (! ASCII_CHAR_P ((c & ~CHAR_MODIFIER_MASK))) - return c | ctrl_modifier; - /* ASCII control chars are made from letters (both cases), - as well as the non-letters within 0100...0137. */ - else if ((c & 0137) >= 0101 && (c & 0137) <= 0132) - return (c & (037 | ~0177)); - else if ((c & 0177) >= 0100 && (c & 0177) <= 0137) - return (c & (037 | ~0177)); - else - return c | ctrl_modifier; - - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - /* An octal escape, as in ANSI C. */ { - register int i = c - '0'; - register int count = 0; - while (++count < 3) + ncontrol++; + int c1 = READCHAR; + if (c1 == '\\') { - if ((c = READCHAR) >= '0' && c <= '7') - { - i *= 8; - i += c - '0'; - } - else + next_char = READCHAR; + goto again; + } + chr = c1; + break; + } + + /* 1-3 octal digits. Values in 0x80..0xff are encoded as raw bytes. */ + case '0': case '1': case '2': case '3': + case '4': case '5': case '6': case '7': + { + int i = c - '0'; + int count = 0; + while (count < 2) + { + int c = READCHAR; + if (c < '0' || c > '7') { UNREAD (c); break; } + i = (i << 3) + (c - '0'); + count++; } if (i >= 0x80 && i < 0x100) i = BYTE8_TO_CHAR (i); - return i; + chr = i; + break; } + /* 1 or more hex digits. Values may encode modifiers. + Values in 0x80..0xff using 2 hex digits are encoded as raw bytes. */ case 'x': - /* A hex escape, as in ANSI C. */ { unsigned int i = 0; int count = 0; while (1) { - c = READCHAR; + int c = READCHAR; int digit = char_hexdigit (c); if (digit < 0) { @@ -2796,40 +2779,37 @@ read_escape (Lisp_Object readcharfun) i = (i << 4) + digit; /* Allow hex escapes as large as ?\xfffffff, because some packages use them to denote characters with modifiers. */ - if ((CHAR_META | (CHAR_META - 1)) < i) + if (i > (CHAR_META | (CHAR_META - 1))) error ("Hex character out of range: \\x%x...", i); count += count < 3; } + if (count == 0) + invalid_escape_syntax_error (); if (count < 3 && i >= 0x80) - return BYTE8_TO_CHAR (i); - return i; + i = BYTE8_TO_CHAR (i); + modifiers |= i & CHAR_MODIFIER_MASK; + chr = i & ~CHAR_MODIFIER_MASK; + break; } + /* 8-digit Unicode hex escape: \UHHHHHHHH */ case 'U': - /* Post-Unicode-2.0: Up to eight hex chars. */ unicode_hex_count = 8; - FALLTHROUGH; - case 'u': + goto unicode_hex; - /* A Unicode escape. We only permit them in strings and characters, - not arbitrarily in the source code, as in some other languages. */ + /* 4-digit Unicode hex escape: \uHHHH */ + case 'u': + unicode_hex_count = 4; + unicode_hex: { unsigned int i = 0; - int count = 0; - - while (++count <= unicode_hex_count) + for (int count = 0; count < unicode_hex_count; count++) { - c = READCHAR; + int c = READCHAR; if (c < 0) - { - if (unicode_hex_count > 4) - error ("Malformed Unicode escape: \\U%x", i); - else - error ("Malformed Unicode escape: \\u%x", i); - } - /* `isdigit' and `isalpha' may be locale-specific, which we don't - want. */ + error ("Malformed Unicode escape: \\%c%x", + unicode_hex_count == 4 ? 'u' : 'U', i); int digit = char_hexdigit (c); if (digit < 0) error ("Non-hex character used for Unicode escape: %c (%d)", @@ -2838,13 +2818,14 @@ read_escape (Lisp_Object readcharfun) } if (i > 0x10FFFF) error ("Non-Unicode character: 0x%x", i); - return i; + chr = i; + break; } + /* Named character: \N{name} */ case 'N': - /* Named character. */ { - c = READCHAR; + int c = READCHAR; if (c != '{') invalid_syntax ("Expected opening brace after \\N", readcharfun); char name[UNICODE_CHARACTER_NAME_LENGTH_BOUND + 1]; @@ -2852,12 +2833,12 @@ read_escape (Lisp_Object readcharfun) ptrdiff_t length = 0; while (true) { - c = READCHAR; + int c = READCHAR; if (c < 0) end_of_file_error (); if (c == '}') break; - if (! (0 < c && c < 0x80)) + if (c >= 0x80) { AUTO_STRING (format, "Invalid character U+%04X in character name"); @@ -2886,13 +2867,41 @@ read_escape (Lisp_Object readcharfun) name[length] = '\0'; /* character_name_to_code can invoke read0, recursively. - This is why read0's buffer is not static. */ - return character_name_to_code (name, length, readcharfun); + This is why read0 needs to be re-entrant. */ + chr = character_name_to_code (name, length, readcharfun); + break; } default: - return c; + chr = c; + break; } + eassert (chr >= 0 && chr < (1 << CHARACTERBITS)); + + /* Apply Control modifiers, using the rules: + \C-X = ascii_ctrl(nomod(X)) | mods(X) if nomod(X) is one of: + A-Z a-z ? @ [ \ ] ^ _ + + X | ctrl_modifier otherwise + + where + nomod(c) = c without modifiers + mods(c) = the modifiers of c + ascii_ctrl(c) = 127 if c = '?' + c & 0x1f otherwise + */ + while (ncontrol > 0) + { + if ((chr >= '@' && chr <= '_') || (chr >= 'a' && chr <= 'z')) + chr &= 0x1f; + else if (chr == '?') + chr = 127; + else + modifiers |= ctrl_modifier; + ncontrol--; + } + + return chr | modifiers; } /* Return the digit that CHARACTER stands for in the given BASE. @@ -3014,7 +3023,7 @@ read_char_literal (Lisp_Object readcharfun) } if (ch == '\\') - ch = read_escape (readcharfun); + ch = read_char_escape (readcharfun, READCHAR); int modifiers = ch & CHAR_MODIFIER_MASK; ch &= ~CHAR_MODIFIER_MASK; @@ -3080,8 +3089,7 @@ read_string_literal (Lisp_Object readcharfun) /* `\SPC' and `\LF' generate no characters at all. */ continue; default: - UNREAD (ch); - ch = read_escape (readcharfun); + ch = read_char_escape (readcharfun, ch); break; } diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el index c0ea37d2c55..fc00204ce7b 100644 --- a/test/src/lread-tests.el +++ b/test/src/lread-tests.el @@ -116,8 +116,27 @@ lread-empty-int-literal (should-error (read "#") :type 'invalid-read-syntax)) (ert-deftest lread-char-modifiers () - (should (eq ?\C-\M-é (+ (- ?\M-a ?a) ?\C-é))) - (should (eq (- ?\C-ŗ ?ŗ) (- ?\C-é ?é)))) + (should (equal ?\C-\M-é (+ (- ?\M-a ?a) ?\C-é))) + (should (equal (- ?\C-ŗ ?ŗ) (- ?\C-é ?é))) + (should (equal ?\C-\C-c #x4000003)) + (should (equal ?\C-\M-\C-c #xc000003)) + (should (equal ?\M-\C-\C-c #xc000003)) + (should (equal ?\C-\C-\M-c #xc000003)) + (should (equal ?\M-\S-\H-\A-\C-\s-x #xbc00018)) + + (should (equal "\s-x" " -x")) + (should (equal "\C-x" "\x18")) + (should (equal "\^x" "\x18")) + (should (equal "\M-x" "\xf8"))) + +(ert-deftest lread-many-modifiers () + ;; The string literal "\M-\M-...\M-a" should be equivalent to "\M-a", + ;; and we should not run out of stack space parsing it. + (let* ((n 500000) + (s (concat "\"" + (apply #'concat (make-list n "\\M-")) + "a\""))) + (should (equal (read-from-string s) (cons "\M-a" (+ (* n 3) 3)))))) (ert-deftest lread-record-1 () (should (equal '(#s(foo) #s(foo)) commit c6bfffa9fe1af7f4f806e5533ba5f3c33476cf9a Author: Paul Eggert Date: Fri Mar 10 16:51:41 2023 -0800 Update from Gnulib by running admin/merge-gnulib Run admin/merge-gnulib along with the following change: * admin/merge-gnulib (GNULIB_MODULES): Replace ‘time’ with ‘time-h’, adjusting to a recent renaming in Gnulib modules. Emacs doesn’t appear to need the new Gnulib ‘time’ module. diff --git a/admin/merge-gnulib b/admin/merge-gnulib index 04e3e34b9f9..917ddda1fd5 100755 --- a/admin/merge-gnulib +++ b/admin/merge-gnulib @@ -46,7 +46,7 @@ GNULIB_MODULES= qcopy-acl readlink readlinkat regex sig2str sigdescr_np socklen stat-time std-gnu11 stdbool stddef stdio stpcpy strnlen strtoimax symlink sys_stat sys_time - tempname time time_r time_rz timegm timer-time timespec-add timespec-sub + tempname time-h time_r time_rz timegm timer-time timespec-add timespec-sub update-copyright unlocked-io utimensat vla warnings ' diff --git a/doc/misc/texinfo.tex b/doc/misc/texinfo.tex index 3cccf01d958..1ddfef4b878 100644 --- a/doc/misc/texinfo.tex +++ b/doc/misc/texinfo.tex @@ -3,7 +3,7 @@ % Load plain if necessary, i.e., if running under initex. \expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi % -\def\texinfoversion{2023-01-02.21} +\def\texinfoversion{2023-03-04.12} % % Copyright 1985, 1986, 1988, 1990-2023 Free Software Foundation, Inc. % @@ -2683,25 +2683,21 @@ } \setregularquotes -% Allow an option to not use regular directed right quote/apostrophe -% (char 0x27), but instead the undirected quote from cmtt (char 0x0d). -% The undirected quote is ugly, so don't make it the default, but it -% works for pasting with more pdf viewers (at least evince), the -% lilypond developers report. xpdf does work with the regular 0x27. +% output for ' in @code +% in tt font hex 0D (undirected) or 27 (curly right quote) % \def\codequoteright{% \ifusingtt {\ifflagclear{txicodequoteundirected}% {\ifflagclear{codequoteundirected}% {'}% - {\char'15 }}% - {\char'15 }}% + {\char"0D }}% + {\char"0D }}% {'}% } -% and a similar option for the left quote char vs. a grave accent. -% Modern fonts display ASCII 0x60 as a grave accent, so some people like -% the code environments to do likewise. +% output for ` in @code +% in tt font hex 12 (grave accent) or 60 (curly left quote) % \relax disables Spanish ligatures ?` and !` of \tt font. % \def\codequoteleft{% @@ -2709,8 +2705,8 @@ {\ifflagclear{txicodequotebacktick}% {\ifflagclear{codequotebacktick}% {\relax`}% - {\char'22 }}% - {\char'22 }}% + {\char"12 }}% + {\char"12 }}% {\relax`}% } @@ -2729,7 +2725,7 @@ \errmessage{Unknown @codequoteundirected value `\temp', must be on|off}% \fi\fi } -% + \parseargdef\codequotebacktick{% \def\temp{#1}% \ifx\temp\onword @@ -2744,6 +2740,11 @@ \fi\fi } +% Turn them on by default +\let\SETtxicodequoteundirected = t +\let\SETtxicodequotebacktick = t + + % [Knuth] pp. 380,381,391, disable Spanish ligatures ?` and !` of \tt font. \def\noligaturesquoteleft{\relax\lq} @@ -2929,10 +2930,6 @@ \let-\dashnobreak \let_\realunder \fi - % Given -foo (with a single dash), we do not want to allow a break - % after the hyphen. - \global\let\codedashprev=\codedash - % \codex } % @@ -2942,21 +2939,30 @@ % % Now, output a discretionary to allow a line break, unless % (a) the next character is a -, or - % (b) the preceding character is a -. + % (b) the preceding character is a -, or + % (c) we are at the start of the string. + % In both cases (b) and (c), \codedashnobreak should be set to \codedash. + % % E.g., given --posix, we do not want to allow a break after either -. % Given --foo-bar, we do want to allow a break between the - and the b. \ifx\next\codedash \else - \ifx\codedashprev\codedash + \ifx\codedashnobreak\codedash \else \discretionary{}{}{}\fi \fi % we need the space after the = for the case when \next itself is a % space token; it would get swallowed otherwise. As in @code{- a}. - \global\let\codedashprev= \next + \global\let\codedashnobreak= \next } } \def\normaldash{-} % -\def\codex #1{\tclose{#1}\endgroup} +\def\codex #1{\tclose{% + % Given -foo (with a single dash), we do not want to allow a break + % after the -. \codedashnobreak is set to the first character in + % @code. + \futurelet\codedashnobreak\relax + #1% +}\endgroup} \def\codeunder{% % this is all so @math{@code{var_name}+1} can work. In math mode, _ @@ -3950,33 +3956,23 @@ \def\HEADINGSoff{{\globaldefs=1 \headingsoff}} % global setting -% When we turn headings on, set the page number to 1. +% Set the page number to 1. \def\pageone{ \global\pageno=1 \global\arabiccount = \pagecount } -% For double-sided printing, put current file name in lower left corner, -% chapter name on inside top of right hand pages, document -% title on inside top of left hand pages, and page numbers on outside top -% edge of all pages. -\def\HEADINGSdouble{% -\pageone -\HEADINGSdoublex -} \let\contentsalignmacro = \chappager -% For single-sided printing, chapter title goes across top left of page, -% page number on top right. -\def\HEADINGSsingle{% -\pageone -\HEADINGSsinglex -} % \def\HEADINGSon{\HEADINGSdouble} % defined by \CHAPPAGon -\def\HEADINGSafter{\let\HEADINGShook=\HEADINGSdoublex} +% For double-sided printing, put current file name in lower left corner, +% chapter name on inside top of right hand pages, document +% title on inside top of left hand pages, and page numbers on outside top +% edge of all pages. +\def\HEADINGSafter{\let\HEADINGShook=\HEADINGSdouble} \let\HEADINGSdoubleafter=\HEADINGSafter -\def\HEADINGSdoublex{% +\def\HEADINGSdouble{% \global\evenfootline={\hfil} \global\oddfootline={\hfil} \global\evenheadline={\line{\folio\hfil\thistitle}} @@ -3986,8 +3982,10 @@ \global\let\contentsalignmacro = \chapoddpage } -\def\HEADINGSsingleafter{\let\HEADINGShook=\HEADINGSsinglex} -\def\HEADINGSsinglex{% +% For single-sided printing, chapter title goes across top left of page, +% page number on top right. +\def\HEADINGSsingleafter{\let\HEADINGShook=\HEADINGSsingle} +\def\HEADINGSsingle{% \global\evenfootline={\hfil} \global\oddfootline={\hfil} \global\evenheadline={\line{\thischapter\hfil\folio}} @@ -3999,7 +3997,6 @@ % for @setchapternewpage off \def\HEADINGSsinglechapoff{% -\pageone \global\evenfootline={\hfil} \global\oddfootline={\hfil} \global\evenheadline={\line{\thischapter\hfil\folio}} @@ -4105,6 +4102,7 @@ \nobreak\kern\dimen0 \endgroup \itemxneedsnegativevskiptrue + \penalty 10021 % for \indexpar \fi } @@ -4221,6 +4219,7 @@ % We can be in inner vertical mode in a footnote, although an % @itemize looks awful there. }% + \penalty 10021 % for \indexpar \flushcr } @@ -4725,13 +4724,11 @@ % except not \outer, so it can be used within macros and \if's. \edef\newwrite{\makecsname{ptexnewwrite}} -% \newindex {foo} defines an index named IX. +% \newindex {IX} defines an index named IX. % It automatically defines \IXindex such that % \IXindex ...rest of line... puts an entry in the index IX. % It also defines \IXindfile to be the number of the output channel for % the file that accumulates this index. The file's extension is IX. -% The name of an index should be no more than 2 characters long -% for the sake of vms. % \def\newindex#1{% \expandafter\chardef\csname#1indfile\endcsname=0 @@ -4787,11 +4784,17 @@ % and it is the two-letter name of the index. \def\doindex#1{\edef\indexname{#1}\parsearg\doindexxxx} -\def\doindexxxx #1{\doind{\indexname}{#1}} +\def\doindexxxx #1{\indexpar\doind{\indexname}{#1}} % like the previous two, but they put @code around the argument. \def\docodeindex#1{\edef\indexname{#1}\parsearg\docodeindexxxx} -\def\docodeindexxxx #1{\docind{\indexname}{#1}} +\def\docodeindexxxx #1{\indexpar\docind{\indexname}{#1}} + +% End any open paragraph, unless we are immediately after @item in +% @itemize or @enumerate. +\def\indexpar{% +\ifnum\lastpenalty=10021 \else\endgraf\fi +} % \definedummyword defines \#1 as \string\#1\space, thus effectively @@ -4989,7 +4992,7 @@ \commondummyword\ampchar {\normalamp}% \commondummyword\atchar {\@}% \commondummyword\arrow {->}% - \commondummyword\backslashchar {}% + \commondummyword\backslashchar {\realbackslash}% \commondummyword\bullet {bullet}% \commondummyword\comma {,}% \commondummyword\copyright {copyright}% @@ -5089,9 +5092,6 @@ % % We need to get rid of all macros, leaving only the arguments (if present). % Of course this is not nearly correct, but it is the best we can do for now. - % makeinfo does not expand macros in the argument to @deffn, which ends up - % writing an index entry, and texindex isn't prepared for an index sort entry - % that starts with \. % % Since macro invocations are followed by braces, we can just redefine them % to take a single TeX argument. The case of a macro invocation that @@ -5351,7 +5351,9 @@ % ..., ready, GO: % \def\safewhatsit#1{\ifhmode + \whatsitpenalty = \lastpenalty #1% + \ifnum\whatsitpenalty>9999 \penalty\whatsitpenalty \fi \else % \lastskip and \lastpenalty cannot both be nonzero simultaneously. \whatsitskip = \lastskip @@ -7387,6 +7389,7 @@ \def\setupverb{% \tt \def\par{\leavevmode\endgraf}% + \parindent = 0pt \setcodequotes \tabeightspaces % Respect line breaks, @@ -7562,11 +7565,6 @@ \exdentamount=\defbodyindent } -\newtoks\defidx -\newtoks\deftext - -\def\useindex#1{\defidx={#1}\ignorespaces} - % Called as \printdefunline \deffooheader{text} % \def\printdefunline#1#2{% @@ -7574,10 +7572,6 @@ \plainfrenchspacing % call \deffooheader: #1#2 \endheader - % create the index entry - \defcharsdefault - \edef\temp{\noexpand\doind{\the\defidx}{\the\deftext}}% - \temp % common ending: \interlinepenalty = 10000 \advance\rightskip by 0pt plus 1fil\relax @@ -7592,6 +7586,24 @@ \def\Edefun{\endgraf\medbreak} +% @defblock, @defline do not automatically create index entries +\envdef\defblock{% + \startdefun +} +\let\Edefblock\Edefun + +\def\defline{% + \doingtypefnfalse + \parseargusing\activeparens{\printdefunline\deflineheader}% +} +\def\deflineheader#1 #2 #3\endheader{% + \defname{#1}{}{#2}\magicamp\defunargs{#3\unskip}% +} +\def\deftypeline{% + \doingtypefntrue + \parseargusing\activeparens{\printdefunline\deflineheader}% +} + % \makedefun{deffoo} (\deffooheader parameters) { (\deffooheader expansion) } % % Define \deffoo, \deffoox \Edeffoo and \deffooheader. @@ -7643,23 +7655,18 @@ \fi\fi } -\def\defind#1#2{ - \defidx={#1}% - \deftext={#2}% -} - % Untyped functions: % @deffn category name args \makedefun{deffn}#1 #2 #3\endheader{% - \defind{fn}{\code{#2}}% + \doind{fn}{\code{#2}}% \defname{#1}{}{#2}\magicamp\defunargs{#3\unskip}% } % @defop category class name args \makedefun{defop}#1 {\defopheaderx{#1\ \putwordon}} \def\defopheaderx#1#2 #3 #4\endheader{% - \defind{fn}{\code{#3}\space\putwordon\ \code{#2}}% + \doind{fn}{\code{#3}\space\putwordon\ \code{#2}}% \defname{#1\ \code{#2}}{}{#3}\magicamp\defunargs{#4\unskip}% } @@ -7667,7 +7674,7 @@ % @deftypefn category type name args \makedefun{deftypefn}#1 #2 #3 #4\endheader{% - \defind{fn}{\code{#3}}% + \doind{fn}{\code{#3}}% \doingtypefntrue \defname{#1}{#2}{#3}\defunargs{#4\unskip}% } @@ -7675,7 +7682,7 @@ % @deftypeop category class type name args \makedefun{deftypeop}#1 {\deftypeopheaderx{#1\ \putwordon}} \def\deftypeopheaderx#1#2 #3 #4 #5\endheader{% - \defind{fn}{\code{#4}\space\putwordon\ \code{#1\ \code{#2}}}% + \doind{fn}{\code{#4}\space\putwordon\ \code{#1\ \code{#2}}}% \doingtypefntrue \defname{#1\ \code{#2}}{#3}{#4}\defunargs{#5\unskip}% } @@ -7684,14 +7691,14 @@ % @deftypevr category type var args \makedefun{deftypevr}#1 #2 #3 #4\endheader{% - \defind{vr}{\code{#3}}% + \doind{vr}{\code{#3}}% \defname{#1}{#2}{#3}\defunargs{#4\unskip}% } % @deftypecv category class type var args \makedefun{deftypecv}#1 {\deftypecvheaderx{#1\ \putwordof}} \def\deftypecvheaderx#1#2 #3 #4 #5\endheader{% - \defind{vr}{\code{#4}\space\putwordof\ \code{#2}}% + \doind{vr}{\code{#4}\space\putwordof\ \code{#2}}% \defname{#1\ \code{#2}}{#3}{#4}\defunargs{#5\unskip}% } @@ -7708,7 +7715,7 @@ % @deftp category name args \makedefun{deftp}#1 #2 #3\endheader{% - \defind{tp}{\code{#2}}% + \doind{tp}{\code{#2}}% \defname{#1}{}{#2}\defunargs{#3\unskip}% } @@ -8580,6 +8587,87 @@ \fi \macnamexxx} +% @linemacro + +\parseargdef\linemacro{% + \linegetargs#1 \linegetargs + \expandafter\linegetparamlist\argl;% + \begingroup \macrobodyctxt \usembodybackslash + \parselinemacrobody +} + +% Parse the arguments to a @linemacro line. Set \macname to the name +% of the macro and \argl to the list of arguments. +\def\linegetargs#1 #2\linegetargs{% + \macname={#1}% + \def\argl{#2}% +} + +% Build up \paramlist which will be used as the parameter text for the macro. +% At the end it will be like "#1 #2 #3\endlinemacro". +\def\linegetparamlist#1;{% + \paramno=0\def\paramlist{}% + \let\hash\relax \let\xeatspaces\relax + \linegetparamlistxxx#1; % +} +\def\linegetparamlistxxx#1 {% + \if#1;\let\next=\linegetparamlistxxxx + \else \let\next=\linegetparamlistxxx + \advance\paramno by 1 + \expandafter\edef\csname macarg.\eatspaces{#1}\endcsname + {\noexpand\xeatspaces{\hash\the\paramno}}% + \edef\paramlist{\paramlist\hash\the\paramno\space}% + \fi\next} +\def\linegetparamlistxxxx{% + \ifx\paramlist\empty + \def\paramlist{\hash 1\endlinemacro}% + \else + \expandafter\fixparamlist\paramlist\fixparamlist + \fi +} +% Replace final space token +\def\fixparamlist#1 \fixparamlist{% + \def\paramlist{#1\endlinemacro}% +} + +% Read the body of the macro, replacing backslash-surrounded variables +% +{\catcode`\ =\other\long\gdef\parselinemacrobody#1@end linemacro{% +\let\xeatspaces\relax +\xdef\macrobody{#1}% +\endgroup +\linemacrodef +}} + +% Make the definition +\def\linemacrodef{% + \let\hash=##% + \let\xeatspaces\relax + \expandafter\xdef\csname\the\macname\endcsname{% + \bgroup + \noexpand\scanctxt + \noexpand\parsearg + \expandafter\noexpand\csname\the\macname @@\endcsname + } + \expandafter\xdef\csname\the\macname @@\endcsname##1{% + \egroup + \expandafter\noexpand + \csname\the\macname @@@\endcsname##1 \noexpand\endlinemacro + % Note that we append a space to the macro line to terminate the last + % argument in case the final argument is empty. @xeatspaces may be needed + % to remove this space. + } + \expandafter\expandafter + \expandafter\xdef + \expandafter\expandafter\csname\the\macname @@@\endcsname\paramlist{% + \newlinechar=13 % split \macrobody into lines + \let\noexpand\xeatspaces\noexpand\eatspaces + \noexpand\scantokens{\macrobody}% + } +} + + + % @alias. % We need some trickery to remove the optional spaces around the equal % sign. Make them active and then expand them all to nothing. diff --git a/lib/gnulib.mk.in b/lib/gnulib.mk.in index 53a821b141e..47d08a5e27f 100644 --- a/lib/gnulib.mk.in +++ b/lib/gnulib.mk.in @@ -156,7 +156,7 @@ # sys_stat \ # sys_time \ # tempname \ -# time \ +# time-h \ # time_r \ # time_rz \ # timegm \ @@ -595,6 +595,7 @@ GL_GNULIB_STRVERSCMP = @GL_GNULIB_STRVERSCMP@ GL_GNULIB_SYMLINK = @GL_GNULIB_SYMLINK@ GL_GNULIB_SYMLINKAT = @GL_GNULIB_SYMLINKAT@ GL_GNULIB_SYSTEM_POSIX = @GL_GNULIB_SYSTEM_POSIX@ +GL_GNULIB_TIME = @GL_GNULIB_TIME@ GL_GNULIB_TIMEGM = @GL_GNULIB_TIMEGM@ GL_GNULIB_TIMESPEC_GET = @GL_GNULIB_TIMESPEC_GET@ GL_GNULIB_TIMESPEC_GETRES = @GL_GNULIB_TIMESPEC_GETRES@ @@ -1209,6 +1210,7 @@ REPLACE_STRTOUMAX = @REPLACE_STRTOUMAX@ REPLACE_STRUCT_TIMEVAL = @REPLACE_STRUCT_TIMEVAL@ REPLACE_SYMLINK = @REPLACE_SYMLINK@ REPLACE_SYMLINKAT = @REPLACE_SYMLINKAT@ +REPLACE_TIME = @REPLACE_TIME@ REPLACE_TIMEGM = @REPLACE_TIMEGM@ REPLACE_TIMESPEC_GET = @REPLACE_TIMESPEC_GET@ REPLACE_TMPFILE = @REPLACE_TMPFILE@ @@ -3723,8 +3725,8 @@ EXTRA_DIST += tempname.h endif ## end gnulib module tempname -## begin gnulib module time -ifeq (,$(OMIT_GNULIB_MODULE_time)) +## begin gnulib module time-h +ifeq (,$(OMIT_GNULIB_MODULE_time-h)) BUILT_SOURCES += time.h @@ -3743,6 +3745,7 @@ time.h: time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $( -e 's/@''GNULIB_NANOSLEEP''@/$(GL_GNULIB_NANOSLEEP)/g' \ -e 's/@''GNULIB_STRFTIME''@/$(GL_GNULIB_STRFTIME)/g' \ -e 's/@''GNULIB_STRPTIME''@/$(GL_GNULIB_STRPTIME)/g' \ + -e 's/@''GNULIB_TIME''@/$(GL_GNULIB_TIME)/g' \ -e 's/@''GNULIB_TIMEGM''@/$(GL_GNULIB_TIMEGM)/g' \ -e 's/@''GNULIB_TIMESPEC_GET''@/$(GL_GNULIB_TIMESPEC_GET)/g' \ -e 's/@''GNULIB_TIMESPEC_GETRES''@/$(GL_GNULIB_TIMESPEC_GETRES)/g' \ @@ -3764,6 +3767,7 @@ time.h: time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $( -e 's|@''REPLACE_MKTIME''@|$(REPLACE_MKTIME)|g' \ -e 's|@''REPLACE_NANOSLEEP''@|$(REPLACE_NANOSLEEP)|g' \ -e 's|@''REPLACE_STRFTIME''@|$(REPLACE_STRFTIME)|g' \ + -e 's|@''REPLACE_TIME''@|$(REPLACE_TIME)|g' \ -e 's|@''REPLACE_TIMEGM''@|$(REPLACE_TIMEGM)|g' \ -e 's|@''REPLACE_TIMESPEC_GET''@|$(REPLACE_TIMESPEC_GET)|g' \ -e 's|@''REPLACE_TZSET''@|$(REPLACE_TZSET)|g' \ @@ -3782,7 +3786,7 @@ MOSTLYCLEANFILES += time.h time.h-t EXTRA_DIST += time.in.h endif -## end gnulib module time +## end gnulib module time-h ## begin gnulib module time_r ifeq (,$(OMIT_GNULIB_MODULE_time_r)) diff --git a/lib/stdio.in.h b/lib/stdio.in.h index 3f8ea985335..098f841738c 100644 --- a/lib/stdio.in.h +++ b/lib/stdio.in.h @@ -36,6 +36,12 @@ #ifndef _@GUARD_PREFIX@_STDIO_H +/* Suppress macOS deprecation warnings for sprintf and vsprintf. */ +#if (defined __APPLE__ && defined __MACH__) && !defined _POSIX_C_SOURCE +# define _POSIX_C_SOURCE 200809L +# define _GL_DEFINED__POSIX_C_SOURCE +#endif + #define _GL_ALREADY_INCLUDING_STDIO_H /* The include_next requires a split double-inclusion guard. */ @@ -43,6 +49,11 @@ #define _GL_ALREADY_INCLUDING_STDIO_H #undef _GL_ALREADY_INCLUDING_STDIO_H +#ifdef _GL_DEFINED__POSIX_C_SOURCE +# undef _GL_DEFINED__POSIX_C_SOURCE +# undef _POSIX_C_SOURCE +#endif + #ifndef _@GUARD_PREFIX@_STDIO_H #define _@GUARD_PREFIX@_STDIO_H diff --git a/lib/time.in.h b/lib/time.in.h index 87cda21413b..3f9af920e34 100644 --- a/lib/time.in.h +++ b/lib/time.in.h @@ -143,6 +143,20 @@ _GL_CXXALIAS_SYS (timespec_getres, int, (struct timespec *ts, int base)); _GL_CXXALIASWARN (timespec_getres); # endif +/* Return the number of seconds that have elapsed since the Epoch. */ +# if @GNULIB_TIME@ +# if @REPLACE_TIME@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# define time rpl_time +# endif +_GL_FUNCDECL_RPL (time, time_t, (time_t *__tp)); +_GL_CXXALIAS_RPL (time, time_t, (time_t *__tp)); +# else +_GL_CXXALIAS_SYS (time, time_t, (time_t *__tp)); +# endif +_GL_CXXALIASWARN (time); +# endif + /* Sleep for at least RQTP seconds unless interrupted, If interrupted, return -1 and store the remaining time into RMTP. See . */ diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 0658652a99e..1bd16a779eb 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -189,7 +189,7 @@ AC_DEFUN # Code from module sys_time: # Code from module sys_types: # Code from module tempname: - # Code from module time: + # Code from module time-h: # Code from module time_r: # Code from module time_rz: # Code from module timegm: diff --git a/m4/time_h.m4 b/m4/time_h.m4 index b74870c3d0e..51d553a2f1a 100644 --- a/m4/time_h.m4 +++ b/m4/time_h.m4 @@ -2,7 +2,7 @@ # Copyright (C) 2000-2001, 2003-2007, 2009-2023 Free Software Foundation, Inc. -# serial 21 +# serial 22 # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -137,6 +137,7 @@ AC_DEFUN gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_NANOSLEEP]) gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_STRFTIME]) gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_STRPTIME]) + gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_TIME]) gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_TIMEGM]) gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_TIMESPEC_GET]) gl_MODULE_INDICATOR_INIT_VARIABLE([GNULIB_TIMESPEC_GETRES]) @@ -169,6 +170,7 @@ AC_DEFUN REPLACE_MKTIME=GNULIB_PORTCHECK; AC_SUBST([REPLACE_MKTIME]) REPLACE_NANOSLEEP=GNULIB_PORTCHECK; AC_SUBST([REPLACE_NANOSLEEP]) REPLACE_STRFTIME=GNULIB_PORTCHECK; AC_SUBST([REPLACE_STRFTIME]) + REPLACE_TIME=0; AC_SUBST([REPLACE_TIME]) REPLACE_TIMEGM=GNULIB_PORTCHECK; AC_SUBST([REPLACE_TIMEGM]) REPLACE_TIMESPEC_GET=GNULIB_PORTCHECK; AC_SUBST([REPLACE_TIMESPEC_GET]) REPLACE_TZSET=GNULIB_PORTCHECK; AC_SUBST([REPLACE_TZSET]) commit d236ab09300070696f21ebfda49678b11c2327eb Author: Stefan Monnier Date: Fri Mar 10 15:54:10 2023 -0500 src/profiler.c: Keep track of the discarded counts When the table overflows and wh evict entries, keep track of those counts in a global counter so we can see the proportion of samples this represents. * src/profiler.c (struct profiler_log): Add `discarded` field. (evict_lower_half): Change arg to be `struct profiler_log`. Transfer counts to the new `discarded` field. (record_backtrace): Change arg to be `struct profiler_log`. (add_sample): Adjust call accordingly. (export_log): Add `discarded` counts to the result. Onle add the GC and `discarded` counts if they're non-zero. (syms_of_profiler): Define new symbol `Discarded Samples`. diff --git a/src/profiler.c b/src/profiler.c index d5a5a2cf5f3..6217071ef9c 100644 --- a/src/profiler.c +++ b/src/profiler.c @@ -51,7 +51,8 @@ saturated_add (EMACS_INT a, EMACS_INT b) struct profiler_log { Lisp_Object log; - EMACS_INT gc_count; + EMACS_INT gc_count; /* Samples taken during GC. */ + EMACS_INT discarded; /* Samples evicted during table overflow. */ }; static struct profiler_log @@ -70,7 +71,7 @@ make_log (void) DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD, Qnil, false), - 0 }; + 0, 0 }; struct Lisp_Hash_Table *h = XHASH_TABLE (log.log); /* What is special about our hash-tables is that the values are pre-filled @@ -123,8 +124,9 @@ make_log (void) } } -static void evict_lower_half (log_t *log) +static void evict_lower_half (struct profiler_log *plog) { + log_t *log = XHASH_TABLE (plog->log); ptrdiff_t size = ASIZE (log->key_and_value) / 2; EMACS_INT median = approximate_median (log, 0, size); @@ -134,6 +136,8 @@ make_log (void) if (XFIXNUM (HASH_VALUE (log, i)) <= median) { Lisp_Object key = HASH_KEY (log, i); + EMACS_INT count = XFIXNUM (HASH_VALUE (log, i)); + plog->discarded = saturated_add (plog->discarded, count); { /* FIXME: we could make this more efficient. */ Lisp_Object tmp; XSET_HASH_TABLE (tmp, log); /* FIXME: Use make_lisp_ptr. */ @@ -155,12 +159,12 @@ make_log (void) size for memory. */ static void -record_backtrace (log_t *log, EMACS_INT count) +record_backtrace (struct profiler_log *plog, EMACS_INT count) { + eassert (HASH_TABLE_P (plog->log)); + log_t *log = XHASH_TABLE (plog->log); if (log->next_free < 0) - /* FIXME: transfer the evicted counts to a special entry rather - than dropping them on the floor. */ - evict_lower_half (log); + evict_lower_half (plog); ptrdiff_t index = log->next_free; /* Get a "working memory" vector. */ @@ -240,7 +244,7 @@ record_backtrace (log_t *log, EMACS_INT count) /* Signal handler for sampling profiler. */ static void -add_sample (struct profiler_log *log, EMACS_INT count) +add_sample (struct profiler_log *plog, EMACS_INT count) { if (EQ (backtrace_top_function (), QAutomatic_GC)) /* bug#60237 */ /* Special case the time-count inside GC because the hash-table @@ -249,12 +253,9 @@ add_sample (struct profiler_log *log, EMACS_INT count) not expect the ARRAY_MARK_FLAG to be set. We could try and harden the hash-table code, but it doesn't seem worth the effort. */ - log->gc_count = saturated_add (log->gc_count, count); + plog->gc_count = saturated_add (plog->gc_count, count); else - { - eassert (HASH_TABLE_P (log->log)); - record_backtrace (XHASH_TABLE (log->log), count); - } + record_backtrace (plog, count); } @@ -424,9 +425,14 @@ DEFUN ("profiler-cpu-running-p", export_log (struct profiler_log *log) { Lisp_Object result = log->log; - Fputhash (CALLN (Fvector, QAutomatic_GC, Qnil), - make_fixnum (log->gc_count), - result); + if (log->gc_count) + Fputhash (CALLN (Fvector, QAutomatic_GC, Qnil), + make_fixnum (log->gc_count), + result); + if (log->discarded) + Fputhash (CALLN (Fvector, QDiscarded_Samples, Qnil), + make_fixnum (log->discarded), + result); /* Here we're making the log visible to Elisp, so it's not safe any more for our use afterwards since we can't rely on its special pre-allocated keys anymore. So we have to allocate a new one. */ @@ -595,6 +601,7 @@ syms_of_profiler (void) profiler_log_size = 10000; DEFSYM (Qprofiler_backtrace_equal, "profiler-backtrace-equal"); + DEFSYM (QDiscarded_Samples, "Discarded Samples"); defsubr (&Sfunction_equal); commit 83be04c66ffaec86aee136b9a94979169d1ba68d Author: Stefan Monnier Date: Fri Mar 10 15:30:20 2023 -0500 src/profiler.c: Share more code between CPU and Memory profilers * src/profiler.c (struct profiler_log): New type. (make_log): Use it. (cpu, memory): New vars to replace cpu_log, memory_log, cpu_gc_count, and mem_gc_count. (add_sample): New function, extracted from `handle_profiler_signal`. (handle_profiler_signal, malloc_probe): Use it. (Fprofiler_cpu_start, Fprofiler_memory_start): Adjust call to `make_log`. (export_log): New function, extracted from `Fprofiler_cpu_log`. (Fprofiler_cpu_log, Fprofiler_memory_log): Use it. (syms_of_profiler, syms_of_profiler_for_pdumper): Adjust to new `cpu` and `memory` vars. diff --git a/src/profiler.c b/src/profiler.c index b96f7211934..d5a5a2cf5f3 100644 --- a/src/profiler.c +++ b/src/profiler.c @@ -49,7 +49,12 @@ saturated_add (EMACS_INT a, EMACS_INT b) hashfn_profiler, }; -static Lisp_Object +struct profiler_log { + Lisp_Object log; + EMACS_INT gc_count; +}; + +static struct profiler_log make_log (void) { /* We use a standard Elisp hash-table object, but we use it in @@ -60,11 +65,13 @@ make_log (void) = clip_to_bounds (0, profiler_log_size, MOST_POSITIVE_FIXNUM); ptrdiff_t max_stack_depth = clip_to_bounds (0, profiler_max_stack_depth, PTRDIFF_MAX);; - Lisp_Object log = make_hash_table (hashtest_profiler, heap_size, - DEFAULT_REHASH_SIZE, - DEFAULT_REHASH_THRESHOLD, - Qnil, false); - struct Lisp_Hash_Table *h = XHASH_TABLE (log); + struct profiler_log log + = { make_hash_table (hashtest_profiler, heap_size, + DEFAULT_REHASH_SIZE, + DEFAULT_REHASH_THRESHOLD, + Qnil, false), + 0 }; + struct Lisp_Hash_Table *h = XHASH_TABLE (log.log); /* What is special about our hash-tables is that the values are pre-filled with the vectors we'll use as keys. */ @@ -222,13 +229,10 @@ record_backtrace (log_t *log, EMACS_INT count) profiler_cpu_running; /* Hash-table log of CPU profiler. */ -static Lisp_Object cpu_log; +static struct profiler_log cpu; -/* Separate counter for the time spent in the GC. */ -static EMACS_INT cpu_gc_count; - -/* Separate counter for the memory allocations during GC. */ -static EMACS_INT mem_gc_count; +/* Hash-table log of Memory profiler. */ +static struct profiler_log memory; /* The current sampling interval in nanoseconds. */ static EMACS_INT current_sampling_interval; @@ -236,30 +240,37 @@ record_backtrace (log_t *log, EMACS_INT count) /* Signal handler for sampling profiler. */ static void -handle_profiler_signal (int signal) +add_sample (struct profiler_log *log, EMACS_INT count) { - if (EQ (backtrace_top_function (), QAutomatic_GC)) + if (EQ (backtrace_top_function (), QAutomatic_GC)) /* bug#60237 */ /* Special case the time-count inside GC because the hash-table code is not prepared to be used while the GC is running. More specifically it uses ASIZE at many places where it does not expect the ARRAY_MARK_FLAG to be set. We could try and harden the hash-table code, but it doesn't seem worth the effort. */ - cpu_gc_count = saturated_add (cpu_gc_count, 1); + log->gc_count = saturated_add (log->gc_count, count); else { - EMACS_INT count = 1; + eassert (HASH_TABLE_P (log->log)); + record_backtrace (XHASH_TABLE (log->log), count); + } +} + + +static void +handle_profiler_signal (int signal) +{ + EMACS_INT count = 1; #if defined HAVE_ITIMERSPEC && defined HAVE_TIMER_GETOVERRUN - if (profiler_timer_ok) - { - int overruns = timer_getoverrun (profiler_timer); - eassert (overruns >= 0); - count += overruns; - } -#endif - eassert (HASH_TABLE_P (cpu_log)); - record_backtrace (XHASH_TABLE (cpu_log), count); + if (profiler_timer_ok) + { + int overruns = timer_getoverrun (profiler_timer); + eassert (overruns >= 0); + count += overruns; } +#endif + add_sample (&cpu, count); } static void @@ -346,11 +357,8 @@ DEFUN ("profiler-cpu-start", Fprofiler_cpu_start, Sprofiler_cpu_start, if (profiler_cpu_running) error ("CPU profiler is already running"); - if (NILP (cpu_log)) - { - cpu_gc_count = 0; - cpu_log = make_log (); - } + if (NILP (cpu.log)) + cpu = make_log (); int status = setup_cpu_timer (sampling_interval); if (status < 0) @@ -412,6 +420,21 @@ DEFUN ("profiler-cpu-running-p", return profiler_cpu_running ? Qt : Qnil; } +static Lisp_Object +export_log (struct profiler_log *log) +{ + Lisp_Object result = log->log; + Fputhash (CALLN (Fvector, QAutomatic_GC, Qnil), + make_fixnum (log->gc_count), + result); + /* Here we're making the log visible to Elisp, so it's not safe any + more for our use afterwards since we can't rely on its special + pre-allocated keys anymore. So we have to allocate a new one. */ + if (profiler_cpu_running) + *log = make_log (); + return result; +} + DEFUN ("profiler-cpu-log", Fprofiler_cpu_log, Sprofiler_cpu_log, 0, 0, 0, doc: /* Return the current cpu profiler log. @@ -421,16 +444,7 @@ DEFUN ("profiler-cpu-log", Fprofiler_cpu_log, Sprofiler_cpu_log, Before returning, a new log is allocated for future samples. */) (void) { - Lisp_Object result = cpu_log; - /* Here we're making the log visible to Elisp, so it's not safe any - more for our use afterwards since we can't rely on its special - pre-allocated keys anymore. So we have to allocate a new one. */ - cpu_log = profiler_cpu_running ? make_log () : Qnil; - Fputhash (CALLN (Fvector, QAutomatic_GC, Qnil), - make_fixnum (cpu_gc_count), - result); - cpu_gc_count = 0; - return result; + return (export_log (&cpu)); } #endif /* PROFILER_CPU_SUPPORT */ @@ -439,8 +453,6 @@ DEFUN ("profiler-cpu-log", Fprofiler_cpu_log, Sprofiler_cpu_log, /* True if memory profiler is running. */ bool profiler_memory_running; -static Lisp_Object memory_log; - DEFUN ("profiler-memory-start", Fprofiler_memory_start, Sprofiler_memory_start, 0, 0, 0, doc: /* Start/restart the memory profiler. @@ -453,11 +465,8 @@ DEFUN ("profiler-memory-start", Fprofiler_memory_start, Sprofiler_memory_start, if (profiler_memory_running) error ("Memory profiler is already running"); - if (NILP (memory_log)) - { - mem_gc_count = 0; - memory_log = make_log (); - } + if (NILP (memory.log)) + memory = make_log (); profiler_memory_running = true; @@ -496,16 +505,7 @@ DEFUN ("profiler-memory-log", Before returning, a new log is allocated for future samples. */) (void) { - Lisp_Object result = memory_log; - /* Here we're making the log visible to Elisp , so it's not safe any - more for our use afterwards since we can't rely on its special - pre-allocated keys anymore. So we have to allocate a new one. */ - memory_log = profiler_memory_running ? make_log () : Qnil; - Fputhash (CALLN (Fvector, QAutomatic_GC, Qnil), - make_fixnum (mem_gc_count), - result); - mem_gc_count = 0; - return result; + return (export_log (&memory)); } @@ -515,19 +515,7 @@ DEFUN ("profiler-memory-log", void malloc_probe (size_t size) { - if (EQ (backtrace_top_function (), QAutomatic_GC)) /* bug#60237 */ - /* Special case the malloc-count inside GC because the hash-table - code is not prepared to be used while the GC is running. - E.g. it uses ASIZE at many places where it does not expect - the ARRAY_MARK_FLAG to be set and in anyn case it'd modify the - heap behind the GC's back. */ - mem_gc_count = saturated_add (mem_gc_count, size); - else - { - eassert (HASH_TABLE_P (memory_log)); - record_backtrace (XHASH_TABLE (memory_log), - min (size, MOST_POSITIVE_FIXNUM)); - } + add_sample (&memory, min (size, MOST_POSITIVE_FIXNUM)); } DEFUN ("function-equal", Ffunction_equal, Sfunction_equal, 2, 2, 0, @@ -612,16 +600,16 @@ syms_of_profiler (void) #ifdef PROFILER_CPU_SUPPORT profiler_cpu_running = NOT_RUNNING; - cpu_log = Qnil; - staticpro (&cpu_log); + cpu.log = Qnil; + staticpro (&cpu.log); defsubr (&Sprofiler_cpu_start); defsubr (&Sprofiler_cpu_stop); defsubr (&Sprofiler_cpu_running_p); defsubr (&Sprofiler_cpu_log); #endif profiler_memory_running = false; - memory_log = Qnil; - staticpro (&memory_log); + memory.log = Qnil; + staticpro (&memory.log); defsubr (&Sprofiler_memory_start); defsubr (&Sprofiler_memory_stop); defsubr (&Sprofiler_memory_running_p); @@ -636,16 +624,16 @@ syms_of_profiler_for_pdumper (void) if (dumped_with_pdumper_p ()) { #ifdef PROFILER_CPU_SUPPORT - cpu_log = Qnil; + cpu.log = Qnil; #endif - memory_log = Qnil; + memory.log = Qnil; } else { #ifdef PROFILER_CPU_SUPPORT - eassert (NILP (cpu_log)); + eassert (NILP (cpu.log)); #endif - eassert (NILP (memory_log)); + eassert (NILP (memory.log)); } } commit f97d4b9e54c7de3f67d78be8c63afcdb6b704531 Author: Stefan Monnier Date: Fri Mar 10 15:05:55 2023 -0500 src/profiler.c: Try and fix occasional assertion failures Apparently the (>= match imatch) test fails sometimes in `profiler.el`. Not sure where this comes from, but this patch should remove one possible source. * src/profiler.c (Fprofiler_cpu_log, Fprofiler_memory_log): Change the special Automatic_GC backtrace to make it clear that it's a *sibling* of the call tree (i.e. it's at the (its own) root). (malloc_probe): Obey `size` when incrementing the gc_counter. diff --git a/src/profiler.c b/src/profiler.c index 92d8a0aea1c..b96f7211934 100644 --- a/src/profiler.c +++ b/src/profiler.c @@ -426,7 +426,7 @@ DEFUN ("profiler-cpu-log", Fprofiler_cpu_log, Sprofiler_cpu_log, more for our use afterwards since we can't rely on its special pre-allocated keys anymore. So we have to allocate a new one. */ cpu_log = profiler_cpu_running ? make_log () : Qnil; - Fputhash (make_vector (1, QAutomatic_GC), + Fputhash (CALLN (Fvector, QAutomatic_GC, Qnil), make_fixnum (cpu_gc_count), result); cpu_gc_count = 0; @@ -501,7 +501,7 @@ DEFUN ("profiler-memory-log", more for our use afterwards since we can't rely on its special pre-allocated keys anymore. So we have to allocate a new one. */ memory_log = profiler_memory_running ? make_log () : Qnil; - Fputhash (make_vector (1, QAutomatic_GC), + Fputhash (CALLN (Fvector, QAutomatic_GC, Qnil), make_fixnum (mem_gc_count), result); mem_gc_count = 0; @@ -518,11 +518,10 @@ malloc_probe (size_t size) if (EQ (backtrace_top_function (), QAutomatic_GC)) /* bug#60237 */ /* Special case the malloc-count inside GC because the hash-table code is not prepared to be used while the GC is running. - More specifically it uses ASIZE at many places where it does - not expect the ARRAY_MARK_FLAG to be set. We could try and - harden the hash-table code, but it doesn't seem worth the - effort. */ - mem_gc_count = saturated_add (mem_gc_count, 1); + E.g. it uses ASIZE at many places where it does not expect + the ARRAY_MARK_FLAG to be set and in anyn case it'd modify the + heap behind the GC's back. */ + mem_gc_count = saturated_add (mem_gc_count, size); else { eassert (HASH_TABLE_P (memory_log)); commit 9a5f2ac97ecd5f434690f04ed0b6573d2dd58148 Author: Eli Zaretskii Date: Fri Mar 10 14:54:52 2023 -0500 src/profiler.c: Keep track of allocations during GC Cargo-cult the `cpu_gc_count` code to `memory_gc_count`. * src/profiler.c (mem_gc_count): New var. (Fprofiler_memory_start): Initialize it. (Fprofiler_memory_log): Increment it. (Fprofiler_memory_log): Use it. diff --git a/src/profiler.c b/src/profiler.c index 8247b2e90c6..92d8a0aea1c 100644 --- a/src/profiler.c +++ b/src/profiler.c @@ -227,6 +227,9 @@ record_backtrace (log_t *log, EMACS_INT count) /* Separate counter for the time spent in the GC. */ static EMACS_INT cpu_gc_count; +/* Separate counter for the memory allocations during GC. */ +static EMACS_INT mem_gc_count; + /* The current sampling interval in nanoseconds. */ static EMACS_INT current_sampling_interval; @@ -451,7 +454,10 @@ DEFUN ("profiler-memory-start", Fprofiler_memory_start, Sprofiler_memory_start, error ("Memory profiler is already running"); if (NILP (memory_log)) - memory_log = make_log (); + { + mem_gc_count = 0; + memory_log = make_log (); + } profiler_memory_running = true; @@ -495,6 +501,10 @@ DEFUN ("profiler-memory-log", more for our use afterwards since we can't rely on its special pre-allocated keys anymore. So we have to allocate a new one. */ memory_log = profiler_memory_running ? make_log () : Qnil; + Fputhash (make_vector (1, QAutomatic_GC), + make_fixnum (mem_gc_count), + result); + mem_gc_count = 0; return result; } @@ -506,10 +516,19 @@ DEFUN ("profiler-memory-log", malloc_probe (size_t size) { if (EQ (backtrace_top_function (), QAutomatic_GC)) /* bug#60237 */ - /* FIXME: We should do something like what we did with `cpu_gc_count`. */ - return; - eassert (HASH_TABLE_P (memory_log)); - record_backtrace (XHASH_TABLE (memory_log), min (size, MOST_POSITIVE_FIXNUM)); + /* Special case the malloc-count inside GC because the hash-table + code is not prepared to be used while the GC is running. + More specifically it uses ASIZE at many places where it does + not expect the ARRAY_MARK_FLAG to be set. We could try and + harden the hash-table code, but it doesn't seem worth the + effort. */ + mem_gc_count = saturated_add (mem_gc_count, 1); + else + { + eassert (HASH_TABLE_P (memory_log)); + record_backtrace (XHASH_TABLE (memory_log), + min (size, MOST_POSITIVE_FIXNUM)); + } } DEFUN ("function-equal", Ffunction_equal, Sfunction_equal, 2, 2, 0, commit d5d2959217f7afc99f2636cafdb8ffe00e14dfae Author: Stefan Monnier Date: Fri Mar 10 12:22:43 2023 -0500 * lisp/progmodes/gud.el (gud-minor-menu-map): Fix thinko in last change diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index 42d64952d86..d5c8e37a37b 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -211,7 +211,9 @@ gud-minor-mode-map ;; We then merge them here into `gud-minor-mode-map'. :parent gud-menu-mode-map "" `(menu-item nil ,gud-text-menu-bar-map - :filter ,(lambda (map) (unless window-system map)))) + ;; Be careful to return an empty keymap rather than nil + ;; so as not to hide the parent's menus. + :filter ,(lambda (map) (if window-system '(keymap) map)))) (easy-menu-define gud-menu-map gud-menu-mode-map "Menu for `gud-mode'." commit 03cfede8f0aa952bde76fa595ca06770cc52e655 Author: Robert Pluim Date: Wed Feb 15 12:16:11 2023 +0100 Improve thing-at-point email detection * lisp/thingatpt.el (thing-at-point-email-regexp): Allow numbers at the start of the user portion, and disallow '.' at the start. Also disallow '.' at the start of the domain portion. * test/lisp/thingatpt-tests.el (thing-at-point-test-data): Add various email tests. Bug#61519 diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index 9363a474cb5..f3367290dee 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -645,7 +645,7 @@ thing-at-point-looking-at ;; Email addresses (defvar thing-at-point-email-regexp - "?" + "?" "A regular expression probably matching an email address. This does not match the real name portion, only the address, optionally with angle brackets.") diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index 0daf27f32ec..7cf41d2817b 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el @@ -72,7 +72,38 @@ thing-at-point-test-data ("" 1 url "ftp://ftp.example.net/abc/") ;; UUID, only hex is allowed ("01234567-89ab-cdef-ABCD-EF0123456789" 1 uuid "01234567-89ab-cdef-ABCD-EF0123456789") - ("01234567-89ab-cdef-ABCD-EF012345678G" 1 uuid nil)) + ("01234567-89ab-cdef-ABCD-EF012345678G" 1 uuid nil) + ;; email addresses + ("foo@example.com" 1 email "foo@example.com") + ("f@example.com" 1 email "f@example.com") + ("foo@example.com" 4 email "foo@example.com") + ("foo@example.com" 5 email "foo@example.com") + ("foo@example.com" 15 email "foo@example.com") + ("foo@example.com" 16 email "foo@example.com") + ("" 1 email "") + ("" 4 email "") + ("" 5 email "") + ("" 16 email "") + ("" 17 email "") + ;; email adresses containing numbers + ("foo1@example.com" 1 email "foo1@example.com") + ("1foo@example.com" 1 email "1foo@example.com") + ("11@example.com" 1 email "11@example.com") + ("1@example.com" 1 email "1@example.com") + ;; email adresses user portion containing dots + ("foo.bar@example.com" 1 email "foo.bar@example.com") + (".foobar@example.com" 1 email nil) + (".foobar@example.com" 2 email "foobar@example.com") + ;; email adresses domain portion containing dots and dashes + ("foobar@.example.com" 1 email nil) + ("foobar@-example.com" 1 email "foobar@-example.com") + ;; These are illegal, but thingatpt doesn't yet handle them + ;; ("foo..bar@example.com" 1 email nil) + ;; ("foobar@.example.com" 1 email nil) + ;; ("foobar@example..com" 1 email nil) + ;; ("foobar.@example.com" 1 email nil) + + ) "List of `thing-at-point' tests. Each list element should have the form commit 8ee205d232574e12921b052c7e93b7e16d6f1187 Author: Stefan Monnier Date: Thu Mar 9 16:19:16 2023 -0500 gud.el: Bring back the pseudo-tool-bar in text frames (bug#62041) commit 8bb5c1bfec0929f2ba419e1c503f5acc01c336c2 accidentally threw away the pseudo-tool-bar implemented in the text frames' menu-bar of gud-minor-mode buffers. Bring it back, and while we're at it, improve it so it also works right when you have both text and GUI frames. Also fix a misunderstanding in last change (`gud-mode-map` does need to have a Gud menu, because `gud-mode` buffers already have it by virtue of being in `gud-minor-mode` as well). * lisp/progmodes/gud.el (gud-text-menu-bar-map): New keymap. (gud-menu-mode-map): Rename from `gud-shared-mode-map`. (gud-menu-map): Adjust accordingly. (gud-minor-mode-map): Use them. (gud-mode-map): Don't inherit from the shared/menu keymap. diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index cfe5f75d19f..42d64952d86 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -159,17 +159,61 @@ gud-stop-subjob (t (comint-interrupt-subjob))))) -(defvar-keymap gud-shared-mode-map +(defvar-keymap gud-text-menu-bar-map + :doc "Menu-bar keymap used in GUD buffers on text frames." + ;; Use the menu-bar as a pseudo-tool-bar. + "" `(,(propertize "down" 'face 'font-lock-doc-face) . gud-down) + "" `(,(propertize "up" 'face 'font-lock-doc-face) . gud-up) + "" `(,(propertize "finish" 'face 'font-lock-doc-face) . gud-finish) + "" `(,(propertize "step" 'face 'font-lock-doc-face) . gud-step) + "" `(,(propertize "next" 'face 'font-lock-doc-face) . gud-next) + "" `(menu-item + ,(propertize "until" 'face 'font-lock-doc-face) gud-until + :visible (memq gud-minor-mode '(gdbmi gdb perldb))) + "" `(menu-item + ,(propertize "cont" 'face 'font-lock-doc-face) gud-cont + :visible (not (eq gud-minor-mode 'gdbmi))) + "" `(menu-item + ,(propertize "run" 'face 'font-lock-doc-face) gud-run + :visible (memq gud-minor-mode '(gdbmi gdb dbx jdb))) + "" `(menu-bar-item + ,(propertize " go " 'face 'font-lock-doc-face) gud-go + :visible (and (eq gud-minor-mode 'gdbmi) + (gdb-show-run-p))) + "" `(menu-item + ,(propertize "stop" 'face 'font-lock-doc-face) gud-stop-subjob + :visible (or (and (eq gud-minor-mode 'gdbmi) + (gdb-show-stop-p)) + (not (eq gud-minor-mode 'gdbmi)))) + "" `(,(propertize "print" 'face 'font-lock-doc-face) . gud-print) + ;; Hide the usual menus to make room. + "" #'undefined + "" #'undefined + "" #'undefined + "" #'undefined + "" #'undefined) + +(defvar-keymap gud-menu-mode-map :doc "Keymap shared between `gud-mode' and `gud-minor-mode'.") (defvar-keymap gud-mode-map :doc "`gud-mode' keymap." - :parent (make-composed-keymap gud-shared-mode-map comint-mode-map)) + ;; BEWARE: `gud-mode-map' does not inherit from something like + ;; `gud-menu-mode-map' because the `gud-mode' buffer is also in + ;; `gud-minor-mode'. + ;;:parent (make-composed-keymap gud-menu-mode-map comint-mode-map) + ) (defvar-keymap gud-minor-mode-map - :parent gud-shared-mode-map) - -(easy-menu-define gud-menu-map gud-shared-mode-map + ;; Part of the menu is dynamic, so we use 2 keymaps: `gud-menu-mode-map' + ;; is the static/normal menu defined with easy-menu, and + ;; `gud-text-menu-bar-map' is the part that's only used on text frames. + ;; We then merge them here into `gud-minor-mode-map'. + :parent gud-menu-mode-map + "" `(menu-item nil ,gud-text-menu-bar-map + :filter ,(lambda (map) (unless window-system map)))) + +(easy-menu-define gud-menu-map gud-menu-mode-map "Menu for `gud-mode'." '("Gud" ["Continue" gud-cont @@ -279,7 +323,7 @@ gud-tool-bar-map (gud-goto-info . "info")) map) (tool-bar-local-item-from-menu - (car x) (cdr x) map gud-minor-mode-map)))) + (car x) (cdr x) map gud-menu-mode-map)))) (defvar gud-gdb-repeat-map (let ((map (make-sparse-keymap))) commit 26740f30469c2b13765f986fa65eca8a3a851ba2 Author: Manuel Giraud Date: Thu Mar 2 19:16:19 2023 +0100 Use a face for DocView SVG * lisp/doc-view.el (doc-view-svg-face): New face for SVG images. (doc-view-insert-image): Use it. (Bug#61816) diff --git a/etc/NEWS b/etc/NEWS index 540b59a628f..13d073c7fb8 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -214,6 +214,12 @@ bound to 'C-c C-d' in 'go-ts-mode'. When this is non-nil, call the 'man' program synchronously rather than asynchronously (which is the default behavior). +** DocView + +--- +*** New face 'doc-view-svg-face'. +This replaces 'doc-view-svg-foreground' and 'doc-view-svg-background'. + * New Modes and Packages in Emacs 30.1 diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 0303fec67a6..b14655fb274 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -236,17 +236,14 @@ doc-view-imenu-flatten :type 'boolean :version "29.1") -(defcustom doc-view-svg-background "white" - "Background color for svg images. +(defface doc-view-svg-face '((t :inherit default)) + "Face used for SVG images. Only background and foreground colors +are used. See `doc-view-mupdf-use-svg'." - :type 'color - :version "29.1") + :version "30.1") -(defcustom doc-view-svg-foreground "black" - "Foreground color for svg images. -See `doc-view-mupdf-use-svg'." - :type 'color - :version "29.1") +(make-obsolete 'doc-view-svg-background 'doc-view-svg-face "30.1") +(make-obsolete 'doc-view-svg-foreground 'doc-view-svg-face "30.1") (defcustom doc-view-ghostscript-options '("-dSAFER" ;; Avoid security problems when rendering files from untrusted @@ -1602,8 +1599,8 @@ doc-view-insert-image (unless (member :transform-smoothing args) (setq args `(,@args :transform-smoothing t))) (when (eq doc-view--image-type 'svg) - (setq args `(,@args :background ,doc-view-svg-background - :foreground ,doc-view-svg-foreground))) + (setq args `(,@args :background ,(face-background 'doc-view-svg-face) + :foreground ,(face-foreground 'doc-view-svg-face)))) (apply #'create-image file doc-view--image-type nil args)))) (slice (doc-view-current-slice)) (img-width (and image (car (image-size image)))) commit 54949f0669d9b9b5595091a660f6ec64a7392bdb Author: Manuel Giraud Date: Thu Mar 2 17:53:26 2023 +0100 Fix out of sync counters in image-dired * lisp/image/image-dired.el (image-dired-delete-char): Update thumbnails counter upon deletion. (image-dired--update-header-line): Compute thumbnail index dynamically. (image-dired-insert-thumbnail): Remove now unused image-number text property. (Bug#61922) diff --git a/lisp/image/image-dired.el b/lisp/image/image-dired.el index 6ecb307ce12..b13b3e08ce2 100644 --- a/lisp/image/image-dired.el +++ b/lisp/image/image-dired.el @@ -424,11 +424,10 @@ image-dired--get-create-thumbnail-file (file-name-nondirectory thumb-file))) thumb-file)) -(defun image-dired-insert-thumbnail ( file original-file-name - associated-dired-buffer image-number) +(defun image-dired-insert-thumbnail (file original-file-name + associated-dired-buffer) "Insert thumbnail image FILE. -Add text properties ORIGINAL-FILE-NAME, ASSOCIATED-DIRED-BUFFER -and IMAGE-NUMBER." +Add text properties ORIGINAL-FILE-NAME, ASSOCIATED-DIRED-BUFFER." (let (beg end) (setq beg (point)) (image-dired-insert-image @@ -452,7 +451,6 @@ image-dired-insert-thumbnail 'keymap nil 'original-file-name original-file-name 'associated-dired-buffer associated-dired-buffer - 'image-number image-number 'tags (image-dired-list-tags original-file-name) 'mouse-face 'highlight 'comment (image-dired-get-comment original-file-name))))) @@ -587,8 +585,8 @@ image-dired-display-thumbs (dolist (file files) (when (string-match-p (image-dired--file-name-regexp) file) (image-dired-insert-thumbnail - (image-dired--get-create-thumbnail-file file) file dired-buf - (cl-incf image-dired--number-of-thumbnails))))) + (image-dired--get-create-thumbnail-file file) file dired-buf) + (cl-incf image-dired--number-of-thumbnails)))) (if (> image-dired--number-of-thumbnails 0) (if do-not-pop (display-buffer buf) @@ -789,7 +787,10 @@ image-dired--update-header-line (let ((file-name (image-dired-original-file-name)) (dired-buf (buffer-name (image-dired-associated-dired-buffer))) (image-count (format "%s/%s" - (get-text-property (point) 'image-number) + ;; Line-up adds one space between two + ;; images: this formula takes this into + ;; account. + (1+ (/ (point) 2)) image-dired--number-of-thumbnails)) (props (string-join (get-text-property (point) 'tags) ", ")) (comment (get-text-property (point) 'comment)) @@ -1127,10 +1128,12 @@ image-dired-delete-char "Remove current thumbnail from thumbnail buffer and line up." (interactive nil image-dired-thumbnail-mode) (let ((inhibit-read-only t)) - (delete-char 1)) + (delete-char 1) + (cl-decf image-dired--number-of-thumbnails)) (let ((pos (point))) (image-dired--line-up-with-method) - (goto-char pos))) + (goto-char pos) + (image-dired--update-header-line))) (defun image-dired-line-up () "Line up thumbnails according to `image-dired-thumbs-per-row'.