From ed37f038bd6d99fbe0c746d5773c315fed0e3dad Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Tue, 24 Mar 2020 16:56:10 +0200 Subject: [PATCH 01/37] Fix sending signals and EOF to the inferior process in gdb-mi.el * lisp/progmodes/gdb-mi.el (gdb-io-interrupt, gdb-io-quit) (gdb-io-stop, gdb-io-eof): Send signal/EOF to the inferior process, not to GDB. (Bug#40210) --- lisp/progmodes/gdb-mi.el | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index ea3b1b816a8..7fb36873918 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -1729,25 +1729,25 @@ this trigger is subscribed to `gdb-buf-publisher' and called with "Interrupt the program being debugged." (interactive) (interrupt-process - (get-buffer-process gud-comint-buffer) comint-ptyp)) + (get-buffer-process (gdb-get-buffer-create 'gdb-inferior-io)) comint-ptyp)) (defun gdb-io-quit () "Send quit signal to the program being debugged." (interactive) (quit-process - (get-buffer-process gud-comint-buffer) comint-ptyp)) + (get-buffer-process (gdb-get-buffer-create 'gdb-inferior-io)) comint-ptyp)) (defun gdb-io-stop () "Stop the program being debugged." (interactive) (stop-process - (get-buffer-process gud-comint-buffer) comint-ptyp)) + (get-buffer-process (gdb-get-buffer-create 'gdb-inferior-io)) comint-ptyp)) (defun gdb-io-eof () "Send end-of-file to the program being debugged." (interactive) (process-send-eof - (get-buffer-process gud-comint-buffer))) + (get-buffer-process (gdb-get-buffer-create 'gdb-inferior-io)))) (defun gdb-clear-inferior-io () (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io) From 421eeff243af683bf0b7c6d9181650a1c6900f9b Mon Sep 17 00:00:00 2001 From: Philip K Date: Tue, 17 Mar 2020 15:29:53 +0100 Subject: [PATCH 02/37] Add support for multiple Gravatar services Now supports Libravatar and Unicornify, next to Gravatar (Bug#39965). * lisp/image/gravatar.el (gravatar-base-url): Remove constant. (gravatar-service-alist): List supported services. (gravatar-service): Add user option to specify service, defaults to Libravatar. (gravatar--service-libravatar): New function, libravatar image host resolver implementation. (gravatar-build-url): Use alist gravatar-service-alist instead of gravatar-base-url. * etc/NEWS: Mention new gravatar service option. --- etc/NEWS | 6 ++++++ lisp/image/gravatar.el | 43 ++++++++++++++++++++++++++++++++++++++---- 2 files changed, 45 insertions(+), 4 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index ba3e691ff91..2150f49b432 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -186,6 +186,12 @@ key binding / v package-menu-filter-by-version / / package-menu-filter-clear +** Gravatar + +=== +*** New user option 'gravatar-service' for host to query for gravatars. +Defaults to Libravatar, with Unicornify and Gravatar as options. + * New Modes and Packages in Emacs 28.1 diff --git a/lisp/image/gravatar.el b/lisp/image/gravatar.el index b8542bc3c35..e13f0075f3c 100644 --- a/lisp/image/gravatar.el +++ b/lisp/image/gravatar.el @@ -26,6 +26,7 @@ (require 'url) (require 'url-cache) +(require 'dns) (eval-when-compile (require 'subr-x)) @@ -118,9 +119,42 @@ a gravatar for a given email address." :version "27.1" :group 'gravatar) -(defconst gravatar-base-url - "https://www.gravatar.com/avatar" - "Base URL for getting gravatars.") +(defconst gravatar-service-alist + `((gravatar . ,(lambda (_addr) "https://www.gravatar.com/avatar")) + (unicornify . ,(lambda (_addr) "https://unicornify.pictures/avatar/")) + (libravatar . ,#'gravatar--service-libravatar)) + "Alist of supported gravatar services.") + +(defcustom gravatar-service 'libravatar + "Symbol denoting gravatar-like service to use. +Note that certain services might ignore other options, such as +`gravatar-default-image' or certain values as with +`gravatar-rating'." + :type `(choice ,@(mapcar (lambda (s) `(const ,(car s))) + gravatar-service-alist)) + :version "28.1" + :link '(url-link "https://www.libravatar.org/") + :link '(url-link "https://unicornify.pictures/") + :link '(url-link "https://gravatar.com/") + :group 'gravatar) + +(defun gravatar--service-libravatar (addr) + "Find domain that hosts avatars for email address ADDR." + ;; implements https://wiki.libravatar.org/api/ + (save-match-data + (unless (string-match ".+@\\(.+\\)" addr) + (error "%s is not an email address" addr)) + (let ((domain (match-string 1 addr))) + (catch 'found + (dolist (record '(("_avatars-sec" . "https") + ("_avatars" . "http"))) + (let* ((query (concat (car record) "._tcp." domain)) + (result (dns-query query 'SRV))) + (when result + (throw 'found (format "%s://%s/avatar" + (cdr record) + result))))) + "https://seccdn.libravatar.org/avatar")))) (defun gravatar-hash (mail-address) "Return the Gravatar hash for MAIL-ADDRESS." @@ -142,7 +176,8 @@ a gravatar for a given email address." "Return the URL of a gravatar for MAIL-ADDRESS." ;; https://gravatar.com/site/implement/images/ (format "%s/%s?%s" - gravatar-base-url + (funcall (alist-get gravatar-service gravatar-service-alist) + mail-address) (gravatar-hash mail-address) (gravatar--query-string))) From c3447e76ea05d12af418b9db7b1cd4ff19201c6a Mon Sep 17 00:00:00 2001 From: Eric Abrahamsen Date: Tue, 24 Mar 2020 13:08:30 -0700 Subject: [PATCH 03/37] ; * etc/NEWS: Clarify news entry for message-draft-headers change --- etc/NEWS | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/etc/NEWS b/etc/NEWS index 2150f49b432..308c5411985 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -114,7 +114,11 @@ the details of marking the last file at the end of the region. --- *** Change to default value of 'message-draft-headers' option. -No longer includes the Date header. +The Date header has been removed from the default value, meaning that +draft or delayed messages will get a Date reflecting when the message +was sent. To restore the original behavior of dating a message +from when it is first saved or delayed, add the symbol 'Date back to +this option. ** Help From 0fe7200418471bd237a39887d0798ba99631e3ac Mon Sep 17 00:00:00 2001 From: Robert Pluim Date: Tue, 24 Mar 2020 21:19:23 +0100 Subject: [PATCH 04/37] ; fix previous commit --- etc/NEWS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/etc/NEWS b/etc/NEWS index 308c5411985..60d22a70ce4 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -192,7 +192,7 @@ key binding ** Gravatar -=== +--- *** New user option 'gravatar-service' for host to query for gravatars. Defaults to Libravatar, with Unicornify and Gravatar as options. From e906cd0d58f3197edf15ccb843bc2577b879af61 Mon Sep 17 00:00:00 2001 From: Robert Pluim Date: Tue, 24 Mar 2020 22:21:26 +0100 Subject: [PATCH 05/37] Fix gravatar tests * lisp/image/gravatar.el (gravatar--service-libravatar): Don't error when failing to parse email address, just return the default URL. * test/lisp/image/gravatar-tests.el (gravatar-build-url): Adjust for new default gravatar url. --- lisp/image/gravatar.el | 26 +++++++++++++------------- test/lisp/image/gravatar-tests.el | 2 +- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/lisp/image/gravatar.el b/lisp/image/gravatar.el index e13f0075f3c..ff59a72ac87 100644 --- a/lisp/image/gravatar.el +++ b/lisp/image/gravatar.el @@ -142,19 +142,19 @@ Note that certain services might ignore other options, such as "Find domain that hosts avatars for email address ADDR." ;; implements https://wiki.libravatar.org/api/ (save-match-data - (unless (string-match ".+@\\(.+\\)" addr) - (error "%s is not an email address" addr)) - (let ((domain (match-string 1 addr))) - (catch 'found - (dolist (record '(("_avatars-sec" . "https") - ("_avatars" . "http"))) - (let* ((query (concat (car record) "._tcp." domain)) - (result (dns-query query 'SRV))) - (when result - (throw 'found (format "%s://%s/avatar" - (cdr record) - result))))) - "https://seccdn.libravatar.org/avatar")))) + (if (not (string-match ".+@\\(.+\\)" addr)) + "https://seccdn.libravatar.org/avatar" + (let ((domain (match-string 1 addr))) + (catch 'found + (dolist (record '(("_avatars-sec" . "https") + ("_avatars" . "http"))) + (let* ((query (concat (car record) "._tcp." domain)) + (result (dns-query query 'SRV))) + (when result + (throw 'found (format "%s://%s/avatar" + (cdr record) + result))))) + "https://seccdn.libravatar.org/avatar"))))) (defun gravatar-hash (mail-address) "Return the Gravatar hash for MAIL-ADDRESS." diff --git a/test/lisp/image/gravatar-tests.el b/test/lisp/image/gravatar-tests.el index e66b5c6803d..66098fa0116 100644 --- a/test/lisp/image/gravatar-tests.el +++ b/test/lisp/image/gravatar-tests.el @@ -67,6 +67,6 @@ (gravatar-force-default nil) (gravatar-size nil)) (should (equal (gravatar-build-url "foo") "\ -https://www.gravatar.com/avatar/acbd18db4cc2f85cedef654fccc4a4d8?r=g")))) +https://seccdn.libravatar.org/avatar/acbd18db4cc2f85cedef654fccc4a4d8?r=g")))) ;;; gravatar-tests.el ends here From ce141686d2d890d9d7c3dd881dc5f9bfb5d6d296 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Tue, 24 Mar 2020 23:58:01 +0200 Subject: [PATCH 06/37] Rename dired-mark-region choices and ignore empty region. * lisp/dired.el (dired-mark-region): Rename choices 'exclusive' to 'file', and 'inclusive' to 'line'. (dired-mark-if, dired-mark): Check for non-empty region explicitly instead of using use-region-p to ignore non-nil value of use-empty-active-region. (Bug#39902) --- etc/NEWS | 4 ++-- lisp/dired.el | 33 ++++++++++++++++++++------------- 2 files changed, 22 insertions(+), 15 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 60d22a70ce4..1be5ad6acc0 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -104,8 +104,8 @@ shows equivalent key bindings for all commands that have them. *** New option 'dired-mark-region' affects all Dired commands that mark files. When non-nil and the region is active in Transient Mark mode, then Dired commands operate only on files in the active region. -The values 'exclusive' and 'inclusive' of this option define -the details of marking the last file at the end of the region. +The values 'file' and 'line' of this option define the details of +marking the file at the end of the region. *** State changing VC operations are supported in dired-mode on files (but still not on directories). diff --git a/lisp/dired.el b/lisp/dired.el index 438f5e7d8b4..41bbf9f56a2 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -296,7 +296,7 @@ new Dired buffers." :version "26.1" :group 'dired) -(defcustom dired-mark-region 'exclusive +(defcustom dired-mark-region 'file "Defines what commands that mark files do with the active region. When nil, marking commands don't operate on all files in the @@ -306,7 +306,8 @@ When the value of this option is non-nil, then all Dired commands that mark or unmark files will operate on all files in the region if the region is active in Transient Mark mode. -When `exclusive', don't mark the file if the end of the region is +When `file', the region marking is based on the file name. +This means don't mark the file if the end of the region is before the file name displayed on the Dired line, so the file name is visually outside the region. This behavior is consistent with marking files without the region using the key `m' that advances @@ -315,12 +316,13 @@ of keys used to mark files is the same as the number of keys used to select the region, e.g. `M-2 m' marks 2 files, and `C-SPC M-2 n m' marks 2 files, and `M-2 S-down m' marks 2 files. -When `inclusive', include the file into marking if the end of the region +When `line', the region marking is based on Dired lines, +so include the file into marking if the end of the region is anywhere on its Dired line, except the beginning of the line." :type '(choice (const :tag "Don't mark files in active region" nil) - (const :tag "Exclude file name outside of region" exclusive) - (const :tag "Include the file at region end line" inclusive)) + (const :tag "Exclude file name outside of region" file) + (const :tag "Include the file at region end line" line)) :group 'dired :version "28.1") @@ -646,16 +648,19 @@ of the region if `dired-mark-region' is non-nil. Otherwise, operate on the whole buffer. Return value is the number of files marked, or nil if none were marked." - `(let ((inhibit-read-only t) count - (beg (if (and dired-mark-region (use-region-p)) + `(let* ((inhibit-read-only t) count + (use-region-p (and dired-mark-region + (region-active-p) + (> (region-end) (region-beginning)))) + (beg (if use-region-p (save-excursion (goto-char (region-beginning)) (line-beginning-position)) (point-min))) - (end (if (and dired-mark-region (use-region-p)) + (end (if use-region-p (save-excursion (goto-char (region-end)) - (if (if (eq dired-mark-region 'inclusive) + (if (if (eq dired-mark-region 'line) (not (bolp)) (get-text-property (1- (point)) 'dired-filename)) (line-end-position) @@ -673,7 +678,7 @@ Return value is the number of files marked, or nil if none were marked." (if (eq dired-del-marker dired-marker-char) " for deletion" "") - (if (and dired-mark-region (use-region-p)) + (if use-region-p " in region" ""))) (goto-char beg) @@ -691,7 +696,7 @@ Return value is the number of files marked, or nil if none were marked." (if (eq dired-marker-char ?\s) "un" "") (if (eq dired-marker-char dired-del-marker) "flagged" "marked") - (if (and dired-mark-region (use-region-p)) + (if use-region-p " in region" "")))) (and (> count 0) count))) @@ -3645,14 +3650,16 @@ this subdir." (interactive (list current-prefix-arg t)) (cond ;; Mark files in the active region. - ((and dired-mark-region interactive (use-region-p)) + ((and interactive dired-mark-region + (region-active-p) + (> (region-end) (region-beginning))) (save-excursion (let ((beg (region-beginning)) (end (region-end))) (dired-mark-files-in-region (progn (goto-char beg) (line-beginning-position)) (progn (goto-char end) - (if (if (eq dired-mark-region 'inclusive) + (if (if (eq dired-mark-region 'line) (not (bolp)) (get-text-property (1- (point)) 'dired-filename)) (line-end-position) From 74489bdcb663722b1747f6a3f81f1f111c751f04 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Wed, 25 Mar 2020 16:18:37 +0200 Subject: [PATCH 07/37] Improve the UI of 'list-timers' * lisp/emacs-lisp/timer-list.el (list-timers): Display both "Next" and "Repeat" in units of seconds, for consistency. (timer-list-mode): Add help-echo to column headers. --- lisp/emacs-lisp/timer-list.el | 15 +++++++++++++-- lisp/ls-lisp.el | 6 +++--- 2 files changed, 16 insertions(+), 5 deletions(-) diff --git a/lisp/emacs-lisp/timer-list.el b/lisp/emacs-lisp/timer-list.el index 4fa31f32673..4cebd739c3b 100644 --- a/lisp/emacs-lisp/timer-list.el +++ b/lisp/emacs-lisp/timer-list.el @@ -52,7 +52,7 @@ (let ((repeat (aref timer 4))) (cond ((numberp repeat) - (format "%.2f" (/ repeat 60))) + (format "%.1f" repeat)) ((null repeat) "-") (t @@ -91,7 +91,18 @@ (setq header-line-format (concat (propertize " " 'display '(space :align-to 0)) (format "%4s %10s %8s %s" - "Idle" "Next" "Repeat" "Function")))) + (propertize "Idle" + 'mouse-face 'highlight + 'help-echo "* marks idle timers") + (propertize "Next" + 'mouse-face 'highlight + 'help-echo "Time in sec till next invocation") + (propertize "Repeat" + 'mouse-face 'highlight + 'help-echo "Symbol: repeat; number: repeat interval in sec") + (propertize "Function" + 'mouse-face 'highlight + 'help-echo "Function called by timer"))))) (defun timer-list-cancel () "Cancel the timer on the line under point." diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el index 2952242c251..8851522bbdb 100644 --- a/lisp/ls-lisp.el +++ b/lisp/ls-lisp.el @@ -435,9 +435,9 @@ not contain `d', so that a full listing is expected." ;; text. But if the listing is empty, as e.g. in empty ;; directories with -a removed from switches, point will be ;; before the inserted text, and dired-insert-directory will - ;; not indent the listing correctly. Going to the end of the - ;; buffer fixes that. - (unless files (goto-char (point-max))) + ;; not indent the listing correctly. Getting past the + ;; inserted text solves this. + (unless (cdr total-line) (forward-line 2)) (if (memq ?R switches) ;; List the contents of all directories recursively. ;; cadr of each element of `file-alist' is t for From 11b37a4167d2eee4cb1f467a7f8ebaa6c8667ce9 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 25 Mar 2020 14:09:48 -0400 Subject: [PATCH 08/37] * lisp/textmodes/conf-mode.el (conf-mode): Fix last change `delay-mode-hooks` cannot be tested from within `define-derived-mode` because it's always non-nil in there, so arrange to test it before we enter the body. --- lisp/textmodes/conf-mode.el | 44 ++++++++++++++++++++----------------- 1 file changed, 24 insertions(+), 20 deletions(-) diff --git a/lisp/textmodes/conf-mode.el b/lisp/textmodes/conf-mode.el index 79312757a2d..722fc0a3137 100644 --- a/lisp/textmodes/conf-mode.el +++ b/lisp/textmodes/conf-mode.el @@ -405,27 +405,31 @@ See also `conf-space-mode', `conf-colon-mode', `conf-javaprop-mode', \\{conf-mode-map}" - ;; `conf-mode' plays two roles: it's the parent of several sub-modes - ;; but it's also the function that chooses between those submodes. - ;; To tell the difference between those two cases where the function - ;; might be called, we check `delay-mode-hooks'. - ;; (adopted from tex-mode.el) - (if (not delay-mode-hooks) - (funcall (conf--guess-mode)) + (setq-local font-lock-defaults '(conf-font-lock-keywords nil t nil nil)) + ;; Let newcomment.el decide this for itself. + ;; (setq-local comment-use-syntax t) + (setq-local parse-sexp-ignore-comments t) + (setq-local outline-regexp "[ \t]*\\(?:\\[\\|.+[ \t\n]*{\\)") + (setq-local outline-heading-end-regexp "[\n}]") + (setq-local outline-level #'conf-outline-level) + (setq-local imenu-generic-expression + '(("Parameters" "^[ \t]*\\(.+?\\)[ \t]*=" 1) + ;; [section] + (nil "^[ \t]*\\[[ \t]*\\(.+\\)[ \t]*\\]" 1) + ;; section { ... } + (nil "^[ \t]*\\([^=:{} \t\n][^=:{}\n]+\\)[ \t\n]*{" 1)))) + +;; `conf-mode' plays two roles: it's the parent of several sub-modes +;; but it's also the function that chooses between those submodes. +;; To tell the difference between those two cases where the function +;; might be called, we check `delay-mode-hooks'. +;; (inspired from tex-mode.el) +(advice-add 'conf-mode :around + (lambda (orig-fun) + "Redirect to one of the submodes when called directly." + (funcall (if delay-mode-hooks orig-fun (conf--guess-mode))))) + - (setq-local font-lock-defaults '(conf-font-lock-keywords nil t nil nil)) - ;; Let newcomment.el decide this for itself. - ;; (setq-local comment-use-syntax t) - (setq-local parse-sexp-ignore-comments t) - (setq-local outline-regexp "[ \t]*\\(?:\\[\\|.+[ \t\n]*{\\)") - (setq-local outline-heading-end-regexp "[\n}]") - (setq-local outline-level #'conf-outline-level) - (setq-local imenu-generic-expression - '(("Parameters" "^[ \t]*\\(.+?\\)[ \t]*=" 1) - ;; [section] - (nil "^[ \t]*\\[[ \t]*\\(.+\\)[ \t]*\\]" 1) - ;; section { ... } - (nil "^[ \t]*\\([^=:{} \t\n][^=:{}\n]+\\)[ \t\n]*{" 1))))) (defun conf-mode-initialize (comment &optional font-lock) "Initializations for sub-modes of `conf-mode'. From 2ea87d6c6f1161801402958bdc6b6a2e6c41c6b8 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Wed, 25 Mar 2020 13:37:23 -0700 Subject: [PATCH 09/37] Pacify --enable-gcc-warnings for lock_file * src/filelock.c (lock_file): Pacify gcc -Wmaybe-uninitialized after recent change to this function. --- src/filelock.c | 24 +++++++++--------------- 1 file changed, 9 insertions(+), 15 deletions(-) diff --git a/src/filelock.c b/src/filelock.c index 2b734ee00d5..ee46e0e3e00 100644 --- a/src/filelock.c +++ b/src/filelock.c @@ -661,7 +661,7 @@ void lock_file (Lisp_Object fn) { Lisp_Object orig_fn, encoded_fn; - char *lfname; + char *lfname = NULL; lock_info_type lock_info; USE_SAFE_ALLOCA; @@ -686,21 +686,15 @@ lock_file (Lisp_Object fn) /* See if this file is visited and has changed on disk since it was visited. */ - { - register Lisp_Object subject_buf; - - subject_buf = get_truename_buffer (orig_fn); - - if (!NILP (subject_buf) - && NILP (Fverify_visited_file_modtime (subject_buf)) - && !NILP (Ffile_exists_p (fn)) - && (!create_lockfiles || current_lock_owner (NULL, lfname) != -2)) - call1 (intern ("userlock--ask-user-about-supersession-threat"), fn); - - } + Lisp_Object subject_buf = get_truename_buffer (orig_fn); + if (!NILP (subject_buf) + && NILP (Fverify_visited_file_modtime (subject_buf)) + && !NILP (Ffile_exists_p (fn)) + && !(lfname && current_lock_owner (NULL, lfname) == -2)) + call1 (intern ("userlock--ask-user-about-supersession-threat"), fn); /* Don't do locking if the user has opted out. */ - if (create_lockfiles) + if (lfname) { /* Try to lock the lock. FIXME: This ignores errors when lock_if_free returns a positive errno value. */ @@ -860,7 +854,7 @@ syms_of_filelock (void) The name of the (per-buffer) lockfile is constructed by prepending a '.#' to the name of the file being locked. See also `lock-buffer' and Info node `(emacs)Interlocking'. */); - create_lockfiles = 1; + create_lockfiles = true; defsubr (&Sunlock_buffer); defsubr (&Slock_buffer); From 1060a6401b8ee9aaa4b2056025402e7fa1ad1643 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Wed, 25 Mar 2020 13:39:21 -0700 Subject: [PATCH 10/37] Update from gnulib This incorporates: 2020-03-25 getopt-posix: port __GETOPT_PREFIX to macOS 2020-03-22 acl-permissions: Improve autoconf macro * lib/getopt-pfx-core.h, m4/acl.m4: Copy from Gnulib. --- lib/getopt-pfx-core.h | 8 ++++++++ m4/acl.m4 | 4 ++-- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/lib/getopt-pfx-core.h b/lib/getopt-pfx-core.h index da0a6d0c3c4..ec545c1b51c 100644 --- a/lib/getopt-pfx-core.h +++ b/lib/getopt-pfx-core.h @@ -48,6 +48,14 @@ # define optind __GETOPT_ID (optind) # define optopt __GETOPT_ID (optopt) +/* Work around a a problem on macOS, which declares getopt with a + trailing __DARWIN_ALIAS(getopt) that would expand to something like + __asm("_" "rpl_getopt" "$UNIX2003") were it not for the following + hack to suppress the macOS declaration . */ +# ifdef __APPLE__ +# define _GETOPT +# endif + /* The system's getopt.h may have already included getopt-core.h to declare the unprefixed identifiers. Undef _GETOPT_CORE_H so that getopt-core.h declares them with prefixes. */ diff --git a/m4/acl.m4 b/m4/acl.m4 index e459451ae31..a3dcf9357b9 100644 --- a/m4/acl.m4 +++ b/m4/acl.m4 @@ -1,5 +1,5 @@ # acl.m4 - check for access control list (ACL) primitives -# serial 23 +# serial 24 # Copyright (C) 2002, 2004-2020 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation @@ -139,7 +139,7 @@ int type = ACL_TYPE_EXTENDED;]])], AC_MSG_WARN([AC_PACKAGE_NAME will be built without ACL support.]) fi fi - test $gl_need_lib_has_acl && LIB_HAS_ACL=$LIB_ACL + test -n "$gl_need_lib_has_acl" && LIB_HAS_ACL=$LIB_ACL AC_SUBST([LIB_ACL]) AC_DEFINE_UNQUOTED([USE_ACL], [$use_acl], [Define to nonzero if you want access control list support.]) From d08c9472e821615da06f92756e49c271be8da7f1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Wed, 18 Mar 2020 16:01:02 +0100 Subject: [PATCH 11/37] Make compilation-mode regexp matching case-sensitive (bug#40119) The number of regexps is large, they are written independently of one another, and they frequently intersect. Using case-sensitive matching improves separation and performance, and is probably what everyone have being assuming was used by compilation-mode all along. * lisp/progmodes/compile.el (compilation-error-case-fold-search): New. (compilation-parse-errors): Bind case-fold-search to compilation-error-case-fold-search during matching. * etc/NEWS: Announce. --- etc/NEWS | 6 ++++++ lisp/progmodes/compile.el | 11 ++++++++++- 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/etc/NEWS b/etc/NEWS index 1be5ad6acc0..910d9fa2d23 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -196,6 +196,12 @@ key binding *** New user option 'gravatar-service' for host to query for gravatars. Defaults to Libravatar, with Unicornify and Gravatar as options. +** Compilation mode + +*** Regexp matching of messages is now case-sensitive by default. +The user option 'compilation-error-case-fold-search' can be set +for case-insensitive matching of messages. + * New Modes and Packages in Emacs 28.1 diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 455f181f501..f4532b7edb7 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -646,6 +646,14 @@ matched file names, and weeding out false positives." :link `(file-link :tag "example file" ,(expand-file-name "compilation.txt" data-directory))) +(defcustom compilation-error-case-fold-search nil + "If non-nil, use case-insensitive matching of compilation errors +by the regexps of `compilation-error-regexp-alist' and +`compilation-error-regexp-alist-alist'. +If nil, matching is case-sensitive." + :type 'boolean + :version "28.1") + ;;;###autoload(put 'compilation-directory 'safe-local-variable 'stringp) (defvar compilation-directory nil "Directory to restore to when doing `recompile'.") @@ -1435,7 +1443,8 @@ to `compilation-error-regexp-alist' if RULES is nil." (if (symbolp item) (setq item (cdr (assq item compilation-error-regexp-alist-alist)))) - (let ((file (nth 1 item)) + (let ((case-fold-search compilation-error-case-fold-search) + (file (nth 1 item)) (line (nth 2 item)) (col (nth 3 item)) (type (nth 4 item)) From e4b6151ff119f36c64d3653b56f761fcdfe47fd3 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Wed, 25 Mar 2020 17:40:57 -0700 Subject: [PATCH 12/37] Fix integer overflow in forward-point * lisp/subr.el (forward-point): Rewrite in Lisp and move here ... * src/cmds.c (Fforward_point): ... from here. This fixes an integer overflow bug with (forward-point most-positive-fixnum). --- lisp/subr.el | 6 +++++- src/cmds.c | 10 ---------- 2 files changed, 5 insertions(+), 11 deletions(-) diff --git a/lisp/subr.el b/lisp/subr.el index 123557e736b..70f33ee5bdb 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -1558,7 +1558,6 @@ be a list of the form returned by `event-start' and `event-end'." ;;;; Obsolescent names for functions. -(make-obsolete 'forward-point "use (+ (point) N) instead." "23.1") (make-obsolete 'buffer-has-markers-at nil "24.3") (make-obsolete 'invocation-directory "use the variable of the same name." @@ -1580,6 +1579,11 @@ be a list of the form returned by `event-start' and `event-end'." (make-obsolete 'string-as-multibyte "use `decode-coding-string'." "26.1") (make-obsolete 'string-make-multibyte "use `decode-coding-string'." "26.1") +(defun forward-point (n) + "Return buffer position N characters after (before if N negative) point." + (declare (obsolete "use (+ (point) N) instead." "23.1")) + (+ (point) n)) + (defun log10 (x) "Return (log X 10), the log base 10 of X." (declare (obsolete log "24.4")) diff --git a/src/cmds.c b/src/cmds.c index 5d7a45e65f6..5b98a09fda9 100644 --- a/src/cmds.c +++ b/src/cmds.c @@ -31,15 +31,6 @@ along with GNU Emacs. If not, see . */ static int internal_self_insert (int, EMACS_INT); -DEFUN ("forward-point", Fforward_point, Sforward_point, 1, 1, 0, - doc: /* Return buffer position N characters after (before if N negative) point. */) - (Lisp_Object n) -{ - CHECK_FIXNUM (n); - - return make_fixnum (PT + XFIXNUM (n)); -} - /* Add N to point; or subtract N if FORWARD is false. N defaults to 1. Validate the new location. Return nil. */ static Lisp_Object @@ -526,7 +517,6 @@ syms_of_cmds (void) This is run after inserting the character. */); Vpost_self_insert_hook = Qnil; - defsubr (&Sforward_point); defsubr (&Sforward_char); defsubr (&Sbackward_char); defsubr (&Sforward_line); From 98546d9c823db544b62bdba0bb388816ea6dd342 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Wed, 25 Mar 2020 18:20:31 -0700 Subject: [PATCH 13/37] Fix integer overflow in internal_self_insert * src/cmds.c (internal_self_insert): Avoid undefined behavior on integer overflow by using saturated add. --- src/cmds.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/cmds.c b/src/cmds.c index 5b98a09fda9..c342cd88bd8 100644 --- a/src/cmds.c +++ b/src/cmds.c @@ -451,7 +451,10 @@ internal_self_insert (int c, EMACS_INT n) string = concat2 (string, tem); } - replace_range (PT, PT + chars_to_delete, string, 1, 1, 1, 0); + ptrdiff_t to; + if (INT_ADD_WRAPV (PT, chars_to_delete, &to)) + to = PTRDIFF_MAX; + replace_range (PT, to, string, 1, 1, 1, 0); Fforward_char (make_fixnum (n)); } else if (n > 1) From fe6b8c91cb7a3c1959f7fb2b43f73cc7f7fc9fc3 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Wed, 25 Mar 2020 18:32:19 -0700 Subject: [PATCH 14/37] line-beginning-position args can be bignums * src/editfns.c (Fline_beginning_position, Fline_end_position): Do not restrict integer arguments to fixnums. --- src/editfns.c | 26 +++++++++++++++++--------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/src/editfns.c b/src/editfns.c index eb15566fb48..cbc1082b2cc 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -725,18 +725,23 @@ boundaries, bind `inhibit-field-text-motion' to t. This function does not move point. */) (Lisp_Object n) { - ptrdiff_t charpos, bytepos; + ptrdiff_t charpos, bytepos, count; if (NILP (n)) - XSETFASTINT (n, 1); + count = 0; + else if (FIXNUMP (n)) + count = clip_to_bounds (-BUF_BYTES_MAX, XFIXNUM (n) - 1, BUF_BYTES_MAX); else - CHECK_FIXNUM (n); + { + CHECK_INTEGER (n); + count = NILP (Fnatnump (n)) ? -BUF_BYTES_MAX : BUF_BYTES_MAX; + } - scan_newline_from_point (XFIXNUM (n) - 1, &charpos, &bytepos); + scan_newline_from_point (count, &charpos, &bytepos); /* Return END constrained to the current input field. */ return Fconstrain_to_field (make_fixnum (charpos), make_fixnum (PT), - XFIXNUM (n) != 1 ? Qt : Qnil, + count != 0 ? Qt : Qnil, Qt, Qnil); } @@ -763,11 +768,14 @@ This function does not move point. */) ptrdiff_t orig = PT; if (NILP (n)) - XSETFASTINT (n, 1); + clipped_n = 1; + else if (FIXNUMP (n)) + clipped_n = clip_to_bounds (-BUF_BYTES_MAX, XFIXNUM (n), BUF_BYTES_MAX); else - CHECK_FIXNUM (n); - - clipped_n = clip_to_bounds (PTRDIFF_MIN + 1, XFIXNUM (n), PTRDIFF_MAX); + { + CHECK_INTEGER (n); + clipped_n = NILP (Fnatnump (n)) ? -BUF_BYTES_MAX : BUF_BYTES_MAX; + } end_pos = find_before_next_newline (orig, 0, clipped_n - (clipped_n <= 0), NULL); From 934b3c9ecc2b91723b9e5826080424ec1a90f264 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Thu, 26 Mar 2020 13:06:12 -0700 Subject: [PATCH 15/37] Remove COERCE_MARKER * src/xdisp.c (COERCE_MARKER): Remove. All uses replaced by Fmarker_position; this is simpler as the macro was invoked only on markers. --- src/xdisp.c | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/src/xdisp.c b/src/xdisp.c index 04fc8aa3c45..58d7ca5cb71 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -815,11 +815,6 @@ static struct props it_props[] = {0, 0, NULL} }; -/* Value is the position described by X. If X is a marker, value is - the marker_position of X. Otherwise, value is X. */ - -#define COERCE_MARKER(X) (MARKERP ((X)) ? Fmarker_position (X) : (X)) - /* Enumeration returned by some move_it_.* functions internally. */ enum move_it_result @@ -14944,7 +14939,7 @@ overlay_arrows_changed_p (bool set_redisplay) val = find_symbol_value (var); if (!MARKERP (val)) continue; - if (! EQ (COERCE_MARKER (val), + if (! EQ (Fmarker_position (val), /* FIXME: Don't we have a problem, using such a global * "last-position" if the variable is buffer-local? */ Fget (var, Qlast_arrow_position)) @@ -14987,8 +14982,7 @@ update_overlay_arrows (int up_to_date) Lisp_Object val = find_symbol_value (var); if (!MARKERP (val)) continue; - Fput (var, Qlast_arrow_position, - COERCE_MARKER (val)); + Fput (var, Qlast_arrow_position, Fmarker_position (val)); Fput (var, Qlast_arrow_string, overlay_arrow_string_or_property (var)); } From d28b00476890f791a89b65007e5f20682b3eaa0d Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Thu, 26 Mar 2020 17:22:25 +0100 Subject: [PATCH 16/37] Add a module function to open a file descriptor connected to a pipe. A common complaint about the module API is that modules can't communicate asynchronously with Emacs. While it isn't possible to call arbitrary Emacs functions asynchronously, writing to a pipe should always be fine and is a pretty low-hanging fruit. This patch implements a function that adapts an existing pipe process. That way, users can use familiar tools like process filters or 'accept-process-output'. * src/module-env-28.h: Add 'open_channel' module function. * src/emacs-module.c (module_open_channel): Provide definition for 'open_channel'. (initialize_environment): Use it. * src/process.c (open_channel_for_module): New helper function. (syms_of_process): Define necessary symbol. * test/src/emacs-module-tests.el (module/async-pipe): New unit test. * test/data/emacs-module/mod-test.c (signal_system_error): New helper function. (signal_errno): Use it. (write_to_pipe): New function running in the background. (Fmod_test_async_pipe): New test module function. (emacs_module_init): Export it. * doc/lispref/internals.texi (Module Misc): Document new module function. * doc/lispref/processes.texi (Asynchronous Processes): New anchor for pipe processes. * etc/NEWS: Document 'open_channel' function. --- doc/lispref/internals.texi | 14 ++++++++ doc/lispref/processes.texi | 1 + etc/NEWS | 4 +++ src/emacs-module.c | 9 +++++ src/module-env-28.h | 3 ++ src/process.c | 12 +++++++ src/process.h | 2 ++ test/data/emacs-module/mod-test.c | 57 +++++++++++++++++++++++++++++-- test/src/emacs-module-tests.el | 14 ++++++++ 9 files changed, 114 insertions(+), 2 deletions(-) diff --git a/doc/lispref/internals.texi b/doc/lispref/internals.texi index 442f6d156b6..0c24dac7775 100644 --- a/doc/lispref/internals.texi +++ b/doc/lispref/internals.texi @@ -2022,6 +2022,20 @@ variable values and buffer content may have been modified in arbitrary ways. @end deftypefn +@anchor{open_channel} +@deftypefun int open_channel (emacs_env *@var{env}, emacs_value @var{pipe_process}) +This function, which is available since Emacs 27, opens a channel to +an existing pipe process. @var{pipe_process} must refer to an +existing pipe process created by @code{make-pipe-process}. @ref{Pipe +Processes}. If successful, the return value will be a new file +descriptor that you can use to write to the pipe. Unlike all other +module functions, you can use the returned file descriptor from +arbitrary threads, even if no module environment is active. You can +use the @code{write} function to write to the file descriptor. Once +done, close the file descriptor using @code{close}. @ref{Low-Level +I/O,,,libc}. +@end deftypefun + @node Module Nonlocal @subsection Nonlocal Exits in Modules @cindex nonlocal exits, in modules diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index f515213615e..14cd079c563 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -743,6 +743,7 @@ Some file name handlers may not support @code{make-process}. In such cases, this function does nothing and returns @code{nil}. @end defun +@anchor{Pipe Processes} @defun make-pipe-process &rest args This function creates a bidirectional pipe which can be attached to a child process. This is useful with the @code{:stderr} keyword of diff --git a/etc/NEWS b/etc/NEWS index 910d9fa2d23..a2cb4b094e8 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -258,6 +258,10 @@ called when the function object is garbage-collected. Use 'set_function_finalizer' to set the finalizer and 'get_function_finalizer' to retrieve it. +** Modules can now open a channel to an existing pipe process using +the new module function 'open_channel'. Modules can use this +functionality to asynchronously send data back to Emacs. + ** 'file-modes', 'set-file-modes', and 'set-file-times' now have an optional argument specifying whether to follow symbolic links. diff --git a/src/emacs-module.c b/src/emacs-module.c index 60f16418efa..cdcbe061b53 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -88,6 +88,7 @@ To add a new module function, proceed as follows: #include "dynlib.h" #include "coding.h" #include "keyboard.h" +#include "process.h" #include "syssignal.h" #include "sysstdio.h" #include "thread.h" @@ -977,6 +978,13 @@ module_make_big_integer (emacs_env *env, int sign, return lisp_to_value (env, make_integer_mpz ()); } +static int +module_open_channel (emacs_env *env, emacs_value pipe_process) +{ + MODULE_FUNCTION_BEGIN (-1); + return open_channel_for_module (value_to_lisp (pipe_process)); +} + /* Subroutines. */ @@ -1391,6 +1399,7 @@ initialize_environment (emacs_env *env, struct emacs_env_private *priv) env->make_big_integer = module_make_big_integer; env->get_function_finalizer = module_get_function_finalizer; env->set_function_finalizer = module_set_function_finalizer; + env->open_channel = module_open_channel; Vmodule_environments = Fcons (make_mint_ptr (env), Vmodule_environments); return env; } diff --git a/src/module-env-28.h b/src/module-env-28.h index a2479a8f744..5d884c148c4 100644 --- a/src/module-env-28.h +++ b/src/module-env-28.h @@ -9,3 +9,6 @@ void (*set_function_finalizer) (emacs_env *env, emacs_value arg, void (*fin) (void *) EMACS_NOEXCEPT) EMACS_ATTRIBUTE_NONNULL (1); + + int (*open_channel) (emacs_env *env, emacs_value pipe_process) + EMACS_ATTRIBUTE_NONNULL (1); diff --git a/src/process.c b/src/process.c index e4e5e57aeee..07881d6c5d3 100644 --- a/src/process.c +++ b/src/process.c @@ -8200,6 +8200,17 @@ restore_nofile_limit (void) #endif } +int +open_channel_for_module (Lisp_Object process) +{ + CHECK_PROCESS (process); + CHECK_TYPE (PIPECONN_P (process), Qpipe_process_p, process); + int fd = dup (XPROCESS (process)->open_fd[SUBPROCESS_STDOUT]); + if (fd == -1) + report_file_error ("Cannot duplicate file descriptor", Qnil); + return fd; +} + /* This is not called "init_process" because that is the name of a Mach system call, so it would cause problems on Darwin systems. */ @@ -8446,6 +8457,7 @@ amounts of data in one go. */); DEFSYM (Qinterrupt_process_functions, "interrupt-process-functions"); DEFSYM (Qnull, "null"); + DEFSYM (Qpipe_process_p, "pipe-process-p"); defsubr (&Sprocessp); defsubr (&Sget_process); diff --git a/src/process.h b/src/process.h index 7884efc5494..a783a31cb86 100644 --- a/src/process.h +++ b/src/process.h @@ -300,6 +300,8 @@ extern Lisp_Object remove_slash_colon (Lisp_Object); extern void update_processes_for_thread_death (Lisp_Object); extern void dissociate_controlling_tty (void); +extern int open_channel_for_module (Lisp_Object); + INLINE_HEADER_END #endif /* EMACS_PROCESS_H */ diff --git a/test/data/emacs-module/mod-test.c b/test/data/emacs-module/mod-test.c index ec6948921f2..61733f1ef49 100644 --- a/test/data/emacs-module/mod-test.c +++ b/test/data/emacs-module/mod-test.c @@ -30,6 +30,9 @@ along with GNU Emacs. If not, see . */ #include #include +#include +#include + #ifdef HAVE_GMP #include #else @@ -320,9 +323,9 @@ Fmod_test_invalid_finalizer (emacs_env *env, ptrdiff_t nargs, emacs_value *args, } static void -signal_errno (emacs_env *env, const char *function) +signal_system_error (emacs_env *env, int error, const char *function) { - const char *message = strerror (errno); + const char *message = strerror (error); emacs_value message_value = env->make_string (env, message, strlen (message)); emacs_value symbol = env->intern (env, "file-error"); emacs_value elements[2] @@ -331,6 +334,12 @@ signal_errno (emacs_env *env, const char *function) env->non_local_exit_signal (env, symbol, data); } +static void +signal_errno (emacs_env *env, const char *function) +{ + signal_system_error (env, errno, function); +} + /* A long-running operation that occasionally calls `should_quit' or `process_input'. */ @@ -533,6 +542,49 @@ Fmod_test_function_finalizer_calls (emacs_env *env, ptrdiff_t nargs, return env->funcall (env, Flist, 2, list_args); } +static void * +write_to_pipe (void *arg) +{ + /* We sleep a bit to test that writing to a pipe is indeed possible + if no environment is active. */ + const struct timespec sleep = {0, 500000000}; + if (nanosleep (&sleep, NULL) != 0) + perror ("nanosleep"); + FILE *stream = arg; + if (fputs ("data from thread", stream) < 0) + perror ("fputs"); + if (fclose (stream) != 0) + perror ("close"); + return NULL; +} + +static emacs_value +Fmod_test_async_pipe (emacs_env *env, ptrdiff_t nargs, emacs_value *args, + void *data) +{ + assert (nargs == 1); + int fd = env->open_channel (env, args[0]); + if (env->non_local_exit_check (env) != emacs_funcall_exit_return) + return NULL; + FILE *stream = fdopen (fd, "w"); + if (stream == NULL) + { + signal_errno (env, "fdopen"); + return NULL; + } + pthread_t thread; + int error + = pthread_create (&thread, NULL, write_to_pipe, stream); + if (error != 0) + { + signal_system_error (env, error, "pthread_create"); + if (fclose (stream) != 0) + perror ("fclose"); + return NULL; + } + return env->intern (env, "nil"); +} + /* Lisp utilities for easier readability (simple wrappers). */ /* Provide FEATURE to Emacs. */ @@ -614,6 +666,7 @@ emacs_module_init (struct emacs_runtime *ert) Fmod_test_make_function_with_finalizer, 0, 0, NULL, NULL); DEFUN ("mod-test-function-finalizer-calls", Fmod_test_function_finalizer_calls, 0, 0, NULL, NULL); + DEFUN ("mod-test-async-pipe", Fmod_test_async_pipe, 1, 1, NULL, NULL); #undef DEFUN diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el index 48d2e86a605..1f91795e1e6 100644 --- a/test/src/emacs-module-tests.el +++ b/test/src/emacs-module-tests.el @@ -424,4 +424,18 @@ See Bug#36226." ;; but at least one. (should (> valid-after valid-before))))) +(ert-deftest module/async-pipe () + "Check that writing data from another thread works." + (with-temp-buffer + (let ((process (make-pipe-process :name "module/async-pipe" + :buffer (current-buffer) + :coding 'utf-8-unix + :noquery t))) + (unwind-protect + (progn + (mod-test-async-pipe process) + (should (accept-process-output process 1)) + (should (equal (buffer-string) "data from thread"))) + (delete-process process))))) + ;;; emacs-module-tests.el ends here From 57f5a63d85f6c3ea1d8b428b12a8db743de3b0bc Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Thu, 26 Mar 2020 16:12:21 -0700 Subject: [PATCH 17/37] Refactor and fix typo in CHECK_*_COERCE_MARKER * src/data.c (check_integer_coerce_marker) (check_number_coerce_marker): New functions. Also, fix a typo in the former, by having it use Qinteger_or_marker_p not Qnumber_or_marker_p. (arithcompare, floatop_arith_driver, bignum_arith_driver) (arith_driver, Fplus, Fminus, Ftimes, Fquo, Frem, Fmod) (minmax_driver, Flogand, Flogior, Flogxor, Fadd1, Fsub1): Use them in place of the similarly-named macros. * src/lisp.h (CHECK_NUMBER_COERCE_MARKER) (CHECK_INTEGER_COERCE_MARKER): Remove; no longer used. --- src/data.c | 77 +++++++++++++++++++++++++++++------------------------- src/lisp.h | 16 ------------ 2 files changed, 41 insertions(+), 52 deletions(-) diff --git a/src/data.c b/src/data.c index b0d438e8b81..bce2e53cfb6 100644 --- a/src/data.c +++ b/src/data.c @@ -2333,6 +2333,24 @@ bool-vector. IDX starts at 0. */) /* Arithmetic functions */ +static Lisp_Object +check_integer_coerce_marker (Lisp_Object x) +{ + if (MARKERP (x)) + return make_fixnum (marker_position (x)); + CHECK_TYPE (INTEGERP (x), Qinteger_or_marker_p, x); + return x; +} + +static Lisp_Object +check_number_coerce_marker (Lisp_Object x) +{ + if (MARKERP (x)) + return make_fixnum (marker_position (x)); + CHECK_TYPE (NUMBERP (x), Qnumber_or_marker_p, x); + return x; +} + Lisp_Object arithcompare (Lisp_Object num1, Lisp_Object num2, enum Arith_Comparison comparison) @@ -2341,8 +2359,8 @@ arithcompare (Lisp_Object num1, Lisp_Object num2, bool lt, eq = true, gt; bool test; - CHECK_NUMBER_COERCE_MARKER (num1); - CHECK_NUMBER_COERCE_MARKER (num2); + num1 = check_number_coerce_marker (num1); + num2 = check_number_coerce_marker (num2); /* If the comparison is mostly done by comparing two doubles, set LT, EQ, and GT to the <, ==, > results of that comparison, @@ -2744,9 +2762,7 @@ floatop_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, argnum++; if (argnum == nargs) return make_float (accum); - Lisp_Object val = args[argnum]; - CHECK_NUMBER_COERCE_MARKER (val); - next = XFLOATINT (val); + next = XFLOATINT (check_number_coerce_marker (args[argnum])); } } @@ -2808,8 +2824,7 @@ bignum_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, argnum++; if (argnum == nargs) return make_integer_mpz (); - val = args[argnum]; - CHECK_NUMBER_COERCE_MARKER (val); + val = check_number_coerce_marker (args[argnum]); if (FLOATP (val)) return float_arith_driver (code, nargs, args, argnum, mpz_get_d_rounded (*accum), val); @@ -2838,8 +2853,7 @@ arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, argnum++; if (argnum == nargs) return make_int (accum); - val = args[argnum]; - CHECK_NUMBER_COERCE_MARKER (val); + val = check_number_coerce_marker (args[argnum]); /* Set NEXT to the next value if it fits, else exit the loop. */ intmax_t next; @@ -2886,8 +2900,7 @@ usage: (+ &rest NUMBERS-OR-MARKERS) */) { if (nargs == 0) return make_fixnum (0); - Lisp_Object a = args[0]; - CHECK_NUMBER_COERCE_MARKER (a); + Lisp_Object a = check_number_coerce_marker (args[0]); return nargs == 1 ? a : arith_driver (Aadd, nargs, args, a); } @@ -2900,8 +2913,7 @@ usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */) { if (nargs == 0) return make_fixnum (0); - Lisp_Object a = args[0]; - CHECK_NUMBER_COERCE_MARKER (a); + Lisp_Object a = check_number_coerce_marker (args[0]); if (nargs == 1) { if (FIXNUMP (a)) @@ -2921,8 +2933,7 @@ usage: (* &rest NUMBERS-OR-MARKERS) */) { if (nargs == 0) return make_fixnum (1); - Lisp_Object a = args[0]; - CHECK_NUMBER_COERCE_MARKER (a); + Lisp_Object a = check_number_coerce_marker (args[0]); return nargs == 1 ? a : arith_driver (Amult, nargs, args, a); } @@ -2934,8 +2945,7 @@ The arguments must be numbers or markers. usage: (/ NUMBER &rest DIVISORS) */) (ptrdiff_t nargs, Lisp_Object *args) { - Lisp_Object a = args[0]; - CHECK_NUMBER_COERCE_MARKER (a); + Lisp_Object a = check_number_coerce_marker (args[0]); if (nargs == 1) { if (FIXNUMP (a)) @@ -3017,10 +3027,10 @@ integer_remainder (Lisp_Object num, Lisp_Object den, bool modulo) DEFUN ("%", Frem, Srem, 2, 2, 0, doc: /* Return remainder of X divided by Y. Both must be integers or markers. */) - (register Lisp_Object x, Lisp_Object y) + (Lisp_Object x, Lisp_Object y) { - CHECK_INTEGER_COERCE_MARKER (x); - CHECK_INTEGER_COERCE_MARKER (y); + x = check_integer_coerce_marker (x); + y = check_integer_coerce_marker (y); return integer_remainder (x, y, false); } @@ -3030,8 +3040,8 @@ The result falls between zero (inclusive) and Y (exclusive). Both X and Y must be numbers or markers. */) (Lisp_Object x, Lisp_Object y) { - CHECK_NUMBER_COERCE_MARKER (x); - CHECK_NUMBER_COERCE_MARKER (y); + x = check_number_coerce_marker (x); + y = check_number_coerce_marker (y); if (FLOATP (x) || FLOATP (y)) return fmod_float (x, y); return integer_remainder (x, y, true); @@ -3041,12 +3051,10 @@ static Lisp_Object minmax_driver (ptrdiff_t nargs, Lisp_Object *args, enum Arith_Comparison comparison) { - Lisp_Object accum = args[0]; - CHECK_NUMBER_COERCE_MARKER (accum); + Lisp_Object accum = check_number_coerce_marker (args[0]); for (ptrdiff_t argnum = 1; argnum < nargs; argnum++) { - Lisp_Object val = args[argnum]; - CHECK_NUMBER_COERCE_MARKER (val); + Lisp_Object val = check_number_coerce_marker (args[argnum]); if (!NILP (arithcompare (val, accum, comparison))) accum = val; else if (FLOATP (val) && isnan (XFLOAT_DATA (val))) @@ -3081,8 +3089,7 @@ usage: (logand &rest INTS-OR-MARKERS) */) { if (nargs == 0) return make_fixnum (-1); - Lisp_Object a = args[0]; - CHECK_INTEGER_COERCE_MARKER (a); + Lisp_Object a = check_integer_coerce_marker (args[0]); return nargs == 1 ? a : arith_driver (Alogand, nargs, args, a); } @@ -3094,8 +3101,7 @@ usage: (logior &rest INTS-OR-MARKERS) */) { if (nargs == 0) return make_fixnum (0); - Lisp_Object a = args[0]; - CHECK_INTEGER_COERCE_MARKER (a); + Lisp_Object a = check_integer_coerce_marker (args[0]); return nargs == 1 ? a : arith_driver (Alogior, nargs, args, a); } @@ -3107,8 +3113,7 @@ usage: (logxor &rest INTS-OR-MARKERS) */) { if (nargs == 0) return make_fixnum (0); - Lisp_Object a = args[0]; - CHECK_INTEGER_COERCE_MARKER (a); + Lisp_Object a = check_integer_coerce_marker (args[0]); return nargs == 1 ? a : arith_driver (Alogxor, nargs, args, a); } @@ -3227,9 +3232,9 @@ expt_integer (Lisp_Object x, Lisp_Object y) DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0, doc: /* Return NUMBER plus one. NUMBER may be a number or a marker. Markers are converted to integers. */) - (register Lisp_Object number) + (Lisp_Object number) { - CHECK_NUMBER_COERCE_MARKER (number); + number = check_number_coerce_marker (number); if (FIXNUMP (number)) return make_int (XFIXNUM (number) + 1); @@ -3242,9 +3247,9 @@ Markers are converted to integers. */) DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0, doc: /* Return NUMBER minus one. NUMBER may be a number or a marker. Markers are converted to integers. */) - (register Lisp_Object number) + (Lisp_Object number) { - CHECK_NUMBER_COERCE_MARKER (number); + number = check_number_coerce_marker (number); if (FIXNUMP (number)) return make_int (XFIXNUM (number) - 1); diff --git a/src/lisp.h b/src/lisp.h index cd6282390f7..49923be702a 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3039,22 +3039,6 @@ CHECK_INTEGER (Lisp_Object x) { CHECK_TYPE (INTEGERP (x), Qnumberp, x); } - -#define CHECK_NUMBER_COERCE_MARKER(x) \ - do { \ - if (MARKERP (x)) \ - XSETFASTINT (x, marker_position (x)); \ - else \ - CHECK_TYPE (NUMBERP (x), Qnumber_or_marker_p, x); \ - } while (false) - -#define CHECK_INTEGER_COERCE_MARKER(x) \ - do { \ - if (MARKERP (x)) \ - XSETFASTINT (x, marker_position (x)); \ - else \ - CHECK_TYPE (INTEGERP (x), Qnumber_or_marker_p, x); \ - } while (false) /* If we're not dumping using the legacy dumper and we might be using From 10bedb75c915158b7662d4dfa4afa3a231714268 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Fri, 27 Mar 2020 01:44:17 +0200 Subject: [PATCH 18/37] Disable enable-local-variables for hunk-only in diff-syntax-fontify-props * lisp/vc/diff-mode.el (diff-syntax-fontify-props): Let-bind enable-local-variables to nil when hunk-only is non-nil (bug#39190) --- lisp/vc/diff-mode.el | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 8171a585158..da2d5ed50e4 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -2720,7 +2720,9 @@ hunk text is not found in the source file." ;; When initialization is requested, we should be in a brand new ;; temp buffer. (cl-assert (null buffer-file-name)) - (let ((enable-local-variables :safe) ;; to find `mode:' + ;; Use `:safe' to find `mode:'. In case of hunk-only, use nil because + ;; Local Variables list might be incomplete when context is truncated. + (let ((enable-local-variables (unless hunk-only :safe)) (buffer-file-name file)) ;; Don't run hooks that might assume buffer-file-name ;; really associates buffer with a file (bug#39190). From de00a933e4b35b42398582eaba58531e5fdd46ca Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Fri, 27 Mar 2020 00:58:31 -0700 Subject: [PATCH 19/37] Treat out-of-range positions consistently If a position argument to get-byte etc. is an out-of-range integer, treat it the same regardless of whether it is a fixnum or a bignum. * src/buffer.c (fix_position): New function. * src/buffer.c (validate_region): * src/character.c (Fget_byte): * src/coding.c (Ffind_coding_systems_region_internal) (Fcheck_coding_systems_region): * src/composite.c (Ffind_composition_internal): * src/editfns.c (Fposition_bytes, Fchar_after, Fchar_before) (Finsert_buffer_substring, Fcompare_buffer_substrings) (Fnarrow_to_region): * src/fns.c (Fsecure_hash_algorithms): * src/font.c (Finternal_char_font, Ffont_at): * src/fringe.c (Ffringe_bitmaps_at_pos): * src/search.c (search_command): * src/textprop.c (get_char_property_and_overlay): * src/window.c (Fpos_visible_in_window_p): * src/xdisp.c (Fwindow_text_pixel_size): Use it instead of CHECK_FIXNUM_COERCE_MARKER, so that the code is simpler and treats bignums consistently with fixnums. * src/buffer.h (CHECK_FIXNUM_COERCE_MARKER): Define here rather than in lisp.h, and reimplement in terms of fix_position so that it treats bignums consistently with fixnums. * src/lisp.h (CHECK_FIXNUM_COERCE_MARKER): Move to buffer.h. * src/textprop.c (validate_interval_range): Signal with original bounds rather than modified ones. --- src/buffer.c | 32 +++++++++++++---- src/buffer.h | 2 ++ src/character.c | 6 ++-- src/coding.c | 42 +++++++++++----------- src/composite.c | 17 ++++----- src/editfns.c | 95 ++++++++++++++----------------------------------- src/fns.c | 18 ++-------- src/font.c | 16 +++++---- src/fringe.c | 6 ++-- src/lisp.h | 8 ----- src/search.c | 3 +- src/textprop.c | 15 ++++---- src/window.c | 5 +-- src/xdisp.c | 10 ++---- 14 files changed, 111 insertions(+), 164 deletions(-) diff --git a/src/buffer.c b/src/buffer.c index cc7d4e4817c..70598a7a22a 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -131,6 +131,23 @@ CHECK_OVERLAY (Lisp_Object x) CHECK_TYPE (OVERLAYP (x), Qoverlayp, x); } +/* Convert the position POS to an EMACS_INT that fits in a fixnum. + Yield POS's value if POS is already a fixnum, POS's marker position + if POS is a marker, and MOST_NEGATIVE_FIXNUM or + MOST_POSITIVE_FIXNUM if POS is a negative or positive bignum. + Signal an error if POS is not of the proper form. */ + +EMACS_INT +fix_position (Lisp_Object pos) +{ + if (FIXNUMP (pos)) + return XFIXNUM (pos); + if (MARKERP (pos)) + return marker_position (pos); + CHECK_TYPE (BIGNUMP (pos), Qinteger_or_marker_p, pos); + return !NILP (Fnatnump (pos)) ? MOST_POSITIVE_FIXNUM : MOST_NEGATIVE_FIXNUM; +} + /* These setters are used only in this file, so they can be private. The public setters are inline functions defined in buffer.h. */ static void @@ -2257,19 +2274,20 @@ so the buffer is truly empty after this. */) } void -validate_region (register Lisp_Object *b, register Lisp_Object *e) +validate_region (Lisp_Object *b, Lisp_Object *e) { - CHECK_FIXNUM_COERCE_MARKER (*b); - CHECK_FIXNUM_COERCE_MARKER (*e); + EMACS_INT beg = fix_position (*b), end = fix_position (*e); - if (XFIXNUM (*b) > XFIXNUM (*e)) + if (end < beg) { - Lisp_Object tem; - tem = *b; *b = *e; *e = tem; + EMACS_INT tem = beg; beg = end; end = tem; } - if (! (BEGV <= XFIXNUM (*b) && XFIXNUM (*e) <= ZV)) + if (! (BEGV <= beg && end <= ZV)) args_out_of_range_3 (Fcurrent_buffer (), *b, *e); + + *b = make_fixnum (beg); + *e = make_fixnum (end); } /* Advance BYTE_POS up to a character boundary diff --git a/src/buffer.h b/src/buffer.h index fd05fdd37de..31f497ea40a 100644 --- a/src/buffer.h +++ b/src/buffer.h @@ -1150,6 +1150,8 @@ extern Lisp_Object interval_insert_behind_hooks; extern Lisp_Object interval_insert_in_front_hooks; +extern EMACS_INT fix_position (Lisp_Object); +#define CHECK_FIXNUM_COERCE_MARKER(x) ((x) = make_fixnum (fix_position (x))) extern void delete_all_overlays (struct buffer *); extern void reset_buffer (struct buffer *); extern void compact_buffer (struct buffer *); diff --git a/src/character.c b/src/character.c index 5d419a2e836..d71cb3f145c 100644 --- a/src/character.c +++ b/src/character.c @@ -931,10 +931,10 @@ character is not ASCII nor 8-bit character, an error is signaled. */) } else { - CHECK_FIXNUM_COERCE_MARKER (position); - if (XFIXNUM (position) < BEGV || XFIXNUM (position) >= ZV) + EMACS_INT fixed_pos = fix_position (position); + if (! (BEGV <= fixed_pos && fixed_pos < ZV)) args_out_of_range_3 (position, make_fixnum (BEGV), make_fixnum (ZV)); - pos = XFIXNAT (position); + pos = fixed_pos; p = CHAR_POS_ADDR (pos); } if (NILP (BVAR (current_buffer, enable_multibyte_characters))) diff --git a/src/coding.c b/src/coding.c index 8b54281c0bf..0bea2a0c2bc 100644 --- a/src/coding.c +++ b/src/coding.c @@ -9023,23 +9023,23 @@ DEFUN ("find-coding-systems-region-internal", } else { - CHECK_FIXNUM_COERCE_MARKER (start); - CHECK_FIXNUM_COERCE_MARKER (end); - if (XFIXNUM (start) < BEG || XFIXNUM (end) > Z || XFIXNUM (start) > XFIXNUM (end)) + EMACS_INT s = fix_position (start); + EMACS_INT e = fix_position (end); + if (! (BEG <= s && s <= e && e <= Z)) args_out_of_range (start, end); if (NILP (BVAR (current_buffer, enable_multibyte_characters))) return Qt; - start_byte = CHAR_TO_BYTE (XFIXNUM (start)); - end_byte = CHAR_TO_BYTE (XFIXNUM (end)); - if (XFIXNUM (end) - XFIXNUM (start) == end_byte - start_byte) + start_byte = CHAR_TO_BYTE (s); + end_byte = CHAR_TO_BYTE (e); + if (e - s == end_byte - start_byte) return Qt; - if (XFIXNUM (start) < GPT && XFIXNUM (end) > GPT) + if (s < GPT && GPT < e) { - if ((GPT - XFIXNUM (start)) < (XFIXNUM (end) - GPT)) - move_gap_both (XFIXNUM (start), start_byte); + if (GPT - s < e - GPT) + move_gap_both (s, start_byte); else - move_gap_both (XFIXNUM (end), end_byte); + move_gap_both (e, end_byte); } } @@ -9277,25 +9277,25 @@ is nil. */) } else { - CHECK_FIXNUM_COERCE_MARKER (start); - CHECK_FIXNUM_COERCE_MARKER (end); - if (XFIXNUM (start) < BEG || XFIXNUM (end) > Z || XFIXNUM (start) > XFIXNUM (end)) + EMACS_INT s = fix_position (start); + EMACS_INT e = fix_position (end); + if (! (BEG <= s && s <= e && e <= Z)) args_out_of_range (start, end); if (NILP (BVAR (current_buffer, enable_multibyte_characters))) return Qnil; - start_byte = CHAR_TO_BYTE (XFIXNUM (start)); - end_byte = CHAR_TO_BYTE (XFIXNUM (end)); - if (XFIXNUM (end) - XFIXNUM (start) == end_byte - start_byte) + start_byte = CHAR_TO_BYTE (s); + end_byte = CHAR_TO_BYTE (e); + if (e - s == end_byte - start_byte) return Qnil; - if (XFIXNUM (start) < GPT && XFIXNUM (end) > GPT) + if (s < GPT && GPT < e) { - if ((GPT - XFIXNUM (start)) < (XFIXNUM (end) - GPT)) - move_gap_both (XFIXNUM (start), start_byte); + if (GPT - s < e - GPT) + move_gap_both (s, start_byte); else - move_gap_both (XFIXNUM (end), end_byte); + move_gap_both (e, end_byte); } - pos = XFIXNUM (start); + pos = s; } list = Qnil; diff --git a/src/composite.c b/src/composite.c index 84de334ce0d..a00a4541f5e 100644 --- a/src/composite.c +++ b/src/composite.c @@ -1839,27 +1839,24 @@ See `find-composition' for more details. */) ptrdiff_t start, end, from, to; int id; - CHECK_FIXNUM_COERCE_MARKER (pos); + EMACS_INT fixed_pos = fix_position (pos); if (!NILP (limit)) - { - CHECK_FIXNUM_COERCE_MARKER (limit); - to = min (XFIXNUM (limit), ZV); - } + to = clip_to_bounds (PTRDIFF_MIN, fix_position (limit), ZV); else to = -1; if (!NILP (string)) { CHECK_STRING (string); - if (XFIXNUM (pos) < 0 || XFIXNUM (pos) > SCHARS (string)) + if (! (0 <= fixed_pos && fixed_pos <= SCHARS (string))) args_out_of_range (string, pos); } else { - if (XFIXNUM (pos) < BEGV || XFIXNUM (pos) > ZV) + if (! (BEGV <= fixed_pos && fixed_pos <= ZV)) args_out_of_range (Fcurrent_buffer (), pos); } - from = XFIXNUM (pos); + from = fixed_pos; if (!find_composition (from, to, &start, &end, &prop, string)) { @@ -1870,12 +1867,12 @@ See `find-composition' for more details. */) return list3 (make_fixnum (start), make_fixnum (end), gstring); return Qnil; } - if ((end <= XFIXNUM (pos) || start > XFIXNUM (pos))) + if (! (start <= fixed_pos && fixed_pos < end)) { ptrdiff_t s, e; if (find_automatic_composition (from, to, &s, &e, &gstring, string) - && (e <= XFIXNUM (pos) ? e > end : s < start)) + && (e <= fixed_pos ? e > end : s < start)) return list3 (make_fixnum (s), make_fixnum (e), gstring); } if (!composition_valid_p (start, end, prop)) diff --git a/src/editfns.c b/src/editfns.c index cbc1082b2cc..90520d0dced 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -948,10 +948,10 @@ DEFUN ("position-bytes", Fposition_bytes, Sposition_bytes, 1, 1, 0, If POSITION is out of range, the value is nil. */) (Lisp_Object position) { - CHECK_FIXNUM_COERCE_MARKER (position); - if (XFIXNUM (position) < BEG || XFIXNUM (position) > Z) + EMACS_INT pos = fix_position (position); + if (! (BEG <= pos && pos <= Z)) return Qnil; - return make_fixnum (CHAR_TO_BYTE (XFIXNUM (position))); + return make_fixnum (CHAR_TO_BYTE (pos)); } DEFUN ("byte-to-position", Fbyte_to_position, Sbyte_to_position, 1, 1, 0, @@ -1068,11 +1068,11 @@ If POS is out of range, the value is nil. */) } else { - CHECK_FIXNUM_COERCE_MARKER (pos); - if (XFIXNUM (pos) < BEGV || XFIXNUM (pos) >= ZV) + EMACS_INT p = fix_position (pos); + if (! (BEGV <= p && p < ZV)) return Qnil; - pos_byte = CHAR_TO_BYTE (XFIXNUM (pos)); + pos_byte = CHAR_TO_BYTE (p); } return make_fixnum (FETCH_CHAR (pos_byte)); @@ -1102,12 +1102,12 @@ If POS is out of range, the value is nil. */) } else { - CHECK_FIXNUM_COERCE_MARKER (pos); + EMACS_INT p = fix_position (pos); - if (XFIXNUM (pos) <= BEGV || XFIXNUM (pos) > ZV) + if (! (BEGV < p && p <= ZV)) return Qnil; - pos_byte = CHAR_TO_BYTE (XFIXNUM (pos)); + pos_byte = CHAR_TO_BYTE (p); } if (!NILP (BVAR (current_buffer, enable_multibyte_characters))) @@ -1726,21 +1726,8 @@ using `string-make-multibyte' or `string-make-unibyte', which see. */) if (!BUFFER_LIVE_P (bp)) error ("Selecting deleted buffer"); - if (NILP (start)) - b = BUF_BEGV (bp); - else - { - CHECK_FIXNUM_COERCE_MARKER (start); - b = XFIXNUM (start); - } - if (NILP (end)) - e = BUF_ZV (bp); - else - { - CHECK_FIXNUM_COERCE_MARKER (end); - e = XFIXNUM (end); - } - + b = !NILP (start) ? fix_position (start) : BUF_BEGV (bp); + e = !NILP (end) ? fix_position (end) : BUF_ZV (bp); if (b > e) temp = b, b = e, e = temp; @@ -1794,21 +1781,8 @@ determines whether case is significant or ignored. */) error ("Selecting deleted buffer"); } - if (NILP (start1)) - begp1 = BUF_BEGV (bp1); - else - { - CHECK_FIXNUM_COERCE_MARKER (start1); - begp1 = XFIXNUM (start1); - } - if (NILP (end1)) - endp1 = BUF_ZV (bp1); - else - { - CHECK_FIXNUM_COERCE_MARKER (end1); - endp1 = XFIXNUM (end1); - } - + begp1 = !NILP (start1) ? fix_position (start1) : BUF_BEGV (bp1); + endp1 = !NILP (end1) ? fix_position (end1) : BUF_ZV (bp1); if (begp1 > endp1) temp = begp1, begp1 = endp1, endp1 = temp; @@ -1832,21 +1806,8 @@ determines whether case is significant or ignored. */) error ("Selecting deleted buffer"); } - if (NILP (start2)) - begp2 = BUF_BEGV (bp2); - else - { - CHECK_FIXNUM_COERCE_MARKER (start2); - begp2 = XFIXNUM (start2); - } - if (NILP (end2)) - endp2 = BUF_ZV (bp2); - else - { - CHECK_FIXNUM_COERCE_MARKER (end2); - endp2 = XFIXNUM (end2); - } - + begp2 = !NILP (start2) ? fix_position (start2) : BUF_BEGV (bp2); + endp2 = !NILP (end2) ? fix_position (end2) : BUF_ZV (bp2); if (begp2 > endp2) temp = begp2, begp2 = endp2, endp2 = temp; @@ -2700,29 +2661,27 @@ See also `save-restriction'. When calling from Lisp, pass two arguments START and END: positions (integers or markers) bounding the text that should remain visible. */) - (register Lisp_Object start, Lisp_Object end) + (Lisp_Object start, Lisp_Object end) { - CHECK_FIXNUM_COERCE_MARKER (start); - CHECK_FIXNUM_COERCE_MARKER (end); + EMACS_INT s = fix_position (start), e = fix_position (end); - if (XFIXNUM (start) > XFIXNUM (end)) + if (e < s) { - Lisp_Object tem; - tem = start; start = end; end = tem; + EMACS_INT tem = s; s = e; e = tem; } - if (!(BEG <= XFIXNUM (start) && XFIXNUM (start) <= XFIXNUM (end) && XFIXNUM (end) <= Z)) + if (!(BEG <= s && s <= e && e <= Z)) args_out_of_range (start, end); - if (BEGV != XFIXNAT (start) || ZV != XFIXNAT (end)) + if (BEGV != s || ZV != e) current_buffer->clip_changed = 1; - SET_BUF_BEGV (current_buffer, XFIXNAT (start)); - SET_BUF_ZV (current_buffer, XFIXNAT (end)); - if (PT < XFIXNAT (start)) - SET_PT (XFIXNAT (start)); - if (PT > XFIXNAT (end)) - SET_PT (XFIXNAT (end)); + SET_BUF_BEGV (current_buffer, s); + SET_BUF_ZV (current_buffer, e); + if (PT < s) + SET_PT (s); + if (e < PT) + SET_PT (e); /* Changing the buffer bounds invalidates any recorded current column. */ invalidate_current_column (); return Qnil; diff --git a/src/fns.c b/src/fns.c index 80012fa9d28..138082e07c8 100644 --- a/src/fns.c +++ b/src/fns.c @@ -5187,22 +5187,8 @@ extract_data_from_object (Lisp_Object spec, struct buffer *bp = XBUFFER (object); set_buffer_internal (bp); - if (NILP (start)) - b = BEGV; - else - { - CHECK_FIXNUM_COERCE_MARKER (start); - b = XFIXNUM (start); - } - - if (NILP (end)) - e = ZV; - else - { - CHECK_FIXNUM_COERCE_MARKER (end); - e = XFIXNUM (end); - } - + b = !NILP (start) ? fix_position (start) : BEGV; + e = !NILP (end) ? fix_position (end) : ZV; if (b > e) { EMACS_INT temp = b; diff --git a/src/font.c b/src/font.c index 2a456300619..0c9e752e089 100644 --- a/src/font.c +++ b/src/font.c @@ -4606,10 +4606,10 @@ DEFUN ("internal-char-font", Finternal_char_font, Sinternal_char_font, 1, 2, 0, Lisp_Object window; struct window *w; - CHECK_FIXNUM_COERCE_MARKER (position); - if (! (BEGV <= XFIXNUM (position) && XFIXNUM (position) < ZV)) + EMACS_INT fixed_pos = fix_position (position); + if (! (BEGV <= fixed_pos && fixed_pos < ZV)) args_out_of_range_3 (position, make_fixnum (BEGV), make_fixnum (ZV)); - pos = XFIXNUM (position); + pos = fixed_pos; pos_byte = CHAR_TO_BYTE (pos); if (NILP (ch)) c = FETCH_CHAR (pos_byte); @@ -5013,24 +5013,26 @@ character at index specified by POSITION. */) (Lisp_Object position, Lisp_Object window, Lisp_Object string) { struct window *w = decode_live_window (window); + EMACS_INT pos; if (NILP (string)) { if (XBUFFER (w->contents) != current_buffer) error ("Specified window is not displaying the current buffer"); - CHECK_FIXNUM_COERCE_MARKER (position); - if (! (BEGV <= XFIXNUM (position) && XFIXNUM (position) < ZV)) + pos = fix_position (position); + if (! (BEGV <= pos && pos < ZV)) args_out_of_range_3 (position, make_fixnum (BEGV), make_fixnum (ZV)); } else { CHECK_FIXNUM (position); CHECK_STRING (string); - if (! (0 <= XFIXNUM (position) && XFIXNUM (position) < SCHARS (string))) + pos = XFIXNUM (position); + if (! (0 <= pos && pos < SCHARS (string))) args_out_of_range (string, position); } - return font_at (-1, XFIXNUM (position), NULL, w, string); + return font_at (-1, pos, NULL, w, string); } #if 0 diff --git a/src/fringe.c b/src/fringe.c index 2a46e3c34f2..d8d80bb3fe9 100644 --- a/src/fringe.c +++ b/src/fringe.c @@ -1675,10 +1675,10 @@ Return nil if POS is not visible in WINDOW. */) if (!NILP (pos)) { - CHECK_FIXNUM_COERCE_MARKER (pos); - if (! (BEGV <= XFIXNUM (pos) && XFIXNUM (pos) <= ZV)) + EMACS_INT p = fix_position (pos); + if (! (BEGV <= p && p <= ZV)) args_out_of_range (window, pos); - textpos = XFIXNUM (pos); + textpos = p; } else if (w == XWINDOW (selected_window)) textpos = PT; diff --git a/src/lisp.h b/src/lisp.h index 49923be702a..d3b1c39c8fb 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3012,14 +3012,6 @@ CHECK_FIXNAT (Lisp_Object x) CHECK_RANGED_INTEGER (x, 0, TYPE_MAXIMUM (type)); \ } while (false) -#define CHECK_FIXNUM_COERCE_MARKER(x) \ - do { \ - if (MARKERP ((x))) \ - XSETFASTINT (x, marker_position (x)); \ - else \ - CHECK_TYPE (FIXNUMP (x), Qinteger_or_marker_p, x); \ - } while (false) - INLINE double XFLOATINT (Lisp_Object n) { diff --git a/src/search.c b/src/search.c index 818bb4af246..7389fbef0ee 100644 --- a/src/search.c +++ b/src/search.c @@ -1028,8 +1028,7 @@ search_command (Lisp_Object string, Lisp_Object bound, Lisp_Object noerror, } else { - CHECK_FIXNUM_COERCE_MARKER (bound); - lim = XFIXNUM (bound); + lim = fix_position (bound); if (n > 0 ? lim < PT : lim > PT) error ("Invalid search bound (wrong side of point)"); if (lim > ZV) diff --git a/src/textprop.c b/src/textprop.c index ee048336ac0..960dba3f8dc 100644 --- a/src/textprop.c +++ b/src/textprop.c @@ -131,6 +131,7 @@ validate_interval_range (Lisp_Object object, Lisp_Object *begin, { INTERVAL i; ptrdiff_t searchpos; + Lisp_Object begin0 = *begin, end0 = *end; CHECK_STRING_OR_BUFFER (object); CHECK_FIXNUM_COERCE_MARKER (*begin); @@ -155,7 +156,7 @@ validate_interval_range (Lisp_Object object, Lisp_Object *begin, if (!(BUF_BEGV (b) <= XFIXNUM (*begin) && XFIXNUM (*begin) <= XFIXNUM (*end) && XFIXNUM (*end) <= BUF_ZV (b))) - args_out_of_range (*begin, *end); + args_out_of_range (begin0, end0); i = buffer_intervals (b); /* If there's no text, there are no properties. */ @@ -170,7 +171,7 @@ validate_interval_range (Lisp_Object object, Lisp_Object *begin, if (! (0 <= XFIXNUM (*begin) && XFIXNUM (*begin) <= XFIXNUM (*end) && XFIXNUM (*end) <= len)) - args_out_of_range (*begin, *end); + args_out_of_range (begin0, end0); i = string_intervals (object); if (len == 0) @@ -611,7 +612,7 @@ get_char_property_and_overlay (Lisp_Object position, register Lisp_Object prop, { struct window *w = 0; - CHECK_FIXNUM_COERCE_MARKER (position); + EMACS_INT pos = fix_position (position); if (NILP (object)) XSETBUFFER (object, current_buffer); @@ -628,14 +629,14 @@ get_char_property_and_overlay (Lisp_Object position, register Lisp_Object prop, Lisp_Object *overlay_vec; struct buffer *obuf = current_buffer; - if (XFIXNUM (position) < BUF_BEGV (XBUFFER (object)) - || XFIXNUM (position) > BUF_ZV (XBUFFER (object))) + if (! (BUF_BEGV (XBUFFER (object)) <= pos + && pos <= BUF_ZV (XBUFFER (object)))) xsignal1 (Qargs_out_of_range, position); set_buffer_temp (XBUFFER (object)); USE_SAFE_ALLOCA; - GET_OVERLAYS_AT (XFIXNUM (position), overlay_vec, noverlays, NULL, false); + GET_OVERLAYS_AT (pos, overlay_vec, noverlays, NULL, false); noverlays = sort_overlays (overlay_vec, noverlays, w); set_buffer_temp (obuf); @@ -662,7 +663,7 @@ get_char_property_and_overlay (Lisp_Object position, register Lisp_Object prop, /* Not a buffer, or no appropriate overlay, so fall through to the simpler case. */ - return Fget_text_property (position, prop, object); + return Fget_text_property (make_fixnum (pos), prop, object); } DEFUN ("get-char-property", Fget_char_property, Sget_char_property, 2, 3, 0, diff --git a/src/window.c b/src/window.c index 8cdad27b664..075fd4e550c 100644 --- a/src/window.c +++ b/src/window.c @@ -1895,10 +1895,7 @@ POS, ROWH is the visible height of that row, and VPOS is the row number if (EQ (pos, Qt)) posint = -1; else if (!NILP (pos)) - { - CHECK_FIXNUM_COERCE_MARKER (pos); - posint = XFIXNUM (pos); - } + posint = fix_position (pos); else if (w == XWINDOW (selected_window)) posint = PT; else diff --git a/src/xdisp.c b/src/xdisp.c index 58d7ca5cb71..61c798c59e8 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -10413,10 +10413,7 @@ include the height of both, if present, in the return value. */) start = pos; } else - { - CHECK_FIXNUM_COERCE_MARKER (from); - start = min (max (XFIXNUM (from), BEGV), ZV); - } + start = clip_to_bounds (BEGV, fix_position (from), ZV); if (NILP (to)) end = ZV; @@ -10430,10 +10427,7 @@ include the height of both, if present, in the return value. */) end = pos; } else - { - CHECK_FIXNUM_COERCE_MARKER (to); - end = max (start, min (XFIXNUM (to), ZV)); - } + end = clip_to_bounds (start, fix_position (to), ZV); if (!NILP (x_limit) && RANGED_FIXNUMP (0, x_limit, INT_MAX)) max_x = XFIXNUM (x_limit); From ac242ed3843e127c1e2e506ecfd1a4552a2a8c44 Mon Sep 17 00:00:00 2001 From: Yuan Fu Date: Fri, 27 Mar 2020 09:43:49 +0100 Subject: [PATCH 20/37] Add manual and NEWS entries for previous gdb-mi changes * etc/NEWS: Add entries for saving and restoring GDB window configurations. * doc/emacs/building.texi (GDB User Interface Layout): Add documentation for 'gdb-save-window-configuration', 'gdb-load-window-configuration', 'gdb-default-window-configuration-file', 'gdb-window-configuration-directory', 'gdb-restore-window-configuration-after-quit'. Change 'many-windows layout' to 'default layout'. --- doc/emacs/building.texi | 28 ++++++++++++++++++++++++++-- etc/NEWS | 17 +++++++++++++++++ 2 files changed, 43 insertions(+), 2 deletions(-) diff --git a/doc/emacs/building.texi b/doc/emacs/building.texi index 38963f225ca..8a05680c742 100644 --- a/doc/emacs/building.texi +++ b/doc/emacs/building.texi @@ -975,9 +975,27 @@ displays the following frame layout: @end group @end smallexample +@findex gdb-save-window-configuration +@findex gdb-load-window-configuration +@vindex gdb-default-window-configuration-file +@vindex gdb-window-configuration-directory + You can customize the window layout based on the one above and save +that layout to a file using @code{gdb-save-window-configuration}. +Then you can later load this layout back using +@code{gdb-load-window-configuration}. (Internally, Emacs uses the +term window configuration instead of window layout.) You can set your +custom layout as the default one used by @code{gdb-many-windows} by +customizing @code{gdb-default-window-configuration-file}. If it is +not an absolute file name, GDB looks under +@code{gdb-window-configuration-directory} for the file. +@code{gdb-window-configuration-directory} defaults to +@code{user-emacs-directory} (@pxref{Find Init}). + + @findex gdb-restore-windows @findex gdb-many-windows - If you ever change the window layout, you can restore the many-windows +@vindex gdb-restore-window-configuration-after-quit + If you ever change the window layout, you can restore the default layout by typing @kbd{M-x gdb-restore-windows}. To toggle between the many windows layout and a simple layout with just the GUD interaction buffer and a source file, type @kbd{M-x gdb-many-windows}. @@ -988,7 +1006,13 @@ interaction buffer and a source file, type @kbd{M-x gdb-many-windows}. of windows on your original frame will not be affected. A separate frame for GDB sessions can come in especially handy if you work on a text-mode terminal, where the screen estate for windows could be at a -premium. +premium. If you choose to start GDB in the same frame, consider +setting @code{gdb-restore-window-configuration-after-quit} to a +non-@code{nil} value. Your original layout will then be restored +after GDB quits. Use @code{t} to always restore; use +@code{if-gdb-many-windows} to restore only when +@code{gdb-many-windows} is non-@code{nil}; use @code{if-gdb-show-main} +to restore only when @code{gdb-show-main} is non-@code{nil}. You may also specify additional GDB-related buffers to display, either in the same frame or a different one. Select the buffers you diff --git a/etc/NEWS b/etc/NEWS index a2cb4b094e8..aafb2081806 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -190,6 +190,23 @@ key binding / v package-menu-filter-by-version / / package-menu-filter-clear +** gdb-mi + ++++ +*** gdb-mi can now store and restore window configurations. +Use 'gdb-save-window-configuration' to save window configuration to a +file and 'gdb-load-window-configuration' to load from a file. These +commands can also be accessed through the menu bar under Gud -- +GDB-Windows. 'gdb-default-window-configuration-file', when non-nil, +is loaded when GDB starts up. + ++++ +*** gdb-mi can now restore window configuration after quit. +Set 'gdb-restore-window-configuration-after-quit' to non-nil and Emacs +will remember the window configuration before GDB started and restore +it after GDB quits. A toggle button is also provided under Gud -- +GDB-Windows. + ** Gravatar --- From e4f8098b9e6e1a0b310cb64f73d39d2b0d3d9f2f Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Fri, 27 Mar 2020 11:02:32 +0100 Subject: [PATCH 21/37] ; * etc/NEWS: Fix typos. --- etc/NEWS | 52 +++++++++++++++++++++++++++------------------------- 1 file changed, 27 insertions(+), 25 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index aafb2081806..49b7fcd8c21 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -38,7 +38,7 @@ when using Cairo. Use 'ftcrhb' if your Emacs was built with HarfBuzz text shaping support, and 'ftcr' otherwise. You can determine this by checking 'system-configuration-features'. The 'ftcr' backend will still be available when HarfBuzz is supported, but will not be used by -default. We strongly recommend building with HarBuzz support. 'x' is +default. We strongly recommend building with HarBuzz support. 'x' is still a valid backend. --- @@ -64,9 +64,9 @@ It was declared obsolete in Emacs 27.1. * Changes in Emacs 28.1 -** Support for '(box . SIZE)' cursor-type. +** Support for '(box . SIZE)' 'cursor-type'. By default, 'box' cursor always has a filled box shape. But if you -specify cursor-type to be '(box . SIZE)', the cursor becomes a hollow +specify 'cursor-type' to be '(box . SIZE)', the cursor becomes a hollow box if the point is on an image larger than 'SIZE' pixels in any dimension. @@ -97,28 +97,29 @@ shows equivalent key bindings for all commands that have them. * Changes in Specialized Modes and Packages in Emacs 28.1 ** Emacs-Lisp mode + *** The mode-line now indicates whether we're using lexical or dynamic scoping. ** Dired -*** New option 'dired-mark-region' affects all Dired commands that mark files. -When non-nil and the region is active in Transient Mark mode, -then Dired commands operate only on files in the active region. -The values 'file' and 'line' of this option define the details of -marking the file at the end of the region. +*** New user option 'dired-mark-region' affects all Dired commands +that mark files. When non-nil and the region is active in Transient +Mark mode, then Dired commands operate only on files in the active +region. The values 'file' and 'line' of this user option define the +details of marking the file at the end of the region. -*** State changing VC operations are supported in dired-mode on files +*** State changing VC operations are supported in 'dired-mode' on files (but still not on directories). ** Gnus --- -*** Change to default value of 'message-draft-headers' option. -The Date header has been removed from the default value, meaning that -draft or delayed messages will get a Date reflecting when the message -was sent. To restore the original behavior of dating a message -from when it is first saved or delayed, add the symbol 'Date back to -this option. +*** Change to default value of 'message-draft-headers' user option. +The 'Date' symbol has been removed from the default value, meaning that +draft or delayed messages will get a date reflecting when the message +was sent. To restore the original behavior of dating a message +from when it is first saved or delayed, add the symbol 'Date' back to +this user option. ** Help @@ -152,8 +153,8 @@ doc string functions. This makes the results of all doc string functions accessible to the user through the existing single function hook 'eldoc-documentation-function'. -*** 'eldoc-documentation-function' is now a custom variable. -Modes should use the new hook instead of this variable to register +*** 'eldoc-documentation-function' is now a user option. +Modes should use the new hook instead of this user option to register their backends. ** Tramp @@ -175,6 +176,7 @@ effect. *** Pcase 'map' pattern added keyword symbols abbreviation. A pattern like '(map :sym)' binds the map's value for ':sym' to 'sym', equivalent to '(map (:sym sym))'. + ** Package +++ @@ -196,22 +198,22 @@ key binding *** gdb-mi can now store and restore window configurations. Use 'gdb-save-window-configuration' to save window configuration to a file and 'gdb-load-window-configuration' to load from a file. These -commands can also be accessed through the menu bar under Gud -- -GDB-Windows. 'gdb-default-window-configuration-file', when non-nil, +commands can also be accessed through the menu bar under 'Gud -- +GDB-Windows'. 'gdb-default-window-configuration-file', when non-nil, is loaded when GDB starts up. +++ *** gdb-mi can now restore window configuration after quit. Set 'gdb-restore-window-configuration-after-quit' to non-nil and Emacs will remember the window configuration before GDB started and restore -it after GDB quits. A toggle button is also provided under Gud -- -GDB-Windows. +it after GDB quits. A toggle button is also provided under 'Gud -- +GDB-Windows'. ** Gravatar --- *** New user option 'gravatar-service' for host to query for gravatars. -Defaults to Libravatar, with Unicornify and Gravatar as options. +Defaults to 'libravatar', with 'unicornify' and 'gravatar' as options. ** Compilation mode @@ -225,11 +227,11 @@ for case-insensitive matching of messages. * Incompatible Editing Changes in Emacs 28.1 -** In nroff mode, 'center-line' is now bound to 'M-o M-s'. +** In 'nroff-mode', 'center-line' is now bound to 'M-o M-s'. The original key binding was 'M-s', which interfered with I-search, since the latter uses 'M-s' as a prefix key of the search prefix map. -** vc-print-branch-log shows the change log for BRANCH from its root +** 'vc-print-branch-log' shows the change log for BRANCH from its root directory instead of the default directory. @@ -261,7 +263,7 @@ This is no longer supported, and setting this variable has no effect. * Lisp Changes in Emacs 28.1 -** New macro 'dlet' to dynamically bind variables +** New macro 'dlet' to dynamically bind variables. ** The variable 'force-new-style-backquotes' has been removed. This removes the final remaining trace of old-style backquotes. From f98ee21c0e3d4e00569fdd9f2671fd8394ab8a65 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 27 Mar 2020 15:43:20 +0300 Subject: [PATCH 22/37] Port the 'module/async-pipe' test to MS-Windows These changes let the code compile and produce a valid DLL, but the test hangs. It looks like the hang is in Fdelete_process, when it closes one of the descriptors of the pipe process. In addition, this use of the pipe process cannot currently work on MS-Windows, since make-pipe-process doesn't set up the reader thread to read from the Emacs's side of the pipe, so the select emulation doesn't know there's stuff to read from that pipe. * test/data/emacs-module/mod-test.c [WINDOWSNT]: Include windows.h. (ALIGN_STACK) [!__x86_64__]: Define for 32-bit builds. (sleep_for_half_second): New function. (write_to_pipe): Declare return type differently for WINDOWSNT. Call sleep_for_half_second. (Fmod_test_async_pipe) [WINDOWSNT]: Use _beginthread as substitute for pthread_create. (invalid_finalizer): Replace non_ASCII character in a comment. * test/src/emacs-module-tests.el (module/async-pipe): Skip on MS-Windows, as the test fails and then hangs. --- test/data/emacs-module/mod-test.c | 48 ++++++++++++++++++++++++++----- test/src/emacs-module-tests.el | 3 ++ 2 files changed, 44 insertions(+), 7 deletions(-) diff --git a/test/data/emacs-module/mod-test.c b/test/data/emacs-module/mod-test.c index 61733f1ef49..5e3112f4471 100644 --- a/test/data/emacs-module/mod-test.c +++ b/test/data/emacs-module/mod-test.c @@ -30,8 +30,18 @@ along with GNU Emacs. If not, see . */ #include #include -#include -#include +#ifdef WINDOWSNT +/* Cannot include because of the local header by the same + name, sigh. */ +uintptr_t _beginthread (void (__cdecl *)(void *), unsigned, void *); +# if !defined __x86_64__ +# define ALIGN_STACK __attribute__((force_align_arg_pointer)) +# endif +# include /* for Sleep */ +#else /* !WINDOWSNT */ +# include +# include +#endif #ifdef HAVE_GMP #include @@ -302,7 +312,7 @@ Fmod_test_invalid_load (emacs_env *env, ptrdiff_t nargs, emacs_value *args, } /* An invalid finalizer: Finalizers are run during garbage collection, - where Lisp code can’t be executed. -module-assertions tests for + where Lisp code can't be executed. -module-assertions tests for this case. */ static emacs_env *current_env; @@ -542,20 +552,39 @@ Fmod_test_function_finalizer_calls (emacs_env *env, ptrdiff_t nargs, return env->funcall (env, Flist, 2, list_args); } +static void +sleep_for_half_second (void) +{ + /* mingw.org's MinGW has nanosleep, but MinGW64 doesn't. */ +#ifdef WINDOWSNT + Sleep (500); +#else + const struct timespec sleep = {0, 500000000}; + if (nanosleep (&sleep, NULL) != 0) + perror ("nanosleep"); +#endif +} + +#ifdef WINDOWSNT +static void ALIGN_STACK +#else static void * +#endif write_to_pipe (void *arg) { /* We sleep a bit to test that writing to a pipe is indeed possible if no environment is active. */ - const struct timespec sleep = {0, 500000000}; - if (nanosleep (&sleep, NULL) != 0) - perror ("nanosleep"); + sleep_for_half_second (); FILE *stream = arg; + /* The string below should be identical to the one we compare with + in emacs-module-tests.el:module/async-pipe. */ if (fputs ("data from thread", stream) < 0) perror ("fputs"); if (fclose (stream) != 0) perror ("close"); +#ifndef WINDOWSNT return NULL; +#endif } static emacs_value @@ -572,12 +601,17 @@ Fmod_test_async_pipe (emacs_env *env, ptrdiff_t nargs, emacs_value *args, signal_errno (env, "fdopen"); return NULL; } +#ifdef WINDOWSNT + uintptr_t thd = _beginthread (write_to_pipe, 0, stream); + int error = (thd == (uintptr_t)-1L) ? errno : 0; +#else /* !WINDOWSNT */ pthread_t thread; int error = pthread_create (&thread, NULL, write_to_pipe, stream); +#endif if (error != 0) { - signal_system_error (env, error, "pthread_create"); + signal_system_error (env, error, "thread create"); if (fclose (stream) != 0) perror ("fclose"); return NULL; diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el index 1f91795e1e6..6851b890451 100644 --- a/test/src/emacs-module-tests.el +++ b/test/src/emacs-module-tests.el @@ -426,6 +426,7 @@ See Bug#36226." (ert-deftest module/async-pipe () "Check that writing data from another thread works." + (skip-unless (not (eq system-type 'windows-nt))) ; FIXME! (with-temp-buffer (let ((process (make-pipe-process :name "module/async-pipe" :buffer (current-buffer) @@ -435,6 +436,8 @@ See Bug#36226." (progn (mod-test-async-pipe process) (should (accept-process-output process 1)) + ;; The string below must be identical to what + ;; mod-test.c:write_to_pipe produces. (should (equal (buffer-string) "data from thread"))) (delete-process process))))) From 4710f28010e47e613d08ff46b788b6b0c8eb317f Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 27 Mar 2020 12:24:19 -0400 Subject: [PATCH 23/37] * lisp/progmodes/ebrowse.el: Prefer hash-tables to obarrays Remove redundant :group args. Use `defvar-local` and `setq-local` where possible. (ebrowse-some): Use seq-some instead. (ebrowse-every): Use seq-every-p instead. (ebrowse-position): Use seq-position. (ebrowse--tree-table): Rename from `ebrowse--tree-obarray`. Change all users to use a hash-table rather than an obarray. (ebrowse-for-all-trees): Adjust to the table being a hash-table. (ebrowse-tree-table-as-alist): Rename from `ebrowse-tree-obarray-as-alist`. (ebrowse-build-tree-obarray): Rename from `ebrowse-build-tree-obarray`. (ebrowse-tree-mode): Remove redundant setting of `ebrowse--tree-obarray`. (ebrowse-set-tree-indentation, ebrowse-view-file-other-frame) (ebrowse-last-completion-table): Rename from ebrowse-last-completion-obarray. (ebrowse-position): Make it a proper struct. --- lisp/progmodes/ebrowse.el | 412 +++++++++++++++----------------------- 1 file changed, 167 insertions(+), 245 deletions(-) diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el index bb780259333..c02703fc59f 100644 --- a/lisp/progmodes/ebrowse.el +++ b/lisp/progmodes/ebrowse.el @@ -34,6 +34,7 @@ ;;; Code: (require 'cl-lib) +(require 'seq) (require 'easymenu) (require 'view) (require 'ebuff-menu) @@ -52,32 +53,27 @@ "List of directories to search for source files in a class tree. Elements should be directory names; nil as an element means to try to find source files relative to the location of the BROWSE file loaded." - :group 'ebrowse :type '(repeat (choice (const :tag "Default" nil) (string :tag "Directory")))) (defcustom ebrowse-view/find-hook nil "Hooks run after finding or viewing a member or class." - :group 'ebrowse :type 'hook) (defcustom ebrowse-not-found-hook nil "Hooks run when finding or viewing a member or class was not successful." - :group 'ebrowse :type 'hook) (defcustom ebrowse-electric-list-mode-hook nil "Hook called by `ebrowse-electric-position-mode'." - :group 'ebrowse :type 'hook) (defcustom ebrowse-max-positions 50 "Number of markers saved on electric position stack." - :group 'ebrowse :type 'integer) @@ -89,32 +85,27 @@ to find source files relative to the location of the BROWSE file loaded." (defcustom ebrowse-tree-mode-hook nil "Hook run in each new tree buffer." - :group 'ebrowse-tree :type 'hook) (defcustom ebrowse-tree-buffer-name "*Tree*" "The default name of class tree buffers." - :group 'ebrowse-tree :type 'string) (defcustom ebrowse--indentation 4 "The amount by which subclasses are indented in the tree." - :group 'ebrowse-tree :type 'integer) (defcustom ebrowse-source-file-column 40 "The column in which source file names are displayed in the tree." - :group 'ebrowse-tree :type 'integer) (defcustom ebrowse-tree-left-margin 2 "Amount of space left at the left side of the tree display. This space is used to display markers." - :group 'ebrowse-tree :type 'integer) @@ -126,25 +117,21 @@ This space is used to display markers." (defcustom ebrowse-default-declaration-column 25 "The column in which member declarations are displayed in member buffers." - :group 'ebrowse-member :type 'integer) (defcustom ebrowse-default-column-width 25 "The width of the columns in member buffers (short display form)." - :group 'ebrowse-member :type 'integer) (defcustom ebrowse-member-buffer-name "*Members*" "The name of the buffer for member display." - :group 'ebrowse-member :type 'string) (defcustom ebrowse-member-mode-hook nil "Run in each new member buffer." - :group 'ebrowse-member :type 'hook) @@ -156,81 +143,47 @@ This space is used to display markers." (defface ebrowse-tree-mark '((((min-colors 88)) :foreground "red1") (t :foreground "red")) - "Face for the mark character in the Ebrowse tree." - :group 'ebrowse-faces) + "Face for the mark character in the Ebrowse tree.") (defface ebrowse-root-class '((((min-colors 88)) :weight bold :foreground "blue1") (t :weight bold :foreground "blue")) - "Face for root classes in the Ebrowse tree." - :group 'ebrowse-faces) + "Face for root classes in the Ebrowse tree.") (defface ebrowse-file-name '((t :slant italic)) - "Face for filenames in the Ebrowse tree." - :group 'ebrowse-faces) + "Face for filenames in the Ebrowse tree.") (defface ebrowse-default '((t)) - "Face for items in the Ebrowse tree which do not have other faces." - :group 'ebrowse-faces) + "Face for items in the Ebrowse tree which do not have other faces.") (defface ebrowse-member-attribute '((((min-colors 88)) :foreground "red1") (t :foreground "red")) - "Face for member attributes." - :group 'ebrowse-faces) + "Face for member attributes.") (defface ebrowse-member-class '((t :foreground "purple")) - "Face used to display the class title in member buffers." - :group 'ebrowse-faces) + "Face used to display the class title in member buffers.") (defface ebrowse-progress '((((min-colors 88)) :background "blue1") (t :background "blue")) - "Face for progress indicator." - :group 'ebrowse-faces) + "Face for progress indicator.") ;;; Utilities. -(defun ebrowse-some (predicate vector) - "Return true if PREDICATE is true of some element of VECTOR. -If so, return the value returned by PREDICATE." - (let ((length (length vector)) - (i 0) - result) - (while (and (< i length) (not result)) - (setq result (funcall predicate (aref vector i)) - i (1+ i))) - result)) +(define-obsolete-function-alias 'ebrowse-some #'seq-some "28.1") -(defun ebrowse-every (predicate vector) - "Return true if PREDICATE is true of every element of VECTOR." - (let ((length (length vector)) - (i 0) - (result t)) - (while (and (< i length) result) - (setq result (funcall predicate (aref vector i)) - i (1+ i))) - result)) +(define-obsolete-function-alias 'ebrowse-every #'seq-every-p "28.1") (defun ebrowse-position (item list &optional test) "Return the position of ITEM in LIST or nil if not found. Compare items with `eq' or TEST if specified." - (let ((i 0) found) - (cond (test - (while list - (when (funcall test item (car list)) - (setq found i list nil)) - (setq list (cdr list) i (1+ i)))) - (t - (while list - (when (eq item (car list)) - (setq found i list nil)) - (setq list (cdr list) i (1+ i))))) - found)) + (declare (obsolete seq-position "28.1")) + (seq-position list item (or test #'eql))) (defmacro ebrowse-ignoring-completion-case (&rest body) @@ -242,17 +195,13 @@ Compare items with `eq' or TEST if specified." (defmacro ebrowse-for-all-trees (spec &rest body) "For all trees in SPEC, eval BODY." (declare (indent 1) (debug ((sexp form) body))) - (let ((var (make-symbol "var")) - (spec-var (car spec)) + (let ((spec-var (car spec)) (array (cadr spec))) - `(cl-loop for ,var being the symbols of ,array - as ,spec-var = (get ,var 'ebrowse-root) do - (when (vectorp ,spec-var) - ,@body)))) - -;;; Set indentation for macros above. - - + `(maphash (lambda (_k ,spec-var) + (when ,spec-var + (cl-assert (cl-typep ,spec-var 'ebrowse-ts)) + ,@body)) + ,array))) (defsubst ebrowse-set-face (start end face) "Set face of a region START END to FACE." @@ -264,8 +213,7 @@ Compare items with `eq' or TEST if specified." Case is ignored in completions. PROMPT is a string to prompt with; normally it ends in a colon and a space. -TABLE is an alist whose elements' cars are strings, or an obarray. -TABLE can also be a function to do the completion itself. +TABLE is a completion table. If INITIAL-INPUT is non-nil, insert it in the minibuffer initially. If it is (STRING . POSITION), the initial input is STRING, but point is placed POSITION characters into the string." @@ -304,6 +252,9 @@ otherwise use the current frame's width." ;;; Structure definitions +;; Note: These use `(:type vector) :named' in order to match the +;; format used in src/BROWSE. + (cl-defstruct (ebrowse-hs (:type vector) :named) "Header structure found at the head of BROWSE files." ;; A version string that is compared against the version number of @@ -457,19 +408,17 @@ members." This must be the same that `ebrowse' uses.") -(defvar ebrowse--last-regexp nil +(defvar-local ebrowse--last-regexp nil "Last regular expression searched for in tree and member buffers. Each tree and member buffer maintains its own search history.") -(make-variable-buffer-local 'ebrowse--last-regexp) - (defconst ebrowse-member-list-accessors - '(ebrowse-ts-member-variables - ebrowse-ts-member-functions - ebrowse-ts-static-variables - ebrowse-ts-static-functions - ebrowse-ts-friends - ebrowse-ts-types) + (list #'ebrowse-ts-member-variables + #'ebrowse-ts-member-functions + #'ebrowse-ts-static-variables + #'ebrowse-ts-static-functions + #'ebrowse-ts-friends + #'ebrowse-ts-types) "List of accessors for member lists. Each element is the symbol of an accessor function. The nth element must be the accessor for the nth member list @@ -478,8 +427,8 @@ in an `ebrowse-ts' structure.") ;;; FIXME: Add more doc strings for the buffer-local variables below. -(defvar ebrowse--tree-obarray nil - "Obarray holding all `ebrowse-ts' structures of a class tree. +(defvar ebrowse--tree-table nil + "Hash-table holding all `ebrowse-ts' structures of a class tree. Buffer-local in Ebrowse buffers.") @@ -637,12 +586,12 @@ Buffer-local in Ebrowse buffers.") ;;; Operations on `ebrowse-ts' structures (defun ebrowse-files-table (&optional marked-only) - "Return an obarray containing all files mentioned in the current tree. -The tree is expected in the buffer-local variable `ebrowse--tree-obarray'. + "Return a hash table containing all files mentioned in the current tree. +The tree is expected in the buffer-local variable `ebrowse--tree-table'. MARKED-ONLY non-nil means include marked classes only." (let ((files (make-hash-table :test 'equal)) (i -1)) - (ebrowse-for-all-trees (tree ebrowse--tree-obarray) + (ebrowse-for-all-trees (tree ebrowse--tree-table) (when (or (not marked-only) (ebrowse-ts-mark tree)) (let ((class (ebrowse-ts-class tree))) (when (zerop (% (cl-incf i) 20)) @@ -677,7 +626,7 @@ MARKED-ONLY non-nil means include marked classes only." (cl-defun ebrowse-marked-classes-p () "Value is non-nil if any class in the current class tree is marked." - (ebrowse-for-all-trees (tree ebrowse--tree-obarray) + (ebrowse-for-all-trees (tree ebrowse--tree-table) (when (ebrowse-ts-mark tree) (cl-return-from ebrowse-marked-classes-p tree)))) @@ -695,21 +644,21 @@ MARKED-ONLY non-nil means include marked classes only." (ebrowse-cs-name class))) -(defun ebrowse-tree-obarray-as-alist (&optional qualified-names-p) +(defun ebrowse-tree-table-as-alist (&optional qualified-names-p) "Return an alist describing all classes in a tree. Each elements in the list has the form (CLASS-NAME . TREE). CLASS-NAME is the name of the class. TREE is the class tree whose root is QUALIFIED-CLASS-NAME. QUALIFIED-NAMES-P non-nil means return qualified names as CLASS-NAME. -The class tree is found in the buffer-local variable `ebrowse--tree-obarray'." +The class tree is found in the buffer-local variable `ebrowse--tree-table'." (let (alist) (if qualified-names-p - (ebrowse-for-all-trees (tree ebrowse--tree-obarray) + (ebrowse-for-all-trees (tree ebrowse--tree-table) (setq alist (cl-acons (ebrowse-qualified-class-name (ebrowse-ts-class tree)) tree alist))) - (ebrowse-for-all-trees (tree ebrowse--tree-obarray) + (ebrowse-for-all-trees (tree ebrowse--tree-table) (setq alist (cl-acons (ebrowse-cs-name (ebrowse-ts-class tree)) tree alist)))) @@ -751,7 +700,7 @@ computes this information lazily." with result = nil as search = (pop to-search) while search finally return result - do (ebrowse-for-all-trees (ti ebrowse--tree-obarray) + do (ebrowse-for-all-trees (ti ebrowse--tree-table) (when (memq search (ebrowse-ts-subclasses ti)) (unless (memq ti result) (setq result (nconc result (list ti)))) @@ -875,7 +824,7 @@ NOCONFIRM." "Create a new tree buffer for tree TREE. The tree was loaded from file TAGS-FILE. HEADER is the header structure of the file. -CLASSES is an obarray with a symbol for each class in the tree. +CLASSES is a hash-table with an entry for each class in the tree. POP non-nil means popup the buffer up at the end. Return the buffer created." (let ((name ebrowse-tree-buffer-name)) @@ -883,7 +832,7 @@ Return the buffer created." (ebrowse-tree-mode) (setq ebrowse--tree tree ebrowse--tags-file-name tags-file - ebrowse--tree-obarray classes + ebrowse--tree-table classes ebrowse--header header ebrowse--frozen-flag nil) (ebrowse-redraw-tree) @@ -895,13 +844,13 @@ Return the buffer created." -;;; Operations for member obarrays +;;; Operations for member tables (defun ebrowse-fill-member-table () - "Return an obarray holding all members of all classes in the current tree. + "Return a hash table holding all members of all classes in the current tree. -For each member, a symbol is added to the obarray. Members are -extracted from the buffer-local tree `ebrowse--tree-obarray'. +For each member, a symbol is added to the table. Members are +extracted from the buffer-local tree `ebrowse--tree-table'. Each symbol has its property `ebrowse-info' set to a list (TREE MEMBER-LIST MEMBER) where TREE is the tree in which the member is defined, @@ -909,26 +858,23 @@ MEMBER-LIST is a symbol describing the member list in which the member is found, and MEMBER is a MEMBER structure describing the member. The slot `member-table' of the buffer-local header structure of -type `ebrowse-hs' is set to the resulting obarray." +type `ebrowse-hs' is set to the resulting table." (let ((members (make-hash-table :test 'equal)) (i -1)) (setf (ebrowse-hs-member-table ebrowse--header) nil) (garbage-collect) ;; For all classes... - (ebrowse-for-all-trees (c ebrowse--tree-obarray) + (ebrowse-for-all-trees (c ebrowse--tree-table) (when (zerop (% (cl-incf i) 10)) (ebrowse-show-progress "Preparing member lookup" (zerop i))) (dolist (f ebrowse-member-list-accessors) (dolist (m (funcall f c)) - (let* ((member-name (ebrowse-ms-name m)) - (value (gethash member-name members))) - (push (list c f m) value) - (puthash member-name value members))))) + (push (list c f m) (gethash (ebrowse-ms-name m) members))))) (setf (ebrowse-hs-member-table ebrowse--header) members))) (defun ebrowse-member-table (header) - "Return the member obarray. Build it if it hasn't been set up yet. + "Return the member table. Build it if it hasn't been set up yet. HEADER is the tree header structure of the class tree." (when (null (ebrowse-hs-member-table header)) (cl-loop for buffer in (ebrowse-browser-buffer-list) @@ -940,19 +886,18 @@ HEADER is the tree header structure of the class tree." -;;; Operations on TREE obarrays +;;; Operations on TREE tables -(defun ebrowse-build-tree-obarray (tree) +(defun ebrowse-build-tree-table (tree) "Make sure every class in TREE is represented by a unique object. -Build obarray of all classes in TREE." - (let ((classes (make-vector 127 0))) +Build hash table of all classes in TREE." + (let ((classes (make-hash-table :test #'equal))) ;; Add root classes... (cl-loop for root in tree - as sym = - (intern (ebrowse-qualified-class-name (ebrowse-ts-class root)) - classes) - do (unless (get sym 'ebrowse-root) - (setf (get sym 'ebrowse-root) root))) + do (let ((name (ebrowse-qualified-class-name + (ebrowse-ts-class root)))) + (unless (gethash name classes) + (setf (gethash name classes) root)))) ;; Process subclasses (ebrowse-insert-supers tree classes) classes)) @@ -962,7 +907,7 @@ Build obarray of all classes in TREE." "Build base class lists in class tree TREE. CLASSES is an obarray used to collect classes. -Helper function for `ebrowse-build-tree-obarray'. Base classes should +Helper function for `ebrowse-build-tree-table'. Base classes should be ordered so that immediate base classes come first, then the base class of the immediate base class and so on. This means that we must construct the base-class list top down with adding each level at the @@ -974,23 +919,21 @@ if for some reason a circle is in the inheritance graph." as subclasses = (ebrowse-ts-subclasses class) do ;; Make sure every class is represented by a unique object (cl-loop for subclass on subclasses - as sym = (intern - (ebrowse-qualified-class-name - (ebrowse-ts-class (car subclass))) - classes) do - ;; Replace the subclass tree with the one found in - ;; CLASSES if there is already an entry for that class - ;; in it. Otherwise make a new entry. - ;; - ;; CAVEAT: If by some means (e.g., use of the - ;; preprocessor in class declarations, a name is marked - ;; as a subclass of itself on some path, we would end up - ;; in an endless loop. We have to omit subclasses from - ;; the recursion that already have been processed. - (if (get sym 'ebrowse-root) - (setf (car subclass) (get sym 'ebrowse-root)) - (setf (get sym 'ebrowse-root) (car subclass)))) + (let ((name (ebrowse-qualified-class-name + (ebrowse-ts-class (car subclass))))) + ;; Replace the subclass tree with the one found in + ;; CLASSES if there is already an entry for that class + ;; in it. Otherwise make a new entry. + ;; + ;; CAVEAT: If by some means (e.g., use of the + ;; preprocessor in class declarations, a name is marked + ;; as a subclass of itself on some path, we would end up + ;; in an endless loop. We have to omit subclasses from + ;; the recursion that already have been processed. + (if (gethash name classes) + (setf (car subclass) (gethash name classes)) + (setf (gethash name classes) (car subclass))))) ;; Process subclasses (ebrowse-insert-supers subclasses classes))) @@ -1072,20 +1015,17 @@ Tree mode key bindings: (erase-buffer) (message nil)) - (set (make-local-variable 'ebrowse--show-file-names-flag) nil) - (set (make-local-variable 'ebrowse--tree-obarray) (make-vector 127 0)) - (set (make-local-variable 'ebrowse--frozen-flag) nil) + (setq-local ebrowse--show-file-names-flag nil) + (setq-local ebrowse--frozen-flag nil) (setq mode-line-buffer-identification ident) (setq buffer-read-only t) (add-to-invisibility-spec '(ebrowse . t)) - (set (make-local-variable 'revert-buffer-function) - #'ebrowse-revert-tree-buffer-from-file) - (set (make-local-variable 'ebrowse--header) header) - (set (make-local-variable 'ebrowse--tree) tree) - (set (make-local-variable 'ebrowse--tags-file-name) buffer-file-name) - (set (make-local-variable 'ebrowse--tree-obarray) - (and tree (ebrowse-build-tree-obarray tree))) - (set (make-local-variable 'ebrowse--frozen-flag) nil) + (setq-local revert-buffer-function #'ebrowse-revert-tree-buffer-from-file) + (setq-local ebrowse--header header) + (setq-local ebrowse--tree tree) + (setq-local ebrowse--tags-file-name buffer-file-name) + (setq-local ebrowse--tree-table (and tree (ebrowse-build-tree-table tree))) + (setq-local ebrowse--frozen-flag nil) (add-hook 'write-file-functions #'ebrowse-write-file-hook-fn nil t) (modify-syntax-entry ?_ (char-to-string (char-syntax ?a))) @@ -1110,18 +1050,18 @@ Tree mode key bindings: (defun ebrowse-remove-class-and-kill-member-buffers (tree class) "Remove from TREE class CLASS. Kill all member buffers still containing a reference to the class." - (let ((sym (intern-soft (ebrowse-cs-name (ebrowse-ts-class class)) - ebrowse--tree-obarray))) - (setf tree (delq class tree) - (get sym 'ebrowse-root) nil) - (dolist (root tree) - (setf (ebrowse-ts-subclasses root) - (delq class (ebrowse-ts-subclasses root)) - (ebrowse-ts-base-classes root) nil) - (ebrowse-remove-class-and-kill-member-buffers - (ebrowse-ts-subclasses root) class)) - (ebrowse-kill-member-buffers-displaying class) - tree)) + (setf tree (delq class tree) + (gethash (ebrowse-cs-name (ebrowse-ts-class class)) + ebrowse--tree-table) + nil) + (dolist (root tree) + (setf (ebrowse-ts-subclasses root) + (delq class (ebrowse-ts-subclasses root)) + (ebrowse-ts-base-classes root) nil) + (ebrowse-remove-class-and-kill-member-buffers + (ebrowse-ts-subclasses root) class)) + (ebrowse-kill-member-buffers-displaying class) + tree) (defun ebrowse-remove-class-at-point (forced) @@ -1184,7 +1124,7 @@ If given a numeric N-TIMES argument, mark that many classes." (defun ebrowse-mark-all-classes (prefix) "Unmark, with PREFIX mark, all classes in the tree." (interactive "P") - (ebrowse-for-all-trees (tree ebrowse--tree-obarray) + (ebrowse-for-all-trees (tree ebrowse--tree-table) (setf (ebrowse-ts-mark tree) prefix)) (ebrowse-redraw-marks (point-min) (point-max))) @@ -1277,17 +1217,17 @@ With PREFIX, insert that many filenames." (defun ebrowse-browser-buffer-list () "Return a list of all tree or member buffers." - (cl-delete-if-not 'ebrowse-buffer-p (buffer-list))) + (cl-delete-if-not #'ebrowse-buffer-p (buffer-list))) (defun ebrowse-member-buffer-list () "Return a list of all member buffers." - (cl-delete-if-not 'ebrowse-member-buffer-p (buffer-list))) + (cl-delete-if-not #'ebrowse-member-buffer-p (buffer-list))) (defun ebrowse-tree-buffer-list () "Return a list of all tree buffers." - (cl-delete-if-not 'ebrowse-tree-buffer-p (buffer-list))) + (cl-delete-if-not #'ebrowse-tree-buffer-p (buffer-list))) (defun ebrowse-known-class-trees-buffer-list () @@ -1396,7 +1336,7 @@ Pop to member buffer if no prefix ARG, to tree buffer otherwise." "): ") nil nil ebrowse--indentation)))) (when (cl-plusp width) - (set (make-local-variable 'ebrowse--indentation) width) + (setq-local ebrowse--indentation width) (ebrowse-redraw-tree)))) @@ -1409,7 +1349,7 @@ Read a class name from the minibuffer if CLASS is nil." (unless class (setf class (completing-read "Goto class: " - (ebrowse-tree-obarray-as-alist) nil t))) + (ebrowse-tree-table-as-alist) nil t))) (goto-char (point-min)) (widen) (setq ebrowse--last-regexp (concat "\\b" class "\\b")) @@ -1426,37 +1366,37 @@ Read a class name from the minibuffer if CLASS is nil." (defun ebrowse-tree-command:show-member-variables (arg) "Display member variables; with prefix ARG in frozen member buffer." (interactive "P") - (ebrowse-display-member-buffer 'ebrowse-ts-member-variables arg)) + (ebrowse-display-member-buffer #'ebrowse-ts-member-variables arg)) (defun ebrowse-tree-command:show-member-functions (&optional arg) "Display member functions; with prefix ARG in frozen member buffer." (interactive "P") - (ebrowse-display-member-buffer 'ebrowse-ts-member-functions arg)) + (ebrowse-display-member-buffer #'ebrowse-ts-member-functions arg)) (defun ebrowse-tree-command:show-static-member-variables (arg) "Display static member variables; with prefix ARG in frozen member buffer." (interactive "P") - (ebrowse-display-member-buffer 'ebrowse-ts-static-variables arg)) + (ebrowse-display-member-buffer #'ebrowse-ts-static-variables arg)) (defun ebrowse-tree-command:show-static-member-functions (arg) "Display static member functions; with prefix ARG in frozen member buffer." (interactive "P") - (ebrowse-display-member-buffer 'ebrowse-ts-static-functions arg)) + (ebrowse-display-member-buffer #'ebrowse-ts-static-functions arg)) (defun ebrowse-tree-command:show-friends (arg) "Display friend functions; with prefix ARG in frozen member buffer." (interactive "P") - (ebrowse-display-member-buffer 'ebrowse-ts-friends arg)) + (ebrowse-display-member-buffer #'ebrowse-ts-friends arg)) (defun ebrowse-tree-command:show-types (arg) "Display types defined in a class; with prefix ARG in frozen member buffer." (interactive "P") - (ebrowse-display-member-buffer 'ebrowse-ts-types arg)) + (ebrowse-display-member-buffer #'ebrowse-ts-types arg)) @@ -1562,12 +1502,12 @@ The new frame is deleted when you quit viewing the file in that frame." (had-a-buf (get-file-buffer file)) (buf-to-view (find-file-noselect file))) (switch-to-buffer-other-frame buf-to-view) - (set (make-local-variable 'ebrowse--frame-configuration) + (setq-local ebrowse--frame-configuration old-frame-configuration) - (set (make-local-variable 'ebrowse--view-exit-action) + (setq-local ebrowse--view-exit-action (and (not had-a-buf) (not (buffer-modified-p buf-to-view)) - 'kill-buffer)) + #'kill-buffer)) (view-mode-enter (cons (selected-window) (cons (selected-window) t)) 'ebrowse-view-exit-fn))) @@ -1934,7 +1874,7 @@ COLLAPSE non-nil means collapse the branch." (when (memq 'mode-name mode-line-format) (setq mode-line-format (copy-sequence mode-line-format)) (setcar (memq 'mode-name mode-line-format) "Tree Buffers")) - (set (make-local-variable 'Helper-return-blurb) "return to buffer editing") + (setq-local Helper-return-blurb "return to buffer editing") (setq truncate-lines t buffer-read-only t)) @@ -2145,41 +2085,31 @@ See `Electric-command-loop' for a description of STATE and CONDITION." (define-derived-mode ebrowse-member-mode special-mode "Ebrowse-Members" "Major mode for Ebrowse member buffers." (mapc #'make-local-variable - '(ebrowse--decl-column ;display column - ebrowse--n-columns ;number of short columns - ebrowse--column-width ;width of columns above - ebrowse--show-inherited-flag ;include inherited members? - ebrowse--filters ;public, protected, private + '(ebrowse--n-columns ;number of short columns ebrowse--accessor ;vars, functions, friends ebrowse--displayed-class ;class displayed - ebrowse--long-display-flag ;display with regexps? - ebrowse--source-regexp-flag ;show source regexp? - ebrowse--attributes-flag ;show `virtual' and `inline' ebrowse--member-list ;list of members displayed ebrowse--tree ;the class tree ebrowse--member-mode-strings ;part of mode line ebrowse--tags-file-name ; ebrowse--header - ebrowse--tree-obarray - ebrowse--virtual-display-flag - ebrowse--inline-display-flag - ebrowse--const-display-flag - ebrowse--pure-display-flag + ebrowse--tree-table ebrowse--frozen-flag)) ;buffer not automagically reused - (setq mode-line-buffer-identification - (propertized-buffer-identification "C++ Members") - buffer-read-only t - ebrowse--long-display-flag nil - ebrowse--attributes-flag t - ebrowse--show-inherited-flag t - ebrowse--source-regexp-flag nil - ebrowse--filters [0 1 2] - ebrowse--decl-column ebrowse-default-declaration-column - ebrowse--column-width ebrowse-default-column-width - ebrowse--virtual-display-flag nil - ebrowse--inline-display-flag nil - ebrowse--const-display-flag nil - ebrowse--pure-display-flag nil) + (setq-local + mode-line-buffer-identification + (propertized-buffer-identification "C++ Members") + buffer-read-only t + ebrowse--long-display-flag nil ;display with regexps? + ebrowse--attributes-flag t ;show `virtual' and `inline' + ebrowse--show-inherited-flag t ;include inherited members? + ebrowse--source-regexp-flag nil ;show source regexp? + ebrowse--filters [0 1 2] ;public, protected, private + ebrowse--decl-column ebrowse-default-declaration-column ;display column + ebrowse--column-width ebrowse-default-column-width ;width of columns above + ebrowse--virtual-display-flag nil + ebrowse--inline-display-flag nil + ebrowse--const-display-flag nil + ebrowse--pure-display-flag nil) (modify-syntax-entry ?_ (char-to-string (char-syntax ?a)))) @@ -2257,10 +2187,10 @@ make one." (ebrowse-create-tree-buffer ebrowse--tree ebrowse--tags-file-name ebrowse--header - ebrowse--tree-obarray + ebrowse--tree-table 'pop)))) (and buf - (funcall (if arg 'switch-to-buffer 'pop-to-buffer) buf)) + (funcall (if arg #'switch-to-buffer #'pop-to-buffer) buf)) buf)) @@ -2276,8 +2206,9 @@ make one." (defun ebrowse-cyclic-display-next/previous-member-list (incr) "Switch buffer to INCR'th next/previous list of members." - (let ((index (ebrowse-position ebrowse--accessor - ebrowse-member-list-accessors))) + (let ((index (seq-position ebrowse-member-list-accessors + ebrowse--accessor + #'eql))) (setf ebrowse--accessor (cond ((cl-plusp incr) (or (nth (1+ index) @@ -2306,37 +2237,37 @@ make one." (defun ebrowse-display-function-member-list () "Display the list of member functions." (interactive) - (ebrowse-display-member-list-for-accessor 'ebrowse-ts-member-functions)) + (ebrowse-display-member-list-for-accessor #'ebrowse-ts-member-functions)) (defun ebrowse-display-variables-member-list () "Display the list of member variables." (interactive) - (ebrowse-display-member-list-for-accessor 'ebrowse-ts-member-variables)) + (ebrowse-display-member-list-for-accessor #'ebrowse-ts-member-variables)) (defun ebrowse-display-static-variables-member-list () "Display the list of static member variables." (interactive) - (ebrowse-display-member-list-for-accessor 'ebrowse-ts-static-variables)) + (ebrowse-display-member-list-for-accessor #'ebrowse-ts-static-variables)) (defun ebrowse-display-static-functions-member-list () "Display the list of static member functions." (interactive) - (ebrowse-display-member-list-for-accessor 'ebrowse-ts-static-functions)) + (ebrowse-display-member-list-for-accessor #'ebrowse-ts-static-functions)) (defun ebrowse-display-friends-member-list () "Display the list of friends." (interactive) - (ebrowse-display-member-list-for-accessor 'ebrowse-ts-friends)) + (ebrowse-display-member-list-for-accessor #'ebrowse-ts-friends)) (defun ebrowse-display-types-member-list () "Display the list of types." (interactive) - (ebrowse-display-member-list-for-accessor 'ebrowse-ts-types)) + (ebrowse-display-member-list-for-accessor #'ebrowse-ts-types)) @@ -2565,8 +2496,8 @@ TAGS-FILE is the file name of the BROWSE file." "Force buffer redisplay." (interactive) (let ((display-fn (if ebrowse--long-display-flag - 'ebrowse-draw-member-long-fn - 'ebrowse-draw-member-short-fn))) + #'ebrowse-draw-member-long-fn + #'ebrowse-draw-member-short-fn))) (with-silent-modifications (erase-buffer) ;; Show this class @@ -2610,7 +2541,7 @@ the class cursor is on." "Start point for member buffer creation. LIST is the member list to display. STAND-ALONE non-nil means the member buffer is standalone. CLASS is its class." - (let* ((classes ebrowse--tree-obarray) + (let* ((classes ebrowse--tree-table) (tree ebrowse--tree) (tags-file ebrowse--tags-file-name) (header ebrowse--header) @@ -2630,7 +2561,7 @@ means the member buffer is standalone. CLASS is its class." (setq ebrowse--member-list (funcall list class) ebrowse--displayed-class class ebrowse--accessor list - ebrowse--tree-obarray classes + ebrowse--tree-table classes ebrowse--frozen-flag stand-alone ebrowse--tags-file-name tags-file ebrowse--header header @@ -2842,7 +2773,7 @@ REPEAT, if specified, says repeat the search REPEAT times." (cl-defun ebrowse-move-point-to-member (name &optional count &aux member) - "Set point on member NAME in the member buffer + "Set point on member NAME in the member buffer. COUNT, if specified, says search the COUNT'th member with the same name." (goto-char (point-min)) (widen) @@ -2867,7 +2798,8 @@ COMPL-LIST is a completion list to use." (class (or (ebrowse-completing-read-value title compl-list initial) (error "Not found")))) (setf ebrowse--displayed-class class - ebrowse--member-list (funcall ebrowse--accessor ebrowse--displayed-class)) + ebrowse--member-list (funcall ebrowse--accessor + ebrowse--displayed-class)) (ebrowse-redisplay-member-buffer))) @@ -2875,7 +2807,9 @@ COMPL-LIST is a completion list to use." "Switch member buffer to a class read from the minibuffer." (interactive) (ebrowse-switch-member-buffer-to-other-class - "Goto class: " (ebrowse-tree-obarray-as-alist))) + "Goto class: " + ;; FIXME: Why not use the hash-table as-is? + (ebrowse-tree-table-as-alist))) (defun ebrowse-switch-member-buffer-to-base-class (arg) @@ -2927,8 +2861,9 @@ Prefix arg INC specifies which one." (cl-first supers)))) (unless tree (error "Not found")) (setq containing-list (ebrowse-ts-subclasses tree))))) - (setq index (+ inc (ebrowse-position ebrowse--displayed-class - containing-list))) + (setq index (+ inc (seq-position containing-list + ebrowse--displayed-class + #'eql))) (cond ((cl-minusp index) (message "No previous class")) ((null (nth index containing-list)) (message "No next class"))) (setq index (max 0 (min index (1- (length containing-list))))) @@ -2943,16 +2878,16 @@ Prefix arg INC specifies which one." Prefix arg ARG says which class should be displayed. Default is the first derived class." (interactive "P") - (cl-flet ((ebrowse-tree-obarray-as-alist () + (cl-flet ((ebrowse-tree-table-as-alist () (cl-loop for s in (ebrowse-ts-subclasses ebrowse--displayed-class) - collect (cons (ebrowse-cs-name - (ebrowse-ts-class s)) s)))) + collect (cons (ebrowse-cs-name (ebrowse-ts-class s)) + s)))) (let ((subs (or (ebrowse-ts-subclasses ebrowse--displayed-class) (error "No derived classes")))) (if (and arg (cl-second subs)) (ebrowse-switch-member-buffer-to-other-class - "Goto derived class: " (ebrowse-tree-obarray-as-alist)) + "Goto derived class: " (ebrowse-tree-table-as-alist)) (setq ebrowse--displayed-class (cl-first subs) ebrowse--member-list (funcall ebrowse--accessor ebrowse--displayed-class)) @@ -3403,7 +3338,8 @@ It is a list (TREE ACCESSOR MEMBER)." (switch-to-buffer buffer) (setq ebrowse--displayed-class (cl-first info) ebrowse--accessor (cl-second info) - ebrowse--member-list (funcall ebrowse--accessor ebrowse--displayed-class)) + ebrowse--member-list (funcall ebrowse--accessor + ebrowse--displayed-class)) (ebrowse-redisplay-member-buffer))) (ebrowse-move-point-to-member (ebrowse-ms-name (cl-third info))))) @@ -3513,28 +3449,20 @@ KIND is an additional string printed in the buffer." (_ "unknown")) "\n"))) -(defvar ebrowse-last-completion nil +(defvar-local ebrowse-last-completion nil "Text inserted by the last completion operation.") -(defvar ebrowse-last-completion-start nil +(defvar-local ebrowse-last-completion-start nil "String which was the basis for the last completion operation.") -(defvar ebrowse-last-completion-location nil +(defvar-local ebrowse-last-completion-location nil "Buffer position at which the last completion operation was initiated.") -(defvar ebrowse-last-completion-obarray nil +(defvar-local ebrowse-last-completion-table nil "Member used in last completion operation.") - - -(make-variable-buffer-local 'ebrowse-last-completion-obarray) -(make-variable-buffer-local 'ebrowse-last-completion-location) -(make-variable-buffer-local 'ebrowse-last-completion) -(make-variable-buffer-local 'ebrowse-last-completion-start) - - (defun ebrowse-some-member-table () "Return a hash table containing all members of a tree. @@ -3552,7 +3480,7 @@ use choose a tree." (defun ebrowse-cyclic-successor-in-string-list (string list) "Return the item following STRING in LIST. If STRING is the last element, return the first element as successor." - (or (nth (1+ (ebrowse-position string list 'string=)) list) + (or (nth (1+ (seq-position list string #'string=)) list) (cl-first list))) @@ -3583,7 +3511,7 @@ completion." ;; expansion ended, insert the next expansion. ((eq (point) ebrowse-last-completion-location) (setf list (all-completions ebrowse-last-completion-start - ebrowse-last-completion-obarray) + ebrowse-last-completion-table) completion (ebrowse-cyclic-successor-in-string-list ebrowse-last-completion list)) (cond ((null completion) @@ -3599,7 +3527,7 @@ completion." ;; buffer: Start new completion. (t (let* ((members (ebrowse-some-member-table)) - (completion (cl-first (all-completions pattern members nil)))) + (completion (cl-first (all-completions pattern members)))) (cond ((eq completion t)) ((null completion) (error "Can't find completion for `%s'" pattern)) @@ -3610,7 +3538,7 @@ completion." (setf ebrowse-last-completion-location (point) ebrowse-last-completion-start pattern ebrowse-last-completion completion - ebrowse-last-completion-obarray members)))))))) + ebrowse-last-completion-table members)))))))) ;;; Tags query replace & search @@ -3746,7 +3674,7 @@ looks like a function call to the member." ;;; Structures of this kind are the elements of the position stack. -(cl-defstruct (ebrowse-position (:type vector) :named) +(cl-defstruct (ebrowse-position) file-name ; in which file point ; point in file target ; t if target of a jump @@ -3888,7 +3816,7 @@ Runs the hook `ebrowse-electric-position-mode-hook'." (setq mode-line-format (copy-sequence mode-line-format)) ;; FIXME: Why not set `mode-name' to "Positions"? (setcar (memq 'mode-name mode-line-format) "Positions")) - (set (make-local-variable 'Helper-return-blurb) "return to buffer editing") + (setq-local Helper-return-blurb "return to buffer editing") (setq truncate-lines t buffer-read-only t)) @@ -4101,7 +4029,7 @@ NUMBER-OF-INSTANCE-VARIABLES NUMBER-OF-STATIC-FUNCTIONS NUMBER-OF-STATIC-VARIABLES:" (let ((classes 0) (member-functions 0) (member-variables 0) (static-functions 0) (static-variables 0)) - (ebrowse-for-all-trees (tree ebrowse--tree-obarray) + (ebrowse-for-all-trees (tree ebrowse--tree-table) (cl-incf classes) (cl-incf member-functions (length (ebrowse-ts-member-functions tree))) (cl-incf member-variables (length (ebrowse-ts-member-variables tree))) @@ -4391,10 +4319,4 @@ EVENT is the mouse event." (provide 'ebrowse) - -;; Local variables: -;; eval:(put 'ebrowse-ignoring-completion-case 'lisp-indent-hook 0) -;; eval:(put 'ebrowse-for-all-trees 'lisp-indent-hook 1) -;; End: - ;;; ebrowse.el ends here From 6075a7c5ae3fa456cd099946f6e042b57e925263 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 27 Mar 2020 12:54:52 -0400 Subject: [PATCH 24/37] * lisp/textmodes/tex-mode.el: Replace double-definition hack with an advice (tex-verbatim-environments): Add "Verbatim". (tex--guess-mode): Rename from tex-guess-mode and return the mode rather than calling it. (tex-mode): Replace second definition with an advice. --- lisp/textmodes/tex-mode.el | 60 +++++++++++++++++--------------------- 1 file changed, 27 insertions(+), 33 deletions(-) diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index f95979e2fcb..1b302e34a73 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -224,7 +224,7 @@ Should show the queue(s) that \\[tex-print] puts jobs on." :group 'tex-view) ;;;###autoload -(defcustom tex-default-mode 'latex-mode +(defcustom tex-default-mode #'latex-mode "Mode to enter for a new file that might be either TeX or LaTeX. This variable is used when it can't be determined whether the file is plain TeX or LaTeX or what because the file contains no commands. @@ -668,7 +668,9 @@ An alternative value is \" . \", if you use a font with a narrow period." "Default expressions to highlight in TeX modes.") (defvar tex-verbatim-environments - '("verbatim" "verbatim*")) + '("verbatim" "verbatim*" + "Verbatim" ;; From "fancyvrb" + )) (put 'tex-verbatim-environments 'safe-local-variable (lambda (x) (not (memq nil (mapcar #'stringp x))))) @@ -966,7 +968,7 @@ Inherits `shell-mode-map' with a few additions.") ;; This would be a lot simpler if we just used a regexp search, ;; but then it would be too slow. -(defun tex-guess-mode () +(defun tex--guess-mode () (let ((mode tex-default-mode) slash comment) (save-excursion (goto-char (point-min)) @@ -983,52 +985,40 @@ Inherits `shell-mode-map' with a few additions.") (regexp-opt '("documentstyle" "documentclass" "begin" "subsection" "section" "part" "chapter" "newcommand" - "renewcommand" "RequirePackage") 'words) + "renewcommand" "RequirePackage") + 'words) "\\|NeedsTeXFormat{LaTeX"))) (if (and (looking-at "document\\(style\\|class\\)\\(\\[.*\\]\\)?{slides}") ;; SliTeX is almost never used any more nowadays. (tex-executable-exists-p slitex-run-command)) - 'slitex-mode - 'latex-mode) - 'plain-tex-mode)))) - (funcall mode))) + #'slitex-mode + #'latex-mode) + #'plain-tex-mode)))) + mode)) ;; `tex-mode' plays two roles: it's the parent of several sub-modes ;; but it's also the function that chooses between those submodes. ;; To tell the difference between those two cases where the function ;; might be called, we check `delay-mode-hooks'. -(define-derived-mode tex-mode text-mode "generic-TeX" - (tex-common-initialization)) -;; We now move the function and define it again. This gives a warning -;; in the byte-compiler :-( but it's difficult to avoid because -;; `define-derived-mode' will necessarily define the function once -;; and we need to define it a second time for `autoload' to get the -;; proper docstring. -(defalias 'tex-mode-internal (symbol-function 'tex-mode)) - -;; Suppress the byte-compiler warning about multiple definitions. -;; This is a) ugly, and b) cheating, but this was the last -;; remaining warning from byte-compiling all of Emacs... -(eval-when-compile - (if (boundp 'byte-compile-function-environment) - (setq byte-compile-function-environment - (delq (assq 'tex-mode byte-compile-function-environment) - byte-compile-function-environment)))) - ;;;###autoload -(defun tex-mode () +(define-derived-mode tex-mode text-mode "generic-TeX" "Major mode for editing files of input for TeX, LaTeX, or SliTeX. +This is the shared parent mode of several submodes. Tries to determine (by looking at the beginning of the file) whether this file is for plain TeX, LaTeX, or SliTeX and calls `plain-tex-mode', -`latex-mode', or `slitex-mode', respectively. If it cannot be determined, +`latex-mode', or `slitex-mode', accordingly. If it cannot be determined, such as if there are no commands in the file, the value of `tex-default-mode' says which mode to use." - (interactive) - (if delay-mode-hooks - ;; We're called from one of the children already. - (tex-mode-internal) - (tex-guess-mode))) + (tex-common-initialization)) + +(advice-add 'tex-mode :around #'tex--redirect-to-submode) +(defun tex--redirect-to-submode (orig-fun) + "Redirect to one of the submodes when called directly." + (funcall (if delay-mode-hooks + ;; We're called from one of the children already. + orig-fun + (tex--guess-mode)))) ;; The following three autoloaded aliases appear to conflict with ;; AUCTeX. However, even though AUCTeX uses the mixed case variants @@ -1037,6 +1027,10 @@ says which mode to use." ;; AUCTeX to provide a fully functional user-level replacement. So ;; these aliases should remain as they are, in particular since AUCTeX ;; users are likely to use them. +;; Note from Stef: I don't understand the above explanation, the only +;; justification I can find to keep those confusing aliases is for those +;; users who may have files annotated with -*- LaTeX -*- (e.g. because they +;; received them from someone using AUCTeX). ;;;###autoload (defalias 'TeX-mode 'tex-mode) From 3fdb53b13ac06af91763410925ca71158bcff6da Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 27 Mar 2020 16:38:52 -0400 Subject: [PATCH 25/37] * lisp/gnus/gnus-registry.el: Use lexical-binding MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit (gnus-registry-install-shortcuts): Use a closure (with dynamic :documentation) (gnus-registry-user-format-function-M): Use define-obsolete-function-alias. (gnus-registry-article-marks-to-names): η-reduce. --- lisp/gnus/gnus-registry.el | 89 ++++++++++++++++++-------------------- 1 file changed, 43 insertions(+), 46 deletions(-) diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index fd2b44f7424..480ed80ef81 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -1,4 +1,4 @@ -;;; gnus-registry.el --- article registry for Gnus +;;; gnus-registry.el --- article registry for Gnus -*- lexical-binding: t; -*- ;; Copyright (C) 2002-2020 Free Software Foundation, Inc. @@ -62,10 +62,10 @@ ;; show the marks as single characters (see the :char property in ;; `gnus-registry-marks'): -;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars) +;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-chars) ;; show the marks by name (see `gnus-registry-marks'): -;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names) +;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-names) ;; TODO: @@ -588,7 +588,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." subject (< gnus-registry-minimum-subject-length (length subject))) (let ((groups (apply - 'append + #'append (mapcar (lambda (reference) (gnus-registry-get-id-key reference 'group)) @@ -615,7 +615,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." sender gnus-registry-unfollowed-addresses))) (let ((groups (apply - 'append + #'append (mapcar (lambda (reference) (gnus-registry-get-id-key reference 'group)) @@ -644,7 +644,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (not (gnus-grep-in-list recp gnus-registry-unfollowed-addresses))) - (let ((groups (apply 'append + (let ((groups (apply #'append (mapcar (lambda (reference) (gnus-registry-get-id-key reference 'group)) @@ -663,7 +663,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." ;; filter the found groups and return them ;; the found groups are NOT the full groups (setq found (gnus-registry-post-process-groups - "recipients" (mapconcat 'identity recipients ", ") found))) + "recipients" (mapconcat #'identity recipients ", ") found))) ;; after the (cond) we extract the actual value safely (car-safe found))) @@ -791,7 +791,8 @@ Consults `gnus-registry-ignored-groups' and ((stringp g) g) ((and (listp g) (nth 1 g)) (nth 0 g)) - (t nil))) gnus-registry-ignored-groups))) + (t nil))) + gnus-registry-ignored-groups))) ;; only use `gnus-parameter-registry-ignore' if ;; `gnus-registry-ignored-groups' is a list of lists ;; (it can be a list of regexes) @@ -871,7 +872,7 @@ Addresses without a name will say \"noname\"." (defun gnus-registry-sort-addresses (&rest addresses) "Return a normalized and sorted list of ADDRESSES." - (sort (mapcan 'gnus-registry-extract-addresses addresses) 'string-lessp)) + (sort (mapcan #'gnus-registry-extract-addresses addresses) 'string-lessp)) (defun gnus-registry-simplify-subject (subject) (if (stringp subject) @@ -961,16 +962,15 @@ Uses `gnus-registry-marks' to find what shortcuts to install." (intern (format function-format variant-name))) (shortcut (format "%c" (if remove (upcase data) data)))) (defalias function-name - ;; If it weren't for the function's docstring, we could - ;; use a closure, with lexical-let :-( - `(lambda (&rest articles) - ,(format - "%s the %s mark over process-marked ARTICLES." - (upcase-initials variant-name) - mark) - (interactive - (gnus-summary-work-articles current-prefix-arg)) - (gnus-registry--set/remove-mark ',mark ',remove articles))) + (lambda (&rest articles) + (:documentation + (format + "%s the %s mark over process-marked ARTICLES." + (upcase-initials variant-name) + mark)) + (interactive + (gnus-summary-work-articles current-prefix-arg)) + (gnus-registry--set/remove-mark mark remove articles))) (push function-name keys-plist) (push shortcut keys-plist) (push (vector (format "%s %s" @@ -990,14 +990,11 @@ Uses `gnus-registry-marks' to find what shortcuts to install." nil (cons "Registry Marks" gnus-registry-misc-menus)))))) -(make-obsolete 'gnus-registry-user-format-function-M - 'gnus-registry-article-marks-to-chars "24.1") ? - -(defalias 'gnus-registry-user-format-function-M - 'gnus-registry-article-marks-to-chars) +(define-obsolete-function-alias 'gnus-registry-user-format-function-M + #'gnus-registry-article-marks-to-chars "24.1") ;; use like this: -;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars) +;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-chars) (defun gnus-registry-article-marks-to-chars (headers) "Show the marks for an article by the :char property." (if gnus-registry-enabled @@ -1013,20 +1010,20 @@ Uses `gnus-registry-marks' to find what shortcuts to install." "")) ;; use like this: -;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names) +;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-names) (defun gnus-registry-article-marks-to-names (headers) "Show the marks for an article by name." (if gnus-registry-enabled (let* ((id (mail-header-message-id headers)) (marks (when id (gnus-registry-get-id-key id 'mark)))) - (mapconcat (lambda (mark) (symbol-name mark)) marks ",")) + (mapconcat #'symbol-name marks ",")) "")) (defun gnus-registry-read-mark () "Read a mark name from the user with completion." (let ((mark (gnus-completing-read "Label" - (mapcar 'symbol-name (mapcar 'car gnus-registry-marks)) + (mapcar #'symbol-name (mapcar #'car gnus-registry-marks)) nil nil nil (symbol-name gnus-registry-default-mark)))) (when (stringp mark) @@ -1050,7 +1047,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install." show-message) "Apply or remove MARK across a list of ARTICLES." (let ((article-id-list - (mapcar 'gnus-registry-fetch-message-id-fast articles))) + (mapcar #'gnus-registry-fetch-message-id-fast articles))) (dolist (id article-id-list) (let* ((marks (delq mark (gnus-registry-get-id-key id 'mark))) (marks (if remove marks (cons mark marks)))) @@ -1173,34 +1170,34 @@ only the last one's marks are returned." (gnus-registry-install-shortcuts) (if (gnus-alive-p) (gnus-registry-load) - (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-load))) + (add-hook 'gnus-read-newsrc-el-hook #'gnus-registry-load))) (defun gnus-registry-install-hooks () "Install the registry hooks." (setq gnus-registry-enabled t) - (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action) - (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) - (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) - (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action) + (add-hook 'gnus-summary-article-move-hook #'gnus-registry-action) + (add-hook 'gnus-summary-article-delete-hook #'gnus-registry-action) + (add-hook 'gnus-summary-article-expire-hook #'gnus-registry-action) + (add-hook 'nnmail-spool-hook #'gnus-registry-spool-action) - (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save) + (add-hook 'gnus-save-newsrc-hook #'gnus-registry-save) - (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) + (add-hook 'gnus-summary-prepare-hook #'gnus-registry-register-message-ids)) (defun gnus-registry-unload-hook () "Uninstall the registry hooks." - (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action) - (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) - (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) - (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action) + (remove-hook 'gnus-summary-article-move-hook #'gnus-registry-action) + (remove-hook 'gnus-summary-article-delete-hook #'gnus-registry-action) + (remove-hook 'gnus-summary-article-expire-hook #'gnus-registry-action) + (remove-hook 'nnmail-spool-hook #'gnus-registry-spool-action) - (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save) - (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-load) + (remove-hook 'gnus-save-newsrc-hook #'gnus-registry-save) + (remove-hook 'gnus-read-newsrc-el-hook #'gnus-registry-load) - (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids) + (remove-hook 'gnus-summary-prepare-hook #'gnus-registry-register-message-ids) (setq gnus-registry-enabled nil)) -(add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook) +(add-hook 'gnus-registry-unload-hook #'gnus-registry-unload-hook) (defun gnus-registry-install-p () "Return non-nil if the registry is enabled (and maybe enable it first). @@ -1234,7 +1231,7 @@ data stored in the registry." (seen-groups (list (gnus-group-group-name)))) (catch 'found - (dolist (group (mapcar 'gnus-simplify-group-name groups)) + (dolist (group (mapcar #'gnus-simplify-group-name groups)) ;; skip over any groups we really don't want to warp to. (unless (or (member group seen-groups) @@ -1270,7 +1267,7 @@ EXTRA is a list of symbols. Valid symbols are those contained in the docs of `gnus-registry-track-extra'. This command is useful when you stop tracking some extra data and now want to purge it from your existing entries." - (interactive (list (mapcar 'intern + (interactive (list (mapcar #'intern (completing-read-multiple "Extra data: " '("subject" "sender" "recipient"))))) From 09d67716e5492306c0bf704e6538d22a5bc76405 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 27 Mar 2020 17:14:34 -0400 Subject: [PATCH 26/37] * lisp/emacs-lisp/cl-macs.el (cl-defstruct): Declare the type immediately --- lisp/emacs-lisp/cl-macs.el | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 954731b06b8..7f5d197b532 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2868,7 +2868,9 @@ Supported keywords for slots are: (append pred-form '(t)) `(and ,pred-form t))) forms) - (push `(put ',name 'cl-deftype-satisfies ',predicate) forms)) + (push `(eval-and-compile + (put ',name 'cl-deftype-satisfies ',predicate)) + forms)) (let ((pos 0) (descp descs)) (while descp (let* ((desc (pop descp)) @@ -3138,6 +3140,7 @@ Of course, we really can't know that for sure, so it's just a heuristic." ;; "Obvious" mappings. (string . stringp) (list . listp) + (cons . consp) (symbol . symbolp) (function . functionp) (integer . integerp) From 90b6ba0a1697c07a668be1776f22246470682724 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Fri, 27 Mar 2020 14:17:44 -0700 Subject: [PATCH 27/37] Use ATTRIBUTE_CONST for some bignum functions * src/bignum.h (mpz_get_d_rounded): * src/lisp.h (bignum_to_double, bignum_to_intmax) (bignum_to_uintmax, bignum_bufsize): Declare as ATTRIBUTE_CONST. --- src/bignum.h | 2 +- src/lisp.h | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/bignum.h b/src/bignum.h index 0c2541a9dc7..ad9021f15fd 100644 --- a/src/bignum.h +++ b/src/bignum.h @@ -55,7 +55,7 @@ extern void emacs_mpz_mul_2exp (mpz_t, mpz_t const, EMACS_INT) ARG_NONNULL ((1, 2)); extern void emacs_mpz_pow_ui (mpz_t, mpz_t const, unsigned long) ARG_NONNULL ((1, 2)); -extern double mpz_get_d_rounded (mpz_t const); +extern double mpz_get_d_rounded (mpz_t const) ATTRIBUTE_CONST; INLINE_HEADER_BEGIN diff --git a/src/lisp.h b/src/lisp.h index d3b1c39c8fb..f223814d8f3 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -585,7 +585,7 @@ INLINE void set_sub_char_table_contents (Lisp_Object, ptrdiff_t, Lisp_Object); /* Defined in bignum.c. */ -extern double bignum_to_double (Lisp_Object); +extern double bignum_to_double (Lisp_Object) ATTRIBUTE_CONST; extern Lisp_Object make_bigint (intmax_t); extern Lisp_Object make_biguint (uintmax_t); @@ -3484,9 +3484,9 @@ set_sub_char_table_contents (Lisp_Object table, ptrdiff_t idx, Lisp_Object val) /* Defined in bignum.c. This part of bignum.c's API does not require the caller to access bignum internals; see bignum.h for that. */ -extern intmax_t bignum_to_intmax (Lisp_Object); -extern uintmax_t bignum_to_uintmax (Lisp_Object); -extern ptrdiff_t bignum_bufsize (Lisp_Object, int); +extern intmax_t bignum_to_intmax (Lisp_Object) ATTRIBUTE_CONST; +extern uintmax_t bignum_to_uintmax (Lisp_Object) ATTRIBUTE_CONST; +extern ptrdiff_t bignum_bufsize (Lisp_Object, int) ATTRIBUTE_CONST; extern ptrdiff_t bignum_to_c_string (char *, ptrdiff_t, Lisp_Object, int); extern Lisp_Object bignum_to_string (Lisp_Object, int); extern Lisp_Object make_bignum_str (char const *, int); From e6c6486ee0b4e50c61c062f475bbe473cfd397f9 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sat, 28 Mar 2020 12:59:03 +0100 Subject: [PATCH 28/37] Tramp cache fixes * lisp/net/tramp-adb.el (tramp-adb-handle-write-region): * lisp/net/tramp-smb.el (tramp-smb-handle-write-region): Flush the cache after the file has been written. --- lisp/net/tramp-adb.el | 7 ++++--- lisp/net/tramp-smb.el | 7 ++++--- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index bfeaebac2cd..4512179eb14 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -629,9 +629,6 @@ But handle the case, if the \"test\" command is not available." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) (let* ((curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) @@ -648,6 +645,10 @@ But handle the case, if the \"test\" command is not available." (tramp-error v 'file-error "Cannot write: `%s'" filename)) (delete-file tmpfile))) + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v localname) + (unless (equal curbuf (current-buffer)) (tramp-error v 'file-error diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index effac333dad..100ddfaa681 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -1557,9 +1557,6 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) (let ((curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) @@ -1579,6 +1576,10 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (tramp-error v 'file-error "Cannot write `%s'" filename)) (delete-file tmpfile))) + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v localname) + (unless (equal curbuf (current-buffer)) (tramp-error v 'file-error From dfeb87d8e54ee5f2ce3e16d34a812131bb2f6e4d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= Date: Thu, 26 Mar 2020 10:58:30 +0100 Subject: [PATCH 29/37] Turn compilation-error-case-fold-search into a defvar See bug#40119, and the discussion at https://lists.gnu.org/archive/html/emacs-devel/2020-03/msg00653.html * lisp/progmodes/compile.el (compilation-error-case-fold-search): Turn into a defvar. * etc/NEWS: Update. --- etc/NEWS | 6 ++++-- lisp/progmodes/compile.el | 10 ++++++---- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 49b7fcd8c21..870d39f7eef 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -218,8 +218,10 @@ Defaults to 'libravatar', with 'unicornify' and 'gravatar' as options. ** Compilation mode *** Regexp matching of messages is now case-sensitive by default. -The user option 'compilation-error-case-fold-search' can be set -for case-insensitive matching of messages. +The variable 'compilation-error-case-fold-search' can be set for +case-insensitive matching of messages when the old behaviour is +required, but the recommended solution is to use a correctly matching +regexp instead. * New Modes and Packages in Emacs 28.1 diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index f4532b7edb7..e5878b28f96 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -646,13 +646,15 @@ matched file names, and weeding out false positives." :link `(file-link :tag "example file" ,(expand-file-name "compilation.txt" data-directory))) -(defcustom compilation-error-case-fold-search nil +(defvar compilation-error-case-fold-search nil "If non-nil, use case-insensitive matching of compilation errors by the regexps of `compilation-error-regexp-alist' and `compilation-error-regexp-alist-alist'. -If nil, matching is case-sensitive." - :type 'boolean - :version "28.1") +If nil, matching is case-sensitive. + +This variable should only be set for backward compatibility as a temporary +measure. The proper solution is to use a regexp that matches the +messages without case-folding.") ;;;###autoload(put 'compilation-directory 'safe-local-variable 'stringp) (defvar compilation-directory nil From a7e3516571e72e58bb4b5d19eca5feca41135f57 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 28 Mar 2020 09:41:15 -0400 Subject: [PATCH 30/37] * lisp/progmodes/ebrowse.el (ebrowse-tags-loop-call): Rename Used to be called `ebrowse-tags-loop-form` and passed to `eval`. Now it's passed to `apply` instead, which is better for karma. (ebrowse-tags-loop-continue, ebrowse-tags-search) (ebrowse-tags-query-replace, ebrowse-tags-search-member-use): Adjust accordingly. (ebrowse-electric-position-mode-map): Move init into declaration. (ebrowse-electric-position-mode): Derive from special. --- lisp/progmodes/ebrowse.el | 46 +++++++++++++++++++-------------------- 1 file changed, 22 insertions(+), 24 deletions(-) diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el index c02703fc59f..1c9e805f039 100644 --- a/lisp/progmodes/ebrowse.el +++ b/lisp/progmodes/ebrowse.el @@ -3543,9 +3543,9 @@ completion." ;;; Tags query replace & search -(defvar ebrowse-tags-loop-form () - "Form for `ebrowse-loop-continue'. -Evaluated for each file in the tree. If it returns nil, proceed +(defvar ebrowse-tags-loop-call '(ignore) + "Function call for `ebrowse-loop-continue'. +Passed to `apply' for each file in the tree. If it returns nil, proceed with the next file.") (defvar ebrowse-tags-next-file-list () @@ -3612,7 +3612,7 @@ TREE-BUFFER if indirectly specifies which files to loop over." (when first-time (ebrowse-tags-next-file first-time tree-buffer) (goto-char (point-min))) - (while (not (eval ebrowse-tags-loop-form)) + (while (not (apply ebrowse-tags-loop-call)) (ebrowse-tags-next-file) (message "Scanning file `%s'..." buffer-file-name) (goto-char (point-min)))) @@ -3625,9 +3625,9 @@ If marked classes exist, process marked classes, only. If regular expression is nil, repeat last search." (interactive "sTree search (regexp): ") (if (and (string= regexp "") - (eq (car ebrowse-tags-loop-form) 're-search-forward)) + (eq (car ebrowse-tags-loop-call) #'re-search-forward)) (ebrowse-tags-loop-continue) - (setq ebrowse-tags-loop-form (list 're-search-forward regexp nil t)) + (setq ebrowse-tags-loop-call `(re-search-forward ,regexp nil t)) (ebrowse-tags-loop-continue 'first-time))) @@ -3637,10 +3637,11 @@ If regular expression is nil, repeat last search." With prefix arg, process files of marked classes only." (interactive "sTree query replace (regexp): \nsTree query replace %s by: ") - (setq ebrowse-tags-loop-form - (list 'and (list 'save-excursion - (list 're-search-forward from nil t)) - (list 'not (list 'perform-replace from to t t nil)))) + (setq ebrowse-tags-loop-call + (list (lambda () + (and (save-excursion + (re-search-forward from nil t)) + (not (perform-replace from to t t nil)))))) (ebrowse-tags-loop-continue 'first-time)) @@ -3665,7 +3666,7 @@ looks like a function call to the member." (cl-values-list (ebrowse-tags-read-name header "Find calls of: ")))) ;; Set tags loop form to search for member and begin loop. (setq regexp (concat "\\<" name "[ \t]*(") - ebrowse-tags-loop-form (list 're-search-forward regexp nil t)) + ebrowse-tags-loop-call `(re-search-forward ,regexp nil t)) (ebrowse-tags-loop-continue 'first-time tree-buffer)))) @@ -3767,18 +3768,10 @@ Prefix arg ARG says how much." ;;; Electric position list -(defvar ebrowse-electric-position-mode-map () - "Keymap used in electric position stack window.") - - -(defvar ebrowse-electric-position-mode-hook nil - "If non-nil, its value is called by `ebrowse-electric-position-mode'.") - - -(unless ebrowse-electric-position-mode-map +(defvar ebrowse-electric-position-mode-map (let ((map (make-keymap)) (submap (make-keymap))) - (setq ebrowse-electric-position-mode-map map) + ;; FIXME: Yuck! (fillarray (car (cdr map)) 'ebrowse-electric-position-undefined) (fillarray (car (cdr submap)) 'ebrowse-electric-position-undefined) (define-key map "\e" submap) @@ -3801,14 +3794,19 @@ Prefix arg ARG says how much." (define-key map "\e\C-v" 'scroll-other-window) (define-key map "\e>" 'end-of-buffer) (define-key map "\e<" 'beginning-of-buffer) - (define-key map "\e>" 'end-of-buffer))) + (define-key map "\e>" 'end-of-buffer) + map) + "Keymap used in electric position stack window.") + + +(defvar ebrowse-electric-position-mode-hook nil + "If non-nil, its value is called by `ebrowse-electric-position-mode'.") -(put 'ebrowse-electric-position-mode 'mode-class 'special) (put 'ebrowse-electric-position-undefined 'suppress-keymap t) (define-derived-mode ebrowse-electric-position-mode - fundamental-mode "Electric Position Menu" + special-mode "Electric Position Menu" "Mode for electric position buffers. Runs the hook `ebrowse-electric-position-mode-hook'." (setq mode-line-buffer-identification "Electric Position Menu") From dceba13ce57ed0cb726e89566197f77359a38d91 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 28 Mar 2020 10:16:58 -0400 Subject: [PATCH 31/37] * lisp/jit-lock.el (jit-lock-mode): Pass `local` to add-hook The old code used local=nil knowing that add-hook would affect the local part only anyway. Remove this hideous assumption. Remove redundant `:group` args while we're at it. --- lisp/jit-lock.el | 31 +++++++++++-------------------- 1 file changed, 11 insertions(+), 20 deletions(-) diff --git a/lisp/jit-lock.el b/lisp/jit-lock.el index d73cd74da0b..9cdb108be03 100644 --- a/lisp/jit-lock.el +++ b/lisp/jit-lock.el @@ -48,8 +48,7 @@ Preserves the `buffer-modified-p' state of the current buffer." "Jit-lock fontifies chunks of at most this many characters at a time. This variable controls both display-time and stealth fontification." - :type 'integer - :group 'jit-lock) + :type 'integer) (defcustom jit-lock-stealth-time nil @@ -59,8 +58,7 @@ If nil, stealth fontification is never performed. The value of this variable is used when JIT Lock mode is turned on." :type '(choice (const :tag "never" nil) - (number :tag "seconds" :value 16)) - :group 'jit-lock) + (number :tag "seconds" :value 16))) (defcustom jit-lock-stealth-nice 0.5 @@ -72,8 +70,7 @@ To reduce machine load during stealth fontification, at the cost of stealth taking longer to fontify, you could increase the value of this variable. See also `jit-lock-stealth-load'." :type '(choice (const :tag "never" nil) - (number :tag "seconds")) - :group 'jit-lock) + (number :tag "seconds"))) (defcustom jit-lock-stealth-load @@ -89,14 +86,12 @@ See also `jit-lock-stealth-nice'." :type (if (condition-case nil (load-average) (error)) '(choice (const :tag "never" nil) (integer :tag "load")) - '(const :format "%t: unsupported\n" nil)) - :group 'jit-lock) + '(const :format "%t: unsupported\n" nil))) (defcustom jit-lock-stealth-verbose nil "If non-nil, means stealth fontification should show status messages." - :type 'boolean - :group 'jit-lock) + :type 'boolean) (defvaralias 'jit-lock-defer-contextually 'jit-lock-contextually) @@ -115,13 +110,11 @@ buffer mode's syntax table, i.e., only if `font-lock-keywords-only' is nil. The value of this variable is used when JIT Lock mode is turned on." :type '(choice (const :tag "never" nil) (const :tag "always" t) - (other :tag "syntax-driven" syntax-driven)) - :group 'jit-lock) + (other :tag "syntax-driven" syntax-driven))) (defcustom jit-lock-context-time 0.5 "Idle time after which text is contextually refontified, if applicable." - :type '(number :tag "seconds") - :group 'jit-lock) + :type '(number :tag "seconds")) (defcustom jit-lock-antiblink-grace 2 "Delay after which to refontify unterminated strings and comments. @@ -134,14 +127,12 @@ and comments, the delay helps avoid unpleasant \"blinking\", between string/comment and non-string/non-comment fontification." :type '(choice (const :tag "never" nil) (number :tag "seconds")) - :group 'jit-lock :version "27.1") (defcustom jit-lock-defer-time nil ;; 0.25 "Idle time after which deferred fontification should take place. If nil, fontification is not deferred. If 0, then fontification is only deferred while there is input pending." - :group 'jit-lock :type '(choice (const :tag "never" nil) (number :tag "seconds"))) @@ -262,7 +253,7 @@ If you need to debug code run from jit-lock, see `jit-lock-debug-mode'." ;; Setup our hooks. (add-hook 'after-change-functions 'jit-lock-after-change nil t) - (add-hook 'fontification-functions 'jit-lock-function)) + (add-hook 'fontification-functions 'jit-lock-function nil t)) ;; Turn Just-in-time Lock mode off. (t @@ -294,7 +285,7 @@ If you need to debug code run from jit-lock, see `jit-lock-debug-mode'." When this minor mode is enabled, jit-lock runs as little code as possible during redisplay and moves the rest to a timer, where things like `debug-on-error' and Edebug can be used." - :global t :group 'jit-lock + :global t (when jit-lock-defer-timer (cancel-timer jit-lock-defer-timer) (setq jit-lock-defer-timer nil)) @@ -438,8 +429,8 @@ Defaults to the whole buffer. END can be out of bounds." (quit (put-text-property start next 'fontified nil) (signal (car err) (cdr err)))))) - ;; In case we fontified more than requested, take advantage of the - ;; good news. + ;; In case we fontified more than requested, take + ;; advantage of the good news. (when (or (< tight-beg start) (> tight-end next)) (put-text-property tight-beg tight-end 'fontified t)) From a775dca449ca8da2e2619ea608a3849f70fa951e Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Sat, 28 Mar 2020 13:50:02 -0700 Subject: [PATCH 32/37] Update from Gnulib This incorporates: 2020-03-28 Use module 'filename' instead of module 'dosname' 2020-03-28 dosname: Redirect to 'filename' * lib/at-func.c, lib/canonicalize-lgpl.c, lib/dosname.h: Copy from Gnulib. * lib/gnulib.mk.in, m4/gnulib-comp.m4: Regenerate. * lib/filename.h: New file, copied from Gnulib. --- lib/at-func.c | 2 +- lib/canonicalize-lgpl.c | 2 +- lib/dosname.h | 38 +------------- lib/filename.h | 110 ++++++++++++++++++++++++++++++++++++++++ lib/gnulib.mk.in | 9 ++++ m4/gnulib-comp.m4 | 2 + 6 files changed, 125 insertions(+), 38 deletions(-) create mode 100644 lib/filename.h diff --git a/lib/at-func.c b/lib/at-func.c index 4a1c909d38e..90022e05787 100644 --- a/lib/at-func.c +++ b/lib/at-func.c @@ -16,7 +16,7 @@ /* written by Jim Meyering */ -#include "dosname.h" /* solely for definition of IS_ABSOLUTE_FILE_NAME */ +#include "filename.h" /* solely for definition of IS_ABSOLUTE_FILE_NAME */ #ifdef GNULIB_SUPPORT_ONLY_AT_FDCWD # include diff --git a/lib/canonicalize-lgpl.c b/lib/canonicalize-lgpl.c index 7d3c710f10f..9f990988393 100644 --- a/lib/canonicalize-lgpl.c +++ b/lib/canonicalize-lgpl.c @@ -51,7 +51,7 @@ # define __realpath realpath # include "pathmax.h" # include "malloca.h" -# include "dosname.h" +# include "filename.h" # if HAVE_GETCWD # if IN_RELOCWRAPPER /* When building the relocatable program wrapper, use the system's getcwd diff --git a/lib/dosname.h b/lib/dosname.h index 57829600948..490e0c5a7dd 100644 --- a/lib/dosname.h +++ b/lib/dosname.h @@ -13,40 +13,6 @@ GNU General Public License for more details. You should have received a copy of the GNU General Public License - along with this program. If not, see . + along with this program. If not, see . */ - From Paul Eggert and Jim Meyering. */ - -#ifndef _DOSNAME_H -#define _DOSNAME_H - -#if (defined _WIN32 || defined __CYGWIN__ \ - || defined __EMX__ || defined __MSDOS__ || defined __DJGPP__) - /* This internal macro assumes ASCII, but all hosts that support drive - letters use ASCII. */ -# define _IS_DRIVE_LETTER(C) (((unsigned int) (C) | ('a' - 'A')) - 'a' \ - <= 'z' - 'a') -# define FILE_SYSTEM_PREFIX_LEN(Filename) \ - (_IS_DRIVE_LETTER ((Filename)[0]) && (Filename)[1] == ':' ? 2 : 0) -# ifndef __CYGWIN__ -# define FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE 1 -# endif -# define ISSLASH(C) ((C) == '/' || (C) == '\\') -#else -# define FILE_SYSTEM_PREFIX_LEN(Filename) 0 -# define ISSLASH(C) ((C) == '/') -#endif - -#ifndef FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE -# define FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE 0 -#endif - -#if FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE -# define IS_ABSOLUTE_FILE_NAME(F) ISSLASH ((F)[FILE_SYSTEM_PREFIX_LEN (F)]) -# else -# define IS_ABSOLUTE_FILE_NAME(F) \ - (ISSLASH ((F)[0]) || FILE_SYSTEM_PREFIX_LEN (F) != 0) -#endif -#define IS_RELATIVE_FILE_NAME(F) (! IS_ABSOLUTE_FILE_NAME (F)) - -#endif /* DOSNAME_H_ */ +#include "filename.h" diff --git a/lib/filename.h b/lib/filename.h new file mode 100644 index 00000000000..4598fb1d638 --- /dev/null +++ b/lib/filename.h @@ -0,0 +1,110 @@ +/* Basic filename support macros. + Copyright (C) 2001-2004, 2007-2020 Free Software Foundation, Inc. + + This program 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. + + This program 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 this program. If not, see . */ + +/* From Paul Eggert and Jim Meyering. */ + +#ifndef _FILENAME_H +#define _FILENAME_H + +#include + +#ifdef __cplusplus +extern "C" { +#endif + + +/* Filename support. + ISSLASH(C) tests whether C is a directory separator + character. + HAS_DEVICE(Filename) tests whether Filename contains a device + specification. + FILE_SYSTEM_PREFIX_LEN(Filename) length of the device specification + at the beginning of Filename, + index of the part consisting of + alternating components and slashes. + FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE + 1 when a non-empty device specification + can be followed by an empty or relative + part, + 0 when a non-empty device specification + must be followed by a slash, + 0 when device specification don't exist. + IS_ABSOLUTE_FILE_NAME(Filename) + tests whether Filename is independent of + any notion of "current directory". + IS_RELATIVE_FILE_NAME(Filename) + tests whether Filename may be concatenated + to a directory filename. + Note: On native Windows, OS/2, DOS, "c:" is neither an absolute nor a + relative file name! + IS_FILE_NAME_WITH_DIR(Filename) tests whether Filename contains a device + or directory specification. + */ +#if defined _WIN32 || defined __CYGWIN__ \ + || defined __EMX__ || defined __MSDOS__ || defined __DJGPP__ + /* Native Windows, Cygwin, OS/2, DOS */ +# define ISSLASH(C) ((C) == '/' || (C) == '\\') + /* Internal macro: Tests whether a character is a drive letter. */ +# define _IS_DRIVE_LETTER(C) \ + (((C) >= 'A' && (C) <= 'Z') || ((C) >= 'a' && (C) <= 'z')) + /* Help the compiler optimizing it. This assumes ASCII. */ +# undef _IS_DRIVE_LETTER +# define _IS_DRIVE_LETTER(C) \ + (((unsigned int) (C) | ('a' - 'A')) - 'a' <= 'z' - 'a') +# define HAS_DEVICE(Filename) \ + (_IS_DRIVE_LETTER ((Filename)[0]) && (Filename)[1] == ':') +# define FILE_SYSTEM_PREFIX_LEN(Filename) (HAS_DEVICE (Filename) ? 2 : 0) +# ifdef __CYGWIN__ +# define FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE 0 +# else + /* On native Windows, OS/2, DOS, the system has the notion of a + "current directory" on each drive. */ +# define FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE 1 +# endif +# if FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE +# define IS_ABSOLUTE_FILE_NAME(Filename) \ + ISSLASH ((Filename)[FILE_SYSTEM_PREFIX_LEN (Filename)]) +# else +# define IS_ABSOLUTE_FILE_NAME(Filename) \ + (ISSLASH ((Filename)[0]) || HAS_DEVICE (Filename)) +# endif +# define IS_RELATIVE_FILE_NAME(Filename) \ + (! (ISSLASH ((Filename)[0]) || HAS_DEVICE (Filename))) +# define IS_FILE_NAME_WITH_DIR(Filename) \ + (strchr ((Filename), '/') != NULL || strchr ((Filename), '\\') != NULL \ + || HAS_DEVICE (Filename)) +#else + /* Unix */ +# define ISSLASH(C) ((C) == '/') +# define HAS_DEVICE(Filename) ((void) (Filename), 0) +# define FILE_SYSTEM_PREFIX_LEN(Filename) ((void) (Filename), 0) +# define FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE 0 +# define IS_ABSOLUTE_FILE_NAME(Filename) ISSLASH ((Filename)[0]) +# define IS_RELATIVE_FILE_NAME(Filename) (! ISSLASH ((Filename)[0])) +# define IS_FILE_NAME_WITH_DIR(Filename) (strchr ((Filename), '/') != NULL) +#endif + +/* Deprecated macros. For backward compatibility with old users of the + 'filename' module. */ +#define IS_ABSOLUTE_PATH IS_ABSOLUTE_FILE_NAME +#define IS_PATH_WITH_DIR IS_FILE_NAME_WITH_DIR + + +#ifdef __cplusplus +} +#endif + +#endif /* _FILENAME_H */ diff --git a/lib/gnulib.mk.in b/lib/gnulib.mk.in index e90d2e39049..256bda7752e 100644 --- a/lib/gnulib.mk.in +++ b/lib/gnulib.mk.in @@ -1672,6 +1672,15 @@ EXTRA_DIST += filemode.h endif ## end gnulib module filemode +## begin gnulib module filename +ifeq (,$(OMIT_GNULIB_MODULE_filename)) + + +EXTRA_DIST += filename.h + +endif +## end gnulib module filename + ## begin gnulib module filevercmp ifeq (,$(OMIT_GNULIB_MODULE_filevercmp)) diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 3228aa42b57..f92222dd771 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -87,6 +87,7 @@ AC_DEFUN([gl_EARLY], # Code from module fcntl-h: # Code from module fdopendir: # Code from module filemode: + # Code from module filename: # Code from module filevercmp: # Code from module flexmember: # Code from module fpending: @@ -977,6 +978,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/fdopendir.c lib/filemode.c lib/filemode.h + lib/filename.h lib/filevercmp.c lib/filevercmp.h lib/flexmember.h From 4f41188a6e1eb0ce832bd74907642f30ada344d9 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Sat, 28 Mar 2020 13:58:44 -0700 Subject: [PATCH 33/37] Stop using newly-deprecated dosname Gnulib module Code is supposed to use the filename module now. * admin/merge-gnulib (GNULIB_MODULES): Replace dosname with filename. * lib/dosname.h: Remove this forwarding stub. * lib/gnulib.mk.in, m4/gnulib-comp.m4: Regenerate. * lib-src/emacsclient.c, src/fileio.c: Include filename.h instead of dosname.h. --- admin/merge-gnulib | 4 ++-- lib-src/emacsclient.c | 2 +- lib/dosname.h | 18 ------------------ lib/gnulib.mk.in | 11 +---------- m4/gnulib-comp.m4 | 2 -- src/fileio.c | 2 +- 6 files changed, 5 insertions(+), 34 deletions(-) delete mode 100644 lib/dosname.h diff --git a/admin/merge-gnulib b/admin/merge-gnulib index 768e5051f0b..99469e47aa7 100755 --- a/admin/merge-gnulib +++ b/admin/merge-gnulib @@ -31,10 +31,10 @@ GNULIB_MODULES=' careadlinkat close-stream copy-file-range count-leading-zeros count-one-bits count-trailing-zeros crypto/md5-buffer crypto/sha1-buffer crypto/sha256-buffer crypto/sha512-buffer - d-type diffseq dosname double-slash-root dtoastr dtotimespec dup2 + d-type diffseq double-slash-root dtoastr dtotimespec dup2 environ execinfo explicit_bzero faccessat fchmodat fcntl fcntl-h fdopendir - filemode filevercmp flexmember fpieee fstatat fsusage fsync futimens + filemode filename filevercmp flexmember fpieee fstatat fsusage fsync futimens getloadavg getopt-gnu gettime gettimeofday gitlog-to-changelog ieee754-h ignore-value intprops largefile lstat manywarnings memmem-simple mempcpy memrchr minmax mkostemp mktime nstrftime diff --git a/lib-src/emacsclient.c b/lib-src/emacsclient.c index 204064f1871..380be95222b 100644 --- a/lib-src/emacsclient.c +++ b/lib-src/emacsclient.c @@ -80,7 +80,7 @@ char *w32_getenv (const char *); #include #include -#include +#include #include #include #include diff --git a/lib/dosname.h b/lib/dosname.h deleted file mode 100644 index 490e0c5a7dd..00000000000 --- a/lib/dosname.h +++ /dev/null @@ -1,18 +0,0 @@ -/* File names on MS-DOS/Windows systems. - - Copyright (C) 2000-2001, 2004-2006, 2009-2020 Free Software Foundation, Inc. - - This program 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. - - This program 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 this program. If not, see . */ - -#include "filename.h" diff --git a/lib/gnulib.mk.in b/lib/gnulib.mk.in index 256bda7752e..0c7c2fb2b66 100644 --- a/lib/gnulib.mk.in +++ b/lib/gnulib.mk.in @@ -86,7 +86,6 @@ # crypto/sha512-buffer \ # d-type \ # diffseq \ -# dosname \ # double-slash-root \ # dtoastr \ # dtotimespec \ @@ -100,6 +99,7 @@ # fcntl-h \ # fdopendir \ # filemode \ +# filename \ # filevercmp \ # flexmember \ # fpieee \ @@ -1452,15 +1452,6 @@ EXTRA_libgnu_a_SOURCES += dirfd.c endif ## end gnulib module dirfd -## begin gnulib module dosname -ifeq (,$(OMIT_GNULIB_MODULE_dosname)) - - -EXTRA_DIST += dosname.h - -endif -## end gnulib module dosname - ## begin gnulib module dtoastr ifeq (,$(OMIT_GNULIB_MODULE_dtoastr)) diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index f92222dd771..d5faa9a1950 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -69,7 +69,6 @@ AC_DEFUN([gl_EARLY], # Code from module diffseq: # Code from module dirent: # Code from module dirfd: - # Code from module dosname: # Code from module double-slash-root: # Code from module dtoastr: # Code from module dtotimespec: @@ -962,7 +961,6 @@ AC_DEFUN([gl_FILE_LIST], [ lib/diffseq.h lib/dirent.in.h lib/dirfd.c - lib/dosname.h lib/dtoastr.c lib/dtotimespec.c lib/dup2.c diff --git a/src/fileio.c b/src/fileio.c index ffe79559a3f..978a373d39b 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -96,7 +96,7 @@ along with GNU Emacs. If not, see . */ #include #include #include -#include +#include #include #include #include From d1b8179f55da75fce313118502ba65444ee1dc98 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Sun, 29 Mar 2020 01:41:29 +0200 Subject: [PATCH 34/37] Switch to literal mode with message when regexp is too big in char-fold search * lisp/char-fold.el (char-fold-to-regexp): Don't use regexp-quote when the length of regexp reaches 5000. (Bug#40216) * lisp/isearch.el (isearch-search): On big regexp in char-fold mode gracefully fall back to literal mode, try to search again and display momentary-message about switching to literal mode. (isearch--momentary-message): Add optional arg SECONDS. --- lisp/char-fold.el | 6 +----- lisp/isearch.el | 12 ++++++++---- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/lisp/char-fold.el b/lisp/char-fold.el index f8a303956e3..5a3c20c7832 100644 --- a/lisp/char-fold.el +++ b/lisp/char-fold.el @@ -370,11 +370,7 @@ from which to start." (setq i (1+ i))) (when (> spaces 0) (push (char-fold--make-space-string spaces) out)) - (let ((regexp (apply #'concat (nreverse out)))) - ;; Limited by `MAX_BUF_SIZE' in `regex-emacs.c'. - (if (> (length regexp) 5000) - (regexp-quote string) - regexp)))) + (apply #'concat (nreverse out)))) ;;; Commands provided for completeness. diff --git a/lisp/isearch.el b/lisp/isearch.el index ddf9190dc6d..7625ec12b58 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -2011,15 +2011,16 @@ Turning on character-folding turns off regexp mode.") (defvar isearch-message-properties minibuffer-prompt-properties "Text properties that are added to the isearch prompt.") -(defun isearch--momentary-message (string) - "Print STRING at the end of the isearch prompt for 1 second." +(defun isearch--momentary-message (string &optional seconds) + "Print STRING at the end of the isearch prompt for 1 second. +The optional argument SECONDS overrides the number of seconds." (let ((message-log-max nil)) (message "%s%s%s" (isearch-message-prefix nil isearch-nonincremental) isearch-message (apply #'propertize (format " [%s]" string) isearch-message-properties))) - (sit-for 1)) + (sit-for (or seconds 1))) (isearch-define-mode-toggle lax-whitespace " " nil "In ordinary search, toggles the value of the variable @@ -3443,7 +3444,10 @@ Optional third argument, if t, means if fail just return nil (no error). (string-match "\\`Regular expression too big" isearch-error)) (cond (isearch-regexp-function - (setq isearch-error "Too many words")) + (setq isearch-error nil) + (setq isearch-regexp-function nil) + (isearch-search-and-update) + (isearch--momentary-message "Too many words; switched to literal mode" 2)) ((and isearch-lax-whitespace search-whitespace-regexp) (setq isearch-error "Too many spaces for whitespace matching")))))) From 52fab66c277cd8d83fad0bd6bda8234e102bdc02 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Sun, 29 Mar 2020 02:08:05 +0200 Subject: [PATCH 35/37] * lisp/vc/vc-dir.el (vc-dir-root): New command (bug#12492, bug#34949). * lisp/vc/vc-hooks.el (vc-menu-map): Change menu command from 'vc-dir' to 'vc-dir-root'. --- etc/NEWS | 4 ++++ lisp/vc/vc-dir.el | 12 +++++++++++- lisp/vc/vc-hooks.el | 6 +++--- 3 files changed, 18 insertions(+), 4 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 870d39f7eef..4b477e5def6 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -111,6 +111,10 @@ details of marking the file at the end of the region. *** State changing VC operations are supported in 'dired-mode' on files (but still not on directories). +** Change Logs and VC + +*** New command 'vc-dir-root' uses the root directory without asking. + ** Gnus --- diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index 38b4937e854..b760e170676 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -1286,6 +1286,16 @@ state of item at point, if any." (setq model (vc-checkout-model vc-dir-backend only-files-list)))) (list vc-dir-backend files only-files-list state model))) +;;;###autoload +(defun vc-dir-root () + "Run `vc-dir' in the repository root directory without prompt. +If the default directory of the current buffer is +not under version control, prompt for a directory." + (interactive) + (let ((root-dir (vc-root-dir))) + (if root-dir (vc-dir root-dir) + (call-interactively 'vc-dir)))) + ;;;###autoload (defun vc-dir (dir &optional backend) "Show the VC status for \"interesting\" files in and below DIR. @@ -1309,7 +1319,7 @@ These are the commands available for use in the file status buffer: ;; When you hit C-x v d in a visited VC file, ;; the *vc-dir* buffer visits the directory under its truename; ;; therefore it makes sense to always do that. - ;; Otherwise if you do C-x v d -> C-x C-f -> C-c v d + ;; Otherwise if you do C-x v d -> C-x C-f -> C-x v d ;; you may get a new *vc-dir* buffer, different from the original (file-truename (read-directory-name "VC status for directory: " (vc-root-dir) nil t diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el index 345a28d3f1d..2ca9d3e620c 100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el @@ -972,9 +972,9 @@ In the latter case, VC mode is deactivated for this buffer." (bindings--define-key map [vc-ignore] '(menu-item "Ignore File..." vc-ignore :help "Ignore a file under current version control system")) - (bindings--define-key map [vc-dir] - '(menu-item "VC Dir" vc-dir - :help "Show the VC status of files in a directory")) + (bindings--define-key map [vc-dir-root] + '(menu-item "VC Dir" vc-dir-root + :help "Show the VC status of the repository")) map)) (defalias 'vc-menu-map vc-menu-map) From 96e53675eaee9f4fcfa966aab643b94608299118 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Sun, 29 Mar 2020 10:22:35 +0200 Subject: [PATCH 36/37] ; * doc/lispref/internals.texi (Module Misc): Fix version --- doc/lispref/internals.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/lispref/internals.texi b/doc/lispref/internals.texi index 0c24dac7775..d70c3543f2a 100644 --- a/doc/lispref/internals.texi +++ b/doc/lispref/internals.texi @@ -2024,7 +2024,7 @@ ways. @anchor{open_channel} @deftypefun int open_channel (emacs_env *@var{env}, emacs_value @var{pipe_process}) -This function, which is available since Emacs 27, opens a channel to +This function, which is available since Emacs 28, opens a channel to an existing pipe process. @var{pipe_process} must refer to an existing pipe process created by @code{make-pipe-process}. @ref{Pipe Processes}. If successful, the return value will be a new file From 76b3bd8cbb9a0a01941d9c1766c054960e4bfd97 Mon Sep 17 00:00:00 2001 From: Michael Albinus Date: Sun, 29 Mar 2020 12:24:04 +0200 Subject: [PATCH 37/37] Improve Tramp cache for asynchronous processes * lisp/net/tramp-adb.el (tramp-adb-handle-exec-path) (tramp-adb-get-device): * lisp/net/tramp-gvfs.el (tramp-gvfs-handler-askquestion): * lisp/net/tramp-sh.el (tramp-remote-selinux-p, tramp-remote-acl-p) (tramp-open-connection-setup-interactive-shell) (tramp-maybe-open-connection, tramp-get-remote-path) (tramp-get-inline-compress, tramp-get-inline-coding): * lisp/net/tramp-smb.el (tramp-smb-get-cifs-capabilities) (tramp-smb-get-stat-capability): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-remote-acl-p) (tramp-sudoedit-remote-selinux-p): Cache property in main process. * lisp/net/tramp-cache.el (tramp-cache-undefined): New defconst. (tramp-get-hash-table, tramp-connection-property-p): Use it. (tramp-set-connection-property, tramp-flush-connection-property) (tramp-flush-connection-properties): Add sanity checks. (tramp-get-file-property, tramp-set-file-property) (tramp-get-connection-property, tramp-set-connection-property) (tramp-dump-connection-properties): Adapt docstring. * lisp/net/tramp-cmds.el (tramp-cleanup-connection): Delete all processes. * lisp/net/tramp-gvfs.el (tramp-gvfs-unmount): Use `tramp-cleanup-connection'. * lisp/net/tramp-sh.el (tramp-sh-handle-vc-registered): Use `bound-and-true-p'. * lisp/net/tramp.el (tramp-get-process): New defun. --- lisp/net/tramp-adb.el | 8 +--- lisp/net/tramp-cache.el | 94 ++++++++++++++++++++++++-------------- lisp/net/tramp-cmds.el | 22 +++++---- lisp/net/tramp-gvfs.el | 6 +-- lisp/net/tramp-sh.el | 69 +++++++++++++++------------- lisp/net/tramp-smb.el | 5 +- lisp/net/tramp-sudoedit.el | 4 +- lisp/net/tramp.el | 12 ++++- 8 files changed, 130 insertions(+), 90 deletions(-) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 4512179eb14..aae25d1dbf3 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -1097,7 +1097,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Like `exec-path' for Tramp files." (append (with-parsed-tramp-file-name default-directory nil - (with-tramp-connection-property v "remote-path" + (with-tramp-connection-property (tramp-get-process v) "remote-path" (tramp-adb-send-command v "echo \\\"$PATH\\\"") (split-string (with-current-buffer (tramp-get-connection-buffer v) @@ -1112,11 +1112,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Return full host name from VEC to be used in shell execution. E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" a host name \"R38273882DE\" returns \"R38273882DE\"." - ;; Sometimes this is called before there is a connection process - ;; yet. In order to work with the connection cache, we flush all - ;; unwanted entries first. - (tramp-flush-connection-properties nil) - (with-tramp-connection-property (tramp-get-connection-process vec) "device" + (with-tramp-connection-property (tramp-get-process vec) "device" (let* ((host (tramp-file-name-host vec)) (port (tramp-file-name-port-or-default vec)) (devices (mapcar #'cadr (tramp-adb-parse-device-names nil)))) diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 91ed5465695..93eeb16f547 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -31,13 +31,13 @@ ;; a process, has a unique cache. We distinguish 4 kind of caches, ;; depending on the key: ;; -;; - localname is NIL. This are reusable properties. Examples: +;; - localname is nil. These are reusable properties. Examples: ;; "remote-shell" identifies the POSIX shell to be called on the ;; remote host, or "perl" is the command to be called on the remote ;; host when starting a Perl script. These properties are saved in ;; the file `tramp-persistency-file-name'. ;; -;; - localname is a string. This are temporary properties, which are +;; - localname is a string. These are temporary properties, which are ;; related to the file localname is referring to. Examples: ;; "file-exists-p" is t or nil, depending on the file existence, or ;; "file-attributes" caches the result of the function @@ -45,21 +45,32 @@ ;; expire after `remote-file-name-inhibit-cache' seconds if this ;; variable is set. ;; -;; - The key is a process. This are temporary properties related to +;; - The key is a process. These are temporary properties related to ;; an open connection. Examples: "scripts" keeps shell script ;; definitions already sent to the remote shell, "last-cmd-time" is ;; the time stamp a command has been sent to the remote process. ;; -;; - The key is nil. This are temporary properties related to the +;; - The key is nil. These are temporary properties related to the ;; local machine. Examples: "parse-passwd" and "parse-group" keep ;; the results of parsing "/etc/passwd" and "/etc/group", ;; "{uid,gid}-{integer,string}" are the local uid and gid, and ;; "locale" is the used shell locale. +;; +;; - The key is `tramp-cache-undefined'. All functions return the +;; expected values, but nothing is cached. ;; Some properties are handled special: ;; ;; - "process-name", "process-buffer" and "first-password-request" are -;; not saved in the file `tramp-persistency-file-name'. +;; not saved in the file `tramp-persistency-file-name', although +;; being connection properties related to a `tramp-file-name' +;; structure. +;; +;; - Reusable properties, which should not be saved, are kept in the +;; process key retrieved by `tramp-get-process' (the main connection +;; process). Other processes could reuse these properties, avoiding +;; recomputation when a new asynchronous process is created by +;; `make-process'. Examples are "remote-path" or "device" (tramp-adb.el). ;;; Code: @@ -96,25 +107,31 @@ details see the info pages." (defvar tramp-cache-data-changed nil "Whether persistent cache data have been changed.") +;;;###tramp-autoload +(defconst tramp-cache-undefined 'undef + "The symbol marking undefined hash keys and values.") + (defun tramp-get-hash-table (key) "Return the hash table for KEY. If it doesn't exist yet, it is created and initialized with -matching entries of `tramp-connection-properties'." - (or (gethash key tramp-cache-data) - (let ((hash - (puthash key (make-hash-table :test #'equal) tramp-cache-data))) - (when (tramp-file-name-p key) - (dolist (elt tramp-connection-properties) - (when (string-match-p - (or (nth 0 elt) "") - (tramp-make-tramp-file-name key 'noloc 'nohop)) - (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) - hash))) +matching entries of `tramp-connection-properties'. +If KEY is `tramp-cache-undefined', don't create anything, and return nil." + (unless (eq key tramp-cache-undefined) + (or (gethash key tramp-cache-data) + (let ((hash + (puthash key (make-hash-table :test #'equal) tramp-cache-data))) + (when (tramp-file-name-p key) + (dolist (elt tramp-connection-properties) + (when (string-match-p + (or (nth 0 elt) "") + (tramp-make-tramp-file-name key 'noloc 'nohop)) + (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) + hash)))) ;;;###tramp-autoload (defun tramp-get-file-property (key file property default) "Get the PROPERTY of FILE from the cache context of KEY. -Returns DEFAULT if not set." +Return DEFAULT if not set." ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq file (tramp-compat-file-name-unquote file) key (copy-tramp-file-name key)) @@ -152,7 +169,7 @@ Returns DEFAULT if not set." ;;;###tramp-autoload (defun tramp-set-file-property (key file property value) "Set the PROPERTY of FILE to VALUE, in the cache context of KEY. -Returns VALUE." +Return VALUE." ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq file (tramp-compat-file-name-unquote file) key (copy-tramp-file-name key)) @@ -283,8 +300,9 @@ This is suppressed for temporary buffers." "Get the named PROPERTY for the connection. KEY identifies the connection, it is either a process or a `tramp-file-name' structure. A special case is nil, which is -used to cache connection properties of the local machine. If the -value is not set for the connection, returns DEFAULT." +used to cache connection properties of the local machine. +If KEY is `tramp-cache-undefined', or if the value is not set for +the connection, return DEFAULT." ;; Unify key by removing localname and hop from `tramp-file-name' ;; structure. Work with a copy in order to avoid side effects. (when (tramp-file-name-p key) @@ -308,19 +326,22 @@ value is not set for the connection, returns DEFAULT." "Set the named PROPERTY of a connection to VALUE. KEY identifies the connection, it is either a process or a `tramp-file-name' structure. A special case is nil, which is -used to cache connection properties of the local machine. -PROPERTY is set persistent when KEY is a `tramp-file-name' structure." +used to cache connection properties of the local machine. If KEY +is `tramp-cache-undefined', nothing is set. +PROPERTY is set persistent when KEY is a `tramp-file-name' structure. +Return VALUE." ;; Unify key by removing localname and hop from `tramp-file-name' ;; structure. Work with a copy in order to avoid side effects. (when (tramp-file-name-p key) (setq key (copy-tramp-file-name key)) (setf (tramp-file-name-localname key) nil (tramp-file-name-hop key) nil)) - (let ((hash (tramp-get-hash-table key))) - (puthash property value hash) - (setq tramp-cache-data-changed t) - (tramp-message key 7 "%s %s" property value) - value)) + (when-let ((hash (tramp-get-hash-table key))) + (puthash property value hash)) + (setq tramp-cache-data-changed + (or tramp-cache-data-changed (tramp-tramp-file-p key))) + (tramp-message key 7 "%s %s" property value) + value) ;;;###tramp-autoload (defun tramp-connection-property-p (key property) @@ -328,7 +349,8 @@ PROPERTY is set persistent when KEY is a `tramp-file-name' structure." KEY identifies the connection, it is either a process or a `tramp-file-name' structure. A special case is nil, which is used to cache connection properties of the local machine." - (not (eq (tramp-get-connection-property key property 'undef) 'undef))) + (not (eq (tramp-get-connection-property key property tramp-cache-undefined) + tramp-cache-undefined))) ;;;###tramp-autoload (defun tramp-flush-connection-property (key property) @@ -343,8 +365,10 @@ PROPERTY is set persistent when KEY is a `tramp-file-name' structure." (setq key (copy-tramp-file-name key)) (setf (tramp-file-name-localname key) nil (tramp-file-name-hop key) nil)) - (remhash property (tramp-get-hash-table key)) - (setq tramp-cache-data-changed t) + (when-let ((hash (tramp-get-hash-table key))) + (remhash property hash)) + (setq tramp-cache-data-changed + (or tramp-cache-data-changed (tramp-tramp-file-p key))) (tramp-message key 7 "%s" property)) ;;;###tramp-autoload @@ -361,9 +385,10 @@ used to cache connection properties of the local machine." (tramp-file-name-hop key) nil)) (tramp-message key 7 "%s %s" key - (let ((hash (gethash key tramp-cache-data))) - (when (hash-table-p hash) (hash-table-keys hash)))) - (setq tramp-cache-data-changed t) + (when-let ((hash (gethash key tramp-cache-data))) + (hash-table-keys hash))) + (setq tramp-cache-data-changed + (or tramp-cache-data-changed (tramp-tramp-file-p key))) (remhash key tramp-cache-data)) ;;;###tramp-autoload @@ -414,7 +439,8 @@ used to cache connection properties of the local machine." (hash-table-keys tramp-cache-data))))) (defun tramp-dump-connection-properties () - "Write persistent connection properties into file `tramp-persistency-file-name'." + "Write persistent connection properties into file \ +`tramp-persistency-file-name'." ;; We shouldn't fail, otherwise Emacs might not be able to be closed. (ignore-errors (when (and (hash-table-p tramp-cache-data) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index b4dca2321c1..7d353e262af 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -107,21 +107,19 @@ When called interactively, a Tramp connection has to be selected." ;; suppressed. (setq tramp-current-connection nil) - ;; Flush file cache. - (tramp-flush-directory-properties vec "") - - ;; Flush connection cache. - (when (processp (tramp-get-connection-process vec)) - (tramp-flush-connection-properties (tramp-get-connection-process vec)) - (delete-process (tramp-get-connection-process vec))) - (tramp-flush-connection-properties vec) - ;; Cancel timer. (dolist (timer timer-list) (when (and (eq (timer--function timer) 'tramp-timeout-session) (tramp-file-name-equal-p vec (car (timer--args timer)))) (cancel-timer timer))) + ;; Delete processes. + (dolist (key (hash-table-keys tramp-cache-data)) + (when (and (processp key) + (tramp-file-name-equal-p (process-get key 'vector) vec)) + (tramp-flush-connection-properties key) + (delete-process key))) + ;; Remove buffers. (dolist (buf (list (get-buffer (tramp-buffer-name vec)) @@ -130,6 +128,12 @@ When called interactively, a Tramp connection has to be selected." (tramp-get-connection-property vec "process-buffer" nil))) (when (bufferp buf) (kill-buffer buf))) + ;; Flush file cache. + (tramp-flush-directory-properties vec "") + + ;; Flush connection cache. + (tramp-flush-connection-properties vec) + ;; The end. (run-hook-with-args 'tramp-cleanup-connection-hook vec))) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 85f28076168..526c564ee33 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -1731,8 +1731,7 @@ a downcased host name only." (list t ;; handled. nil ;; no abort of D-Bus. - (with-tramp-connection-property - (tramp-get-connection-process v) message + (with-tramp-connection-property (tramp-get-process v) message ;; In theory, there can be several choices. ;; Until now, there is only the question whether ;; to accept an unknown host signature or certificate. @@ -1946,8 +1945,7 @@ a downcased host name only." (tramp-gvfs-url-file-name (tramp-make-tramp-file-name vec)))) (while (tramp-gvfs-connection-mounted-p vec) (read-event nil nil 0.1)) - (tramp-flush-connection-properties vec) - (tramp-flush-connection-properties (tramp-get-connection-process vec))) + (tramp-cleanup-connection vec 'keep-debug 'keep-password)) (defun tramp-gvfs-mount-spec-entry (key value) "Construct a mount-spec entry to be used in a mount_spec. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 06dca312275..c770e3ce400 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1539,7 +1539,7 @@ of." (defun tramp-remote-selinux-p (vec) "Check, whether SELINUX is enabled on the remote host." - (with-tramp-connection-property (tramp-get-connection-process vec) "selinux-p" + (with-tramp-connection-property (tramp-get-process vec) "selinux-p" (tramp-send-command-and-check vec "selinuxenabled"))) (defun tramp-sh-handle-file-selinux-context (filename) @@ -1588,7 +1588,7 @@ of." (defun tramp-remote-acl-p (vec) "Check, whether ACL is enabled on the remote host." - (with-tramp-connection-property (tramp-get-connection-process vec) "acl-p" + (with-tramp-connection-property (tramp-get-process vec) "acl-p" (tramp-send-command-and-check vec "getfacl /"))) (defun tramp-sh-handle-file-acl (filename) @@ -3580,23 +3580,29 @@ STDERR can also be a file name." remote-file-name-inhibit-cache process-file-side-effects) ;; Reduce `vc-handled-backends' in order to minimize ;; process calls. - (when (and (memq 'Bzr vc-handled-backends) - (boundp 'vc-bzr-program) - (not (with-tramp-connection-property v vc-bzr-program - (tramp-find-executable - v vc-bzr-program (tramp-get-remote-path v))))) + (when (and + (memq 'Bzr vc-handled-backends) + (not (and + (bound-and-true-p vc-bzr-program) + (with-tramp-connection-property v vc-bzr-program + (tramp-find-executable + v vc-bzr-program (tramp-get-remote-path v)))))) (setq vc-handled-backends (remq 'Bzr vc-handled-backends))) - (when (and (memq 'Git vc-handled-backends) - (boundp 'vc-git-program) - (not (with-tramp-connection-property v vc-git-program - (tramp-find-executable - v vc-git-program (tramp-get-remote-path v))))) + (when (and + (memq 'Git vc-handled-backends) + (not (and + (bound-and-true-p vc-git-program) + (with-tramp-connection-property v vc-git-program + (tramp-find-executable + v vc-git-program (tramp-get-remote-path v)))))) (setq vc-handled-backends (remq 'Git vc-handled-backends))) - (when (and (memq 'Hg vc-handled-backends) - (boundp 'vc-hg-program) - (not (with-tramp-connection-property v vc-hg-program - (tramp-find-executable - v vc-hg-program (tramp-get-remote-path v))))) + (when (and + (memq 'Hg vc-handled-backends) + (not (and + (bound-and-true-p vc-hg-program) + (with-tramp-connection-property v vc-hg-program + (tramp-find-executable + v vc-hg-program (tramp-get-remote-path v)))))) (setq vc-handled-backends (remq 'Hg vc-handled-backends))) ;; Run. (tramp-with-demoted-errors @@ -4290,11 +4296,15 @@ process to set up. VEC specifies the connection." ;; connection properties. We start again with ;; `tramp-maybe-open-connection', it will be caught there. (tramp-message vec 5 "Checking system information") - (let ((old-uname (tramp-get-connection-property vec "uname" nil)) - (uname - (tramp-set-connection-property - vec "uname" - (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\"")))) + (let* ((old-uname (tramp-get-connection-property vec "uname" nil)) + (uname + ;; If we are in `make-process', we don't need to recompute. + (if (and old-uname + (tramp-get-connection-property vec "process-name" nil)) + old-uname + (tramp-set-connection-property + vec "uname" + (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\""))))) (when (and (stringp old-uname) (not (string-equal old-uname uname))) (tramp-message vec 3 @@ -5053,7 +5063,7 @@ connection if a previous connection has died for some reason." ;; we cannot use `tramp-get-connection-process'. (tmpfile (with-tramp-connection-property - (get-process (tramp-buffer-name vec)) "temp-file" + (tramp-get-process vec) "temp-file" (make-temp-name (expand-file-name tramp-temp-name-prefix @@ -5426,7 +5436,7 @@ Nonexistent directories are removed from spec." ;; cache the result for the session only. Otherwise, the ;; result is cached persistently. (if (memq 'tramp-own-remote-path tramp-remote-path) - (tramp-get-connection-process vec) + (tramp-get-process vec) vec) "remote-path" (let* ((remote-path (copy-tree tramp-remote-path)) @@ -5945,10 +5955,9 @@ the length of the file to be compressed. If no corresponding command is found, nil is returned." (when (and (integerp tramp-inline-compress-start-size) (> size tramp-inline-compress-start-size)) - (with-tramp-connection-property (tramp-get-connection-process vec) prop + (with-tramp-connection-property (tramp-get-process vec) prop (tramp-find-inline-compress vec) - (tramp-get-connection-property - (tramp-get-connection-process vec) prop nil)))) + (tramp-get-connection-property (tramp-get-process vec) prop nil)))) (defun tramp-get-inline-coding (vec prop size) "Return the coding command related to PROP. @@ -5966,11 +5975,9 @@ function cell is returned to be applied on a buffer." ;; no inline coding is found. (ignore-errors (let ((coding - (with-tramp-connection-property - (tramp-get-connection-process vec) prop + (with-tramp-connection-property (tramp-get-process vec) prop (tramp-find-inline-encoding vec) - (tramp-get-connection-property - (tramp-get-connection-process vec) prop nil))) + (tramp-get-connection-property (tramp-get-process vec) prop nil))) (prop1 (if (string-match-p "encoding" prop) "inline-compress" "inline-decompress")) compress) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 100ddfaa681..d361db483a1 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -1845,7 +1845,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." (if (and (process-live-p (tramp-get-connection-process vec)) (tramp-get-connection-property vec "posix" t)) (with-tramp-connection-property - (tramp-get-connection-process vec) "cifs-capabilities" + (tramp-get-process vec) "cifs-capabilities" (save-match-data (when (tramp-smb-send-command vec "posix") (with-current-buffer (tramp-get-connection-buffer vec) @@ -1862,8 +1862,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." ;; When we are not logged in yet, we return nil. (if (and (tramp-smb-get-share vec) (process-live-p (tramp-get-connection-process vec))) - (with-tramp-connection-property - (tramp-get-connection-process vec) "stat-capability" + (with-tramp-connection-property (tramp-get-process vec) "stat-capability" (tramp-smb-send-command vec "stat \"/\"")))) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index b6861ba7882..68e68a242c9 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -373,7 +373,7 @@ the result will be a local, non-Tramp, file name." (defun tramp-sudoedit-remote-acl-p (vec) "Check, whether ACL is enabled on the remote host." - (with-tramp-connection-property (tramp-get-connection-process vec) "acl-p" + (with-tramp-connection-property (tramp-get-process vec) "acl-p" (zerop (tramp-call-process vec "getfacl" nil nil nil "/")))) (defun tramp-sudoedit-handle-file-acl (filename) @@ -478,7 +478,7 @@ the result will be a local, non-Tramp, file name." (defun tramp-sudoedit-remote-selinux-p (vec) "Check, whether SELINUX is enabled on the remote host." - (with-tramp-connection-property (tramp-get-connection-process vec) "selinux-p" + (with-tramp-connection-property (tramp-get-process vec) "selinux-p" (zerop (tramp-call-process vec "selinuxenabled")))) (defun tramp-sudoedit-handle-file-selinux-context (filename) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 3ce2225cb84..e30f27fd338 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -37,7 +37,7 @@ ;; For more detailed instructions, please see the info file. ;; ;; Notes: -;; ----- +;; ------ ;; ;; Also see the todo list at the bottom of this file. ;; @@ -46,6 +46,7 @@ ;; ;; There's a mailing list for this, as well. Its name is: ;; tramp-devel@gnu.org + ;; You can use the Web to subscribe, under the following URL: ;; https://lists.gnu.org/mailman/listinfo/tramp-devel ;; @@ -1631,6 +1632,15 @@ from the default one." (or (tramp-get-connection-property vec "process-name" nil) (tramp-buffer-name vec))) +(defun tramp-get-process (vec-or-proc) + "Get the default connection process to be used for VEC-OR-PROC. +Return `tramp-cache-undefined' in case it doesn't exist." + (or (and (tramp-file-name-p vec-or-proc) + (get-buffer-process (tramp-buffer-name vec-or-proc))) + (and (processp vec-or-proc) + (tramp-get-process (process-get vec-or-proc 'vector))) + tramp-cache-undefined)) + (defun tramp-get-connection-process (vec) "Get the connection process to be used for VEC. In case a second asynchronous communication has been started, it is different