commit dd162a3f2264940e3e329d0bfb195f56d00ed08f (HEAD, refs/remotes/origin/master) Author: Glenn Morris Date: Sun Sep 1 14:35:31 2019 -0700 * admin/admin.el (set-version): Check for empty NEWS sections. diff --git a/admin/admin.el b/admin/admin.el index d3a477fde8..5968e32b05 100644 --- a/admin/admin.el +++ b/admin/admin.el @@ -147,6 +147,10 @@ Root must be the root of an Emacs source tree." (unless (> (length newversion) 2) ; pretest or release candidate? (with-temp-buffer (insert-file-contents newsfile) + (when (re-search-forward "^\\* [^\n]*\n+ " nil t) + (display-warning 'admin + "NEWS file contains empty sections - remove them?")) + (goto-char (point-min)) (if (re-search-forward "^\\(\\+\\+\\+ *\\|--- *\\)$" nil t) (display-warning 'admin "NEWS file still contains temporary markup. commit ba12c5467dadd228a00bcf972fd8415c26f4a4bd Author: Paul Eggert Date: Sun Sep 1 09:56:40 2019 -0700 Fix load-theme bug with user-emacs-directory * lisp/custom.el (custom-theme-directory): Delay initialization, since the value depends on user-emacs-directory (Bug#37256). diff --git a/lisp/custom.el b/lisp/custom.el index 9bd9712b65..2e42ea73c1 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -1137,6 +1137,7 @@ Every theme X has a property `provide-theme' whose value is \"X-theme\". The command `customize-create-theme' writes theme files into this directory. By default, Emacs searches for custom themes in this directory first---see `custom-theme-load-path'." + :initialize #'custom-initialize-delay :type 'string :group 'customize :version "22.1") commit a7d47e64aaf438feaa8cbe4d40acb7bae0eab059 Author: Glenn Morris Date: Sun Sep 1 06:26:47 2019 -0700 ; Auto-commit of loaddefs files. diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index e925adbb11..7bac452a5c 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -57,58 +57,6 @@ should return a grid vector array that is the new solution. (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "5x5" '("5x5-"))) -;;;*** - -;;;### (autoloads nil "ada-mode" "progmodes/ada-mode.el" (0 0 0 0)) -;;; Generated autoloads from progmodes/ada-mode.el -(push (purecopy '(ada-mode 4 0)) package--builtin-versions) - -(autoload 'ada-add-extensions "ada-mode" "\ -Define SPEC and BODY as being valid extensions for Ada files. -Going from body to spec with `ff-find-other-file' used these -extensions. -SPEC and BODY are two regular expressions that must match against -the file name. - -\(fn SPEC BODY)" nil nil) - -(autoload 'ada-mode "ada-mode" "\ -Ada mode is the major mode for editing Ada code. - -\(fn)" t nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ada-mode" '("ada-"))) - -;;;*** - -;;;### (autoloads nil "ada-prj" "progmodes/ada-prj.el" (0 0 0 0)) -;;; Generated autoloads from progmodes/ada-prj.el - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ada-prj" '("ada-"))) - -;;;*** - -;;;### (autoloads nil "ada-stmt" "progmodes/ada-stmt.el" (0 0 0 0)) -;;; Generated autoloads from progmodes/ada-stmt.el - -(autoload 'ada-header "ada-stmt" "\ -Insert a descriptive header at the top of the file." t nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ada-stmt" '("ada-"))) - -;;;*** - -;;;### (autoloads nil "ada-xref" "progmodes/ada-xref.el" (0 0 0 0)) -;;; Generated autoloads from progmodes/ada-xref.el - -(autoload 'ada-find-file "ada-xref" "\ -Open FILENAME, from anywhere in the source path. -Completion is available. - -\(fn FILENAME)" t nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ada-xref" '("ada-"))) - ;;;*** ;;;### (autoloads nil "add-log" "vc/add-log.el" (0 0 0 0)) @@ -1273,7 +1221,7 @@ Entering array mode calls the function `array-mode-hook'. \(fn)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "array" '("array-" "current-line" "limit-index" "move-to-column-untabify" "untabify-backward" "xor"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "array" '("array-" "current-line" "limit-index" "move-to-column-untabify" "untabify-backward"))) ;;;*** @@ -2490,7 +2438,9 @@ If the value is not a function it should be a list of pairs \(REGEXP . FUNCTION). In this case the function called will be the one associated with the first REGEXP which matches the current URL. The function is passed the URL and any other args of `browse-url'. The last -regexp should probably be \".\" to specify a default browser.") +regexp should probably be \".\" to specify a default browser. + +Also see `browse-url-secondary-browser-function'.") (custom-autoload 'browse-url-browser-function "browse-url" t) @@ -3026,8 +2976,15 @@ it won't work in an interactive Emacs." nil nil) Run `byte-compile-file' on the files remaining on the command line. Use this from the command line, with `-batch'; it won't work in an interactive Emacs. -Each file is processed even if an error occurred previously. + +Each file is processed even if an error occurred previously. If +a file name denotes a directory, all Emacs Lisp source files in +that directory (that have previously been compiled) will be +recompiled if newer than the compiled files. In this case, +NOFORCE is ignored. + For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\". + If NOFORCE is non-nil, don't recompile a file that seems to be already up-to-date. @@ -4761,13 +4718,6 @@ and runs the normal hook `command-history-hook'." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "chistory" '("command-history-" "default-command-history-filter" "list-command-history-"))) -;;;*** - -;;;### (autoloads nil "cl" "emacs-lisp/cl.el" (0 0 0 0)) -;;; Generated autoloads from emacs-lisp/cl.el - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl" '("cl-" "define-" "defsetf" "flet" "labels" "lexical-let"))) - ;;;*** ;;;### (autoloads "actual autoloads are elsewhere" "cl-extra" "emacs-lisp/cl-extra.el" @@ -5250,9 +5200,8 @@ Otherwise, it saves all modified buffers without asking.") (defvar compilation-search-path '(nil) "\ List of directories to search for source files named in error messages. -Elements should be directory names, not file names of -directories. The value nil as an element means the error -message buffer `default-directory'.") +Elements should be directory names, not file names of directories. +The value nil as an element means to try the default directory.") (custom-autoload 'compilation-search-path "compile" t) @@ -5385,7 +5334,7 @@ This is the value of `next-error-function' in Compilation buffers. \(fn N &optional RESET)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "compile" '("compil" "define-compilation-mode" "kill-compilation" "recompile"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "compile" '("compil" "define-compilation-mode" "kill-compilation" "overlay-arrow-overlay" "recompile"))) ;;;*** @@ -8112,14 +8061,17 @@ For example, you could write Make a global mode GLOBAL-MODE corresponding to buffer-local minor MODE. TURN-ON is a function that will be called with no args in every buffer and that should try to turn MODE on if applicable for that buffer. -KEYS is a list of CL-style keyword arguments. As the minor mode - defined by this function is always global, any :global keyword is - ignored. Other keywords have the same meaning as in `define-minor-mode', - which see. In particular, :group specifies the custom group. - The most useful keywords are those that are passed on to the - `defcustom'. It normally makes no sense to pass the :lighter - or :keymap keywords to `define-globalized-minor-mode', since these - are usually passed to the buffer-local version of the minor mode. +Each of KEY VALUE is a pair of CL-style keyword arguments. As + the minor mode defined by this function is always global, any + :global keyword is ignored. Other keywords have the same + meaning as in `define-minor-mode', which see. In particular, + :group specifies the custom group. The most useful keywords + are those that are passed on to the `defcustom'. It normally + makes no sense to pass the :lighter or :keymap keywords to + `define-globalized-minor-mode', since these are usually passed + to the buffer-local version of the minor mode. +BODY contains code to execute each time the mode is enabled or disabled. + It is executed after toggling the mode, and before running GLOBAL-MODE-hook. If MODE's set-up depends on the major mode in effect when it was enabled, then disabling and reenabling MODE should make MODE work @@ -8131,7 +8083,7 @@ When a major mode is initialized, MODE is actually turned on just after running the major mode's hook. However, MODE is not turned on if the hook has explicitly disabled it. -\(fn GLOBAL-MODE MODE TURN-ON &rest KEYS)" nil t) +\(fn GLOBAL-MODE MODE TURN-ON [KEY VALUE]... BODY...)" nil t) (function-put 'define-globalized-minor-mode 'doc-string-elt '2) @@ -8207,6 +8159,17 @@ pairs: if the expression evaluates to a non-nil value. `:enable' is an alias for `:active'. + :label FORM + FORM is an expression that is dynamically evaluated and whose + value serves as the menu's label (the default is the first + element of MENU). + + :help HELP + HELP is a string, the help to display for the menu. + In a GUI this is a \"tooltip\" on the menu button. (Though + in Lucid :help is not shown for the top-level menu bar, only + for sub-menus.) + The rest of the elements in MENU are menu items. A menu item can be a vector of three elements: @@ -12855,7 +12818,11 @@ to get the effect of a C-q. \(fn &optional BUFFER)" nil nil) (autoload 'fill-flowed "flow-fill" "\ +Apply RFC2646 decoding to BUFFER. +If BUFFER is nil, default to the current buffer. +If DELETE-SPACE, delete RFC2646 spaces padding at the end of +lines. \(fn &optional BUFFER DELETE-SPACE)" nil nil) @@ -14762,24 +14729,6 @@ Add the window configuration CONF to `gnus-buffer-configuration'. ;;;### (autoloads nil "gnutls" "net/gnutls.el" (0 0 0 0)) ;;; Generated autoloads from net/gnutls.el -(defvar gnutls-min-prime-bits 256 "\ -Minimum number of prime bits accepted by GnuTLS for key exchange. -During a Diffie-Hellman handshake, if the server sends a prime -number with fewer than this number of bits, the handshake is -rejected. (The smaller the prime number, the less secure the -key exchange is against man-in-the-middle attacks.) - -A value of nil says to use the default GnuTLS value. - -The default value of this variable is such that virtually any -connection can be established, whether this connection can be -considered cryptographically \"safe\" or not. However, Emacs -network security is handled at a higher level via -`open-network-stream' and the Network Security Manager. See Info -node `(emacs) Network Security'.") - -(custom-autoload 'gnutls-min-prime-bits "gnutls" t) - (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnutls" '("gnutls-" "open-gnutls-stream"))) ;;;*** @@ -14863,11 +14812,11 @@ if ARG is `toggle'; disable the mode otherwise. (autoload 'gravatar-retrieve "gravatar" "\ Asynchronously retrieve a gravatar for MAIL-ADDRESS. -When finished, call CB as (apply CB GRAVATAR CBARGS), +When finished, call CALLBACK as (apply CALLBACK GRAVATAR CBARGS), where GRAVATAR is either an image descriptor, or the symbol `error' if the retrieval failed. -\(fn MAIL-ADDRESS CB &optional CBARGS)" nil nil) +\(fn MAIL-ADDRESS CALLBACK &optional CBARGS)" nil nil) (autoload 'gravatar-retrieve-synchronously "gravatar" "\ Synchronously retrieve a gravatar for MAIL-ADDRESS. @@ -15107,9 +15056,15 @@ and source-file directory for your debugger. \(fn COMMAND-LINE)" t nil) (autoload 'pdb "gud" "\ -Run pdb on program FILE in buffer `*gud-FILE*'. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger. +Run COMMAND-LINE in the `*gud-FILE*' buffer. + +COMMAND-LINE should include the pdb executable +name (`gud-pdb-command-name') and the file to be debugged. + +If called interactively, the command line will be prompted for. + +The directory containing this file becomes the initial working +directory and source-file directory for your debugger. \(fn COMMAND-LINE)" t nil) @@ -17117,7 +17072,8 @@ RET Select the file at the front of the list of matches. \\[ido-toggle-case] Toggle case-sensitive searching of file names. \\[ido-toggle-literal] Toggle literal reading of this file. \\[ido-completion-help] Show list of matching files in separate window. -\\[ido-toggle-ignore] Toggle ignoring files listed in `ido-ignore-files'." t nil) +\\[ido-toggle-ignore] Toggle ignoring files listed in `ido-ignore-files'. +\\[ido-reread-directory] Reread the current directory." t nil) (autoload 'ido-find-file-other-window "ido" "\ Switch to another file and show it in another window. @@ -17965,7 +17921,7 @@ Display the \"Reporting Bugs\" section of the Emacs manual in Info mode." t nil) (autoload 'info-standalone "info" "\ Run Emacs as a standalone Info reader. Usage: emacs -f info-standalone [filename] -In standalone mode, \\\\[Info-exit] exits Emacs itself." nil nil) +In standalone mode, \\\\[quit-window] exits Emacs itself." nil nil) (autoload 'Info-on-current-buffer "info" "\ Use Info mode to browse the current Info buffer. @@ -18007,7 +17963,7 @@ one topic and contains references to other nodes which discuss related topics. Info has commands to follow the references and show you other nodes. \\\\[Info-help] Invoke the Info tutorial. -\\[Info-exit] Quit Info: reselect previously selected buffer. +\\[quit-window] Quit Info: reselect previously selected buffer. Selecting other nodes: \\[Info-mouse-follow-nearest-node] @@ -20528,10 +20484,9 @@ OTHER-HEADERS is an alist specifying additional header fields. Elements look like (HEADER . VALUE) where both HEADER and VALUE are strings. -CONTINUE, SWITCH-FUNCTION, YANK-ACTION, SEND-ACTIONS, and -RETURN-ACTION and any additional arguments are IGNORED. +Any additional arguments are IGNORED. -\(fn &optional TO SUBJECT OTHER-HEADERS CONTINUE SWITCH-FUNCTION YANK-ACTION SEND-ACTIONS RETURN-ACTION &rest IGNORED)" nil nil) +\(fn &optional TO SUBJECT OTHER-HEADERS &rest IGNORED)" nil nil) (autoload 'mh-send-letter "mh-comp" "\ Save draft and send message. @@ -21787,8 +21742,38 @@ Interactively, prompt for NAME-SERVER if invoked with prefix argument. This command uses `nslookup-program' for looking up the DNS information. +See also: `nslookup-host-ipv4', `nslookup-host-ipv6' for +non-interactive versions of this function more suitable for use +in Lisp code. + \(fn HOST &optional NAME-SERVER)" t nil) +(autoload 'nslookup-host-ipv4 "net-utils" "\ +Return the IPv4 address for HOST (name or IP address). +Optional argument NAME-SERVER says which server to use for DNS +resolution. + +If FORMAT is `string', returns the IP address as a +string (default). If FORMAT is `vector', returns a 4-integer +vector of octets. + +This command uses `nslookup-program' to look up DNS records. + +\(fn HOST &optional NAME-SERVER FORMAT)" nil nil) + +(autoload 'nslookup-host-ipv6 "net-utils" "\ +Return the IPv6 address for HOST (name or IP address). +Optional argument NAME-SERVER says which server to use for DNS +resolution. + +If FORMAT is `string', returns the IP address as a +string (default). If FORMAT is `vector', returns a 8-integer +vector of hextets. + +This command uses `nslookup-program' to look up DNS records. + +\(fn HOST &optional NAME-SERVER FORMAT)" nil nil) + (autoload 'nslookup "net-utils" "\ Run `nslookup-program'." t nil) @@ -21845,7 +21830,7 @@ Open a network connection to HOST on PORT. \(fn HOST PORT)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "net-utils" '("arp-program" "dig-program" "dns-lookup-program" "finger-X.500-host-regexps" "ftp-" "ifconfig-program" "ipconfig" "iwconfig-program" "net" "nslookup-" "ping-program" "route-program" "run-network-program" "smbclient" "traceroute-program" "whois-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "net-utils" '("arp-program" "dig-program" "dns-lookup-program" "finger-X.500-host-regexps" "ftp-" "ifconfig-program" "iwconfig-program" "net" "nslookup-" "ping-program" "route-program" "run-network-program" "smbclient" "traceroute-program" "whois-"))) ;;;*** @@ -24268,7 +24253,7 @@ matching parenthesis is highlighted in `show-paren-style' after (put 'parse-time-rules 'risky-local-variable t) (autoload 'parse-time-string "parse-time" "\ -Parse the time-string STRING into (SEC MIN HOUR DAY MON YEAR DOW DST TZ). +Parse the time in STRING into (SEC MIN HOUR DAY MON YEAR DOW DST TZ). STRING should be something resembling an RFC 822 (or later) date-time, e.g., \"Fri, 25 Mar 2016 16:24:56 +0100\", but this function is somewhat liberal in what format it accepts, and will attempt to @@ -33258,7 +33243,7 @@ If DATE lacks timezone information, GMT is assumed. (defalias 'time-to-seconds 'float-time) -(defalias 'seconds-to-time 'encode-time) +(defalias 'seconds-to-time 'time-convert) (autoload 'days-to-time "time-date" "\ Convert DAYS into a time value. @@ -36411,7 +36396,7 @@ Usage: Emacs with VHDL Mode (i.e. load a VHDL file or use \"emacs -l vhdl-mode\") in a directory with an existing project setup file, it is automatically loaded and its project activated if option - `vhdl-project-auto-load' is non-nil. Names/paths of the project setup + `vhdl-project-autoload' is non-nil. Names/paths of the project setup files can be specified in option `vhdl-project-file-name'. Multiple project setups can be automatically loaded from global directories. This is an alternative to specifying project setups with option commit 4051fa3ba9b4527b57b4cd114ddaaf72a3b23528 Author: Mattias Engdegård Date: Sun Sep 1 14:26:18 2019 +0200 Clarify what counts as whitespace in `string-blank-p' * lisp/emacs-lisp/subr-x.el (string-blank-p): Expand doc string. diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index f76409c4de..bb2bf3dd5f 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -236,7 +236,9 @@ TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"." (string-trim-left (string-trim-right string trim-right) trim-left)) (defsubst string-blank-p (string) - "Check whether STRING is either empty or only whitespace." + "Check whether STRING is either empty or only whitespace. +The following characters count as whitespace here: space, tab, newline and +carriage return." (string-match-p "\\`[ \t\n\r]*\\'" string)) (defsubst string-remove-prefix (prefix string) commit e8c46c2b6f76cc055366041b6112d61dd5f2dcf4 Author: Thomas Fitzsimmons Date: Sat Aug 31 10:48:59 2019 -0400 package.el: Allow Package-Requires to span multiple lines (Bug#36301) * lisp/emacs-lisp/package.el (lm-header-multiline): Declare function. (package-buffer-info): Parse Package-Requires with lm-header-multiline instead of lm-header. (Bug#36301) Co-authored-by: Noam Postavsky diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index cd127e1a8e..ef0c5171de 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1028,6 +1028,7 @@ is wrapped around any parts requiring it." deps)))) (declare-function lm-header "lisp-mnt" (header)) +(declare-function lm-header-multiline "lisp-mnt" (header)) (declare-function lm-homepage "lisp-mnt" (&optional file)) (declare-function lm-keywords-list "lisp-mnt" (&optional file)) (declare-function lm-maintainer "lisp-mnt" (&optional file)) @@ -1054,8 +1055,7 @@ boundaries." (narrow-to-region start (point)) (require 'lisp-mnt) ;; Use some headers we've invented to drive the process. - (let* ((requires-str (lm-header "package-requires")) - ;; Prefer Package-Version; if defined, the package author + (let* (;; Prefer Package-Version; if defined, the package author ;; probably wants us to use it. Otherwise try Version. (pkg-version (or (package-strip-rcs-id (lm-header "package-version")) @@ -1067,9 +1067,9 @@ boundaries." "Package lacks a \"Version\" or \"Package-Version\" header")) (package-desc-from-define file-name pkg-version desc - (if requires-str - (package--prepare-dependencies - (package-read-from-string requires-str))) + (and-let* ((require-lines (lm-header-multiline "package-requires"))) + (package--prepare-dependencies + (package-read-from-string (mapconcat #'identity require-lines " ")))) :kind 'single :url homepage :keywords keywords commit fd8346600c3872fa1dfdd1ce6522799ba40d0dc0 Author: Paul Eggert Date: Sat Aug 31 18:17:20 2019 -0700 Make user-emacs-directory a variable This is in response to Eli’s review here: https://lists.gnu.org/r/emacs-devel/2019-07/msg00712.html * lisp/subr.el (user-emacs-directory): defvar, not defconst diff --git a/lisp/subr.el b/lisp/subr.el index cf6fb108e9..0d7bffb35f 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -2937,7 +2937,7 @@ When the hook runs, the temporary buffer is current. This hook is normally set up with a function to put the buffer in Help mode.") -(defconst user-emacs-directory +(defvar user-emacs-directory ;; The value does not matter since Emacs sets this at startup. nil "Directory beneath which additional per-user Emacs-specific files are placed. commit 72ab46fefcc8fa2b20204eaa79e1d750e56d8ccf Author: Paul Eggert Date: Sat Aug 31 18:16:17 2019 -0700 Improve documentation for recent XDG-related changes Adjust documentation in the light of Eli’s review here: https://lists.gnu.org/r/emacs-devel/2019-07/msg00712.html * doc/emacs/custom.texi (Init File, Find Init): * doc/lispref/files.texi (Standard File Names): * doc/lispref/os.texi (Init File): diff --git a/doc/emacs/custom.texi b/doc/emacs/custom.texi index d3d7d97120..0c2509e1cd 100644 --- a/doc/emacs/custom.texi +++ b/doc/emacs/custom.texi @@ -2228,25 +2228,10 @@ as a function from Lisp programs. When Emacs is started, it normally tries to load a Lisp program from an @dfn{initialization file}, or @dfn{init file} for short. This file, if it exists, specifies how to initialize Emacs for you. -If the directory @file{@var{xdghome}/.config/emacs} exists, Emacs uses -@file{@var{xdghome}/.config/emacs/init.el} as the init file. Here, -@var{xdghome} stands for the value of the environment variable -@env{XDG_CONFIG_HOME}, or for @file{~/.config} if -@env{XDG_CONFIG_HOME} is unset; @file{~/} stands for your home -directory. - - If @file{~/.config/emacs} does not exist, Emacs looks for your init -file using the filenames @file{~/.emacs}, @file{~/.emacs.el}, or -@file{~/.emacs.d/init.el}; you can choose to use any one of these -names (@pxref{Find Init}). Although this is backward-compatible -with older Emacs versions, modern POSIX platforms prefer putting your -initialization files under @file{.config} so that if you have -to troubleshoot a problem that might be due to a bad init file, or -archive a collection of them, it can be done by renaming or -copying that directory. Note that the @file{.config} versions -don't have a leading dot on the basename part of the file. -For convenience the rest of this section assumes @env{XDG_CONFIG_HOME} -is unset or has a value equivalent to @file{~/.config}. +If the file @file{~/.config/emacs/init.el} exists, it is used as the +init file; otherwise Emacs may look at @file{~/.emacs.el}, +@file{~/.emacs}, @file{~/.emacs.d/init.el}, or other locations. +@xref{Find Init}. You can use the command line switch @samp{-q} to prevent loading your init file, and @samp{-u} (or @samp{--user}) to specify a @@ -2652,8 +2637,31 @@ library. @xref{Hooks}. @subsection How Emacs Finds Your Init File Emacs normally finds your init file in a location under your home -directory, e.g., @file{~/.config/emacs/init.el} or -@file{~/.emacs.d/init.el}. @xref{Init File}. +directory. @xref{Init File}. By default this location is +@file{~/.config/emacs/init.el} where @file{~/} stands for your home directory. +This default can be overridden as described below. + + If @env{XDG_CONFIG_HOME} is set in your environment, its +value replaces @file{~/.config} in the name of the default +init file. + + If the default init file's parent directory does not exist but the +directory @file{~/.emacs.d} does exist, Emacs looks for your init file +using the filenames @file{~/.emacs.el}, @file{~/.emacs}, or +@file{~/.emacs.d/init.el}; you can choose to use any one of these +names. (Note that only the locations directly in your home directory +have a leading dot in the location's basename.) Although this is +backward-compatible with older Emacs versions, modern POSIX platforms +prefer putting your initialization files under @file{~/.config} so +that troubleshooting a problem that might be due to a bad init file, +or archiving a collection of init files, can be done by renaming that +directory. To help older Emacs versions find configuration files in +their current default locations, you can execute the following +Emacs Lisp code: + +@example +(make-symbolic-link ".config/emacs" "~/.emacs.d") +@end example However, if you run Emacs from a shell started by @code{su} and @env{XDG_CONFIG_HOME} is not set in your environment, Emacs @@ -2663,10 +2671,14 @@ editor customizations even if you are running as the super user. More precisely, Emacs first determines which user's init file to use. It gets your user name from the environment variables @env{LOGNAME} and -@env{USER}; if neither of those exists, it uses effective user-ID@. +@env{USER}; if neither of those exists, it uses the effective user-ID@. If that user name matches the real user-ID, then Emacs uses @env{HOME}; otherwise, it looks up the home directory corresponding to that user name in the system's data base of users. + + For brevity the rest of the Emacs documentation generally uses just +the current default location @file{~/.config/emacs/init.el} for the +init file. @c LocalWords: backtab @node Init Non-ASCII diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi index d53fed4ee8..c3b6c39b28 100644 --- a/doc/lispref/files.texi +++ b/doc/lispref/files.texi @@ -2822,9 +2822,10 @@ filter out a directory named @file{foo.elc}. name for a particular use---typically, to hold configuration data specified by the current user. Usually, such files should be located in the directory specified by @code{user-emacs-directory}, which is -@file{~/.config/emacs} or @file{~/.emacs.d} by default (@pxref{Init -File}). For example, abbrev definitions are stored by default in -@file{~/.config/emacs/abbrev_defs} or @file{~/.emacs.d/abbrev_defs}. +typically @file{~/.config/emacs} by default (@pxref{Find +Init,,How Emacs Finds Your Init File, emacs, The GNU Emacs Manual}). +For example, abbrev definitions are stored by default in +@file{~/.config/emacs/abbrev_defs}. The easiest way to specify such a file name is to use the function @code{locate-user-emacs-file}. diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index df21256908..c94e96bde8 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -474,10 +474,13 @@ the value refers to the corresponding source file. @defvar user-emacs-directory This variable holds the name of the Emacs default directory. -It is @file{@var{xdghome}/emacs/} if that directory exists, otherwise -@file{~/.emacs.d/} on all platforms but MS-DOS. Here, @var{xdghome} +It defaults to @file{$@{XDG_CONFIG_HOME-'~/.config'@}/emacs/} +if that directory exists and @file{~/.emacs.d/} does not exist, +otherwise to @file{~/.emacs.d/} on all platforms but MS-DOS@. +Here, @file{$@{XDG_CONFIG_HOME-'~/.config'@}} stands for the value of the environment variable @env{XDG_CONFIG_HOME} if that variable is set, and for @file{~/.config} otherwise. +@xref{Find Init,,How Emacs Finds Your Init File, emacs, The GNU Emacs Manual}. @end defvar @node Terminal-Specific commit 02a74ed315ab0a69a098a2a1c4687c0c9a644e75 Author: Paul Eggert Date: Sat Aug 31 14:48:26 2019 -0700 * doc/lispref/customize.texi: Fix typo. diff --git a/doc/lispref/customize.texi b/doc/lispref/customize.texi index e4a500b069..822066f3c5 100644 --- a/doc/lispref/customize.texi +++ b/doc/lispref/customize.texi @@ -418,7 +418,7 @@ already set or has been customized; otherwise, just use @code{set-default}. @item custom-initialize-delay -This functions behaves like @code{custom-initialize-set}, but it +This function behaves like @code{custom-initialize-set}, but it delays the actual initialization to the next Emacs start. This should be used in files that are preloaded (or for autoloaded variables), so that the initialization is done in the run-time context rather than commit 2befb4f0a1494f699f56215d5f28ba055663d881 Author: Paul Eggert Date: Sat Aug 31 14:47:04 2019 -0700 Calculate user-emacs-directory on startup Problem reported by Glenn Morris (Bug#583#56). * lisp/startup.el (startup--xdg-config-default): New constant. (startup--xdg-config-home-emacs): New var. (startup--xdg-or-homedot): New function. (normal-top-level): Use it to set user-emacs-directory early on. (command-line): Also use it to determine the startup init directory. * lisp/subr.el (user-emacs-directory): Just initialize to nil. diff --git a/lisp/startup.el b/lisp/startup.el index c1e429b8db..a16db242da 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -490,6 +490,27 @@ DIRS are relative." (when tail (setcdr tail (append (mapcar 'expand-file-name dirs) (cdr tail)))))) +;; The default location for XDG-convention Emacs init files. +(defconst startup--xdg-config-default "~/.config/emacs/") +;; The location for XDG-convention Emacs init files. +(defvar startup--xdg-config-home-emacs) + +;; Return the name of the init file directory for Emacs, assuming +;; XDG-DIR is the XDG location and USER-NAME is the user name. +;; If USER-NAME is nil or "", use the current user. +;; Prefer the XDG location unless it does does not exist and the +;; .emacs.d location does exist. +(defun startup--xdg-or-homedot (xdg-dir user-name) + (if (file-exists-p xdg-dir) + xdg-dir + (let ((emacs-d-dir (concat "~" user-name + (if (eq system-type 'ms-dos) + "/_emacs.d/" + "/.emacs.d/")))) + (if (file-exists-p emacs-d-dir) + emacs-d-dir + xdg-dir)))) + (defun normal-top-level () "Emacs calls this function when it first starts up. It sets `command-line-processed', processes the command-line, @@ -499,6 +520,14 @@ It is the default value of the variable `top-level'." (message internal--top-level-message) (setq command-line-processed t) + (setq startup--xdg-config-home-emacs + (let ((xdg-config-home (getenv-internal "XDG_CONFIG_HOME"))) + (if xdg-config-home + (concat xdg-config-home "/emacs/") + startup--xdg-config-default))) + (setq user-emacs-directory + (startup--xdg-or-homedot startup--xdg-config-home-emacs nil)) + ;; Look in each dir in load-path for a subdirs.el file. If we ;; find one, load it, which will add the appropriate subdirs of ;; that dir into load-path. This needs to be done before setting @@ -1167,19 +1196,17 @@ please check its value") :error)))) ;; Calculate the name of the Emacs init directory. - ;; This is typically equivalent to ~/.config/emacs if the user is - ;; following the XDG convention, and is ~INIT-FILE-USER/.emacs.d - ;; on other systems. - (setq xdg-dir (concat (or (getenv "XDG_CONFIG_HOME") - (concat "~" init-file-user "/.config")) - "/emacs/")) + ;; This is typically ~INIT-FILE-USER/.config/emacs unless the user + ;; is following the ~INIT-FILE-USER/.emacs.d convention. + (setq xdg-dir startup--xdg-config-home-emacs) (setq startup-init-directory - (if (file-exists-p xdg-dir) - xdg-dir - (let ((emacs-d-dir (concat "~" init-file-user "/.emacs.d/"))) - (if (file-exists-p emacs-d-dir) - emacs-d-dir - xdg-dir)))) + (if (or (zerop (length init-file-user)) + (and (eq xdg-dir user-emacs-directory) + (not (eq xdg-dir startup--xdg-config-default)))) + user-emacs-directory + ;; The name is not obvious, so access more directories to calculate it. + (setq xdg-dir (concat "~" init-file-user "/.config/emacs/")) + (startup--xdg-or-homedot xdg-dir init-file-user))) ;; Load the early init file, if found. (startup--load-user-init-file diff --git a/lisp/subr.el b/lisp/subr.el index 566a3fc758..cf6fb108e9 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -2938,18 +2938,8 @@ This hook is normally set up with a function to put the buffer in Help mode.") (defconst user-emacs-directory - (let ((config-dir (concat (or (getenv-internal "XDG_CONFIG_HOME") - "~/.config") - "/emacs/"))) - (if (file-exists-p config-dir) - config-dir - (let ((emacs-d-dir (if (eq system-type 'ms-dos) - ;; MS-DOS cannot have initial dot. - "~/_emacs.d/" - "~/.emacs.d/"))) - (if (file-exists-p emacs-d-dir) - emacs-d-dir - config-dir)))) + ;; The value does not matter since Emacs sets this at startup. + nil "Directory beneath which additional per-user Emacs-specific files are placed. Various programs in Emacs store information in this directory. Note that this should end with a directory separator. commit 7791005544836f93542e8277ad5897f8f5920f05 Author: Paul Eggert Date: Sat Aug 31 10:35:08 2019 -0700 Check instead of relying on NOTREACHED NOTREACHED was designed for traditional lint decades ago, and _Noreturn now normally subsumes its function. In the one case in Emacs where NORETURN might help and _Noreturn does not, check for NOTREACHED instead of assuming it. * lib-src/etags.c (main): * src/xterm.c (x_connection_closed): Remove NOTREACHED after a call to a _Noreturn function, as NOTREACHED is no longer needed there. Also, one of the NOTREACHEDs was misplaced, which defeated traditional lint checking anyway. * lib-src/pop.c (pop_getline): Redo so as to not need NOTREACHED. * src/emacs.c (main): Use eassume (false) rather than NOTREACHED, so that running with ENABLE_CHECKING catches any internal error causing the toplevel Frecursive_edit to return. diff --git a/lib-src/etags.c b/lib-src/etags.c index 036c485d0b..6409407e46 100644 --- a/lib-src/etags.c +++ b/lib-src/etags.c @@ -1146,7 +1146,6 @@ main (int argc, char **argv) { error ("-o option may only be given once."); suggest_asking_for_help (); - /* NOTREACHED */ } tagfile = optarg; break; @@ -1208,7 +1207,6 @@ main (int argc, char **argv) case 'w': no_warnings = true; break; default: suggest_asking_for_help (); - /* NOTREACHED */ } /* No more options. Store the rest of arguments. */ @@ -1227,13 +1225,11 @@ main (int argc, char **argv) if (help_asked) print_help (argbuffer); - /* NOTREACHED */ if (nincluded_files == 0 && file_count == 0) { error ("no input files specified."); suggest_asking_for_help (); - /* NOTREACHED */ } if (tagfile == NULL) diff --git a/lib-src/pop.c b/lib-src/pop.c index e4bd6c0496..9a0dd8ca70 100644 --- a/lib-src/pop.c +++ b/lib-src/pop.c @@ -1275,7 +1275,7 @@ pop_getline (popserver server, char **line) server->buffer_index = 0; } - while (1) + while (true) { /* There's a "- 1" here to leave room for the null that we put at the end of the read data below. We put the null there so @@ -1288,7 +1288,7 @@ pop_getline (popserver server, char **line) { strcpy (pop_error, "Out of memory in pop_getline"); pop_trash (server); - return (-1); + break; } } ret = RECV (server->file, server->buffer + server->data, @@ -1298,13 +1298,13 @@ pop_getline (popserver server, char **line) snprintf (pop_error, ERROR_MAX, "%s%s", GETLINE_ERROR, strerror (errno)); pop_trash (server); - return (-1); + break; } else if (ret == 0) { strcpy (pop_error, "Unexpected EOF from server in pop_getline"); pop_trash (server); - return (-1); + break; } else { @@ -1332,7 +1332,7 @@ pop_getline (popserver server, char **line) } } - /* NOTREACHED */ + return -1; } /* diff --git a/src/emacs.c b/src/emacs.c index cc5818393a..53572d7f0c 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -2084,8 +2084,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem /* Enter editor command loop. This never returns. */ Frecursive_edit (); - /* NOTREACHED */ - return 0; + eassume (false); } /* Sort the args so we can find the most important ones diff --git a/src/xterm.c b/src/xterm.c index 0d224063d7..b761eaf4d1 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -10044,7 +10044,6 @@ For details, see etc/PROBLEMS.\n", { fprintf (stderr, "%s\n", error_msg); Fkill_emacs (make_fixnum (70)); - /* NOTREACHED */ } totally_unblock_input (); commit 2de46be6620174e6e2cf4ed397e7cf901d1f1a7a Author: Glenn Morris Date: Sat Aug 31 10:30:14 2019 -0700 * test/lisp/net/tramp-tests.el (tramp-test21-file-links): More cleanup. diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 0d37d0763f..dd6b9edd00 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -3479,7 +3479,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (setq tmp-name3 (concat (file-remote-p tmp-name3) tmp-name2))))) ;; Cleanup. - (ignore-errors (delete-directory tmp-name1 'recursive))) + (ignore-errors + (delete-file tmp-name3) + (delete-directory tmp-name1 'recursive))) ;; Detect cyclic symbolic links. (unwind-protect commit 172b99a43ab60dac29eb09231246793a1ab32343 Author: Andreas Schwab Date: Sat Aug 31 12:39:16 2019 +0200 Fix compilation with CHECK_STRUCTS * src/pdumper.c (dump_hash_table): Update hash of Lisp_Hash_Table. diff --git a/src/pdumper.c b/src/pdumper.c index 73a50cee53..5e70e20431 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2696,7 +2696,7 @@ dump_hash_table (struct dump_context *ctx, Lisp_Object object, dump_off offset) { -#if CHECK_STRUCTS && !defined HASH_Lisp_Hash_Table_BB1ACF756E +#if CHECK_STRUCTS && !defined HASH_Lisp_Hash_Table_12AFBF47AF # error "Lisp_Hash_Table changed. See CHECK_STRUCTS comment in config.h." #endif const struct Lisp_Hash_Table *hash_in = XHASH_TABLE (object); commit 3608c5f27cf9a2913a5fcc854acc267eceaa8fe2 Author: Eli Zaretskii Date: Sat Aug 31 09:58:45 2019 +0300 ; * src/floatfns.c: Don't use non-ASCII characters in comments. diff --git a/src/floatfns.c b/src/floatfns.c index 49068bee77..9049185307 100644 --- a/src/floatfns.c +++ b/src/floatfns.c @@ -48,7 +48,7 @@ along with GNU Emacs. If not, see . */ #include -/* Emacs needs proper handling of ±inf; correct printing as well as +/* Emacs needs proper handling of +/-inf; correct printing as well as important packages depend on it. Make sure the user didn't specify -ffinite-math-only, either directly or implicitly with -Ofast or -ffast-math. */ commit 616835312e950fdeb38e8d7cbfcc6f581866ae36 Author: Eli Zaretskii Date: Sat Aug 31 09:54:05 2019 +0300 Avoid signaling errors from ls-lisp--insert-directory on macOS * lisp/ls-lisp.el (ls-lisp-sanitize): Don't assume the directory entries for ".." and "." will either both be present or both absent. (Bug#37236) diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el index e802c2408f..8491181bbe 100644 --- a/lisp/ls-lisp.el +++ b/lisp/ls-lisp.el @@ -517,7 +517,8 @@ If the \"..\" directory entry has nil attributes, the attributes are copied from the \".\" entry, if they are non-nil. Otherwise, the offending element is removed from the list, as are any elements for other directory entries with nil attributes." - (if (and (null (cdr (assoc ".." file-alist))) + (if (and (consp (assoc ".." file-alist)) + (null (cdr (assoc ".." file-alist))) (cdr (assoc "." file-alist))) (setcdr (assoc ".." file-alist) (cdr (assoc "." file-alist)))) (rassq-delete-all nil file-alist)) commit 4a919b1bbc00c8084aea2a4e8196d2b38e657946 Author: Mattias Engdegård Date: Thu Aug 29 12:29:47 2019 +0200 * src/floatfns.c: Check against __FINITE_MATH_ONLY__ (bug#37140) diff --git a/src/floatfns.c b/src/floatfns.c index 0a85df47de..49068bee77 100644 --- a/src/floatfns.c +++ b/src/floatfns.c @@ -48,6 +48,14 @@ along with GNU Emacs. If not, see . */ #include +/* Emacs needs proper handling of ±inf; correct printing as well as + important packages depend on it. Make sure the user didn't specify + -ffinite-math-only, either directly or implicitly with -Ofast or + -ffast-math. */ +#if defined __FINITE_MATH_ONLY__ && __FINITE_MATH_ONLY__ + #error Emacs cannot be built with -ffinite-math-only +#endif + /* Check that X is a floating point number. */ static void commit d09a1d66c608e9e993ce73515cf83f785d04e407 Author: Michael Albinus Date: Fri Aug 30 13:54:42 2019 +0200 Extend tramp--test-check-files (Bug#37228) * test/lisp/net/tramp-tests.el (tramp--test-check-files): Test also `directory-files-and-attributes'. (Bug#37228) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 5767551e32..0d37d0763f 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -5153,7 +5153,8 @@ This requires restrictions of file name syntax." (tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name 'local quoted)) (files (delq nil files)) - (process-environment process-environment)) + (process-environment process-environment) + (sorted-files (sort (copy-sequence files) #'string-lessp))) (unwind-protect (progn (make-directory tmp-name1) @@ -5200,10 +5201,20 @@ This requires restrictions of file name syntax." ;; Check file names. (should (equal (directory-files tmp-name1 nil directory-files-no-dot-files-regexp) - (sort (copy-sequence files) #'string-lessp))) + sorted-files)) (should (equal (directory-files tmp-name2 nil directory-files-no-dot-files-regexp) - (sort (copy-sequence files) #'string-lessp))) + sorted-files)) + (should (equal (mapcar + #'car + (directory-files-and-attributes + tmp-name1 nil directory-files-no-dot-files-regexp)) + sorted-files)) + (should (equal (mapcar + #'car + (directory-files-and-attributes + tmp-name2 nil directory-files-no-dot-files-regexp)) + sorted-files)) ;; `substitute-in-file-name' could return different ;; values. For `adb', there could be strange file commit cea78adf7c57e82f1343c7a004cd4053d2e312a6 Author: Koichi Arakawa Date: Fri Aug 30 13:53:56 2019 +0200 Fix Tramp's directory-files-and-attributes-with-stat (Bug#37228) * lisp/net/tramp-sh.el (tramp-do-directory-files-and-attributes-with-stat): Handle file names with spaces. (Bug#37228) Copyright-paperwork-exempt: yes diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 217e73a24b..bcfac78ee6 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1759,11 +1759,14 @@ of." ;; We must care about file names with spaces, or starting with ;; "-"; this would confuse xargs. "ls -aQ" might be a ;; solution, but it does not work on all remote systems. + ;; Therefore, we use \000 as file separator. + ;; `tramp-sh--quoting-style-options' do not work for file names + ;; with spaces piped to "xargs". ;; Apostrophes in the stat output are masked as ;; `tramp-stat-marker', in order to make a proper shell escape ;; of them in file names. - "cd %s && echo \"(\"; (%s %s -a | " - "xargs %s -c " + "cd %s && echo \"(\"; (%s %s -a | tr '\\n\\r' '\\000\\000' | " + "xargs -0 %s -c " "'(%s%%n%s (%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " "-- 2>/dev/null | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"")) (tramp-shell-quote-argument localname) commit 44f15b63dbe9a45921573197e08c8aaaed08412a Author: Paul Eggert Date: Fri Aug 30 00:24:07 2019 -0700 emacsclient: adjust to new config file location * lib-src/emacsclient.c (open_config): New arg XDG, to respect XDG_CONFIG_HOME, consistently with Emacs proper. Caller changed. Use XDG convention if available, falling back on the old names if not. diff --git a/lib-src/emacsclient.c b/lib-src/emacsclient.c index ba2721e8bc..e9469f77c5 100644 --- a/lib-src/emacsclient.c +++ b/lib-src/emacsclient.c @@ -914,22 +914,38 @@ initialize_sockets (void) #endif /* WINDOWSNT */ -/* If the home directory is HOME, return the configuration file with - basename CONFIG_FILE. Fail if there is no home directory or if the - configuration file could not be opened. */ +/* If the home directory is HOME, and XDG_CONFIG_HOME's value is XDG, + return the configuration file with basename CONFIG_FILE. Fail if + the configuration file could not be opened. */ static FILE * -open_config (char const *home, char const *config_file) +open_config (char const *home, char const *xdg, char const *config_file) { - if (!home) - return NULL; - ptrdiff_t homelen = strlen (home); - static char const emacs_d_server[] = "/.emacs.d/server/"; - ptrdiff_t suffixsize = sizeof emacs_d_server + strlen (config_file); - char *configname = xmalloc (homelen + suffixsize); - strcpy (stpcpy (stpcpy (configname, home), emacs_d_server), config_file); - - FILE *config = fopen (configname, "rb"); + ptrdiff_t xdgsubdirsize = xdg ? strlen (xdg) + sizeof "/emacs/server/" : 0; + ptrdiff_t homesuffixsizemax = max (sizeof "/.config/emacs/server/", + sizeof "/.emacs.d/server/"); + ptrdiff_t homesubdirsizemax = home ? strlen (home) + homesuffixsizemax : 0; + char *configname = xmalloc (max (xdgsubdirsize, homesubdirsizemax) + + strlen (config_file)); + FILE *config; + if (xdg || home) + { + strcpy ((xdg + ? stpcpy (stpcpy (configname, xdg), "/emacs/server/") + : stpcpy (stpcpy (configname, home), "/.config/emacs/server/")), + config_file); + config = fopen (configname, "rb"); + } + else + config = NULL; + + if (! config && home) + { + strcpy (stpcpy (stpcpy (configname, home), "/.emacs.d/server/"), + config_file); + config = fopen (configname, "rb"); + } + free (configname); return config; } @@ -949,10 +965,11 @@ get_server_config (const char *config_file, struct sockaddr_in *server, config = fopen (config_file, "rb"); else { - config = open_config (egetenv ("HOME"), config_file); + char const *xdg = egetenv ("XDG_CONFIG_HOME"); + config = open_config (egetenv ("HOME"), xdg, config_file); #ifdef WINDOWSNT if (!config) - config = open_config (egetenv ("APPDATA"), config_file); + config = open_config (egetenv ("APPDATA"), xdg, config_file); #endif } commit a4144af909c3a6baf381659bf158e254b28ee002 Author: Paul Eggert Date: Thu Aug 29 22:29:52 2019 -0700 Prefer ~/.config/emacs to ~/.emacs.d if neither exists That way, when Emacs starts in a fresh home directory, it prefers the new (XDG) convention rather than the old one. * lisp/files.el (locate-user-emacs-file): Make the parent directories of user-emacs-directory if needed. This is useful if user-emacs-directory is "~/.config/emacs" and "~/.config" does not yet exist. * lisp/startup.el (command-line): * lisp/subr.el (user-emacs-directory): Prefer XDG_CONFIG_HOME to ~/.emacs.d if neither exists. diff --git a/lisp/files.el b/lisp/files.el index 2a84c2c48f..ce4dd99bd5 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -1043,7 +1043,7 @@ directory if it does not exist." (setq errtype "access")) (with-file-modes ?\700 (condition-case nil - (make-directory user-emacs-directory) + (make-directory user-emacs-directory t) (error (setq errtype "create"))))) (when (and errtype user-emacs-directory-warning diff --git a/lisp/startup.el b/lisp/startup.el index 4d584a0cb5..c1e429b8db 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -1170,13 +1170,16 @@ please check its value") ;; This is typically equivalent to ~/.config/emacs if the user is ;; following the XDG convention, and is ~INIT-FILE-USER/.emacs.d ;; on other systems. - (setq xdg-dir - (let* ((dir (concat (or (getenv "XDG_CONFIG_HOME") + (setq xdg-dir (concat (or (getenv "XDG_CONFIG_HOME") (concat "~" init-file-user "/.config")) - "/emacs/"))) - (if (file-exists-p dir) dir))) + "/emacs/")) (setq startup-init-directory - (or xdg-dir (concat "~" init-file-user "/.emacs.d/"))) + (if (file-exists-p xdg-dir) + xdg-dir + (let ((emacs-d-dir (concat "~" init-file-user "/.emacs.d/"))) + (if (file-exists-p emacs-d-dir) + emacs-d-dir + xdg-dir)))) ;; Load the early init file, if found. (startup--load-user-init-file @@ -1325,7 +1328,7 @@ please check its value") (startup--load-user-init-file (lambda () (cond - (xdg-dir nil) + ((eq startup-init-directory xdg-dir) nil) ((eq system-type 'ms-dos) (concat "~" init-file-user "/_emacs")) ((not (eq system-type 'windows-nt)) diff --git a/lisp/subr.el b/lisp/subr.el index 3cf395787e..566a3fc758 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -2943,10 +2943,13 @@ mode.") "/emacs/"))) (if (file-exists-p config-dir) config-dir - (if (eq system-type 'ms-dos) - ;; MS-DOS cannot have initial dot. - "~/_emacs.d/" - "~/.emacs.d/"))) + (let ((emacs-d-dir (if (eq system-type 'ms-dos) + ;; MS-DOS cannot have initial dot. + "~/_emacs.d/" + "~/.emacs.d/"))) + (if (file-exists-p emacs-d-dir) + emacs-d-dir + config-dir)))) "Directory beneath which additional per-user Emacs-specific files are placed. Various programs in Emacs store information in this directory. Note that this should end with a directory separator. commit 462be72f41580a3137e8f4f1e48580ac6bcc371f Author: Nick Drozd Date: Thu Aug 29 18:36:50 2019 -0500 Minor copyedits in ido.texi * doc/misc/ido.texi (Overview) (Interactive Substring Matching, Prefix Matching) (Regexp Matching, Hidden Buffers and Files) (Changing List Order, Find File At Point, Misc) (All Matching, Replacement): Fix wording, markup and punctuation. (Bug#37225) diff --git a/doc/misc/ido.texi b/doc/misc/ido.texi index 29a204cf9e..a787b74343 100644 --- a/doc/misc/ido.texi +++ b/doc/misc/ido.texi @@ -108,7 +108,7 @@ This document describes a set of features that can interactively do things with buffers and files. All the features are described here in detail. -The @dfn{Ido} package can let you switch between buffers and visit +The @dfn{Ido} package lets you switch between buffers and visit files and directories with a minimum of keystrokes. It is a superset of Iswitchb, the interactive buffer switching package by Stephen Eglen. @@ -211,7 +211,7 @@ do with various kinds of @emph{matching}: among buffers, files, and directories. @noindent As you type in a substring, the list of buffers or files currently -matching the substring are displayed as you type. The list is +matching the substring is displayed as you type. The list is ordered so that the most recent buffers or files visited come at the start of the list. @@ -240,13 +240,13 @@ If you then press @kbd{2}: Buffer: 2[3]@{123456 | 123@} @end example -The list in @{...@} are the matching buffers, most recent first -(buffers visible in the current frame are put at the end of the list -by default). At any time you can select the item at the head of the -list by pressing @key{RET}. You can also put the first element at the -end of the list by pressing @kbd{C-s} or @kbd{}, or bring the -last element to the head of the list by pressing @kbd{C-r} or -@kbd{}. +The items listed in @{...@} are the matching buffers, most recent +first (buffers visible in the current frame are put at the end of the +list by default). At any time you can select the item at the head of +the list by pressing @key{RET}. You can also put the first element at +the end of the list by pressing @kbd{C-s} or @key{RIGHT}, or bring +the last element to the head of the list by pressing @kbd{C-r} or +@key{LEFT}. @findex ido-complete The item in [...] indicates what can be added to your input by @@ -287,7 +287,7 @@ Buffer: 234a [No match] There are no matching buffers. If you press @key{RET} or @key{TAB}, you can be prompted to create a new buffer called @file{234a}. -Of course, where this function comes in really useful is when you can +Of course, where this function really comes in handy is when you can specify the buffer using only a few keystrokes. In the above example, the quickest way to get to the @file{123456} file would be just to type @kbd{4} and then @key{RET} (assuming there isn't any newer buffer @@ -305,7 +305,7 @@ In addition to scrolling through the list using @kbd{} and @kbd{}, you can use @kbd{} and @kbd{} to quickly scroll the list to the next or previous subdirectory. -To go down into a subdirectory, and continue the file selection on +To go down into a subdirectory and continue the file selection on the files in that directory, simply move the directory to the head of the list and hit @key{RET}. @@ -366,9 +366,9 @@ If for some reason you cannot specify the proper file using @noindent The standard way of completion with *nix shells and Emacs is to insert a @dfn{prefix} and then hitting @key{TAB} (or another completion key). -Cause of this behavior has become second nature to a lot of Emacs -users Ido offers in addition to the default substring matching method -(look above) also the prefix matching method. The kind of matching is +Because this behavior has become second nature to a lot of Emacs +users, Ido offers, in addition to the default substring matching method +(see above), also the prefix matching method. The kind of matching is the only difference to the description of the substring matching above. @@ -425,7 +425,7 @@ matching. The value of this user option can be toggled within ido-mode using @code{ido-toggle-regexp}. @end defopt -@strong{Please notice:} Ido-style completion is inhibited when you +@strong{Please note:} Ido-style completion is inhibited when you enable regexp matching. @node Highlighting @@ -438,21 +438,21 @@ The highlighting of matching items is controlled via @code{ido-use-faces}. The faces used are @code{ido-first-match}, @code{ido-only-match} and @code{ido-subdir}. -Coloring of the matching item was suggested by Carsten Dominik. +Coloring of the matching items was suggested by Carsten Dominik. @node Hidden Buffers and Files @chapter Hidden Buffers and Files @cindex hidden buffers and files -Normally, Ido does not include hidden buffers (whose name starts with -a space) and hidden files and directories (whose name starts with -@samp{.}) in the list of possible completions. However, if the +Normally, Ido does not include hidden buffers (whose names start with +a space) and hidden files and directories (whose names start with +@file{.}) in the list of possible completions. However, if the substring you enter does not match any of the visible buffers or files, Ido will automatically look for completions among the hidden buffers or files. @findex ido-toggle-ignore -You can toggle display of the hidden buffers and files with @kbd{C-a} +You can toggle the display of hidden buffers and files with @kbd{C-a} (@code{ido-toggle-ignore}). @c @deffn Command ido-toggle-ignore @@ -525,7 +525,7 @@ deleting or rearranging elements.) @noindent Find File At Point, also known generally as ``ffap'', is an -intelligent system for opening files, and URLs. +intelligent system for opening files and URLs. The following expression will make Ido guess the context: @@ -552,7 +552,7 @@ a URL at point. If found, call @code{find-file-at-point} to visit it. @noindent Ido is capable of ignoring buffers, directories, files and extensions -using regular expression. +using regular expressions. @defopt ido-ignore-buffers This variable takes a list of regular expressions for buffers to @@ -590,7 +590,7 @@ Now you can customize @code{completion-ignored-extensions} as well. Go ahead and add all the useless object files, backup files, shared library files and other computing flotsam you don't want Ido to show. -@strong{Please notice:} Ido will still complete the ignored elements +@strong{Note:} Ido will still complete the ignored elements if it would otherwise not show any other matches. So if you type out the name of an ignored file, Ido will still let you open it just fine. @@ -718,7 +718,7 @@ packages. After @kbd{C-x b} (@code{ido-switch-buffer}), the buffer at the head of the list can be killed by pressing @kbd{C-k}. If the buffer needs saving, you will be queried before the buffer is killed. @kbd{C-S-b} -buries the buffer at the head of the list. +buries the buffer at the end of the list. Likewise, after @kbd{C-x C-f}, you can delete (i.e., physically remove) the file at the head of the list with @kbd{C-k}. You will @@ -726,8 +726,8 @@ always be asked for confirmation before deleting the file. If you enter @kbd{C-x b} to switch to a buffer visiting a given file, and you find that the file you are after is not in any buffer, you can -press @kbd{C-f} to immediately drop into @code{ido-find-file}. And -you can switch back to buffer selection with @kbd{C-b}. +press @kbd{C-f} to immediately drop into @code{ido-find-file}. You +can switch back to buffer selection with @kbd{C-b}. @c @deffn Command ido-magic-forward-char @c @deffn Command ido-magic-backward-char @@ -759,7 +759,7 @@ want Ido to behave differently from the default minibuffer resizing behavior, set the variable @code{ido-max-window-height}. Also, to improve the responsiveness of Ido, the maximum number of -matching items is limited to 12, but you can increase or removed this +matching items is limited to 12, but you can increase or remove this limit via the @code{ido-max-prospects} user option. @c @defopt ido-max-prospects @@ -774,7 +774,7 @@ this separate buffer. @noindent @code{ido-read-buffer} and @code{ido-read-file-name} have been written -to be drop in replacements for the normal buffer and file name reading +to be drop-in replacements for the normal buffer and file name reading functions @code{read-buffer} and @code{read-file-name}. To use ido for all buffer and file selections in Emacs, customize the commit 51cf9161ceaa613a95f714e56fb793dcf62d1da6 Merge: 040b305752 1af1240f5f Author: Glenn Morris Date: Thu Aug 29 11:12:12 2019 -0700 Merge from origin/emacs-26 1af1240 (origin/emacs-26, emacs-26) ; Remove empty NEWS sections 96dd019 (tag: emacs-26.3-rc1, tag: emacs-26.3) * etc/HISTORY: Add Ema... # Conflicts: # etc/NEWS commit 040b305752de07d9b564536afeb6a2d2b67e48b9 Merge: e7f16f00e1 4e59ad59a2 Author: Glenn Morris Date: Thu Aug 29 11:11:24 2019 -0700 ; Merge from origin/emacs-26 The following commit was skipped: 4e59ad5 Bump Emacs version to 26.3 commit e7f16f00e17c81b9550b4a96540b77bae6a4fc5d Merge: 8e8ebd44ae 70829f8c22 Author: Glenn Morris Date: Thu Aug 29 11:11:23 2019 -0700 Merge from origin/emacs-26 70829f8 ; ChangeLog.3 update # Conflicts: # ChangeLog.3 commit 8e8ebd44ae292687007f36ee87119a91b3679184 Merge: 5a3e501edd a6d0172e83 Author: Glenn Morris Date: Thu Aug 29 11:11:22 2019 -0700 ; Merge from origin/emacs-26 The following commit was skipped: a6d0172 * etc/AUTHORS: Update. commit 5a3e501edd61e20454fff775d779d906185f3247 Merge: 6dd44926a3 290fe4d122 Author: Glenn Morris Date: Thu Aug 29 11:11:21 2019 -0700 Merge from origin/emacs-26 290fe4d * ; ChangeLog.3 update e8f176b * etc/NEWS: Delete temporary markup. # Conflicts: # ChangeLog.3 # etc/NEWS commit 6dd44926a31b811578b384293f520afa83a2dcad Author: Glenn Morris Date: Thu Aug 29 11:04:18 2019 -0700 ; Fix earlier NEWS merge diff --git a/etc/NEWS b/etc/NEWS index ddaee02e26..9a3725b033 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -191,12 +191,6 @@ after Emacs has finished initialization and is ready for use. emacs.service file to eg "~/.config/systemd/user/", you will need to copy the new version of the file again.) -+++ -** New option 'help-enable-completion-auto-load'. -This allows disabling the new feature introduced in Emacs 26.1 which -loads files during completion of 'C-h f' and 'C-h v' according to -'definition-prefixes'. - * Changes in Emacs 27.1 diff --git a/etc/NEWS.26 b/etc/NEWS.26 index aa583f47c6..9beb79c150 100644 --- a/etc/NEWS.26 +++ b/etc/NEWS.26 @@ -23,6 +23,12 @@ with a prefix argument or by typing 'C-u C-h C-n'. * Changes in Emacs 26.3 + ++++ +** New option 'help-enable-completion-auto-load'. +This allows disabling the new feature introduced in Emacs 26.1 which +loads files during completion of 'C-h f' and 'C-h v' according to +'definition-prefixes'. * Editing Changes in Emacs 26.3 commit 1af1240f5f101ce3a4db30675a665ee70a9f8c81 Author: Glenn Morris Date: Thu Aug 29 10:59:53 2019 -0700 ; Remove empty NEWS sections diff --git a/etc/NEWS b/etc/NEWS index d672d057bb..de42606d2b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -15,12 +15,6 @@ in older Emacs versions. You can narrow news to a specific version by calling 'view-emacs-news' with a prefix argument or by typing 'C-u C-h C-n'. - -* Installation Changes in Emacs 26.3 - - -* Startup Changes in Emacs 26.3 - * Changes in Emacs 26.3 @@ -33,24 +27,6 @@ loads files during completion of 'C-h f' and 'C-h v' according to The newly assigned codepoint U+32FF was added to the Unicode Character Database compiled into Emacs. - -* Editing Changes in Emacs 26.3 - - -* Changes in Specialized Modes and Packages in Emacs 26.3 - - -* New Modes and Packages in Emacs 26.3 - - -* Incompatible Lisp Changes in Emacs 26.3 - - -* Lisp Changes in Emacs 26.3 - - -* Changes in Emacs 26.3 on Non-Free Operating Systems - * Installation Changes in Emacs 26.2 commit 9df285250bc30b5ba86a19c817eea0c56164e022 Author: Stefan Kangas Date: Wed Aug 21 01:02:43 2019 +0200 Add new "make help" target * GNUmakefile: Add new "help" target that shows a brief summary of common make targets. (Bug#12411) * INSTALL * etc/NEWS: Announce it. diff --git a/GNUmakefile b/GNUmakefile index a67624e1f7..274109ca48 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -32,6 +32,38 @@ # But run 'autogen.sh' first, if the source was checked out directly # from the repository. +# Display help. + +ifeq (help,$(filter help,$(MAKECMDGOALS))) +help: + @echo "NOTE: This is a brief summary of some common make targets." + @echo "For more detailed information, please read the files INSTALL," + @echo "INSTALL.REPO, Makefile or visit this URL:" + @echo "http://www.gnu.org/prep/standards/html_node/Standard-Targets.html" + @echo "" + @echo "make all -- compile and build Emacs" + @echo "make install -- install Emacs" + @echo "make TAGS -- update tags tables" + @echo "make clean -- delete built files but preserve configuration" + @echo "make mostlyclean -- like 'make clean', but leave those files that" + @echo " usually do not need to be recompiled" + @echo "make distclean -- delete all build and configuration files," + @echo " leave only files included in source distribution" + @echo "make maintainer-clean -- delete almost everything that can be regenerated" + @echo "make bootstrap -- delete all compiled files to force a new bootstrap" + @echo " from a clean slate, then build in the normal way" + @echo "make uninstall -- remove files installed by 'make install'" + @echo "make check -- run the Emacs test suite" + @echo "make docs -- generate Emacs documentation in info format" + @echo "make html -- generate documentation in html format" + @echo "make ps -- generate documentation in ps format" + @echo "make pdf -- generate documentation in pdf format " + @exit + +.PHONY: help + +else + # If a Makefile already exists, just use it. ifeq ($(wildcard Makefile),Makefile) @@ -82,3 +114,4 @@ bootstrap: Makefile endif endif +endif diff --git a/INSTALL b/INSTALL index 6934022c4e..86f9e0080c 100644 --- a/INSTALL +++ b/INSTALL @@ -109,6 +109,9 @@ sections if you need to. (provided you have the 'gzip' program) those installed Lisp source (.el) files that have corresponding .elc versions, as well as the Info files. + You can read a brief summary about common make targets: + + make help ADDITIONAL DISTRIBUTION FILES diff --git a/etc/NEWS b/etc/NEWS index cd9a0947b9..ddaee02e26 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -129,6 +129,8 @@ This is intended mostly to help developers. ** Emacs now requires GTK 2.24 and GTK 3.10 for the GTK 2 and GTK 3 builds respectively. +** New make target 'help' shows a summary of common make targets. + * Startup Changes in Emacs 27.1 commit d87e9a59cde7466780c6c9bec4702665f7eb86e1 Author: Lars Ingebrigtsen Date: Thu Aug 29 09:18:40 2019 +0200 Tweak shr background colour handling * lisp/net/shr.el (shr-fill-line): Extend the background to the end of the line when folding lines. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 189873d8ce..81c3fb4aa5 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -715,8 +715,12 @@ size, and full-buffer size." ;; Success; continue. (when (= (preceding-char) ?\s) (delete-char -1)) - (let ((gap-start (point))) - (insert "\n") + (let ((gap-start (point)) + (face (get-text-property (point) 'face))) + ;; Extend the background to the end of the line. + (if face + (insert (propertize "\n" 'face (shr-face-background face))) + (insert "\n")) (shr-indent) (when (and (> (1- gap-start) (point-min)) (get-text-property (point) 'shr-url) commit 7803e65ffc105a788741c4a1ab927fed32c6ab9b Author: Michael Albinus Date: Wed Aug 28 20:39:33 2019 +0200 Clarify meaning of in test/README diff --git a/test/README b/test/README index c34cdce8ef..b55e24556f 100644 --- a/test/README +++ b/test/README @@ -44,6 +44,9 @@ The Makefile in this directory supports the following targets: tests. In the former case the output is shown on the terminal, in the latter case the output is written to .log. + could be either a relative file name like +"lisp/files-tests", or a package name like "files-tests". + ERT offers selectors, which make it possible to filter out which test cases shall run. The make variable $(SELECTOR) gives you a simple mean to use your own selectors. The ERT manual describes how commit fdccab473e1f95dae5ee0f07a4531dd4e05b22dd Author: Paul Eggert Date: Wed Aug 28 11:34:48 2019 -0700 Don't worry about pre-1.0.0 alsa-lib include Problem reported by Ergus in: https://lists.gnu.org/r/emacs-devel/2019-08/msg00563.html * configure.ac (ALSA_SUBDIR_INCLUDE): Do not define. * src/sound.c: Assume ALSA_SUBDIR_INCLUDE. diff --git a/configure.ac b/configure.ac index 6c83d61921..e39a438052 100644 --- a/configure.ac +++ b/configure.ac @@ -1731,26 +1731,6 @@ if test "${with_sound}" != "no"; then ALSA_MODULES="alsa >= $ALSA_REQUIRED" EMACS_CHECK_MODULES([ALSA], [$ALSA_MODULES]) if test $HAVE_ALSA = yes; then - SAVE_CFLAGS="$CFLAGS" - SAVE_LIBS="$LIBS" - CFLAGS="$ALSA_CFLAGS $CFLAGS" - LIBS="$ALSA_LIBS $LIBS" - AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include ]], [[snd_lib_error_set_handler (0);]])], - emacs_alsa_normal=yes, - emacs_alsa_normal=no) - if test "$emacs_alsa_normal" != yes; then - AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include ]], - [[snd_lib_error_set_handler (0);]])], - emacs_alsa_subdir=yes, - emacs_alsa_subdir=no) - if test "$emacs_alsa_subdir" != yes; then - AC_MSG_ERROR([pkg-config found alsa, but it does not compile. See config.log for error messages.]) - fi - ALSA_CFLAGS="$ALSA_CFLAGS -DALSA_SUBDIR_INCLUDE" - fi - - CFLAGS="$SAVE_CFLAGS" - LIBS="$SAVE_LIBS" LIBSOUND="$LIBSOUND $ALSA_LIBS" CFLAGS_SOUND="$CFLAGS_SOUND $ALSA_CFLAGS" AC_DEFINE(HAVE_ALSA, 1, [Define to 1 if ALSA is available.]) diff --git a/src/sound.c b/src/sound.c index 4ba826e82c..44d4cbc6d5 100644 --- a/src/sound.c +++ b/src/sound.c @@ -72,12 +72,8 @@ along with GNU Emacs. If not, see . */ #include #endif #ifdef HAVE_ALSA -#ifdef ALSA_SUBDIR_INCLUDE #include -#else -#include -#endif /* ALSA_SUBDIR_INCLUDE */ -#endif /* HAVE_ALSA */ +#endif /* END: Non Windows Includes */ commit e028131e05a12f13015b6b0cd8a41092850e43b8 Author: Eli Zaretskii Date: Wed Aug 28 14:00:01 2019 +0300 ; Improve and clarify wording of recent commit in NEWS. diff --git a/etc/NEWS b/etc/NEWS index 9b3dadf452..cd9a0947b9 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -134,12 +134,19 @@ builds respectively. +++ ** Emacs now uses the XDG convention for init files. -For example, it looks for init.el in ~/.config/emacs/init.el. -Emacs continues to look for init files in their traditional locations -if ~/.config/emacs does not exist. The XDG_CONFIG_HOME environment -variable (default ~/.config) specifies the parent directory of these -configuration files, so invoking Emacs with XDG_CONFIG_HOME='/nowhere' -might be useful if your new-location init files are scrambled. +For example, it looks for init.el in ~/.config/emacs/init.el, and +similarly for other init files. + +The XDG_CONFIG_HOME environment variable (which defaults to ~/.config) +specifies the parent directory of these and other configuration files, +and will override their traditional locations (the home directory, +~/.emacs.d, etc.). + +Emacs will still look for init files in their traditional locations if +XDG_CONFIG_HOME does not exist, so invoking Emacs with +XDG_CONFIG_HOME='/nowhere' might be useful if your new-location init +files are scrambled, or if you want to force Emacs to ignore files +under XDG_CONFIG_HOME for some other reason. +++ ** Emacs can now be configured using an early init file. commit 4118297ae2fab4886b20d193ba511a229637aea3 Author: Paul Eggert Date: Tue Aug 27 14:21:45 2019 -0700 Use XDG conventions more consistently Fit in better with the XDG conventions. Something like this was suggested in 2008 (Bug#583) and the XDG conventions seem to have settled down by now. * doc/emacs/custom.texi (Init File, Init Syntax, Find Init): * doc/lispref/files.texi (Standard File Names): * doc/lispref/os.texi (Init File): * doc/misc/url.texi (Customization): * etc/NEWS: Adjust accordingly. * lisp/startup.el (startup--load-user-init-file): If init-file-name is nil, do not load from it; instead just use the alt-file. (find-init-path): Remove; no longer used. (command-line): Don't check twice for XDG. Look at XDG_CONFIG_HOME instead of assuming it's ~/.config. Prefer XDG configuration if it exists; the user can disable this by setting XDG_CONFIG_HOME to some other place. * lisp/subr.el (user-emacs-directory): Prefer XDG configuration if it exists. diff --git a/doc/emacs/custom.texi b/doc/emacs/custom.texi index 8fbc6c1ca0..d3d7d97120 100644 --- a/doc/emacs/custom.texi +++ b/doc/emacs/custom.texi @@ -2220,28 +2220,33 @@ as a function from Lisp programs. @cindex init file @cindex .emacs file @cindex ~/.emacs file -@cindex ~/.config/emacs file +@cindex ~/.config/emacs/init.el file @cindex Emacs initialization file @cindex startup (init file) +@cindex XDG_CONFIG_HOME When Emacs is started, it normally tries to load a Lisp program from an @dfn{initialization file}, or @dfn{init file} for short. This -file, if it exists, specifies how to initialize Emacs for you. Emacs -looks for your init file using the filenames -@file{~/.config/emacs},. @file{~/.emacs}, @file{~/.config/emacs.el}, -@file{~/.emacs.el}, @file{~/.config/emacs.d/init.el} or -@file{~/.emacs.d/init.el}; you can choose to use any one of these -names (@pxref{Find Init}). Here, @file{~/} stands for your home +file, if it exists, specifies how to initialize Emacs for you. +If the directory @file{@var{xdghome}/.config/emacs} exists, Emacs uses +@file{@var{xdghome}/.config/emacs/init.el} as the init file. Here, +@var{xdghome} stands for the value of the environment variable +@env{XDG_CONFIG_HOME}, or for @file{~/.config} if +@env{XDG_CONFIG_HOME} is unset; @file{~/} stands for your home directory. - While the @file{~/.emacs} and @file{~/.emacs.d/init.el} locations -are backward-compatible to older Emacs versions, and the rest of this -chapter will use them to name your initialization file, it is better practice -to group all of your dotfiles under @file{.config} so that if you have + If @file{~/.config/emacs} does not exist, Emacs looks for your init +file using the filenames @file{~/.emacs}, @file{~/.emacs.el}, or +@file{~/.emacs.d/init.el}; you can choose to use any one of these +names (@pxref{Find Init}). Although this is backward-compatible +with older Emacs versions, modern POSIX platforms prefer putting your +initialization files under @file{.config} so that if you have to troubleshoot a problem that might be due to a bad init file, or archive a collection of them, it can be done by renaming or copying that directory. Note that the @file{.config} versions don't have a leading dot on the basename part of the file. +For convenience the rest of this section assumes @env{XDG_CONFIG_HOME} +is unset or has a value equivalent to @file{~/.config}. You can use the command line switch @samp{-q} to prevent loading your init file, and @samp{-u} (or @samp{--user}) to specify a @@ -2313,17 +2318,17 @@ function @code{setq} to set the variable @code{fill-column} You can set any Lisp variable with @code{setq}, but with certain variables @code{setq} won't do what you probably want in the -@file{.emacs} file. Some variables automatically become buffer-local -when set with @code{setq}; what you want in @file{.emacs} is to set +init file. Some variables automatically become buffer-local +when set with @code{setq}; what you want in the init file is to set the default value, using @code{setq-default}. Some customizable minor mode variables do special things to enable the mode when you set them with Customize, but ordinary @code{setq} won't do that; to enable the -mode in your @file{.emacs} file, call the minor mode command. The +mode in your init file, call the minor mode command. The following section has examples of both of these methods. The second argument to @code{setq} is an expression for the new value of the variable. This can be a constant, a variable, or a -function call expression. In @file{.emacs}, constants are used most +function call expression. In the init file, constants are used most of the time. They can be: @table @asis @@ -2646,15 +2651,12 @@ library. @xref{Hooks}. @node Find Init @subsection How Emacs Finds Your Init File - Normally Emacs uses your home directory to find -@file{~/.config/emacs} or @file{~/.emacs}; that's what @samp{~} means -in a file name. @xref{General Variables, HOME}. If none of -@file{~/.config/emacs}, @file{~/.emacs}, @file{~/.config/emacs.el} nor -@file{~/.emacs.el} is found, Emacs looks for -@file{~/.config/emacs.d/init.el} or @file{~/.emacs.d/init.el} (these, -like @file{~/.emacs.el}, can be byte-compiled). + Emacs normally finds your init file in a location under your home +directory, e.g., @file{~/.config/emacs/init.el} or +@file{~/.emacs.d/init.el}. @xref{Init File}. - However, if you run Emacs from a shell started by @code{su}, Emacs + However, if you run Emacs from a shell started by @code{su} and +@env{XDG_CONFIG_HOME} is not set in your environment, Emacs tries to find your own initialization files, not that of the user you are currently pretending to be. The idea is that you should get your own editor customizations even if you are running as the super user. @@ -2705,8 +2707,8 @@ Type @kbd{C-q}, followed by the key you want to bind, to insert @var{char}. @subsection The Early Init File @cindex early init file - Most customizations for Emacs should be put in the normal init file, -@file{.config/emacs} or @file{~/.config/emacs.d/init.el}. However, it is sometimes desirable + Most customizations for Emacs should be put in the normal init file. +@xref{Init File}. However, it is sometimes desirable to have customizations that take effect during Emacs startup earlier than the normal init file is processed. Such customizations can be put in the early init file, @file{~/.config/emacs.d/early-init.el} or @file{~/.emacs.d/early-init.el}. This file is loaded before the diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi index 6be5a52837..d53fed4ee8 100644 --- a/doc/lispref/files.texi +++ b/doc/lispref/files.texi @@ -2822,8 +2822,9 @@ filter out a directory named @file{foo.elc}. name for a particular use---typically, to hold configuration data specified by the current user. Usually, such files should be located in the directory specified by @code{user-emacs-directory}, which is -@file{~/.emacs.d} by default (@pxref{Init File}). For example, abbrev -definitions are stored by default in @file{~/.emacs.d/abbrev_defs}. +@file{~/.config/emacs} or @file{~/.emacs.d} by default (@pxref{Init +File}). For example, abbrev definitions are stored by default in +@file{~/.config/emacs/abbrev_defs} or @file{~/.emacs.d/abbrev_defs}. The easiest way to specify such a file name is to use the function @code{locate-user-emacs-file}. diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index dd80b04ad8..df21256908 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -473,8 +473,11 @@ the value refers to the corresponding source file. @end defvar @defvar user-emacs-directory -This variable holds the name of the @file{.emacs.d} directory. It is -@file{~/.emacs.d} on all platforms but MS-DOS. +This variable holds the name of the Emacs default directory. +It is @file{@var{xdghome}/emacs/} if that directory exists, otherwise +@file{~/.emacs.d/} on all platforms but MS-DOS. Here, @var{xdghome} +stands for the value of the environment variable @env{XDG_CONFIG_HOME} +if that variable is set, and for @file{~/.config} otherwise. @end defvar @node Terminal-Specific diff --git a/doc/misc/url.texi b/doc/misc/url.texi index 0cdfcac24e..bad7701daf 100644 --- a/doc/misc/url.texi +++ b/doc/misc/url.texi @@ -1267,7 +1267,8 @@ files, etc. The default value specifies a subdirectory named @file{url/} in the standard Emacs user data directory specified by the variable -@code{user-emacs-directory} (normally @file{~/.emacs.d}). However, +@code{user-emacs-directory} (normally @file{~/.config/emacs} +or @file{~/.emacs.d}). However, the old default was @file{~/.url}, and this directory is used instead if it exists. @end defopt diff --git a/etc/NEWS b/etc/NEWS index 4e231e2a64..9b3dadf452 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -132,6 +132,15 @@ builds respectively. * Startup Changes in Emacs 27.1 ++++ +** Emacs now uses the XDG convention for init files. +For example, it looks for init.el in ~/.config/emacs/init.el. +Emacs continues to look for init files in their traditional locations +if ~/.config/emacs does not exist. The XDG_CONFIG_HOME environment +variable (default ~/.config) specifies the parent directory of these +configuration files, so invoking Emacs with XDG_CONFIG_HOME='/nowhere' +might be useful if your new-location init files are scrambled. + +++ ** Emacs can now be configured using an early init file. The file is called 'early-init.el', in 'user-emacs-directory'. It is diff --git a/lisp/startup.el b/lisp/startup.el index 564428580b..4d584a0cb5 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -1,4 +1,4 @@ -;; startup.el --- process Emacs shell arguments -*- lexical-binding: t -*- +;;; startup.el --- process Emacs shell arguments -*- lexical-binding: t -*- ;; Copyright (C) 1985-1986, 1992, 1994-2019 Free Software Foundation, ;; Inc. @@ -906,16 +906,19 @@ init-file, or to a default value if loading is not possible." ;; the name of the file that it loads into ;; `user-init-file'. (setq user-init-file t) - (load (if (equal (file-name-extension init-file-name) - "el") - (file-name-sans-extension init-file-name) - init-file-name) - 'noerror 'nomessage) + (when init-file-name + (load (if (equal (file-name-extension init-file-name) + "el") + (file-name-sans-extension init-file-name) + init-file-name) + 'noerror 'nomessage)) (when (and (eq user-init-file t) alternate-filename-function) (let ((alt-file (funcall alternate-filename-function))) (and (equal (file-name-extension alt-file) "el") (setq alt-file (file-name-sans-extension alt-file))) + (unless init-file-name + (setq init-file-name alt-file)) (load alt-file 'noerror 'nomessage))) ;; If we did not find the user's init file, set @@ -971,18 +974,10 @@ the `--debug-init' option to view a complete error backtrace." (when debug-on-error-should-be-set (setq debug-on-error debug-on-error-from-init-file)))) -(defun find-init-path (fn) - "Look in ~/.config/FOO or ~/.FOO for the dotfile or dot directory FOO. -It is expected that the output will undergo ~ expansion. Implements the -XDG convention for dotfiles." - (let* ((xdg-path (concat "~" init-file-user "/.config/" fn)) - (oldstyle-path (concat "~" init-file-user "/." fn)) - (found-path (if (file-exists-p xdg-path) xdg-path oldstyle-path))) - found-path)) - (defun command-line () "A subroutine of `normal-top-level'. Amongst another things, it parses the command-line arguments." + (let (xdg-dir startup-init-directory) (setq before-init-time (current-time) after-init-time nil command-line-default-directory default-directory) @@ -1171,6 +1166,18 @@ please check its value") init-file-user)) :error)))) + ;; Calculate the name of the Emacs init directory. + ;; This is typically equivalent to ~/.config/emacs if the user is + ;; following the XDG convention, and is ~INIT-FILE-USER/.emacs.d + ;; on other systems. + (setq xdg-dir + (let* ((dir (concat (or (getenv "XDG_CONFIG_HOME") + (concat "~" init-file-user "/.config")) + "/emacs/"))) + (if (file-exists-p dir) dir))) + (setq startup-init-directory + (or xdg-dir (concat "~" init-file-user "/.emacs.d/"))) + ;; Load the early init file, if found. (startup--load-user-init-file (lambda () @@ -1180,8 +1187,7 @@ please check its value") ;; with the .el extension, if the file doesn't exist, not just ;; "early-init" without an extension, as it does for ".emacs". "early-init.el" - (file-name-as-directory - (find-init-path "emacs.d"))))) + startup-init-directory))) (setq early-init-file user-init-file) ;; If any package directory exists, initialize the package system. @@ -1319,10 +1325,11 @@ please check its value") (startup--load-user-init-file (lambda () (cond + (xdg-dir nil) ((eq system-type 'ms-dos) (concat "~" init-file-user "/_emacs")) ((not (eq system-type 'windows-nt)) - (find-init-path "emacs")) + (concat "~" init-file-user "/.emacs")) ;; Else deal with the Windows situation. ((directory-files "~" nil "^\\.emacs\\(\\.elc?\\)?$") ;; Prefer .emacs on Windows. @@ -1339,8 +1346,7 @@ please check its value") (lambda () (expand-file-name "init" - (file-name-as-directory - (find-init-path "emacs.d")))) + startup-init-directory)) (not inhibit-default-init)) (when (and deactivate-mark transient-mark-mode) @@ -1456,7 +1462,7 @@ Consider using a subdirectory instead, e.g.: %s" (if (and (boundp 'x-session-previous-id) (stringp x-session-previous-id)) (with-no-warnings - (emacs-session-restore x-session-previous-id)))) + (emacs-session-restore x-session-previous-id))))) (defun x-apply-session-resources () "Apply X resources which specify initial values for Emacs variables. diff --git a/lisp/subr.el b/lisp/subr.el index b22db65bb6..3cf395787e 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -2938,10 +2938,15 @@ This hook is normally set up with a function to put the buffer in Help mode.") (defconst user-emacs-directory - (if (eq system-type 'ms-dos) - ;; MS-DOS cannot have initial dot. - "~/_emacs.d/" - "~/.emacs.d/") + (let ((config-dir (concat (or (getenv-internal "XDG_CONFIG_HOME") + "~/.config") + "/emacs/"))) + (if (file-exists-p config-dir) + config-dir + (if (eq system-type 'ms-dos) + ;; MS-DOS cannot have initial dot. + "~/_emacs.d/" + "~/.emacs.d/"))) "Directory beneath which additional per-user Emacs-specific files are placed. Various programs in Emacs store information in this directory. Note that this should end with a directory separator. commit fa41fa70f1ed0bb392328f84388b803ddef7f6d9 Author: Paul Eggert Date: Tue Aug 27 14:19:38 2019 -0700 Port recent gnutls fixes to gcc -Wpointer-sign * src/gnutls.c (Fgnutls_format_certificate): Fix pointer signedness problem. diff --git a/src/gnutls.c b/src/gnutls.c index 577675f340..042f43e291 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -1622,7 +1622,8 @@ string representation. */) emacs_gnutls_strerror (err)); } - Lisp_Object result = make_string_from_bytes (out.data, out.size, out.size); + Lisp_Object result = make_string_from_bytes ((char *) out.data, out.size, + out.size); gnutls_free (out.data); gnutls_x509_crt_deinit (crt); commit ba5d9795f87fb2660be5d54516c97e2d56344b03 Author: Juri Linkov Date: Tue Aug 27 23:48:57 2019 +0300 Browser-like Info-history button menu (bug#37184) * doc/misc/info.texi (Help-Int): Using tool-bar to navigate history. * lisp/info.el (Info-history-menu): New function. (Info-history-back-menu, Info-history-forward-menu): New commands. (Info-mode-map): Bind Info-history-back-menu and Info-history-forward-menu to tool-bar on C-key. diff --git a/doc/misc/info.texi b/doc/misc/info.texi index cbdeaff50c..077e83e3c9 100644 --- a/doc/misc/info.texi +++ b/doc/misc/info.texi @@ -886,6 +886,14 @@ which the header says is the @samp{Previous} node (from this node, the to revisit nodes in the history list in the forward direction, so that @kbd{r} will return you to the node you came from by typing @kbd{l}. +@cindex using tool-bar to navigate history + Clicking the mouse on the left arrow icon in the tool-bar while +holding down the @key{CTRL} key in Emacs opens a menu of previously +visited nodes: the same nodes that you can revisit by +@code{Info-history-back}. Selecting a node after clicking on the +right arrow icon revisits the same nodes as available by +@code{Info-history-forward}. + @kindex L @r{(Info mode)} @findex Info-history @cindex history list of visited nodes diff --git a/etc/NEWS b/etc/NEWS index a03e2027a9..4e231e2a64 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -953,6 +953,11 @@ early init file. ** Info ++++ +*** Clicking on the left/right arrow icon in the Info tool-bar while +holding down the Ctrl key pops up a menu of previously visited Info nodes +where you can select a node to go back (like in browsers). + --- *** Info can now follow 'file://' protocol URLs. The 'file://' URLs in Info documents can now be followed by passing diff --git a/lisp/info.el b/lisp/info.el index 17a2d63e6d..e22466af87 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -4059,6 +4059,8 @@ If FORK is non-nil, it is passed to `Info-goto-node'." (define-key map [follow-link] 'mouse-face) (define-key map [XF86Back] 'Info-history-back) (define-key map [XF86Forward] 'Info-history-forward) + (define-key map [tool-bar C-Back\ in\ history] 'Info-history-back-menu) + (define-key map [tool-bar C-Forward\ in\ history] 'Info-history-forward-menu) map) "Keymap containing Info commands.") @@ -4151,6 +4153,36 @@ If FORK is non-nil, it is passed to `Info-goto-node'." :vert-only t) map)) +(defun Info-history-menu (e name history command) + (let* ((i (length history)) + (map (make-sparse-keymap name))) + (mapc (lambda (history) + (let ((file (nth 0 history)) + (node (nth 1 history))) + (when (stringp file) + (setq file (file-name-sans-extension + (file-name-nondirectory file)))) + (define-key map (vector (intern (format "history-%i" i))) + `(menu-item ,(format "(%s) %s" file node) + (lambda () + (interactive) + (dotimes (_ ,i) (call-interactively ',command)))))) + (setq i (1- i))) + (reverse history)) + (let* ((selection (x-popup-menu e map)) + (binding (and selection (lookup-key map (vector (car selection)))))) + (if binding (call-interactively binding))))) + +(defun Info-history-back-menu (e) + "Pop up the menu with a list of previously visited Info nodes." + (interactive "e") + (Info-history-menu e "Back in history" Info-history 'Info-history-back)) + +(defun Info-history-forward-menu (e) + "Pop up the menu with a list of Info nodes visited with ‘Info-history-back’." + (interactive "e") + (Info-history-menu e "Forward in history" Info-history-forward 'Info-history-forward)) + (defvar Info-menu-last-node nil) ;; Last node the menu was created for. ;; Value is a list, (FILE-NAME NODE-NAME). commit ba1f7797fbf6c6b94f5236b621b6aeda9ada405c Author: Michael Albinus Date: Tue Aug 27 18:53:26 2019 +0200 Deactivate part of tramp--test-check-files on macOS (Bug#36940) * test/lisp/net/tramp-tests.el (tramp--test-check-files): Do not search for environment variables on macOS. (Bug#36940) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 9930a2c9e1..5767551e32 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -5276,7 +5276,10 @@ This requires restrictions of file name syntax." (should-not (file-exists-p file1)))) ;; Check, that environment variables are set correctly. - (when (and (tramp--test-expensive-test) (tramp--test-sh-p)) + ;; We do not run on macOS due to encoding problems. See + ;; Bug#36940. + (when (and (tramp--test-expensive-test) (tramp--test-sh-p) + (not (eq system-type 'darwin))) (dolist (elt files) (let ((envvar (concat "VAR_" (upcase (md5 elt)))) (elt (encode-coding-string elt coding-system-for-read)) @@ -5291,15 +5294,10 @@ This requires restrictions of file name syntax." (goto-char (point-min)) (should (re-search-forward - ;; We must use proper encoding on macOS. See - ;; Bug#36940. - (funcall - (if (eq coding-system-for-read 'utf-8-hfs) - 'ucs-normalize-HFS-NFD-string 'identity) - (format - "^%s=%s$" - (regexp-quote envvar) - (regexp-quote (getenv envvar))))))))))) + (format + "^%s=%s$" + (regexp-quote envvar) + (regexp-quote (getenv envvar)))))))))) ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive)) commit b5e18f9fe5514e25aa547b87b5eb56a983b23bd6 Author: Eli Zaretskii Date: Tue Aug 27 19:13:39 2019 +0300 ; Fix commentary of last change. diff --git a/src/gnutls.c b/src/gnutls.c index fb75eb930f..577675f340 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -567,9 +567,9 @@ init_gnutls_functions (void) # endif # endif /* HAVE_GNUTLS3 */ -/* gnutls_free is a data pointer to a variable which holds a pointer - to the function. We use #undef because MinGW64 defines gnutls_free - as a macro as well in the GnuTLS headers. */ +/* gnutls_free_func is a data pointer to a variable which holds an + address of a function. We use #undef because MinGW64 defines + gnutls_free as a macro as well in the GnuTLS headers. */ # undef gnutls_free # define gnutls_free (*gnutls_free_func) commit 6769b649286fbf0f29cb20590eb17011b435d429 Author: Eli Zaretskii Date: Tue Aug 27 18:47:24 2019 +0300 Fix crashes on MS-Windows when using GnuTLS connections * src/gnutls.c (init_gnutls_functions) [WINDOWSNT]: Define and load gnutls_free by an explicit call to GetProcAddress. (gnutls_free) [WINDOWSNT]: Define as a macro that dereferences a function pointer. (Bug#31946) (Fgnutls_format_certificate): Use make_string_from_bytes instead of going through an intermediate malloc'ed buffer. diff --git a/src/gnutls.c b/src/gnutls.c index 67d1fb9552..fb75eb930f 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -140,7 +140,6 @@ DEF_DLL_FN (void, gnutls_dh_set_prime_bits, DEF_DLL_FN (int, gnutls_dh_get_prime_bits, (gnutls_session_t)); DEF_DLL_FN (int, gnutls_error_is_fatal, (int)); DEF_DLL_FN (int, gnutls_global_init, (void)); -DEF_DLL_FN (void, gnutls_free, (void *)); DEF_DLL_FN (void, gnutls_global_set_log_function, (gnutls_log_func)); # ifdef HAVE_GNUTLS3 DEF_DLL_FN (void, gnutls_global_set_audit_log_function, (gnutls_audit_log_func)); @@ -291,6 +290,7 @@ DEF_DLL_FN (const char *, gnutls_ext_get_name, (unsigned int)); # endif # endif /* HAVE_GNUTLS3 */ +static gnutls_free_function *gnutls_free_func; static bool init_gnutls_functions (void) @@ -327,7 +327,6 @@ init_gnutls_functions (void) LOAD_DLL_FN (library, gnutls_dh_get_prime_bits); LOAD_DLL_FN (library, gnutls_error_is_fatal); LOAD_DLL_FN (library, gnutls_global_init); - LOAD_DLL_FN (library, gnutls_free); LOAD_DLL_FN (library, gnutls_global_set_log_function); # ifdef HAVE_GNUTLS3 LOAD_DLL_FN (library, gnutls_global_set_audit_log_function); @@ -430,6 +429,13 @@ init_gnutls_functions (void) # endif # endif /* HAVE_GNUTLS3 */ + /* gnutls_free is a variable inside GnuTLS, whose value is the + "free" function. So it needs special handling. */ + gnutls_free_func = (gnutls_free_function *) GetProcAddress (library, + "gnutls_free"); + if (!gnutls_free_func) + return false; + max_log_level = clip_to_bounds (INT_MIN, global_gnutls_log_level, INT_MAX); { Lisp_Object name = CAR_SAFE (Fget (Qgnutls, QCloaded_from)); @@ -465,7 +471,6 @@ init_gnutls_functions (void) # define gnutls_global_init fn_gnutls_global_init # define gnutls_global_set_audit_log_function fn_gnutls_global_set_audit_log_function # define gnutls_global_set_log_function fn_gnutls_global_set_log_function -# define gnutls_free fn_gnutls_free # define gnutls_global_set_log_level fn_gnutls_global_set_log_level # define gnutls_handshake fn_gnutls_handshake # define gnutls_init fn_gnutls_init @@ -562,6 +567,11 @@ init_gnutls_functions (void) # endif # endif /* HAVE_GNUTLS3 */ +/* gnutls_free is a data pointer to a variable which holds a pointer + to the function. We use #undef because MinGW64 defines gnutls_free + as a macro as well in the GnuTLS headers. */ +# undef gnutls_free +# define gnutls_free (*gnutls_free_func) /* This wrapper is called from fns.c, which doesn't know about the LOAD_DLL_FN stuff above. */ @@ -1612,16 +1622,10 @@ string representation. */) emacs_gnutls_strerror (err)); } - char *out_buf = xmalloc ((out.size + 1) * sizeof (char)); - memset (out_buf, 0, (out.size + 1) * sizeof (char)); - memcpy (out_buf, out.data, out.size); - + Lisp_Object result = make_string_from_bytes (out.data, out.size, out.size); gnutls_free (out.data); gnutls_x509_crt_deinit (crt); - Lisp_Object result = build_string (out_buf); - xfree (out_buf); - return result; } commit e4d17d8cb479ffeeb7dfb7320a1432722ac8df75 Author: Alex Branham Date: Thu Aug 15 11:02:38 2019 -0500 Fix filename completion in shell mode buffers * lisp/shell.el (shell-dynamic-complete-functions): Move pcomplete-completions-at-point down the list so that filename completion has a chance to complete before pcompletion. Fixes bug#34330 diff --git a/lisp/shell.el b/lisp/shell.el index ba7515e7ba..fb2c36fa73 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -184,13 +184,16 @@ shell buffer. The value may depend on the operating system or shell." shell-environment-variable-completion shell-command-completion shell-c-a-p-replace-by-expanded-directory - pcomplete-completions-at-point shell-filename-completion - comint-filename-completion) + comint-filename-completion + ;; Put `pcomplete-completions-at-point' last so that other + ;; functions can run before it does, see bug#34330. + pcomplete-completions-at-point) "List of functions called to perform completion. This variable is used to initialize `comint-dynamic-complete-functions' in the shell buffer." :type '(repeat function) + :version "27.1" :group 'shell) (defcustom shell-command-regexp "[^;&|\n]+" commit 693e9be5871f4e9bcb1a4ecfe5a40e68f5433cc3 Author: Michael Albinus Date: Tue Aug 27 12:58:38 2019 +0200 * test/Makefile.in (test_template): Declare target FOO.log. diff --git a/test/Makefile.in b/test/Makefile.in index b795907208..abcba94473 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -233,6 +233,7 @@ define test_template ifeq (,$(patsubst %-tests,,$(1))$(findstring -tests/,$(1))) $(1).log: $(patsubst %-tests,$(srcdir)/../%,$(1))$(if \ $(patsubst src/%,,$(patsubst lib-src/%,,$(1))),.el,.c) + $(notdir $(1).log): $(1).log endif ## Short aliases that always re-run the tests, with no logging. commit ed44217d3245ddc8f2cf75c9499d5bb37848cfd7 Author: Lars Ingebrigtsen Date: Tue Aug 27 09:46:28 2019 +0200 Fix completion in `read-library-name' * lisp/emacs-lisp/find-func.el (read-library-name): Only list .el/.el.gz files when completing (bug#36945). diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 9fc7e4a797..142c99edd4 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -285,10 +285,19 @@ Interactively, prompt for LIBRARY using the one at or near point." A library name is the filename of an Emacs Lisp library located in a directory under `load-path' (or `find-function-source-path', if non-nil)." - (let* ((dirs (or find-function-source-path load-path)) - (suffixes (find-library-suffixes)) - (table (apply-partially 'locate-file-completion-table - dirs suffixes)) + (let* ((suffix-regexp (mapconcat + (lambda (suffix) + (concat (regexp-quote suffix) "\\'")) + (find-library-suffixes) + "\\|")) + (table (cl-loop for dir in (or find-function-source-path load-path) + when (file-readable-p dir) + append (mapcar + (lambda (file) + (replace-regexp-in-string suffix-regexp + "" file)) + (directory-files dir nil + suffix-regexp)))) (def (if (eq (function-called-at-point) 'require) ;; `function-called-at-point' may return 'require ;; with `point' anywhere on this line. So wrap the commit d9e4d52a10a198b06333eb6523561cccc1a078c1 Author: Mauro Aranda Date: Tue Aug 27 08:41:44 2019 +0200 Make link widgets obey mouse-1-click-follows-link * lisp/wid-edit.el (widget-link-keymap): New variable, a keymap to use inside a link widget. ('link widget): Restore the :follow-link property and add widget-link-keymap as the :keymap property (bug#15682). diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index dd03a24bb3..1ddc461f4e 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1790,17 +1790,22 @@ If END is omitted, it defaults to the length of LIST." :type 'string :group 'widget-button) +(defvar widget-link-keymap + (let ((map (copy-keymap widget-keymap))) + ;; Only bind mouse-2, since mouse-1 will be translated accordingly to + ;; the customization of `mouse-1-click-follows-link'. + (define-key map [down-mouse-1] (lookup-key widget-global-map [down-mouse-1])) + (define-key map [down-mouse-2] 'widget-button-click) + (define-key map [mouse-2] 'widget-button-click) + map) + "Keymap used inside a link widget.") + (define-widget 'link 'item "An embedded link." :button-prefix 'widget-link-prefix :button-suffix 'widget-link-suffix - ;; The `follow-link' property should only be used in those contexts where the - ;; mouse-1 event normally doesn't follow the link, yet the `link' widget - ;; seems to almost always be used in contexts where (down-)mouse-1 is bound - ;; to `widget-button-click' and hence the "mouse-1 to mouse-2" remapping is - ;; not necessary (and can even be harmful). So let's not add a :follow-link - ;; by default. See (bug#22434). - ;; :follow-link 'mouse-face + :follow-link 'mouse-face + :keymap widget-link-keymap :help-echo "Follow the link." :format "%[%t%]") commit ec5d4ff096590cb12b579169ba561b37c82fe0cf Author: Mauro Aranda Date: Tue Aug 27 08:40:32 2019 +0200 Adapt recentf.el to the change in the Widget Library * lisp/recentf.el (recentf-open-files-item): Stop overriding :follow-link property of the link widgets, since now it should work as expected (bug#15682). diff --git a/lisp/recentf.el b/lisp/recentf.el index 4112b44e48..2720286814 100644 --- a/lisp/recentf.el +++ b/lisp/recentf.el @@ -1184,9 +1184,6 @@ IGNORE other arguments." :format "%[%t\n%]" :help-echo ,(concat "Open " (cdr menu-element)) :action recentf-open-files-action - ;; Override the (problematic) follow-link property of the - ;; `link' widget (bug#22434). - :follow-link nil ,(cdr menu-element)))) (defun recentf-open-files-items (files) commit f3f091899e811bfa5d138be95fca7c0a23c7ec84 Author: Mauro Aranda Date: Tue Aug 27 08:39:04 2019 +0200 Create push-button widgets instead of links in epa *Keys* buffer * lisp/epa.el (epa--select-keys): Make OK and Cancel into buttons (bug#15682). diff --git a/lisp/epa.el b/lisp/epa.el index 9e6edf463c..b55a55fbb9 100644 --- a/lisp/epa.el +++ b/lisp/epa.el @@ -440,12 +440,12 @@ If ARG is non-nil, mark the key." (substitute-command-keys "\ - `\\[epa-mark-key]' to mark a key on the line - `\\[epa-unmark-key]' to unmark a key on the line\n")) - (widget-create 'link + (widget-create 'push-button :notify (lambda (&rest _ignore) (abort-recursive-edit)) :help-echo "Click here or \\[abort-recursive-edit] to cancel" "Cancel") - (widget-create 'link + (widget-create 'push-button :notify (lambda (&rest _ignore) (exit-recursive-edit)) :help-echo "Click here or \\[exit-recursive-edit] to finish" commit 0e2d559daf43a04024ceaacfc8844839af2d50df Author: Paul Eggert Date: Mon Aug 26 18:57:56 2019 -0700 Fix Tramp rounding of file sizes and inode numbers * lisp/net/tramp-sh.el (tramp-perl-file-attributes) (tramp-perl-directory-files-and-attributes) (tramp-do-file-attributes-with-stat) (tramp-do-directory-files-and-attributes-with-stat): Format file sizes and inode numbers without trailing ".0", to avoid rounding errors when absolute values exceed 2**53 (Bug#36940#94). This fixes the problem for Emacs 27 and later, and doesn't hurt in earlier Emacs. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 1f7c8f6e49..217e73a24b 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -669,7 +669,7 @@ else $uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\"; $gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; printf( - \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t %%u.0 -1)\\n\", + \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u %%u t %%u -1)\\n\", $type, $stat[3], $uid, @@ -719,7 +719,7 @@ for($i = 0; $i < $n; $i++) $gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; $filename =~ s/\"/\\\\\"/g; printf( - \"(\\\"%%s\\\" %%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t %%u.0 -1)\\n\", + \"(\\\"%%s\\\" %%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u %%u t %%u -1)\\n\", $filename, $type, $stat[3], @@ -1353,7 +1353,7 @@ component is used as the target of the symlink." ;; `tramp-stat-marker', in order to make a proper shell escape ;; of them in file names. "( (%s %s || %s -h %s) && (%s -c " - "'((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s.0 %s%%A%s t %%i.0 -1)' " + "'((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " "%s | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g') || echo nil)")) (tramp-get-file-exists-command vec) (tramp-shell-quote-argument localname) @@ -1764,7 +1764,7 @@ of." ;; of them in file names. "cd %s && echo \"(\"; (%s %s -a | " "xargs %s -c " - "'(%s%%n%s (%s%%N%s) %%h %s %s %%X %%Y %%Z %%s.0 %s%%A%s t %%i.0 -1)' " + "'(%s%%n%s (%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " "-- 2>/dev/null | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"")) (tramp-shell-quote-argument localname) (tramp-get-ls-command vec) commit 3ef6849b458893669b1d83653e3672f7f1ac56cd Author: Stefan Kangas Date: Sat Jun 1 01:40:11 2019 +0200 Prefer display-line-numbers over linum in docs and one defcustom * doc/misc/efaq.texi: Replace linum with display-line-numbers. * lisp/progmodes/prog-mode.el (prog-mode-hook): Replace linum-mode with display-line-numbers-mode in :options. (Bug#37120) diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi index df244a71c8..e5673daf3a 100644 --- a/doc/misc/efaq.texi +++ b/doc/misc/efaq.texi @@ -1687,11 +1687,21 @@ mode-line-format @key{RET}}) for more information on how to set and use this variable. @cindex Set number capability in @code{vi} emulators -The @samp{linum} package (distributed with Emacs since version 23.1) -displays line numbers in the left margin, like the ``set number'' -capability of @code{vi}. The packages @samp{setnu} and -@samp{wb-line-number} (not distributed with Emacs) also implement this -feature. +The @samp{display-line-numbers} package (added to Emacs in version +26.1) displays line numbers in the text area, before each line, like +the ``set number'' capability of @samp{vi}. Customize the +buffer-local variable @code{display-line-numbers} to activate this +optional display. Alternatively, you can use the +@code{display-line-numbers-mode} minor mode or the global +@code{global-display-line-numbers-mode}. When using these modes, +customize @code{display-line-numbers-type} with the same value as you +would use with @code{display-line-numbers}. + +There is also the @samp{linum} package (distributed with Emacs since +version 23.1) which will henceforth become obsolete. Users and +developers are encouraged to use @samp{display-line-numbers} instead. +The packages @samp{setnu} and @samp{wb-line-number} (not distributed +with Emacs) also implement this feature. @node Displaying the current file name in the titlebar @section How can I modify the titlebar to contain the current file name? diff --git a/lisp/progmodes/prog-mode.el b/lisp/progmodes/prog-mode.el index cb39e62265..8d3513bad3 100644 --- a/lisp/progmodes/prog-mode.el +++ b/lisp/progmodes/prog-mode.el @@ -39,7 +39,8 @@ (defcustom prog-mode-hook nil "Normal hook run when entering programming modes." :type 'hook - :options '(flyspell-prog-mode abbrev-mode flymake-mode linum-mode + :options '(flyspell-prog-mode abbrev-mode flymake-mode + display-line-numbers-mode prettify-symbols-mode) :group 'prog-mode) commit f600134a24feab37f393e066e811f5c09ad48917 Author: Juri Linkov Date: Tue Aug 27 01:38:19 2019 +0300 * src/keyboard.c (parse_tool_bar_item): Use CAPTION when HELP is unavailable while adding equivalent key binding to the tooltip. (Bug#36156) diff --git a/src/keyboard.c b/src/keyboard.c index 30686a2589..1b9a603ca1 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -8304,6 +8304,10 @@ parse_tool_bar_item (Lisp_Object key, Lisp_Object item) AUTO_STRING (end, ")"); Lisp_Object orig = PROP (TOOL_BAR_ITEM_HELP); Lisp_Object desc = Fkey_description (keys, Qnil); + + if (NILP (orig)) + orig = PROP (TOOL_BAR_ITEM_CAPTION); + set_prop (TOOL_BAR_ITEM_HELP, CALLN (Fconcat, orig, beg, desc, end)); } commit 1071a4fac6f2e70572a1259e073124cbb723e90d Author: Eli Zaretskii Date: Mon Aug 26 19:06:13 2019 +0300 Fix crashes in networking with GnuTLS on MS-Windows * src/gnutls.c (init_gnutls_functions) [WINDOWSNT]: Define and load gnutls_free. (Fgnutls_format_certificate): Use gnutls_free instead of xfree. This prevents crashes on MS-Windows, since the memory being released was allocated inside GnuTLS. (Bug#31946) diff --git a/src/gnutls.c b/src/gnutls.c index a7ef59ab91..67d1fb9552 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -140,6 +140,7 @@ DEF_DLL_FN (void, gnutls_dh_set_prime_bits, DEF_DLL_FN (int, gnutls_dh_get_prime_bits, (gnutls_session_t)); DEF_DLL_FN (int, gnutls_error_is_fatal, (int)); DEF_DLL_FN (int, gnutls_global_init, (void)); +DEF_DLL_FN (void, gnutls_free, (void *)); DEF_DLL_FN (void, gnutls_global_set_log_function, (gnutls_log_func)); # ifdef HAVE_GNUTLS3 DEF_DLL_FN (void, gnutls_global_set_audit_log_function, (gnutls_audit_log_func)); @@ -326,6 +327,7 @@ init_gnutls_functions (void) LOAD_DLL_FN (library, gnutls_dh_get_prime_bits); LOAD_DLL_FN (library, gnutls_error_is_fatal); LOAD_DLL_FN (library, gnutls_global_init); + LOAD_DLL_FN (library, gnutls_free); LOAD_DLL_FN (library, gnutls_global_set_log_function); # ifdef HAVE_GNUTLS3 LOAD_DLL_FN (library, gnutls_global_set_audit_log_function); @@ -463,6 +465,7 @@ init_gnutls_functions (void) # define gnutls_global_init fn_gnutls_global_init # define gnutls_global_set_audit_log_function fn_gnutls_global_set_audit_log_function # define gnutls_global_set_log_function fn_gnutls_global_set_log_function +# define gnutls_free fn_gnutls_free # define gnutls_global_set_log_level fn_gnutls_global_set_log_level # define gnutls_handshake fn_gnutls_handshake # define gnutls_init fn_gnutls_init @@ -1613,7 +1616,7 @@ string representation. */) memset (out_buf, 0, (out.size + 1) * sizeof (char)); memcpy (out_buf, out.data, out.size); - xfree (out.data); + gnutls_free (out.data); gnutls_x509_crt_deinit (crt); Lisp_Object result = build_string (out_buf); commit f87ace2aed492d5d605da59b59af6fad5f0e33e4 Author: Michael Albinus Date: Mon Aug 26 16:14:16 2019 +0200 ; Continued attempt to fix Bug#36940 * test/lisp/net/tramp-tests.el (tramp--test-file-attributes-equal-p): Handle link number. (tramp--test-check-files): Encode search string on macOS. (Bug#36940) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 557536a0eb..9930a2c9e1 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -3098,6 +3098,12 @@ They might differ only in time attributes or directory size." (let ((attr1 (copy-sequence attr1)) (attr2 (copy-sequence attr2)) (start-time (- tramp--test-start-time 10))) + ;; Link number. For directories, it includes the number of + ;; subdirectories. Set it to 1. + (when (eq (tramp-compat-file-attribute-type attr1) t) + (setcar (nthcdr 1 attr1) 1)) + (when (eq (tramp-compat-file-attribute-type attr2) t) + (setcar (nthcdr 1 attr2) 1)) ;; Access time. (setcar (nthcdr 4 attr1) tramp-time-dont-know) (setcar (nthcdr 4 attr2) tramp-time-dont-know) @@ -5285,10 +5291,15 @@ This requires restrictions of file name syntax." (goto-char (point-min)) (should (re-search-forward - (format - "^%s=%s$" - (regexp-quote envvar) - (regexp-quote (getenv envvar)))))))))) + ;; We must use proper encoding on macOS. See + ;; Bug#36940. + (funcall + (if (eq coding-system-for-read 'utf-8-hfs) + 'ucs-normalize-HFS-NFD-string 'identity) + (format + "^%s=%s$" + (regexp-quote envvar) + (regexp-quote (getenv envvar))))))))))) ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive)) commit 42ba6200af10c00c72ac13912d6fb42a7af88058 Author: Lars Ingebrigtsen Date: Mon Aug 26 08:02:31 2019 +0200 Allow finding gpg2 binaries when gpg2 has an "unknown" version string * lisp/epg-config.el (epg-find-configuration): Allow finding a usable configuration even if the version string looks like "gpg (GnuPG) 2.2.15-unknown" (bug#35629). diff --git a/lisp/epg-config.el b/lisp/epg-config.el index 54328290c8..4a9cc7744c 100644 --- a/lisp/epg-config.el +++ b/lisp/epg-config.el @@ -148,7 +148,11 @@ Otherwise, it tries the programs listed in the entry until the version requirement is met." (unless program-alist (setq program-alist epg-config--program-alist)) - (let ((entry (assq protocol program-alist))) + (let ((entry (assq protocol program-alist)) + ;; In many gnupg distributions (especially on Windows), the + ;; version string is "gpg (GnuPG) 2.2.15-unknown" or the like. + (version-regexp-alist (cons '("^[-._+ ]?unknown$" . -4) + version-regexp-alist))) (unless entry (error "Unknown protocol %S" protocol)) (cl-destructuring-bind (symbol . alist) commit f5fa0c9062d065dc61fdff92b56b9f5da439a83d Author: Teemu Likonen Date: Mon Aug 26 07:52:54 2019 +0200 Only use --sender for gpg when gpg supports it * lisp/epg-config.el (epg-required-version-p): New function (bug#37025). * lisp/gnus/mml-sec.el (mml-secure-epg-sign): * lisp/epg.el (epg-start-sign): (epg-start-encrypt): Use it to only use --sender when the gpg binary supports it. diff --git a/lisp/epg-config.el b/lisp/epg-config.el index 5549068169..54328290c8 100644 --- a/lisp/epg-config.el +++ b/lisp/epg-config.el @@ -262,6 +262,15 @@ a single minimum version string." (throw 'version-ok t))) (error "Unsupported version: %s" version)))) +(defun epg-required-version-p (protocol required-version) + "Verify a sufficient version of GnuPG for specific protocol. +PROTOCOL is symbol, either `OpenPGP' or `CMS'. REQUIRED-VERSION +is a string containing the required version number. Return +non-nil if that version or higher is installed." + (let ((version (cdr (assq 'version (epg-find-configuration protocol))))) + (and (stringp version) + (version<= required-version version)))) + ;;;###autoload (defun epg-expand-group (config group) "Look at CONFIG and try to expand GROUP." diff --git a/lisp/epg.el b/lisp/epg.el index ce58c520f1..6d377d07e2 100644 --- a/lisp/epg.el +++ b/lisp/epg.el @@ -1618,7 +1618,9 @@ If you are unsure, use synchronous version of this function (car (epg-key-sub-key-list signer))))) (epg-context-signers context))) (let ((sender (epg-context-sender context))) - (when (stringp sender) + (when (and (eql 'OpenPGP (epg-context-protocol context)) + (epg-required-version-p 'OpenPGP "2.1.15") + (stringp sender)) (list "--sender" sender))) (epg--args-from-sig-notations (epg-context-sig-notations context)) @@ -1714,9 +1716,11 @@ If you are unsure, use synchronous version of this function (car (epg-key-sub-key-list signer))))) (epg-context-signers context)))) - (if sign + (if (and sign + (eql 'OpenPGP (epg-context-protocol context))) (let ((sender (epg-context-sender context))) - (when (stringp sender) + (when (and (epg-required-version-p 'OpenPGP "2.1.15") + (stringp sender)) (list "--sender" sender)))) (if sign (epg--args-from-sig-notations diff --git a/lisp/gnus/mml-sec.el b/lisp/gnus/mml-sec.el index 07d2028534..e0ec829617 100644 --- a/lisp/gnus/mml-sec.el +++ b/lisp/gnus/mml-sec.el @@ -915,7 +915,7 @@ If no one is selected, symmetric encryption will be performed. " (when sign (setq signers (mml-secure-signers context signer-names)) (setf (epg-context-signers context) signers) - (when mml-secure-openpgp-sign-with-sender + (when (and (eq 'OpenPGP protocol) mml-secure-openpgp-sign-with-sender) (setf (epg-context-sender context) sender))) (when (eq 'OpenPGP protocol) (setf (epg-context-armor context) t) @@ -945,10 +945,10 @@ If no one is selected, symmetric encryption will be performed. " signature micalg) (when (eq 'OpenPGP protocol) (setf (epg-context-armor context) t) - (setf (epg-context-textmode context) t)) + (setf (epg-context-textmode context) t) + (when mml-secure-openpgp-sign-with-sender + (setf (epg-context-sender context) sender))) (setf (epg-context-signers context) signers) - (when mml-secure-openpgp-sign-with-sender - (setf (epg-context-sender context) sender)) (when (mml-secure-cache-passphrase-p protocol) (epg-context-set-passphrase-callback context commit 8056d39c1d3f5e7afcc921932db04f7d1f9accf9 Author: Lars Ingebrigtsen Date: Mon Aug 26 06:13:20 2019 +0200 Fix ede-proj-project class * lisp/cedet/ede/proj.el (ede-proj-project): Make class inherit from eieio-named to get object-name slot (bug#37181). diff --git a/lisp/cedet/ede/proj.el b/lisp/cedet/ede/proj.el index 0774a4625b..59ba3ffcf8 100644 --- a/lisp/cedet/ede/proj.el +++ b/lisp/cedet/ede/proj.el @@ -216,7 +216,7 @@ This enables the creation of your target type." (setq ede-proj-target-alist (cons (cons name class) ede-proj-target-alist))))) -(defclass ede-proj-project (eieio-persistent ede-project) +(defclass ede-proj-project (eieio-persistent ede-project eieio-named) ((extension :initform ".ede") (file-header-line :initform ";; EDE Project Files are auto generated: Do Not Edit") (makefile-type :initarg :makefile-type commit fffefeecc81aad1b0a8e00032de66e2502c86547 Author: Paul Eggert Date: Sun Aug 25 16:35:43 2019 -0700 Fix bug with non-paletted transparent PNGs Adapted from a fix by YAMAMOTO Mitsuharu (Bug#37153#77). * src/image.c (png_load_body): Fix bug with non-paletted transparent images. diff --git a/src/image.c b/src/image.c index 18495612e9..fe7bd90b05 100644 --- a/src/image.c +++ b/src/image.c @@ -6598,15 +6598,16 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c) # ifdef PNG_tRNS_SUPPORTED png_bytep trans_alpha; int num_trans; - if (png_get_tRNS (png_ptr, info_ptr, &trans_alpha, &num_trans, NULL) - && trans_alpha) + if (png_get_tRNS (png_ptr, info_ptr, &trans_alpha, &num_trans, NULL)) { - int i; - for (i = 0; i < num_trans; i++) - if (0 < trans_alpha[i] && trans_alpha[i] < 255) - break; - if (! (i < num_trans)) - transparent_p = true; + transparent_p = true; + if (trans_alpha) + for (int i = 0; i < num_trans; i++) + if (0 < trans_alpha[i] && trans_alpha[i] < 255) + { + transparent_p = false; + break; + } } # endif commit 8826beaf00660eaaeff28016e022af1d9bf40b7c Author: Paul Eggert Date: Sun Aug 25 10:01:46 2019 -0700 Fix misdisplay of PNG paletted images Problem reported by Roland Winkler (Bug#37153). Derived from a patch suggested by YAMAMOTO Mitsuharu (Bug#37153#62). * src/image.c (png_get_valid) [WINDOWSNT]: Do not dynamically link this function. (png_get_tRNS) [WINDOWSNT && PNG_tRNS_SUPPORTED]: Dynamically link this function instead. (png_load_body): Do not assume that every paletted image supplies only transparency data. Fix typo in use of transparent_p. diff --git a/src/image.c b/src/image.c index 81d8cb4e2b..18495612e9 100644 --- a/src/image.c +++ b/src/image.c @@ -6234,7 +6234,10 @@ DEF_DLL_FN (void, png_read_info, (png_structp, png_infop)); DEF_DLL_FN (png_uint_32, png_get_IHDR, (png_structp, png_infop, png_uint_32 *, png_uint_32 *, int *, int *, int *, int *, int *)); -DEF_DLL_FN (png_uint_32, png_get_valid, (png_structp, png_infop, png_uint_32)); +# ifdef PNG_tRNS_SUPPORTED +DEF_DLL_FN (png_uint_32, png_get_tRNS, (png_structp, png_infop, png_bytep *, + int *, png_color_16p *)); +# endif DEF_DLL_FN (void, png_set_strip_16, (png_structp)); DEF_DLL_FN (void, png_set_expand, (png_structp)); DEF_DLL_FN (void, png_set_gray_to_rgb, (png_structp)); @@ -6273,7 +6276,9 @@ init_png_functions (void) LOAD_DLL_FN (library, png_set_sig_bytes); LOAD_DLL_FN (library, png_read_info); LOAD_DLL_FN (library, png_get_IHDR); - LOAD_DLL_FN (library, png_get_valid); +# ifdef PNG_tRNS_SUPPORTED + LOAD_DLL_FN (library, png_get_tRNS); +# endif LOAD_DLL_FN (library, png_set_strip_16); LOAD_DLL_FN (library, png_set_expand); LOAD_DLL_FN (library, png_set_gray_to_rgb); @@ -6304,7 +6309,7 @@ init_png_functions (void) # undef png_get_IHDR # undef png_get_io_ptr # undef png_get_rowbytes -# undef png_get_valid +# undef png_get_tRNS # undef png_longjmp # undef png_read_end # undef png_read_image @@ -6329,7 +6334,7 @@ init_png_functions (void) # define png_get_IHDR fn_png_get_IHDR # define png_get_io_ptr fn_png_get_io_ptr # define png_get_rowbytes fn_png_get_rowbytes -# define png_get_valid fn_png_get_valid +# define png_get_tRNS fn_png_get_tRNS # define png_longjmp fn_png_longjmp # define png_read_end fn_png_read_end # define png_read_image fn_png_read_image @@ -6589,10 +6594,21 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c) /* If image contains simply transparency data, we prefer to construct a clipping mask. */ - if (png_get_valid (png_ptr, info_ptr, PNG_INFO_tRNS)) - transparent_p = 1; - else - transparent_p = 0; + transparent_p = false; +# ifdef PNG_tRNS_SUPPORTED + png_bytep trans_alpha; + int num_trans; + if (png_get_tRNS (png_ptr, info_ptr, &trans_alpha, &num_trans, NULL) + && trans_alpha) + { + int i; + for (i = 0; i < num_trans; i++) + if (0 < trans_alpha[i] && trans_alpha[i] < 255) + break; + if (! (i < num_trans)) + transparent_p = true; + } +# endif /* This function is easier to write if we only have to handle one data format: RGB or RGBA with 8 bits per channel. Let's @@ -6680,7 +6696,7 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c) /* Create an image and pixmap serving as mask if the PNG image contains an alpha channel. */ if (channels == 4 - && !transparent_p + && transparent_p && !image_create_x_image_and_pixmap (f, img, width, height, 1, &mask_img, 1)) { commit ae7ab3b6ee5237b202d6104aadc2b3f3742f2bf7 Author: Michael Albinus Date: Sun Aug 25 13:44:11 2019 +0200 Fix a further part of Bug#36940 * lisp/net/tramp-sh.el (tramp-perl-file-attributes) (tramp-perl-directory-files-and-attributes) (tramp-do-file-attributes-with-stat) (tramp-do-directory-files-and-attributes-with-stat): Return size and inode as floating number. (Bug#36940). diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index f1f0abc6e5..1f7c8f6e49 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -669,7 +669,7 @@ else $uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\"; $gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; printf( - \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u %%u t %%u -1)\\n\", + \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t %%u.0 -1)\\n\", $type, $stat[3], $uid, @@ -719,7 +719,7 @@ for($i = 0; $i < $n; $i++) $gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; $filename =~ s/\"/\\\\\"/g; printf( - \"(\\\"%%s\\\" %%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t (%%u . %%u) (%%u . %%u))\\n\", + \"(\\\"%%s\\\" %%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t %%u.0 -1)\\n\", $filename, $type, $stat[3], @@ -733,10 +733,7 @@ for($i = 0; $i < $n; $i++) $stat[10] & 0xffff, $stat[7], $stat[2], - $stat[1] >> 16 & 0xffff, - $stat[1] & 0xffff, - $stat[0] >> 16 & 0xffff, - $stat[0] & 0xffff); + $stat[1]); } printf(\")\\n\");' \"$1\" \"$2\" 2>/dev/null" "Perl script implementing `directory-files-attributes' as Lisp `read'able @@ -1356,7 +1353,7 @@ component is used as the target of the symlink." ;; `tramp-stat-marker', in order to make a proper shell escape ;; of them in file names. "( (%s %s || %s -h %s) && (%s -c " - "'((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " + "'((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s.0 %s%%A%s t %%i.0 -1)' " "%s | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g') || echo nil)")) (tramp-get-file-exists-command vec) (tramp-shell-quote-argument localname) @@ -1767,7 +1764,7 @@ of." ;; of them in file names. "cd %s && echo \"(\"; (%s %s -a | " "xargs %s -c " - "'(%s%%n%s (%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " + "'(%s%%n%s (%s%%N%s) %%h %s %s %%X %%Y %%Z %%s.0 %s%%A%s t %%i.0 -1)' " "-- 2>/dev/null | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"")) (tramp-shell-quote-argument localname) (tramp-get-ls-command vec) commit 29d1c72d7c98ea23d5af434c5af6b39a5bd264d9 Author: Alan Mackenzie Date: Sun Aug 25 10:21:37 2019 +0000 Introduce new value t for compilation-context-lines to eliminate scrolling In particular, to prevent scrolling in a window lacking a left fringe. Instead, a visible arrow "=>" is inserted before column zero. This fixes bug #36832. * lisp/progmodes/compile.el (compilation-context-lines): Add the new value t. (compilation-set-window): Amend to handle compilation-context-lines being t. (overlay-arrow-overlay): New variable holding an overlay with before-string property "=>". (compilation-set-overlay-arrow): New function which manipulates overlay-arrow-overlay. (compilation-goto-locus, compilation-find-file): In addition to calling compilation-set-window, also call compilation-set-overlay-arrow. * doc/emacs/building.texi (Compilation Mode): Document the new value t which compilation-context-lines can take. * etc/NEWS: Add an entry for this change. diff --git a/doc/emacs/building.texi b/doc/emacs/building.texi index 990b82d10e..f7809d4aa9 100644 --- a/doc/emacs/building.texi +++ b/doc/emacs/building.texi @@ -266,11 +266,12 @@ fringe (@pxref{Fringes}), the locus-visiting commands put an arrow in the fringe, pointing to the current error message. If the window has no left fringe, such as on a text terminal, these commands scroll the window so that the current message is at the top of the window. If -you change the variable @code{compilation-context-lines} to an integer -value @var{n}, these commands scroll the window so that the current -error message is @var{n} lines from the top, whether or not there is a -fringe; the default value, @code{nil}, gives the behavior described -above. +you change the variable @code{compilation-context-lines} to @code{t}, +a visible arrow is inserted before column zero instead. If you change +the variable to an integer value @var{n}, these commands scroll the +window so that the current error message is @var{n} lines from the +top, whether or not there is a fringe; the default value, @code{nil}, +gives the behavior described above. @vindex compilation-error-regexp-alist @vindex grep-regexp-alist diff --git a/etc/NEWS b/etc/NEWS index 1d98ccab39..a03e2027a9 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -558,6 +558,11 @@ that it doesn't bring any measurable benefit. --- *** In 'compilation-error-regexp-alist', 'line' (and 'end-line') can be functions. ++++ +*** 'compilation-context-lines' can now take the value t; this is like +nil, but instead of scrolling the current line to the top of the +screen when there is no left fringe, it inserts a visible arrow before +column zero. ** cl-lib.el +++ diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 4cc1daf4fa..09188dc14b 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -701,9 +701,8 @@ of `my-compilation-root' here." ;;;###autoload (defcustom compilation-search-path '(nil) "List of directories to search for source files named in error messages. -Elements should be directory names, not file names of -directories. The value nil as an element means the error -message buffer `default-directory'." +Elements should be directory names, not file names of directories. +The value nil as an element means to try the default directory." :type '(repeat (choice (const :tag "Default" nil) (string :tag "Directory")))) @@ -2575,28 +2574,73 @@ region and the first line of the next region." (defcustom compilation-context-lines nil "Display this many lines of leading context before the current message. -If nil and the left fringe is displayed, don't scroll the +If nil or t, and the left fringe is displayed, don't scroll the compilation output window; an arrow in the left fringe points to -the current message. If nil and there is no left fringe, the message -displays at the top of the window; there is no arrow." - :type '(choice integer (const :tag "No window scrolling" nil)) +the current message. With no left fringe, If nil, the message +scrolls to the top of the window; there is no arrow. If t, don't +scroll the compilation output window at all; an arrow before +column zero points to the current message." + :type '(choice integer + (const :tag "Scroll window when no fringe" nil) + (const :tag "No window scrolling" t)) :version "22.1") (defsubst compilation-set-window (w mk) - "Align the compilation output window W with marker MK near top." - (if (integerp compilation-context-lines) - (set-window-start w (save-excursion - (goto-char mk) - (compilation-beginning-of-line - (- 1 compilation-context-lines)) - (point))) + "Maybe align the compilation output window W with marker MK near top." + (cond ((integerp compilation-context-lines) + (set-window-start w (save-excursion + (goto-char mk) + (compilation-beginning-of-line + (- 1 compilation-context-lines)) + (point)))) + ((eq compilation-context-lines t)) ;; If there is no left fringe. - (when (equal (car (window-fringes w)) 0) - (set-window-start w (save-excursion - (goto-char mk) - (beginning-of-line 1) - (point))))) - (set-window-point w mk)) + ((equal (car (window-fringes w)) 0) + (set-window-start w (save-excursion + (goto-char mk) + (beginning-of-line 1) + (point))) + (set-window-point w mk)))) + +(defvar-local overlay-arrow-overlay nil + "Overlay with the before-string property of `overlay-arrow-string'. + +When non-nil, this overlay causes redisplay to display `overlay-arrow-string' +at the overlay's start position.") + +(defun compilation-set-overlay-arrow (w) + "Set up, or switch off, the overlay-arrow for window W." + (with-current-buffer (window-buffer w) + (if (and (eq compilation-context-lines t) + (equal (car (window-fringes w)) 0)) ; No left fringe + ;; Insert a "=>" before-string overlay at the beginning of the + ;; line pointed to by `overlay-arrow-position'. + (cond + ((overlayp overlay-arrow-overlay) + (when (not (eq (overlay-start overlay-arrow-overlay) + overlay-arrow-position)) + (if overlay-arrow-position + (progn + (move-overlay overlay-arrow-overlay + overlay-arrow-position overlay-arrow-position) + (setq overlay-arrow-string "=>") + (overlay-put overlay-arrow-overlay + 'before-string overlay-arrow-string)) + (delete-overlay overlay-arrow-overlay) + (setq overlay-arrow-overlay nil)))) + + (overlay-arrow-position + (setq overlay-arrow-overlay + (make-overlay overlay-arrow-position overlay-arrow-position)) + (setq overlay-arrow-string "=>") + (overlay-put overlay-arrow-overlay 'before-string overlay-arrow-string))) + + ;; `compilation-context-lines' isn't t, or we've got a left + ;; fringe, so remove any overlay arrow. + (when (overlayp overlay-arrow-overlay) + (setq overlay-arrow-string "") + (delete-overlay overlay-arrow-overlay) + (setq overlay-arrow-overlay nil))))) (defvar next-error-highlight-timer) @@ -2618,7 +2662,8 @@ and overlay is highlighted between MK and END-MK." (highlight-regexp (with-current-buffer (marker-buffer msg) ;; also do this while we change buffer (goto-char (marker-position msg)) - (and w (compilation-set-window w msg)) + (and w (progn (compilation-set-window w msg) + (compilation-set-overlay-arrow w))) compilation-highlight-regexp))) ;; Ideally, the window-size should be passed to `display-buffer' ;; so it's only used when creating a new window. @@ -2739,7 +2784,8 @@ attempts to find a file whose name is produced by (format FMT FILENAME)." '(nil (allow-no-window . t)))))) (with-current-buffer (marker-buffer marker) (goto-char marker) - (and w (compilation-set-window w marker))) + (and w (progn (compilation-set-window w marker) + (compilation-set-overlay-arrow w)))) (let* ((name (read-file-name (format "Find this %s in (default %s): " compilation-error filename) commit 50980ba74e0f9f4c85bde446bb6e42e8998d2060 Author: Alex Ott Date: Sun Aug 25 11:33:48 2019 +0200 Fix minor problems in TUTORIAL.ru This fixes wording and avoids visiting the tutorial in Ruby mode. diff --git a/etc/tutorials/TUTORIAL.ru b/etc/tutorials/TUTORIAL.ru index ba3a5c27c5..a9bd90d28b 100644 --- a/etc/tutorials/TUTORIAL.ru +++ b/etc/tutorials/TUTORIAL.ru @@ -985,7 +985,7 @@ Emacs также может создавать множество "фреймо представить все это здесь не представляется возможным. Однако, возможно вы захотите узнать больше о возможностях Emacs. Emacs предоставляет команды для чтения документации о командах Emacs. Все команды "справки" (help) -начинаются с сочетания CONTROL-h, который является "символом справки". +начинаются с сочетания CONTROL-h, которое является "символом справки". Чтобы использовать справку, нажмите C-h, а затем -- символ, который расскажет, какой именно вид справки вы хотите получить. Если вы @@ -1130,5 +1130,6 @@ Copyright (C) 1985, 1996, 1998, 2001-2019 Free Software Foundation, Inc. ;;; Local Variables: ;;; coding: utf-8 ;;; sentence-end-double-space: nil +;;; mode: fundamental ;;; fill-column: 76 ;;; End: commit 543ae99fe8cf21a00087ace878dbec909546476b Author: Eli Zaretskii Date: Sun Aug 25 11:08:11 2019 +0300 Fix a recent change in coding.c This partially reverts the changes in "extern function cleanup". * src/coding.c (encode_string_utf_8, decode_string_utf_8): Now extern again. They should NOT be static, as they are intended to be used by the likes of json.c, where we need highly-optimized code for processing UTF-8 strings. E.g., decode_string_utf_8 beats make_string_from_utf8 by a factor of 2 to 5 in a large number of scenarios. diff --git a/src/coding.c b/src/coding.c index 1c6475828d..c0408fbce4 100644 --- a/src/coding.c +++ b/src/coding.c @@ -9516,10 +9516,6 @@ code_convert_string_norecord (Lisp_Object string, Lisp_Object coding_system, } -/* #define ENABLE_UTF_8_CONVERTER_TEST */ - -#ifdef ENABLE_UTF_8_CONVERTER_TEST - /* Return the gap address of BUFFER. If the gap size is less than NBYTES, enlarge the gap in advance. */ @@ -9622,7 +9618,7 @@ get_char_bytes (int c, int *len) If the two arguments are Qnil, return Qnil if STRING has a non-Unicode character. */ -static Lisp_Object +Lisp_Object encode_string_utf_8 (Lisp_Object string, Lisp_Object buffer, bool nocopy, Lisp_Object handle_8_bit, Lisp_Object handle_over_uni) @@ -9846,7 +9842,10 @@ encode_string_utf_8 (Lisp_Object string, Lisp_Object buffer, If BUFFER is Qnil, return a multibyte string from the decoded result. As a special case, return STRING itself in the following cases: 1. STRING contains only ASCII characters. - 2. NOCOPY, and STRING contains only valid UTF-8 sequences. + 2. NOCOPY is true, and STRING contains only valid UTF-8 sequences. + + For maximum speed, always specify NOCOPY true when STRING is + guaranteed to contain only valid UTF-8 sequences. HANDLE-8-BIT and HANDLE-OVER-UNI specify how to handle a invalid byte sequence. The former is for an 1-byte invalid sequence that @@ -9877,7 +9876,7 @@ encode_string_utf_8 (Lisp_Object string, Lisp_Object buffer, If the two arguments are Qnil, return Qnil if STRING has an invalid sequence. */ -static Lisp_Object +Lisp_Object decode_string_utf_8 (Lisp_Object string, Lisp_Object buffer, bool nocopy, Lisp_Object handle_8_bit, Lisp_Object handle_over_uni) @@ -10115,6 +10114,10 @@ decode_string_utf_8 (Lisp_Object string, Lisp_Object buffer, return val; } +/* #define ENABLE_UTF_8_CONVERTER_TEST */ + +#ifdef ENABLE_UTF_8_CONVERTER_TEST + /* These functions are useful for testing and benchmarking encode_string_utf_8 and decode_string_utf_8. */ diff --git a/src/coding.h b/src/coding.h index 70690d42d3..8efddbf55c 100644 --- a/src/coding.h +++ b/src/coding.h @@ -689,6 +689,10 @@ extern Lisp_Object code_convert_string (Lisp_Object, Lisp_Object, Lisp_Object, bool, bool, bool); extern Lisp_Object code_convert_string_norecord (Lisp_Object, Lisp_Object, bool); +extern Lisp_Object encode_string_utf_8 (Lisp_Object, Lisp_Object, bool, + Lisp_Object, Lisp_Object); +extern Lisp_Object decode_string_utf_8 (Lisp_Object, Lisp_Object, bool, + Lisp_Object, Lisp_Object); extern Lisp_Object encode_file_name (Lisp_Object); extern Lisp_Object decode_file_name (Lisp_Object); extern Lisp_Object raw_text_coding_system (Lisp_Object); commit 26703b98f93ff6e0819e43b872bfe63f8753dfcb Author: Eli Zaretskii Date: Sun Aug 25 10:10:01 2019 +0300 ; Improve a recent change. * src/frame.c (Fx_parse_geometry): Improve the comment about non-initialization of some locals. diff --git a/src/frame.c b/src/frame.c index cf38c85f09..1d42d0cb4d 100644 --- a/src/frame.c +++ b/src/frame.c @@ -5328,7 +5328,8 @@ On Nextstep, this just calls `ns-parse-geometry'. */) (Lisp_Object string) { /* x and y don't need initialization, as they are not accessed - unless XParseGeometry sets them. */ + unless XParseGeometry sets them, in which case it always returns + a non-zero value. */ int x UNINIT, y UNINIT; unsigned int width, height; commit 9b10ec066000c198f01981ff6f259b7826b3eeed Author: Lars Ingebrigtsen Date: Sun Aug 25 08:12:17 2019 +0200 Use ' instead of ` in NEWS diff --git a/etc/NEWS b/etc/NEWS index ec906aaf02..1d98ccab39 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -516,14 +516,14 @@ current and the previous or the next line, as before. acinclude.m4/aclocal.m4/acsite.m4 files. --- -** On GNU/Linux, `M-x battery' will now list all batteries, no matter -what they're named, and the `battery-linux-sysfs-regexp' variable has +** On GNU/Linux, 'M-x battery' will now list all batteries, no matter +what they're named, and the 'battery-linux-sysfs-regexp' variable has been removed. ** The 'list-processes' command now includes port numbers in the network connection information (in addition to the host name). -** The 'cl' package is now officially deprecated in favor of `cl-lib`. +** The 'cl' package is now officially deprecated in favor of 'cl-lib'. +++ ** winner commit 9459c4c17c3338298e88a0af4be1798674bdb6ef Author: Lars Ingebrigtsen Date: Sun Aug 25 08:11:58 2019 +0200 Use `autoconf-mode' for Autoconf .m4 files * lisp/files.el (auto-mode-alist): Use `autoconf-mode' (instead of `m4-mode') for acinclude.m4/aclocal.m4/acsite.m4 files (bug#37133). diff --git a/etc/NEWS b/etc/NEWS index cf187598ce..ec906aaf02 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -511,6 +511,10 @@ current and the previous or the next line, as before. * Changes in Specialized Modes and Packages in Emacs 27.1 +--- +** 'autoconf-mode' is now used instead of 'm4-mode' for the +acinclude.m4/aclocal.m4/acsite.m4 files. + --- ** On GNU/Linux, `M-x battery' will now list all batteries, no matter what they're named, and the `battery-linux-sysfs-regexp' variable has diff --git a/lisp/files.el b/lisp/files.el index f76635017d..2a84c2c48f 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -2719,6 +2719,8 @@ since only a single case-insensitive search through the alist is made." ("\\.bib\\'" . bibtex-mode) ("\\.bst\\'" . bibtex-style-mode) ("\\.sql\\'" . sql-mode) + ;; These .m4 files are Autoconf files. + ("\\(acinclude\\|aclocal\\|acsite\\)\\.m4\\'" . autoconf-mode) ("\\.m[4c]\\'" . m4-mode) ("\\.mf\\'" . metafont-mode) ("\\.mp\\'" . metapost-mode) commit 16cae184c13f03515f1883555f4e22a541b0cc32 Author: Alex Branham Date: Sun Aug 25 08:05:48 2019 +0200 The `gnus*-1' functions shouldn't be interactive * lisp/gnus/gnus-start.el (gnus-no-server-1): This function shouldn't be interactive (bug#37022). (gnus-1): Ditto. diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index 930d522c41..e8775c6667 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -738,7 +738,6 @@ level. If ARG is nil, Gnus will be started at level 2 and not a positive number, Gnus will prompt the user for the name of an NNTP server to use. As opposed to \\[gnus], this command will not connect to the local server." - (interactive "P") (let ((val (or arg (1- gnus-level-default-subscribed)))) (gnus val t slave) (make-local-variable 'gnus-group-use-permanent-levels) @@ -749,8 +748,6 @@ will not connect to the local server." If ARG is non-nil and a positive number, Gnus will use that as the startup level. If ARG is non-nil and not a positive number, Gnus will prompt the user for the name of an NNTP server to use." - (interactive "P") - (if (gnus-alive-p) (progn (gnus-run-hooks 'gnus-before-resume-hook) commit 2e6e250521f5076bfa1afb32c24d0075d34b4c53 Author: Lars Ingebrigtsen Date: Sun Aug 25 07:57:30 2019 +0200 Disallow just hitting RET in gnus-mime-replace-part * lisp/gnus/gnus-art.el (gnus-mime-replace-part): Don't replace the part if the file to replace it with doesn't exist (bug#36864). diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 930b0a0510..04cb087737 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -5059,7 +5059,10 @@ and `gnus-mime-delete-part', and not provided at run-time normally." (list (read-file-name "Replace MIME part with file: " (or mm-default-directory default-directory) - nil nil))) + nil t))) + (unless (file-regular-p (file-truename file)) + (error "Can't replace part with %s, which isn't a regular file" + file)) (gnus-mime-save-part-and-strip file)) (defun gnus-mime-save-part-and-strip (&optional file) commit 84f1674ee8cbd83ea219595e9adec2d148946976 Author: Paul Eggert Date: Sat Aug 24 17:46:21 2019 -0700 Clarify Fx_parse_geometry initialization * src/frame.c (Fx_parse_geometry): Clarify why local init isn’t needed. diff --git a/src/frame.c b/src/frame.c index 330f98aee1..cf38c85f09 100644 --- a/src/frame.c +++ b/src/frame.c @@ -5327,9 +5327,10 @@ or a list (- N) meaning -N pixels relative to bottom/right corner. On Nextstep, this just calls `ns-parse-geometry'. */) (Lisp_Object string) { - int geometry, x UNINIT, y UNINIT; + /* x and y don't need initialization, as they are not accessed + unless XParseGeometry sets them. */ + int x UNINIT, y UNINIT; unsigned int width, height; - Lisp_Object result; CHECK_STRING (string); @@ -5337,9 +5338,9 @@ On Nextstep, this just calls `ns-parse-geometry'. */) if (strchr (SSDATA (string), ' ') != NULL) return call1 (Qns_parse_geometry, string); #endif - geometry = XParseGeometry (SSDATA (string), - &x, &y, &width, &height); - result = Qnil; + int geometry = XParseGeometry (SSDATA (string), + &x, &y, &width, &height); + Lisp_Object result = Qnil; if (geometry & XValue) { Lisp_Object element; commit 63906ab4877b0f93e806a1a0b3b92ba8c8c67398 Author: Paul Eggert Date: Sat Aug 24 15:40:55 2019 -0700 Tweak time arithmetic performance * src/timefns.c (time_arith): Prefer mpz_divexact to mpz_tdiv_q when either will do. diff --git a/src/timefns.c b/src/timefns.c index 6c9473f22a..c1e3141c4c 100644 --- a/src/timefns.c +++ b/src/timefns.c @@ -1105,8 +1105,8 @@ time_arith (Lisp_Object a, Lisp_Object b, bool subtract) /* fa = da/g, fb = db/g. */ mpz_t *fa = &mpz[4], *fb = &mpz[3]; - mpz_tdiv_q (*fa, *da, *g); - mpz_tdiv_q (*fb, *db, *g); + mpz_divexact (*fa, *da, *g); + mpz_divexact (*fb, *db, *g); /* ihz = fa * db. This is equal to lcm (da, db). */ mpz_t *ihz = &mpz[0]; @@ -1149,8 +1149,8 @@ time_arith (Lisp_Object a, Lisp_Object b, bool subtract) if (!FASTER_TIMEFNS || mpz_cmp_ui (*ig, 1) > 0) { - mpz_tdiv_q (*iticks, *iticks, *ig); - mpz_tdiv_q (*ihz, *ihz, *ig); + mpz_divexact (*iticks, *iticks, *ig); + mpz_divexact (*ihz, *ihz, *ig); if (!FASTER_TIMEFNS || mpz_cmp (*ihz, *hzmin) < 0) { commit a050cf80f38e6b9b33745bc62b50dab43cac7a3a Author: Paul Eggert Date: Sat Aug 24 15:46:31 2019 -0700 Speed up % and mod with fixnum denom * src/data.c (integer_remainder): New function. When the numerator is a bignum and the denominator is small, this function uses mpz_tdiv_ui, which should be faster than mpz_tdiv_r. (Frem, Fmod): Use it. diff --git a/src/data.c b/src/data.c index cb25fce014..1d9222e75a 100644 --- a/src/data.c +++ b/src/data.c @@ -3055,58 +3055,67 @@ usage: (/ NUMBER &rest DIVISORS) */) return arith_driver (Adiv, nargs, args, a); } -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) -{ - CHECK_INTEGER_COERCE_MARKER (x); - CHECK_INTEGER_COERCE_MARKER (y); - - /* A bignum can never be 0, so don't check that case. */ - if (EQ (y, make_fixnum (0))) - xsignal0 (Qarith_error); - - if (FIXNUMP (x) && FIXNUMP (y)) - return make_fixnum (XFIXNUM (x) % XFIXNUM (y)); - else - { - mpz_tdiv_r (mpz[0], - *bignum_integer (&mpz[0], x), - *bignum_integer (&mpz[1], y)); - return make_integer_mpz (); - } -} - -/* Return X mod Y. Both must be integers and Y must be nonzero. */ +/* Return NUM % DEN (or NUM mod DEN, if MODULO). NUM and DEN must be + integers. */ static Lisp_Object -integer_mod (Lisp_Object x, Lisp_Object y) +integer_remainder (Lisp_Object num, Lisp_Object den, bool modulo) { - if (FIXNUMP (x) && FIXNUMP (y)) + if (FIXNUMP (den)) { - EMACS_INT i1 = XFIXNUM (x), i2 = XFIXNUM (y); + EMACS_INT d = XFIXNUM (den); + if (d == 0) + xsignal0 (Qarith_error); - i1 %= i2; + EMACS_INT r; + bool have_r = false; + if (FIXNUMP (num)) + { + r = XFIXNUM (num) % d; + have_r = true; + } + else if (eabs (d) <= ULONG_MAX) + { + mpz_t const *n = xbignum_val (num); + bool neg_n = mpz_sgn (*n) < 0; + r = mpz_tdiv_ui (*n, eabs (d)); + if (neg_n) + r = -r; + have_r = true; + } - /* If the "remainder" comes out with the wrong sign, fix it. */ - if (i2 < 0 ? i1 > 0 : i1 < 0) - i1 += i2; + if (have_r) + { + /* If MODULO and the remainder has the wrong sign, fix it. */ + if (modulo && (d < 0 ? r > 0 : r < 0)) + r += d; - return make_fixnum (i1); + return make_fixnum (r); + } } - else - { - mpz_t const *ym = bignum_integer (&mpz[1], y); - bool neg_y = mpz_sgn (*ym) < 0; - mpz_tdiv_r (mpz[0], *bignum_integer (&mpz[0], x), *ym); - /* Fix the sign if needed. */ - int sgn_r = mpz_sgn (mpz[0]); - if (neg_y ? sgn_r > 0 : sgn_r < 0) - mpz_add (mpz[0], mpz[0], *ym); + mpz_t const *d = bignum_integer (&mpz[1], den); + mpz_t *r = &mpz[0]; + mpz_tdiv_r (*r, *bignum_integer (&mpz[0], num), *d); - return make_integer_mpz (); + if (modulo) + { + /* If the remainder has the wrong sign, fix it. */ + int sgn_r = mpz_sgn (*r); + if (mpz_sgn (*d) < 0 ? sgn_r > 0 : sgn_r < 0) + mpz_add (*r, *r, *d); } + + return make_integer_mpz (); +} + +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) +{ + CHECK_INTEGER_COERCE_MARKER (x); + CHECK_INTEGER_COERCE_MARKER (y); + return integer_remainder (x, y, false); } DEFUN ("mod", Fmod, Smod, 2, 2, 0, @@ -3119,12 +3128,7 @@ Both X and Y must be numbers or markers. */) CHECK_NUMBER_COERCE_MARKER (y); if (FLOATP (x) || FLOATP (y)) return fmod_float (x, y); - - /* A bignum can never be 0, so don't check that case. */ - if (EQ (y, make_fixnum (0))) - xsignal0 (Qarith_error); - - return integer_mod (x, y); + return integer_remainder (x, y, true); } static Lisp_Object commit 2f7ca4020e4f1e30b263758439dba55551f0675d Author: Paul Eggert Date: Sat Aug 24 12:45:36 2019 -0700 Tweak integer mod performance * src/data.c (integer_mod): Use mpz_tdiv_r not mpz_mod, as that’s more similar to the fixnum case, is a bit more efficient, and otherwise the later ‘sgn_r < 0’ code is useless anyway. diff --git a/src/data.c b/src/data.c index dfc8a892f5..cb25fce014 100644 --- a/src/data.c +++ b/src/data.c @@ -3098,7 +3098,7 @@ integer_mod (Lisp_Object x, Lisp_Object y) { mpz_t const *ym = bignum_integer (&mpz[1], y); bool neg_y = mpz_sgn (*ym) < 0; - mpz_mod (mpz[0], *bignum_integer (&mpz[0], x), *ym); + mpz_tdiv_r (mpz[0], *bignum_integer (&mpz[0], x), *ym); /* Fix the sign if needed. */ int sgn_r = mpz_sgn (mpz[0]); commit 575179f74d9b80ee468ae39239c853546da8de43 Author: Paul Eggert Date: Sat Aug 24 12:43:50 2019 -0700 Make (mod 1.0 0) consistent with (/ 1.0 0) * src/data.c (Fmod): Do not signal an error for (mod 1.0 0), for the same reason (/ 1.0 0) does not signal an error. * test/src/data-tests.el (data-tests-mod-0): New test. diff --git a/src/data.c b/src/data.c index 38968359a5..dfc8a892f5 100644 --- a/src/data.c +++ b/src/data.c @@ -3117,12 +3117,14 @@ Both X and Y must be numbers or markers. */) { CHECK_NUMBER_COERCE_MARKER (x); CHECK_NUMBER_COERCE_MARKER (y); + if (FLOATP (x) || FLOATP (y)) + return fmod_float (x, y); /* A bignum can never be 0, so don't check that case. */ if (EQ (y, make_fixnum (0))) xsignal0 (Qarith_error); - return (FLOATP (x) || FLOATP (y) ? fmod_float : integer_mod) (x, y); + return integer_mod (x, y); } static Lisp_Object diff --git a/test/src/data-tests.el b/test/src/data-tests.el index a9d48e29a8..3a7462b6ad 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -653,6 +653,13 @@ comparing the subr with a much slower lisp implementation." (data-tests-check-sign (% -1 -3) (% nb1 nb3)) (data-tests-check-sign (mod -1 -3) (mod nb1 nb3)))) +(ert-deftest data-tests-mod-0 () + (dolist (num (list (1- most-negative-fixnum) -1 0 1 + (1+ most-positive-fixnum))) + (should-error (mod num 0))) + (when (ignore-errors (/ 0.0 0)) + (should (equal (abs (mod 0.0 0)) (abs (- 0.0 (/ 0.0 0))))))) + (ert-deftest data-tests-ash-lsh () (should (= (ash most-negative-fixnum 1) (* most-negative-fixnum 2))) commit b62eac0f870754bc75b1162246f9901a04910044 Author: Paul Eggert Date: Sat Aug 24 11:42:28 2019 -0700 extern function cleanup Most of these functions can be static. A few are unused. * src/coding.c (encode_string_utf_8, decode_string_utf_8): Define only if ENABLE_UTF_8_CONVERTER_TEST, as they're not needed otherwise. * src/coding.c (encode_string_utf_8, decode_string_utf_8): * src/data.c (integer_mod): * src/fns.c (base64_encode_region_1, base64_encode_string_1): * src/ftfont.c (ftfont_get_fc_charset): Now static. * src/sysdep.c (verrprintf): Remove; unused. diff --git a/src/coding.c b/src/coding.c index 2ddd34eb7b..1c6475828d 100644 --- a/src/coding.c +++ b/src/coding.c @@ -9516,6 +9516,10 @@ code_convert_string_norecord (Lisp_Object string, Lisp_Object coding_system, } +/* #define ENABLE_UTF_8_CONVERTER_TEST */ + +#ifdef ENABLE_UTF_8_CONVERTER_TEST + /* Return the gap address of BUFFER. If the gap size is less than NBYTES, enlarge the gap in advance. */ @@ -9618,7 +9622,7 @@ get_char_bytes (int c, int *len) If the two arguments are Qnil, return Qnil if STRING has a non-Unicode character. */ -Lisp_Object +static Lisp_Object encode_string_utf_8 (Lisp_Object string, Lisp_Object buffer, bool nocopy, Lisp_Object handle_8_bit, Lisp_Object handle_over_uni) @@ -9873,7 +9877,7 @@ encode_string_utf_8 (Lisp_Object string, Lisp_Object buffer, If the two arguments are Qnil, return Qnil if STRING has an invalid sequence. */ -Lisp_Object +static Lisp_Object decode_string_utf_8 (Lisp_Object string, Lisp_Object buffer, bool nocopy, Lisp_Object handle_8_bit, Lisp_Object handle_over_uni) @@ -10111,10 +10115,6 @@ decode_string_utf_8 (Lisp_Object string, Lisp_Object buffer, return val; } -/* #define ENABLE_UTF_8_CONVERTER_TEST */ - -#ifdef ENABLE_UTF_8_CONVERTER_TEST - /* These functions are useful for testing and benchmarking encode_string_utf_8 and decode_string_utf_8. */ diff --git a/src/coding.h b/src/coding.h index 8efddbf55c..70690d42d3 100644 --- a/src/coding.h +++ b/src/coding.h @@ -689,10 +689,6 @@ extern Lisp_Object code_convert_string (Lisp_Object, Lisp_Object, Lisp_Object, bool, bool, bool); extern Lisp_Object code_convert_string_norecord (Lisp_Object, Lisp_Object, bool); -extern Lisp_Object encode_string_utf_8 (Lisp_Object, Lisp_Object, bool, - Lisp_Object, Lisp_Object); -extern Lisp_Object decode_string_utf_8 (Lisp_Object, Lisp_Object, bool, - Lisp_Object, Lisp_Object); extern Lisp_Object encode_file_name (Lisp_Object); extern Lisp_Object decode_file_name (Lisp_Object); extern Lisp_Object raw_text_coding_system (Lisp_Object); diff --git a/src/data.c b/src/data.c index 2797adfcdc..38968359a5 100644 --- a/src/data.c +++ b/src/data.c @@ -3079,7 +3079,7 @@ Both must be integers or markers. */) } /* Return X mod Y. Both must be integers and Y must be nonzero. */ -Lisp_Object +static Lisp_Object integer_mod (Lisp_Object x, Lisp_Object y) { if (FIXNUMP (x) && FIXNUMP (y)) diff --git a/src/fns.c b/src/fns.c index 4fb33500bf..df921e28f3 100644 --- a/src/fns.c +++ b/src/fns.c @@ -3280,11 +3280,11 @@ static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool, static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool, bool, ptrdiff_t *); -Lisp_Object base64_encode_region_1 (Lisp_Object, Lisp_Object, bool, - bool, bool); +static Lisp_Object base64_encode_region_1 (Lisp_Object, Lisp_Object, bool, + bool, bool); -Lisp_Object base64_encode_string_1(Lisp_Object, bool, - bool, bool); +static Lisp_Object base64_encode_string_1 (Lisp_Object, bool, + bool, bool); DEFUN ("base64-encode-region", Fbase64_encode_region, Sbase64_encode_region, @@ -3295,7 +3295,7 @@ Optional third argument NO-LINE-BREAK means do not break long lines into shorter lines. */) (Lisp_Object beg, Lisp_Object end, Lisp_Object no_line_break) { - return base64_encode_region_1(beg, end, NILP (no_line_break), true, false); + return base64_encode_region_1 (beg, end, NILP (no_line_break), true, false); } @@ -3308,10 +3308,10 @@ Optional second argument NO-PAD means do not add padding char =. This produces the URL variant of base 64 encoding defined in RFC 4648. */) (Lisp_Object beg, Lisp_Object end, Lisp_Object no_pad) { - return base64_encode_region_1(beg, end, false, NILP(no_pad), true); + return base64_encode_region_1 (beg, end, false, NILP(no_pad), true); } -Lisp_Object +static Lisp_Object base64_encode_region_1 (Lisp_Object beg, Lisp_Object end, bool line_break, bool pad, bool base64url) { @@ -3376,11 +3376,11 @@ into shorter lines. */) (Lisp_Object string, Lisp_Object no_line_break) { - return base64_encode_string_1(string, NILP (no_line_break), true, false); + return base64_encode_string_1 (string, NILP (no_line_break), true, false); } -DEFUN ("base64url-encode-string", Fbase64url_encode_string, Sbase64url_encode_string, - 1, 2, 0, +DEFUN ("base64url-encode-string", Fbase64url_encode_string, + Sbase64url_encode_string, 1, 2, 0, doc: /* Base64url-encode STRING and return the result. Optional second argument NO-PAD means do not add padding char =. @@ -3388,12 +3388,12 @@ This produces the URL variant of base 64 encoding defined in RFC 4648. */) (Lisp_Object string, Lisp_Object no_pad) { - return base64_encode_string_1(string, false, NILP(no_pad), true); + return base64_encode_string_1 (string, false, NILP(no_pad), true); } -Lisp_Object -base64_encode_string_1(Lisp_Object string, bool line_break, - bool pad, bool base64url) +static Lisp_Object +base64_encode_string_1 (Lisp_Object string, bool line_break, + bool pad, bool base64url) { ptrdiff_t allength, length, encoded_length; char *encoded; @@ -3510,9 +3510,7 @@ base64_encode_1 (const char *from, char *to, ptrdiff_t length, { *e++ = b64_value_to_char[value]; if (pad) - { - *e++ = '='; - } + *e++ = '='; break; } diff --git a/src/ftfont.c b/src/ftfont.c index 16b18de686..77a4cf5de5 100644 --- a/src/ftfont.c +++ b/src/ftfont.c @@ -433,7 +433,7 @@ ftfont_lookup_cache (Lisp_Object key, enum ftfont_cache_for cache_for) return cache; } -FcCharSet * +static FcCharSet * ftfont_get_fc_charset (Lisp_Object entity) { Lisp_Object val, cache; diff --git a/src/ftfont.h b/src/ftfont.h index b2280e9aab..f771dc159b 100644 --- a/src/ftfont.h +++ b/src/ftfont.h @@ -41,7 +41,6 @@ along with GNU Emacs. If not, see . */ #endif /* HAVE_M17N_FLT */ #endif /* HAVE_LIBOTF */ -extern FcCharSet *ftfont_get_fc_charset (Lisp_Object); extern void ftfont_fix_match (FcPattern *, FcPattern *); extern void ftfont_add_rendering_parameters (FcPattern *, Lisp_Object); extern FcPattern *ftfont_entity_pattern (Lisp_Object, int); diff --git a/src/lisp.h b/src/lisp.h index ae5a81e7b5..a7b19ab576 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3615,7 +3615,6 @@ extern void set_default_internal (Lisp_Object, Lisp_Object, extern Lisp_Object expt_integer (Lisp_Object, Lisp_Object); extern void syms_of_data (void); extern void swap_in_global_binding (struct Lisp_Symbol *); -extern Lisp_Object integer_mod (Lisp_Object, Lisp_Object); /* Defined in cmds.c */ extern void syms_of_cmds (void); diff --git a/src/sysdep.c b/src/sysdep.c index f7478253a3..aa18ee22fd 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -2809,12 +2809,6 @@ errputc (int c) fputc_unlocked (c, errstream ()); } -void -verrprintf (char const *fmt, va_list ap) -{ - vfprintf (errstream (), fmt, ap); -} - void errwrite (void const *buf, ptrdiff_t nbuf) { diff --git a/src/sysstdio.h b/src/sysstdio.h index f402bd633d..1e1180a4d3 100644 --- a/src/sysstdio.h +++ b/src/sysstdio.h @@ -28,7 +28,6 @@ along with GNU Emacs. If not, see . */ extern FILE *emacs_fopen (char const *, char const *); extern void errputc (int); -extern void verrprintf (char const *, va_list) ATTRIBUTE_FORMAT_PRINTF (1, 0); extern void errwrite (void const *, ptrdiff_t); extern void close_output_streams (void); commit aa49aa884053d0e8b33efe265f2aade19d1f3f3d Author: Noam Postavsky Date: Thu Aug 22 20:48:19 2019 -0400 Fix non-deterministic process test * test/src/process-tests.el (set-process-filter-t): Don't assume subprocess output will come in a single chunk, keep waiting for more data until next "prompt" is read from subprocess. diff --git a/test/src/process-tests.el b/test/src/process-tests.el index 82eeee1150..158c036aaa 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -155,24 +155,30 @@ (concat invocation-directory invocation-name) "-Q" "--batch" "--eval" (prin1-to-string - '(let (s) - (while (setq s (read-from-minibuffer "$ ")) + '(let ((s nil) (count 0)) + (while (setq s (read-from-minibuffer + (format "%d> " count))) (princ s) - (princ "\n"))))))) + (princ "\n") + (setq count (1+ count)))))))) (set-process-query-on-exit-flag proc nil) (send-string proc "one\n") - (should - (accept-process-output proc 1)) ; Read "one". - (should (equal (buffer-string) "$ one\n$ ")) + (while (not (equal (buffer-substring + (line-beginning-position) (point-max)) + "1> ")) + (accept-process-output proc)) ; Read "one". + (should (equal (buffer-string) "0> one\n1> ")) (set-process-filter proc t) ; Stop reading from proc. (send-string proc "two\n") (should-not (accept-process-output proc 1)) ; Can't read "two" yet. - (should (equal (buffer-string) "$ one\n$ ")) + (should (equal (buffer-string) "0> one\n1> ")) (set-process-filter proc nil) ; Resume reading from proc. - (should - (accept-process-output proc 1)) ; Read "two" from proc. - (should (equal (buffer-string) "$ one\n$ two\n$ "))))) + (while (not (equal (buffer-substring + (line-beginning-position) (point-max)) + "2> ")) + (accept-process-output proc)) ; Read "Two". + (should (equal (buffer-string) "0> one\n1> two\n2> "))))) (ert-deftest start-process-should-not-modify-arguments () "`start-process' must not modify its arguments in-place." commit e2efcabdc6f4a07acfc9b6c143eb4469ec26ac02 Merge: 6d70161de6 649fb17443 Author: Eli Zaretskii Date: Sat Aug 24 16:46:00 2019 +0300 Merge branch 'master' of git.savannah.gnu.org:/srv/git/emacs commit 6d70161de6f675a1cf8257da231845189ce19793 Author: Eli Zaretskii Date: Sat Aug 24 16:45:10 2019 +0300 Revert "Recompute user-emacs-directory-relative defcustoms one more time" This reverts commit bb5cd7c4caf415e40836edbbc4e62b0dd411d73f. See bug#37173. diff --git a/lisp/startup.el b/lisp/startup.el index ff90646d7a..564428580b 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -406,7 +406,6 @@ if you have not already set `auto-save-list-file-name' yourself. Directories in the prefix will be created if necessary. Set this to nil if you want to prevent `auto-save-list-file-name' from being initialized." - :initialize 'custom-initialize-delay :type '(choice (const :tag "Don't record a session's auto save list" nil) string) :group 'auto-save) @@ -1283,7 +1282,8 @@ please check its value") ;; depends on the runtime context, in case some of them depend on ;; the window-system features. Example: blink-cursor-mode. (let (current-load-list) ; c-r-s may call defvar, and hence LOADHIST_ATTACH - (mapc 'custom-reevaluate-setting custom-delayed-init-variables)) + (mapc 'custom-reevaluate-setting custom-delayed-init-variables) + (setq custom-delayed-init-variables nil)) (normal-erase-is-backspace-setup-frame) @@ -1377,14 +1377,6 @@ please check its value") (eq face-ignored-fonts old-face-ignored-fonts)) (clear-face-cache))) - ;; Re-evaluate again the predefined variables whose initial value - ;; depends on the runtime context, in case the user init file - ;; modified user-emacs-directory. Examples: abbrev-file-name, - ;; auto-save-list-file-prefix. - (let (current-load-list) ; c-r-s may call defvar, and hence LOADHIST_ATTACH - (mapc 'custom-reevaluate-setting custom-delayed-init-variables) - (setq custom-delayed-init-variables nil)) - (setq after-init-time (current-time)) ;; Display any accumulated warnings after all functions in ;; `after-init-hook' like `desktop-read' have finalized possible commit 649fb174431fd030c4bef563af79fe65c5fbf979 Author: Robert Pluim Date: Sat Aug 24 14:54:02 2019 +0200 Fix DNS tests * test/src/process-tests.el: (lookup-family-specification, lookup-unicode-domains, unibyte-domain-name, lookup-google, non-existent-lookup-failure): Skip on Hydra, which doesn't have DNS. Fix buggy test condition. (Bug#37165) diff --git a/test/src/process-tests.el b/test/src/process-tests.el index 724da1c3e7..82eeee1150 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -323,31 +323,39 @@ See Bug#30460." invocation-directory)) :stop t))) +;; All the following tests require working DNS, which appears not to +;; be the case for hydra.nixos.org, so disable them there for now. + (ert-deftest lookup-family-specification () "network-lookup-address-info should only accept valid family symbols." + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) (should-error (network-lookup-address-info "google.com" 'both)) (should (network-lookup-address-info "google.com" 'ipv4)) (should (network-lookup-address-info "google.com" 'ipv6))) (ert-deftest lookup-unicode-domains () "Unicode domains should fail" + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) (should-error (network-lookup-address-info "faß.de")) - (should (length (network-lookup-address-info (puny-encode-domain "faß.de"))))) + (should (network-lookup-address-info (puny-encode-domain "faß.de")))) (ert-deftest unibyte-domain-name () "Unibyte domain names should work" - (should (length (network-lookup-address-info (string-to-unibyte "google.com"))))) + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) + (should (network-lookup-address-info (string-to-unibyte "google.com")))) (ert-deftest lookup-google () "Check that we can look up google IP addresses" + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) (let ((addresses-both (network-lookup-address-info "google.com")) (addresses-v4 (network-lookup-address-info "google.com" 'ipv4)) (addresses-v6 (network-lookup-address-info "google.com" 'ipv6))) - (should (length addresses-both)) - (should (length addresses-v4)) - (should (length addresses-v6)))) + (should addresses-both) + (should addresses-v4) + (should addresses-v6))) (ert-deftest non-existent-lookup-failure () + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) "Check that looking up non-existent domain returns nil" (should (eq nil (network-lookup-address-info "emacs.invalid")))) commit 42f8fa80706ee34bba98a922e2f42edcfe474bc9 Author: Michael Albinus Date: Sat Aug 24 10:10:05 2019 +0200 Fix some problems of Bug#36940 * test/lisp/net/tramp-tests.el (tramp-test22-file-times): Do not compare time value lists by `equal'. (Bug#36940). (tramp-test30-make-process): Adapt "kill" message to match on macOS. diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 180f746c64..557536a0eb 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -3533,9 +3533,10 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (file-attributes tmp-name1)) tramp-time-dont-know) (should - (equal (tramp-compat-file-attribute-modification-time - (file-attributes tmp-name1)) - (seconds-to-time 1))) + (tramp-compat-time-equal-p + (tramp-compat-file-attribute-modification-time + (file-attributes tmp-name1)) + (seconds-to-time 1))) (write-region "bla" nil tmp-name2) (should (file-exists-p tmp-name2)) (should (file-newer-than-file-p tmp-name2 tmp-name1)) @@ -4182,8 +4183,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (with-timeout (10 (tramp--test-timeout-handler)) (while (accept-process-output proc 0 nil t))) ;; We cannot use `string-equal', because tramp-adb.el - ;; echoes also the sent string. - (should (string-match "killed\n\\'" (buffer-string)))) + ;; echoes also the sent string. And a remote macOS sends + ;; a slightly modified string. + (should (string-match "killed.*\n\\'" (buffer-string)))) ;; Cleanup. (ignore-errors (delete-process proc))) commit 80376945952943888bb34c7d4ea06972e422eca7 Author: Paul Eggert Date: Fri Aug 23 11:50:40 2019 -0700 Tweak gnutls-peer-status reporting * src/gnutls.c (Fgnutls_peer_status): Report :compression and :encrypt-then-mac only if the underlying GnuTLS library has the corresponding features. This give the Elisp caller a bit more information about the peer status. * lisp/net/nsm.el (nsm-protocol-check--compression): Don’t worry about compression in newer GnuTLS versions that do not support compression. diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index ed700bc9b5..5e8381075b 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -692,7 +692,8 @@ Sheffer, Holz, Saint-Andre (May 2015). \"Recommendations for Secure Use of Transport Layer Security (TLS) and Datagram Transport Layer Security (DTLS)\", `https://tools.ietf.org/html/rfc7525'" (let ((compression (plist-get status :compression))) - (and (string-match "^\\bDEFLATE\\b" compression) + (and compression + (string-match "^\\bDEFLATE\\b" compression) (format-message "compression method (%s) may lead to leakage of sensitive information" compression)))) diff --git a/src/gnutls.c b/src/gnutls.c index 51536b1463..a7ef59ab91 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -1493,20 +1493,18 @@ returned as the :certificate entry. */) /* Compression name. */ #ifdef HAVE_GNUTLS_COMPRESSION_GET - Lisp_Object compression = build_string (gnutls_compression_get_name - (gnutls_compression_get (state))); -#else - Lisp_Object compression = build_string ("NULL"); + result = nconc2 + (result, list2 (intern (":compression"), + build_string (gnutls_compression_get_name + (gnutls_compression_get (state))))); #endif - result = nconc2 (result, list2 (intern (":compression"), compression)); /* Encrypt-then-MAC. */ - Lisp_Object etm_status = Qnil; #ifdef HAVE_GNUTLS_ETM_STATUS - if (gnutls_session_etm_status (state)) - etm_status = Qt; + result = nconc2 + (result, list2 (intern (":encrypt-then-mac"), + gnutls_session_etm_status (state) ? Qt : Qnil)); #endif - result = nconc2 (result, list2 (intern (":encrypt-then-mac"), etm_status)); /* Renegotiation Indication */ result = nconc2 commit c5210fd00af7c3e261a52864e799e16ed6a1b165 Author: Lars Ingebrigtsen Date: Fri Aug 23 20:42:45 2019 +0200 Mention new usage of `invalid-read-syntax' in the manual * doc/lispref/errors.texi (Standard Errors): Document "trailing garbage" use of `invalid-read-syntax' (bug#24649). diff --git a/doc/lispref/errors.texi b/doc/lispref/errors.texi index aa99b2b1a9..b25fb99399 100644 --- a/doc/lispref/errors.texi +++ b/doc/lispref/errors.texi @@ -140,8 +140,10 @@ emacs, The GNU Emacs Manual}. The message is @samp{Invalid function}. @xref{Function Indirection}. @item invalid-read-syntax -The message is @samp{Invalid read syntax}. @xref{Printed -Representation}. +The message is usually @samp{Invalid read syntax}. @xref{Printed +Representation}. This error can also be raised by commands like +@code{eval-expression} when there's text following an expression. In +that case, the message is @samp{Trailing garbage following expression}. @item invalid-regexp The message is @samp{Invalid regexp}. @xref{Regular Expressions}. commit 6cd567878443dd5fb9c3910de3a8e67acb5962b4 Author: Paul Eggert Date: Fri Aug 23 11:17:38 2019 -0700 Clarify compiler-pacifier in frame.c * src/frame.c (Fx_parse_geometry): Pacify the compiler in a different way, so that the human reader can more easily see that the initializations are unnecessary. diff --git a/src/frame.c b/src/frame.c index 8ee8e4203f..330f98aee1 100644 --- a/src/frame.c +++ b/src/frame.c @@ -5327,7 +5327,7 @@ or a list (- N) meaning -N pixels relative to bottom/right corner. On Nextstep, this just calls `ns-parse-geometry'. */) (Lisp_Object string) { - int geometry, x = 0, y = 0; + int geometry, x UNINIT, y UNINIT; unsigned int width, height; Lisp_Object result; commit ad9c8b029c4949b492db778c40b5c94bd7093f85 Author: Eli Zaretskii Date: Fri Aug 23 19:21:33 2019 +0300 Fix compilation --without--x * src/xdisp.c (extend_face_to_end_of_line): Fix a recent change that moved the initialization of default_face. Reported by Glenn Morris . diff --git a/src/xdisp.c b/src/xdisp.c index 41d36bd7b9..75bc536cb9 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -20513,10 +20513,11 @@ extend_face_to_end_of_line (struct it *it) it->face_id = FACE_FOR_CHAR (f, face, 0, -1, Qnil); } -#ifdef HAVE_WINDOW_SYSTEM /* The default face, possibly remapped. */ struct face *default_face = FACE_FROM_ID (f, lookup_basic_face (it->w, f, DEFAULT_FACE_ID)); + +#ifdef HAVE_WINDOW_SYSTEM if (default_face == NULL) error ("extend_face_to_end_of_line: default_face is not set!"); commit 4b87169d113a151e5d9d6cf7b0d7cb4fb1d3d2d7 Author: Eli Zaretskii Date: Fri Aug 23 16:00:25 2019 +0300 Avoid a compilation warning in w32.c * src/w32.c (logon_network_drive): Avoid compilation warning about strncpy arguments. diff --git a/src/w32.c b/src/w32.c index 36a5a37496..d7a91692c6 100644 --- a/src/w32.c +++ b/src/w32.c @@ -3918,7 +3918,7 @@ logon_network_drive (const char *path) return; n_slashes = 2; - strncpy (share, path, MAX_UTF8_PATH); + strncpy (share, path, MAX_UTF8_PATH - 1); /* Truncate to just server and share name. */ for (p = share + 2; *p && p < share + MAX_UTF8_PATH; p++) { commit c4dd5a73ce3ee80a4e152a48f120495cfa89de52 Author: Eli Zaretskii Date: Fri Aug 23 15:52:33 2019 +0300 Avoid compilation warning in frame.c * src/frame.c (Fx_parse_geometry): Avoid compilation warning about x and y being used without initializing them. diff --git a/src/frame.c b/src/frame.c index a0da55c0e9..8ee8e4203f 100644 --- a/src/frame.c +++ b/src/frame.c @@ -5327,7 +5327,7 @@ or a list (- N) meaning -N pixels relative to bottom/right corner. On Nextstep, this just calls `ns-parse-geometry'. */) (Lisp_Object string) { - int geometry, x, y; + int geometry, x = 0, y = 0; unsigned int width, height; Lisp_Object result; commit df20cbe0757d3071f9571531872951ddba9fca51 Author: Noam Postavsky Date: Fri Aug 23 07:59:32 2019 -0400 ; Fix references to log-edit-generate-changelog-from-diff * doc/emacs/maintaining.texi (Log Buffer): * etc/NEWS: Replace log-edit-generate-changelog (an old name which was changed during editing) to log-edit-generate-changelog-from-diff. diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi index c6fe29ed27..e92a959d99 100644 --- a/doc/emacs/maintaining.texi +++ b/doc/emacs/maintaining.texi @@ -679,12 +679,12 @@ started editing (@pxref{Old Revisions}), type @kbd{C-c C-d} (@code{log-edit-show-diff}). @kindex C-c C-w @r{(Log Edit mode)} -@findex log-edit-generate-changelog +@findex log-edit-generate-changelog-from-diff To help generate ChangeLog entries, type @kbd{C-c C-w} -(@code{log-edit-generate-changelog}), to generate skeleton ChangeLog -entries, listing all changed file and function names based on the diff -of the VC fileset. Consecutive entries left empty will be combined by -@kbd{C-q} (@code{fill-paragraph}). +(@code{log-edit-generate-changelog-from-diff}), to generate skeleton +ChangeLog entries, listing all changed file and function names based +on the diff of the VC fileset. Consecutive entries left empty will be +combined by @kbd{C-q} (@code{fill-paragraph}). @kindex C-c C-a @r{(Log Edit mode)} @findex log-edit-insert-changelog diff --git a/etc/NEWS b/etc/NEWS index 60327e92d2..cf187598ce 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -699,7 +699,7 @@ The default value is 'find-dired-sort-by-filename'. ** Change Logs and VC +++ -*** New command 'log-edit-generate-changelog', bound to C-c C-w. +*** New command 'log-edit-generate-changelog-from-diff', bound to C-c C-w. This generates ChangeLog entries from the VC fileset diff. *** Recording ChangeLog entries doesn't require an actual file. commit c5e3815f4989ec5ed5e4cd507305e36c95ebb420 Author: Noam Postavsky Date: Fri Aug 23 07:55:09 2019 -0400 Print macro modified macro keys as characters not integers * lisp/macros.el (macros--insert-vector-macro): Pass all elements to 'prin1-char', not just those that satisfy characterp (because characters which have modifier bits set wouldn't qualify otherwise). 'prin1-char' will return nil if it can't handle the argument (e.g., for symbols representing function keys). diff --git a/lisp/macros.el b/lisp/macros.el index 4b38506d8a..3470359c0c 100644 --- a/lisp/macros.el +++ b/lisp/macros.el @@ -38,13 +38,13 @@ (defun macros--insert-vector-macro (definition) "Print DEFINITION, a vector, into the current buffer." - (dotimes (i (length definition)) - (let ((char (aref definition i))) - (insert (if (zerop i) ?\[ ?\s)) - (if (characterp char) - (princ (prin1-char char) (current-buffer)) - (prin1 char (current-buffer))))) - (insert ?\])) + (insert ?\[ + (mapconcat (lambda (event) + (or (prin1-char event) + (prin1-to-string event))) + definition + " ") + ?\])) ;;;###autoload (defun insert-kbd-macro (macroname &optional keys) commit f38901d431ba6dfe5dd9ebbe32f24afa16f129bd Author: Eli Zaretskii Date: Fri Aug 23 15:30:45 2019 +0300 ; Fix last change. * src/process.c (network_lookup_address_info_1): A better fix for compilation on platforms without HAVE_GAI_STRERROR. (Bug#37158) diff --git a/src/process.c b/src/process.c index 856c9c4b63..372277a953 100644 --- a/src/process.c +++ b/src/process.c @@ -4596,7 +4596,7 @@ network_lookup_address_info_1 (Lisp_Object host, const char *service, #else AUTO_STRING (format, "%s/%s getaddrinfo error %d"); msg = CALLN (Fformat, format, host, build_string (service), - make_fixnum (ret)); + make_int (ret)); #endif } return msg; commit cbd536d6a9cc2d3bd7b1ac00c4b658403b5e91e6 Author: Robert Pluim Date: Fri Aug 23 14:24:27 2019 +0200 Fix compilation of process.c * src/process.c (network_lookup_address_info_1): [!HAVE_GAI_STRERROR]: Use make_fixnum instead of make_number. (Bug#37158). diff --git a/src/process.c b/src/process.c index c3cc78afa2..856c9c4b63 100644 --- a/src/process.c +++ b/src/process.c @@ -4596,7 +4596,7 @@ network_lookup_address_info_1 (Lisp_Object host, const char *service, #else AUTO_STRING (format, "%s/%s getaddrinfo error %d"); msg = CALLN (Fformat, format, host, build_string (service), - make_number (ret)); + make_fixnum (ret)); #endif } return msg; commit d534687c43a1517e291b8de31e3ce23c2e6e4603 Author: Michael Heerdegen Date: Wed Aug 21 15:51:13 2019 +0200 Hi-lock lines up to right margin (Bug#15934) * lisp/hi-lock.el (hi-lock-line-face-buffer): Change used regexp so that a line terminating newline character is included in the match. diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el index 65465d3b4c..b6b0e2a736 100644 --- a/lisp/hi-lock.el +++ b/lisp/hi-lock.el @@ -447,7 +447,7 @@ highlighting will not update as you type." (hi-lock-set-pattern ;; The \\(?:...\\) grouping construct ensures that a leading ^, +, * or ? ;; or a trailing $ in REGEXP will be interpreted correctly. - (concat "^.*\\(?:" regexp "\\).*$") face)) + (concat "^.*\\(?:" regexp "\\).*\\(?:$\\)\n?") face)) ;;;###autoload commit b4065de33cf397b80e15c22740d34b4a03cfdc17 Author: Lars Ingebrigtsen Date: Fri Aug 23 11:51:54 2019 +0200 Rename renamed nsm.el variables and functions back * doc/emacs/misc.texi (Network Security): Start working on updating the NSM bits, but it's unclear how much of the new stuff to document. * lisp/net/nsm.el: Rename all nsm-tls-check-* functions to nsm-protocol-check--* to bring them back into line with the documentation. (network-security-protocol-checks): Renamed back again from `nsm-tls-checks', as this variable is documented and can't just go away. diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi index 5877c4b0de..83fb8acf7c 100644 --- a/doc/emacs/misc.texi +++ b/doc/emacs/misc.texi @@ -302,7 +302,10 @@ the Transport Layer Security (@acronym{TLS}) features. @vindex network-security-level The @code{network-security-level} variable determines the security level that @acronym{NSM} enforces. If its value is @code{low}, no -security checks are performed. +security checks are performed. This is not recommended, and will +basically mean that your network connections can't be trusted. +However, the setting can be useful in limited circumstances, as when +testing network issues. If this variable is @code{medium} (which is the default), a number of checks will be performed. If as result @acronym{NSM} determines that @@ -325,13 +328,12 @@ The protocol network checks is controlled via the @code{network-security-protocol-checks} variable. It's an alist where the first element of each association is the name -of the check, the second element is the security level where the check -should be used, and the optional third element is a parameter supplied -to the check. +of the check, and the second element is the security level where the +check should be used. An element like @code{(rc4 medium)} will result in the function @code{nsm-protocol-check--rc4} being called like thus: -@w{@code{(nsm-protocol-check--rc4 host port status optional-parameter)}}. +@w{@code{(nsm-protocol-check--rc4 host port status settings)}}. The function should return non-@code{nil} if the connection should proceed and @code{nil} otherwise. diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index 69dc86f76f..ed700bc9b5 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -138,27 +138,27 @@ unencrypted." (nsm-save-host host port status 'fingerprint nil 'always)) process))))) -(defcustom nsm-tls-checks +(defcustom network-security-protocol-checks '(;; Old Known Weaknesses. - (nsm-tls-check-version . medium) - (nsm-tls-check-compression . medium) - (nsm-tls-check-renegotiation-info-ext . medium) - (nsm-tls-check-verify-cert . medium) - (nsm-tls-check-same-cert . medium) - (nsm-tls-check-null-suite . medium) - (nsm-tls-check-export-kx . medium) - (nsm-tls-check-anon-kx . medium) - (nsm-tls-check-md5-sig . medium) - (nsm-tls-check-rc4-cipher . medium) + (version medium) + (compression medium) + (renegotiation-info-ext medium) + (verify-cert medium) + (same-cert medium) + (null-suite medium) + (export-kx medium) + (anon-kx medium) + (md5-sig medium) + (rc4-cipher medium) ;; Weaknesses made known after 2013. - (nsm-tls-check-dhe-prime-kx . medium) - (nsm-tls-check-sha1-sig . medium) - (nsm-tls-check-ecdsa-cbc-cipher . medium) + (dhe-prime-kx medium) + (sha1-sig medium) + (ecdsa-cbc-cipher medium) ;; Towards TLS 1.3 - (nsm-tls-check-dhe-kx . high) - (nsm-tls-check-rsa-kx . high) - (nsm-tls-check-3des-cipher . high) - (nsm-tls-check-cbc-cipher . high)) + (dhe-kx high) + (rsa-kx high) + (3des-cipher high) + (cbc-cipher high)) "This variable specifies what TLS connection checks to perform. It's an alist where the key is the name of the check, and the value is the minimum security level the check should begin. @@ -252,9 +252,10 @@ otherwise." (defun nsm-check-tls-connection (process host port status settings) "Check TLS connection against potential security problems. -This function runs each test defined in `nsm-tls-checks' in the -order specified against the TLS connection's peer status STATUS -for the host HOST and port PORT. +This function runs each test defined in +`network-security-protocol-checks' in the order specified against +the TLS connection's peer status STATUS for the host HOST and +port PORT. If one or more problems are found, this function will collect all the error messages returned by the check functions, and confirm @@ -268,23 +269,23 @@ terminating the connection. This function returns the process PROCESS if no problems are found, and nil otherwise. -See also: `nsm-tls-checks' and `nsm-noninteractive'" +See also: `network-security-protocol-checks' and `nsm-noninteractive'" (when (nsm-should-check host) (let* ((results (cl-loop - for check in nsm-tls-checks - for type = (intern (format ":%s" - (string-remove-prefix - "nsm-tls-check-" - (symbol-name (car check)))) - obarray) + for check in network-security-protocol-checks + for type = (intern (format ":%s" (car check)) obarray) ;; Skip the check if the user has already said that this ;; host is OK for this type of "error". for result = (and (not (memq type (plist-get settings :conditions))) (>= (nsm-level network-security-level) - (nsm-level (cdr check))) - (funcall (car check) host port status settings)) + (nsm-level (cadr check))) + (funcall + (intern (format "nsm-protocol-check--%s" + (car check)) + obarray) + host port status settings)) when result collect (cons type result))) (problems (nconc (plist-get status :warnings) (map-keys results)))) @@ -325,21 +326,18 @@ See also: `nsm-tls-checks' and `nsm-noninteractive'" (declare-function gnutls-peer-status-warning-describe "gnutls.c" (status-symbol)) -(defun nsm-tls-check-verify-cert (host port status settings) +(defun nsm-protocol-check--verify-cert (host port status settings) "Check for warnings from the certificate verification status. This is the most basic security check for a TLS connection. If certificate verification fails, it means the server's identity - cannot be verified by the credentials received. - -Think very carefully before removing this check from -`nsm-tls-checks'." + cannot be verified by the credentials received." (let ((warnings (plist-get status :warnings))) (and warnings (not (nsm-warnings-ok-p status settings)) (mapconcat #'gnutls-peer-status-warning-describe warnings "\n")))) -(defun nsm-tls-check-same-cert (host port status settings) +(defun nsm-protocol-check--same-cert (host port status settings) "Check for certificate fingerprint mismatch. If the fingerprints saved do not match the fingerprint of the @@ -351,7 +349,7 @@ man-in-the-middle attack." ;; Key exchange checks -(defun nsm-tls-check-rsa-kx (host port status &optional settings) +(defun nsm-protocol-check--rsa-kx (host port status &optional settings) "Check for static RSA key exchange. Static RSA key exchange methods do not offer perfect forward @@ -381,7 +379,7 @@ Security (DTLS)\", \"(4.1. General Guidelines)\" "RSA key exchange method (%s) does not offer perfect forward secrecy" kx)))) -(defun nsm-tls-check-dhe-prime-kx (host port status &optional settings) +(defun nsm-protocol-check--dhe-prime-kx (host port status &optional settings) "Check for the key strength of DH key exchange based on integer factorization. This check is a response to Logjam[1]. Logjam is an attack that @@ -397,7 +395,7 @@ exchange in June 2018[2]. To provide a balance between compatibility and security, this function only checks for a minimum key strength of 1024-bit. -See also: `nsm-tls-check-dhe-kx' +See also: `nsm-protocol-check--dhe-kx' Reference: @@ -412,7 +410,7 @@ Diffie-Hellman Fails in Practice\", `https://weakdh.org/' "Diffie-Hellman key strength (%s bits) too weak (%s bits)" prime-bits 1024)))) -(defun nsm-tls-check-dhe-kx (host port status &optional settings) +(defun nsm-protocol-check--dhe-kx (host port status &optional settings) "Check for existence of DH key exchange based on integer factorization. In the years since the discovery of Logjam, it was discovered @@ -436,7 +434,7 @@ Diffie-Hellman Backdoors in TLS.\", "unable to verify Diffie-Hellman key exchange method (%s) parameters" kx)))) -(defun nsm-tls-check-export-kx (host port status &optional settings) +(defun nsm-protocol-check--export-kx (host port status &optional settings) "Check for RSA-EXPORT key exchange. EXPORT cipher suites are a family of 40-bit and 56-bit effective @@ -461,7 +459,7 @@ of user-visible changes.\" Version 3.4.0, "EXPORT level key exchange (%s) is insecure" kx))))) -(defun nsm-tls-check-anon-kx (host port status &optional settings) +(defun nsm-protocol-check--anon-kx (host port status &optional settings) "Check for anonymous key exchange. Anonymous key exchange exposes the connection to @@ -480,7 +478,7 @@ authentication\", ;; Cipher checks -(defun nsm-tls-check-cbc-cipher (host port status &optional settings) +(defun nsm-protocol-check--cbc-cipher (host port status &optional settings) "Check for CBC mode ciphers. CBC mode cipher in TLS versions earlier than 1.3 are problematic @@ -509,7 +507,7 @@ Security (TLS) and Datagram Transport Layer Security (DTLS)\", "CBC mode cipher (%s) can be insecure" cipher))))) -(defun nsm-tls-check-ecdsa-cbc-cipher (host port status &optional settings) +(defun nsm-protocol-check--ecdsa-cbc-cipher (host port status &optional settings) "Check for CBC mode cipher usage under ECDSA key exchange. CBC mode cipher in TLS versions earlier than 1.3 are problematic @@ -547,7 +545,7 @@ Security (TLS) and Datagram Transport Layer Security (DTLS)\", "CBC mode cipher (%s) can be insecure" cipher))))) -(defun nsm-tls-check-3des-cipher (host port status &optional settings) +(defun nsm-protocol-check--3des-cipher (host port status &optional settings) "Check for 3DES ciphers. Due to its use of 64-bit block size, it is known that a @@ -568,7 +566,7 @@ Current Use and Deprecation of TDEA\", "3DES cipher (%s) is weak" cipher)))) -(defun nsm-tls-check-rc4-cipher (host port status &optional settings) +(defun nsm-protocol-check--rc4-cipher (host port status &optional settings) "Check for RC4 ciphers. RC4 cipher has been prohibited by RFC 7465[1]. @@ -592,7 +590,7 @@ Reference: ;; Signature checks -(defun nsm-tls-check-sha1-sig (host port status &optional settings) +(defun nsm-protocol-check--sha1-sig (host port status &optional settings) "Check for SHA1 signatures on certificates. The first SHA1 collision was found in 2017[1], as a precaution @@ -627,7 +625,7 @@ SHA-1 for SSL/TLS Certificates in Microsoft Edge and Internet Explorer algo) end)) -(defun nsm-tls-check-md5-sig (host port status &optional settings) +(defun nsm-protocol-check--md5-sig (host port status &optional settings) "Check for MD5 signatures on certificates. In 2008, a group of researchers were able to forge an @@ -660,7 +658,7 @@ the MD5 Message-Digest and the HMAC-MD5 Algorithms\", ;; Extension checks -(defun nsm-tls-check-renegotiation-info-ext (host port status +(defun nsm-protocol-check--renegotiation-info-ext (host port status &optional settings) "Check for renegotiation_info TLS extension status. @@ -681,7 +679,7 @@ Layer Security (TLS) Renegotiation Indication Extension\", ;; Compression checks -(defun nsm-tls-check-compression (host port status &optional settings) +(defun nsm-protocol-check--compression (host port status &optional settings) "Check for TLS compression. TLS compression attacks such as CRIME would allow an attacker to @@ -701,7 +699,7 @@ Security (DTLS)\", `https://tools.ietf.org/html/rfc7525'" ;; Protocol version checks -(defun nsm-tls-check-version (host port status &optional settings) +(defun nsm-protocol-check--version (host port status &optional settings) "Check for SSL/TLS protocol version. This function guards against the usage of SSL3.0, which has been @@ -726,7 +724,7 @@ Early TLS\" ;; Full suite checks -(defun nsm-tls-check-null-suite (host port status &optional settings) +(defun nsm-protocol-check--null-suite (host port status &optional settings) "Check for NULL cipher suites. This function checks for NULL key exchange, cipher and message commit 7b0d49854675eae962c6baf8ae6fd90a2c87889b Author: Lars Ingebrigtsen Date: Fri Aug 23 11:00:02 2019 +0200 Move all NSM tests away from the `low' level * lisp/net/nsm.el (network-security-level, nsm-tls-checks): Make `low' a "check nothing" setting again, and move all the `low' checks back to `medium'. This makes the test suite work again. diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index 7ebd0c4872..69dc86f76f 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -46,7 +46,7 @@ connection should be handled. The following values are possible: -`low': Only the most basic checks are performed -- very insecure. +`low': No checks are performed: This is extremely insecure. `medium': Default. Suitable for most circumstances. `high': Warns about additional issues not enabled in `medium' due to compatibility concerns. @@ -140,16 +140,16 @@ unencrypted." (defcustom nsm-tls-checks '(;; Old Known Weaknesses. - (nsm-tls-check-version . low) - (nsm-tls-check-compression . low) - (nsm-tls-check-renegotiation-info-ext . low) - (nsm-tls-check-verify-cert . low) - (nsm-tls-check-same-cert . low) - (nsm-tls-check-null-suite . low) - (nsm-tls-check-export-kx . low) - (nsm-tls-check-anon-kx . low) - (nsm-tls-check-md5-sig . low) - (nsm-tls-check-rc4-cipher . low) + (nsm-tls-check-version . medium) + (nsm-tls-check-compression . medium) + (nsm-tls-check-renegotiation-info-ext . medium) + (nsm-tls-check-verify-cert . medium) + (nsm-tls-check-same-cert . medium) + (nsm-tls-check-null-suite . medium) + (nsm-tls-check-export-kx . medium) + (nsm-tls-check-anon-kx . medium) + (nsm-tls-check-md5-sig . medium) + (nsm-tls-check-rc4-cipher . medium) ;; Weaknesses made known after 2013. (nsm-tls-check-dhe-prime-kx . medium) (nsm-tls-check-sha1-sig . medium) commit 15c4a822e1fe6d58592b0c5afd42c100d81cc4e5 Author: Lars Ingebrigtsen Date: Fri Aug 23 10:44:49 2019 +0200 Tweak previous tar-mode time stamp code * lisp/tar-mode.el (tar-header-block-summarize): Tweak previous commit to output the time stamp in the exact same way that GNU tar does. diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el index 95862dec82..8e7e1945cb 100644 --- a/lisp/tar-mode.el +++ b/lisp/tar-mode.el @@ -510,7 +510,7 @@ MODE should be an integer which is a file mode value." (if (= 0 (length gname)) gid gname) size (if tar-mode-show-date - (format-time-string " %FT%T" time) + (format-time-string " %Y-%m-%d %H:%M" time) "") (propertize name 'mouse-face 'highlight commit 0fa18503522b3016647cabd67eb4abce7aa092c1 Author: Eli Zaretskii Date: Fri Aug 23 11:43:30 2019 +0300 ; * lisp/emacs-lisp/cl-lib.el (cl-pushnew): Doc fix. diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index fceabf8c2e..c09fcf51eb 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -129,11 +129,11 @@ The return value is the decremented value of PLACE." (list 'cl-callf '- place (or x 1)))) (defmacro cl-pushnew (x place &rest keys) - "Add X to the list stored in PLACE unless already X is already in the list. + "Add X to the list stored in PLACE unless X is already in the list. PLACE is a generalized variable that stores a list. -Like (push X PLACE), except that PLACE is unmodified if X is -`eql' to an element already in PLACE list. +Like (push X PLACE), except that PLACE is unmodified if X is `eql' +to an element already in the list stored in PLACE. \nKeywords supported: :test :test-not :key \n(fn X PLACE [KEYWORD VALUE]...)" commit 49a8c8506a8477fd27ba924f14aa196e0d0813f9 Author: Paul Eggert Date: Fri Aug 23 01:11:12 2019 -0700 Get the Gnutls code compiling on Fedora 30 The recent changes caused the build to fail on Fedora 30 when built with --enable-gcc-warnings, among other things with diagnostics that gnutls_compression_get and gnutls_compression_get_name are deprecated (this started with GnuTLS 3.6). Fix this by refusing to call these obsolescent and now-dummy functions in GnuTLS 3.6 and later. However, this is just a temporary workaround to get the build working; a real fix is needed, as network-stream-tests fail. * src/gnutls.c (HAVE_GNUTLS_COMPRESSION_GET): New macro. (gnutls_compression_get, gnutls_compression_get_name): Define only if HAVE_GNUTLS_COMPRESSION_GET. (init_gnutls_functions): Load the two functions only if HAVE_GNUTLS_COMPRESSION_GET. (emacs_gnutls_certificate_export_pem): Use alloca instead of xmalloc. (Fgnutls_peer_status): Just return "NULL" if the functions are deprecated. (Fgnutls_format_certificate): Fix pointer signedness glitches. * src/process.c: Fix spacing. diff --git a/src/gnutls.c b/src/gnutls.c index db452e01aa..51536b1463 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -48,6 +48,10 @@ along with GNU Emacs. If not, see . */ # define HAVE_GNUTLS_ETM_STATUS #endif +#if GNUTLS_VERSION_NUMBER < 0x030600 +# define HAVE_GNUTLS_COMPRESSION_GET +#endif + /* gnutls_mac_get_nonce_size was added in GnuTLS 3.2.0, but was exported only since 3.3.0. */ #if GNUTLS_VERSION_NUMBER >= 0x030300 @@ -217,10 +221,12 @@ DEF_DLL_FN (const char *, gnutls_cipher_get_name, (gnutls_cipher_algorithm_t)); DEF_DLL_FN (gnutls_mac_algorithm_t, gnutls_mac_get, (gnutls_session_t)); DEF_DLL_FN (const char *, gnutls_mac_get_name, (gnutls_mac_algorithm_t)); +#ifdef HAVE_GNUTLS_COMPRESSION_GET DEF_DLL_FN (gnutls_compression_method_t, gnutls_compression_get, (gnutls_session_t)); DEF_DLL_FN (const char *, gnutls_compression_get_name, (gnutls_compression_method_t)); +#endif DEF_DLL_FN (unsigned, gnutls_safe_renegotiation_status, (gnutls_session_t)); # ifdef HAVE_GNUTLS3 @@ -368,8 +374,10 @@ init_gnutls_functions (void) LOAD_DLL_FN (library, gnutls_cipher_get_name); LOAD_DLL_FN (library, gnutls_mac_get); LOAD_DLL_FN (library, gnutls_mac_get_name); +# ifdef HAVE_GNUTLS_COMPRESSION_GET LOAD_DLL_FN (library, gnutls_compression_get); LOAD_DLL_FN (library, gnutls_compression_get_name); +# endif LOAD_DLL_FN (library, gnutls_safe_renegotiation_status); # ifdef HAVE_GNUTLS3 LOAD_DLL_FN (library, gnutls_rnd); @@ -462,8 +470,10 @@ init_gnutls_functions (void) # define gnutls_kx_get_name fn_gnutls_kx_get_name # define gnutls_mac_get fn_gnutls_mac_get # define gnutls_mac_get_name fn_gnutls_mac_get_name -# define gnutls_compression_get fn_gnutls_compression_get -# define gnutls_compression_get_name fn_gnutls_compression_get_name +# ifdef HAVE_GNUTLS_COMPRESSION_GET +# define gnutls_compression_get fn_gnutls_compression_get +# define gnutls_compression_get_name fn_gnutls_compression_get_name +# endif # define gnutls_safe_renegotiation_status fn_gnutls_safe_renegotiation_status # define gnutls_pk_algorithm_get_name fn_gnutls_pk_algorithm_get_name # define gnutls_pk_bits_to_sec_param fn_gnutls_pk_bits_to_sec_param @@ -1082,17 +1092,18 @@ emacs_gnutls_certificate_export_pem (gnutls_x509_crt_t cert) if (err == GNUTLS_E_SHORT_MEMORY_BUFFER) { - unsigned char *buf = xmalloc(size * sizeof (unsigned char)); + USE_SAFE_ALLOCA; + char *buf = SAFE_ALLOCA (size); err = gnutls_x509_crt_export (cert, GNUTLS_X509_FMT_PEM, buf, &size); check_memory_full (err); if (err < GNUTLS_E_SUCCESS) - { - xfree (buf); - error ("GnuTLS certificate export error: %s", emacs_gnutls_strerror (err)); - } + error ("GnuTLS certificate export error: %s", + emacs_gnutls_strerror (err)); - return build_string(buf); + Lisp_Object result = build_string (buf); + SAFE_FREE (); + return result; } else if (err < GNUTLS_E_SUCCESS) error ("GnuTLS certificate export error: %s", emacs_gnutls_strerror (err)); @@ -1481,20 +1492,21 @@ returned as the :certificate entry. */) (gnutls_mac_get (state))))); /* Compression name. */ - result = nconc2 - (result, list2 (intern (":compression"), - build_string (gnutls_compression_get_name - (gnutls_compression_get (state))))); +#ifdef HAVE_GNUTLS_COMPRESSION_GET + Lisp_Object compression = build_string (gnutls_compression_get_name + (gnutls_compression_get (state))); +#else + Lisp_Object compression = build_string ("NULL"); +#endif + result = nconc2 (result, list2 (intern (":compression"), compression)); /* Encrypt-then-MAC. */ - result = nconc2 - (result, list2 (intern (":encrypt-then-mac"), + Lisp_Object etm_status = Qnil; #ifdef HAVE_GNUTLS_ETM_STATUS - gnutls_session_etm_status (state) ? Qt : Qnil -#else - Qnil + if (gnutls_session_etm_status (state)) + etm_status = Qt; #endif - )); + result = nconc2 (result, list2 (intern (":encrypt-then-mac"), etm_status)); /* Renegotiation Indication */ result = nconc2 @@ -1561,7 +1573,8 @@ boot_error (struct Lisp_Process *p, const char *m, ...) va_end (ap); } -DEFUN ("gnutls-format-certificate", Fgnutls_format_certificate, Sgnutls_format_certificate, 1, 1, 0, +DEFUN ("gnutls-format-certificate", Fgnutls_format_certificate, + Sgnutls_format_certificate, 1, 1, 0, doc: /* Format a X.509 certificate to a string. Given a PEM-encoded X.509 certificate CERT, returns a human-readable @@ -1578,14 +1591,14 @@ string representation. */) if (err < GNUTLS_E_SUCCESS) error ("gnutls-format-certificate error: %s", emacs_gnutls_strerror (err)); - unsigned char *crt_buf = SDATA (cert); - gnutls_datum_t crt_data = { crt_buf, strlen (crt_buf) }; + gnutls_datum_t crt_data = { SDATA (cert), strlen (SSDATA (cert)) }; err = gnutls_x509_crt_import (crt, &crt_data, GNUTLS_X509_FMT_PEM); check_memory_full (err); if (err < GNUTLS_E_SUCCESS) { gnutls_x509_crt_deinit (crt); - error ("gnutls-format-certificate error: %s", emacs_gnutls_strerror (err)); + error ("gnutls-format-certificate error: %s", + emacs_gnutls_strerror (err)); } gnutls_datum_t out; @@ -1594,7 +1607,8 @@ string representation. */) if (err < GNUTLS_E_SUCCESS) { gnutls_x509_crt_deinit (crt); - error ("gnutls-format-certificate error: %s", emacs_gnutls_strerror (err)); + error ("gnutls-format-certificate error: %s", + emacs_gnutls_strerror (err)); } char *out_buf = xmalloc ((out.size + 1) * sizeof (char)); diff --git a/src/process.c b/src/process.c index 7097b7ace1..c3cc78afa2 100644 --- a/src/process.c +++ b/src/process.c @@ -4120,10 +4120,8 @@ usage: (make-network-process &rest ARGS) */) hints.ai_socktype = socktype; msg = network_lookup_address_info_1 (host, portstring, &hints, &res); - if (!EQ(msg, Qt)) - { - error ("%s", SSDATA (msg)); - } + if (!EQ (msg, Qt)) + error ("%s", SSDATA (msg)); for (lres = res; lres; lres = lres->ai_next) addrinfos = Fcons (conv_addrinfo_to_lisp (lres), addrinfos); @@ -4593,10 +4591,12 @@ network_lookup_address_info_1 (Lisp_Object host, const char *service, str = SSDATA (code_convert_string_norecord (build_string (str), Vlocale_coding_system, 0)); AUTO_STRING (format, "%s/%s %s"); - msg = CALLN (Fformat, format, host, build_string (service), build_string (str)); + msg = CALLN (Fformat, format, host, build_string (service), + build_string (str)); #else AUTO_STRING (format, "%s/%s getaddrinfo error %d"); - msg = CALLN (Fformat, format, host, build_string (service), make_number (ret)); + msg = CALLN (Fformat, format, host, build_string (service), + make_number (ret)); #endif } return msg; @@ -4634,18 +4634,14 @@ nil if none were found. Each address is a vector of integers. */) hints.ai_socktype = SOCK_DGRAM; msg = network_lookup_address_info_1 (name, NULL, &hints, &res); - if (!EQ(msg, Qt)) - { - message ("%s", SSDATA(msg)); - } + if (!EQ (msg, Qt)) + message ("%s", SSDATA(msg)); else { for (lres = res; lres; lres = lres->ai_next) - { - addresses = Fcons (conv_sockaddr_to_lisp - (lres->ai_addr, lres->ai_addrlen), - addresses); - } + addresses = Fcons (conv_sockaddr_to_lisp (lres->ai_addr, + lres->ai_addrlen), + addresses); addresses = Fnreverse (addresses); freeaddrinfo (res); commit 27988f136c35396e0ef1e865f5a0c0a0bf20358a Author: Lars Ingebrigtsen Date: Fri Aug 23 10:10:09 2019 +0200 Put error output from M-! at the end of the error buffer * lisp/simple.el (shell-command-on-region): Put the error output at the end of the buffer instead of wherever point is (bug#7513). This avoids interleaving error output. diff --git a/lisp/simple.el b/lisp/simple.el index 9f86d70f84..358b6a4f20 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -3944,15 +3944,14 @@ interactively, this is t." (when (and error-file (file-exists-p error-file)) (if (< 0 (file-attribute-size (file-attributes error-file))) (with-current-buffer (get-buffer-create error-buffer) - (let ((pos-from-end (- (point-max) (point)))) - (or (bobp) - (insert "\f\n")) - ;; Do no formatting while reading error file, - ;; because that can run a shell command, and we - ;; don't want that to cause an infinite recursion. - (format-insert-file error-file nil) - ;; Put point after the inserted errors. - (goto-char (- (point-max) pos-from-end))) + (goto-char (point-max)) + ;; Insert a separator if there's already text here. + (unless (bobp) + (insert "\f\n")) + ;; Do no formatting while reading error file, + ;; because that can run a shell command, and we + ;; don't want that to cause an infinite recursion. + (format-insert-file error-file nil) (and display-error-buffer (display-buffer (current-buffer))))) (delete-file error-file)) commit ef49439ff9b5b09e9f77425c13713f55b7b6316a Author: Robert Pluim Date: Wed Feb 6 09:30:07 2019 +0100 Move default face lookup * src/xdisp.c (extend_face_to_end_of_line): Move default face lookup lower. diff --git a/src/xdisp.c b/src/xdisp.c index dea80a1f9a..41d36bd7b9 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -20463,7 +20463,7 @@ append_space_for_newline (struct it *it, bool default_face_p) static void extend_face_to_end_of_line (struct it *it) { - struct face *face, *default_face; + struct face *face; struct frame *f = it->f; /* If line is already filled, do nothing. Non window-system frames @@ -20481,10 +20481,6 @@ extend_face_to_end_of_line (struct it *it) || WINDOW_RIGHT_MARGIN_WIDTH (it->w) > 0)) return; - /* The default face, possibly remapped. */ - default_face = - FACE_FROM_ID_OR_NULL (f, lookup_basic_face (it->w, f, DEFAULT_FACE_ID)); - /* Face extension extends the background and box of IT->face_id to the end of the line. If the background equals the background of the frame, we don't have to do anything. */ @@ -20518,6 +20514,12 @@ extend_face_to_end_of_line (struct it *it) } #ifdef HAVE_WINDOW_SYSTEM + /* The default face, possibly remapped. */ + struct face *default_face = + FACE_FROM_ID (f, lookup_basic_face (it->w, f, DEFAULT_FACE_ID)); + if (default_face == NULL) + error ("extend_face_to_end_of_line: default_face is not set!"); + if (FRAME_WINDOW_P (f)) { /* If the row is empty, add a space with the current face of IT, commit 11bfc0ffcc547fad689a028fe17676534d33a5cb Author: Robert Pluim Date: Fri Aug 23 09:46:24 2019 +0200 Correct description of network-lookup-address-info * doc/lispref/processes.texi (Misc Network): Remove erroneous text about port numbers diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index e2a59d419f..61de77d066 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -3012,7 +3012,7 @@ signaled. Call @code{puny-encode-domain} on @var{name} first if you wish to lookup internationalized hostnames. If successful it returns a list of Lisp representations of network -addresses (without port numbers), otherwise it returns @code{nil}. +addresses, otherwise it returns @code{nil}. By default both IPv4 and IPv6 lookups are attempted. The optional argument @var{family} controls this behavior, specifying the symbol commit 6b68f92166df6fcd78a9223deb3d0137a6f60748 Author: Lars Ingebrigtsen Date: Fri Aug 23 09:58:58 2019 +0200 Remove debugging from previous shr.el patch diff --git a/lisp/net/shr.el b/lisp/net/shr.el index c0f8c72d5b..189873d8ce 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -2364,7 +2364,6 @@ flags that control whether to collect or render objects." (car (window-text-pixel-size nil (point-min) (point-max))))))) (defun shr-render-td (dom width fill) - (setq d dom) (let ((cache (intern (format "shr-td-cache-%s-%s" width fill)))) (or (dom-attr dom cache) (and fill commit c3753a322a73aaad31f155a2045cb0d030815ed2 Author: Eli Zaretskii Date: Fri Aug 23 10:38:14 2019 +0300 Fix recent changes in gnutls.c * src/gnutls.c: Fix typos that broke the MS-Windows build. (Fgnutls_peer_status_warning_describe): Fix incomplete error message string. diff --git a/src/gnutls.c b/src/gnutls.c index ce977d901c..db452e01aa 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -163,7 +163,7 @@ DEF_DLL_FN (int, gnutls_x509_crt_check_hostname, DEF_DLL_FN (int, gnutls_x509_crt_check_issuer, (gnutls_x509_crt_t, gnutls_x509_crt_t)); DEF_DLL_FN (void, gnutls_x509_crt_deinit, (gnutls_x509_crt_t)); -DEF_DLL_DN (int, gnutls_x509_crt_export, +DEF_DLL_FN (int, gnutls_x509_crt_export, (gnutls_x509_crt_t, gnutls_x509_crt_fmt_t, void *, size_t *)); DEF_DLL_FN (int, gnutls_x509_crt_import, (gnutls_x509_crt_t, const gnutls_datum_t *, @@ -350,7 +350,7 @@ init_gnutls_functions (void) LOAD_DLL_FN (library, gnutls_x509_crt_get_expiration_time); LOAD_DLL_FN (library, gnutls_x509_crt_get_dn); LOAD_DLL_FN (library, gnutls_x509_crt_get_pk_algorithm); - LOAD_DLL_FN (library, gnutls_x509_crt_print) + LOAD_DLL_FN (library, gnutls_x509_crt_print); LOAD_DLL_FN (library, gnutls_pk_algorithm_get_name); LOAD_DLL_FN (library, gnutls_pk_bits_to_sec_param); LOAD_DLL_FN (library, gnutls_x509_crt_get_issuer_unique_id); @@ -464,7 +464,7 @@ init_gnutls_functions (void) # define gnutls_mac_get_name fn_gnutls_mac_get_name # define gnutls_compression_get fn_gnutls_compression_get # define gnutls_compression_get_name fn_gnutls_compression_get_name -# define gnutls_safe_renegotiation_status fn_gnutls_safe_renegotiation_status; +# define gnutls_safe_renegotiation_status fn_gnutls_safe_renegotiation_status # define gnutls_pk_algorithm_get_name fn_gnutls_pk_algorithm_get_name # define gnutls_pk_bits_to_sec_param fn_gnutls_pk_bits_to_sec_param # define gnutls_priority_set_direct fn_gnutls_priority_set_direct @@ -1321,7 +1321,7 @@ DEFUN ("gnutls-peer-status-warning-describe", Fgnutls_peer_status_warning_descri return build_string ("certificate revocation data have a future issue date"); if (EQ (status_symbol, intern (":signer-constraints-failure"))) - return build_string ("certificate "); + return build_string ("certificate signer constraints were violated"); if (EQ (status_symbol, intern (":purpose-mismatch"))) return build_string ("certificate does not match the intended purpose"); commit aae9ac275c96438b99d977a6ad6726f5b43d3204 Author: Lars Ingebrigtsen Date: Fri Aug 23 08:51:35 2019 +0200 Avoid an infloop in shr when filling text with :align-to properties * lisp/net/shr.el (shr-fill-line): Only join together URL buttons if there are any URL buttons. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index fbd1a9b766..c0f8c72d5b 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -719,6 +719,7 @@ size, and full-buffer size." (insert "\n") (shr-indent) (when (and (> (1- gap-start) (point-min)) + (get-text-property (point) 'shr-url) ;; The link on both sides of the newline are the ;; same... (equal (get-text-property (point) 'shr-url) @@ -2363,6 +2364,7 @@ flags that control whether to collect or render objects." (car (window-text-pixel-size nil (point-min) (point-max))))))) (defun shr-render-td (dom width fill) + (setq d dom) (let ((cache (intern (format "shr-td-cache-%s-%s" width fill)))) (or (dom-attr dom cache) (and fill commit b22dffbc2869503f553931ad28a567cbf1507409 Author: Lars Ingebrigtsen Date: Fri Aug 23 07:19:45 2019 +0200 Fix Gnus display of timestamps that's less than a second old * lisp/gnus/gnus-art.el (article-lapsed-string): The elapsed seconds may be a fractional second. In that case, just say "now". diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index af8ec68ddd..930b0a0510 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -3628,7 +3628,7 @@ possible values." (unless max-segments (setq max-segments (length article-time-units))) (cond - ((zerop sec) + ((< (abs sec) 1) "Now") (t (concat commit d31fa998e7f9e98b8f60869253c6603c80416cbb Author: Lars Ingebrigtsen Date: Fri Aug 23 06:40:20 2019 +0200 Really save games scores to the games scores directory * lisp/play/gamegrid.el (gamegrid-add-score-with-update-game-score): Save games scores to `gamegrid-user-score-file-directory' by default (bug#36971). diff --git a/lisp/play/gamegrid.el b/lisp/play/gamegrid.el index 2d19c145b0..be09a73a1f 100644 --- a/lisp/play/gamegrid.el +++ b/lisp/play/gamegrid.el @@ -562,7 +562,8 @@ FILE is created there." (gamegrid-shared-game-dir (not (zerop (logand #o6000 (or update-game-score-modes 0)))))) (cond ((or (not update-game-score-modes) (file-name-absolute-p file)) - (gamegrid-add-score-insecure file score)) + (gamegrid-add-score-insecure file score + gamegrid-user-score-file-directory)) ((and gamegrid-shared-game-dir (file-exists-p (expand-file-name file shared-game-score-directory))) ;; Use the setgid (or setuid) "update-game-score" program commit 1071dfe18175ecf48d98ea9d3fd1468a7a5e9568 Author: Damien Cassou Date: Fri Aug 23 06:30:46 2019 +0200 Add imenu support to xref * lisp/progmodes/xref.el (xref--imenu-prev-index-position) (xref--imenu-extract-index-name): Add functions to get imenu support. (xref--xref-buffer-mode): Set imenu variables to the new functions. * etc/NEWS: Add corresponding entry (bug#36974). diff --git a/etc/NEWS b/etc/NEWS index cd47464039..60327e92d2 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1849,6 +1849,11 @@ and 'gravatar-force-default'. *** The built-in ada-mode is now deleted. The Gnu ELPA package is a good replacement, even in very large source files. +** xref + +--- +*** Imenu support has been added to 'xref--xref-buffer-mode'. + * New Modes and Packages in Emacs 27.1 diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index ae35766ecd..eef2ca643f 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -728,7 +728,11 @@ references displayed in the current *xref* buffer." "Mode for displaying cross-references." (setq buffer-read-only t) (setq next-error-function #'xref--next-error-function) - (setq next-error-last-buffer (current-buffer))) + (setq next-error-last-buffer (current-buffer)) + (setq imenu-prev-index-position-function + #'xref--imenu-prev-index-position) + (setq imenu-extract-index-name-function + #'xref--imenu-extract-index-name)) (defvar xref--transient-buffer-mode-map (let ((map (make-sparse-keymap))) @@ -740,6 +744,22 @@ references displayed in the current *xref* buffer." xref--xref-buffer-mode "XREF Transient") +(defun xref--imenu-prev-index-position () + "Move point to previous line in `xref' buffer. +This function is used as a value for +`imenu-prev-index-position-function'." + (if (bobp) + nil + (xref--search-property 'xref-group t))) + +(defun xref--imenu-extract-index-name () + "Return imenu name for line at point. +This function is used as a value for +`imenu-extract-index-name-function'. Point should be at the +beginning of the line." + (buffer-substring-no-properties (line-beginning-position) + (line-end-position))) + (defun xref--next-error-function (n reset?) (when reset? (goto-char (point-min))) @@ -789,7 +809,8 @@ GROUP is a string for decoration purposes and XREF is an for line-format = (and max-line-width (format "%%%dd: " max-line-width)) do - (xref--insert-propertized '(face xref-file-header) group "\n") + (xref--insert-propertized '(face xref-file-header 'xref-group t) + group "\n") (cl-loop for (xref . more2) on xrefs do (with-slots (summary location) xref (let* ((line (xref-location-line location)) commit fbbc257190d115dc76e1a8cf4e4992d52d7f55b9 Author: Lars Ingebrigtsen Date: Fri Aug 23 06:20:41 2019 +0200 Give a better error message when reading invalid "\unicode" escapes. * src/lread.c (read_escape): Give a clearer error message on Unicode escape sequences (bug#36988). diff --git a/src/lread.c b/src/lread.c index e444830c99..6ae7a0d8ba 100644 --- a/src/lread.c +++ b/src/lread.c @@ -2585,7 +2585,8 @@ read_escape (Lisp_Object readcharfun, bool stringp) want. */ int digit = char_hexdigit (c); if (digit < 0) - error ("Non-hex digit used for Unicode escape"); + error ("Non-hex character used for Unicode escape: %c (%d)", + c, c); i = (i << 4) + digit; } if (i > 0x10FFFF) commit e7d3ddf689300bdcccbd1762cf3387ceb17505a1 Author: Lars Ingebrigtsen Date: Fri Aug 23 06:12:44 2019 +0200 Clarify doc string of cl-pushnew * lisp/emacs-lisp/cl-lib.el (cl-pushnew): Clarify doc string (bug#37016). diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 7b22fa8483..fceabf8c2e 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -129,9 +129,12 @@ The return value is the decremented value of PLACE." (list 'cl-callf '- place (or x 1)))) (defmacro cl-pushnew (x place &rest keys) - "(cl-pushnew X PLACE): insert X at the head of the list if not already there. -Like (push X PLACE), except that the list is unmodified if X is `eql' to -an element already on the list. + "Add X to the list stored in PLACE unless already X is already in the list. +PLACE is a generalized variable that stores a list. + +Like (push X PLACE), except that PLACE is unmodified if X is +`eql' to an element already in PLACE list. + \nKeywords supported: :test :test-not :key \n(fn X PLACE [KEYWORD VALUE]...)" (declare (debug commit a179209678f009e72f7d28a80e026afaa3076d1d Author: Lars Ingebrigtsen Date: Fri Aug 23 06:00:36 2019 +0200 Fix interaction between url-handler-mode and browse-url * lisp/net/browse-url.el (browse-url): Don't expand any URLs (like "man:") that have a scheme when using `url-handler-mode' (bug#37056). diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 3151dae0aa..87a8248854 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -781,7 +781,9 @@ as ARGS." (interactive (browse-url-interactive-arg "URL: ")) (unless (called-interactively-p 'interactive) (setq args (or args (list browse-url-new-window-flag)))) - (when (and url-handler-mode (not (file-name-absolute-p url))) + (when (and url-handler-mode + (not (file-name-absolute-p url)) + (not (string-match "\\`[a-z]+:" url))) (setq url (expand-file-name url))) (let ((process-environment (copy-sequence process-environment)) (function (or (and (string-match "\\`mailto:" url) commit baae65d918e7f4c1f47057bc4b5f0302c3e47f38 Author: Lars Ingebrigtsen Date: Fri Aug 23 05:44:59 2019 +0200 Use ISO8601 time formats in tar-mode * lisp/tar-mode.el (tar-clip-time-string): Make obsolete (bug#37130). (tar-header-block-summarize): Use ISO8601 time instead of home-brew format. diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el index 713f3d944b..95862dec82 100644 --- a/lisp/tar-mode.el +++ b/lisp/tar-mode.el @@ -450,6 +450,7 @@ checksum before doing the check." (progn (beep) (message "Invalid checksum for file %s!" file-name)))) (defun tar-clip-time-string (time) + (declare (obsolete format-time-string "27.1")) (let ((str (current-time-string time))) (concat " " (substring str 4 16) (format-time-string " %Y" time)))) @@ -508,7 +509,9 @@ MODE should be an integer which is a file mode value." (if (= 0 (length uname)) uid uname) (if (= 0 (length gname)) gid gname) size - (if tar-mode-show-date (tar-clip-time-string time) "") + (if tar-mode-show-date + (format-time-string " %FT%T" time) + "") (propertize name 'mouse-face 'highlight 'help-echo "mouse-2: extract this file into a buffer") commit 6aab45bffc616efc938d7bcdb3a18c206f389a2c Author: Lars Ingebrigtsen Date: Fri Aug 23 05:31:17 2019 +0200 Make dired recognize .lz files * lisp/dired-aux.el (dired-compress-file-suffixes): Recognize .lz (lzip) compressed files (bug#37136). diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 6c06d841e7..a321247b0b 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -992,6 +992,7 @@ command with a prefix argument (the value does not matter)." ("\\.tar\\.gz\\'" "" "gzip -dc %i | tar -xf -") ("\\.tgz\\'" "" "gzip -dc %i | tar -xf -") ("\\.gz\\'" "" "gunzip") + ("\\.lz\\'" "" "lzip -d") ("\\.Z\\'" "" "uncompress") ;; For .z, try gunzip. It might be an old gzip file, ;; or it might be from compact? pack? (which?) but gunzip handles both. commit 228ca5aa4b499052be2a61afb686a15fbb1a38f6 Author: Lars Ingebrigtsen Date: Fri Aug 23 05:05:27 2019 +0200 Fix too-long lines in nsm.el * lisp/net/nsm.el: Fix some too-long lines and some terminology in the doc strings/comments. diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index da1fbf930a..7ebd0c4872 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -46,10 +46,11 @@ connection should be handled. The following values are possible: -`low': Check for problems known before Edward Snowden. +`low': Only the most basic checks are performed -- very insecure. `medium': Default. Suitable for most circumstances. `high': Warns about additional issues not enabled in `medium' due to compatibility concerns. +`paranoid': On this level, the user is queried for most new connections. See the Emacs manual for a description of all things that are checked and warned against." @@ -57,11 +58,8 @@ checked and warned against." :group 'nsm :type '(choice (const :tag "Low" low) (const :tag "Medium" medium) - (const :tag "High" high))) - -;; Backward compatibility -(when (eq network-security-level 'paranoid) - (setq network-security-level 'high)) + (const :tag "High" high) + (const :tag "Paranoid" paranoid))) (defcustom nsm-trust-local-network nil "Disable warnings when visiting trusted hosts on local networks. @@ -141,7 +139,7 @@ unencrypted." process))))) (defcustom nsm-tls-checks - '(;; Pre-Snowden Known Weaknesses + '(;; Old Known Weaknesses. (nsm-tls-check-version . low) (nsm-tls-check-compression . low) (nsm-tls-check-renegotiation-info-ext . low) @@ -152,7 +150,7 @@ unencrypted." (nsm-tls-check-anon-kx . low) (nsm-tls-check-md5-sig . low) (nsm-tls-check-rc4-cipher . low) - ;; Post-Snowden Apocalypse + ;; Weaknesses made known after 2013. (nsm-tls-check-dhe-prime-kx . medium) (nsm-tls-check-sha1-sig . medium) (nsm-tls-check-ecdsa-cbc-cipher . medium) @@ -273,23 +271,32 @@ found, and nil otherwise. See also: `nsm-tls-checks' and `nsm-noninteractive'" (when (nsm-should-check host) (let* ((results - (cl-loop for check in nsm-tls-checks - for type = (intern (format ":%s" - (string-remove-prefix - "nsm-tls-check-" - (symbol-name (car check)))) - obarray) - ;; Skip the check if the user has already said that this - ;; host is OK for this type of "error". - for result = (and (not (memq type (plist-get settings :conditions))) - (>= (nsm-level network-security-level) - (nsm-level (cdr check))) - (funcall (car check) host port status settings)) - when result - collect (cons type result))) + (cl-loop + for check in nsm-tls-checks + for type = (intern (format ":%s" + (string-remove-prefix + "nsm-tls-check-" + (symbol-name (car check)))) + obarray) + ;; Skip the check if the user has already said that this + ;; host is OK for this type of "error". + for result = (and (not (memq type + (plist-get settings :conditions))) + (>= (nsm-level network-security-level) + (nsm-level (cdr check))) + (funcall (car check) host port status settings)) + when result + collect (cons type result))) (problems (nconc (plist-get status :warnings) (map-keys results)))) + + ;; We haven't seen this before, and we're paranoid. + (when (and (eq network-security-level 'paranoid) + (not (nsm-fingerprint-ok-p status settings))) + (push '(:not-seen . "Certificate not seen before") results)) + (when (and results - (not (seq-set-equal-p (plist-get settings :conditions) problems)) + (not (seq-set-equal-p (plist-get settings :conditions) + problems)) (not (nsm-query host port status 'conditions problems @@ -653,7 +660,8 @@ the MD5 Message-Digest and the HMAC-MD5 Algorithms\", ;; Extension checks -(defun nsm-tls-check-renegotiation-info-ext (host port status &optional settings) +(defun nsm-tls-check-renegotiation-info-ext (host port status + &optional settings) "Check for renegotiation_info TLS extension status. If this TLS extension is not used, the connection established is @@ -739,18 +747,15 @@ protocol." (defun nsm-fingerprint-ok-p (status settings) (let ((saved-fingerprints (plist-get settings :fingerprints))) - ;; Haven't seen this host before or not pinning cert + ;; Haven't seen this host before or not pinning cert. (or (null saved-fingerprints) - ;; Plain connection allowed + ;; Plain connection allowed. (memq :none saved-fingerprints) - ;; We are pinning certs, and we have seen this host - ;; before, but the credientials for this host differs - ;; from the last times we saw it + ;; We are pinning certs, and we have seen this host before, + ;; but the credientials for this host differs from the last + ;; times we saw it. (member (nsm-fingerprint status) saved-fingerprints)))) -(set-advertised-calling-convention - 'nsm-fingerprint-ok-p '(status settings) "27.1") - (defun nsm-check-plain-connection (process host port settings warn-unencrypted) (if (nsm-should-check host) ;; If this connection used to be TLS, but is now plain, then it's commit ac77e62b23a2745bdb0dab41f5e91002b67ed4f1 Author: Lars Ingebrigtsen Date: Fri Aug 23 04:54:42 2019 +0200 Mention new NSM warnings diff --git a/etc/NEWS b/etc/NEWS index a4a11cc787..cd47464039 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -275,7 +275,8 @@ variable. +++ ** TLS connections have their security tightened by default. Most of the checks for outdated, believed-to-be-weak TLS algorithms -and ciphers are now switched on by default. By default, the NSM will +and ciphers are now switched on by default. (In addition, several new +TLS weaknesses are now warned about.) By default, the NSM will flag connections using these weak algorithms and ask users whether to allow them. To get the old behavior back (where certificates are checked for validity, but no warnings about weak cryptography are commit 53cb3d3e0ddb666dc5b7774957ca863c668213cb Merge: b4d3a882a8 29d485fb76 Author: Lars Ingebrigtsen Date: Fri Aug 23 04:49:52 2019 +0200 Merge remote-tracking branch 'origin/netsec' commit 29d485fb768fbe375d60fd80cb2dbdbd90f3becc (refs/remotes/origin/netsec) Author: Lars Ingebrigtsen Date: Fri Aug 23 04:07:10 2019 +0200 Tweak the warning display to be less like a TLS decoding page * lisp/net/nsm.el (nsm-parse-subject, nsm-certificate-part): Restore functions for parsing subjects. (nsm-format-certificate): Use them to display more user-friendly data. Also change the display to have fewer lines again so that the data of interest isn't pushed off the screen. diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index b0eff81161..c170ec9e4e 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -28,6 +28,7 @@ (require 'rmc) ; read-multiple-choice (require 'subr-x) (require 'seq) +(require 'map) (defvar nsm-permanent-host-settings nil) (defvar nsm-temporary-host-settings nil) @@ -293,7 +294,7 @@ See also: `nsm-tls-checks' and `nsm-noninteractive'" 'conditions problems (format-message - "The TLS connection to %s:%s is insecure for the following reason%s:\n\n%s" + "The TLS connection to %s:%s is insecure\nfor the following reason%s:\n\n%s" host port (if (> (length problems) 1) "s" "") @@ -835,10 +836,12 @@ protocol." (?n "next" "Next certificate") (?p "previous" "Previous certificate") (?q "quit" "Quit details view"))) - (answer (read-multiple-choice "Continue connecting?" accept-choices)) + (answer (read-multiple-choice "Continue connecting?" + accept-choices)) (show-details (char-equal (car answer) ?d)) (pems (cl-loop for cert in certs - collect (gnutls-format-certificate (plist-get cert :pem)))) + collect (gnutls-format-certificate + (plist-get cert :pem)))) (cert-index 0)) (while show-details (unless (get-buffer-window cert-buffer) @@ -999,13 +1002,27 @@ protocol." (insert (propertize "Certificate information" 'face 'underline) "\n" " Issued by:" - (plist-get cert :issuer) "\n" + (nsm-certificate-part (plist-get cert :issuer) "CN" t) "\n" " Issued to:" - (plist-get cert :subject) "\n") + (or (nsm-certificate-part (plist-get cert :subject) "O") + (nsm-certificate-part (plist-get cert :subject) "OU" t)) + "\n" + " Hostname:" + (nsm-certificate-part (plist-get cert :subject) "CN" t) "\n") (when (and (plist-get cert :public-key-algorithm) (plist-get cert :signature-algorithm)) - (insert " Public key:" (plist-get cert :public-key-algorithm) "\n") - (insert " Signature:" (plist-get cert :signature-algorithm) "\n")) + (insert + " Public key:" (plist-get cert :public-key-algorithm) + ", signature: " (plist-get cert :signature-algorithm) "\n")) + (when (and (plist-get status :key-exchange) + (plist-get status :cipher) + (plist-get status :mac) + (plist-get status :protocol)) + (insert + " Session:" (plist-get status :protocol) + ", key: " (plist-get status :key-exchange) + ", cipher: " (plist-get status :cipher) + ", mac: " (plist-get status :mac) "\n")) (when (plist-get cert :certificate-security-level) (insert " Security level:" @@ -1015,16 +1032,7 @@ protocol." (insert " Valid:From " (plist-get cert :valid-from) " to " (plist-get cert :valid-to) "\n") - ;; Handshake parameters - (insert (propertize "Session information" 'face 'underline) "\n") - (insert " Version:" (plist-get status :protocol) "\n") - (insert " Safe renegotiation:" (if (plist-get status :safe-renegotiation) "Yes" "No") "\n") - (insert " Compression:" (plist-get status :compression) "\n") - (insert " Encrypt-then-MAC:" (if (plist-get status :encrypt-then-mac) "Yes" "No") "\n") - (insert " Cipher suite:" (nsm-cipher-suite status) "\n") - (if (string-match "^\\bDHE\\b" (plist-get status :key-exchange)) - (insert " DH prime bits:" (format "%d" (plist-get status :diffie-hellman-prime-bits)) "\n") - (insert "\n")) + (insert "\n") (goto-char (point-min)) (while (re-search-forward "^[^:]+:" nil t) (insert (make-string (- 22 (current-column)) ? ))) @@ -1043,6 +1051,37 @@ protocol." (plist-get status :cipher) (plist-get status :mac))) +(defun nsm-certificate-part (string part &optional full) + (let ((part (cadr (assoc part (nsm-parse-subject string))))) + (cond + (part part) + (full string) + (t nil)))) + +(defun nsm-parse-subject (string) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (let ((start (point)) + (result nil)) + (while (not (eobp)) + (push (replace-regexp-in-string + "[\\]\\(.\\)" "\\1" + (buffer-substring start + (if (re-search-forward "[^\\]," nil 'move) + (1- (point)) + (point)))) + result) + (setq start (point))) + (mapcar + (lambda (elem) + (let ((pos (cl-position ?= elem))) + (if pos + (list (substring elem 0 pos) + (substring elem (1+ pos))) + elem))) + (nreverse result))))) + (define-obsolete-function-alias 'nsm--encryption #'nsm-cipher-suite "27.1") (provide 'nsm) commit b4d3a882a8423e81c418fc56b7a9677f5582fcc7 Author: Lars Ingebrigtsen Date: Fri Aug 23 03:43:41 2019 +0200 Enable sorting paragraphs when the final paragraph has no newline * lisp/sort.el (sort-paragraphs): Ensure that when sorting paragraphs, the final paragraph ends with a newline (bug#21785). diff --git a/lisp/sort.el b/lisp/sort.el index 6ea1c44060..6ceda8e448 100644 --- a/lisp/sort.el +++ b/lisp/sort.el @@ -225,11 +225,17 @@ the sort order." (narrow-to-region beg end) (goto-char (point-min)) (sort-subr reverse - (function - (lambda () - (while (and (not (eobp)) (looking-at paragraph-separate)) - (forward-line 1)))) - 'forward-paragraph)))) + (lambda () + (while (and (not (eobp)) (looking-at paragraph-separate)) + (forward-line 1))) + (lambda () + (forward-paragraph) + ;; If the buffer doesn't end with a newline, add a + ;; newline to avoid having paragraphs being + ;; concatenated after sorting. + (when (and (eobp) + (not (bolp))) + (insert "\n"))))))) ;;;###autoload (defun sort-pages (reverse beg end) commit d08f7c41241e78b88bc2aaaa2dd323ce7512ae94 Author: Lars Ingebrigtsen Date: Thu Aug 22 17:57:07 2019 -0700 Signal an error on `M-x shell-mode' * lisp/shell.el (shell-mode): This mode can't usefully be called interactively (and is somewhat destructive, as it disables `undo'), and it's usually confused with `shell-script-mode' (bug#19812). So signal an error if it's used interactively. diff --git a/lisp/shell.el b/lisp/shell.el index 2914d1d2c8..ba7515e7ba 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -553,6 +553,8 @@ Variables `comint-output-filter-functions', a hook, and `comint-scroll-to-bottom-on-input' and `comint-scroll-to-bottom-on-output' control whether input and output cause the window to scroll to the end of the buffer." + (when (called-interactively-p 'any) + (error "Can't be called interactively; did you mean `shell-script-mode' instead?")) (setq comint-prompt-regexp shell-prompt-pattern) (shell-completion-vars) (setq-local paragraph-separate "\\'") commit 18e9cb8f431e4b7520e99854b423c25d546335be Author: Lars Ingebrigtsen Date: Thu Aug 22 17:52:07 2019 -0700 Make ibuffer-mark-by-file-name-regexp work on the displayed file name * lisp/ibuf-ext.el (ibuffer-mark-by-file-name-regexp): Perform the matching on the abbreviated (i.e., displayed) file name, and not the complete name (bug#18859). This seems like the more expected action. diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index 1b69574a39..06a2248d40 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el @@ -1846,7 +1846,8 @@ When BUF nil, default to the buffer at current line." (stringp dired-directory) dired-directory))))) (when name - (string-match regexp name)))))) + ;; Match on the displayed file name (which is abbreviated). + (string-match regexp (abbreviate-file-name name))))))) ;;;###autoload (defun ibuffer-mark-by-content-regexp (regexp &optional all-buffers) commit 6b38e34a11a85d50fa384b90ed21ea60d6d646d5 Author: Lars Ingebrigtsen Date: Fri Aug 23 02:40:26 2019 +0200 Have `M-x battery' list all batteries under GNU/Linux * lisp/battery.el (battery-upower-device): Remove (bug#25559). (battery--find-linux-sysfs-batteries): New function. (battery-status-function, battery-linux-sysfs): Use it to list all batteries, no matter what they're called. diff --git a/etc/NEWS b/etc/NEWS index 3fdc185af4..da3c29b1ac 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -507,6 +507,11 @@ current and the previous or the next line, as before. * Changes in Specialized Modes and Packages in Emacs 27.1 +--- +** On GNU/Linux, `M-x battery' will now list all batteries, no matter +what they're named, and the `battery-linux-sysfs-regexp' variable has +been removed. + ** The 'list-processes' command now includes port numbers in the network connection information (in addition to the host name). diff --git a/lisp/battery.el b/lisp/battery.el index 7037d07dcf..0ef6d37b40 100644 --- a/lisp/battery.el +++ b/lisp/battery.el @@ -38,19 +38,21 @@ :prefix "battery-" :group 'hardware) -(defcustom battery-linux-sysfs-regexp "[bB][aA][tT][0-9]?$" - "Regexp for folder names to be searched under - /sys/class/power_supply/ that contain battery information." - :version "26.1" - :type 'regexp - :group 'battery) - (defcustom battery-upower-device "battery_BAT1" "Upower battery device name." :version "26.1" :type 'string :group 'battery) +(defun battery--find-linux-sysfs-batteries () + (let ((dirs nil)) + (dolist (file (directory-files "/sys/class/power_supply/" t)) + (when (and (or (file-directory-p file) + (file-symlink-p file)) + (file-exists-p (expand-file-name "capacity" file))) + (push file dirs))) + (nreverse dirs))) + (defcustom battery-status-function (cond ((and (eq system-type 'gnu/linux) (file-readable-p "/proc/apm")) @@ -60,8 +62,7 @@ #'battery-linux-proc-acpi) ((and (eq system-type 'gnu/linux) (file-directory-p "/sys/class/power_supply/") - (directory-files "/sys/class/power_supply/" nil - battery-linux-sysfs-regexp)) + (battery--find-linux-sysfs-batteries)) #'battery-linux-sysfs) ((and (eq system-type 'berkeley-unix) (file-executable-p "/usr/sbin/apm")) @@ -449,9 +450,7 @@ The following %-sequences are provided: ;; available information together. (with-temp-buffer (dolist (dir (ignore-errors - (directory-files - "/sys/class/power_supply/" t - battery-linux-sysfs-regexp))) + (battery--find-linux-sysfs-batteries))) (erase-buffer) (ignore-errors (insert-file-contents (expand-file-name "uevent" dir))) commit 4982fd95c7d1e099f50d875ca58e92d0c24bb0df Author: Lars Ingebrigtsen Date: Fri Aug 23 02:24:55 2019 +0200 Signal `invalid-read-syntax' for "trailing garbage" * src/minibuf.c (string_to_object): Signal `invalid-read-syntax' instead of the generic `error' for "trailing garbage following expression" (bug#24649). diff --git a/src/minibuf.c b/src/minibuf.c index 14a0dbe762..f6cf47f1f2 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -169,7 +169,8 @@ string_to_object (Lisp_Object val, Lisp_Object defalt) { int c = SREF (val, i); if (c != ' ' && c != '\t' && c != '\n') - error ("Trailing garbage following expression"); + xsignal1 (Qinvalid_read_syntax, + build_string ("Trailing garbage following expression")); } } commit e8f3390dea43d55c49919a9d8595d4ea7461d877 Author: Lars Ingebrigtsen Date: Fri Aug 23 02:20:54 2019 +0200 Fix skeleton edebug spec * lisp/skeleton.el (skeleton-edebug-spec): Fix edebug spec (bug#24779). diff --git a/lisp/skeleton.el b/lisp/skeleton.el index bce73d6bfe..67fc4aae15 100644 --- a/lisp/skeleton.el +++ b/lisp/skeleton.el @@ -105,8 +105,8 @@ are integer buffer positions in the reverse order of the insertion order.") (defvar skeleton-regions) (def-edebug-spec skeleton-edebug-spec - ([&or null stringp (stringp &rest stringp) [[¬ atom] def-form]] - &rest &or "n" "_" "-" ">" "@" "&" "!" "resume:" + ([&or null stringp (stringp &rest stringp) [[¬ atom] sexp]] + &rest &or "n" "_" "-" ">" "@" "&" "!" "|" "resume:" ("quote" def-form) skeleton-edebug-spec def-form)) ;;;###autoload (defmacro define-skeleton (command documentation &rest skeleton) commit 4c084ba6b8953dac6f80148c0a20b92b6e7f6932 Author: Lars Ingebrigtsen Date: Fri Aug 23 02:07:41 2019 +0200 Run quit-window-hook from the correct buffer * lisp/window.el (quit-window): Run the hook from the buffer specified by the WINDOW parameter. diff --git a/lisp/window.el b/lisp/window.el index 334b56c8e6..cf733153b8 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -4982,7 +4982,10 @@ one. If non-nil, reset `quit-restore' parameter to nil. The functions in `quit-window-hook' will be run before doing anything else." (interactive "P") - (run-hooks 'quit-window-hook) + ;; Run the hook from the buffer implied to get any buffer-local + ;; values. + (with-current-buffer (window-buffer (window-normalize-window window)) + (run-hooks 'quit-window-hook)) (quit-restore-window window (if kill 'kill 'bury))) (defun quit-windows-on (&optional buffer-or-name kill frame) commit bb5cd7c4caf415e40836edbbc4e62b0dd411d73f Author: Eli Zaretskii Date: Thu Aug 22 20:46:31 2019 +0300 Recompute user-emacs-directory-relative defcustoms one more time * lisp/startup.el (command-line): Re-evaluate the custom-delayed predefined variables one more time after loading the user's init file. (Bug#37116) diff --git a/lisp/startup.el b/lisp/startup.el index 564428580b..ff90646d7a 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -406,6 +406,7 @@ if you have not already set `auto-save-list-file-name' yourself. Directories in the prefix will be created if necessary. Set this to nil if you want to prevent `auto-save-list-file-name' from being initialized." + :initialize 'custom-initialize-delay :type '(choice (const :tag "Don't record a session's auto save list" nil) string) :group 'auto-save) @@ -1282,8 +1283,7 @@ please check its value") ;; depends on the runtime context, in case some of them depend on ;; the window-system features. Example: blink-cursor-mode. (let (current-load-list) ; c-r-s may call defvar, and hence LOADHIST_ATTACH - (mapc 'custom-reevaluate-setting custom-delayed-init-variables) - (setq custom-delayed-init-variables nil)) + (mapc 'custom-reevaluate-setting custom-delayed-init-variables)) (normal-erase-is-backspace-setup-frame) @@ -1377,6 +1377,14 @@ please check its value") (eq face-ignored-fonts old-face-ignored-fonts)) (clear-face-cache))) + ;; Re-evaluate again the predefined variables whose initial value + ;; depends on the runtime context, in case the user init file + ;; modified user-emacs-directory. Examples: abbrev-file-name, + ;; auto-save-list-file-prefix. + (let (current-load-list) ; c-r-s may call defvar, and hence LOADHIST_ATTACH + (mapc 'custom-reevaluate-setting custom-delayed-init-variables) + (setq custom-delayed-init-variables nil)) + (setq after-init-time (current-time)) ;; Display any accumulated warnings after all functions in ;; `after-init-hook' like `desktop-read' have finalized possible commit 1f441de5fec867af069e32a5fc9b0efd50e52851 Author: Stefan Kangas Date: Thu Aug 22 19:15:30 2019 +0200 Fix minor checkdoc errors in package.el * lisp/emacs-lisp/package.el (package-all-keywords) (package-menu--generate, package-archive-priority): Doc fixes. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 4e0c0464d4..cd127e1a8e 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2894,7 +2894,7 @@ KEYWORDS should be nil or a list of keywords." (mapcar #'package-menu--print-info-simple info-list)))) (defun package-all-keywords () - "Collect all package keywords" + "Collect all package keywords." (let ((key-list)) (package--mapc (lambda (desc) (setq key-list (append (package-desc--keywords desc) @@ -2951,7 +2951,7 @@ When none are given, the package matches." (defun package-menu--generate (remember-pos packages &optional keywords) "Populate the Package Menu. - If REMEMBER-POS is non-nil, keep point on the same entry. +If REMEMBER-POS is non-nil, keep point on the same entry. PACKAGES should be t, which means to display all known packages, or a list of package names (symbols) to display. @@ -3209,7 +3209,7 @@ The full list of keys can be viewed with \\[describe-mode]." "Return the priority of ARCHIVE. The archive priorities are specified in -`package-archive-priorities'. If not given there, the priority +`package-archive-priorities'. If not given there, the priority defaults to 0." (or (cdr (assoc archive package-archive-priorities)) 0)) commit a6d87ea045d9df73f70765bedfb02522043efd9b Author: Stefan Kangas Date: Wed Jul 17 19:55:08 2019 +0200 Signal user-error on duplicate package refresh * lisp/emacs-lisp/package.el (package-menu-refresh): Signal a user-error if there is already a refresh running in the background. Doc fix. (Bug#36707) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index a72522ad8f..4e0c0464d4 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -3086,12 +3086,15 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." "`package-archive-contents' before the latest refresh.") (defun package-menu-refresh () - "Download the Emacs Lisp package archive. -This fetches the contents of each archive specified in -`package-archives', and then refreshes the package menu." + "In Package Menu, download the Emacs Lisp package archive. +Fetch the contents of each archive specified in +`package-archives', and then refresh the package menu. Signal a +user-error if there is already a refresh running asynchronously." (interactive) (unless (derived-mode-p 'package-menu-mode) (user-error "The current buffer is not a Package Menu")) + (when (and package-menu-async package--downloads-in-progress) + (user-error "Package refresh is already in progress, please wait...")) (setq package-menu--old-archive-contents package-archive-contents) (setq package-menu--new-package-list nil) (package-refresh-contents package-menu-async)) commit b289ceaf79dc9b284ed254854fc23106e1df0264 Author: Stefan Kangas Date: Thu Aug 22 17:01:39 2019 +0200 * doc/misc/efaq.texi: Note the inclusion year. (Bug#37142) diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi index 8fd3bf3a45..df244a71c8 100644 --- a/doc/misc/efaq.texi +++ b/doc/misc/efaq.texi @@ -34,7 +34,7 @@ the FAQ may not be embedded in a larger literary work unless that work itself allows free copying and redistribution. [This version has been heavily edited since it was included in the Emacs -distribution.] +distribution in 1999.] @end quotation @end copying commit d9b83465c7c392d36bcbe44ccc6b66e3bec22b2d Author: Eli Zaretskii Date: Thu Aug 22 17:49:40 2019 +0300 Improve documentation of 'ispell-skip-html' * lisp/textmodes/ispell.el (ispell-skip-html): Doc fix. (Bug#37141) diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el index 9dfa9f3c44..5c77e03b0b 100644 --- a/lisp/textmodes/ispell.el +++ b/lisp/textmodes/ispell.el @@ -394,7 +394,12 @@ for language-specific arguments." "Indicates whether ispell should skip spell checking of SGML markup. If t, always skip SGML markup; if nil, never skip; if non-t and non-nil, guess whether SGML markup should be skipped according to the name of the -buffer's major mode." +buffer's major mode. + +SGML markup is any text inside the brackets \"<>\" or entities +such as \"&\". See `ispell-html-skip-alists' for more details. + +This variable affects spell-checking of HTML, XML, and SGML files." :type '(choice (const :tag "always" t) (const :tag "never" nil) (const :tag "use-mode-name" use-mode-name)) :group 'ispell) commit ef8531d262081d91ecf2a4f349bc63a0fede90d4 Author: Michael Albinus Date: Thu Aug 22 14:50:38 2019 +0200 * doc/misc/tramp.texi: Use @acronym{GVFS}. diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index d48fa319fb..e6a454be4c 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -125,7 +125,7 @@ Configuring @value{tramp} for use * Connection types:: Types of connections to remote hosts. * Inline methods:: Inline methods. * External methods:: External methods. -* GVFS based methods:: GVFS based external methods. +* GVFS-based methods:: @acronym{GVFS}-based external methods. * Default Method:: Selecting a default method. * Default User:: Selecting a default user. * Default Host:: Selecting a default host. @@ -545,9 +545,9 @@ of the local file name is the share exported by the remote host, @anchor{Quick Start Guide: GVFS-based methods} -@section Using GVFS-based methods +@section Using @acronym{GVFS}-based methods @cindex methods, gvfs -@cindex gvfs based methods +@cindex gvfs-based methods @cindex method @option{sftp} @cindex @option{sftp} method @cindex method @option{afp} @@ -557,10 +557,9 @@ of the local file name is the share exported by the remote host, @cindex @option{dav} method @cindex @option{davs} method -On systems, which have installed the virtual file system for the -@acronym{GNOME} Desktop (GVFS), its offered methods could be used by -@value{tramp}. Examples are -@file{@trampfn{sftp,user@@host,/path/to/file}}, +On systems, which have installed @acronym{GVFS, the GNOME Virtual File +System}, its offered methods could be used by @value{tramp}. Examples +are @file{@trampfn{sftp,user@@host,/path/to/file}}, @file{@trampfn{afp,user@@host,/path/to/file}} (accessing Apple's AFP file system), @file{@trampfn{dav,user@@host,/path/to/file}} and @file{@trampfn{davs,user@@host,/path/to/file}} (for WebDAV shares). @@ -576,10 +575,10 @@ file system), @file{@trampfn{dav,user@@host,/path/to/file}} and @cindex @option{nextcloud} method @cindex nextcloud -GVFS-based methods include also @acronym{GNOME} Online Accounts, which -support the @option{Files} service. These are the Google Drive file -system, and the OwnCloud/NextCloud file system. The file name syntax -is here always +@acronym{GVFS}-based methods include also @acronym{GNOME} Online +Accounts, which support the @option{Files} service. These are the +Google Drive file system, and the OwnCloud/NextCloud file system. The +file name syntax is here always @file{@trampfn{gdrive,john.doe@@gmail.com,/path/to/file}} (@samp{john.doe@@gmail.com} stands here for your Google Drive account), or @file{@trampfn{nextcloud,user@@host#8081,/path/to/file}} @@ -645,7 +644,7 @@ might be used in your init file: * Connection types:: Types of connections to remote hosts. * Inline methods:: Inline methods. * External methods:: External methods. -* GVFS based methods:: GVFS based external methods. +* GVFS-based methods:: @acronym{GVFS}-based external methods. * Default Method:: Selecting a default method. Here we also try to help those who don't have the foggiest which method @@ -1170,8 +1169,8 @@ information}. Supported properties are @samp{mount-args}, @samp{copyto-args} and @samp{moveto-args}. Access via @option{rclone} is slow. If you have an alternative method -for accessing the system storage, you shall prefer this. @ref{GVFS -based methods} for example, methods @option{gdrive} and +for accessing the system storage, you shall prefer this. +@ref{GVFS-based methods} for example, methods @option{gdrive} and @option{nextcloud}. @strong{Note}: The @option{rclone} method is experimental, don't use @@ -1180,20 +1179,20 @@ it in production systems! @end table -@node GVFS based methods -@section GVFS based external methods +@node GVFS-based methods +@section @acronym{GVFS}-based external methods @cindex methods, gvfs -@cindex gvfs based methods +@cindex gvfs-based methods @cindex dbus -GVFS is the virtual file system for the @acronym{GNOME} Desktop, -@uref{https://en.wikipedia.org/wiki/GVFS}. Remote files on GVFS are -mounted locally through FUSE and @value{tramp} uses this locally -mounted directory internally. +@acronym{GVFS} is the virtual file system for the @acronym{GNOME} +Desktop, @uref{https://en.wikipedia.org/wiki/GVFS}. Remote files on +@acronym{GVFS} are mounted locally through FUSE and @value{tramp} uses +this locally mounted directory internally. -Emacs uses the D-Bus mechanism to communicate with GVFS@. Emacs must -have the message bus system, D-Bus integration active, @pxref{Top, , -D-Bus, dbus}. +Emacs uses the D-Bus mechanism to communicate with @acronym{GVFS}@. +Emacs must have the message bus system, D-Bus integration active, +@pxref{Top, , D-Bus, dbus}. @table @asis @item @option{afp} @@ -1216,9 +1215,10 @@ syntax requires a leading volume (share) name, for example: based on standard protocols, such as HTTP@. @option{davs} does the same but with SSL encryption. Both methods support the port numbers. -Paths being part of the WebDAV volume to be mounted by GVFS, as it is -common for OwnCloud or NextCloud file names, are not supported by -these methods. See method @option{nextcloud} for handling them. +Paths being part of the WebDAV volume to be mounted by @acronym{GVFS}, +as it is common for OwnCloud or NextCloud file names, are not +supported by these methods. See method @option{nextcloud} for +handling them. @item @option{gdrive} @cindex method @option{gdrive} @@ -1259,18 +1259,19 @@ that for security reasons refuse @command{ssh} connections. @end table @defopt tramp-gvfs-methods -This user option is a list of external methods for GVFS@. By default, -this list includes @option{afp}, @option{dav}, @option{davs}, -@option{gdrive}, @option{nextcloud} and @option{sftp}. Other methods -to include are @option{ftp}, @option{http}, @option{https} and -@option{smb}. These methods are not intended to be used directly as -GVFS based method. Instead, they are added here for the benefit of -@ref{Archive file names}. - -If you want to use GVFS-based @option{ftp} or @option{smb} methods, -you must add them to @code{tramp-gvfs-methods}, and you must disable -the corresponding Tramp package by setting @code{tramp-ftp-method} or -@code{tramp-smb-method} to @code{nil}, respectively: +This user option is a list of external methods for @acronym{GVFS}@. +By default, this list includes @option{afp}, @option{dav}, +@option{davs}, @option{gdrive}, @option{nextcloud} and @option{sftp}. +Other methods to include are @option{ftp}, @option{http}, +@option{https} and @option{smb}. These methods are not intended to be +used directly as @acronym{GVFS}-based method. Instead, they are added +here for the benefit of @ref{Archive file names}. + +If you want to use @acronym{GVFS}-based @option{ftp} or @option{smb} +methods, you must add them to @code{tramp-gvfs-methods}, and you must +disable the corresponding Tramp package by setting +@code{tramp-ftp-method} or @code{tramp-smb-method} to @code{nil}, +respectively: @lisp @group @@ -2937,9 +2938,10 @@ host when the variable @code{default-directory} is remote: @end group @end lisp -Remote processes do not apply to GVFS (see @ref{GVFS based methods}) -because the remote file system is mounted on the local host and -@value{tramp} just accesses by changing the @code{default-directory}. +Remote processes do not apply to @acronym{GVFS} (see @ref{GVFS-based +methods}) because the remote file system is mounted on the local host +and @value{tramp} just accesses by changing the +@code{default-directory}. @value{tramp} starts a remote process when a command is executed in a remote file or directory buffer. As of now, these packages have been @@ -3323,10 +3325,10 @@ killing all buffers related to remote connections. @cindex archive method @value{tramp} offers also transparent access to files inside file -archives. This is possible only on machines which have installed the -virtual file system for the @acronym{GNOME} Desktop (GVFS), @ref{GVFS -based methods}. Internally, file archives are mounted via the GVFS -@option{archive} method. +archives. This is possible only on machines which have installed +@acronym{GVFS, the GNOME Virtual File System}, @ref{GVFS-based +methods}. Internally, file archives are mounted via the +@acronym{GVFS} @option{archive} method. A file archive is a regular file of kind @file{/path/to/dir/file.EXT}. The extension @samp{.EXT} identifies the type of the file archive. A @@ -3349,9 +3351,9 @@ file names as well. @vindex tramp-archive-suffixes File archives are identified by the file name extension @samp{.EXT}. -Since GVFS uses internally the library @code{libarchive(3)}, all -suffixes, which are accepted by this library, work also for archive -file names. Accepted suffixes are listed in the constant +Since @acronym{GVFS} uses internally the library @code{libarchive(3)}, +all suffixes, which are accepted by this library, work also for +archive file names. Accepted suffixes are listed in the constant @code{tramp-archive-suffixes}. They are @itemize @@ -3519,11 +3521,11 @@ row are possible, like @file{/path/to/dir/file.tar.gz.uu/dir/file}. @vindex tramp-archive-all-gvfs-methods An archive file name could be a remote file name, as in @file{/ftp:anonymous@@ftp.gnu.org:/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL}. -Since all file operations are mapped internally to GVFS operations, -remote file names supported by @code{tramp-gvfs} perform better, -because no local copy of the file archive must be downloaded first. -For example, @samp{/sftp:user@@host:...} performs better than the -similar @samp{/scp:user@@host:...}. See the constant +Since all file operations are mapped internally to @acronym{GVFS} +operations, remote file names supported by @code{tramp-gvfs} perform +better, because no local copy of the file archive must be downloaded +first. For example, @samp{/sftp:user@@host:...} performs better than +the similar @samp{/scp:user@@host:...}. See the constant @code{tramp-archive-all-gvfs-methods} for a complete list of @code{tramp-gvfs} supported method names. commit e5defc3e0fc753231d04db514d650c731d12bf1e Author: Paul Eggert Date: Thu Aug 22 01:22:10 2019 -0700 Fix Qunbound-Qnil confusion in clrhash patch Problem reported by Stefan Monnier. * src/fns.c (hash_clear): Fix typo I introduced in my previous patch here, by setting keys to Qunbound not Qnil. diff --git a/src/fns.c b/src/fns.c index 8ca0953fe8..4fb33500bf 100644 --- a/src/fns.c +++ b/src/fns.c @@ -4406,9 +4406,12 @@ hash_clear (struct Lisp_Hash_Table *h) ptrdiff_t size = HASH_TABLE_SIZE (h); if (!hash_rehash_needed_p (h)) memclear (XVECTOR (h->hash)->contents, size * word_size); - memclear (XVECTOR (h->key_and_value)->contents, size * 2 * word_size); for (ptrdiff_t i = 0; i < size; i++) - set_hash_next_slot (h, i, i < size - 1 ? i + 1 : -1); + { + set_hash_next_slot (h, i, i < size - 1 ? i + 1 : -1); + set_hash_key_slot (h, i, Qunbound); + set_hash_value_slot (h, i, Qnil); + } for (ptrdiff_t i = 0; i < ASIZE (h->index); i++) ASET (h->index, i, make_fixnum (-1)); commit 7d15079c7e819dd7862b3f35df16e175802ca7a2 Author: Paul Eggert Date: Wed Aug 21 22:29:35 2019 -0700 Remove no-longer-needed workaround for GC bug * src/keymap.c (describe_vector): Remove old workaround for GC bug. This workaround, introduced in 1993-02-19T05:43:54Z!rms@gnu.org, has not been needed for some time. Problem reported by Pip Cet in: https://lists.gnu.org/r/emacs-devel/2019-08/msg00316.html diff --git a/src/keymap.c b/src/keymap.c index 6762915f70..b1e09a92f2 100644 --- a/src/keymap.c +++ b/src/keymap.c @@ -3371,12 +3371,10 @@ describe_vector (Lisp_Object vector, Lisp_Object prefix, Lisp_Object args, if (!keymap_p) { - /* Call Fkey_description first, to avoid GC bug for the other string. */ if (!NILP (prefix) && XFIXNAT (Flength (prefix)) > 0) { - Lisp_Object tem = Fkey_description (prefix, Qnil); AUTO_STRING (space, " "); - elt_prefix = concat2 (tem, space); + elt_prefix = concat2 (Fkey_description (prefix, Qnil), space); } prefix = Qnil; } commit 2b552f34892ee3c73f4b5fb5380218dc6ebbf4bb Author: Paul Eggert Date: Wed Aug 21 22:19:03 2019 -0700 Don’t debug fset by default This GC bug seems to have been fixed, so the check is no longer needed in production code. From a suggestion by Pip Cet in: https://lists.gnu.org/r/emacs-devel/2019-08/msg00316.html * src/alloc.c (SUSPICIOUS_OBJECT_CHECKING) [!ENABLE_CHECKING]: Do not define. (find_suspicious_object_in_range, detect_suspicious_free): Expand to proper dummy expressions if !SUSPICIOUS_OBJECT_CHECKING. * src/data.c (Ffset): Convert test to an eassert. diff --git a/src/alloc.c b/src/alloc.c index 53af7325f4..39964c4b29 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -302,15 +302,11 @@ static intptr_t garbage_collection_inhibited; const char *pending_malloc_warning; -#if 0 /* Normally, pointer sanity only on request... */ +/* Pointer sanity only on request. FIXME: Code depending on + SUSPICIOUS_OBJECT_CHECKING is obsolete; remove it entirely. */ #ifdef ENABLE_CHECKING #define SUSPICIOUS_OBJECT_CHECKING 1 #endif -#endif - -/* ... but unconditionally use SUSPICIOUS_OBJECT_CHECKING while the GC - bug is unresolved. */ -#define SUSPICIOUS_OBJECT_CHECKING 1 #ifdef SUSPICIOUS_OBJECT_CHECKING struct suspicious_free_record @@ -327,8 +323,8 @@ static int suspicious_free_history_index; static void *find_suspicious_object_in_range (void *begin, void *end); static void detect_suspicious_free (void *ptr); #else -# define find_suspicious_object_in_range(begin, end) NULL -# define detect_suspicious_free(ptr) (void) +# define find_suspicious_object_in_range(begin, end) ((void *) NULL) +# define detect_suspicious_free(ptr) ((void) 0) #endif /* Maximum amount of C stack to save when a GC happens. */ diff --git a/src/data.c b/src/data.c index 8344bfdd3d..2797adfcdc 100644 --- a/src/data.c +++ b/src/data.c @@ -771,10 +771,7 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0, if (AUTOLOADP (function)) Fput (symbol, Qautoload, XCDR (function)); - /* Convert to eassert or remove after GC bug is found. In the - meantime, check unconditionally, at a slight perf hit. */ - if (! valid_lisp_object_p (definition)) - emacs_abort (); + eassert (valid_lisp_object_p (definition)); set_symbol_function (symbol, definition); commit ceebf3efbea7faffc01558d88c91250539c737e0 Author: Paul Eggert Date: Wed Aug 21 18:54:08 2019 -0700 Fix clrhash bug when hash table needs rehashing Problem reported by Pip Cet in: https://lists.gnu.org/r/emacs-devel/2019-08/msg00316.html * src/fns.c (maybe_resize_hash_table): Prefer ASET to gc_aset where either will do. Simplify appending of Qunbound values. Put index_size calculation closer to where it’s needed. (hash_clear): If hash_rehash_needed_p (h), don’t clear the nonexistent hash vector. Use memclear to speed up clearing. * src/lisp.h (HASH_TABLE_SIZE): Check that the size is positive, and tell that to the compiler. diff --git a/src/fns.c b/src/fns.c index b606d6299c..8ca0953fe8 100644 --- a/src/fns.c +++ b/src/fns.c @@ -4198,21 +4198,20 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h) new_size); ptrdiff_t next_size = ASIZE (next); for (ptrdiff_t i = old_size; i < next_size - 1; i++) - gc_aset (next, i, make_fixnum (i + 1)); - gc_aset (next, next_size - 1, make_fixnum (-1)); - ptrdiff_t index_size = hash_index_size (h, next_size); + ASET (next, i, make_fixnum (i + 1)); + ASET (next, next_size - 1, make_fixnum (-1)); /* Build the new&larger key_and_value vector, making sure the new fields are initialized to `unbound`. */ Lisp_Object key_and_value = larger_vecalloc (h->key_and_value, 2 * (next_size - old_size), 2 * next_size); - for (ptrdiff_t i = ASIZE (h->key_and_value); - i < ASIZE (key_and_value); i++) + for (ptrdiff_t i = 2 * old_size; i < 2 * next_size; i++) ASET (key_and_value, i, Qunbound); Lisp_Object hash = larger_vector (h->hash, next_size - old_size, next_size); + ptrdiff_t index_size = hash_index_size (h, next_size); h->index = make_vector (index_size, make_fixnum (-1)); h->key_and_value = key_and_value; h->hash = hash; @@ -4404,17 +4403,14 @@ hash_clear (struct Lisp_Hash_Table *h) { if (h->count > 0) { - ptrdiff_t i, size = HASH_TABLE_SIZE (h); - - for (i = 0; i < size; ++i) - { - set_hash_next_slot (h, i, i < size - 1 ? i + 1 : -1); - set_hash_key_slot (h, i, Qunbound); - set_hash_value_slot (h, i, Qnil); - set_hash_hash_slot (h, i, Qnil); - } - - for (i = 0; i < ASIZE (h->index); ++i) + ptrdiff_t size = HASH_TABLE_SIZE (h); + if (!hash_rehash_needed_p (h)) + memclear (XVECTOR (h->hash)->contents, size * word_size); + memclear (XVECTOR (h->key_and_value)->contents, size * 2 * word_size); + for (ptrdiff_t i = 0; i < size; i++) + set_hash_next_slot (h, i, i < size - 1 ? i + 1 : -1); + + for (ptrdiff_t i = 0; i < ASIZE (h->index); i++) ASET (h->index, i, make_fixnum (-1)); h->next_free = 0; diff --git a/src/lisp.h b/src/lisp.h index 56ad99b8e3..ae5a81e7b5 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2307,7 +2307,7 @@ struct Lisp_Hash_Table weakness of the table. */ Lisp_Object weak; - /* Vector of hash codes. + /* Vector of hash codes, or nil if the table needs rehashing. If the I-th entry is unused, then hash[I] should be nil. */ Lisp_Object hash; @@ -2327,8 +2327,7 @@ struct Lisp_Hash_Table 'index' are special and are either ignored by the GC or traced in a special way (e.g. because of weakness). */ - /* Number of key/value entries in the table. This number is - negated if the table needs rehashing. */ + /* Number of key/value entries in the table. */ ptrdiff_t count; /* Index of first free entry in free list, or -1 if none. */ @@ -2413,7 +2412,9 @@ HASH_HASH (const struct Lisp_Hash_Table *h, ptrdiff_t idx) INLINE ptrdiff_t HASH_TABLE_SIZE (const struct Lisp_Hash_Table *h) { - return ASIZE (h->next); + ptrdiff_t size = ASIZE (h->next); + eassume (0 < size); + return size; } void hash_table_rehash (struct Lisp_Hash_Table *h); commit c64c0230d65260f44f367bac72bfdee50c52a90d Author: Paul Eggert Date: Wed Aug 21 17:19:53 2019 -0700 * src/buffer.c: Fix comment typo. diff --git a/src/buffer.c b/src/buffer.c index ea785bbcd7..62a3d66c8b 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -4568,7 +4568,7 @@ report_overlay_modification (Lisp_Object start, Lisp_Object end, bool after, prop_i = copy[i++]; overlay_i = copy[i++]; /* It is possible that the recorded overlay has been deleted - (which makes it's markers' buffers be nil), or that (due to + (which makes its markers' buffers be nil), or that (due to some bug) it belongs to a different buffer. Only run this hook if the overlay belongs to the current buffer. */ if (XMARKER (OVERLAY_START (overlay_i))->buffer == current_buffer) commit 951ea375d52891f79b89794fbb9dca86ab8cd5a8 Author: Paul Eggert Date: Wed Aug 21 17:18:33 2019 -0700 Don’t hard-loop on cycles in ‘read’ etc. Problem for ‘read’ reported by Pip Cet in: https://lists.gnu.org/r/emacs-devel/2019-08/msg00316.html * src/fns.c (Frequire): Protect against circular current-load-list. * src/lread.c (Fget_load_suffixes): Protect against circular load-suffixes or load-file-rep-suffixes. (Fload): Protect against circular loads-in-progress. (openp): Protect against circular PATH and SUFFIXES. (build_load_history): Protect against circular load-history or current-load-list. (readevalloop_eager_expand_eval): Protect against circular SUBFORMS. (read1): Protect against circular data. * test/src/lread-tests.el (lread-circular-hash): New test. diff --git a/src/fns.c b/src/fns.c index 6c47b3e5b1..b606d6299c 100644 --- a/src/fns.c +++ b/src/fns.c @@ -2950,9 +2950,12 @@ suppressed. */) But not more than once in any file, and not when we aren't loading or reading from a file. */ if (!from_file) - for (tem = Vcurrent_load_list; CONSP (tem); tem = XCDR (tem)) - if (NILP (XCDR (tem)) && STRINGP (XCAR (tem))) - from_file = 1; + { + Lisp_Object tail = Vcurrent_load_list; + FOR_EACH_TAIL_SAFE (tail) + if (NILP (XCDR (tail)) && STRINGP (XCAR (tail))) + from_file = true; + } if (from_file) { diff --git a/src/lread.c b/src/lread.c index 1bfbf5aa86..e444830c99 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1064,18 +1064,13 @@ required. This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */) (void) { - Lisp_Object lst = Qnil, suffixes = Vload_suffixes, suffix, ext; - while (CONSP (suffixes)) + Lisp_Object lst = Qnil, suffixes = Vload_suffixes; + FOR_EACH_TAIL (suffixes) { Lisp_Object exts = Vload_file_rep_suffixes; - suffix = XCAR (suffixes); - suffixes = XCDR (suffixes); - while (CONSP (exts)) - { - ext = XCAR (exts); - exts = XCDR (exts); - lst = Fcons (concat2 (suffix, ext), lst); - } + Lisp_Object suffix = XCAR (suffixes); + FOR_EACH_TAIL (exts) + lst = Fcons (concat2 (suffix, XCAR (exts)), lst); } return Fnreverse (lst); } @@ -1290,8 +1285,8 @@ Return t if the file exists and loads successfully. */) the general case; the second load may do something different. */ { int load_count = 0; - Lisp_Object tem; - for (tem = Vloads_in_progress; CONSP (tem); tem = XCDR (tem)) + Lisp_Object tem = Vloads_in_progress; + FOR_EACH_TAIL_SAFE (tem) if (!NILP (Fequal (found, XCAR (tem))) && (++load_count > 3)) signal_error ("Recursive load", Fcons (found, Vloads_in_progress)); record_unwind_protect (record_load_unwind, Vloads_in_progress); @@ -1611,7 +1606,8 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, CHECK_STRING (str); - for (tail = suffixes; CONSP (tail); tail = XCDR (tail)) + tail = suffixes; + FOR_EACH_TAIL_SAFE (tail) { CHECK_STRING_CAR (tail); max_suffix_len = max (max_suffix_len, @@ -1625,12 +1621,17 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, absolute = complete_filename_p (str); + AUTO_LIST1 (just_use_str, Qnil); + if (NILP (path)) + path = just_use_str; + /* Go through all entries in the path and see whether we find the executable. */ - do { + FOR_EACH_TAIL_SAFE (path) + { ptrdiff_t baselen, prefixlen; - if (NILP (path)) + if (EQ (path, just_use_str)) filename = str; else filename = Fexpand_file_name (str, XCAR (path)); @@ -1663,8 +1664,9 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, memcpy (fn, SDATA (filename) + prefixlen, baselen); /* Loop over suffixes. */ - for (tail = NILP (suffixes) ? list1 (empty_unibyte_string) : suffixes; - CONSP (tail); tail = XCDR (tail)) + AUTO_LIST1 (empty_string_only, empty_unibyte_string); + tail = NILP (suffixes) ? empty_string_only : suffixes; + FOR_EACH_TAIL_SAFE (tail) { Lisp_Object suffix = XCAR (tail); ptrdiff_t fnlen, lsuffix = SBYTES (suffix); @@ -1808,10 +1810,9 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, } } } - if (absolute || NILP (path)) + if (absolute) break; - path = XCDR (path); - } while (CONSP (path)); + } SAFE_FREE (); errno = last_errno; @@ -1838,7 +1839,7 @@ build_load_history (Lisp_Object filename, bool entire) tail = Vload_history; prev = Qnil; - while (CONSP (tail)) + FOR_EACH_TAIL (tail) { tem = XCAR (tail); @@ -1861,22 +1862,19 @@ build_load_history (Lisp_Object filename, bool entire) { tem2 = Vcurrent_load_list; - while (CONSP (tem2)) + FOR_EACH_TAIL (tem2) { newelt = XCAR (tem2); if (NILP (Fmember (newelt, tem))) Fsetcar (tail, Fcons (XCAR (tem), Fcons (newelt, XCDR (tem)))); - - tem2 = XCDR (tem2); maybe_quit (); } } } else prev = tail; - tail = XCDR (tail); maybe_quit (); } @@ -1918,10 +1916,9 @@ readevalloop_eager_expand_eval (Lisp_Object val, Lisp_Object macroexpand) if (EQ (CAR_SAFE (val), Qprogn)) { Lisp_Object subforms = XCDR (val); - - for (val = Qnil; CONSP (subforms); subforms = XCDR (subforms)) - val = readevalloop_eager_expand_eval (XCAR (subforms), - macroexpand); + val = Qnil; + FOR_EACH_TAIL (subforms) + val = readevalloop_eager_expand_eval (XCAR (subforms), macroexpand); } else val = eval_sub (call2 (macroexpand, val, Qt)); @@ -2861,16 +2858,19 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) /* Now use params to make a new hash table and fill it. */ ht = Fmake_hash_table (param_count, params); - while (CONSP (data)) - { + Lisp_Object last = data; + FOR_EACH_TAIL_SAFE (data) + { key = XCAR (data); data = XCDR (data); if (!CONSP (data)) - error ("Odd number of elements in hash table data"); + break; val = XCAR (data); - data = XCDR (data); + last = XCDR (data); Fputhash (key, val, ht); - } + } + if (!NILP (last)) + error ("Hash table data is not a list of even length"); return ht; } diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el index 82b75b195c..ba5bfe0145 100644 --- a/test/src/lread-tests.el +++ b/test/src/lread-tests.el @@ -220,4 +220,7 @@ literals (Bug#20852)." (* most-positive-fixnum most-positive-fixnum))) (should (= n (string-to-number (format "%d." n)))))) +(ert-deftest lread-circular-hash () + (should-error (read "#s(hash-table data #0=(#0# . #0#))"))) + ;;; lread-tests.el ends here commit 96dd0196c28bc36779584e47fffcca433c9309cd (tag: refs/tags/emacs-26.3-rc1, tag: refs/tags/emacs-26.3) Author: Nicolas Petton Date: Thu Aug 22 00:40:13 2019 +0200 * etc/HISTORY: Add Emacs 26.3 release release date. diff --git a/etc/HISTORY b/etc/HISTORY index bf03692d3f..6cda28d15a 100644 --- a/etc/HISTORY +++ b/etc/HISTORY @@ -218,6 +218,8 @@ GNU Emacs 26.1 (2018-05-28) emacs-26.1 GNU Emacs 26.2 (2019-04-12) emacs-26.2 +GNU Emacs 26.3 (2019-08-28) emacs-26.3 + ---------------------------------------------------------------------- This file is part of GNU Emacs. commit 4e59ad59a2ec098cd33294aeba5769ff8cd96110 Author: Nicolas Petton Date: Thu Aug 22 00:38:54 2019 +0200 Bump Emacs version to 26.3 * README: * configure.ac: * msdos/sed2v2.inp: * nt/README.W32: Bump Emacs version. diff --git a/README b/README index b1e0111028..1c4341de03 100644 --- a/README +++ b/README @@ -2,7 +2,7 @@ Copyright (C) 2001-2019 Free Software Foundation, Inc. See the end of the file for license conditions. -This directory tree holds version 26.2.90 of GNU Emacs, the extensible, +This directory tree holds version 26.3 of GNU Emacs, the extensible, customizable, self-documenting real-time display editor. The file INSTALL in this directory says how to build and install GNU diff --git a/configure.ac b/configure.ac index a79b322ecd..ebf24c8657 100644 --- a/configure.ac +++ b/configure.ac @@ -23,7 +23,7 @@ dnl along with GNU Emacs. If not, see . AC_PREREQ(2.65) dnl Note this is parsed by (at least) make-dist and lisp/cedet/ede/emacs.el. -AC_INIT(GNU Emacs, 26.2.90, bug-gnu-emacs@gnu.org) +AC_INIT(GNU Emacs, 26.3, bug-gnu-emacs@gnu.org) dnl Set emacs_config_options to the options of 'configure', quoted for the shell, dnl and then quoted again for a C string. Separate options with spaces. diff --git a/msdos/sed2v2.inp b/msdos/sed2v2.inp index 886fcb1747..f010892129 100644 --- a/msdos/sed2v2.inp +++ b/msdos/sed2v2.inp @@ -66,7 +66,7 @@ /^#undef PACKAGE_NAME/s/^.*$/#define PACKAGE_NAME ""/ /^#undef PACKAGE_STRING/s/^.*$/#define PACKAGE_STRING ""/ /^#undef PACKAGE_TARNAME/s/^.*$/#define PACKAGE_TARNAME ""/ -/^#undef PACKAGE_VERSION/s/^.*$/#define PACKAGE_VERSION "26.2.90"/ +/^#undef PACKAGE_VERSION/s/^.*$/#define PACKAGE_VERSION "26.3"/ /^#undef SYSTEM_TYPE/s/^.*$/#define SYSTEM_TYPE "ms-dos"/ /^#undef HAVE_DECL_GETENV/s/^.*$/#define HAVE_DECL_GETENV 1/ /^#undef SYS_SIGLIST_DECLARED/s/^.*$/#define SYS_SIGLIST_DECLARED 1/ diff --git a/nt/README.W32 b/nt/README.W32 index 501ad45f73..1ba4081a68 100644 --- a/nt/README.W32 +++ b/nt/README.W32 @@ -1,7 +1,7 @@ Copyright (C) 2001-2019 Free Software Foundation, Inc. See the end of the file for license conditions. - Emacs version 26.2.90 for MS-Windows + Emacs version 26.3 for MS-Windows This README file describes how to set up and run a precompiled distribution of the latest version of GNU Emacs for MS-Windows. You commit 70829f8c22b6020321b8e63c74c31f3a4c70e431 Author: Nicolas Petton Date: Thu Aug 22 00:38:06 2019 +0200 ; ChangeLog.3 update diff --git a/ChangeLog.3 b/ChangeLog.3 index 117b57d73c..de51077a0e 100644 --- a/ChangeLog.3 +++ b/ChangeLog.3 @@ -1,3 +1,7 @@ +2019-08-22 Nicolas Petton + + * etc/AUTHORS: Update. + 2019-08-21 Nicolas Petton * etc/NEWS: Delete temporary markup. @@ -66510,7 +66514,7 @@ This file records repository revisions from commit 9d56a21e6a696ad19ac65c4b405aeca44785884a (exclusive) to -commit e8f176b6423a1b4d456e2c332415c32982ff4553 (inclusive). +commit a6d0172e8330a5683517eba78356d4c70ad979d7 (inclusive). See ChangeLog.1 for earlier changes. ;; Local Variables: commit a6d0172e8330a5683517eba78356d4c70ad979d7 Author: Nicolas Petton Date: Thu Aug 22 00:15:11 2019 +0200 * etc/AUTHORS: Update. diff --git a/etc/AUTHORS b/etc/AUTHORS index 9fa657337a..7e18fa9ff0 100644 --- a/etc/AUTHORS +++ b/etc/AUTHORS @@ -441,10 +441,10 @@ Bartosz Duszel: changed allout.el bib-mode.el cc-cmds.el hexl.el icon.el xscheme.el Basil L. Contovounesios: changed simple.el message.el customize.texi - internals.texi sequences.texi bibtex.el css-mode-tests.el css-mode.el - display.texi electric.el eval.texi functions.texi gnus-art.el - gnus-gravatar.el gnus.texi gravatar.el ibuffer.el image-tests.el - image.el indent.el json-tests.el and 14 other files + gnus.texi internals.texi sequences.texi bibtex.el css-mode-tests.el + css-mode.el display.texi electric.el eval.texi functions.texi + gnus-art.el gnus-cus.el gnus-gravatar.el gravatar.el ibuffer.el + image-tests.el image.el indent.el and 16 other files Bastian Beischer: changed include.el mru-bookmark.el refs.el semantic/complete.el senator.el @@ -3281,8 +3281,8 @@ Matt Swift: changed dired.el editfns.c lisp-mode.el mm-decode.el Mauro Aranda: changed autorevert.el cc-mode.texi control.texi dbus.texi dired-x.texi eudc.texi files.texi functions.texi gnus-faq.texi - gnus.texi info.el modes.texi org.texi os.texi picture.el positions.texi - reftex.texi variables.texi + gnus.texi info.el modes.texi octave.el org.texi os.texi picture.el + pong.el positions.texi reftex.texi variables.texi Maxime Edouard Robert Froumentin: changed gnus-art.el mml.el @@ -3659,11 +3659,11 @@ and changed rsz-mini.el emacs-buffer.gdb comint.el files.el Makefile Noah Lavine: changed tramp.el -Noam Postavsky: changed lisp-mode.el progmodes/python.el xdisp.c - lisp-mode-tests.el cl-macs.el emacs-lisp/debug.el term.el bytecomp.el - data.c simple.el ert.el help-fns.el subr.el modes.texi processes.texi - cl-print.el elisp-mode.el eval.c ffap.el search.c sh-script.el - and 259 other files +Noam Postavsky: changed lisp-mode.el progmodes/python.el + lisp-mode-tests.el xdisp.c cl-macs.el term.el emacs-lisp/debug.el + bytecomp.el data.c simple.el ert.el help-fns.el processes.texi subr.el + modes.texi cl-print.el elisp-mode.el eval.c ffap.el search.c + sh-script.el and 259 other files Nobuyoshi Nakada: co-wrote ruby-mode.el @@ -4512,8 +4512,8 @@ Stefan Bruda: co-wrote prolog.el Stefan Guath: changed find-dired.el -Stefan Kangas: changed bookmark.el buffer.c fileio.c windows.texi - winner.el +Stefan Kangas: changed bookmark.el buffer.c fileio.c package-x.el + package.texi windows.texi winner.el Stefan Merten: co-wrote rst.el @@ -4857,10 +4857,10 @@ Tino Calancha: wrote buff-menu-tests.el ediff-ptch-tests.el em-ls-tests.el ffap-tests.el hi-lock-tests.el ls-lisp-tests.el register-tests.el rmc-tests.el and changed ibuffer.el dired-tests.el ibuf-ext.el dired.el dired-aux.el - simple.el replace.el ibuffer-tests.el ls-lisp.el diff-mode.el - ibuf-macs.el cl-seq.el dired-x.el dired.texi ediff-ptch.el em-ls.el - files.el replace-tests.el buff-menu.el cl.texi ediff-init.el - and 82 other files + replace.el simple.el ibuffer-tests.el ls-lisp.el diff-mode.el + ibuf-macs.el replace-tests.el cl-seq.el dired-x.el dired.texi + ediff-ptch.el em-ls.el files.el buff-menu.el cl.texi ediff-init.el + and 83 other files Titus von der Malsburg: changed simple.el window.el commit 290fe4d12281a848cb02f51d2dbf874cd30ab441 Author: Nicolas Petton Date: Thu Aug 22 00:13:37 2019 +0200 * ; ChangeLog.3 update diff --git a/ChangeLog.3 b/ChangeLog.3 index d994fcb870..117b57d73c 100644 --- a/ChangeLog.3 +++ b/ChangeLog.3 @@ -1,3 +1,546 @@ +2019-08-21 Nicolas Petton + + * etc/NEWS: Delete temporary markup. + +2019-08-20 Noam Postavsky + + Fix process filter documentation (Bug#13400) + + * doc/lispref/processes.texi (Asynchronous Processes): Note that input + may read when sending data as well. + (Output from Processes): Note that functions which send data may also + trigger reading from processes. + (Input to Processes, Filter Functions): Note that filter functions may + be called recursively. + +2019-08-19 Tino Calancha + + Fix query-replace-regexp undo feature + + Ensure that non-regexp strings used with `looking-at' are quoted. + * lisp/replace.el (perform-replace): Quote regexp (Bug#37073). + * test/lisp/replace-tests.el (replace-tests-perform-replace-regexp-flag): + New variable. + (replace-tests-with-undo): Use it. + (query-replace-undo-bug37073): Add tests. + +2019-08-18 Eli Zaretskii + + Support the new Japanese era name + + * admin/unidata/NormalizationTest.txt: + * admin/unidata/UnicodeData.txt: Add U+32FF SQUARE ERA NAME REIWA. + Do not merge to master. + + * test/lisp/international/ucs-normalize-tests.el + (ucs-normalize-tests--failing-lines-part1) + (ucs-normalize-tests--failing-lines-part2): Update. Do not + merge to master. + + * etc/NEWS: Mention the change. + +2019-08-18 Eli Zaretskii + + Fix a typo in char-width-table + + * lisp/international/characters.el (char-width-table): Fix a + typo in zero-width characters. + +2019-08-17 Eli Zaretskii + + Minor update in admin/notes/unicode + + * admin/notes/unicode: Mention changes to be done in + setup-default-fontset in fontset.el. (Bug#14461) + +2019-08-17 Noam Postavsky + + Fix lisp indent infloop on unfinished strings (Bug#37045) + + * lisp/emacs-lisp/lisp-mode.el (lisp-indent-calc-next): Stop trying to + skip over strings if we've hit the end of buffer. + * test/lisp/emacs-lisp/lisp-mode-tests.el + (lisp-indent-unfinished-string): New test. + +2019-08-17 Eli Zaretskii + + Improve commentary in composite.el + + * lisp/composite.el (compose-gstring-for-graphic) + (compose-gstring-for-terminal): Add comments that explain + Unicode General Category mnemonics in human-readable terms. + (Bug#14461) + +2019-08-16 Eli Zaretskii + + Fix markup in dired-x.texi + + * doc/misc/dired-x.texi (Omitting Variables) + (Local Variables, Shell Command Guessing) + (Advanced Cleaning Variables, Special Marking Function): Fix + markup and indexing. (Bug#14212) + +2019-08-10 Eli Zaretskii + + * src/callproc.c (Fcall_process): Doc fix. + +2019-08-10 Eli Zaretskii + + Improve documentation of features that use the fringes + + * doc/emacs/display.texi (Fringes): Add cross-reference to + where indicate-empty-lines is described. + (Useless Whitespace): Add an @anchor for a more accurate + cross-reference in "Fringes". + +2019-08-10 Mauro Aranda + + Fix docstrings in pong + + * lisp/play/pong.el (pong-move-left pong-move-right): Refer to the + right bats and directions of movement. (Bug#36959) + +2019-08-09 Eli Zaretskii + + Improve doc strings of 'append-to-buffer' and friends + + * lisp/simple.el (append-to-buffer, prepend-to-buffer) + (copy-to-buffer): Doc fixes. + +2019-08-08 Mauro Aranda + + Fix octave-mode ElDoc support + + * lisp/progmodes/octave.el (octave-eldoc-function-signatures): Fix the + regexp used, so no match happens when there is no defined function FN. + Also, tweak the regexp to support GNU Octave 4.2.x and newer. (Bug#36459) + +2019-08-08 Eli Zaretskii + + Avoid Groff hanging on MS-Windows when invoked by "M-x man" + + * lisp/man.el (Man-build-man-command): On MS-Windows, redirect + stdin of 'man' to the null device, to make sure Groff exits + immediately after formatting the man page. + +2019-08-07 Philipp Stephani + + Ignore pending_signals when checking for quits. + + pending_signals is often set if no quit is pending. This results in + bugs in module code if the module returns but no quit is actually + pending. + + * src/emacs-module.c (module_should_quit): Use QUITP macro to check + whether the caller should quit. + + * src/eval.c: Remove obsolete comment. + +2019-08-03 Basil L. Contovounesios + + Fix nnmail-expiry-wait docs and custom :types + + * doc/misc/gnus.texi (Group Parameters, Expiring Mail): + * lisp/gnus/gnus-cus.el (gnus-group-parameters): Clarify + descriptions of nnmail-expiry, nnmail-expiry-wait, and + nnmail-expiry-wait-function. + * lisp/gnus/nnmail.el (nnmail-expiry-wait) + (nnmail-expiry-wait-function): Clarify docstrings and fix custom + :types (bug#36850). + +2019-08-03 Eli Zaretskii + + * lisp/simple.el (kill-do-not-save-duplicates): Doc fix. (Bug#36827) + +2019-08-03 Eli Zaretskii + + Improve documentation of debugging Lisp syntax error + + * doc/lispref/debugging.texi (Syntax Errors, Excess Open) + (Excess Close): Name the commands invoked by the key + sequences. Add cross-references to appropriate sections of + the Emacs manual. (Bug#21385) + + (cherry picked from commit faafd467a374c9398ee4668cdc173611d35693ed) + +2019-07-30 Noam Postavsky + + Add index for "\( in strings" (Bug#25195) + + * doc/emacs/programs.texi (Left Margin Paren): Add index for "\( in + strings". + * doc/lispref/positions.texi (List Motion): Add index, and cross + reference. + +2019-07-30 Martin Rudalics + + Fix doc-string of 'fit-window-to-buffer' (Bug#36848) + + * lisp/window.el (fit-window-to-buffer): Fix doc-string. + + Suggested by Drew Adams + +2019-07-26 Tino Calancha + + Update view-mode docstring + + Not all the kill commands save the text in the kill ring + by default (e.g. `kill-rectangle'). + It is more precise to just say that the kill commands save + the text and do not change the buffer (Bug#36741). + * lisp/view.el (view-mode): Update docstring. + +2019-07-26 Noam Postavsky + + Fix subproc listening when setting filter to non-t (Bug#36591) + + * src/process.c (Fset_process_filter): Call add_process_read_fd + according to the state of process filter before it's updated. This + restores the correct functioning as it was before 2016-02-16 "Allow + setting the filter masks later". Inline the set_process_filter_masks + call instead of fixing it that function, because it is also called + from connect_network_socket, and we don't want to change the behavior + of that function so close to release. + * test/src/process-tests.el (set-process-filter-t): New test. + +2019-07-26 Noam Postavsky + + * etc/NEWS.25: Belatedly announce rcirc-reconnect-delay. + +2019-07-26 Noam Postavsky + + Mention term.el's \032 dir tracking in commentary (Bug#19524) + + * lisp/term.el: Mention both forms of directory tracking in + commentary. Remove obsolete ChangeLog comments. Move more relevant + summary comments to the top. + +2019-07-26 Stefan Kangas + + Remove upload functionality of package-x from the elisp manual + + Suggested by Stefan Monnier. + Ref: https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19537#8 + + * doc/lispref/package.texi (Package Archives): Don't document + package-x upload functions in the elisp manual, since they are not + very commonly used. (Bug#19537) + * lisp/emacs-lisp/package-x.el (package-archive-upload-base) + (package-upload-buffer, package-upload-file): Add to the doc strings + any details removed from the elisp manual that would otherwise be + missing. + +2019-07-25 Nicolas Petton + + * etc/AUTHORS: Update. + +2019-07-23 Basil L. Contovounesios + + Clarify Gravatar docs + + For discussion, see the following thread: + https://lists.gnu.org/archive/html/emacs-devel/2019-07/msg00528.html + * doc/misc/gnus.texi (X-Face): Fix cross-reference. + (Gravatars): + * lisp/gnus/gnus-gravatar.el (gnus-gravatar-too-ugly): + * lisp/image/gravatar.el (gravatar-cache-ttl, gravatar-rating) + (gravatar-size): Clarify user option descriptions. + (gravatar-retrieve, gravatar-retrieve-synchronously): Document + return value. + +2019-07-22 Alan Mackenzie + + * doc/lispref/display.texi (Defining Faces): Say a face can't be undefined. + +2019-07-21 Noam Postavsky + + Handle completely undecoded input in term (Bug#29918) + + * lisp/term.el (term-emulate-terminal): Avoid errors if the whole + decoded string is eight-bit characters. Don't attempt to save the + string for next iteration in that case. + * test/lisp/term-tests.el (term-decode-partial) + (term-undecodable-input): New tests. + +2019-07-20 N. Jackson (tiny change) + + * doc/misc/forms.texi (Control File Format): Fix a doc error. + + (Bug#36693) + +2019-07-17 Basil L. Contovounesios + + Fix typo in package-alist docstring + + Pointed out by Michael Heerdegen . + * lisp/emacs-lisp/package.el (package-alist): Fix docstring + grammar (bug#17403). + +2019-07-14 Markus Triska + + * doc/lispref/text.texi (Mode-Specific Indent): Fix a typo (bug#36646). + +2019-07-13 Eli Zaretskii + + Improve doc string of 'bidi-display-reordering' + + * src/buffer.c (syms_of_buffer) : + Further doc fix. + +2019-07-13 Stefan Kangas + + Add warning to bidi-display-reordering doc string + + This explanation was given by Eli Zaretskii on emacs-devel. + For discussion, see: + https://lists.gnu.org/archive/html/emacs-devel/2019-07/msg00294.html + + * src/buffer.c (syms_of_buffer): Add warning to doc string of + bidi-display-reordering to explain that it should only be used for + debugging. + +2019-07-12 YAMAMOTO Mitsuharu + + Raise required librsvg version so as to match the current use + + * configure.ac: Set RSVG_REQUIRED to 2.14.0 as rsvg_handle_get_dimensions + needs it. + +2019-07-10 Michael Albinus + + * lisp/net/tramp-sh.el (tramp-inline-compress-start-size): Set nil on w32. + +2019-07-09 Stefan Monnier + + * lisp/progmodes/verilog-mode.el: One more ELPA Version: + +2019-07-06 Stefan Monnier + + * lisp/svg.el, lisp/progmodes/ada-mode.el: Fix bug#36360. + + Tell package.el their version number, for better behavior w.r.t the + versions available in GNU ELPA + +2019-07-06 Eli Zaretskii + + Minor copyedit of "Font Lock" in user manual + + * doc/emacs/display.texi (Font Lock): Make the wording about + "enabling Font Lock" crystal clear. (Bug#36529) + +2019-07-06 Eli Zaretskii + + Improve description of image descriptors + + * doc/lispref/display.texi (Image Descriptors): More accurate + description of where image files are looked up. (Bug#36523) + +2019-07-06 Eli Zaretskii + + Improve documentation of secondary selections + + * doc/emacs/killing.texi (Secondary Selection): Improve + wording. Mention that 'M-mouse-1' can be used to cancel + secondary selections. (Bug#36365) + +2019-07-06 Eli Zaretskii + + * src/fns.c (Fmapconcat): Doc fix. (Bug#36418) + +2019-07-06 YAMAMOTO Mitsuharu + + Avoid crash inside CFCharacterSetIsLongCharacterMember (Bug#36507) + + * src/macfont.m (macfont_supports_charset_and_languages_p) + (macfont_has_char): Don't pass integers outside the Unicode codespace to + CFCharacterSetIsLongCharacterMember. Do not merge to master. + +2019-07-06 Noam Postavsky + + Fix python.el docstring (Bug#36458) + + * lisp/progmodes/python.el (python-shell--prompt-calculated-output-regexp): + python-shell-set-prompt-regexp doesn't exist, presumably + python-shell-prompt-set-calculated-regexps was meant. + +2019-07-03 Eli Zaretskii + + * lisp/hi-lock.el (hi-lock-line-face-buffer): Doc fix. (Bug36448) + +2019-06-29 Stefan Kangas + + Fix typo in doc string of file-exists-p (bug#36408) + + * src/fileio.c (Ffile_exists_p): Fix typo in doc string. + +2019-06-28 Juanma Barranquero + + * test/lisp/url/url-file-tests.el (url-file): Fix for POSIX filenames. + +2019-06-28 Stefan Kangas + + Fix typo in windows.texi + + * doc/lispref/windows.texi (Window History): Fix typo. (Bug#36412) + +2019-06-26 Basil L. Contovounesios + + Clarify & update (elisp) Writing Emacs Primitives + + * doc/lispref/internals.texi (Writing Emacs Primitives): Update some + of the sample code listings, fixing argument lists and parentheses. + Replace ... with @dots{}. Describe UNEVALLED special forms as + taking a single argument. (bug#36392) + +2019-06-26 Eli Zaretskii + + Clarify a subtle issue in the Internals chapter of lispref + + * doc/lispref/internals.texi (Writing Emacs Primitives): + Clarify the issue with relocation of buffer or string text as + side effect of Lisp evaluation. (Bug#36392) + +2019-06-26 Noam Postavsky + + Fix sgml-mode handling of quotes within parens (Bug#36347) + + * lisp/textmodes/sgml-mode.el (sgml-syntax-propertize): Use + syntax-ppss-table if set. This is only needed on the release branch, + on master the caller (syntax-propertize) already does this. + (sgml-mode): Set syntax-ppss-table to sgml-tag-syntax-table. This + correctly classifies parens as punctuation, so they won't confuse the + parser. + * test/lisp/textmodes/sgml-mode-tests.el (sgml-tests--quotes-syntax): + New test copied from master, with two cases added for this bug. + +2019-06-21 Juanma Barranquero + + Rename 'make-symbolic-link' argument NEWNAME to LINKNAME + + * src/fileio.c (Fmake_symbolic_link): Fix docstring. + * doc/lispref/files.texi (Changing Files): Doc fix. + +2019-06-20 Robert Pluim + + Check that length of data returned by sysctl is non-zero + + The length of the data returned by sysctl can be zero, which was not + checked for. This could cause crashes, e.g. when querying + non-existent processes. (Bug#36279) + + * src/sysdep.c (list_system_processes) [DARWIN_OS || __FreeBSD__]: + (system_process_attributes) [__FreeBSD__]: + (system_process_attributes) [DARWIN_OS]: + * src/filelock.c (get_boot_time) [CTL_KERN && KERN_BOOTTIME]: Check + for zero length data returned by sysctl. + +2019-06-17 Juanma Barranquero + + * test/lisp/progmodes/python-tests.el (python-virt-bin): Doc fix. + +2019-06-17 Juanma Barranquero + + Fix Python tests depending on system-type + + * test/lisp/progmodes/python-tests.el (python-virt-bin): New function. + (python-shell-calculate-exec-path-2) + (python-shell-calculate-exec-path-3) + (python-shell-calculate-exec-path-4) + (python-shell-with-environment-1, python-shell-with-environment-2): + Use it. + +2019-06-16 Juanma Barranquero + + Fix problem with wdired test when symlinks cannot be created. + + * test/lisp/wdired-tests.el (wdired-test-symlink-name): + Skip test if 'make-symbolic-link' fails for whatever reason; + that's not what's being tested. + +2019-06-16 Eli Zaretskii + + Improve wording of documentation of click events + + * doc/lispref/commands.texi (Click Events, Accessing Mouse): + Improve and clarify wording. (Bug#36232) + +2019-06-16 Mattias Engdegård + + Backport: Fix typo in regexp-opt example code + + * doc/lispref/searching.texi (Regexp Functions): + Fix typo in example code (Bug#34596). + +2019-06-15 Stefan Kangas + + Remove outdated comment in winner.el (Bug#36185) + + * lisp/winner.el: Remove outdated comment. + +2019-06-15 Michael Albinus + + Fix accidential change in tramp-tests; do not merge with master + + * lisp/net/trampver.el: Change version to "2.3.5.26.3". + (customize-package-emacs-version-alist): Add Tramp version + integrated in Emacs 26.3. + + * test/lisp/net/tramp-tests.el (tramp-test42-auto-load): + Add skip for w32. + +2019-06-15 Juanma Barranquero + + tramp-test42-auto-load: Add expected-result. + + * test/lisp/net/tramp-tests.el (tramp-test42-auto-load): + Expect a failed result if remote file access is not enabled, + as it happens while doing the test on Windows. + +2019-06-15 Juanma Barranquero + + * test/lisp/url/url-file-tests.el (url-file): Use file:///, not file://. + +2019-06-15 Juanma Barranquero + + Fix doc of srecompile-compile-split-code (Bug#36200) + + * lisp/cedet/srecode/compile.el (srecode-compile-split-code): + Remove leftover text from docstring. + +2019-06-14 Eric Abrahamsen + + Make sure Gnus imap group names are decoded before searching + + do not merge (fix unnecessary in Emacs 27) + + * lisp/gnus/nnir.el (nnir-run-imap): Ensure that non-ascii group names + have been fully decoded before passing them to imap search. + +2019-06-14 Eli Zaretskii + + Remove failing test erroneously added in backport + + * test/src/thread-tests.el (threads-test-bug33073): Remove + test which cannot work on the emacs-26 branch. Do not merge + to master. Reported by Juanma Barranquero . + +2019-06-14 Juanma Barranquero + + * lisp/net/sieve-manage.el (sieve-manage-parse-capability): Doc fix. + +2019-06-12 Nicolas Petton + + Bump Emacs version to 26.2.90 + + * README: + * configure.ac: + * msdos/sed2v2.inp: + * nt/README.W32: Bump Emacs version. + +2019-06-12 Nicolas Petton + + * etc/AUTHORS: Update. + 2019-06-12 Martin Rudalics Fix description of 'display-buffer-in-previous-window' again (Bug#36161) @@ -65967,7 +66510,7 @@ This file records repository revisions from commit 9d56a21e6a696ad19ac65c4b405aeca44785884a (exclusive) to -commit eca2677b1db94a126b6d2871526a1d6fce98353d (inclusive). +commit e8f176b6423a1b4d456e2c332415c32982ff4553 (inclusive). See ChangeLog.1 for earlier changes. ;; Local Variables: commit e8f176b6423a1b4d456e2c332415c32982ff4553 Author: Nicolas Petton Date: Wed Aug 21 22:52:46 2019 +0200 * etc/NEWS: Delete temporary markup. diff --git a/etc/NEWS b/etc/NEWS index a4bc862d60..d672d057bb 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -24,13 +24,11 @@ with a prefix argument or by typing 'C-u C-h C-n'. * Changes in Emacs 26.3 -+++ ** New option 'help-enable-completion-auto-load'. This allows disabling the new feature introduced in Emacs 26.1 which loads files during completion of 'C-h f' and 'C-h v' according to 'definition-prefixes'. ---- ** Emacs now supports the new Japanese Era name. The newly assigned codepoint U+32FF was added to the Unicode Character Database compiled into Emacs. commit 11de1155f81fdac515b5465d31634c7b91a4d42a Author: Lars Ingebrigtsen Date: Wed Aug 21 13:49:57 2019 -0700 Make hide-ifdef-mode-prefix-key customisable * lisp/progmodes/hideif.el (hide-ifdef-mode-prefix-key): Make into a defcustom since it seems like this is something that should be user-customisable (bug#8922). diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el index 1b06077005..9fea447e76 100644 --- a/lisp/progmodes/hideif.el +++ b/lisp/progmodes/hideif.el @@ -112,28 +112,23 @@ (defcustom hide-ifdef-initially nil "Non-nil means call `hide-ifdefs' when Hide-Ifdef mode is first activated." - :type 'boolean - :group 'hide-ifdef) + :type 'boolean) (defcustom hide-ifdef-read-only nil "Set to non-nil if you want buffer to be read-only while hiding text." - :type 'boolean - :group 'hide-ifdef) + :type 'boolean) (defcustom hide-ifdef-lines nil "Non-nil means hide the #ifX, #else, and #endif lines." - :type 'boolean - :group 'hide-ifdef) + :type 'boolean) (defcustom hide-ifdef-shadow nil "Non-nil means shadow text instead of hiding it." :type 'boolean - :group 'hide-ifdef :version "23.1") (defface hide-ifdef-shadow '((t (:inherit shadow))) "Face for shadowing ifdef blocks." - :group 'hide-ifdef :version "23.1") (defcustom hide-ifdef-exclude-define-regexp nil @@ -168,7 +163,6 @@ This behavior is generally undesirable. If this option is non-nil, the outermos "C/C++ header file name patterns to determine if current buffer is a header. Effective only if `hide-ifdef-expand-reinclusion-protection' is t." :type 'string - :group 'hide-ifdef :version "25.1") (defvar hide-ifdef-mode-submap @@ -196,8 +190,10 @@ Effective only if `hide-ifdef-expand-reinclusion-protection' is t." map) "Keymap used by `hide-ifdef-mode' under `hide-ifdef-mode-prefix-key'.") -(defconst hide-ifdef-mode-prefix-key "\C-c@" - "Prefix key for all Hide-Ifdef mode commands.") +(defcustom hide-ifdef-mode-prefix-key "\C-c@" + "Prefix key for all Hide-Ifdef mode commands." + :type 'key-sequence + :version "27.1") (defvar hide-ifdef-mode-map ;; Set up the mode's main map, which leads via the prefix key to the submap. commit 08dd4b9f0c0f2ccfcd17ae719b4a354919ddfeb5 Author: Lars Ingebrigtsen Date: Wed Aug 21 13:36:59 2019 -0700 Use `quit-window-hook' in Info instead of having its own command * doc/misc/info.texi (Help-Q): Info now uses `quit-window'. * lisp/info.el (info-standalone): Adjust doc string. (Info-exit): Made into obsolete alias. (Info-mode-map): Bind "q" to `quit-window'. (Info-mode-menu): Adjust. (info-tool-bar-map): Ditto. (Info-mode): Adjust doc string. (Info-mode): If Info is standalone, kill Emacs on "q". diff --git a/doc/misc/info.texi b/doc/misc/info.texi index e69779a03c..cbdeaff50c 100644 --- a/doc/misc/info.texi +++ b/doc/misc/info.texi @@ -929,10 +929,9 @@ is @code{Info-top-node}. @section Quitting Info @kindex q @r{(Info mode)} -@findex Info-exit @cindex quitting Info mode To get out of Info, back to what you were doing before, type @kbd{q} -for @dfn{Quit}. This runs @code{Info-exit} in Emacs. +for @dfn{Quit}. This runs @code{quit-window} in Emacs. This is the end of the basic course on using Info. You have learned how to move in an Info document, and how to follow menus and cross diff --git a/lisp/info.el b/lisp/info.el index 16909736f8..17a2d63e6d 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -841,7 +841,7 @@ See a list of available Info commands in `Info-mode'." (defun info-standalone () "Run Emacs as a standalone Info reader. Usage: emacs -f info-standalone [filename] -In standalone mode, \\\\[Info-exit] exits Emacs itself." +In standalone mode, \\\\[quit-window] exits Emacs itself." (setq Info-standalone t) (if (and command-line-args-left (not (string-match "^-" (car command-line-args-left)))) @@ -2948,12 +2948,7 @@ N is the digit argument used to invoke this command." (t (user-error "No pointer backward from this node"))))) -(defun Info-exit () - "Exit Info by selecting some other buffer." - (interactive) - (if Info-standalone - (save-buffers-kill-emacs) - (quit-window))) +(define-obsolete-function-alias 'Info-exit #'quit-window "27.1") (defun Info-next-menu-item () "Go to the node of the next menu item." @@ -4045,7 +4040,7 @@ If FORK is non-nil, it is passed to `Info-goto-node'." (define-key map "m" 'Info-menu) (define-key map "n" 'Info-next) (define-key map "p" 'Info-prev) - (define-key map "q" 'Info-exit) + (define-key map "q" 'quit-window) (define-key map "r" 'Info-history-forward) (define-key map "s" 'Info-search) (define-key map "S" 'Info-search-case-sensitively) @@ -4123,7 +4118,7 @@ If FORK is non-nil, it is passed to `Info-goto-node'." :help "Copy the name of the current node into the kill ring"] ["Clone Info buffer" clone-buffer :help "Create a twin copy of the current Info buffer."] - ["Exit" Info-exit :help "Stop reading Info"])) + ["Exit" quit-window :help "Stop reading Info"])) (defvar info-tool-bar-map @@ -4152,7 +4147,7 @@ If FORK is non-nil, it is passed to `Info-goto-node'." :label "Index") (tool-bar-local-item-from-menu 'Info-search "search" map Info-mode-map :vert-only t) - (tool-bar-local-item-from-menu 'Info-exit "exit" map Info-mode-map + (tool-bar-local-item-from-menu 'quit-window "exit" map Info-mode-map :vert-only t) map)) @@ -4280,7 +4275,7 @@ topics. Info has commands to follow the references and show you other nodes. \\\ \\[Info-help] Invoke the Info tutorial. -\\[Info-exit] Quit Info: reselect previously selected buffer. +\\[quit-window] Quit Info: reselect previously selected buffer. Selecting other nodes: \\[Info-mouse-follow-nearest-node] @@ -4353,6 +4348,8 @@ Advanced commands: (add-hook 'clone-buffer-hook 'Info-clone-buffer nil t) (add-hook 'change-major-mode-hook 'font-lock-defontify nil t) (add-hook 'isearch-mode-hook 'Info-isearch-start nil t) + (when Info-standalone + (add-hook 'quit-window-hook 'save-buffers-kill-emacs nil t)) (setq-local isearch-search-fun-function #'Info-isearch-search) (setq-local isearch-wrap-function #'Info-isearch-wrap) (setq-local isearch-push-state-function #'Info-isearch-push-state) commit b60bdfcd4cc4fdfa38894e8619ce4fec206b8303 Author: Lars Ingebrigtsen Date: Wed Aug 21 13:22:56 2019 -0700 Adjust quit-window-hook documentation * doc/lispref/windows.texi (Quitting Windows): Adjust documentation of quit-window-hook (bug#9867). diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi index 157f004cf3..39d3960c9a 100644 --- a/doc/lispref/windows.texi +++ b/doc/lispref/windows.texi @@ -4034,6 +4034,10 @@ This command quits @var{window} and buries its buffer. The argument With prefix argument @var{kill} non-@code{nil}, it kills the buffer instead of burying it. It calls the function @code{quit-restore-window} described next to deal with the window and its buffer. + +@vindex quit-window-hook +The functions in @code{quit-window-hook} are run before doing anything +else. @end deffn @defun quit-restore-window &optional window bury-or-kill @@ -4043,10 +4047,6 @@ the selected one. The function's behavior is determined by the four elements of the list specified by @var{window}'s @code{quit-restore} parameter (@pxref{Window Parameters}). -@vindex quit-window-hook -The functions in @code{quit-window-hook} are run before doing anything -else. - The first element of the @code{quit-restore} parameter is one of the symbols @code{window}, meaning that the window has been specially created by @code{display-buffer}; @code{frame}, a separate frame has commit ab9cb08ebba1cb85d45065887f5dcc2cdafbb5df Author: Lars Ingebrigtsen Date: Wed Aug 21 13:21:52 2019 -0700 Mention quit-window-hook in "Standard Hooks" * doc/lispref/hooks.texi (Standard Hooks): Mention quit-window-hook (bug#9867). diff --git a/doc/lispref/hooks.texi b/doc/lispref/hooks.texi index f775aa4d4b..4542db9730 100644 --- a/doc/lispref/hooks.texi +++ b/doc/lispref/hooks.texi @@ -160,6 +160,9 @@ The command loop runs this soon after @code{post-command-hook} (q.v.). @item frame-auto-hide-function @xref{Quitting Windows}. +@item quit-window-hook +@xref{Quitting Windows}. + @item kill-buffer-hook @itemx kill-buffer-query-functions @xref{Killing Buffers}. commit 2e8bbd5881d8851f19c8eb0b60def932d69b4dbc Author: Lars Ingebrigtsen Date: Wed Aug 21 13:18:47 2019 -0700 Call `quit-window-hook' in the `quit-window' command only * lisp/window.el (quit-restore-window): Don't run quit-window-hook here... (quit-window): ... but here instead. Callers that call the former programmatically can decide themselves whether to call the hook. (quit-window-hook): Fix doc string. diff --git a/lisp/window.el b/lisp/window.el index 80dbd64f18..334b56c8e6 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -4849,7 +4849,7 @@ all window-local buffer lists." (unrecord-window-buffer window buffer))))) (defcustom quit-window-hook nil - "Hook run before performing any other actions in the `quit-buffer' command." + "Hook run before performing any other actions in the `quit-window' command." :type 'hook :version "27.1" :group 'windows) @@ -4882,11 +4882,7 @@ nil means to not handle the buffer in a particular way. This most reliable remedy to not have `switch-to-prev-buffer' switch to this buffer again without killing the buffer. -`kill' means to kill WINDOW's buffer. - -The functions in `quit-window-hook' will be run before doing -anything else." - (run-hooks 'quit-window-hook) +`kill' means to kill WINDOW's buffer." (setq window (window-normalize-window window t)) (let* ((buffer (window-buffer window)) (quit-restore (window-parameter window 'quit-restore)) @@ -4986,6 +4982,7 @@ one. If non-nil, reset `quit-restore' parameter to nil. The functions in `quit-window-hook' will be run before doing anything else." (interactive "P") + (run-hooks 'quit-window-hook) (quit-restore-window window (if kill 'kill 'bury))) (defun quit-windows-on (&optional buffer-or-name kill frame) commit 6224fce0d4168fb217175a2c9e40409a0055e436 Author: Lars Ingebrigtsen Date: Wed Aug 21 13:05:18 2019 -0700 Fix the interactive spec for set-frame-width/height * src/frame.c (Fset_frame_width): (Fset_frame_height): Use `prefix-numeric-value' to get the proper numeric value (bug#9970). diff --git a/src/frame.c b/src/frame.c index 50a7f138b8..a0da55c0e9 100644 --- a/src/frame.c +++ b/src/frame.c @@ -3492,7 +3492,7 @@ DEFUN ("frame-bottom-divider-width", Fbottom_divider_width, Sbottom_divider_widt } DEFUN ("set-frame-height", Fset_frame_height, Sset_frame_height, 2, 4, - "(list (selected-frame) current-prefix-arg)", + "(list (selected-frame) (prefix-numeric-value current-prefix-arg))", doc: /* Set text height of frame FRAME to HEIGHT lines. Optional third arg PRETEND non-nil means that redisplay should use HEIGHT lines but that the idea of the actual height of the frame should @@ -3521,7 +3521,7 @@ currenly selected frame will be set to this height. */) } DEFUN ("set-frame-width", Fset_frame_width, Sset_frame_width, 2, 4, - "(list (selected-frame) current-prefix-arg)", + "(list (selected-frame) (prefix-numeric-value current-prefix-arg))", doc: /* Set text width of frame FRAME to WIDTH columns. Optional third arg PRETEND non-nil means that redisplay should use WIDTH columns but that the idea of the actual width of the frame should not commit 6c1cf80721f19c36e71a6825e705d09818b97de7 Author: Stefan Kangas Date: Wed Aug 21 19:16:20 2019 +0200 * lisp/mail/flow-fill.el: Change todo comment to not mention XEmacs. diff --git a/lisp/mail/flow-fill.el b/lisp/mail/flow-fill.el index 7b50fcd96e..4dbd4d7b08 100644 --- a/lisp/mail/flow-fill.el +++ b/lisp/mail/flow-fill.el @@ -33,8 +33,7 @@ ;; paragraph and we let `fill-region' fill the long line into several ;; lines with the quote prefix as `fill-prefix'. -;; Todo: implement basic `fill-region' (Emacs and XEmacs -;; implementations differ..) +;; Todo: implement basic `fill-region' ;;; History: commit 0f801d4a5e37e69c4e527830f13f255a6f01360b Author: Michael Albinus Date: Wed Aug 21 11:03:34 2019 +0200 ; Fix typo introduced by last autorevert-tests patch diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el index 9c41ea7af9..0aec1800df 100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el @@ -111,7 +111,7 @@ being the result.") (cons t (ignore-errors (and - (not (getenv "EMACS_HYDRA_CI")(getenv "EMACS_HYDRA_CI")) + (not (getenv "EMACS_HYDRA_CI")) (file-remote-p auto-revert-test-remote-temporary-file-directory) (file-directory-p auto-revert-test-remote-temporary-file-directory) (file-writable-p commit 9a28cb5a87c420b46a33be97463b23b823b7de2e Author: Martin Rudalics Date: Wed Aug 21 10:24:25 2019 +0200 ; Fix typos in commentary section of xdisp.c diff --git a/src/xdisp.c b/src/xdisp.c index af772bdef2..dea80a1f9a 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -184,7 +184,7 @@ along with GNU Emacs. If not, see . */ infrequently. These include the face of the characters, whether text is invisible, the object (buffer or display or overlay string) being iterated, character composition info, etc. For any given - buffer or string position, these sources of information that + buffer or string position, the sources of information that affects the display can be determined by calling the appropriate primitives, such as Fnext_single_property_change, but both these calls and the processing of their return values is relatively @@ -214,7 +214,7 @@ along with GNU Emacs. If not, see . */ string's interval tree to determine where the text properties change, finds the next position where overlays and character composition can change, and stores in stop_charpos the closest - position where any of these factors should be reconsider. + position where any of these factors should be reconsidered. Producing glyphs. commit c2abe6abba1bee2e551f374b0d6d9dd182abeb5c Author: Michael Albinus Date: Wed Aug 21 09:19:28 2019 +0200 ; Add traces to auto-revert-test02-auto-revert-deleted-file diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el index 0ff3c5a407..9c41ea7af9 100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el @@ -111,7 +111,7 @@ being the result.") (cons t (ignore-errors (and - (not (getenv "EMACS_HYDRA_CI")) + (not (getenv "EMACS_HYDRA_CI")(getenv "EMACS_HYDRA_CI")) (file-remote-p auto-revert-test-remote-temporary-file-directory) (file-directory-p auto-revert-test-remote-temporary-file-directory) (file-writable-p @@ -277,6 +277,9 @@ This expects `auto-revert--messages' to be bound by ; (skip-unless (not (getenv "EMACS_HYDRA_CI"))) (let ((tmpfile (make-temp-file "auto-revert-test")) + ;; Try to catch bug#32645. + (auto-revert-debug (getenv "EMACS_HYDRA_CI")) + (file-notify-debug (getenv "EMACS_HYDRA_CI")) buf desc) (unwind-protect (progn commit 39fee209942ab7c35b4789f0010264cd6a52197b Author: Paul Eggert Date: Wed Aug 21 00:06:00 2019 -0700 Be more careful about pointers to bignum vals This uses ‘const’ to be better at catching bugs that mistakenly attempt to modify a bignum value. Lisp bignums are supposed to be immutable. * src/alloc.c (make_pure_bignum): * src/fns.c (sxhash_bignum): Accept Lisp_Object instead of struct Lisp_Bignum *, as that’s simpler now. Caller changed. * src/bignum.h (bignum_val, xbignum_val): New inline functions. Prefer them to &i->value and XBIGNUM (i)->value, since they apply ‘const’ to the result. * src/timefns.c (lisp_to_timespec): Use mpz_t const * to point to a bignum value. diff --git a/src/alloc.c b/src/alloc.c index bb8e97f873..53af7325f4 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -5290,9 +5290,10 @@ make_pure_float (double num) space. */ static Lisp_Object -make_pure_bignum (struct Lisp_Bignum *value) +make_pure_bignum (Lisp_Object value) { - size_t i, nlimbs = mpz_size (value->value); + mpz_t const *n = xbignum_val (value); + size_t i, nlimbs = mpz_size (*n); size_t nbytes = nlimbs * sizeof (mp_limb_t); mp_limb_t *pure_limbs; mp_size_t new_size; @@ -5303,10 +5304,10 @@ make_pure_bignum (struct Lisp_Bignum *value) int limb_alignment = alignof (mp_limb_t); pure_limbs = pure_alloc (nbytes, - limb_alignment); for (i = 0; i < nlimbs; ++i) - pure_limbs[i] = mpz_getlimbn (value->value, i); + pure_limbs[i] = mpz_getlimbn (*n, i); new_size = nlimbs; - if (mpz_sgn (value->value) < 0) + if (mpz_sgn (*n) < 0) new_size = -new_size; mpz_roinit_n (b->value, pure_limbs, new_size); @@ -5456,7 +5457,7 @@ purecopy (Lisp_Object obj) return obj; } else if (BIGNUMP (obj)) - obj = make_pure_bignum (XBIGNUM (obj)); + obj = make_pure_bignum (obj); else { AUTO_STRING (fmt, "Don't know how to purify: %S"); diff --git a/src/bignum.c b/src/bignum.c index 90b1ebea87..167b73eee0 100644 --- a/src/bignum.c +++ b/src/bignum.c @@ -63,7 +63,7 @@ init_bignum (void) double bignum_to_double (Lisp_Object n) { - return mpz_get_d_rounded (XBIGNUM (n)->value); + return mpz_get_d_rounded (*xbignum_val (n)); } /* Return D, converted to a Lisp integer. Discard any fraction. @@ -264,13 +264,13 @@ intmax_t bignum_to_intmax (Lisp_Object x) { intmax_t i; - return mpz_to_intmax (XBIGNUM (x)->value, &i) ? i : 0; + return mpz_to_intmax (*xbignum_val (x), &i) ? i : 0; } uintmax_t bignum_to_uintmax (Lisp_Object x) { uintmax_t i; - return mpz_to_uintmax (XBIGNUM (x)->value, &i) ? i : 0; + return mpz_to_uintmax (*xbignum_val (x), &i) ? i : 0; } /* Yield an upper bound on the buffer size needed to contain a C @@ -284,7 +284,7 @@ mpz_bufsize (mpz_t const num, int base) ptrdiff_t bignum_bufsize (Lisp_Object num, int base) { - return mpz_bufsize (XBIGNUM (num)->value, base); + return mpz_bufsize (*xbignum_val (num), base); } /* Convert NUM to a nearest double, as opposed to mpz_get_d which @@ -318,7 +318,7 @@ ptrdiff_t bignum_to_c_string (char *buf, ptrdiff_t size, Lisp_Object num, int base) { eassert (bignum_bufsize (num, abs (base)) == size); - mpz_get_str (buf, base, XBIGNUM (num)->value); + mpz_get_str (buf, base, *xbignum_val (num)); ptrdiff_t n = size - 2; return !buf[n - 1] ? n - 1 : n + !!buf[n]; } diff --git a/src/bignum.h b/src/bignum.h index 9a32ffb037..bf7b366953 100644 --- a/src/bignum.h +++ b/src/bignum.h @@ -80,6 +80,19 @@ mpz_set_uintmax (mpz_t result, uintmax_t v) mpz_set_uintmax_slow (result, v); } +/* Return a pointer to the mpz_t value represented by the bignum I. + It is const because the value should not change. */ +INLINE mpz_t const * +bignum_val (struct Lisp_Bignum const *i) +{ + return &i->value; +} +INLINE mpz_t const * +xbignum_val (Lisp_Object i) +{ + return bignum_val (XBIGNUM (i)); +} + /* Return a pointer to an mpz_t that is equal to the Lisp integer I. If I is a bignum this returns a pointer to I's representation; otherwise this sets *TMP to I's value and returns TMP. */ @@ -91,7 +104,7 @@ bignum_integer (mpz_t *tmp, Lisp_Object i) mpz_set_intmax (*tmp, XFIXNUM (i)); return tmp; } - return &XBIGNUM (i)->value; + return xbignum_val (i); } /* Set RESULT to the value stored in the Lisp integer I. If I is a @@ -103,7 +116,7 @@ mpz_set_integer (mpz_t result, Lisp_Object i) if (FIXNUMP (i)) mpz_set_intmax (result, XFIXNUM (i)); else - mpz_set (result, XBIGNUM (i)->value); + mpz_set (result, *xbignum_val (i)); } INLINE_HEADER_END diff --git a/src/data.c b/src/data.c index cf9f8e5613..8344bfdd3d 100644 --- a/src/data.c +++ b/src/data.c @@ -525,7 +525,7 @@ DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0, (Lisp_Object object) { return ((FIXNUMP (object) ? 0 <= XFIXNUM (object) - : BIGNUMP (object) && 0 <= mpz_sgn (XBIGNUM (object)->value)) + : BIGNUMP (object) && 0 <= mpz_sgn (*xbignum_val (object))) ? Qt : Qnil); } @@ -2481,7 +2481,7 @@ arithcompare (Lisp_Object num1, Lisp_Object num2, else if (isnan (f1)) lt = eq = gt = false; else - i2 = mpz_cmp_d (XBIGNUM (num2)->value, f1); + i2 = mpz_cmp_d (*xbignum_val (num2), f1); } else if (FIXNUMP (num1)) { @@ -2502,7 +2502,7 @@ arithcompare (Lisp_Object num1, Lisp_Object num2, i2 = XFIXNUM (num2); } else - i2 = mpz_sgn (XBIGNUM (num2)->value); + i2 = mpz_sgn (*xbignum_val (num2)); } else if (FLOATP (num2)) { @@ -2510,12 +2510,12 @@ arithcompare (Lisp_Object num1, Lisp_Object num2, if (isnan (f2)) lt = eq = gt = false; else - i1 = mpz_cmp_d (XBIGNUM (num1)->value, f2); + i1 = mpz_cmp_d (*xbignum_val (num1), f2); } else if (FIXNUMP (num2)) - i1 = mpz_sgn (XBIGNUM (num1)->value); + i1 = mpz_sgn (*xbignum_val (num1)); else - i1 = mpz_cmp (XBIGNUM (num1)->value, XBIGNUM (num2)->value); + i1 = mpz_cmp (*xbignum_val (num1), *xbignum_val (num2)); if (eq) { @@ -3005,7 +3005,7 @@ usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */) return make_int (-XFIXNUM (a)); if (FLOATP (a)) return make_float (-XFLOAT_DATA (a)); - mpz_neg (mpz[0], XBIGNUM (a)->value); + mpz_neg (mpz[0], *xbignum_val (a)); return make_integer_mpz (); } return arith_driver (Asub, nargs, args, a); @@ -3214,7 +3214,7 @@ representation. */) if (BIGNUMP (value)) { - mpz_t *nonneg = &XBIGNUM (value)->value; + mpz_t const *nonneg = xbignum_val (value); if (mpz_sgn (*nonneg) < 0) { mpz_com (mpz[0], *nonneg); @@ -3245,10 +3245,10 @@ In this case, the sign bit is duplicated. */) { if (EQ (value, make_fixnum (0))) return value; - if (mpz_sgn (XBIGNUM (count)->value) < 0) + if (mpz_sgn (*xbignum_val (count)) < 0) { EMACS_INT v = (FIXNUMP (value) ? XFIXNUM (value) - : mpz_sgn (XBIGNUM (value)->value)); + : mpz_sgn (*xbignum_val (value))); return make_fixnum (v < 0 ? -1 : 0); } overflow_error (); @@ -3291,8 +3291,8 @@ expt_integer (Lisp_Object x, Lisp_Object y) if (TYPE_RANGED_FIXNUMP (unsigned long, y)) exp = XFIXNUM (y); else if (MOST_POSITIVE_FIXNUM < ULONG_MAX && BIGNUMP (y) - && mpz_fits_ulong_p (XBIGNUM (y)->value)) - exp = mpz_get_ui (XBIGNUM (y)->value); + && mpz_fits_ulong_p (*xbignum_val (y))) + exp = mpz_get_ui (*xbignum_val (y)); else overflow_error (); @@ -3311,7 +3311,7 @@ Markers are converted to integers. */) return make_int (XFIXNUM (number) + 1); if (FLOATP (number)) return (make_float (1.0 + XFLOAT_DATA (number))); - mpz_add_ui (mpz[0], XBIGNUM (number)->value, 1); + mpz_add_ui (mpz[0], *xbignum_val (number), 1); return make_integer_mpz (); } @@ -3326,7 +3326,7 @@ Markers are converted to integers. */) return make_int (XFIXNUM (number) - 1); if (FLOATP (number)) return (make_float (-1.0 + XFLOAT_DATA (number))); - mpz_sub_ui (mpz[0], XBIGNUM (number)->value, 1); + mpz_sub_ui (mpz[0], *xbignum_val (number), 1); return make_integer_mpz (); } @@ -3337,7 +3337,7 @@ DEFUN ("lognot", Flognot, Slognot, 1, 1, 0, CHECK_INTEGER (number); if (FIXNUMP (number)) return make_fixnum (~XFIXNUM (number)); - mpz_com (mpz[0], XBIGNUM (number)->value); + mpz_com (mpz[0], *xbignum_val (number)); return make_integer_mpz (); } diff --git a/src/floatfns.c b/src/floatfns.c index a913aad5aa..0a85df47de 100644 --- a/src/floatfns.c +++ b/src/floatfns.c @@ -268,9 +268,9 @@ DEFUN ("abs", Fabs, Sabs, 1, 1, 0, } else { - if (mpz_sgn (XBIGNUM (arg)->value) < 0) + if (mpz_sgn (*xbignum_val (arg)) < 0) { - mpz_neg (mpz[0], XBIGNUM (arg)->value); + mpz_neg (mpz[0], *xbignum_val (arg)); arg = make_integer_mpz (); } } @@ -315,7 +315,7 @@ This is the same as the exponent of a float. */) value = ivalue - 1; } else if (!FIXNUMP (arg)) - value = mpz_sizeinbase (XBIGNUM (arg)->value, 2) - 1; + value = mpz_sizeinbase (*xbignum_val (arg), 2) - 1; else { EMACS_INT i = XFIXNUM (arg); diff --git a/src/fns.c b/src/fns.c index 920addeaf1..6c47b3e5b1 100644 --- a/src/fns.c +++ b/src/fns.c @@ -47,7 +47,6 @@ static void sort_vector_copy (Lisp_Object, ptrdiff_t, enum equal_kind { EQUAL_NO_QUIT, EQUAL_PLAIN, EQUAL_INCLUDING_PROPERTIES }; static bool internal_equal (Lisp_Object, Lisp_Object, enum equal_kind, int, Lisp_Object); -static EMACS_UINT sxhash_bignum (struct Lisp_Bignum *); DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0, doc: /* Return the argument unchanged. */ @@ -1444,7 +1443,7 @@ DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0, } else { - if (mpz_sgn (XBIGNUM (n)->value) < 0) + if (mpz_sgn (*xbignum_val (n)) < 0) return tail; num = large_num; } @@ -1482,11 +1481,11 @@ DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0, CYCLE_LENGTH. */ /* Add N mod CYCLE_LENGTH to NUM. */ if (cycle_length <= ULONG_MAX) - num += mpz_tdiv_ui (XBIGNUM (n)->value, cycle_length); + num += mpz_tdiv_ui (*xbignum_val (n), cycle_length); else { mpz_set_intmax (mpz[0], cycle_length); - mpz_tdiv_r (mpz[0], XBIGNUM (n)->value, mpz[0]); + mpz_tdiv_r (mpz[0], *xbignum_val (n), mpz[0]); intptr_t iz; mpz_export (&iz, NULL, -1, sizeof iz, 0, 0, mpz[0]); num += iz; @@ -1595,7 +1594,7 @@ The value is actually the tail of LIST whose car is ELT. */) { Lisp_Object tem = XCAR (tail); if (BIGNUMP (tem) - && mpz_cmp (XBIGNUM (elt)->value, XBIGNUM (tem)->value) == 0) + && mpz_cmp (*xbignum_val (elt), *xbignum_val (tem)) == 0) return tail; } } @@ -2307,7 +2306,7 @@ This differs from numeric comparison: (eql 0.0 -0.0) returns nil and return FLOATP (obj2) && same_float (obj1, obj2) ? Qt : Qnil; else if (BIGNUMP (obj1)) return ((BIGNUMP (obj2) - && mpz_cmp (XBIGNUM (obj1)->value, XBIGNUM (obj2)->value) == 0) + && mpz_cmp (*xbignum_val (obj1), *xbignum_val (obj2)) == 0) ? Qt : Qnil); else return EQ (obj1, obj2) ? Qt : Qnil; @@ -2437,7 +2436,7 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, if (ASIZE (o2) != size) return false; if (BIGNUMP (o1)) - return mpz_cmp (XBIGNUM (o1)->value, XBIGNUM (o2)->value) == 0; + return mpz_cmp (*xbignum_val (o1), *xbignum_val (o2)) == 0; if (OVERLAYP (o1)) { if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2), @@ -4640,13 +4639,14 @@ sxhash_bool_vector (Lisp_Object vec) /* Return a hash for a bignum. */ static EMACS_UINT -sxhash_bignum (struct Lisp_Bignum *bignum) +sxhash_bignum (Lisp_Object bignum) { - size_t i, nlimbs = mpz_size (bignum->value); + mpz_t const *n = xbignum_val (bignum); + size_t i, nlimbs = mpz_size (*n); EMACS_UINT hash = 0; for (i = 0; i < nlimbs; ++i) - hash = sxhash_combine (hash, mpz_getlimbn (bignum->value, i)); + hash = sxhash_combine (hash, mpz_getlimbn (*n, i)); return SXHASH_REDUCE (hash); } @@ -4680,7 +4680,7 @@ sxhash (Lisp_Object obj, int depth) /* This can be everything from a vector to an overlay. */ case Lisp_Vectorlike: if (BIGNUMP (obj)) - hash = sxhash_bignum (XBIGNUM (obj)); + hash = sxhash_bignum (obj); else if (VECTORP (obj) || RECORDP (obj)) /* According to the CL HyperSpec, two arrays are equal only if they are `eq', except for strings and bit-vectors. In diff --git a/src/pdumper.c b/src/pdumper.c index 326a346a63..73a50cee53 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2211,7 +2211,7 @@ dump_bignum (struct dump_context *ctx, Lisp_Object object) const struct Lisp_Bignum *bignum = XBIGNUM (object); START_DUMP_PVEC (ctx, &bignum->header, struct Lisp_Bignum, out); verify (sizeof (out->value) >= sizeof (struct bignum_reload_info)); - dump_field_fixup_later (ctx, out, bignum, &bignum->value); + dump_field_fixup_later (ctx, out, bignum, xbignum_val (object)); dump_off bignum_offset = finish_dump_pvec (ctx, &out->header); if (ctx->flags.dump_object_contents) { @@ -3397,19 +3397,18 @@ dump_cold_buffer (struct dump_context *ctx, Lisp_Object data) static void dump_cold_bignum (struct dump_context *ctx, Lisp_Object object) { - const struct Lisp_Bignum *bignum = XBIGNUM (object); - size_t sz_nlimbs = mpz_size (bignum->value); + mpz_t const *n = xbignum_val (object); + size_t sz_nlimbs = mpz_size (*n); eassert (sz_nlimbs < DUMP_OFF_MAX); dump_align_output (ctx, alignof (mp_limb_t)); dump_off nlimbs = (dump_off) sz_nlimbs; Lisp_Object descriptor = list2 (dump_off_to_lisp (ctx->offset), - dump_off_to_lisp ((mpz_sgn (bignum->value) < 0 - ? -nlimbs : nlimbs))); + dump_off_to_lisp (mpz_sgn (*n) < 0 ? -nlimbs : nlimbs)); Fputhash (object, descriptor, ctx->bignum_data); for (mp_size_t i = 0; i < nlimbs; ++i) { - mp_limb_t limb = mpz_getlimbn (bignum->value, i); + mp_limb_t limb = mpz_getlimbn (*n, i); dump_write (ctx, &limb, sizeof (limb)); } } @@ -5205,8 +5204,8 @@ dump_do_dump_relocation (const uintptr_t dump_base, { struct Lisp_Bignum *bignum = dump_ptr (dump_base, reloc_offset); struct bignum_reload_info reload_info; - verify (sizeof (reload_info) <= sizeof (bignum->value)); - memcpy (&reload_info, &bignum->value, sizeof (reload_info)); + verify (sizeof (reload_info) <= sizeof (*bignum_val (bignum))); + memcpy (&reload_info, bignum_val (bignum), sizeof (reload_info)); const mp_limb_t *limbs = dump_ptr (dump_base, reload_info.data_location); mpz_roinit_n (bignum->value, limbs, reload_info.nlimbs); diff --git a/src/timefns.c b/src/timefns.c index 3c4c15b657..6c9473f22a 100644 --- a/src/timefns.c +++ b/src/timefns.c @@ -91,7 +91,7 @@ static Lisp_Object timespec_hz; #define TRILLION 1000000000000 #if FIXNUM_OVERFLOW_P (TRILLION) static Lisp_Object trillion; -# define ztrillion (XBIGNUM (trillion)->value) +# define ztrillion (*xbignum_val (trillion)) #else # define trillion make_fixnum (TRILLION) # if ULONG_MAX < TRILLION || !FASTER_TIMEFNS @@ -534,7 +534,7 @@ lisp_time_hz_ticks (struct lisp_time t, Lisp_Object hz) return make_int (ticks / XFIXNUM (t.hz) - (ticks % XFIXNUM (t.hz) < 0)); } - else if (! (BIGNUMP (hz) && 0 < mpz_sgn (XBIGNUM (hz)->value))) + else if (! (BIGNUMP (hz) && 0 < mpz_sgn (*xbignum_val (hz)))) invalid_hz (hz); mpz_mul (mpz[0], @@ -906,6 +906,7 @@ lisp_to_timespec (struct lisp_time t) struct timespec result = invalid_timespec (); int ns; mpz_t *q = &mpz[0]; + mpz_t const *qt = q; if (FASTER_TIMEFNS && EQ (t.hz, timespec_hz)) { @@ -924,7 +925,7 @@ lisp_to_timespec (struct lisp_time t) return result; } else - ns = mpz_fdiv_q_ui (*q, XBIGNUM (t.ticks)->value, TIMESPEC_HZ); + ns = mpz_fdiv_q_ui (*q, *xbignum_val (t.ticks), TIMESPEC_HZ); } else if (FASTER_TIMEFNS && EQ (t.hz, make_fixnum (1))) { @@ -941,7 +942,7 @@ lisp_to_timespec (struct lisp_time t) return result; } else - q = &XBIGNUM (t.ticks)->value; + qt = xbignum_val (t.ticks); } else { @@ -953,7 +954,7 @@ lisp_to_timespec (struct lisp_time t) /* With some versions of MinGW, tv_sec is a 64-bit type, whereas time_t is a 32-bit type. */ time_t sec; - if (mpz_time (*q, &sec)) + if (mpz_time (*qt, &sec)) { result.tv_sec = sec; result.tv_nsec = ns; @@ -1038,7 +1039,7 @@ lispint_arith (Lisp_Object a, Lisp_Object b, bool subtract) if (eabs (XFIXNUM (b)) <= ULONG_MAX) { ((XFIXNUM (b) < 0) == subtract ? mpz_add_ui : mpz_sub_ui) - (mpz[0], XBIGNUM (a)->value, eabs (XFIXNUM (b))); + (mpz[0], *xbignum_val (a), eabs (XFIXNUM (b))); mpz_done = true; } } commit 3881542edeac3e94291c2ce574edf0b0e52764a8 Author: Paul Eggert Date: Tue Aug 20 18:11:16 2019 -0700 Update mini-gmp * src/mini-gmp.c: Sync from upstream. This incorporates: 2019-08-13 Silence a couple of warnings diff --git a/src/mini-gmp.c b/src/mini-gmp.c index 88b71c3f9a..e92e7cf9c7 100644 --- a/src/mini-gmp.c +++ b/src/mini-gmp.c @@ -2,7 +2,7 @@ Contributed to the GNU project by Niels Möller -Copyright 1991-1997, 1999-2018 Free Software Foundation, Inc. +Copyright 1991-1997, 1999-2019 Free Software Foundation, Inc. This file is part of the GNU MP Library. @@ -295,7 +295,7 @@ gmp_default_alloc (size_t size) } static void * -gmp_default_realloc (void *old, size_t old_size, size_t new_size) +gmp_default_realloc (void *old, size_t unused_old_size, size_t new_size) { void * p; @@ -308,7 +308,7 @@ gmp_default_realloc (void *old, size_t old_size, size_t new_size) } static void -gmp_default_free (void *p, size_t size) +gmp_default_free (void *p, size_t unused_size) { free (p); } @@ -1595,7 +1595,7 @@ mpz_get_ui (const mpz_t u) int LOCAL_GMP_LIMB_BITS = GMP_LIMB_BITS; unsigned long r = 0; mp_size_t n = GMP_ABS (u->_mp_size); - n = GMP_MIN (n, 1 + (GMP_ULONG_BITS - 1) / GMP_LIMB_BITS); + n = GMP_MIN (n, 1 + (mp_size_t) (GMP_ULONG_BITS - 1) / GMP_LIMB_BITS); while (--n >= 0) r = (r << LOCAL_GMP_LIMB_BITS) + u->_mp_d[n]; return r; @@ -3499,7 +3499,7 @@ gmp_stronglucas (const mpz_t x, mpz_t Qk) b0 = mpz_scan0 (n, 0); /* D= P^2 - 4Q; P = 1; Q = (1-D)/4 */ - Q = (D & 2) ? (D >> 2) + 1 : -(long) (D >> 2); + Q = (D & 2) ? (long) (D >> 2) + 1 : -(long) (D >> 2); if (! gmp_lucas_mod (V, Qk, Q, b0, n)) /* If Ud != 0 */ while (V->_mp_size != 0 && --b0 != 0) /* while Vk != 0 */ commit 396ed88a50fba95cd3b989965defef0130a42c42 Author: Paul Eggert Date: Tue Aug 20 17:34:03 2019 -0700 Avoid some excess precision in time arithmetic * doc/misc/emacs-mime.texi (time-date): Adjust example to match new behavior. * etc/NEWS: Mention this. * lisp/calendar/time-date.el (decoded-time-add) (decoded-time--alter-second): Don’t lose underestimate precision of seconds component. * src/bignum.c (mpz): Grow by 1. * src/timefns.c (trillion_factor): New function. (timeform_sub_ps_p): Remove. (time_arith): Avoid unnecessarily-large hz, by reducing the hz to a value no worse than the worse hz of the two arguments. The result is always exact unless an error is signaled. * test/src/timefns-tests.el (timefns-tests--decode-time): New function. (format-time-string-with-zone): Test (decode-time LOOK ZONE t) resolution as well as its numeric value. diff --git a/doc/misc/emacs-mime.texi b/doc/misc/emacs-mime.texi index eb829b0612..131a358ba5 100644 --- a/doc/misc/emacs-mime.texi +++ b/doc/misc/emacs-mime.texi @@ -1568,7 +1568,7 @@ Here's a bunch of time/date/second/day examples: (time-subtract '(905595714000000 . 1000000) '(905595593000000000 . 1000000000)) -@result{} (121000000000 . 1000000000) +@result{} (121000000 . 1000000) (days-between "Sat Sep 12 12:21:54 1998 +0200" "Sat Sep 07 12:21:54 1998 +0200") diff --git a/etc/NEWS b/etc/NEWS index 9f25cf4af5..3fdc185af4 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2166,7 +2166,9 @@ end and duration). +++ *** 'time-add', 'time-subtract', and 'time-less-p' now accept infinities and NaNs too, and propagate them or return nil like -floating-point operators do. +floating-point operators do. If both arguments are finite, these +functions now return exact results instead of rounding in some cases, +and they also avoid excess precision when that is easy. +++ *** New function 'time-equal-p' compares time values for equality. diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index f3d252f03c..11bd469ae3 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -421,10 +421,13 @@ changes in daylight saving time are not taken into account." ;; Do the time part, which is pretty simple (except for leap ;; seconds, I guess). ;; Time zone adjustments are basically the same as time adjustments. - (setq seconds (time-add (+ (* (or (decoded-time-hour delta) 0) 3600) - (* (or (decoded-time-minute delta) 0) 60) - (or (decoded-time-zone delta) 0)) - (or (decoded-time-second delta) 0))) + (setq seconds (time-convert (or (decoded-time-second delta) 0) t)) + (setq seconds + (time-add seconds + (time-convert (+ (* (or (decoded-time-hour delta) 0) 3600) + (* (or (decoded-time-minute delta) 0) 60) + (or (decoded-time-zone delta) 0)) + (cdr seconds)))) (decoded-time--alter-second time seconds) time)) @@ -461,11 +464,16 @@ changes in daylight saving time are not taken into account." (defun decoded-time--alter-second (time seconds) "Increase the time in TIME by SECONDS." - (let* ((secsperday 86400) - (old (time-add (+ (* 3600 (or (decoded-time-hour time) 0)) - (* 60 (or (decoded-time-minute time) 0))) - (or (decoded-time-second time) 0))) - (new (time-add old seconds))) + (let* ((time-sec (time-convert (or (decoded-time-second time) 0) t)) + (time-hz (cdr time-sec)) + (old (time-add time-sec + (time-convert + (+ (* 3600 (or (decoded-time-hour time) 0)) + (* 60 (or (decoded-time-minute time) 0))) + time-hz))) + (new (time-convert (time-add old seconds) t)) + (new-hz (cdr new)) + (secsperday (time-convert 86400 new-hz))) ;; Hm... DST... (while (time-less-p new 0) (decoded-time--alter-day time nil) @@ -474,8 +482,10 @@ changes in daylight saving time are not taken into account." (decoded-time--alter-day time t) (setq new (time-subtract new secsperday))) (let ((sec (time-convert new 'integer))) - (setf (decoded-time-second time) (time-add (% sec 60) - (time-subtract new sec)) + (setf (decoded-time-second time) (time-add + (time-convert (% sec 60) new-hz) + (time-subtract + new (time-convert sec new-hz))) (decoded-time-minute time) (% (/ sec 60) 60) (decoded-time-hour time) (/ sec 3600))))) diff --git a/src/bignum.c b/src/bignum.c index 3883d3a394..90b1ebea87 100644 --- a/src/bignum.c +++ b/src/bignum.c @@ -31,9 +31,10 @@ along with GNU Emacs. If not, see . */ storage is exhausted. Admittedly this is not ideal. An mpz value in a temporary is made permanent by mpz_swapping it with a bignum's value. Although typically at most two temporaries are needed, - time_arith, rounddiv_q and rounding_driver each need four. */ + rounddiv_q and rounding_driver both need four and time_arith needs + five. */ -mpz_t mpz[4]; +mpz_t mpz[5]; static void * xrealloc_for_gmp (void *ptr, size_t ignore, size_t size) diff --git a/src/bignum.h b/src/bignum.h index a9c7a0a09a..9a32ffb037 100644 --- a/src/bignum.h +++ b/src/bignum.h @@ -41,7 +41,7 @@ struct Lisp_Bignum mpz_t value; } GCALIGNED_STRUCT; -extern mpz_t mpz[4]; +extern mpz_t mpz[5]; extern void init_bignum (void); extern Lisp_Object make_integer_mpz (void); diff --git a/src/timefns.c b/src/timefns.c index 3b686eb226..3c4c15b657 100644 --- a/src/timefns.c +++ b/src/timefns.c @@ -99,6 +99,22 @@ mpz_t ztrillion; # endif #endif +/* True if the nonzero Lisp integer HZ divides evenly into a trillion. */ +static bool +trillion_factor (Lisp_Object hz) +{ + if (FASTER_TIMEFNS) + { + if (FIXNUMP (hz)) + return TRILLION % XFIXNUM (hz) == 0; + if (!FIXNUM_OVERFLOW_P (TRILLION)) + return false; + } + verify (TRILLION <= INTMAX_MAX); + intmax_t ihz; + return integer_to_intmax (hz, &ihz) && TRILLION % ihz == 0; +} + /* Return a struct timeval that is roughly equivalent to T. Use the least timeval not less than T. Return an extremal value if the result would overflow. */ @@ -681,18 +697,10 @@ enum timeform TIMEFORM_HI_LO_US, /* seconds plus microseconds (HI LO US) */ TIMEFORM_NIL, /* current time in nanoseconds */ TIMEFORM_HI_LO_US_PS, /* seconds plus micro and picoseconds (HI LO US PS) */ - /* These two should be last; see timeform_sub_ps_p. */ TIMEFORM_FLOAT, /* time as a float */ TIMEFORM_TICKS_HZ /* fractional time: HI is ticks, LO is ticks per second */ }; -/* True if Lisp times of form FORM can express sub-picosecond timestamps. */ -static bool -timeform_sub_ps_p (enum timeform form) -{ - return TIMEFORM_FLOAT <= form; -} - /* From the valid form FORM and the time components HIGH, LOW, USEC and PSEC, generate the corresponding time value. If LOW is floating point, the other components should be zero and FORM should @@ -1080,9 +1088,14 @@ time_arith (Lisp_Object a, Lisp_Object b, bool subtract) else { /* The plan is to decompose ta into na/da and tb into nb/db. - Start by computing da and db. */ + Start by computing da and db, their minimum (which will be + needed later) and the iticks temporary that will become + available once only their minimum is needed. */ mpz_t const *da = bignum_integer (&mpz[1], ta.hz); mpz_t const *db = bignum_integer (&mpz[2], tb.hz); + bool da_lt_db = mpz_cmp (*da, *db) < 0; + mpz_t const *hzmin = da_lt_db ? da : db; + mpz_t *iticks = &mpz[da_lt_db + 1]; /* The plan is to compute (na * (db/g) + nb * (da/g)) / lcm (da, db) where g = gcd (da, db). Start by computing g. */ @@ -1090,34 +1103,83 @@ time_arith (Lisp_Object a, Lisp_Object b, bool subtract) mpz_gcd (*g, *da, *db); /* fa = da/g, fb = db/g. */ - mpz_t *fa = &mpz[1], *fb = &mpz[3]; + mpz_t *fa = &mpz[4], *fb = &mpz[3]; mpz_tdiv_q (*fa, *da, *g); mpz_tdiv_q (*fb, *db, *g); - /* FIXME: Maybe omit need for extra temp by computing fa * db here? */ - - /* hz = fa * db. This is equal to lcm (da, db). */ - mpz_mul (mpz[0], *fa, *db); - hz = make_integer_mpz (); + /* ihz = fa * db. This is equal to lcm (da, db). */ + mpz_t *ihz = &mpz[0]; + mpz_mul (*ihz, *fa, *db); + + /* When warning about obsolete timestamps, if the smaller + denominator comes from a non-(TICKS . HZ) timestamp and could + generate a (TICKS . HZ) timestamp that would look obsolete, + arrange for the result to have a higher HZ to avoid a + spurious warning by a later consumer of this function's + returned value. */ + verify (1 << LO_TIME_BITS <= ULONG_MAX); + if (WARN_OBSOLETE_TIMESTAMPS + && (da_lt_db ? aform : bform) == TIMEFORM_FLOAT + && (da_lt_db ? bform : aform) != TIMEFORM_TICKS_HZ + && mpz_cmp_ui (*hzmin, 1) > 0 + && mpz_cmp_ui (*hzmin, 1 << LO_TIME_BITS) < 0) + { + mpz_t *hzmin1 = &mpz[2 - da_lt_db]; + mpz_set_ui (*hzmin1, 1 << LO_TIME_BITS); + hzmin = hzmin1; + } - /* ticks = (fb * na) OPER (fa * nb), where OPER is + or -. - OP is the multiply-add or multiply-sub form of OPER. */ - mpz_t const *na = bignum_integer (&mpz[0], ta.ticks); - mpz_mul (mpz[0], *fb, *na); + /* iticks = (fb * na) OP (fa * nb), where OP is + or -. */ + mpz_t const *na = bignum_integer (iticks, ta.ticks); + mpz_mul (*iticks, *fb, *na); mpz_t const *nb = bignum_integer (&mpz[3], tb.ticks); - (subtract ? mpz_submul : mpz_addmul) (mpz[0], *fa, *nb); + (subtract ? mpz_submul : mpz_addmul) (*iticks, *fa, *nb); + + /* Normalize iticks/ihz by dividing both numerator and + denominator by ig = gcd (iticks, ihz). However, if that + would cause the denominator to become less than hzmin, + rescale the denominator upwards from its ordinary value by + multiplying numerator and denominator so that the denominator + becomes at least hzmin. This rescaling avoids returning a + timestamp that is less precise than both a and b, or a + timestamp that looks obsolete when that might be a problem. */ + mpz_t *ig = &mpz[3]; + mpz_gcd (*ig, *iticks, *ihz); + + if (!FASTER_TIMEFNS || mpz_cmp_ui (*ig, 1) > 0) + { + mpz_tdiv_q (*iticks, *iticks, *ig); + mpz_tdiv_q (*ihz, *ihz, *ig); + + if (!FASTER_TIMEFNS || mpz_cmp (*ihz, *hzmin) < 0) + { + /* Rescale straightforwardly. Although this might not + yield the minimal denominator that preserves numeric + value and is at least hzmin, calculating such a + denominator would be too expensive because it would + require testing multisets of factors of lcm (da, db). */ + mpz_t *rescale = &mpz[3]; + mpz_cdiv_q (*rescale, *hzmin, *ihz); + mpz_mul (*iticks, *iticks, *rescale); + mpz_mul (*ihz, *ihz, *rescale); + } + } + hz = make_integer_mpz (); + mpz_swap (mpz[0], *iticks); ticks = make_integer_mpz (); } /* Return an integer if the timestamp resolution is 1, otherwise the (TICKS . HZ) form if !CURRENT_TIME_LIST or if - either input form supports timestamps that cannot be expressed + either input used (TICKS . HZ) form or the result can't be expressed exactly in (HI LO US PS) form, otherwise the (HI LO US PS) form for backward compatibility. */ return (EQ (hz, make_fixnum (1)) ? ticks : (!CURRENT_TIME_LIST - || timeform_sub_ps_p (aform) || timeform_sub_ps_p (bform)) + || aform == TIMEFORM_TICKS_HZ + || bform == TIMEFORM_TICKS_HZ + || !trillion_factor (hz)) ? Fcons (ticks, hz) : ticks_hz_list4 (ticks, hz)); } diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el index 48d964d129..3a18a4a24d 100644 --- a/test/src/timefns-tests.el +++ b/test/src/timefns-tests.el @@ -19,6 +19,12 @@ (require 'ert) +(defun timefns-tests--decode-time (look zone decoded-time) + (should (equal (decode-time look zone t) decoded-time)) + (should (equal (decode-time look zone 'integer) + (cons (time-convert (car decoded-time) 'integer) + (cdr decoded-time))))) + ;;; Check format-time-string and decode-time with various TZ settings. ;;; Use only POSIX-compatible TZ values, since the tests should work ;;; even if tzdb is not in use. @@ -40,31 +46,29 @@ (7879679999900 . 100000) (78796799999999999999 . 1000000000000))) ;; UTC. - (let ((sec (time-add 59 (time-subtract (time-convert look t) - (time-convert look 'integer))))) + (let* ((look-ticks-hz (time-convert look t)) + (hz (cdr look-ticks-hz)) + (look-integer (time-convert look 'integer)) + (sec (time-add (time-convert 59 hz) + (time-subtract look-ticks-hz + (time-convert look-integer hz))))) (should (string-equal (format-time-string "%Y-%m-%d %H:%M:%S.%3N %z" look t) "1972-06-30 23:59:59.999 +0000")) - (should (equal (decode-time look t 'integer) - '(59 59 23 30 6 1972 5 nil 0))) - (should (equal (decode-time look t t) - (list sec 59 23 30 6 1972 5 nil 0))) + (timefns-tests--decode-time look t + (list sec 59 23 30 6 1972 5 nil 0)) ;; "UTC0". (should (string-equal (format-time-string format look "UTC0") "1972-06-30 23:59:59.999 +0000 (UTC)")) - (should (equal (decode-time look "UTC0" 'integer) - '(59 59 23 30 6 1972 5 nil 0))) - (should (equal (decode-time look "UTC0" t) - (list sec 59 23 30 6 1972 5 nil 0))) + (timefns-tests--decode-time look "UTC0" + (list sec 59 23 30 6 1972 5 nil 0)) ;; Negative UTC offset, as a Lisp list. (should (string-equal (format-time-string format look '(-28800 "PST")) "1972-06-30 15:59:59.999 -0800 (PST)")) - (should (equal (decode-time look '(-28800 "PST") 'integer) - '(59 59 15 30 6 1972 5 nil -28800))) - (should (equal (decode-time look '(-28800 "PST") t) - (list sec 59 15 30 6 1972 5 nil -28800))) + (timefns-tests--decode-time look '(-28800 "PST") + (list sec 59 15 30 6 1972 5 nil -28800)) ;; Negative UTC offset, as a Lisp integer. (should (string-equal (format-time-string format look -28800) @@ -73,18 +77,14 @@ (if (eq system-type 'windows-nt) "1972-06-30 15:59:59.999 -0800 (ZZZ)" "1972-06-30 15:59:59.999 -0800 (-08)"))) - (should (equal (decode-time look -28800 'integer) - '(59 59 15 30 6 1972 5 nil -28800))) - (should (equal (decode-time look -28800 t) - (list sec 59 15 30 6 1972 5 nil -28800))) + (timefns-tests--decode-time look -28800 + (list sec 59 15 30 6 1972 5 nil -28800)) ;; Positive UTC offset that is not an hour multiple, as a string. (should (string-equal (format-time-string format look "IST-5:30") "1972-07-01 05:29:59.999 +0530 (IST)")) - (should (equal (decode-time look "IST-5:30" 'integer) - '(59 29 5 1 7 1972 6 nil 19800))) - (should (equal (decode-time look "IST-5:30" t) - (list sec 29 5 1 7 1972 6 nil 19800))))))) + (timefns-tests--decode-time look "IST-5:30" + (list sec 29 5 1 7 1972 6 nil 19800)))))) (ert-deftest decode-then-encode-time () (let ((time-values (list 0 -2 1 0.0 -0.0 -2.0 1.0 commit 7e2090ee80c9099ee953392444e1d73d10e973d4 Author: Noam Postavsky Date: Sat Aug 3 20:19:31 2019 -0400 Respect global-eldoc-mode in minibuffers (Bug#36886) * lisp/emacs-lisp/easy-mmode.el (define-globalized-minor-mode): Accept a BODY parameter. * doc/lispref/modes.texi (Defining Minor Modes): Document new parameter. * etc/NEWS: Announce it. * lisp/simple.el (read--expression): Move eldoc-mode setup to... * lisp/emacs-lisp/eldoc.el (eldoc--eval-expression-setup): ... here, new function. (global-eldoc-mode): Add or remove it to eval-expression-minibuffer-setup-hook when enabling or disabling global-eldoc-mode. This enables eldoc in the minibuffer (solving Bug#27202), only when global-eldoc-mode is enabled. diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi index 764a67e362..7185c243e2 100644 --- a/doc/lispref/modes.texi +++ b/doc/lispref/modes.texi @@ -1783,12 +1783,12 @@ don't need any. (hungry-electric-delete t))))) @end smallexample -@defmac define-globalized-minor-mode global-mode mode turn-on keyword-args@dots{} +@defmac define-globalized-minor-mode global-mode mode turn-on keyword-args@dots{} body@dots{} This defines a global toggle named @var{global-mode} whose meaning is to enable or disable the buffer-local minor mode @var{mode} in all -buffers. To turn on the minor mode in a buffer, it uses the function -@var{turn-on}; to turn off the minor mode, it calls @var{mode} with -@minus{}1 as argument. +buffers. It also executes the @var{body} forms. To turn on the minor +mode in a buffer, it uses the function @var{turn-on}; to turn off the +minor mode, it calls @var{mode} with @minus{}1 as argument. Globally enabling the mode also affects buffers subsequently created by visiting files, and buffers that use a major mode other than diff --git a/etc/NEWS b/etc/NEWS index 7c329f0044..9f25cf4af5 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2569,6 +2569,9 @@ subr.el so that it is available by default. It now always returns the non-nil argument when the other is nil. Several duplicates of 'xor' in other packages are now obsolete aliases of 'xor'. ++++ +** 'define-globalized-minor-mode' now takes BODY forms. + * Changes in Emacs 27.1 on Non-Free Operating Systems diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index be531aab84..bbc3a27504 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -363,18 +363,21 @@ No problems result if this variable is not bound. ;;;###autoload (defalias 'define-global-minor-mode 'define-globalized-minor-mode) ;;;###autoload -(defmacro define-globalized-minor-mode (global-mode mode turn-on &rest keys) +(defmacro define-globalized-minor-mode (global-mode mode turn-on &rest body) "Make a global mode GLOBAL-MODE corresponding to buffer-local minor MODE. TURN-ON is a function that will be called with no args in every buffer and that should try to turn MODE on if applicable for that buffer. -KEYS is a list of CL-style keyword arguments. As the minor mode - defined by this function is always global, any :global keyword is - ignored. Other keywords have the same meaning as in `define-minor-mode', - which see. In particular, :group specifies the custom group. - The most useful keywords are those that are passed on to the - `defcustom'. It normally makes no sense to pass the :lighter - or :keymap keywords to `define-globalized-minor-mode', since these - are usually passed to the buffer-local version of the minor mode. +Each of KEY VALUE is a pair of CL-style keyword arguments. As + the minor mode defined by this function is always global, any + :global keyword is ignored. Other keywords have the same + meaning as in `define-minor-mode', which see. In particular, + :group specifies the custom group. The most useful keywords + are those that are passed on to the `defcustom'. It normally + makes no sense to pass the :lighter or :keymap keywords to + `define-globalized-minor-mode', since these are usually passed + to the buffer-local version of the minor mode. +BODY contains code to execute each time the mode is enabled or disabled. + It is executed after toggling the mode, and before running GLOBAL-MODE-hook. If MODE's set-up depends on the major mode in effect when it was enabled, then disabling and reenabling MODE should make MODE work @@ -384,7 +387,9 @@ call another major mode in their body. When a major mode is initialized, MODE is actually turned on just after running the major mode's hook. However, MODE is not turned -on if the hook has explicitly disabled it." +on if the hook has explicitly disabled it. + +\(fn GLOBAL-MODE MODE TURN-ON [KEY VALUE]... BODY...)" (declare (doc-string 2)) (let* ((global-mode-name (symbol-name global-mode)) (mode-name (symbol-name mode)) @@ -404,12 +409,12 @@ on if the hook has explicitly disabled it." keyw) ;; Check keys. - (while (keywordp (setq keyw (car keys))) - (setq keys (cdr keys)) + (while (keywordp (setq keyw (car body))) + (pop body) (pcase keyw - (:group (setq group (nconc group (list :group (pop keys))))) - (:global (setq keys (cdr keys))) - (_ (push keyw extra-keywords) (push (pop keys) extra-keywords)))) + (:group (setq group (nconc group (list :group (pop body))))) + (:global (pop body)) + (_ (push keyw extra-keywords) (push (pop body) extra-keywords)))) `(progn (progn @@ -446,7 +451,8 @@ See `%s' for more information on %s." ;; Go through existing buffers. (dolist (buf (buffer-list)) (with-current-buffer buf - (if ,global-mode (funcall #',turn-on) (when ,mode (,mode -1)))))) + (if ,global-mode (funcall #',turn-on) (when ,mode (,mode -1))))) + ,@body) ;; Autoloading define-globalized-minor-mode autoloads everything ;; up-to-here. diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 16b5863209..2892faae21 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -207,7 +207,24 @@ expression point is on." (define-globalized-minor-mode global-eldoc-mode eldoc-mode turn-on-eldoc-mode :group 'eldoc :initialize 'custom-initialize-delay - :init-value t) + :init-value t + ;; For `read--expression', the usual global mode mechanism of + ;; `change-major-mode-hook' runs in the minibuffer before + ;; `eldoc-documentation-function' is set, so `turn-on-eldoc-mode' + ;; does nothing. Configure and enable eldoc from + ;; `eval-expression-minibuffer-setup-hook' instead. + (if global-eldoc-mode + (add-hook 'eval-expression-minibuffer-setup-hook + #'eldoc--eval-expression-setup) + (remove-hook 'eval-expression-minibuffer-setup-hook + #'eldoc--eval-expression-setup))) + +(defun eldoc--eval-expression-setup () + ;; Setup `eldoc', similar to `emacs-lisp-mode'. FIXME: Call + ;; `emacs-lisp-mode' itself? + (add-function :before-until (local 'eldoc-documentation-function) + #'elisp-eldoc-documentation-function) + (eldoc-mode +1)) ;;;###autoload (defun turn-on-eldoc-mode () diff --git a/lisp/simple.el b/lisp/simple.el index 84497c31b2..9f86d70f84 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -1587,10 +1587,8 @@ display the result of expression evaluation." (let ((minibuffer-completing-symbol t)) (minibuffer-with-setup-hook (lambda () - ;; FIXME: call emacs-lisp-mode? - (add-function :before-until (local 'eldoc-documentation-function) - #'elisp-eldoc-documentation-function) - (eldoc-mode 1) + ;; FIXME: call emacs-lisp-mode (see also + ;; `eldoc--eval-expression-setup')? (add-hook 'completion-at-point-functions #'elisp-completion-at-point nil t) (run-hooks 'eval-expression-minibuffer-setup-hook)) commit 5a9552128296478ec74594b45d0728d87450197e Author: Paul Eggert Date: Tue Aug 20 14:02:30 2019 -0700 Support larger TIMEs in (time-convert TIME t) Also, improve the doc to match current behavior. * doc/lispref/os.texi (Time Conversion): Document that time-convert signals an error for infinite or NaN args, and that (time-convert TIME t) is exact otherwise. Mention float-time as an alternative to time-convert. (Time Calculations): Document that time-add and time-subtract are exact and do not decrease HZ below the minimum of their args. * src/timefns.c (decode_float_time): Don’t signal an error for floating-point arguments whose base-FLT_RADIX exponent is not less than DBL_MANT_DIG. Instead, convert them to (TICKS . 1) values. Use two (instead of three) integer exponent comparisons in the typical case. * test/src/timefns-tests.el (time-arith-tests): Add more floating-point tests, including some tests that the old code fails. diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index 49c07380c5..dd80b04ad8 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -1346,6 +1346,8 @@ given, specifies a time to convert instead of the current time. @emph{Warning}: Since the result is floating point, it may not be exact. Do not use this function if precise time stamps are required. +For example, on typical systems @code{(float-time '(1 . 10))} displays +as @samp{0.1} but is slightly greater than 1/10. @code{time-to-seconds} is an alias for this function. @end defun @@ -1432,8 +1434,6 @@ as traditional Gregorian years do; for example, the year number @defun time-convert time &optional form This function converts a time value into a Lisp timestamp. -If the time cannot be represented exactly, it is truncated -toward minus infinity. The optional @var{form} argument specifies the timestamp form to be returned. If @var{form} is the symbol @code{integer}, this function @@ -1452,8 +1452,17 @@ Although an omitted or @code{nil} @var{form} currently acts like @code{list}, this is planned to change in a future Emacs version, so callers requiring list timestamps should pass @code{list} explicitly. -If @var{time} already has the proper form, this function might yield -@var{time} rather than a copy. +If @var{time} is infinite or a NaN, this function signals an error. +Otherwise, if @var{time} cannot be represented exactly, conversion +truncates it toward minus infinity. When @var{form} is @code{t}, +conversion is always exact so no truncation occurs, and the returned +clock resolution is no less than that of @var{time}. By way of +contrast, @code{float-time} can convert any Lisp time value without +signaling an error, although the result might not be exact. +@xref{Time of Day}. + +For efficiency this function might return a value that is @code{eq} to +@var{time}, or that otherwise shares structure with @var{time}. Although @code{(time-convert nil nil)} is equivalent to @code{(current-time)}, the latter may be a bit faster. @@ -1950,16 +1959,18 @@ The result is @code{nil} if either argument is a NaN. @defun time-subtract t1 t2 This returns the time difference @var{t1} @minus{} @var{t2} between -two time values, as a time value. However, the result is a float -if either argument is a float infinity or NaN@. +two time values, normally as a Lisp timestamp but as a float +if either argument is infinite or a NaN@. +When the result is a timestamp, it is exact and its clock +resolution is no worse than the worse of its two arguments' resolutions. If you need the difference in units -of elapsed seconds, use @code{float-time} (@pxref{Time of Day, -float-time}) to convert the result into seconds. +of elapsed seconds, you can convert it with @code{time-convert} or +@code{float-time}. @xref{Time Conversion}. @end defun @defun time-add t1 t2 -This returns the sum of two time values, as a time value. -However, the result is a float if either argument is a float infinity or NaN@. +This returns the sum of two time values, +using the same conversion rules as @code{time-subtract}. One argument should represent a time difference rather than a point in time, as a time value that is often just a single number of elapsed seconds. Here is how to add a number of seconds to a time value: diff --git a/src/timefns.c b/src/timefns.c index 2d545a4f90..3b686eb226 100644 --- a/src/timefns.c +++ b/src/timefns.c @@ -391,16 +391,36 @@ decode_float_time (double t, struct lisp_time *result) else { int exponent = ilogb (t); - if (exponent == FP_ILOGBNAN) - return EINVAL; - - /* An enormous or infinite T would make SCALE < 0 which would make - HZ < 1, which the (TICKS . HZ) representation does not allow. */ - if (DBL_MANT_DIG - 1 < exponent) - return EOVERFLOW; - - /* min so we don't scale tiny numbers as if they were normalized. */ - int scale = min (DBL_MANT_DIG - 1 - exponent, flt_radix_power_size - 1); + int scale; + if (exponent < DBL_MANT_DIG) + { + if (exponent < DBL_MIN_EXP - 1) + { + if (exponent == FP_ILOGBNAN + && (FP_ILOGBNAN != FP_ILOGB0 || isnan (t))) + return EINVAL; + /* T is tiny. SCALE must be less than FLT_RADIX_POWER_SIZE, + as otherwise T would be scaled as if it were normalized. */ + scale = flt_radix_power_size - 1; + } + else + { + /* The typical case. */ + scale = DBL_MANT_DIG - 1 - exponent; + } + } + else if (exponent < INT_MAX) + { + /* T is finite but so large that HZ would be less than 1 if + T's precision were represented exactly. SCALE must be + nonnegative, as the (TICKS . HZ) representation requires + HZ to be at least 1. So use SCALE = 0, which converts T to + (T . 1), which is the exact numeric value with too-large HZ, + which is typically better than signaling overflow. */ + scale = 0; + } + else + return FP_ILOGBNAN == INT_MAX && isnan (t) ? EINVAL : EOVERFLOW; double scaled = scalbn (t, scale); eassert (trunc (scaled) == scaled); diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el index a30b2de3a5..48d964d129 100644 --- a/test/src/timefns-tests.el +++ b/test/src/timefns-tests.el @@ -129,6 +129,12 @@ most-negative-fixnum most-positive-fixnum (1- most-negative-fixnum) (1+ most-positive-fixnum) + 1e1 -1e1 1e-1 -1e-1 + 1e8 -1e8 1e-8 -1e-8 + 1e9 -1e9 1e-9 -1e-9 + 1e10 -1e10 1e-10 -1e-10 + 1e16 -1e16 1e-16 -1e-16 + 1e37 -1e37 1e-37 -1e-37 1e+INF -1e+INF 1e+NaN -1e+NaN '(0 0 0 1) '(0 0 1 0) '(0 1 0 0) '(1 0 0 0) '(-1 0 0 0) '(1 2 3 4) '(-1 2 3 4) commit a13c64204c8ead966789abf8efe176e4f2d4f599 Author: Stephen Leake Date: Tue Aug 20 15:36:08 2019 -0700 Delete built-in ada-mode; Gnu ELPA is a good replacement * doc/misc/Makefile.in (INFO_COMMON): Delete ada-mode. * doc/misc/ada-mode.texi: Delete. * etc/NEWS: Mention ada-mode deleted. * lisp/progmodes/ada-mode.el: Delete. * lisp/progmodes/ada-prj.el: Delete. * lisp/progmodes/ada-stmt.el: Delete. * lisp/progmodes/ada-xref.el: Delete. diff --git a/doc/misc/Makefile.in b/doc/misc/Makefile.in index a03efaf8be..5490580ad2 100644 --- a/doc/misc/Makefile.in +++ b/doc/misc/Makefile.in @@ -65,7 +65,7 @@ MAKEINFO_OPTS = --force -I$(emacsdir) DOCMISC_W32 = @DOCMISC_W32@ ## Info files to build and install on all platforms. -INFO_COMMON = ada-mode auth autotype bovine calc ccmode cl \ +INFO_COMMON = auth autotype bovine calc ccmode cl \ dbus dired-x ebrowse ede ediff edt eieio \ emacs-mime epa erc ert eshell eudc efaq eww \ flymake forms gnus emacs-gnutls htmlfontify idlwave ido info.info \ diff --git a/doc/misc/ada-mode.texi b/doc/misc/ada-mode.texi deleted file mode 100644 index 1ac90cdc7f..0000000000 --- a/doc/misc/ada-mode.texi +++ /dev/null @@ -1,1526 +0,0 @@ -\input texinfo @c -*-texinfo-*- -@setfilename ../../info/ada-mode.info -@settitle Ada Mode -@include docstyle.texi - -@copying -Copyright @copyright{} 1999--2019 Free Software Foundation, Inc. - -@quotation -Permission is granted to copy, distribute and/or modify this document -under the terms of the GNU Free Documentation License, Version 1.3 or -any later version published by the Free Software Foundation; with no -Invariant Sections, with the Front-Cover Texts being ``A GNU Manual'', -and with the Back-Cover Texts as in (a) below. A copy of the license -is included in the section entitled ``GNU Free Documentation License''. - -(a) The FSF's Back-Cover Text is: ``You have the freedom to copy and -modify this GNU manual.'' -@end quotation -@end copying - -@dircategory Emacs editing modes -@direntry -* Ada mode: (ada-mode). Emacs mode for editing and compiling Ada code. -@end direntry - -@titlepage -@sp 10 -@title Ada Mode -@sp 2 -@subtitle An Emacs major mode for programming in Ada -@subtitle Ada Mode Version 4.00 -@sp 2 -@page -@vskip 0pt plus 1filll -@insertcopying -@end titlepage - -@contents - -@node Top -@top Ada Mode - -@ifnottex -@insertcopying -@end ifnottex - -@menu -* Overview:: -* Installation:: Installing Ada mode on your system -* Customization:: Setting up Ada mode to your taste -* Compiling Executing:: Working with your application within Emacs -* Project files:: Describing the organization of your project -* Compiling Examples:: A small tutorial -* Moving Through Ada Code:: Moving easily through Ada sources -* Identifier completion:: Finishing words automatically -* Automatic Smart Indentation:: Indenting your code automatically as you type -* Formatting Parameter Lists:: Formatting subprograms' parameter lists - automatically -* Automatic Casing:: Adjusting the case of words automatically -* Statement Templates:: Inserting code templates -* Comment Handling:: Reformatting comments easily -* GNU Free Documentation License:: The license for this documentation. -* Index:: -@end menu - - -@node Overview -@chapter Overview - -The Emacs mode for programming in Ada helps the user in understanding -existing code and facilitates writing new code. - -When the GNU Ada compiler GNAT is used, the cross-reference -information output by the compiler is used to provide powerful code -navigation (jump to definition, find all uses, etc.). - -When you open a file with a file extension of @file{.ads} or -@file{.adb}, Emacs will automatically load and activate Ada mode. - -Ada mode works without any customization, if you are using the GNAT -compiler (@url{https://libre2.adacore.com/}) and the GNAT default -naming convention. - -You must customize a few things if you are using a different compiler -or file naming convention; @xref{Other compiler}, @xref{Non-standard -file names}. - -In addition, you may want to customize the indentation, -capitalization, and other things; @xref{Other customization}. - -Finally, for large Ada projects, you will want to set up an Emacs -Ada mode project file for each project; @xref{Project files}. Note -that these are different from the GNAT project files used by gnatmake -and other GNAT commands. - -See the Emacs info manual, section 'Running Debuggers Under Emacs', -for general information on debugging. - -@node Installation -@chapter Installation - -Ada mode is part of the standard Emacs distribution; if you use that, -no files need to be installed. - -Ada mode is also available as a separate distribution, from the Emacs -Ada mode website -@uref{http://stephe-leake.org/emacs/ada-mode/emacs-ada-mode.html}. The -separate distribution may be more recent. - -For installing the separate distribution, see the @file{README} file -in the distribution. - -To see what version of Ada mode you have installed, do @kbd{M-x -ada-mode-version}. - -The following files are provided with the Ada mode distribution: - -@itemize @bullet - -@item -@file{ada-mode.el}: The main file for Ada mode, providing indentation, -formatting of parameter lists, moving through code, comment handling -and automatic casing. - -@item -@file{ada-prj.el}: GUI editing of Ada mode project files, using Emacs -widgets. - -@item -@file{ada-stmt.el}: Ada statement templates. - -@item -@file{ada-xref.el}: GNAT cross-references, completion of identifiers, -and compilation. Also provides project files (which are not -GNAT-specific). - -@end itemize - -@node Customization -@chapter Customizing Ada mode - -Here we assume you are familiar with setting variables in Emacs, -either thru 'customize' or in elisp (in your @file{.emacs} file). For -a basic introduction to customize, elisp, and Emacs in general, see -the tutorial in -@iftex -@cite{The GNU Emacs Manual}. -@end iftex -@ifhtml -@cite{The GNU Emacs Manual}. -@end ifhtml -@ifinfo -@ref{Top, , The GNU Emacs Manual, emacs, The GNU Emacs Manual}. -@end ifinfo - -These global Emacs settings are strongly recommended (put them in your -.emacs): - -@example -(global-font-lock-mode t) -(transient-mark-mode t) -@end example - -@samp{(global-font-lock-mode t)} turns on syntax -highlighting for all buffers (it is off by default because it may be -too slow for some machines). - -@samp{(transient-mark-mode t)} highlights selected text. - -See the Emacs help for each of these variables for more information. - -@menu -* Non-standard file names:: -* Other compiler:: -* Other customization:: -@end menu - -@node Non-standard file names -@section Non-standard file names - -By default, Ada mode is configured to use the GNAT file naming -convention, where file names are a simple modification of the Ada -names, and the extension for specs and bodies are -@samp{.ads} and @samp{.adb}, respectively. - -Ada mode uses the file extensions to allow moving from a package body -to the corresponding spec and back. - -Ada mode supports a list of alternative file extensions for specs and bodies. - -For instance, if your spec and bodies files are called -@file{@var{unit}_s.ada} and @file{@var{unit}_b.ada}, respectively, you -can add the following to your @file{.emacs} file: - -@example -(ada-add-extensions "_s.ada" "_b.ada") -@end example - -You can define additional extensions: - -@example -(ada-add-extensions ".ads" "_b.ada") -(ada-add-extensions ".ads" ".body") -@end example - -This means that whenever Ada mode looks for the body for a file -whose extension is @file{.ads}, it will take the first available file -that ends with either @file{.adb}, @file{_b.ada} or -@file{.body}. - -Similarly, if Ada mode is looking for a spec, it will look for -@file{.ads} or @file{_s.ada}. - -If the filename is not derived from the Ada name following the GNAT -convention, things are a little more complicated. You then need to -rewrite the function @code{ada-make-filename-from-adaname}. Doing that -is beyond the scope of this manual; see the current definitions in -@file{ada-mode.el} and @file{ada-xref.el} for examples. - -@node Other compiler -@section Other compiler - -By default, Ada mode is configured to use the GNU Ada compiler GNAT. - -To use a different Ada compiler, you must specify the command lines -used to run that compiler, either in lisp variables or in Emacs -Ada mode project files. See @ref{Project file variables} for the list -of project variables, and the corresponding lisp variables. - -@node Other customization -@section Other customization - -All user-settable Ada mode variables can be set via the menu -@samp{Ada | Customize}. Click on the @samp{Help} button there for help -on using customize. - -To modify a specific variable, you can directly call the function -@code{customize-variable}; just type @kbd{M-x customize-variable -@key{RET} @var{variable-name} @key{RET}}). - -Alternately, you can specify variable settings in the Emacs -configuration file, @file{.emacs}. This file is coded in Emacs lisp, -and the syntax to set a variable is the following: -@example -(setq variable-name value) -@end example - -@node Compiling Executing -@chapter Compiling Executing - -Ada projects can be compiled, linked, and executed using commands on -the Ada menu. All of these commands can be customized via a project -file (@pxref{Project files}), but the defaults are sufficient for using -the GNAT compiler for simple projects (single files, or several files -in a single directory). - -Even when no project file is used, the GUI project editor (menu -@samp{Ada | Project | Edit}) shows the settings of the various project -file variables referenced here. - -@menu -* Compile commands:: -* Compiler errors:: -@end menu - -@node Compile commands -@section Compile commands - -Here are the commands for building and using an Ada project, as -listed in the Ada menu. - -In multi-file projects, there must be one file that is the main -program. That is given by the @code{main} project file variable; -it defaults to the current file if not yet set, but is also set by the -``set main and build'' command. - -@table @code - -@item Check file -Compiles the current file in syntax check mode, by running -@code{check_cmd} defined in the current project file. This typically -runs faster than full compile mode, speeding up finding and fixing -compilation errors. - -This sets @code{main} only if it has not been set yet. - -@item Compile file -Compiles the current file, by running @code{comp_cmd} from the current -project file. - -This does not set @code{main}. - -@item Set main and Build -Sets @code{main} to the current file, then executes the Build -command. - -@item Show main -Display @code{main} in the message buffer. - -@item Build -Compiles all obsolete units of the current @code{main}, and links -@code{main}, by running @code{make_cmd} from the current project. - -This sets @code{main} only if it has not been set yet. - -@item Run -Executes the main program in a shell, displayed in a separate Emacs -buffer. This runs @code{run_cmd} from the current project. The -execution buffer allows for interactive input/output. - -To modify the run command, in particular to provide or change the -command line arguments, type @kbd{C-u} before invoking the command. - -This command is not available for a cross-compilation toolchain. - -@end table -It is important when using these commands to understand how -@code{main} is used and changed. - -Build runs 'gnatmake' on the main unit. During a typical edit/compile -session, this is the only command you need to invoke, which is why it -is bound to @kbd{C-c C-c}. It will compile all files needed by the -main unit, and display compilation errors in any of them. - -Note that Build can be invoked from any Ada buffer; typically you will -be fixing errors in files other than the main, but you don't have to -switch back to the main to invoke the compiler again. - -Novices and students typically work on single-file Ada projects. In -this case, @kbd{C-c C-m} will normally be the only command needed; it -will build the current file, rather than the last-built main. - -There are three ways to change @code{main}: - -@enumerate -@item -Invoke @samp{Ada | Set main and Build}, which sets @code{main} to -the current file. - -@item -Invoke @samp{Ada | Project | Edit}, edit @code{main} and -@code{main}, and click @samp{[save]} - -@item -Invoke @samp{Ada | Project | Load}, and load a project file that specifies @code{main} - -@end enumerate - -@node Compiler errors -@section Compiler errors - -The @code{Check file}, @code{Compile file}, and @code{Build} commands -all place compilation errors in a separate buffer named -@file{*compilation*}. - -Each line in this buffer will become active: you can simply click on -it with the middle button of the mouse, or move point to it and press -@key{RET}. Emacs will then display the relevant source file and put -point on the line and column where the error was found. - -You can also press the @kbd{C-x `} key (@code{next-error}), and Emacs -will jump to the first error. If you press that key again, it will -move you to the second error, and so on. - -Some error messages might also include references to other files. These -references are also clickable in the same way, or put point after the -line number and press @key{RET}. - -@node Project files -@chapter Project files - -An Emacs Ada mode project file specifies what directories hold sources -for your project, and allows you to customize the compilation commands -and other things on a per-project basis. - -Note that Ada mode project files @file{*.adp} are different than GNAT -compiler project files @file{*.gpr}. However, Emacs Ada mode can use a -GNAT project file to specify the project directories. If no -other customization is needed, a GNAT project file can be used without -an Emacs Ada mode project file. - -@menu -* Project File Overview:: -* GUI Editor:: -* Project file variables:: -@end menu - -@node Project File Overview -@section Project File Overview - -Project files have a simple syntax; they may be edited directly. Each -line specifies a project variable name and its value, separated by ``='': -@example -src_dir=/Projects/my_project/src_1 -src_dir=/Projects/my_project/src_2 -@end example - -Some variables (like @code{src_dir}) are lists; multiple occurrences -are concatenated. - -There must be no space between the variable name and ``='', and no -trailing spaces. - -Alternately, a GUI editor for project files is available (@pxref{GUI -Editor}). It uses Emacs widgets, similar to Emacs customize. - -The GUI editor also provides a convenient way to view current project -settings, if they have been modified using menu commands rather than -by editing the project file. - -After the first Ada mode build command is invoked, there is always a -current project file, given by the lisp variable -@code{ada-prj-default-project-file}. Currently, the only way to show -the current project file is to invoke the GUI editor. - -To find the project file the first time, Ada mode uses the following -search algorithm: - -@itemize @bullet -@item -If @code{ada-prj-default-project-file} is set, use that. - -@item -Otherwise, search for a file in the current directory with -the same base name as the Ada file, but extension given by -@code{ada-prj-file-extension} (default @code{".adp"}). - -@item -If not found, search for @file{*.adp} in the current directory; if -several are found, prompt the user to select one. - -@item -If none are found, use @file{default.adp} in the current directory (even -if it does not exist). - -@end itemize - -This algorithm always sets @code{ada-prj-default-project-file}, even -when the file does not actually exist. - -To change the project file before or after the first one is found, -invoke @samp{Ada | Project | Load ...}. - -Or, in lisp, evaluate @code{(ada-set-default-project-file "/path/file.adp")}. -This sets @code{ada-prj-default-project-file}, and reads the project file. - -You can also specify a GNAT project file to @samp{Ada | Project | Load -...} or @code{ada-set-default-project-file}. Emacs Ada mode checks the -file extension; if it is @code{.gpr}, the file is treated as a GNAT -project file. Any other extension is treated as an Emacs Ada mode -project file. - -@node GUI Editor -@section GUI Editor - -The project file editor is invoked with the menu @samp{Ada | Projects -| Edit}. - -Once in the buffer for editing the project file, you can save your -modification using the @samp{[save]} button at the bottom of the -buffer, or the @kbd{C-x C-s} binding. To cancel your modifications, -kill the buffer or click on the @samp{[cancel]} button. - -@node Project file variables -@section Project file variables - -The following variables can be defined in a project file; some can -also be defined in lisp variables. - -To set a project variable that is a list, specify each element of the -list on a separate line in the project file. - -Any project variable can be referenced in other project variables, -using a shell-like notation. For instance, if the variable -@code{comp_cmd} contains @code{$@{comp_opt@}}, the value of the -@code{comp_opt} variable will be substituted when @code{comp_cmd} is -used. - -In addition, process environment variables can be referenced using the -same syntax, or the normal @code{$var} syntax. - -Most project variables have defaults that can be changed by setting -lisp variables; the table below identifies the lisp variable for each -project variable. Lisp variables corresponding to project variables -that are lists are lisp lists. - -In general, project variables are evaluated when referenced in -Emacs Ada mode commands. Relative file paths are expanded to -absolute relative to @code{$@{build_dir@}}. - -Here is the list of variables. In the default values, the current -directory @code{"."} is the project file directory. - -@table @asis -@c defined in ada-default-prj-properties; alphabetical order - -@item @code{ada_project_path_sep} [default: @code{":" or ";"}] -Path separator for @code{ADA_PROJECT_PATH}. It defaults to the correct -value for a native implementation of GNAT for the current operating -system. The user must override this when using Windows native GNAT -with Cygwin Emacs, and perhaps in other cases. - -Lisp variable: @code{ada-prj-ada-project-path-sep}. - -@item @code{ada_project_path} [default: @code{""}] -A list of directories to search for GNAT project files. - -If set, the @code{ADA_PROJECT_PATH} process environment variable is -set to this value in the Emacs process when the Emacs Ada mode project -is selected via menu @samp{Ada | Project | Load}. - -For @code{ada_project_path}, relative file paths are expanded to -absolute when the Emacs Ada project file is read, rather than when the -project file is selected. - -For example if the project file is in the directory -@file{/home/myproject}, the environment variable @code{GDS_ROOT} is -set to @code{/home/shared}, and the project file contains: -@example -ada_project_path_sep=: -ada_project_path=$GDS_ROOT/makerules -ada_project_path=../opentoken -@end example -then as a result the environment variable @code{ADA_PROJECT_PATH} will -be set to @code{"/home/shared/makerules:/home/opentoken/"}. - -The default value is not the current value of this environment -variable, because that will typically have been set by another -project, and will therefore be incorrect for this project. - -If you have the environment variable set correctly for all of your -projects, you do not need to set this project variable. - -@item @code{bind_opt} [default: @code{""}] -Holds user binder options; used in the default build commands. - -Lisp variable: @code{ada-prj-default-bind-opt}. - -@item @code{build_dir} [default: @code{"."}] -The compile commands will be issued in this directory. - -@item @code{casing} [default: @code{("~/.emacs_case_exceptions")}] -List of files containing casing exceptions. See the help on -@code{ada-case-exception-file} for more info. -@c FIXME: section on case exceptions - -Lisp variable: @code{ada-case-exception-file}. - -@item @code{check_cmd} [default: @code{"$@{cross_prefix@}gnatmake -u -c -gnatc $@{gnatmake_opt@} $@{full_current@} -cargs $@{comp_opt@}"}] -Command used to syntax check a single file. -The name of the file is substituted for @code{full_current}. - -Lisp variable: @code{ada-prj-default-check-cmd} - -@item @code{comp_cmd} [default: @code{"$@{cross_prefix@}gnatmake -u -c $@{gnatmake_opt@} $@{full_current@} -cargs $@{comp_opt@}"}] -Command used to compile a single file. -The name of the file is substituted for @code{full_current}. - -Lisp variable: @code{ada-prj-default-comp-cmd}. - -@item @code{comp_opt} [default: @code{"-gnatq -gnatQ"}] -Holds user compiler options; used in the default compile commands. The -default value tells gnatmake to generate library files for -cross-referencing even when there are errors. - -If source code for the project is in multiple directories, the -appropriate compiler options must be added here. @ref{Set source -search path} for examples of this. Alternately, GNAT project files may -be used; @ref{Use GNAT project file}. - -Lisp variable: @code{ada-prj-default-comp-opt}. - -@item @code{cross_prefix} [default: @code{""}] -Name of target machine in a cross-compilation environment. Used in -default compile and build commands. - -@item @code{debug_cmd} [default: @code{"$@{cross_prefix@}gdb $@{main@}"}] -Command used to debug the application - -Lisp variable: @code{ada-prj-default-debugger}. - -@item @code{debug_post_cmd} [default: @code{""}] -Command executed after @code{debug_cmd}. - -@item @code{debug_pre_cmd} [default: @code{"cd $@{build_dir@}"}] -Command executed before @code{debug_cmd}. - -@item @code{gnatfind_opt} [default: @code{"-rf"}] -Holds user gnatfind options; used in the default find commands. - -Lisp variable: @code{ada-prj-gnatfind-switches}. - -@item @code{gnatmake_opt} [default: @code{"-g"}] -Holds user gnatmake options; used in the default build commands. - -Lisp variable: @code{ada-prj-default-gnatmake-opt}. - -@item @code{gpr_file} [default: @code{""}] -Specify GNAT project file. - -If set, the source and object directories specified in the GNAT -project file are appended to @code{src_dir} and @code{obj_dir}. This -allows specifying Ada source directories with a GNAT project file, and -other source directories with the Emacs project file. - -In addition, @code{-P@{gpr_file@}} is added to the project variable -@code{gnatmake_opt} whenever it is referenced. With the default -project variables, this passes the project file to all gnatmake -commands. - -Lisp variable: @code{ada-prj-default-gpr-file}. - -@c FIXME: add gnatstub-opts - -@item @code{link_opt} [default: @code{""}] -Holds user linker options; used in the default build commands. - -Lisp variable: @code{ada-prj-default-link-opt}. - -@item @code{main} [default: current file] -Specifies the name of the executable file for the project; used in the -default build commands. - -@item @code{make_cmd} [default: @code{"$@{cross_prefix@}gnatmake -o $@{main@} $@{main@} $@{gnatmake_opt@} -cargs $@{comp_opt@} -bargs $@{bind_opt@} -largs $@{link_opt@}"}] -Command used to build the application. - -Lisp variable: @code{ada-prj-default-make-cmd}. - -@item @code{obj_dir} [default: @code{"."}] -A list of directories to search for library files. Ada mode searches -this list for the @samp{.ali} files generated by GNAT that contain -cross-reference information. - -The compiler commands must place the @samp{.ali} files in one of these -directories; the default commands do that. - -@item @code{remote_machine} [default: @code{""}] -Name of the machine to log into before issuing the compile and build -commands. If this variable is empty, the command will be run on the -local machine. - -@item @code{run_cmd} [default: @code{"./$@{main@}"}] -Command used to run the application. - -@item @code{src_dir} [default: @code{"."}] -A list of directories to search for source files, both for compile -commands and source navigation. - -@end table - -@node Compiling Examples -@chapter Compiling Examples - -We present several small projects, and walk thru the process of -compiling, linking, and running them. - -The first example illustrates more Ada mode features than the others; -you should work thru that example before doing the others. - -All of these examples assume you are using GNAT. - -The source for these examples is available on the Emacs Ada mode -website mentioned in @xref{Installation}. - -@menu -* No project files:: Just menus -* Set compiler options:: A basic Ada mode project file -* Set source search path:: Source in multiple directories -* Use GNAT project file:: -* Use multiple GNAT project files:: -@end menu - -@node No project files -@section No project files -This example uses no project files. - -First, create a directory @file{Example_1}, containing: - -@file{hello.adb}: - -@example -with Ada.Text_IO; -procedure Hello -is begin - Put_Line("Hello from hello.adb"); -end Hello; -@end example - -Yes, this is missing ``use Ada.Text_IO;'' - we want to demonstrate -compiler error handling. - -@file{hello_2.adb}: - -@example -with Hello_Pkg; -procedure Hello_2 -is begin - Hello_Pkg.Say_Hello; -end Hello_2; -@end example - -This file has no errors. - -@file{hello_pkg.ads}: - -@example -package Hello_Pkg is - procedure Say_Hello; -end Hello_Pkg; -@end example - -This file has no errors. - -@file{hello_pkg.adb}: - -@example -with Ada.Text_IO; -package Hello_Pkg is - procedure Say_Hello - is begin - Ada.Text_IO.Put_Line ("Hello from hello_pkg.adb"); - end Say_Hello; -end Hello_Pkg; -@end example - -Yes, this is missing the keyword @code{body}; another compiler error -example. - -In buffer @file{hello.adb}, invoke @samp{Ada | Check file}. You should -get a @file{*compilation*} buffer containing something like (the -directory paths will be different): - -@smallexample -cd c:/Examples/Example_1/ -gnatmake -u -c -gnatc -g c:/Examples/Example_1/hello.adb -cargs -gnatq -gnatQ -gcc -c -Ic:/Examples/Example_1/ -gnatc -g -gnatq -gnatQ -I- c:/Examples/Example_1/hello.adb -hello.adb:4:04: "Put_Line" is not visible -hello.adb:4:04: non-visible declaration at a-textio.ads:264 -hello.adb:4:04: non-visible declaration at a-textio.ads:260 -gnatmake: "c:/Examples/Example_1/hello.adb" compilation error -@end smallexample - -If you have enabled font-lock, the lines with actual errors (starting -with @file{hello.adb}) are highlighted, with the file name in red. - -Now type @kbd{C-x `} (on a PC keyboard, @key{`} is next to @key{1}). -Or you can click the middle mouse button on the first error line. The -compilation buffer scrolls to put the first error on the top line, and -point is put at the place of the error in the @file{hello.adb} buffer. - -To fix the error, change the line to be - -@example - Ada.Text_IO.Put_Line ("hello from hello.adb"); -@end example - -Now invoke @samp{Ada | Show main}; this displays @samp{Ada mode main: hello}. - -Now (in buffer @file{hello.adb}), invoke @samp{Ada | Build}. You are -prompted to save the file (if you haven't already). Then the -compilation buffer is displayed again, containing: - -@example -cd c:/Examples/Example_1/ -gnatmake -o hello hello -g -cargs -gnatq -gnatQ -bargs -largs -gcc -c -g -gnatq -gnatQ hello.adb -gnatbind -x hello.ali -gnatlink hello.ali -o hello.exe -g -@end example - -The compilation has succeeded without errors; @file{hello.exe} now -exists in the same directory as @file{hello.adb}. - -Now invoke @samp{Ada | Run}. A @file{*run*} buffer is displayed, -containing - -@example -Hello from hello.adb - -Process run finished -@end example - -That completes the first part of this example. - -Now we will compile a multi-file project. Open the file -@file{hello_2.adb}, and invoke @samp{Ada | Set main and Build}. This -finds an error in @file{hello_pkg.adb}: - -@example -cd c:/Examples/Example_1/ -gnatmake -o hello_2 hello_2 -g -cargs -gnatq -gnatQ -bargs -largs -gcc -c -g -gnatq -gnatQ hello_pkg.adb -hello_pkg.adb:2:08: keyword "body" expected here [see file name] -gnatmake: "hello_pkg.adb" compilation error -@end example - -This demonstrates that gnatmake finds the files needed by the main -program. However, it cannot find files in a different directory, -unless you use an Emacs Ada mode project file to specify the other directories; -@xref{Set source search path}, or a GNAT project file; @ref{Use GNAT -project file}. - -Invoke @samp{Ada | Show main}; this displays @file{Ada mode main: hello_2}. - -Move to the error with @kbd{C-x `}, and fix the error by adding @code{body}: - -@example -package body Hello_Pkg is -@end example - -Now, while still in @file{hello_pkg.adb}, invoke @samp{Ada | Build}. -gnatmake successfully builds @file{hello_2}. This demonstrates that -Emacs has remembered the main file, in the project variable -@code{main}, and used it for the Build command. - -Finally, again while in @file{hello_pkg.adb}, invoke @samp{Ada | Run}. -The @file{*run*} buffer displays @code{Hello from hello_pkg.adb}. - -One final point. If you switch back to buffer @file{hello.adb}, and -invoke @samp{Ada | Run}, @file{hello_2.exe} will be run. That is -because @code{main} is still set to @code{hello_2}, as you can -see when you invoke @samp{Ada | Project | Edit}. - -There are three ways to change @code{main}: - -@enumerate -@item -Invoke @samp{Ada | Set main and Build}, which sets @code{main} to -the current file. - -@item -Invoke @samp{Ada | Project | Edit}, edit @code{main}, and click @samp{[save]} - -@item -Invoke @samp{Ada | Project | Load}, and load a project file that specifies @code{main} - -@end enumerate - -@node Set compiler options -@section Set compiler options - -This example illustrates using an Emacs Ada mode project file to set a -compiler option. - -If you have files from @file{Example_1} open in Emacs, you should -close them so you don't get confused. Use menu @samp{File | Close -(current buffer)}. - -In directory @file{Example_2}, create these files: - -@file{hello.adb}: - -@example -with Ada.Text_IO; -procedure Hello -is begin - Put_Line("Hello from hello.adb"); -end Hello; -@end example - -This is the same as @file{hello.adb} from @file{Example_1}. It has two -errors; missing ``use Ada.Text_IO;'', and no space between -@code{Put_Line} and its argument list. - -@file{hello.adp}: - -@example -comp_opt=-gnatyt -@end example - -This tells the GNAT compiler to check for token spacing; in -particular, there must be a space preceding a parenthesis. - -In buffer @file{hello.adb}, invoke @samp{Ada | Project | Load...}, and -select @file{Example_2/hello.adp}. - -Then, again in buffer @file{hello.adb}, invoke @samp{Ada | Set main and -Build}. You should get a @file{*compilation*} buffer containing -something like (the directory paths will be different): - -@example -cd c:/Examples/Example_2/ -gnatmake -o hello hello -g -cargs -gnatyt -bargs -largs -gcc -c -g -gnatyt hello.adb -hello.adb:4:04: "Put_Line" is not visible -hello.adb:4:04: non-visible declaration at a-textio.ads:264 -hello.adb:4:04: non-visible declaration at a-textio.ads:260 -hello.adb:4:12: (style) space required -gnatmake: "hello.adb" compilation error -@end example - -Compare this to the compiler output in @ref{No project files}; the -gnatmake option @code{-cargs -gnatq -gnatQ} has been replaced by -@code{-cargs -gnaty}, and an additional error is reported in -@file{hello.adb} on line 4. This shows that @file{hello.adp} is being -used to set the compiler options. - -Fixing the error, linking and running the code proceed as in @ref{No -project files}. - -@node Set source search path -@section Set source search path - -In this example, we show how to deal with files in more than one -directory. We start with the same code as in @ref{No project files}; -create those files (with the errors present) - -Create the directory @file{Example_3}, containing: - -@file{hello_pkg.ads}: - -@example -package Hello_Pkg is - procedure Say_Hello; -end Hello_Pkg; -@end example - -@file{hello_pkg.adb}: - -@example -with Ada.Text_IO; -package Hello_Pkg is - procedure Say_Hello - is begin - Ada.Text_IO.Put_Line ("Hello from hello_pkg.adb"); - end Say_Hello; -end Hello_Pkg; -@end example - -These are the same files from example 1; @file{hello_pkg.adb} has an -error on line 2. - -In addition, create a directory @file{Example_3/Other}, containing these files: - -@file{Other/hello_3.adb}: - -@example -with Hello_Pkg; -with Ada.Text_IO; use Ada.Text_IO; -procedure Hello_3 -is begin - Hello_Pkg.Say_Hello; - Put_Line ("From hello_3"); -end Hello_3; -@end example - -There are no errors in this file. - -@file{Other/other.adp}: - -@example -src_dir=.. -comp_opt=-I.. -@end example - -Note that there must be no trailing spaces. - -In buffer @file{hello_3.adb}, invoke @samp{Ada | Project | Load...}, and -select @file{Example_3/Other/other.adp}. - -Then, again in @file{hello_3.adb}, invoke @samp{Ada | Set main and -Build}. You should get a @file{*compilation*} buffer containing -something like (the directory paths will be different): - -@example -cd c:/Examples/Example_3/Other/ -gnatmake -o hello_3 hello_3 -g -cargs -I.. -bargs -largs -gcc -c -g -I.. hello_3.adb -gcc -c -I./ -g -I.. -I- C:\Examples\Example_3\hello_pkg.adb -hello_pkg.adb:2:08: keyword "body" expected here [see file name] -gnatmake: "C:\Examples\Example_3\hello_pkg.adb" compilation error -@end example - -Compare the @code{-cargs} option to the compiler output in @ref{Set -compiler options}; this shows that @file{other.adp} is being used to -set the compiler options. - -Move to the error with @kbd{C-x `}. Ada mode searches the list of -directories given by @code{src_dir} for the file mentioned in the -compiler error message. - -Fixing the error, linking and running the code proceed as in @ref{No -project files}. - -@node Use GNAT project file -@section Use GNAT project file - -In this example, we show how to use a GNAT project file, with no Ada -mode project file. - -Create the directory @file{Example_4}, containing: - -@file{hello_pkg.ads}: - -@example -package Hello_Pkg is - procedure Say_Hello; -end Hello_Pkg; -@end example - -@file{hello_pkg.adb}: - -@example -with Ada.Text_IO; -package Hello_Pkg is - procedure Say_Hello - is begin - Ada.Text_IO.Put_Line ("Hello from hello_pkg.adb"); - end Say_Hello; -end Hello_Pkg; -@end example - -These are the same files from example 1; @file{hello_pkg.adb} has an -error on line 2. - -In addition, create a directory @file{Example_4/Gnat_Project}, -containing these files: - -@file{Gnat_Project/hello_4.adb}: - -@example -with Hello_Pkg; -with Ada.Text_IO; use Ada.Text_IO; -procedure Hello_4 -is begin - Hello_Pkg.Say_Hello; - Put_Line ("From hello_4"); -end Hello_4; -@end example - -There are no errors in this file. - -@file{Gnat_Project/hello_4.gpr}: - -@example -Project Hello_4 is - for Source_Dirs use (".", ".."); -end Hello_4; -@end example - -In buffer @file{hello_4.adb}, invoke @samp{Ada | Project | Load...}, and -select @file{Example_4/Gnat_Project/hello_4.gpr}. - -Then, again in @file{hello_4.adb}, invoke @samp{Ada | Set main and -Build}. You should get a @file{*compilation*} buffer containing -something like (the directory paths will be different): - -@smallexample -cd c:/Examples/Example_4/Gnat_Project/ -gnatmake -o hello_4 hello_4 -Phello_4.gpr -cargs -gnatq -gnatQ -bargs -largs -gcc -c -g -gnatyt -gnatq -gnatQ -I- -gnatA c:\Examples\Example_4\Gnat_Project\hello_4.adb -gcc -c -g -gnatyt -gnatq -gnatQ -I- -gnatA c:\Examples\Example_4\hello_pkg.adb -hello_pkg.adb:2:08: keyword "body" expected here [see file name] -gnatmake: "c:\examples\example_4\hello_pkg.adb" compilation error -@end smallexample - -Compare the @code{gcc} options to the compiler output in @ref{Set -compiler options}; this shows that @file{hello_4.gpr} is being used to -set the compiler options. - -Fixing the error, linking and running the code proceed as in @ref{No -project files}. - -@node Use multiple GNAT project files -@section Use multiple GNAT project files - -In this example, we show how to use multiple GNAT project files, -specifying the GNAT project search path in an Ada mode project file. - -Create the directory @file{Example_4} as specified in @ref{Use GNAT -project file}. - -Create the directory @file{Example_5}, containing: - -@file{hello_5.adb}: - -@example -with Hello_Pkg; -with Ada.Text_IO; use Ada.Text_IO; -procedure Hello_5 -is begin - Hello_Pkg.Say_Hello; - Put_Line ("From hello_5"); -end Hello_5; -@end example - -There are no errors in this file. - -@file{hello_5.adp}: - -@example -ada_project_path=../Example_4/Gnat_Project -gpr_file=hello_5.gpr -@end example - -@file{hello_5.gpr}: - -@example -with "hello_4"; -Project Hello_5 is - for Source_Dirs use ("."); - package Compiler is - for Default_Switches ("Ada") use ("-g", "-gnatyt"); - end Compiler; -end Hello_5; -@end example - -In buffer @file{hello_5.adb}, invoke @samp{Ada | Project | Load...}, and -select @file{Example_5/hello_5.adp}. - -Then, again in @file{hello_5.adb}, invoke @samp{Ada | Set main and -Build}. You should get a @file{*compilation*} buffer containing -something like (the directory paths will be different): - -@smallexample -cd c:/Examples/Example_5/ -gnatmake -o hello_5 hello_5 -Phello_5.gpr -g -cargs -gnatq -gnatQ -bargs -largs -gcc -c -g -gnatyt -g -gnatq -gnatQ -I- -gnatA c:\Examples\Example_5\hello_5.adb -gcc -c -g -gnatyt -g -gnatq -gnatQ -I- -gnatA c:\Examples\Example_4\hello_pkg.adb -hello_pkg.adb:2:08: keyword "body" expected here [see file name] -gnatmake: "c:\examples\example_4\hello_pkg.adb" compilation error -@end smallexample - -Now type @kbd{C-x `}. @file{Example_4/hello_pkg.adb} is shown, -demonstrating that @file{hello_5.gpr} and @file{hello_4.gpr} are being -used to set the compilation search path. - -@node Moving Through Ada Code -@chapter Moving Through Ada Code - -There are several easy to use commands to navigate through Ada code. All -these functions are available through the Ada menu, and you can also -use the following key bindings or the command names. Some of these -menu entries are available only if the GNAT compiler is used, since -the implementation relies on the GNAT cross-referencing information. - -@table @kbd -@item M-C-e -@findex ada-next-procedure -Move to the next function/procedure/task, which ever comes next -(@code{ada-next-procedure}). -@item M-C-a -@findex ada-previous-procedure -Move to previous function/procedure/task -(@code{ada-previous-procedure}). -@item M-x ada-next-package -@findex ada-next-package -Move to next package. -@item M-x ada-previous-package -@findex ada-previous-package -Move to previous package. -@item C-c C-a -@findex ada-move-to-start -Move to matching start of @code{end} (@code{ada-move-to-start}). If -point is at the end of a subprogram, this command jumps to the -corresponding @code{begin} if the user option -@code{ada-move-to-declaration} is @code{nil} (default), otherwise it jumps to -the subprogram declaration. -@item C-c C-e -@findex ada-move-to-end -Move point to end of current block (@code{ada-move-to-end}). -@item C-c o -Switch between corresponding spec and body file -(@code{ff-find-other-file}). If point is in a subprogram, position -point on the corresponding declaration or body in the other file. -@item C-c c-d -@findex ada-goto-declaration -Move from any reference to its declaration, for from a declaration to -its body (for procedures, tasks, private and incomplete types). -@item C-c C-r -@findex ada-find-references -Runs the @file{gnatfind} command to search for all references to the -identifier surrounding point (@code{ada-find-references}). Use -@kbd{C-x `} (@code{next-error}) to visit each reference (as for -compilation errors). -@end table - -If the @code{ada-xref-create-ali} variable is non-@code{nil}, Emacs -will try to run GNAT for you whenever cross-reference information is -needed, and is older than the current source file. - -@node Identifier completion -@chapter Identifier completion - -Emacs and Ada mode provide two general ways for the completion of -identifiers. This is an easy way to type faster: you just have to type -the first few letters of an identifiers, and then loop through all the -possible completions. - -The first method is general for Emacs. It works by parsing all open -files for possible completions. - -For instance, if the words @samp{my_identifier}, @samp{my_subprogram} -are the only words starting with @samp{my} in any of the opened files, -then you will have this scenario: - -@example -You type: my@kbd{M-/} -Emacs inserts: @samp{my_identifier} -If you press @kbd{M-/} once again, Emacs replaces @samp{my_identifier} with -@samp{my_subprogram}. -Pressing @kbd{M-/} once more will bring you back to @samp{my_identifier}. -@end example - -This is a very fast way to do completion, and the casing of words will -also be respected. - -The second method (@kbd{C-@key{TAB}}) is specific to Ada mode and the GNAT -compiler. Emacs will search the cross-information for possible -completions. - -The main advantage is that this completion is more accurate: only -existing identifier will be suggested. - -On the other hand, this completion is a little bit slower and requires -that you have compiled your file at least once since you created that -identifier. - -@table @kbd -@item C-@key{TAB} -@findex ada-complete-identifier -Complete current identifier using cross-reference information. -@item M-/ -Complete identifier using buffer information (not Ada-specific). -@end table - -@node Automatic Smart Indentation -@chapter Automatic Smart Indentation - -Ada mode comes with a full set of rules for automatic indentation. You -can also configure the indentation, via the following variables: - -@table @asis -@item @code{ada-broken-indent} (default value: 2) -Number of columns to indent the continuation of a broken line. - -@item @code{ada-indent} (default value: 3) -Number of columns for default indentation. - -@item @code{ada-indent-record-rel-type} (default value: 3) -Indentation for @code{record} relative to @code{type} or @code{use}. - -@item @code{ada-indent-return} (default value: 0) -Indentation for @code{return} relative to @code{function} (if -@code{ada-indent-return} is greater than 0), or the open parenthesis -(if @code{ada-indent-return} is negative or 0). Note that in the second -case, when there is no open parenthesis, the indentation is done -relative to @code{function} with the value of @code{ada-broken-indent}. - -@item @code{ada-label-indent} (default value: -4) -Number of columns to indent a label. - -@item @code{ada-stmt-end-indent} (default value: 0) -Number of columns to indent a statement @code{end} keyword on a separate line. - -@item @code{ada-when-indent} (default value: 3) -Indentation for @code{when} relative to @code{exception} or @code{case}. - -@item @code{ada-indent-is-separate} (default value: t) -Non-@code{nil} means indent @code{is separate} or @code{is abstract} if on a single line. - -@item @code{ada-indent-to-open-paren} (default value: t) -Non-@code{nil} means indent according to the innermost open parenthesis. - -@item @code{ada-indent-after-return} (default value: t) -Non-@code{nil} means that the current line will also be re-indented -before inserting a newline, when you press @key{RET}. -@end table - -Most of the time, the indentation will be automatic, i.e., when you -press @key{RET}, the cursor will move to the correct column on the -next line. - -You can also indent single lines, or the current region, with @key{TAB}. - -Another mode of indentation exists that helps you to set up your -indentation scheme. If you press @kbd{C-c @key{TAB}}, Ada mode will do -the following: - -@itemize @bullet -@item -Reindent the current line, as @key{TAB} would do. -@item -Temporarily move the cursor to a reference line, i.e., the line that -was used to calculate the current indentation. -@item -Display in the message window the name of the variable that provided -the offset for the indentation. -@end itemize - -The exact indentation of the current line is the same as the one for the -reference line, plus an offset given by the variable. - -@table @kbd -@item @key{TAB} -Indent the current line or the current region. -@item C-M-\ -Indent lines in the current region. -@item C-c @key{TAB} -Indent the current line and display the name of the variable used for -indentation. -@end table - -@node Formatting Parameter Lists -@chapter Formatting Parameter Lists - -@table @kbd -@item C-c C-f -@findex ada-format-paramlist -Format the parameter list (@code{ada-format-paramlist}). -@end table - -This aligns the declarations on the colon (@samp{:}) separating -argument names and argument types, and aligns the @code{in}, -@code{out} and @code{in out} keywords. - -@node Automatic Casing -@chapter Automatic Casing - -Casing of identifiers, attributes and keywords is automatically -performed while typing when the variable @code{ada-auto-case} is set. -Every time you press a word separator, the previous word is -automatically cased. - -You can customize the automatic casing differently for keywords, -attributes and identifiers. The relevant variables are the following: -@code{ada-case-keyword}, @code{ada-case-attribute} and -@code{ada-case-identifier}. - -All these variables can have one of the following values: - -@table @code -@item downcase-word -The word will be lowercase. For instance @code{My_vARIable} is -converted to @code{my_variable}. - -@item upcase-word -The word will be uppercase. For instance @code{My_vARIable} is -converted to @code{MY_VARIABLE}. - -@item ada-capitalize-word -The first letter and each letter following an underscore (@samp{_}) -are uppercase, others are lowercase. For instance @code{My_vARIable} -is converted to @code{My_Variable}. - -@item ada-loose-case-word -Characters after an underscore @samp{_} character are uppercase, -others are not modified. For instance @code{My_vARIable} is converted -to @code{My_VARIable}. -@end table - -Ada mode allows you to define exceptions to these rules, in a file -specified by the variable @code{ada-case-exception-file} -(default @file{~/.emacs_case_exceptions}). Each line in this file -specifies the casing of one word or word fragment. Comments may be -included, separated from the word by a space. - -If the word starts with an asterisk (@samp{*}), it defines the casing -as a word fragment (or ``substring''); part of a word between two -underscores or word boundary. - -For example: - -@example -DOD Department of Defense -*IO -GNAT The GNAT compiler from Ada Core Technologies -@end example - -The word fragment @code{*IO} applies to any word containing ``_io''; -@code{Text_IO}, @code{Hardware_IO}, etc. - -@findex ada-create-case-exception -There are two ways to add new items to this file: you can simply edit -it as you would edit any text file. Or you can position point on the -word you want to add, and select menu @samp{Ada | Edit | Create Case -Exception}, or press @kbd{C-c C-y} (@code{ada-create-case-exception}). -The word will automatically be added to the current list of exceptions -and to the file. - -To define a word fragment case exception, select the word fragment, -then select menu @samp{Ada | Edit | Create Case Exception Substring}. - -It is sometimes useful to have multiple exception files around (for -instance, one could be the standard Ada acronyms, the second some -company specific exceptions, and the last one some project specific -exceptions). If you set up the variable @code{ada-case-exception-file} -as a list of files, each of them will be parsed and used in your emacs -session. However, when you save a new exception through the menu, as -described above, the new exception will be added to the first file in -the list. - -@table @kbd -@item C-c C-b -@findex ada-adjust-case-buffer -Adjust case in the whole buffer (@code{ada-adjust-case-buffer}). -@item C-c C-y -Create a new entry in the exception dictionary, with the word under -the cursor (@code{ada-create-case-exception}) -@item C-c C-t -@findex ada-case-read-exceptions -Rereads the exception dictionary from the file -@code{ada-case-exception-file} (@code{ada-case-read-exceptions}). -@end table - -@node Statement Templates -@chapter Statement Templates - -Templates are defined for most Ada statements, using the Emacs -``skeleton'' package. They can be inserted in the buffer using the -following commands: - -@table @kbd -@item C-c t b -@findex ada-exception-block -exception Block (@code{ada-exception-block}). -@item C-c t c -@findex ada-case -case (@code{ada-case}). -@item C-c t d -@findex ada-declare-block -declare Block (@code{ada-declare-block}). -@item C-c t e -@findex ada-else -else (@code{ada-else}). -@item C-c t f -@findex ada-for-loop -for Loop (@code{ada-for-loop}). -@item C-c t h -@findex ada-header -Header (@code{ada-header}). -@item C-c t i -@findex ada-if -if (@code{ada-if}). -@item C-c t k -@findex ada-package-body -package Body (@code{ada-package-body}). -@item C-c t l -@findex ada-loop -loop (@code{ada-loop}). -@item C-c p -@findex ada-subprogram-body -subprogram body (@code{ada-subprogram-body}). -@item C-c t t -@findex ada-task-body -task Body (@code{ada-task-body}). -@item C-c t w -@findex ada-while -while Loop (@code{ada-while}). -@item C-c t u -@findex ada-use -use (@code{ada-use}). -@item C-c t x -@findex ada-exit -exit (@code{ada-exit}). -@item C-c t C-a -@findex ada-array -array (@code{ada-array}). -@item C-c t C-e -@findex ada-elsif -elsif (@code{ada-elsif}). -@item C-c t C-f -@findex ada-function-spec -function Spec (@code{ada-function-spec}). -@item C-c t C-k -@findex ada-package-spec -package Spec (@code{ada-package-spec}). -@item C-c t C-p -@findex ada-procedure-spec -procedure Spec (@code{ada-package-spec}. -@item C-c t C-r -@findex ada-record -record (@code{ada-record}). -@item C-c t C-s -@findex ada-subtype -subtype (@code{ada-subtype}). -@item C-c t C-t -@findex ada-task-spec -task Spec (@code{ada-task-spec}). -@item C-c t C-u -@findex ada-with -with (@code{ada-with}). -@item C-c t C-v -@findex ada-private -private (@code{ada-private}). -@item C-c t C-w -@findex ada-when -when (@code{ada-when}). -@item C-c t C-x -@findex ada-exception -exception (@code{ada-exception}). -@item C-c t C-y -@findex ada-type -type (@code{ada-type}). -@end table - -@node Comment Handling -@chapter Comment Handling - -By default, comment lines get indented like Ada code. There are a few -additional functions to handle comments: - -@table @kbd -@item M-; -Start a comment in default column. -@item M-j -Continue comment on next line. -@item C-c ; -Comment the selected region (add @samp{--} at the beginning of lines). -@item C-c : -Uncomment the selected region -@item M-q -autofill the current comment. -@end table - -@node GNU Free Documentation License -@appendix GNU Free Documentation License -@include doclicense.texi - -@node Index -@unnumbered Index - -@printindex fn - -@bye diff --git a/etc/NEWS b/etc/NEWS index 56e5fd2f83..7c329f0044 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1835,6 +1835,11 @@ This results in the use of Gravatar's default size of 80 pixels. This is possible using the new user options 'gravatar-default-image' and 'gravatar-force-default'. +** ada-mode + +*** The built-in ada-mode is now deleted. The Gnu ELPA package is a +good replacement, even in very large source files. + * New Modes and Packages in Emacs 27.1 diff --git a/lisp/progmodes/ada-mode.el b/lisp/progmodes/ada-mode.el deleted file mode 100644 index 4a4e1a7aad..0000000000 --- a/lisp/progmodes/ada-mode.el +++ /dev/null @@ -1,5493 +0,0 @@ -;;; ada-mode.el --- major-mode for editing Ada sources - -;; Copyright (C) 1994-1995, 1997-2019 Free Software Foundation, Inc. - -;; Author: Rolf Ebert -;; Markus Heritsch -;; Emmanuel Briot -;; Maintainer: Stephen Leake -;; Keywords: languages ada -;; Version: 4.0 - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Commentary: -;; This mode is a major mode for editing Ada code. This is a major -;; rewrite of the file packaged with Emacs-20. The Ada mode is -;; composed of four Lisp files: ada-mode.el, ada-xref.el, ada-prj.el -;; and ada-stmt.el. Only this file (ada-mode.el) is completely -;; independent from the GNU Ada compiler GNAT, distributed by Ada -;; Core Technologies. All the other files rely heavily on features -;; provided only by GNAT. - -;;; Usage: -;; Emacs should enter Ada mode automatically when you load an Ada file. -;; By default, the valid extensions for Ada files are .ads, .adb or .ada -;; If the ada-mode does not start automatically, then simply type the -;; following command : -;; M-x ada-mode -;; -;; By default, ada-mode is configured to take full advantage of the GNAT -;; compiler (the menus will include the cross-referencing features,...). -;; If you are using another compiler, you might want to set the following -;; variable in your .emacs (Note: do not set this in the ada-mode-hook, it -;; won't work) : -;; (setq ada-which-compiler 'generic) -;; -;; This mode requires find-file.el to be present on your system. - -;;; History: -;; The first Ada mode for GNU Emacs was written by V. Broman in -;; 1985. He based his work on the already existing Modula-2 mode. -;; This was distributed as ada.el in versions of Emacs prior to 19.29. -;; -;; Lynn Slater wrote an extensive Ada mode in 1989. It consisted of -;; several files with support for dired commands and other nice -;; things. It is currently available from the PAL -;; (wuarchive.wustl.edu:/languages/ada) as ada-mode-1.06a.tar.Z. -;; -;; The probably very first Ada mode (called electric-ada.el) was -;; written by Steven D. Litvintchouk and Steven M. Rosen for the -;; Gosling Emacs. L. Slater based his development on ada.el and -;; electric-ada.el. -;; -;; A complete rewrite by M. Heritsch and R. Ebert has been done. -;; Some ideas from the Ada mode mailing list have been -;; added. Some of the functionality of L. Slater's mode has not -;; (yet) been recoded in this new mode. Perhaps you prefer sticking -;; to his version. -;; -;; A complete rewrite for Emacs-20 / GNAT-3.11 has been done by Ada Core -;; Technologies. - -;;; Credits: -;; Many thanks to John McCabe for sending so -;; many patches included in this package. -;; Christian Egli : -;; ada-imenu-generic-expression -;; Many thanks also to the following persons that have contributed -;; to the ada-mode -;; Philippe Waroquiers (PW) in particular, -;; woodruff@stc.llnl.gov (John Woodruff) -;; jj@ddci.dk (Jesper Joergensen) -;; gse@ocsystems.com (Scott Evans) -;; comar@gnat.com (Cyrille Comar) -;; stephen.leake@gsfc.nasa.gov (Stephen Leake) -;; robin-reply@reagans.org -;; and others for their valuable hints. - -;;; Code: -;; Note: Every function in this package is compiler-independent. -;; The names start with ada- -;; The variables that the user can edit can all be modified through -;; the customize mode. They are sorted in alphabetical order in this -;; file. - -;; Supported packages. -;; This package supports a number of other Emacs modes. These other modes -;; should be loaded before the ada-mode, which will then setup some variables -;; to improve the support for Ada code. -;; Here is the list of these modes: -;; `which-function-mode': Display in the mode line the name of the subprogram -;; the cursor is in. -;; `outline-mode': Provides the capability to collapse or expand the code -;; for specific language constructs, for instance if you want to hide the -;; code corresponding to a subprogram -;; `align': This mode is now provided with Emacs 21, but can also be -;; installed manually for older versions of Emacs. It provides the -;; capability to automatically realign the selected region (for instance -;; all ':=', ':' and '--' will be aligned on top of each other. -;; `imenu': Provides a menu with the list of entities defined in the current -;; buffer, and an easy way to jump to any of them -;; `speedbar': Provides a separate file browser, and the capability for each -;; file to see the list of entities defined in it and to jump to them -;; easily -;; `abbrev-mode': Provides the capability to define abbreviations, which -;; are automatically expanded when you type them. See the Emacs manual. - -(require 'find-file nil t) -(require 'align nil t) -(require 'which-func nil t) -(require 'compile nil t) - -(defvar ispell-check-comments) -(defvar skeleton-further-elements) - -(define-error 'ada-mode-errors nil) - -(defun ada-mode-version () - "Return Ada mode version." - (interactive) - (let ((version-string "4.00")) - (if (called-interactively-p 'interactive) - (message version-string) - version-string))) - -(defvar ada-mode-hook nil - "List of functions to call when Ada mode is invoked. -This hook is automatically executed after the `ada-mode' is -fully loaded. -This is a good place to add Ada environment specific bindings.") - -(defgroup ada nil - "Major mode for editing and compiling Ada source in Emacs." - :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) - :link '(custom-manual "(ada-mode) Top") - :link '(emacs-commentary-link :tag "Commentary" "ada-mode.el") - :group 'languages) - -(defcustom ada-auto-case t - "Non-nil means automatically change case of preceding word while typing. -Casing is done according to `ada-case-keyword', `ada-case-identifier' -and `ada-case-attribute'." - :type 'boolean :group 'ada) - -(defcustom ada-broken-decl-indent 0 - "Number of columns to indent a broken declaration. - -An example is : - declare - A, - >>>>>B : Integer;" - :type 'integer :group 'ada) - -(defcustom ada-broken-indent 2 - "Number of columns to indent the continuation of a broken line. - -An example is : - My_Var : My_Type := (Field1 => - >>>>>>>>>Value);" - :type 'integer :group 'ada) - -(defcustom ada-continuation-indent ada-broken-indent - "Number of columns to indent the continuation of broken lines in parenthesis. - -An example is : - Func (Param1, - >>>>>Param2);" - :type 'integer :group 'ada) - -(defcustom ada-case-attribute 'ada-capitalize-word - "Function to call to adjust the case of Ada attributes. -It may be `downcase-word', `upcase-word', `ada-loose-case-word', -`ada-capitalize-word' or `ada-no-auto-case'." - :type '(choice (const downcase-word) - (const upcase-word) - (const ada-capitalize-word) - (const ada-loose-case-word) - (const ada-no-auto-case)) - :group 'ada) - -(defcustom ada-case-exception-file - (list (convert-standard-filename' "~/.emacs_case_exceptions")) - "List of special casing exceptions dictionaries for identifiers. -The first file is the one where new exceptions will be saved by Emacs -when you call `ada-create-case-exception'. - -These files should contain one word per line, that gives the casing -to be used for that word in Ada files. If the line starts with the -character *, then the exception will be used for substrings that either -start at the beginning of a word or after a _ character, and end either -at the end of the word or at a _ character. Each line can be terminated -by a comment." - :type '(repeat (file)) - :group 'ada) - -(defcustom ada-case-keyword 'downcase-word - "Function to call to adjust the case of an Ada keywords. -It may be `downcase-word', `upcase-word', `ada-loose-case-word' or -`ada-capitalize-word'." - :type '(choice (const downcase-word) - (const upcase-word) - (const ada-capitalize-word) - (const ada-loose-case-word) - (const ada-no-auto-case)) - :group 'ada) - -(defcustom ada-case-identifier 'ada-loose-case-word - "Function to call to adjust the case of an Ada identifier. -It may be `downcase-word', `upcase-word', `ada-loose-case-word' or -`ada-capitalize-word'." - :type '(choice (const downcase-word) - (const upcase-word) - (const ada-capitalize-word) - (const ada-loose-case-word) - (const ada-no-auto-case)) - :group 'ada) - -(defcustom ada-clean-buffer-before-saving t - "Non-nil means remove trailing spaces and untabify the buffer before saving." - :type 'boolean :group 'ada) -(make-obsolete-variable 'ada-clean-buffer-before-saving - "it has no effect - use `write-file-functions' hook." - "23.2") - - -(defcustom ada-indent 3 - "Size of Ada indentation. - -An example is : -procedure Foo is -begin ->>>>>>>>>>null;" - :type 'integer :group 'ada) - -(defcustom ada-indent-after-return t - "Non-nil means automatically indent after RET or LFD." - :type 'boolean :group 'ada) - -(defcustom ada-indent-align-comments t - "Non-nil means align comments on previous line comments, if any. -If nil, indentation is calculated as usual. -Note that indentation is calculated only if `ada-indent-comment-as-code' is t. - -For instance: - A := 1; -- A multi-line comment - -- aligned if `ada-indent-align-comments' is t" - :type 'boolean :group 'ada) - -(defcustom ada-indent-comment-as-code t - "Non-nil means indent comment lines as code. -A nil value means do not auto-indent comments." - :type 'boolean :group 'ada) - -(defcustom ada-indent-handle-comment-special nil - "Non-nil if comment lines should be handled specially inside parenthesis. -By default, if the line that contains the open parenthesis has some -text following it, then the following lines will be indented in the -same column as this text. This will not be true if the first line is -a comment and `ada-indent-handle-comment-special' is t. - -type A is - ( Value_1, -- common behavior, when not a comment - Value_2); - -type A is - ( -- `ada-indent-handle-comment-special' is nil - Value_1, - Value_2); - -type A is - ( -- `ada-indent-handle-comment-special' is non-nil - Value_1, - Value_2);" - :type 'boolean :group 'ada) - -(defcustom ada-indent-is-separate t - "Non-nil means indent `is separate' or `is abstract' if on a single line." - :type 'boolean :group 'ada) - -(defcustom ada-indent-record-rel-type 3 - "Indentation for `record' relative to `type' or `use'. - -An example is: - type A is - >>>>>>>>>>>record" - :type 'integer :group 'ada) - -(defcustom ada-indent-renames ada-broken-indent - "Indentation for renames relative to the matching function statement. -If `ada-indent-return' is null or negative, the indentation is done relative to -the open parenthesis (if there is no parenthesis, `ada-broken-indent' is used). - -An example is: - function A (B : Integer) - return C; - >>>renames Foo;" - :type 'integer :group 'ada) - -(defcustom ada-indent-return 0 - "Indentation for `return' relative to the matching `function' statement. -If `ada-indent-return' is null or negative, the indentation is done relative to -the open parenthesis (if there is no parenthesis, `ada-broken-indent' is used). - -An example is: - function A (B : Integer) - >>>>>return C;" - :type 'integer :group 'ada) - -(defcustom ada-indent-to-open-paren t - "Non-nil means indent according to the innermost open parenthesis." - :type 'boolean :group 'ada) - -(defcustom ada-fill-comment-prefix "-- " - "Text inserted in the first columns when filling a comment paragraph. -Note: if you modify this variable, you will have to invoke `ada-mode' -again to take account of the new value." - :type 'string :group 'ada) - -(defcustom ada-fill-comment-postfix " --" - "Text inserted at the end of each line when filling a comment paragraph. -Used by `ada-fill-comment-paragraph-postfix'." - :type 'string :group 'ada) - -(defcustom ada-label-indent -4 - "Number of columns to indent a label. - -An example is: -procedure Foo is -begin ->>>>Label: - -This is also used for <<..>> labels" - :type 'integer :group 'ada) - -(defcustom ada-language-version 'ada95 - "Ada language version; one of `ada83', `ada95', `ada2005'." - :type '(choice (const ada83) (const ada95) (const ada2005)) :group 'ada) - -(defcustom ada-move-to-declaration nil - "Non-nil means `ada-move-to-start' moves to the subprogram declaration, not to `begin'." - :type 'boolean :group 'ada) - -(defcustom ada-popup-key '[down-mouse-3] - "Key used for binding the contextual menu. -If nil, no contextual menu is available." - :type '(restricted-sexp :match-alternatives (stringp vectorp)) - :group 'ada) - -(defcustom ada-search-directories - (append '(".") - (split-string (or (getenv "ADA_INCLUDE_PATH") "") ":") - '("/usr/adainclude" "/usr/local/adainclude" - "/opt/gnu/adainclude")) - "Default list of directories to search for Ada files. -See the description for the `ff-search-directories' variable. This variable -is the initial value of `ada-search-directories-internal'." - :type '(repeat (choice :tag "Directory" - (const :tag "default" nil) - (directory :format "%v"))) - :group 'ada) - -(defvar ada-search-directories-internal ada-search-directories - "Internal version of `ada-search-directories'. -Its value is the concatenation of the search path as read in the project file -and the standard runtime location, and the value of the user-defined -`ada-search-directories'.") - -(defcustom ada-stmt-end-indent 0 - "Number of columns to indent the end of a statement on a separate line. - -An example is: - if A = B - >>>>then" - :type 'integer :group 'ada) - -(defcustom ada-tab-policy 'indent-auto - "Control the behavior of the TAB key. -Must be one of : -`indent-rigidly' : always adds `ada-indent' blanks at the beginning of the line. -`indent-auto' : use indentation functions in this file. -`always-tab' : do `indent-relative'." - :type '(choice (const indent-auto) - (const indent-rigidly) - (const always-tab)) - :group 'ada) - -(defcustom ada-use-indent ada-broken-indent - "Indentation for the lines in a `use' statement. - -An example is: - use Ada.Text_IO, - >>>>Ada.Numerics;" - :type 'integer :group 'ada) - -(defcustom ada-when-indent 3 - "Indentation for `when' relative to `exception' or `case'. - -An example is: - case A is - >>>>when B =>" - :type 'integer :group 'ada) - -(defcustom ada-with-indent ada-broken-indent - "Indentation for the lines in a `with' statement. - -An example is: - with Ada.Text_IO, - >>>>Ada.Numerics;" - :type 'integer :group 'ada) - -(defcustom ada-which-compiler 'gnat - "Name of the compiler to use. -This will determine what features are made available through the Ada mode. -The possible choices are: -`gnat': Use Ada Core Technologies' GNAT compiler. Add some cross-referencing - features. -`generic': Use a generic compiler." - :type '(choice (const gnat) - (const generic)) - :group 'ada) - - -;;; ---- end of user configurable variables - - -(defvar ada-body-suffixes '(".adb") - "List of possible suffixes for Ada body files. -The extensions should include a `.' if needed.") - -(defvar ada-spec-suffixes '(".ads") - "List of possible suffixes for Ada spec files. -The extensions should include a `.' if needed.") - -(defvar ada-mode-menu (make-sparse-keymap "Ada") - "Menu for Ada mode.") - -(defvar ada-mode-map (make-sparse-keymap) - "Local keymap used for Ada mode.") - -(defvar ada-mode-extra-map (make-sparse-keymap) - "Keymap used for non-standard keybindings.") - -;; default is C-c C-q because it's free in ada-mode-map -(defvar ada-mode-extra-prefix "\C-c\C-q" - "Prefix key to access `ada-mode-extra-map' functions.") - -(define-abbrev-table 'ada-mode-abbrev-table () - "Local abbrev table for Ada mode.") - -(eval-when-compile - ;; These values are used in eval-when-compile expressions. - (defconst ada-83-string-keywords - '("abort" "abs" "accept" "access" "all" "and" "array" "at" "begin" - "body" "case" "constant" "declare" "delay" "delta" "digits" "do" - "else" "elsif" "end" "entry" "exception" "exit" "for" "function" - "generic" "goto" "if" "in" "is" "limited" "loop" "mod" "new" - "not" "null" "of" "or" "others" "out" "package" "pragma" "private" - "procedure" "raise" "range" "record" "rem" "renames" "return" - "reverse" "select" "separate" "subtype" "task" "terminate" "then" - "type" "use" "when" "while" "with" "xor") - "List of Ada 83 keywords. -Used to define `ada-*-keywords'.") - - (defconst ada-95-string-keywords - '("abstract" "aliased" "protected" "requeue" "tagged" "until") - "List of keywords new in Ada 95. -Used to define `ada-*-keywords'.") - - (defconst ada-2005-string-keywords - '("interface" "overriding" "synchronized") - "List of keywords new in Ada 2005. -Used to define `ada-*-keywords.'")) - -(defvar ada-ret-binding nil - "Variable to save key binding of RET when casing is activated.") - -(defvar ada-case-exception '() - "Alist of words (entities) that have special casing.") - -(defvar ada-case-exception-substring '() - "Alist of substrings (entities) that have special casing. -The substrings are detected for word constituent when the word -is not itself in `ada-case-exception', and only for substrings that -either are at the beginning or end of the word, or start after `_'.") - -(defvar ada-lfd-binding nil - "Variable to save key binding of LFD when casing is activated.") - -(defvar ada-other-file-alist nil - "Variable used by `find-file' to find the name of the other package. -See `ff-other-file-alist'.") - -(defvar ada-align-list - '(("[^:]\\(\\s-*\\):[^:]" 1 t) - ("[^=]\\(\\s-+\\)=[^=]" 1 t) - ("\\(\\s-*\\)use\\s-" 1) - ("\\(\\s-*\\)--" 1)) - "Ada support for align.el <= 2.2. -This variable provides regular expressions on which to align different lines. -See `align-mode-alist' for more information.") - -(defvar ada-align-modes - '((ada-declaration - (regexp . "[^:]\\(\\s-*\\):[^:]") - (valid . (lambda() (not (ada-in-comment-p)))) - (modes . '(ada-mode))) - (ada-assignment - (regexp . "[^=]\\(\\s-+\\)=[^=]") - (valid . (lambda() (not (ada-in-comment-p)))) - (modes . '(ada-mode))) - (ada-comment - (regexp . "\\(\\s-*\\)--") - (modes . '(ada-mode))) - (ada-use - (regexp . "\\(\\s-*\\)use\\s-") - (valid . (lambda() (not (ada-in-comment-p)))) - (modes . '(ada-mode))) - ) - "Ada support for align.el >= 2.8. -This variable defines several rules to use to align different lines.") - -(defconst ada-align-region-separate - (eval-when-compile - (concat - "^\\s-*\\($\\|\\(" - "begin\\|" - "declare\\|" - "else\\|" - "end\\|" - "exception\\|" - "for\\|" - "function\\|" - "generic\\|" - "if\\|" - "is\\|" - "procedure\\|" - "record\\|" - "return\\|" - "type\\|" - "when" - "\\)\\>\\)")) - "See the variable `align-region-separate' for more information.") - -;;; ---- Below are the regexp used in this package for parsing - -(defconst ada-83-keywords - (eval-when-compile - (concat "\\<" (regexp-opt ada-83-string-keywords t) "\\>")) - "Regular expression matching Ada83 keywords.") - -(defconst ada-95-keywords - (eval-when-compile - (concat "\\<" (regexp-opt - (append - ada-95-string-keywords - ada-83-string-keywords) t) "\\>")) - "Regular expression matching Ada95 keywords.") - -(defconst ada-2005-keywords - (eval-when-compile - (concat "\\<" (regexp-opt - (append - ada-2005-string-keywords - ada-83-string-keywords - ada-95-string-keywords) t) "\\>")) - "Regular expression matching Ada2005 keywords.") - -(defvar ada-keywords ada-2005-keywords - "Regular expression matching Ada keywords.") -;; FIXME: make this customizable - -(defconst ada-ident-re - "[[:alpha:]]\\(?:[_[:alnum:]]\\)*" - ;; [:alnum:] matches any multibyte word constituent, as well as - ;; Latin-1 letters and numbers. This allows __ and trailing _; - ;; someone (emacs bug#1919) proposed [^\W_] to fix that, but \W does - ;; _not_ mean "not word constituent" inside a character alternative. - "Regexp matching an Ada identifier.") - -(defconst ada-goto-label-re - (concat "<<" ada-ident-re ">>") - "Regexp matching a goto label.") - -(defconst ada-block-label-re - (concat ada-ident-re "[ \t\n]*:[^=]") - "Regexp matching a block label. -Note that this also matches a variable declaration.") - -(defconst ada-label-re - (concat "\\(?:" ada-block-label-re "\\)\\|\\(?:" ada-goto-label-re "\\)") - "Regexp matching a goto or block label.") - -;; "with" needs to be included in the regexp, to match generic subprogram parameters -;; Similarly, we put '[not] overriding' on the same line with 'procedure' etc. -(defvar ada-procedure-start-regexp - (concat - "^[ \t]*\\(with[ \t]+\\)?\\(\\(not[ \t]+\\)?overriding[ \t]+\\)?\\(procedure\\|function\\|task\\)[ \t\n]+" - - ;; subprogram name: operator ("[+/=*]") - "\\(" - "\\(\"[^\"]+\"\\)" - - ;; subprogram name: name - "\\|" - "\\(\\(\\sw\\|[_.]\\)+\\)" - "\\)") - "Regexp matching Ada subprogram start. -The actual start is at (match-beginning 4). The name is in (match-string 5).") - -(defconst ada-name-regexp - "\\([a-zA-Z][a-zA-Z0-9_.']*[a-zA-Z0-9]\\)" - "Regexp matching a fully qualified name (including attribute).") - -(defconst ada-package-start-regexp - (concat "^[ \t]*\\(private[ \t]+\\)?\\(package\\)[ \t\n]+\\(body[ \t]*\\)?" ada-name-regexp) - "Regexp matching start of package. -The package name is in (match-string 4).") - -(defconst ada-compile-goto-error-file-linenr-re - "\\([-_.a-zA-Z0-9]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?" - "Regexp matching filename:linenr[:column].") - - -;;; ---- regexps for indentation functions - -(defvar ada-block-start-re - (eval-when-compile - (concat "\\<\\(" (regexp-opt '("begin" "declare" "else" - "exception" "generic" "loop" "or" - "private" "select" )) - "\\|\\(\\(limited\\|abstract\\|tagged\\)[ \t\n]+\\)*record\\)\\>")) - "Regexp for keywords starting Ada blocks.") - -(defvar ada-end-stmt-re - (eval-when-compile - (concat "\\(" - ";" "\\|" - "=>[ \t]*$" "\\|" - "=>[ \t]*--.*$" "\\|" - "^[ \t]*separate[ \t]*(\\(\\sw\\|[_.]\\)+)" "\\|" - "\\<" (regexp-opt '("begin" "declare" "is" "do" "else" "generic" - "loop" "private" "record" "select" - "then abort" "then") t) "\\>" "\\|" - "^[ \t]*" (regexp-opt '("function" "package" "procedure") - t) "\\>\\(\\sw\\|[ \t_.]\\)+\\" "\\|" - "^[ \t]*exception\\>" - "\\)") ) - "Regexp of possible ends for a non-broken statement. -A new statement starts after these.") - -(defvar ada-matching-start-re - (eval-when-compile - (concat "\\<" - (regexp-opt - '("end" "loop" "select" "begin" "case" "do" "declare" - "if" "task" "package" "procedure" "function" "record" "protected") t) - "\\>")) - "Regexp used in `ada-goto-matching-start'.") - -(defvar ada-loop-start-re - "\\<\\(for\\|while\\|loop\\)\\>" - "Regexp for the start of a loop.") - -(defvar ada-subprog-start-re - (eval-when-compile - (concat "\\<" (regexp-opt '("accept" "entry" "function" "overriding" "package" "procedure" - "protected" "task") t) "\\>")) - "Regexp for the start of a subprogram.") - -(defvar ada-contextual-menu-on-identifier nil - "Set to true when the right mouse button was clicked on an identifier.") - -(defvar ada-contextual-menu-last-point nil - "Position of point just before displaying the menu. -This is a list (point buffer). -Since `ada-popup-menu' moves the point where the user clicked, the region -is modified. Therefore no command from the menu knows what the user selected -before displaying the contextual menu. -To get the original region, restore the point to this position before -calling `region-end' and `region-beginning'. -Modify this variable if you want to restore the point to another position.") - -(easy-menu-define ada-contextual-menu nil - "Menu to use when the user presses the right mouse button. -The variable `ada-contextual-menu-on-identifier' will be set to t before -displaying the menu if point was on an identifier." - '("Ada" - ["Goto Declaration/Body" ada-point-and-xref - :included ada-contextual-menu-on-identifier] - ["Goto Body" ada-point-and-xref-body - :included ada-contextual-menu-on-identifier] - ["Goto Previous Reference" ada-xref-goto-previous-reference] - ["List References" ada-find-references - :included ada-contextual-menu-on-identifier] - ["List Local References" ada-find-local-references - :included ada-contextual-menu-on-identifier] - ["-" nil nil] - ["Other File" ff-find-other-file] - ["Goto Parent Unit" ada-goto-parent])) - - -;;------------------------------------------------------------------ -;; Support for imenu (see imenu.el) -;;------------------------------------------------------------------ - -(defconst ada-imenu-comment-re "\\([ \t]*--.*\\)?") - -(defconst ada-imenu-subprogram-menu-re - (concat "^[ \t]*\\(overriding[ \t]*\\)?\\(procedure\\|function\\)[ \t\n]+" - "\\(\\(\\sw\\|_\\)+\\)[ \t\n]*\\([ \t\n]\\|([^)]+)" - ada-imenu-comment-re - "\\)[ \t\n]*" - "\\(return[ \t\n]+\\(\\sw\\|[_.]\\)+[ \t\n]*\\)?is[ \t\n]")) - -(defvar ada-imenu-generic-expression - (list - (list nil ada-imenu-subprogram-menu-re 3) - (list "*Specs*" - (concat - "^[ \t]*\\(procedure\\|function\\)[ \t\n]+\\(\\(\\sw\\|_\\)+\\)" - "\\(" - "\\(" ada-imenu-comment-re "[ \t\n]+\\|[ \t\n]*([^)]+)" - ada-imenu-comment-re "\\)";; parameter list or simple space - "\\([ \t\n]*return[ \t\n]+\\(\\sw\\|[_.]\\)+[ \t\n]*\\)?" - "\\)?;") 2) - '("*Tasks*" "^[ \t]*task[ \t]+\\(type[ \t]+\\)?\\(\\(body[ \t]+\\)?\\(\\sw\\|_\\)+\\)" 2) - '("*Type Defs*" "^[ \t]*\\(sub\\)?type[ \t]+\\(\\(\\sw\\|_\\)+\\)" 2) - '("*Protected*" - "^[ \t]*protected[ \t]+\\(type[ \t]+\\)?\\(\\(body[ \t]+\\)?\\(\\sw\\|_\\)+\\)" 2) - '("*Packages*" "^[ \t]*package[ \t]+\\(\\(body[ \t]+\\)?\\(\\sw\\|[_.]\\)+\\)" 1)) - "Imenu generic expression for Ada mode. -See `imenu-generic-expression'. This variable will create several submenus for -each type of entity that can be found in an Ada file.") - - -;;------------------------------------------------------------ -;; Support for compile.el -;;------------------------------------------------------------ - -(defun ada-compile-mouse-goto-error () - "Mouse interface for `ada-compile-goto-error'." - (interactive) - (mouse-set-point last-input-event) - (ada-compile-goto-error (point)) - ) - -(defun ada-compile-goto-error (pos) - "Replace `compile-goto-error' from compile.el. -If POS is on a file and line location, go to this position. It adds -to compile.el the capacity to go to a reference in an error message. -For instance, on these lines: - foo.adb:61:11: [...] in call to size declared at foo.ads:11 - foo.adb:61:11: [...] in call to local declared at line 20 -the 4 file locations can be clicked on and jumped to." - (interactive "d") - (goto-char pos) - - (skip-chars-backward "-a-zA-Z0-9_:./\\\\") - (cond - ;; special case: looking at a filename:line not at the beginning of a line - ;; or a simple line reference "at line ..." - ((and (not (bolp)) - (or (looking-at ada-compile-goto-error-file-linenr-re) - (and - (save-excursion - (beginning-of-line) - (looking-at ada-compile-goto-error-file-linenr-re)) - (save-excursion - (if (looking-at "\\([0-9]+\\)") (backward-word-strictly 1)) - (looking-at "line \\([0-9]+\\)")))) - ) - (let ((line (if (match-beginning 2) (match-string 2) (match-string 1))) - (file (if (match-beginning 2) (match-string 1) - (save-excursion (beginning-of-line) - (looking-at ada-compile-goto-error-file-linenr-re) - (match-string 1)))) - (error-pos (point-marker)) - source) - - ;; set source marker - (save-excursion - (compilation-find-file (point-marker) (match-string 1) "./") - (set-buffer file) - - (when (stringp line) - (goto-char (point-min)) - (forward-line (1- (string-to-number line)))) - - (setq source (point-marker))) - - (compilation-goto-locus error-pos source nil) - - )) - - ;; otherwise, default behavior - (t - (compile-goto-error)) - ) - (recenter)) - - -;;------------------------------------------------------------------------- -;; Grammar related function -;; The functions below work with the syntax class of the characters in an Ada -;; buffer. Two syntax tables are created, depending on whether we want '_' -;; to be considered as part of a word or not. -;; Some characters may have multiple meanings depending on the context: -;; - ' is either the beginning of a constant character or an attribute -;; - # is either part of a based literal or a gnatprep statement. -;; - " starts a string, but not if inside a constant character. -;; - ( and ) should be ignored if inside a constant character. -;; Thus their syntax property is changed automatically, and we can still use -;; the standard Emacs functions for sexp (see `ada-in-string-p') -;; -;; On Emacs, this is done through the `syntax-table' text property. The -;; corresponding action is applied automatically each time the buffer -;; changes via syntax-propertize-function. -;; -;; on XEmacs, the `syntax-table' property does not exist and we have to use a -;; slow advice to `parse-partial-sexp' to do the same thing. -;; When executing parse-partial-sexp, we simply modify the strings before and -;; after, so that the special constants '"', '(' and ')' do not interact -;; with parse-partial-sexp. -;; Note: this code is slow and needs to be rewritten as soon as something -;; better is available on XEmacs. -;;------------------------------------------------------------------------- - -(defvar ada-mode-syntax-table - (let ((st (make-syntax-table))) - ;; Define string brackets (`%' is alternative string bracket, but - ;; almost never used as such and throws font-lock and indentation - ;; off the track.) - (modify-syntax-entry ?% "$" st) - (modify-syntax-entry ?\" "\"" st) - - (modify-syntax-entry ?: "." st) - (modify-syntax-entry ?\; "." st) - (modify-syntax-entry ?& "." st) - (modify-syntax-entry ?\| "." st) - (modify-syntax-entry ?+ "." st) - (modify-syntax-entry ?* "." st) - (modify-syntax-entry ?/ "." st) - (modify-syntax-entry ?= "." st) - (modify-syntax-entry ?< "." st) - (modify-syntax-entry ?> "." st) - (modify-syntax-entry ?$ "." st) - (modify-syntax-entry ?\[ "." st) - (modify-syntax-entry ?\] "." st) - (modify-syntax-entry ?\{ "." st) - (modify-syntax-entry ?\} "." st) - (modify-syntax-entry ?. "." st) - (modify-syntax-entry ?\\ "." st) - (modify-syntax-entry ?\' "." st) - - ;; A single hyphen is punctuation, but a double hyphen starts a comment. - (modify-syntax-entry ?- ". 12" st) - - ;; See the comment above on grammar related function for the special - ;; setup for '#'. - (modify-syntax-entry ?# (if (featurep 'xemacs) "<" "$") st) - - ;; And \f and \n end a comment. - (modify-syntax-entry ?\f "> " st) - (modify-syntax-entry ?\n "> " st) - - ;; Define what belongs in Ada symbols. - (modify-syntax-entry ?_ "_" st) - - ;; Define parentheses to match. - (modify-syntax-entry ?\( "()" st) - (modify-syntax-entry ?\) ")(" st) - st) - "Syntax table to be used for editing Ada source code.") - -(defvar ada-mode-symbol-syntax-table - (let ((st (make-syntax-table ada-mode-syntax-table))) - (modify-syntax-entry ?_ "w" st) - st) - "Syntax table for Ada, where `_' is a word constituent.") - -;; Support of special characters in XEmacs (see the comments at the beginning -;; of the section on Grammar related functions). - -(if (featurep 'xemacs) - (defadvice parse-partial-sexp (around parse-partial-sexp-protect-constants) - "Handles special character constants and gnatprep statements." - (let (change) - (if (< to from) - (let ((tmp from)) - (setq from to to tmp))) - (save-excursion - (goto-char from) - (while (re-search-forward "'\\([(\")#]\\)'" to t) - (setq change (cons (list (match-beginning 1) - 1 - (match-string 1)) - change)) - (replace-match "'A'")) - (goto-char from) - (while (re-search-forward "\\(#[[:xdigit:]]*#\\)" to t) - (setq change (cons (list (match-beginning 1) - (length (match-string 1)) - (match-string 1)) - change)) - (replace-match (make-string (length (match-string 1)) ?@)))) - ad-do-it - (save-excursion - (while change - (goto-char (caar change)) - (delete-char (cadar change)) - (insert (caddar change)) - (setq change (cdr change))))))) - -(unless (eval-when-compile (fboundp 'syntax-propertize-via-font-lock)) - ;; Before `syntax-propertize', we had to use font-lock to apply syntax-table - ;; properties, and in some cases we even had to do it manually (in - ;; `ada-after-change-function'). `ada-handle-syntax-table-properties' - ;; decides which method to use. - -(defun ada-set-syntax-table-properties () - "Assign `syntax-table' properties in accessible part of buffer. -In particular, character constants are said to be strings, #...# -are treated as numbers instead of gnatprep comments." - (let ((modified (buffer-modified-p)) - (buffer-undo-list t) - (inhibit-read-only t) - (inhibit-point-motion-hooks t) - (inhibit-modification-hooks t)) - (remove-text-properties (point-min) (point-max) '(syntax-table nil)) - (goto-char (point-min)) - (while (re-search-forward - ;; The following regexp was adapted from - ;; `ada-font-lock-syntactic-keywords'. - "^[ \t]*\\(#\\(?:if\\|else\\|elsif\\|end\\)\\)\\|[^a-zA-Z0-9)]\\('\\)[^'\n]\\('\\)" - nil t) - (if (match-beginning 1) - (put-text-property - (match-beginning 1) (match-end 1) 'syntax-table '(11 . ?\n)) - (put-text-property - (match-beginning 2) (match-end 2) 'syntax-table '(7 . ?')) - (put-text-property - (match-beginning 3) (match-end 3) 'syntax-table '(7 . ?')))) - (unless modified - (restore-buffer-modified-p nil)))) - -(defun ada-after-change-function (beg end _old-len) - "Called when the region between BEG and END was changed in the buffer. -OLD-LEN indicates what the length of the replaced text was." - (save-excursion - (save-restriction - (let ((from (progn (goto-char beg) (line-beginning-position))) - (to (progn (goto-char end) (line-end-position)))) - (narrow-to-region from to) - (save-match-data - (ada-set-syntax-table-properties)))))) - -(defun ada-initialize-syntax-table-properties () - "Assign `syntax-table' properties in current buffer." - (save-excursion - (save-restriction - (widen) - (save-match-data - (ada-set-syntax-table-properties)))) - (add-hook 'after-change-functions 'ada-after-change-function nil t)) - -(defun ada-handle-syntax-table-properties () - "Handle `syntax-table' properties." - (if font-lock-mode - ;; `font-lock-mode' will take care of `syntax-table' properties. - (remove-hook 'after-change-functions 'ada-after-change-function t) - ;; Take care of `syntax-table' properties manually. - (ada-initialize-syntax-table-properties))) - -) ;;(not (fboundp 'syntax-propertize)) - -;;------------------------------------------------------------------ -;; Testing the grammatical context -;;------------------------------------------------------------------ - -(defsubst ada-in-comment-p (&optional parse-result) - "Return t if inside a comment. -If PARSE-RESULT is non-nil, use it instead of calling `parse-partial-sexp'." - (nth 4 (or parse-result - (parse-partial-sexp - (line-beginning-position) (point))))) - -(defsubst ada-in-string-p (&optional parse-result) - "Return t if point is inside a string. -If PARSE-RESULT is non-nil, use it instead of calling `parse-partial-sexp'." - (nth 3 (or parse-result - (parse-partial-sexp - (line-beginning-position) (point))))) - -(defsubst ada-in-string-or-comment-p (&optional parse-result) - "Return t if inside a comment or string. -If PARSE-RESULT is non-nil, use it instead of calling `parse-partial-sexp'." - (setq parse-result (or parse-result - (parse-partial-sexp - (line-beginning-position) (point)))) - (or (ada-in-string-p parse-result) (ada-in-comment-p parse-result))) - -(defsubst ada-in-numeric-literal-p () - "Return t if point is after a prefix of a numeric literal." - (looking-back "\\([0-9]+#[[:xdigit:]_]+\\)" (line-beginning-position))) - -;;------------------------------------------------------------------ -;; Contextual menus -;; The Ada mode comes with contextual menus, bound by default to the right -;; mouse button. -;; Add items to this menu by modifying `ada-contextual-menu'. Note that the -;; variable `ada-contextual-menu-on-identifier' is set automatically to t -;; if the mouse button was pressed on an identifier. -;;------------------------------------------------------------------ - -(defun ada-call-from-contextual-menu (function) - "Execute FUNCTION when called from the contextual menu. -It forces Emacs to change the cursor position." - (interactive) - (funcall function) - (setq ada-contextual-menu-last-point - (list (point) (current-buffer)))) - -(defun ada-popup-menu (position) - "Pops up a contextual menu, depending on where the user clicked. -POSITION is the location the mouse was clicked on. -Sets `ada-contextual-menu-last-point' to the current position before -displaying the menu. When a function from the menu is called, the -point is where the mouse button was clicked." - (interactive "e") - - ;; declare this as a local variable, so that the function called - ;; in the contextual menu does not hide the region in - ;; transient-mark-mode. - (let ((deactivate-mark nil)) - (setq ada-contextual-menu-last-point - (list (point) (current-buffer))) - (mouse-set-point last-input-event) - - (setq ada-contextual-menu-on-identifier - (and (char-after) - (or (= (char-syntax (char-after)) ?w) - (= (char-after) ?_)) - (not (ada-in-string-or-comment-p)) - (save-excursion (skip-syntax-forward "w") - (not (ada-after-keyword-p))) - )) - (if (fboundp 'popup-menu) - (funcall (symbol-function 'popup-menu) ada-contextual-menu) - (let (choice) - (setq choice (x-popup-menu position ada-contextual-menu)) - (if choice - (funcall (lookup-key ada-contextual-menu (vector (car choice))))))) - - (set-buffer (cadr ada-contextual-menu-last-point)) - (goto-char (car ada-contextual-menu-last-point)) - )) - - -;;------------------------------------------------------------------ -;; Misc functions -;;------------------------------------------------------------------ - -;;;###autoload -(defun ada-add-extensions (spec body) - "Define SPEC and BODY as being valid extensions for Ada files. -Going from body to spec with `ff-find-other-file' used these -extensions. -SPEC and BODY are two regular expressions that must match against -the file name." - (let* ((reg (concat (regexp-quote body) "$")) - (tmp (assoc reg ada-other-file-alist))) - (if tmp - (setcdr tmp (list (cons spec (cadr tmp)))) - (add-to-list 'ada-other-file-alist (list reg (list spec))))) - - (let* ((reg (concat (regexp-quote spec) "$")) - (tmp (assoc reg ada-other-file-alist))) - (if tmp - (setcdr tmp (list (cons body (cadr tmp)))) - (add-to-list 'ada-other-file-alist (list reg (list body))))) - - (add-to-list 'auto-mode-alist - (cons (concat (regexp-quote spec) "\\'") 'ada-mode)) - (add-to-list 'auto-mode-alist - (cons (concat (regexp-quote body) "\\'") 'ada-mode)) - - (add-to-list 'ada-spec-suffixes spec) - (add-to-list 'ada-body-suffixes body) - - ;; Support for speedbar (Specifies that we want to see these files in - ;; speedbar) - (if (fboundp 'speedbar-add-supported-extension) - (progn - (funcall (symbol-function 'speedbar-add-supported-extension) - spec) - (funcall (symbol-function 'speedbar-add-supported-extension) - body)))) - -(defvar ada-font-lock-syntactic-keywords) ; defined below - -;;;###autoload -(define-derived-mode ada-mode prog-mode "Ada" - "Ada mode is the major mode for editing Ada code." - - ;; Set the paragraph delimiters so that one can select a whole block - ;; simply with M-h - (set (make-local-variable 'paragraph-start) "[ \t\n\f]*$") - (set (make-local-variable 'paragraph-separate) "[ \t\n\f]*$") - - ;; comment end must be set because it may hold a wrong value if - ;; this buffer had been in another mode before. RE - (set (make-local-variable 'comment-end) "") - - ;; used by autofill and indent-new-comment-line - (set (make-local-variable 'comment-start-skip) "---*[ \t]*") - - ;; used by autofill to break a comment line and continue it on another line. - ;; The reason we need this one is that the default behavior does not work - ;; correctly with the definition of paragraph-start above when the comment - ;; is right after a multi-line subprogram declaration (the comments are - ;; aligned under the latest parameter, not under the declaration start). - (set (make-local-variable 'comment-line-break-function) - (lambda (&optional soft) (let ((fill-prefix nil)) - (indent-new-comment-line soft)))) - - (set (make-local-variable 'indent-line-function) - 'ada-indent-current-function) - - (set (make-local-variable 'comment-column) 40) - - ;; Emacs 20.3 defines a comment-padding to insert spaces between - ;; the comment and the text. We do not want any, this is already - ;; included in comment-start - (unless (featurep 'xemacs) - (set (make-local-variable 'parse-sexp-ignore-comments) t) - (set (make-local-variable 'comment-padding) 0) - (set (make-local-variable 'parse-sexp-lookup-properties) t)) - - (setq case-fold-search t) - (if (boundp 'imenu-case-fold-search) - (setq imenu-case-fold-search t)) - - (set (make-local-variable 'fill-paragraph-function) - 'ada-fill-comment-paragraph) - - ;; Support for compile.el - ;; We just substitute our own functions to go to the error. - (add-hook 'compilation-mode-hook - (lambda() - ;; FIXME: This has global impact! -stef - (define-key compilation-minor-mode-map [mouse-2] - 'ada-compile-mouse-goto-error) - (define-key compilation-minor-mode-map "\C-c\C-c" - 'ada-compile-goto-error) - (define-key compilation-minor-mode-map "\C-m" - 'ada-compile-goto-error))) - - ;; font-lock support : - - (set (make-local-variable 'font-lock-defaults) - '(ada-font-lock-keywords - nil t - ((?\_ . "w") (?# . ".")) - beginning-of-line)) - - (if (eval-when-compile (fboundp 'syntax-propertize-via-font-lock)) - (set (make-local-variable 'syntax-propertize-function) - (syntax-propertize-via-font-lock ada-font-lock-syntactic-keywords)) - (set (make-local-variable 'font-lock-syntactic-keywords) - ada-font-lock-syntactic-keywords)) - - ;; Set up support for find-file.el. - (set (make-local-variable 'ff-other-file-alist) - 'ada-other-file-alist) - (set (make-local-variable 'ff-search-directories) - 'ada-search-directories-internal) - (setq ff-post-load-hook 'ada-set-point-accordingly - ff-file-created-hook 'ada-make-body) - (add-hook 'ff-pre-load-hook 'ada-which-function-are-we-in) - - (make-local-variable 'ff-special-constructs) - (mapc (lambda (pair) (add-to-list 'ff-special-constructs pair)) - (list - ;; Top level child package declaration; go to the parent package. - (cons (eval-when-compile - (concat "^\\(private[ \t]\\)?[ \t]*package[ \t]+" - "\\(body[ \t]+\\)?" - "\\(\\(\\sw\\|[_.]\\)+\\)\\.\\(\\sw\\|_\\)+[ \t\n]+is")) - (lambda () - (ff-get-file - ada-search-directories-internal - (ada-make-filename-from-adaname (match-string 3)) - ada-spec-suffixes))) - - ;; A "separate" clause. - (cons "^separate[ \t\n]*(\\(\\(\\sw\\|[_.]\\)+\\))" - (lambda () - (ff-get-file - ada-search-directories-internal - (ada-make-filename-from-adaname (match-string 1)) - ada-spec-suffixes))) - - ;; A "with" clause. - (cons "^with[ \t]+\\([a-zA-Z0-9_\\.]+\\)" - (lambda () - (ff-get-file - ada-search-directories-internal - (ada-make-filename-from-adaname (match-string 1)) - ada-spec-suffixes))) - )) - - ;; Support for outline-minor-mode - (set (make-local-variable 'outline-regexp) - "\\([ \t]*\\(procedure\\|function\\|package\\|if\\|while\\|for\\|declare\\|case\\|end\\|begin\\|loop\\)\\|--\\)") - (set (make-local-variable 'outline-level) 'ada-outline-level) - - ;; Support for imenu : We want a sorted index - (setq imenu-generic-expression ada-imenu-generic-expression) - - (setq imenu-sort-function 'imenu--sort-by-name) - - ;; Support for ispell : Check only comments - (set (make-local-variable 'ispell-check-comments) 'exclusive) - - ;; Support for align - (add-to-list 'align-dq-string-modes 'ada-mode) - (add-to-list 'align-open-comment-modes 'ada-mode) - (set (make-local-variable 'align-region-separate) ada-align-region-separate) - - ;; Exclude comments alone on line from alignment. - (add-to-list 'align-exclude-rules-list - '(ada-solo-comment - (regexp . "^\\(\\s-*\\)--") - (modes . '(ada-mode)))) - (add-to-list 'align-exclude-rules-list - '(ada-solo-use - (regexp . "^\\(\\s-*\\)\\") - (modes . '(ada-mode)))) - - (setq ada-align-modes nil) - - (add-to-list 'ada-align-modes - '(ada-declaration-assign - (regexp . "[^:]\\(\\s-*\\):[^:]") - (valid . (lambda() (not (ada-in-comment-p)))) - (repeat . t) - (modes . '(ada-mode)))) - (add-to-list 'ada-align-modes - '(ada-associate - (regexp . "[^=]\\(\\s-*\\)=>") - (valid . (lambda() (not (ada-in-comment-p)))) - (modes . '(ada-mode)))) - (add-to-list 'ada-align-modes - '(ada-comment - (regexp . "\\(\\s-*\\)--") - (modes . '(ada-mode)))) - (add-to-list 'ada-align-modes - '(ada-use - (regexp . "\\(\\s-*\\)\\") - (modes . '(ada-mode)))) - - (setq align-mode-rules-list ada-align-modes) - - ;; Set up the contextual menu - (if ada-popup-key - (define-key ada-mode-map ada-popup-key 'ada-popup-menu)) - - ;; Support for Abbreviations (the user still needs to "M-x abbrev-mode"). - (setq local-abbrev-table ada-mode-abbrev-table) - - ;; Support for which-function mode - (set (make-local-variable 'which-func-functions) '(ada-which-function)) - - ;; Support for indent-new-comment-line (Especially for XEmacs) - (set (make-local-variable 'comment-multi-line) nil) - - ;; Support for add-log - (set (make-local-variable 'add-log-current-defun-function) - 'ada-which-function) - - (easy-menu-add ada-mode-menu ada-mode-map) - - (set (make-local-variable 'skeleton-further-elements) - '((< '(backward-delete-char-untabify - (min ada-indent (current-column)))))) - (add-hook 'skeleton-end-hook 'ada-adjust-case-skeleton nil t) - - ;; To be run after the hook, in case the user modified - ;; ada-fill-comment-prefix - (add-hook 'hack-local-variables-hook - (lambda () - (set (make-local-variable 'comment-start) - (or ada-fill-comment-prefix "-- ")) - - ;; Run this after the hook to give the users a chance - ;; to activate font-lock-mode. - - (unless (or (eval-when-compile (fboundp 'syntax-propertize-via-font-lock)) - (featurep 'xemacs)) - (ada-initialize-syntax-table-properties) - (add-hook 'font-lock-mode-hook - 'ada-handle-syntax-table-properties nil t)) - - ;; FIXME: ada-language-version might be set in the mode - ;; hook or it might even be set later on via file-local - ;; vars, so ada-keywords should be set lazily. - (cond ((eq ada-language-version 'ada83) - (setq ada-keywords ada-83-keywords)) - ((eq ada-language-version 'ada95) - (setq ada-keywords ada-95-keywords)) - ((eq ada-language-version 'ada2005) - (setq ada-keywords ada-2005-keywords))) - - (if ada-auto-case - (ada-activate-keys-for-case))) - nil 'local)) - -(defun ada-adjust-case-skeleton () - "Adjust the case of the text inserted by a skeleton." - (save-excursion - (let ((aa-end (point))) - (ada-adjust-case-region - (progn (goto-char (symbol-value 'beg)) (forward-word-strictly -1) - (point)) - (goto-char aa-end))))) - -(defun ada-region-selected () - "Should we operate on an active region?" - (if (fboundp 'use-region-p) - (use-region-p) - (region-active-p))) - -;;----------------------------------------------------------------- -;; auto-casing -;; Since Ada is case-insensitive, the Ada mode provides an extensive set of -;; functions to auto-case identifiers, keywords, ... -;; The basic rules for autocasing are defined through the variables -;; `ada-case-attribute', `ada-case-keyword' and `ada-case-identifier'. These -;; are references to the functions that will do the actual casing. -;; -;; However, in most cases, the user will want to define some exceptions to -;; these casing rules. This is done through a list of files, that contain -;; one word per line. These files are stored in `ada-case-exception-file'. -;; For backward compatibility, this variable can also be a string. -;;----------------------------------------------------------------- - -(defun ada-save-exceptions-to-file (file-name) - "Save the casing exception lists to the file FILE-NAME. -Casing exception lists are `ada-case-exception' and `ada-case-exception-substring'." - (find-file (expand-file-name file-name)) - (erase-buffer) - (mapc (lambda (x) (insert (car x) "\n")) - (sort (copy-sequence ada-case-exception) - (lambda(a b) (string< (car a) (car b))))) - (mapc (lambda (x) (insert "*" (car x) "\n")) - (sort (copy-sequence ada-case-exception-substring) - (lambda(a b) (string< (car a) (car b))))) - (save-buffer) - (kill-buffer nil) - ) - -(defun ada-create-case-exception (&optional word) - "Define WORD as an exception for the casing system. -If WORD is not given, then the current word in the buffer is used instead. -The new word is added to the first file in `ada-case-exception-file'. -The standard casing rules will no longer apply to this word." - (interactive) - (let ((file-name - (cond ((stringp ada-case-exception-file) - ada-case-exception-file) - ((listp ada-case-exception-file) - (car ada-case-exception-file)) - (t - (error (concat "No exception file specified. " - "See variable ada-case-exception-file")))))) - - (unless word - (with-syntax-table ada-mode-symbol-syntax-table - (save-excursion - (skip-syntax-backward "w") - (setq word (buffer-substring-no-properties - (point) (save-excursion (forward-word-strictly 1) - (point))))))) - - ;; Reread the exceptions file, in case it was modified by some other, - (ada-case-read-exceptions-from-file file-name) - - ;; If the word is already in the list, even with a different casing - ;; we simply want to replace it. - (if (and (not (equal ada-case-exception '())) - (assoc-string word ada-case-exception t)) - (setcar (assoc-string word ada-case-exception t) word) - (add-to-list 'ada-case-exception (cons word t))) - - (ada-save-exceptions-to-file file-name))) - -(defun ada-create-case-exception-substring (&optional word) - "Define the substring WORD as an exception for the casing system. -If WORD is not given, then the current word in the buffer is used instead, -or the selected region if any is active. -The new word is added to the first file in `ada-case-exception-file'. -When auto-casing a word, this substring will be special-cased, unless the -word itself has a special casing." - (interactive) - (let ((file-name - (cond ((stringp ada-case-exception-file) - ada-case-exception-file) - ((listp ada-case-exception-file) - (car ada-case-exception-file)) - (t - (error (concat "No exception file specified. " - "See variable ada-case-exception-file")))))) - - ;; Find the substring to define as an exception. Order is: the parameter, - ;; if any, or the selected region, or the word under the cursor - (cond - (word nil) - - ((ada-region-selected) - (setq word (buffer-substring-no-properties - (region-beginning) (region-end)))) - - (t - (let ((underscore-syntax (char-syntax ?_))) - (unwind-protect - (progn - (modify-syntax-entry ?_ "." (syntax-table)) - (save-excursion - (skip-syntax-backward "w") - (setq word (buffer-substring-no-properties - (point) - (save-excursion (forward-word-strictly 1) - (point)))))) - (modify-syntax-entry ?_ (make-string 1 underscore-syntax) - (syntax-table)))))) - - ;; Reread the exceptions file, in case it was modified by some other, - (ada-case-read-exceptions-from-file file-name) - - ;; If the word is already in the list, even with a different casing - ;; we simply want to replace it. - (if (and (not (equal ada-case-exception-substring '())) - (assoc-string word ada-case-exception-substring t)) - (setcar (assoc-string word ada-case-exception-substring t) word) - (add-to-list 'ada-case-exception-substring (cons word t)) - ) - - (ada-save-exceptions-to-file file-name) - - (message "%s" (concat "Defining " word " as a casing exception")))) - -(defun ada-case-read-exceptions-from-file (file-name) - "Read the content of the casing exception file FILE-NAME." - (if (file-readable-p (expand-file-name file-name)) - (let ((buffer (current-buffer))) - (find-file (expand-file-name file-name)) - (set-syntax-table ada-mode-symbol-syntax-table) - (widen) - (goto-char (point-min)) - (while (not (eobp)) - - ;; If the item is already in the list, even with an other casing, - ;; do not add it again. This way, the user can easily decide which - ;; priority should be applied to each casing exception - (let ((word (buffer-substring-no-properties - (point) (save-excursion (forward-word-strictly 1) - (point))))) - - ;; Handling a substring ? - (if (char-equal (string-to-char word) ?*) - (progn - (setq word (substring word 1)) - (unless (assoc-string word ada-case-exception-substring t) - (add-to-list 'ada-case-exception-substring (cons word t)))) - (unless (assoc-string word ada-case-exception t) - (add-to-list 'ada-case-exception (cons word t))))) - - (forward-line 1)) - (kill-buffer nil) - (set-buffer buffer))) - ) - -(defun ada-case-read-exceptions () - "Read all the casing exception files from `ada-case-exception-file'." - (interactive) - - ;; Reinitialize the casing exception list - (setq ada-case-exception '() - ada-case-exception-substring '()) - - (cond ((stringp ada-case-exception-file) - (ada-case-read-exceptions-from-file ada-case-exception-file)) - - ((listp ada-case-exception-file) - (mapcar 'ada-case-read-exceptions-from-file - ada-case-exception-file)))) - -(defun ada-adjust-case-substring () - "Adjust case of substrings in the previous word." - (interactive) - (let ((substrings ada-case-exception-substring) - (max (point)) - (case-fold-search t) - (underscore-syntax (char-syntax ?_)) - re) - - (save-excursion - (forward-word -1) - - (unwind-protect - (progn - (modify-syntax-entry ?_ "." (syntax-table)) - - (while substrings - (setq re (concat "\\b" (regexp-quote (caar substrings)) "\\b")) - - (save-excursion - (while (re-search-forward re max t) - (replace-match (caar substrings) t))) - (setq substrings (cdr substrings)) - ) - ) - (modify-syntax-entry ?_ (make-string 1 underscore-syntax) (syntax-table))) - ))) - -(defun ada-adjust-case-identifier () - "Adjust case of the previous identifier. -The auto-casing is done according to the value of `ada-case-identifier' -and the exceptions defined in `ada-case-exception-file'." - (interactive) - (if (or (equal ada-case-exception '()) - (equal (char-after) ?_)) - (progn - (funcall ada-case-identifier -1) - (ada-adjust-case-substring)) - - (progn - (let ((end (point)) - (start (save-excursion (skip-syntax-backward "w") - (point))) - match) - ;; If we have an exception, replace the word by the correct casing - (if (setq match (assoc-string (buffer-substring start end) - ada-case-exception t)) - - (progn - (delete-region start end) - (insert (car match))) - - ;; Else simply re-case the word - (funcall ada-case-identifier -1) - (ada-adjust-case-substring)))))) - -(defun ada-after-keyword-p () - "Return t if cursor is after a keyword that is not an attribute." - (save-excursion - (forward-word-strictly -1) - (and (not (and (char-before) - (or (= (char-before) ?_) - (= (char-before) ?'))));; unless we have a _ or ' - (looking-at (concat ada-keywords "[^_]"))))) - -(defun ada-adjust-case (&optional force-identifier) - "Adjust the case of the word before the character just typed. -If FORCE-IDENTIFIER is non-nil then also adjust keyword as identifier." - (if (not (bobp)) - (progn - (forward-char -1) - (if (and (not (bobp)) - ;; or if at the end of a character constant - (not (and (eq (following-char) ?') - (eq (char-before (1- (point))) ?'))) - ;; or if the previous character was not part of a word - (eq (char-syntax (char-before)) ?w) - ;; if in a string or a comment - (not (ada-in-string-or-comment-p)) - ;; if in a numeric literal - (not (ada-in-numeric-literal-p)) - ) - (if (save-excursion - (forward-word -1) - (or (= (point) (point-min)) - (backward-char 1)) - (= (following-char) ?')) - (funcall ada-case-attribute -1) - (if (and - (not force-identifier) ; (MH) - (ada-after-keyword-p)) - (funcall ada-case-keyword -1) - (ada-adjust-case-identifier)))) - (forward-char 1) - )) - ) - -(defun ada-adjust-case-interactive (arg) - "Adjust the case of the previous word, and process the character just typed. -ARG is the prefix the user entered with \\[universal-argument]." - (interactive "P") - - (if ada-auto-case - (let ((lastk last-command-event)) - - (with-syntax-table ada-mode-symbol-syntax-table - (cond ((memq lastk '(?\n ?\r)) - ;; Horrible kludge. - (insert " ") - (ada-adjust-case) - ;; horrible dekludge - (delete-char -1) - ;; some special keys and their bindings - (cond - ((eq lastk ?\n) - (funcall ada-lfd-binding)) - ((eq lastk ?\r) - (funcall ada-ret-binding)))) - ((eq lastk ?\C-i) (ada-tab)) - ;; Else just insert the character - ((self-insert-command (prefix-numeric-value arg)))) - ;; if there is a keyword in front of the underscore - ;; then it should be part of an identifier (MH) - (if (eq lastk ?_) - (ada-adjust-case t) - (ada-adjust-case)))) - - ;; Else, no auto-casing - (cond - ((eq last-command-event ?\n) - (funcall ada-lfd-binding)) - ((eq last-command-event ?\r) - (funcall ada-ret-binding)) - (t - (self-insert-command (prefix-numeric-value arg)))))) - -(defun ada-activate-keys-for-case () - ;; FIXME: Use post-self-insert-hook instead of changing key bindings. - "Modify the key bindings for all the keys that should readjust the casing." - (interactive) - ;; Save original key-bindings to allow swapping ret/lfd - ;; when casing is activated. - ;; The 'or ...' is there to be sure that the value will not - ;; be changed again when Ada mode is called more than once - (or ada-ret-binding (setq ada-ret-binding (key-binding "\C-M"))) - (or ada-lfd-binding (setq ada-lfd-binding (key-binding "\C-j"))) - - ;; Call case modifying function after certain keys. - (mapcar (function (lambda(key) (define-key - ada-mode-map - (char-to-string key) - 'ada-adjust-case-interactive))) - '( ?` ?_ ?# ?% ?& ?* ?\( ?\) ?- ?= ?+ - ?| ?\; ?: ?' ?\" ?< ?, ?. ?> ?/ ?\n 32 ?\r ))) - -(defun ada-loose-case-word (&optional _arg) - "Upcase first letter and letters following `_' in the following word. -No other letter is modified. -ARG is ignored, and is there for compatibility with `capitalize-word' only." - (interactive) - (save-excursion - (let ((end (save-excursion (skip-syntax-forward "w") (point))) - (first t)) - (skip-syntax-backward "w") - (while (and (or first (search-forward "_" end t)) - (< (point) end)) - (and first - (setq first nil)) - (insert-char (upcase (following-char)) 1) - (delete-char 1))))) - -(defun ada-no-auto-case (&optional _arg) - "Do nothing. ARG is ignored. -This function can be used for the auto-casing variables in Ada mode, to -adapt to unusual auto-casing schemes. Since it does nothing, you can for -instance use it for `ada-case-identifier' if you don't want any special -auto-casing for identifiers, whereas keywords have to be lower-cased. -See also `ada-auto-case' to disable auto casing altogether." - nil) - -(defun ada-capitalize-word (&optional _arg) - "Upcase first letter and letters following `_', lower case other letters. -ARG is ignored, and is there for compatibility with `capitalize-word' only." - (interactive) - (let ((end (save-excursion (skip-syntax-forward "w") (point))) - (begin (save-excursion (skip-syntax-backward "w") (point)))) - (capitalize-region begin end))) - -(defun ada-adjust-case-region (from to) - "Adjust the case of all words in the region between FROM and TO. -Attention: This function might take very long for big regions!" - (interactive "*r") - (let ((begin nil) - (end nil) - (keywordp nil) - (attribp nil)) - (message "Adjusting case ...") - (with-syntax-table ada-mode-symbol-syntax-table - (save-excursion - (goto-char to) - ;; - ;; loop: look for all identifiers, keywords, and attributes - ;; - (while (re-search-backward "\\<\\(\\sw+\\)\\>" from t) - (setq end (match-end 1)) - (setq attribp - (and (> (point) from) - (save-excursion - (forward-char -1) - (setq attribp (looking-at "'.[^']"))))) - (or - ;; do nothing if it is a string or comment - (ada-in-string-or-comment-p) - (progn - ;; - ;; get the identifier or keyword or attribute - ;; - (setq begin (point)) - (setq keywordp (looking-at ada-keywords)) - (goto-char end) - ;; - ;; casing according to user-option - ;; - (if attribp - (funcall ada-case-attribute -1) - (if keywordp - (funcall ada-case-keyword -1) - (ada-adjust-case-identifier))) - (goto-char begin)))) - (message "Adjusting case ... Done"))))) - -(defun ada-adjust-case-buffer () - "Adjust the case of all words in the whole buffer. -ATTENTION: This function might take very long for big buffers!" - (interactive "*") - (ada-adjust-case-region (point-min) (point-max))) - - -;;-------------------------------------------------------------- -;; Format Parameter Lists -;; Some special algorithms are provided to indent the parameter lists in -;; subprogram declarations. This is done in two steps: -;; - First parses the parameter list. The returned list has the following -;; format: -;; ( ( in? out? access? ) -;; ... ) -;; This is done in `ada-scan-paramlist'. -;; - Delete and recreate the parameter list in function -;; `ada-insert-paramlist'. -;; Both steps are called from `ada-format-paramlist'. -;; Note: Comments inside the parameter list are lost. -;; The syntax has to be correct, or the reformatting will fail. -;;-------------------------------------------------------------- - -(defun ada-format-paramlist () - "Reformat the parameter list point is in." - (interactive) - (let ((begin nil) - (end nil) - (delend nil) - (paramlist nil)) - (with-syntax-table ada-mode-symbol-syntax-table - - ;; check if really inside parameter list - (or (ada-in-paramlist-p) - (error "Not in parameter list")) - - ;; find start of current parameter-list - (ada-search-ignore-string-comment - (concat ada-subprog-start-re "\\|\\" ) t nil) - (down-list 1) - (backward-char 1) - (setq begin (point)) - - ;; find end of parameter-list - (forward-sexp 1) - (setq delend (point)) - (delete-char -1) - (insert "\n") - - ;; find end of last parameter-declaration - (forward-comment -1000) - (setq end (point)) - - ;; build a list of all elements of the parameter-list - (setq paramlist (ada-scan-paramlist (1+ begin) end)) - - ;; delete the original parameter-list - (delete-region begin delend) - - ;; insert the new parameter-list - (goto-char begin) - (ada-insert-paramlist paramlist)))) - -(defun ada-scan-paramlist (begin end) - "Scan the parameter list found in between BEGIN and END. -Return the equivalent internal parameter list." - (let ((paramlist (list)) - (param (list)) - (notend t) - (apos nil) - (epos nil) - (semipos nil) - (match-cons nil)) - - (goto-char begin) - - ;; loop until end of last parameter - (while notend - - ;; find first character of parameter-declaration - (ada-goto-next-non-ws) - (setq apos (point)) - - ;; find last character of parameter-declaration - (if (setq match-cons - (ada-search-ignore-string-comment "[ \t\n]*;" nil end t)) - (progn - (setq epos (car match-cons)) - (setq semipos (cdr match-cons))) - (setq epos end)) - - ;; read name(s) of parameter(s) - (goto-char apos) - (looking-at "\\(\\(\\sw\\|[_, \t\n]\\)*\\(\\sw\\|_\\)\\)[ \t\n]*:[^=]") - - (setq param (list (match-string 1))) - (ada-search-ignore-string-comment ":" nil epos t 'search-forward) - - ;; look for 'in' - (setq apos (point)) - (setq param - (append param - (list - (consp - (ada-search-ignore-string-comment - "in" nil epos t 'word-search-forward))))) - - ;; look for 'out' - (goto-char apos) - (setq param - (append param - (list - (consp - (ada-search-ignore-string-comment - "out" nil epos t 'word-search-forward))))) - - ;; look for 'access' - (goto-char apos) - (setq param - (append param - (list - (consp - (ada-search-ignore-string-comment - "access" nil epos t 'word-search-forward))))) - - ;; skip 'in'/'out'/'access' - (goto-char apos) - (ada-goto-next-non-ws) - (while (looking-at "\\<\\(in\\|out\\|access\\)\\>") - (forward-word-strictly 1) - (ada-goto-next-non-ws)) - - ;; read type of parameter - ;; We accept spaces in the name, since some software like Rose - ;; generates something like: "A : B 'Class" - (looking-at "\\<\\(\\sw\\|[_.' \t]\\)+\\>") - (setq param - (append param - (list (match-string 0)))) - - ;; read default-expression, if there is one - (goto-char (setq apos (match-end 0))) - (setq param - (append param - (list - (if (setq match-cons - (ada-search-ignore-string-comment - ":=" nil epos t 'search-forward)) - (buffer-substring (car match-cons) epos) - nil)))) - - ;; add this parameter-declaration to the list - (setq paramlist (append paramlist (list param))) - - ;; check if it was the last parameter - (if (eq epos end) - (setq notend nil) - (goto-char semipos)) - ) - (reverse paramlist))) - -(defun ada-insert-paramlist (paramlist) - "Insert a formatted PARAMLIST in the buffer." - (let ((i (length paramlist)) - (parlen 0) - (typlen 0) - (inp nil) - (outp nil) - (accessp nil) - (column nil) - (firstcol nil)) - - ;; loop until last parameter - (while (not (zerop i)) - (setq i (1- i)) - - ;; get max length of parameter-name - (setq parlen (max parlen (length (nth 0 (nth i paramlist))))) - - ;; get max length of type-name - (setq typlen (max typlen (length (nth 4 (nth i paramlist))))) - - ;; is there any 'in' ? - (setq inp (or inp (nth 1 (nth i paramlist)))) - - ;; is there any 'out' ? - (setq outp (or outp (nth 2 (nth i paramlist)))) - - ;; is there any 'access' ? - (setq accessp (or accessp (nth 3 (nth i paramlist)))) - ) - - ;; does paramlist already start on a separate line ? - (if (save-excursion - (re-search-backward "^.\\|[^ \t]" nil t) - (looking-at "^.")) - ;; yes => re-indent it - (progn - (ada-indent-current) - (save-excursion - (if (looking-at "\\(is\\|return\\)") - (replace-match " \\1")))) - - ;; no => insert it where we are after removing any whitespace - (fixup-whitespace) - (save-excursion - (cond - ((looking-at "[ \t]*\\(\n\\|;\\)") - (replace-match "\\1")) - ((looking-at "[ \t]*\\(is\\|return\\)") - (replace-match " \\1")))) - (insert " ")) - - (insert "(") - (ada-indent-current) - - (setq firstcol (current-column)) - (setq i (length paramlist)) - - ;; loop until last parameter - (while (not (zerop i)) - (setq i (1- i)) - (setq column firstcol) - - ;; insert parameter-name, space and colon - (insert (nth 0 (nth i paramlist))) - (indent-to (+ column parlen 1)) - (insert ": ") - (setq column (current-column)) - - ;; insert 'in' or space - (if (nth 1 (nth i paramlist)) - (insert "in ") - (if (and - (or inp - accessp) - (not (nth 3 (nth i paramlist)))) - (insert " "))) - - ;; insert 'out' or space - (if (nth 2 (nth i paramlist)) - (insert "out ") - (if (and - (or outp - accessp) - (not (nth 3 (nth i paramlist)))) - (insert " "))) - - ;; insert 'access' - (if (nth 3 (nth i paramlist)) - (insert "access ")) - - (setq column (current-column)) - - ;; insert type-name and, if necessary, space and default-expression - (insert (nth 4 (nth i paramlist))) - (if (nth 5 (nth i paramlist)) - (progn - (indent-to (+ column typlen 1)) - (insert (nth 5 (nth i paramlist))))) - - ;; check if it was the last parameter - (if (zerop i) - (insert ")") - ;; no => insert ';' and newline and indent - (insert ";") - (newline) - (indent-to firstcol)) - ) - - ;; if anything follows, except semicolon, newline, is or return - ;; put it in a new line and indent it - (unless (looking-at "[ \t]*\\(;\\|\n\\|is\\|return\\)") - (ada-indent-newline-indent)) - )) - - - -;;;---------------------------------------------------------------- -;; Indentation Engine -;; All indentations are indicated as a two-element string: -;; - position of reference in the buffer -;; - offset to indent from this position (can also be a symbol or a list -;; that are evaluated) -;; Thus the total indentation for a line is the column number of the reference -;; position plus whatever value the evaluation of the second element provides. -;; This mechanism is used so that the Ada mode can "explain" how the -;; indentation was calculated, by showing which variables were used. -;; -;; The indentation itself is done in only one pass: first we try to guess in -;; what context we are by looking at the following keyword or punctuation -;; sign. If nothing remarkable is found, just try to guess the indentation -;; based on previous lines. -;; -;; The relevant functions for indentation are: -;; - `ada-indent-region': Re-indent a region of text -;; - `ada-justified-indent-current': Re-indent the current line and shows the -;; calculation that were done -;; - `ada-indent-current': Re-indent the current line -;; - `ada-get-current-indent': Calculate the indentation for the current line, -;; based on the context (see above). -;; - `ada-get-indent-*': Calculate the indentation in a specific context. -;; For efficiency, these functions do not check they are in the correct -;; context. -;;;---------------------------------------------------------------- - -(defun ada-indent-region (beg end) - "Indent the region between BEG end END." - (interactive "*r") - (goto-char beg) - (let ((block-done 0) - (lines-remaining (count-lines beg end)) - (msg (format "%%4d out of %4d lines remaining ..." - (count-lines beg end))) - (endmark (copy-marker end))) - ;; catch errors while indenting - (while (< (point) endmark) - (if (> block-done 39) - (progn - (setq lines-remaining (- lines-remaining block-done) - block-done 0) - (message msg lines-remaining))) - (if (= (char-after) ?\n) nil - (ada-indent-current)) - (forward-line 1) - (setq block-done (1+ block-done))) - (message "Indenting ... done"))) - -(defun ada-indent-newline-indent () - "Indent the current line, insert a newline and then indent the new line." - (interactive "*") - (ada-indent-current) - (newline) - (ada-indent-current)) - -(defun ada-indent-newline-indent-conditional () - "Insert a newline and indent it. -The original line is re-indented if `ada-indent-after-return' is non-nil." - (interactive "*") - ;; If at end of buffer (entering brand new code), some indentation - ;; fails. For example, a block label requires whitespace following - ;; the : to be recognized. So we do the newline first, then - ;; go back and indent the original line. - (newline) - (if ada-indent-after-return - (progn - (forward-char -1) - (ada-indent-current) - (forward-char 1))) - (ada-indent-current)) - -(defun ada-justified-indent-current () - "Indent the current line and explain how the calculation was done." - (interactive) - - (let ((cur-indent (ada-indent-current))) - - (let ((line (save-excursion - (goto-char (car cur-indent)) - (count-lines 1 (point))))) - - (if (equal (cdr cur-indent) '(0)) - (message (concat "same indentation as line " (number-to-string line))) - (message "%s" (mapconcat (lambda(x) - (cond - ((symbolp x) - (symbol-name x)) - ((numberp x) - (number-to-string x)) - ((listp x) - (concat "- " (symbol-name (cadr x)))) - )) - (cdr cur-indent) - " + ")))) - (save-excursion - (goto-char (car cur-indent)) - (sit-for 1)))) - -(defun ada-batch-reformat () - "Re-indent and re-case all the files found on the command line. -This function should be used from the command line, with a -command like: - emacs -batch -l ada-mode -f ada-batch-reformat file1 file2 ..." - - (while command-line-args-left - (let ((source (car command-line-args-left))) - (message "Formatting %s" source) - (find-file source) - (ada-indent-region (point-min) (point-max)) - (ada-adjust-case-buffer) - (write-file source)) - (setq command-line-args-left (cdr command-line-args-left))) - (message "Done") - (kill-emacs 0)) - -(defsubst ada-goto-previous-word () - "Move point to the beginning of the previous word of Ada code. -Return the new position of point or nil if not found." - (ada-goto-next-word t)) - -(defun ada-indent-current () - "Indent current line as Ada code. -Return the calculation that was done, including the reference point -and the offset." - (interactive) - (let ((orgpoint (point-marker)) - cur-indent tmp-indent - prev-indent) - - (unwind-protect - (with-syntax-table ada-mode-symbol-syntax-table - - ;; This needs to be done here so that the advice is not always - ;; activated (this might interact badly with other modes) - (if (featurep 'xemacs) - (ad-activate 'parse-partial-sexp t)) - - (save-excursion - (setq cur-indent - - ;; Not First line in the buffer ? - (if (save-excursion (zerop (forward-line -1))) - (progn - (back-to-indentation) - (ada-get-current-indent)) - - ;; first line in the buffer - (list (point-min) 0)))) - - ;; Evaluate the list to get the column to indent to - ;; prev-indent contains the column to indent to - (if cur-indent - (setq prev-indent (save-excursion (goto-char (car cur-indent)) - (current-column)) - tmp-indent (cdr cur-indent)) - (setq prev-indent 0 tmp-indent '())) - - (while (not (null tmp-indent)) - (cond - ((numberp (car tmp-indent)) - (setq prev-indent (+ prev-indent (car tmp-indent)))) - (t - (setq prev-indent (+ prev-indent (eval (car tmp-indent))))) - ) - (setq tmp-indent (cdr tmp-indent))) - - ;; only re-indent if indentation is different then the current - (if (= (save-excursion (back-to-indentation) (current-column)) prev-indent) - nil - (beginning-of-line) - (delete-horizontal-space) - (indent-to prev-indent)) - ;; - ;; restore position of point - ;; - (goto-char orgpoint) - (if (< (current-column) (current-indentation)) - (back-to-indentation))) - - (if (featurep 'xemacs) - (ad-deactivate 'parse-partial-sexp))) - - cur-indent)) - -(defun ada-get-current-indent () - "Return the indentation to use for the current line." - (let (column - pos - match-cons - result - (orgpoint (save-excursion - (beginning-of-line) - (forward-comment -10000) - (forward-line 1) - (point)))) - - (setq result - (cond - - ;;----------------------------- - ;; in open parenthesis, but not in parameter-list - ;;----------------------------- - - ((and ada-indent-to-open-paren - (not (ada-in-paramlist-p)) - (setq column (ada-in-open-paren-p))) - - ;; check if we have something like this (Table_Component_Type => - ;; Source_File_Record) - (save-excursion - - ;; Align the closing parenthesis on the opening one - (if (= (following-char) ?\)) - (save-excursion - (goto-char column) - (skip-chars-backward " \t") - (list (1- (point)) 0)) - - (if (and (skip-chars-backward " \t") - (= (char-before) ?\n) - (not (forward-comment -10000)) - (= (char-before) ?>)) - ;; ??? Could use a different variable - (list column 'ada-broken-indent) - - ;; We want all continuation lines to be indented the same - ;; (ada-broken-line from the opening parenthesis. However, in - ;; parameter list, each new parameter should be indented at the - ;; column as the opening parenthesis. - - ;; A special case to handle nested boolean expressions, as in - ;; ((B - ;; and then C) -- indented by ada-broken-indent - ;; or else D) -- indenting this line. - ;; ??? This is really a hack, we should have a proper way to go to - ;; ??? the beginning of the statement - - (if (= (char-before) ?\)) - (backward-sexp)) - - (if (memq (char-before) '(?, ?\; ?\( ?\))) - (list column 0) - (list column 'ada-continuation-indent) - ))))) - - ;;--------------------------- - ;; at end of buffer - ;;--------------------------- - - ((not (char-after)) - (ada-indent-on-previous-lines nil orgpoint orgpoint)) - - ;;--------------------------- - ;; starting with e - ;;--------------------------- - - ((= (downcase (char-after)) ?e) - (cond - - ;; ------- end ------ - - ((looking-at "end\\>") - (let ((label 0) - limit) - (save-excursion - (ada-goto-matching-start 1) - - ;; - ;; found 'loop' => skip back to 'while' or 'for' - ;; if 'loop' is not on a separate line - ;; Stop the search for 'while' and 'for' when a ';' is encountered. - ;; - (if (save-excursion - (beginning-of-line) - (looking-at ".+\\")) - (progn - (save-excursion - (setq limit (car (ada-search-ignore-string-comment ";" t)))) - (if (save-excursion - (and - (setq match-cons - (ada-search-ignore-string-comment ada-loop-start-re t limit)) - (not (looking-at "\\")))) - (progn - (goto-char (car match-cons)) - (save-excursion - (back-to-indentation) - (if (looking-at ada-block-label-re) - (setq label (- ada-label-indent)))))))) - - ;; found 'record' => - ;; if the keyword is found at the beginning of a line (or just - ;; after limited, we indent on it, otherwise we indent on the - ;; beginning of the type declaration) - ;; type A is (B : Integer; - ;; C : Integer) is record - ;; end record; -- This is badly indented otherwise - (if (looking-at "record") - (if (save-excursion - (beginning-of-line) - (looking-at "^[ \t]*\\(record\\|limited record\\)")) - (list (save-excursion (back-to-indentation) (point)) 0) - (list (save-excursion - (car (ada-search-ignore-string-comment "\\" t))) - 0)) - - ;; Else keep the same indentation as the beginning statement - (list (+ (save-excursion (back-to-indentation) (point)) label) 0))))) - - ;; ------ exception ---- - - ((looking-at "exception\\>") - (save-excursion - (ada-goto-matching-start 1) - (list (save-excursion (back-to-indentation) (point)) 0))) - - ;; else - - ((looking-at "else\\>") - (if (save-excursion (ada-goto-previous-word) - (looking-at "\\")) - (ada-indent-on-previous-lines nil orgpoint orgpoint) - (save-excursion - (ada-goto-matching-start 1 nil t) - (list (progn (back-to-indentation) (point)) 0)))) - - ;; elsif - - ((looking-at "elsif\\>") - (save-excursion - (ada-goto-matching-start 1 nil t) - (list (progn (back-to-indentation) (point)) 0))) - - )) - - ;;--------------------------- - ;; starting with w (when) - ;;--------------------------- - - ((and (= (downcase (char-after)) ?w) - (looking-at "when\\>")) - (save-excursion - (ada-goto-matching-start 1) - (list (save-excursion (back-to-indentation) (point)) - 'ada-when-indent))) - - ;;--------------------------- - ;; starting with t (then) - ;;--------------------------- - - ((and (= (downcase (char-after)) ?t) - (looking-at "then\\>")) - (if (save-excursion (ada-goto-previous-word) - (looking-at "and\\>")) - (ada-indent-on-previous-lines nil orgpoint orgpoint) - (save-excursion - ;; Select has been added for the statement: "select ... then abort" - (ada-search-ignore-string-comment - "\\<\\(elsif\\|if\\|select\\)\\>" t nil) - (list (progn (back-to-indentation) (point)) - 'ada-stmt-end-indent)))) - - ;;--------------------------- - ;; starting with l (loop) - ;;--------------------------- - - ((and (= (downcase (char-after)) ?l) - (looking-at "loop\\>")) - (setq pos (point)) - (save-excursion - (goto-char (match-end 0)) - (ada-goto-stmt-start) - (if (looking-at "\\<\\(loop\\|if\\)\\>") - (ada-indent-on-previous-lines nil orgpoint orgpoint) - (unless (looking-at ada-loop-start-re) - (ada-search-ignore-string-comment ada-loop-start-re - nil pos)) - (if (looking-at "\\") - (ada-indent-on-previous-lines nil orgpoint orgpoint) - (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent))))) - - ;;---------------------------- - ;; starting with l (limited) or r (record) - ;;---------------------------- - - ((or (and (= (downcase (char-after)) ?l) - (looking-at "limited\\>")) - (and (= (downcase (char-after)) ?r) - (looking-at "record\\>"))) - - (save-excursion - (ada-search-ignore-string-comment - "\\<\\(type\\|use\\)\\>" t nil) - (if (looking-at "\\") - (ada-search-ignore-string-comment "for" t nil nil - 'word-search-backward)) - (list (progn (back-to-indentation) (point)) - 'ada-indent-record-rel-type))) - - ;;--------------------------- - ;; starting with b (begin) - ;;--------------------------- - - ((and (= (downcase (char-after)) ?b) - (looking-at "begin\\>")) - (save-excursion - (if (ada-goto-decl-start t) - (list (progn (back-to-indentation) (point)) 0) - (ada-indent-on-previous-lines nil orgpoint orgpoint)))) - - ;;--------------------------- - ;; starting with i (is) - ;;--------------------------- - - ((and (= (downcase (char-after)) ?i) - (looking-at "is\\>")) - - (if (and ada-indent-is-separate - (save-excursion - (goto-char (match-end 0)) - (ada-goto-next-non-ws (point-at-eol)) - (looking-at "\\\\|\\"))) - (save-excursion - (ada-goto-stmt-start) - (list (progn (back-to-indentation) (point)) 'ada-indent)) - (save-excursion - (ada-goto-stmt-start) - (if (looking-at "\\") - (list (progn (back-to-indentation) (point)) 0) - (list (progn (back-to-indentation) (point)) 'ada-indent))))) - - ;;--------------------------- - ;; starting with r (return, renames) - ;;--------------------------- - - ((and (= (downcase (char-after)) ?r) - (looking-at "re\\(turn\\|names\\)\\>")) - - (save-excursion - (let ((var 'ada-indent-return)) - ;; If looking at a renames, skip the 'return' statement too - (if (looking-at "renames") - (let (pos) - (save-excursion - (setq pos (ada-search-ignore-string-comment ";\\|return\\>" t))) - (if (and pos - (= (downcase (char-after (car pos))) ?r)) - (goto-char (car pos))) - (setq var 'ada-indent-renames))) - - (forward-comment -1000) - (if (= (char-before) ?\)) - (forward-sexp -1) - (forward-word-strictly -1)) - - ;; If there is a parameter list, and we have a function declaration - ;; or access to subprogram declaration - (let ((num-back 1)) - (if (and (= (following-char) ?\() - (save-excursion - (or (progn - (backward-word-strictly 1) - (looking-at "\\(function\\|procedure\\)\\>")) - (progn - (backward-word-strictly 1) - (setq num-back 2) - (looking-at "\\(function\\|procedure\\)\\>"))))) - - ;; The indentation depends of the value of ada-indent-return - (if (<= (eval var) 0) - (list (point) (list '- var)) - (list (progn (backward-word-strictly num-back) (point)) - var)) - - ;; Else there is no parameter list, but we have a function - ;; Only do something special if the user want to indent - ;; relative to the "function" keyword - (if (and (> (eval var) 0) - (save-excursion (forward-word-strictly -1) - (looking-at "function\\>"))) - (list (progn (forward-word-strictly -1) (point)) var) - - ;; Else... - (ada-indent-on-previous-lines nil orgpoint orgpoint))))))) - - ;;-------------------------------- - ;; starting with 'o' or 'p' - ;; 'or' as statement-start - ;; 'private' as statement-start - ;;-------------------------------- - - ((and (or (= (downcase (char-after)) ?o) - (= (downcase (char-after)) ?p)) - (or (ada-looking-at-semi-or) - (ada-looking-at-semi-private))) - (save-excursion - ;; ??? Wasn't this done already in ada-looking-at-semi-or ? - (ada-goto-matching-start 1) - (list (progn (back-to-indentation) (point)) 0))) - - ;;-------------------------------- - ;; starting with 'd' (do) - ;;-------------------------------- - - ((and (= (downcase (char-after)) ?d) - (looking-at "do\\>")) - (save-excursion - (ada-goto-stmt-start) - (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent))) - - ;;-------------------------------- - ;; starting with '-' (comment) - ;;-------------------------------- - - ((= (char-after) ?-) - (if ada-indent-comment-as-code - - ;; Indent comments on previous line comments if required - ;; We must use a search-forward (even if the code is more complex), - ;; since we want to find the beginning of the comment. - (let (pos) - - (if (and ada-indent-align-comments - (save-excursion - (forward-line -1) - (beginning-of-line) - (while (and (not pos) - (search-forward "--" (point-at-eol) t)) - (unless (ada-in-string-p) - (setq pos (point)))) - pos)) - (list (- pos 2) 0) - - ;; Else always on previous line - (ada-indent-on-previous-lines nil orgpoint orgpoint))) - - ;; Else same indentation as the previous line - (list (save-excursion (back-to-indentation) (point)) 0))) - - ;;-------------------------------- - ;; starting with '#' (preprocessor line) - ;;-------------------------------- - - ((and (= (char-after) ?#) - (equal ada-which-compiler 'gnat) - (looking-at "#[ \t]*\\(if\\|els\\(e\\|if\\)\\|end[ \t]*if\\)")) - (list (point-at-bol) 0)) - - ;;-------------------------------- - ;; starting with ')' (end of a parameter list) - ;;-------------------------------- - - ((and (not (eobp)) (= (char-after) ?\))) - (save-excursion - (forward-char 1) - (backward-sexp 1) - (list (point) 0))) - - ;;--------------------------------- - ;; new/abstract/separate - ;;--------------------------------- - - ((looking-at "\\(new\\|abstract\\|separate\\)\\>") - (ada-indent-on-previous-lines nil orgpoint orgpoint)) - - ;;--------------------------------- - ;; package/function/procedure - ;;--------------------------------- - - ((and (or (= (downcase (char-after)) ?p) (= (downcase (char-after)) ?f)) - (looking-at "\\<\\(package\\|function\\|procedure\\)\\>")) - (save-excursion - ;; Go up until we find either a generic section, or the end of the - ;; previous subprogram/package, or 'overriding' for this function/procedure - (let (found) - (while (and (not found) - (ada-search-ignore-string-comment - "\\<\\(generic\\|end\\|begin\\|overriding\\|package\\|procedure\\|function\\)\\>" t)) - - ;; avoid "with procedure"... in generic parts - (save-excursion - (forward-word-strictly -1) - (setq found (not (looking-at "with")))))) - - (cond - ((looking-at "\\") - (list (progn (back-to-indentation) (point)) 0)) - - (t - (ada-indent-on-previous-lines nil orgpoint orgpoint))))) - - ;;--------------------------------- - ;; label - ;;--------------------------------- - - ((looking-at ada-label-re) - (if (ada-in-decl-p) - ;; ada-block-label-re matches variable declarations - (ada-indent-on-previous-lines nil orgpoint orgpoint) - (append (ada-indent-on-previous-lines nil orgpoint orgpoint) - '(ada-label-indent)))) - - )) - - ;;--------------------------------- - ;; Other syntaxes - ;;--------------------------------- - (or result (ada-indent-on-previous-lines nil orgpoint orgpoint)))) - -(defun ada-indent-on-previous-lines (&optional nomove orgpoint initial-pos) - "Calculate the indentation for the new line after ORGPOINT. -The result list is based on the previous lines in the buffer. -If NOMOVE is nil, moves point to the beginning of the current statement. -if INITIAL-POS is non-nil, moves point to INITIAL-POS before calculation." - (if initial-pos - (goto-char initial-pos)) - (let ((oldpoint (point))) - - ;; Is inside a parameter-list ? - (if (ada-in-paramlist-p) - (ada-get-indent-paramlist) - - ;; Move to beginning of current statement. If already at a - ;; statement start, move to beginning of enclosing statement. - (unless nomove - (ada-goto-stmt-start t)) - - ;; no beginning found => don't change indentation - (if (and (eq oldpoint (point)) - (not nomove)) - (ada-get-indent-nochange) - - (cond - ;; - ((and - ada-indent-to-open-paren - (ada-in-open-paren-p)) - (ada-get-indent-open-paren)) - ;; - ((looking-at "end\\>") - (ada-get-indent-end orgpoint)) - ;; - ((looking-at ada-loop-start-re) - (ada-get-indent-loop orgpoint)) - ;; - ((looking-at ada-subprog-start-re) - (ada-get-indent-subprog orgpoint)) - ;; - ((looking-at ada-block-start-re) - (ada-get-indent-block-start orgpoint)) - ;; - ((looking-at ada-block-label-re) ; also variable declaration - (ada-get-indent-block-label orgpoint)) - ;; - ((looking-at ada-goto-label-re) - (ada-get-indent-goto-label orgpoint)) - ;; - ((looking-at "\\(sub\\)?type\\>") - (ada-get-indent-type orgpoint)) - ;; - ;; "then" has to be included in the case of "select...then abort" - ;; statements, since (goto-stmt-start) at the beginning of - ;; the current function would leave the cursor on that position - ((looking-at "\\(\\(els\\)?if\\>\\)\\|then abort\\>") - (ada-get-indent-if orgpoint)) - ;; - ((looking-at "case\\>") - (ada-get-indent-case orgpoint)) - ;; - ((looking-at "when\\>") - (ada-get-indent-when orgpoint)) - ;; - ((looking-at "separate\\>") - (ada-get-indent-nochange)) - ;; - ((looking-at "with\\>\\|use\\>") - ;; Are we still in that statement, or are we in fact looking at - ;; the previous one ? - (if (save-excursion (search-forward ";" oldpoint t)) - (list (progn (back-to-indentation) (point)) 0) - (list (point) (if (looking-at "with") - 'ada-with-indent - 'ada-use-indent)))) - ;; - (t - (ada-get-indent-noindent orgpoint))))) - )) - -(defun ada-get-indent-open-paren () - "Calculate the indentation when point is behind an unclosed parenthesis." - (list (ada-in-open-paren-p) 0)) - -(defun ada-get-indent-nochange () - "Return the current indentation of the previous line." - (save-excursion - (forward-line -1) - (back-to-indentation) - (list (point) 0))) - -(defun ada-get-indent-paramlist () - "Calculate the indentation when point is inside a parameter list." - (save-excursion - (ada-search-ignore-string-comment "[^ \t\n]" t nil t) - (cond - ;; in front of the first parameter - ((= (char-after) ?\() - (goto-char (match-end 0)) - (list (point) 0)) - - ;; in front of another parameter - ((= (char-after) ?\;) - (goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t))) - (ada-goto-next-non-ws) - (list (point) 0)) - - ;; After an affectation (default parameter value in subprogram - ;; declaration) - ((and (= (following-char) ?=) (= (preceding-char) ?:)) - (back-to-indentation) - (list (point) 'ada-broken-indent)) - - ;; inside a parameter declaration - (t - (goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t))) - (ada-goto-next-non-ws) - (list (point) 'ada-broken-indent))))) - -(defun ada-get-indent-end (orgpoint) - "Calculate the indentation when point is just before an end statement. -ORGPOINT is the limit position used in the calculation." - (let ((defun-name nil) - (indent nil)) - - ;; is the line already terminated by ';' ? - (if (save-excursion - (ada-search-ignore-string-comment ";" nil orgpoint nil - 'search-forward)) - - ;; yes, look what's following 'end' - (progn - (forward-word-strictly 1) - (ada-goto-next-non-ws) - (cond - ;; - ;; loop/select/if/case/return - ;; - ((looking-at "\\<\\(loop\\|select\\|if\\|case\\|return\\)\\>") - (save-excursion (ada-check-matching-start (match-string 0))) - (list (save-excursion (back-to-indentation) (point)) 0)) - - ;; - ;; record - ;; - ((looking-at "\\") - (save-excursion - (ada-check-matching-start (match-string 0)) - ;; we are now looking at the matching "record" statement - (forward-word-strictly 1) - (ada-goto-stmt-start) - ;; now on the matching type declaration, or use clause - (unless (looking-at "\\(for\\|type\\)\\>") - (ada-search-ignore-string-comment "\\" t)) - (list (progn (back-to-indentation) (point)) 0))) - ;; - ;; a named block end - ;; - ((looking-at ada-ident-re) - (setq defun-name (match-string 0)) - (save-excursion - (ada-goto-matching-start 0) - (ada-check-defun-name defun-name)) - (list (progn (back-to-indentation) (point)) 0)) - ;; - ;; a block-end without name - ;; - ((= (char-after) ?\;) - (save-excursion - (ada-goto-matching-start 0) - (if (looking-at "\\") - (progn - (setq indent (list (point) 0)) - (if (ada-goto-decl-start t) - (list (progn (back-to-indentation) (point)) 0) - indent)) - (list (progn (back-to-indentation) (point)) 0) - ))) - ;; - ;; anything else - should maybe signal an error ? - ;; - (t - (list (save-excursion (back-to-indentation) (point)) - 'ada-broken-indent)))) - - (list (save-excursion (back-to-indentation) (point)) - 'ada-broken-indent)))) - -(defun ada-get-indent-case (orgpoint) - "Calculate the indentation when point is just before a case statement. -ORGPOINT is the limit position used in the calculation." - (let ((match-cons nil) - (opos (point))) - (cond - ;; - ;; case..is..when..=> - ;; - ((save-excursion - (setq match-cons (and - ;; the `=>' must be after the keyword `is'. - (ada-search-ignore-string-comment - "is" nil orgpoint nil 'word-search-forward) - (ada-search-ignore-string-comment - "[ \t\n]+=>" nil orgpoint)))) - (save-excursion - (goto-char (car match-cons)) - (unless (ada-search-ignore-string-comment "when" t opos) - (error "Missing `when' between `case' and `=>'")) - (list (save-excursion (back-to-indentation) (point)) 'ada-indent))) - ;; - ;; case..is..when - ;; - ((save-excursion - (setq match-cons (ada-search-ignore-string-comment - "when" nil orgpoint nil 'word-search-forward))) - (goto-char (cdr match-cons)) - (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent)) - ;; - ;; case..is - ;; - ((save-excursion - (setq match-cons (ada-search-ignore-string-comment - "is" nil orgpoint nil 'word-search-forward))) - (list (save-excursion (back-to-indentation) (point)) 'ada-when-indent)) - ;; - ;; incomplete case - ;; - (t - (list (save-excursion (back-to-indentation) (point)) - 'ada-broken-indent))))) - -(defun ada-get-indent-when (orgpoint) - "Calculate the indentation when point is just before a when statement. -ORGPOINT is the limit position used in the calculation." - (let ((cur-indent (save-excursion (back-to-indentation) (point)))) - (if (ada-search-ignore-string-comment "[ \t\n]*=>" nil orgpoint) - (list cur-indent 'ada-indent) - (list cur-indent 'ada-broken-indent)))) - -(defun ada-get-indent-if (orgpoint) - "Calculate the indentation when point is just before an if statement. -ORGPOINT is the limit position used in the calculation." - (let ((cur-indent (save-excursion (back-to-indentation) (point))) - (match-cons nil)) - ;; - ;; Move to the correct then (ignore all "and then") - ;; - (while (and (setq match-cons (ada-search-ignore-string-comment - "\\<\\(then\\|and[ \t]*then\\)\\>" - nil orgpoint)) - (= (downcase (char-after (car match-cons))) ?a))) - ;; If "then" was found (we are looking at it) - (if match-cons - (progn - ;; - ;; 'then' first in separate line ? - ;; => indent according to 'then', - ;; => else indent according to 'if' - ;; - (if (save-excursion - (back-to-indentation) - (looking-at "\\")) - (setq cur-indent (save-excursion (back-to-indentation) (point)))) - ;; skip 'then' - (forward-word-strictly 1) - (list cur-indent 'ada-indent)) - - (list cur-indent 'ada-broken-indent)))) - -(defun ada-get-indent-block-start (orgpoint) - "Calculate the indentation when point is at the start of a block. -ORGPOINT is the limit position used in the calculation." - (let ((pos nil)) - (cond - ((save-excursion - (forward-word-strictly 1) - (setq pos (ada-goto-next-non-ws orgpoint))) - (goto-char pos) - (save-excursion - (ada-indent-on-previous-lines t orgpoint))) - - ;; Special case for record types, for instance for: - ;; type A is (B : Integer; - ;; C : Integer) is record - ;; null; -- This is badly indented otherwise - ((looking-at "record") - - ;; If record is at the beginning of the line, indent from there - (if (save-excursion - (beginning-of-line) - (looking-at "^[ \t]*\\(record\\|limited record\\)")) - (list (save-excursion (back-to-indentation) (point)) 'ada-indent) - - ;; else indent relative to the type command - (list (save-excursion - (car (ada-search-ignore-string-comment "\\" t))) - 'ada-indent))) - - ;; Special case for label: - ((looking-at ada-block-label-re) - (list (- (save-excursion (back-to-indentation) (point)) ada-label-indent) 'ada-indent)) - - ;; nothing follows the block-start - (t - (list (save-excursion (back-to-indentation) (point)) 'ada-indent))))) - -(defun ada-get-indent-subprog (orgpoint) - "Calculate the indentation when point is just before a subprogram. -ORGPOINT is the limit position used in the calculation." - (let ((match-cons nil) - (cur-indent (save-excursion (back-to-indentation) (point))) - (foundis nil)) - ;; - ;; is there an 'is' in front of point ? - ;; - (if (save-excursion - (setq match-cons - (ada-search-ignore-string-comment - "\\<\\(is\\|do\\)\\>" nil orgpoint))) - ;; - ;; yes, then skip to its end - ;; - (progn - (setq foundis t) - (goto-char (cdr match-cons))) - ;; - ;; no, then goto next non-ws, if there is one in front of point - ;; - (progn - (unless (ada-goto-next-non-ws orgpoint) - (goto-char orgpoint)))) - - (cond - ;; - ;; nothing follows 'is' - ;; - ((and - foundis - (save-excursion - (not (ada-search-ignore-string-comment - "[^ \t\n]" nil orgpoint t)))) - (list cur-indent 'ada-indent)) - ;; - ;; is abstract/separate/new ... - ;; - ((and - foundis - (save-excursion - (setq match-cons - (ada-search-ignore-string-comment - "\\<\\(separate\\|new\\|abstract\\)\\>" - nil orgpoint)))) - (goto-char (car match-cons)) - (ada-search-ignore-string-comment ada-subprog-start-re t) - (ada-get-indent-noindent orgpoint)) - ;; - ;; something follows 'is' - ;; - ((and - foundis - (save-excursion (setq match-cons (ada-goto-next-non-ws orgpoint))) - (goto-char match-cons) - (ada-indent-on-previous-lines t orgpoint))) - ;; - ;; no 'is' but ';' - ;; - ((save-excursion - (ada-search-ignore-string-comment ";" nil orgpoint nil 'search-forward)) - (list cur-indent 0)) - ;; - ;; no 'is' or ';' - ;; - (t - (list cur-indent 'ada-broken-indent))))) - -(defun ada-get-indent-noindent (orgpoint) - "Calculate the indentation when point is just before a `noindent stmt'. -ORGPOINT is the limit position used in the calculation." - (let ((label 0)) - (save-excursion - (beginning-of-line) - - (cond - - ;; This one is called when indenting a line preceded by a multi-line - ;; subprogram declaration (in that case, we are at this point inside - ;; the parameter declaration list) - ((ada-in-paramlist-p) - (ada-previous-procedure) - (list (save-excursion (back-to-indentation) (point)) 0)) - - ;; This one is called when indenting the second line of a multi-line - ;; declaration section, in a declare block or a record declaration - ((looking-at "[ \t]*\\(\\sw\\|_\\)*[ \t]*,[ \t]*$") - (list (save-excursion (back-to-indentation) (point)) - 'ada-broken-decl-indent)) - - ;; This one is called in every other case when indenting a line at the - ;; top level - (t - (if (looking-at (concat "[ \t]*" ada-block-label-re)) - (setq label (- ada-label-indent)) - - (let (p) - - ;; "with private" or "null record" cases - (if (or (save-excursion - (and (ada-search-ignore-string-comment "\\" nil orgpoint) - (setq p (point)) - (save-excursion (forward-char -7);; skip back "private" - (ada-goto-previous-word) - (looking-at "with")))) - (save-excursion - (and (ada-search-ignore-string-comment "\\" nil orgpoint) - (setq p (point)) - (save-excursion (forward-char -6);; skip back "record" - (ada-goto-previous-word) - (looking-at "null"))))) - (progn - (goto-char p) - (re-search-backward "\\<\\(type\\|subtype\\)\\>" nil t) - (list (save-excursion (back-to-indentation) (point)) 0))))) - (if (save-excursion - (ada-search-ignore-string-comment ";" nil orgpoint nil - 'search-forward)) - (list (+ (save-excursion (back-to-indentation) (point)) label) 0) - (list (+ (save-excursion (back-to-indentation) (point)) label) - 'ada-broken-indent))))))) - -(defun ada-get-indent-block-label (orgpoint) - "Calculate the indentation when before a label or variable declaration. -ORGPOINT is the limit position used in the calculation." - (let ((match-cons nil) - (cur-indent (save-excursion (back-to-indentation) (point)))) - (ada-search-ignore-string-comment ":" nil) - (cond - ;; loop label - ((save-excursion - (setq match-cons (ada-search-ignore-string-comment - ada-loop-start-re nil orgpoint))) - (goto-char (car match-cons)) - (ada-get-indent-loop orgpoint)) - - ;; declare label - ((save-excursion - (setq match-cons (ada-search-ignore-string-comment - "\\" nil orgpoint))) - (goto-char (car match-cons)) - (list (save-excursion (back-to-indentation) (point)) 'ada-indent)) - - ;; variable declaration - ((ada-in-decl-p) - (if (save-excursion - (ada-search-ignore-string-comment ";" nil orgpoint)) - (list cur-indent 0) - (list cur-indent 'ada-broken-indent))) - - ;; nothing follows colon - (t - (list cur-indent '(- ada-label-indent)))))) - -(defun ada-get-indent-goto-label (orgpoint) - "Calculate the indentation when at a goto label." - (search-forward ">>") - (ada-goto-next-non-ws) - (if (>= (point) orgpoint) - ;; labeled statement is the one we need to indent - (list (- (point) ada-label-indent)) - ;; else indentation is indent for labeled statement - (ada-indent-on-previous-lines t orgpoint))) - -(defun ada-get-indent-loop (orgpoint) - "Calculate the indentation when just before a loop or a for ... use. -ORGPOINT is the limit position used in the calculation." - (let ((match-cons nil) - (pos (point)) - - ;; If looking at a named block, skip the label - (label (save-excursion - (back-to-indentation) - (if (looking-at ada-block-label-re) - (- ada-label-indent) - 0)))) - - (cond - - ;; - ;; statement complete - ;; - ((save-excursion - (ada-search-ignore-string-comment ";" nil orgpoint nil - 'search-forward)) - (list (+ (save-excursion (back-to-indentation) (point)) label) 0)) - ;; - ;; simple loop - ;; - ((looking-at "loop\\>") - (setq pos (ada-get-indent-block-start orgpoint)) - (if (equal label 0) - pos - (list (+ (car pos) label) (cadr pos)))) - - ;; - ;; 'for'- loop (or also a for ... use statement) - ;; - ((looking-at "for\\>") - (cond - ;; - ;; for ... use - ;; - ((save-excursion - (and - (goto-char (match-end 0)) - (ada-goto-next-non-ws orgpoint) - (forward-word-strictly 1) - (if (= (char-after) ?') (forward-word-strictly 1) t) - (ada-goto-next-non-ws orgpoint) - (looking-at "\\") - ;; - ;; check if there is a 'record' before point - ;; - (progn - (setq match-cons (ada-search-ignore-string-comment - "record" nil orgpoint nil 'word-search-forward)) - t))) - (if match-cons - (progn - (goto-char (car match-cons)) - (list (save-excursion (back-to-indentation) (point)) 'ada-indent)) - (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent)) - ) - - ;; - ;; for..loop - ;; - ((save-excursion - (setq match-cons (ada-search-ignore-string-comment - "loop" nil orgpoint nil 'word-search-forward))) - (goto-char (car match-cons)) - ;; - ;; indent according to 'loop', if it's first in the line; - ;; otherwise to 'for' - ;; - (unless (save-excursion - (back-to-indentation) - (looking-at "\\")) - (goto-char pos)) - (list (+ (save-excursion (back-to-indentation) (point)) label) - 'ada-indent)) - ;; - ;; for-statement is broken - ;; - (t - (list (+ (save-excursion (back-to-indentation) (point)) label) - 'ada-broken-indent)))) - - ;; - ;; 'while'-loop - ;; - ((looking-at "while\\>") - ;; - ;; while..loop ? - ;; - (if (save-excursion - (setq match-cons (ada-search-ignore-string-comment - "loop" nil orgpoint nil 'word-search-forward))) - - (progn - (goto-char (car match-cons)) - ;; - ;; indent according to 'loop', if it's first in the line; - ;; otherwise to 'while'. - ;; - (unless (save-excursion - (back-to-indentation) - (looking-at "\\")) - (goto-char pos)) - (list (+ (save-excursion (back-to-indentation) (point)) label) - 'ada-indent)) - - (list (+ (save-excursion (back-to-indentation) (point)) label) - 'ada-broken-indent)))))) - -(defun ada-get-indent-type (orgpoint) - "Calculate the indentation when before a type statement. -ORGPOINT is the limit position used in the calculation." - (let ((match-dat nil)) - (cond - ;; - ;; complete record declaration - ;; - ((save-excursion - (and - (setq match-dat (ada-search-ignore-string-comment - "end" nil orgpoint nil 'word-search-forward)) - (ada-goto-next-non-ws) - (looking-at "\\") - (forward-word-strictly 1) - (ada-goto-next-non-ws) - (= (char-after) ?\;))) - (goto-char (car match-dat)) - (list (save-excursion (back-to-indentation) (point)) 0)) - ;; - ;; record type - ;; - ((save-excursion - (setq match-dat (ada-search-ignore-string-comment - "record" nil orgpoint nil 'word-search-forward))) - (goto-char (car match-dat)) - (list (save-excursion (back-to-indentation) (point)) 'ada-indent)) - ;; - ;; complete type declaration - ;; - ((save-excursion - (ada-search-ignore-string-comment ";" nil orgpoint nil - 'search-forward)) - (list (save-excursion (back-to-indentation) (point)) 0)) - ;; - ;; "type ... is", but not "type ... is ...", which is broken - ;; - ((save-excursion - (and - (ada-search-ignore-string-comment "is" nil orgpoint nil - 'word-search-forward) - (not (ada-goto-next-non-ws orgpoint)))) - (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent)) - ;; - ;; broken statement - ;; - (t - (list (save-excursion (back-to-indentation) (point)) - 'ada-broken-indent))))) - - -;; ----------------------------------------------------------- -;; -- searching and matching -;; ----------------------------------------------------------- - -(defun ada-goto-stmt-start (&optional ignore-goto-label) - "Move point to the beginning of the statement that point is in or after. -Return the new position of point. -As a special case, if we are looking at a closing parenthesis, skip to the -open parenthesis." - (let ((match-dat nil) - (orgpoint (point))) - - (setq match-dat (ada-search-prev-end-stmt)) - (if match-dat - - ;; - ;; found a previous end-statement => check if anything follows - ;; - (unless (looking-at "declare") - (progn - (unless (save-excursion - (goto-char (cdr match-dat)) - (ada-goto-next-non-ws orgpoint ignore-goto-label)) - ;; - ;; nothing follows => it's the end-statement directly in - ;; front of point => search again - ;; - (setq match-dat (ada-search-prev-end-stmt))) - ;; - ;; if found the correct end-statement => goto next non-ws - ;; - (if match-dat - (goto-char (cdr match-dat))) - (ada-goto-next-non-ws) - )) - - ;; - ;; no previous end-statement => we are at the beginning of the - ;; accessible part of the buffer - ;; - (progn - (goto-char (point-min)) - ;; - ;; skip to the very first statement, if there is one - ;; - (unless (ada-goto-next-non-ws orgpoint) - (goto-char orgpoint)))) - (point))) - - -(defun ada-search-prev-end-stmt () - "Move point to previous end statement. -Return a cons cell whose car is the beginning and whose cdr -is the end of the match." - (let ((match-dat nil) - (found nil)) - - ;; search until found or beginning-of-buffer - (while - (and - (not found) - (setq match-dat (ada-search-ignore-string-comment - ada-end-stmt-re t))) - - (goto-char (car match-dat)) - (unless (ada-in-open-paren-p) - (cond - - ((and (looking-at - "\\<\\(record\\|loop\\|select\\|else\\|then\\)\\>") - (save-excursion - (ada-goto-previous-word) - (looking-at "\\<\\(end\\|or\\|and\\)\\>[ \t]*[^;]"))) - (forward-word-strictly -1)) - - ((looking-at "is") - (setq found - (and (save-excursion (ada-goto-previous-word) - (ada-goto-previous-word) - (not (looking-at "subtype"))) - - (save-excursion (goto-char (cdr match-dat)) - (ada-goto-next-non-ws) - ;; words that can go after an 'is' - (not (looking-at - (eval-when-compile - (concat "\\<" - (regexp-opt - '("separate" "access" "array" - "private" "abstract" "new") t) - "\\>\\|(")))))))) - - ((looking-at "private") - (save-excursion - (backward-word-strictly 1) - (setq found (not (looking-at "is"))))) - - (t - (setq found t)) - ))) - - (if found - match-dat - nil))) - -(defun ada-goto-next-non-ws (&optional limit skip-goto-label) - "Skip to next non-whitespace character. -Skips spaces, newlines and comments, and possibly goto labels. -Return `point' if moved, nil if not. -Stop the search at LIMIT. -Do not call this function from within a string." - (unless limit - (setq limit (point-max))) - (while (and (<= (point) limit) - (or (progn (forward-comment 10000) - (if (and (not (eobp)) - (save-excursion (forward-char 1) - (ada-in-string-p))) - (progn (forward-sexp 1) t))) - (and skip-goto-label - (looking-at ada-goto-label-re) - (progn - (goto-char (match-end 0)) - t))))) - (if (< (point) limit) - (point) - nil) - ) - - -(defun ada-goto-stmt-end (&optional limit) - "Move point to the end of the statement that point is in or before. -Return the new position of point or nil if not found. -Stop the search at LIMIT." - (if (ada-search-ignore-string-comment ada-end-stmt-re nil limit) - (point) - nil)) - - -(defun ada-goto-next-word (&optional backward) - "Move point to the beginning of the next word of Ada code. -If BACKWARD is non-nil, jump to the beginning of the previous word. -Return the new position of point or nil if not found." - (let ((match-cons nil) - (orgpoint (point))) - (unless backward - (skip-syntax-forward "w_")) - (if (setq match-cons - (ada-search-ignore-string-comment "\\sw\\|\\s_" backward nil t)) - ;; - ;; move to the beginning of the word found - ;; - (progn - (goto-char (car match-cons)) - (skip-syntax-backward "w_") - (point)) - ;; - ;; if not found, restore old position of point - ;; - (goto-char orgpoint) - 'nil))) - - -(defun ada-check-matching-start (keyword) - "Signal an error if matching block start is not KEYWORD. -Moves point to the matching block start." - (ada-goto-matching-start 0) - (unless (looking-at (concat "\\<" keyword "\\>")) - (error "Matching start is not `%s'" keyword))) - - -(defun ada-check-defun-name (defun-name) - "Check if the name of the matching defun really is DEFUN-NAME. -Assumes point to be already positioned by `ada-goto-matching-start'. -Moves point to the beginning of the declaration." - - ;; named block without a `declare'; ada-goto-matching-start leaves - ;; point at start of 'begin' for a block. - (if (save-excursion - (ada-goto-previous-word) - (looking-at (concat "\\<" defun-name "\\> *:"))) - t ; name matches - ;; else - ;; - ;; 'accept' or 'package' ? - ;; - (unless (looking-at ada-subprog-start-re) - (ada-goto-decl-start)) - ;; - ;; 'begin' of 'procedure'/'function'/'task' or 'declare' - ;; - (save-excursion - ;; - ;; a named 'declare'-block ? => jump to the label - ;; - (if (looking-at "\\") - (progn - (forward-comment -1) - (backward-word-strictly 1)) - ;; - ;; no, => 'procedure'/'function'/'task'/'protected' - ;; - (progn - (forward-word-strictly 2) - (backward-word-strictly 1) - ;; - ;; skip 'body' 'type' - ;; - (if (looking-at "\\<\\(body\\|type\\)\\>") - (forward-word-strictly 1)) - (forward-sexp 1) - (backward-sexp 1))) - ;; - ;; should be looking-at the correct name - ;; - (unless (looking-at (concat "\\<" defun-name "\\>")) - (error "Matching defun has different name: %s" - (buffer-substring (point) - (progn (forward-sexp 1) (point)))))))) - -(defun ada-goto-decl-start (&optional noerror) - "Move point to the declaration start of the current construct. -If NOERROR is non-nil, return nil if no match was found; -otherwise throw error." - (let ((nest-count 1) - (regexp (eval-when-compile - (concat "\\<" - (regexp-opt - '("is" "separate" "end" "declare" "if" "new" "begin" "generic" "when") t) - "\\>"))) - - ;; first should be set to t if we should stop at the first - ;; "begin" we encounter. - (first t) - (count-generic nil) - (stop-at-when nil) - ) - - ;; Ignore "when" most of the time, except if we are looking at the - ;; beginning of a block (structure: case .. is - ;; when ... => - ;; begin ... - ;; exception ... ) - (if (looking-at "begin") - (setq stop-at-when t)) - - (if (or - (looking-at "\\<\\(package\\|procedure\\|function\\)\\>") - (save-excursion - (ada-search-ignore-string-comment - "\\<\\(package\\|procedure\\|function\\|generic\\)\\>" t) - (looking-at "generic"))) - (setq count-generic t)) - - ;; search backward for interesting keywords - (while (and - (not (zerop nest-count)) - (ada-search-ignore-string-comment regexp t)) - ;; - ;; calculate nest-depth - ;; - (cond - ;; - ((looking-at "end") - (ada-goto-matching-start 1 noerror) - - ;; In some case, two begin..end block can follow each other closely, - ;; which we have to detect, as in - ;; procedure P is - ;; procedure Q is - ;; begin - ;; end; - ;; begin -- here we should go to procedure, not begin - ;; end - - (if (looking-at "begin") - (let ((loop-again t)) - (save-excursion - (while loop-again - ;; If begin was just there as the beginning of a block - ;; (with no declare) then do nothing, otherwise just - ;; register that we have to find the statement that - ;; required the begin - - (ada-search-ignore-string-comment - "\\<\\(declare\\|begin\\|end\\|procedure\\|function\\|task\\|package\\)\\>" - t) - - (if (looking-at "end") - (ada-goto-matching-start 1 noerror t) - - (setq loop-again nil) - (unless (looking-at "begin") - (setq nest-count (1+ nest-count)))) - )) - ))) - ;; - ((looking-at "generic") - (if count-generic - (progn - (setq first nil) - (setq nest-count (1- nest-count))))) - ;; - ((looking-at "if") - (save-excursion - (forward-word-strictly -1) - (unless (looking-at "\\") - (progn - (setq nest-count (1- nest-count)) - (setq first nil))))) - - ;; - ((looking-at "declare\\|generic") - (setq nest-count (1- nest-count)) - (setq first t)) - ;; - ((looking-at "is") - ;; look for things to ignore - (if - (or - ;; generic formal parameter - (looking-at "is[ t]+<>") - - ;; A type definition, or a case statement. Note that the - ;; goto-matching-start above on 'end record' leaves us at - ;; 'record', not at 'type'. - ;; - ;; We get to a case statement here by calling - ;; 'ada-move-to-end' from inside a case statement; then - ;; we are not ignoring 'when'. - (save-excursion - ;; Skip type discriminants or case argument function call param list - (forward-comment -10000) - (forward-char -1) - (if (= (char-after) ?\)) - (progn - (forward-char 1) - (backward-sexp 1) - (forward-comment -10000) - )) - ;; skip type or case argument name - (skip-chars-backward "a-zA-Z0-9_.'") - (ada-goto-previous-word) - (and - ;; if it's a protected type, it's the decl start we - ;; are looking for; since we didn't see the 'end' - ;; above, we are inside it. - (looking-at "\\<\\(sub\\)?type\\|case\\>") - (save-match-data - (ada-goto-previous-word) - (not (looking-at "\\")))) - ) ; end of type definition p - - ;; null procedure declaration - (save-excursion (ada-goto-next-word) (looking-at "\\")) - );; end or - ;; skip this construct - nil - ;; this is the right "is" - (setq nest-count (1- nest-count)) - (setq first nil))) - - ;; - ((looking-at "new") - (if (save-excursion - (ada-goto-previous-word) - (looking-at "is")) - (goto-char (match-beginning 0)))) - ;; - ((and first - (looking-at "begin")) - (setq nest-count 0)) - ;; - ((looking-at "when") - (save-excursion - (forward-word-strictly -1) - (unless (looking-at "\\") - (progn - (if stop-at-when - (setq nest-count (1- nest-count))) - )))) - ;; - ((looking-at "begin") - (setq first nil)) - ;; - (t - (setq nest-count (1+ nest-count)) - (setq first nil))) - - );; end of loop - - ;; check if declaration-start is really found - (if (and - (zerop nest-count) - (if (looking-at "is") - (ada-search-ignore-string-comment ada-subprog-start-re t) - (looking-at "declare\\|generic"))) - t - (if noerror nil - (error "No matching proc/func/task/declare/package/protected"))) - )) - -(defun ada-goto-matching-start (&optional nest-level noerror gotothen) - "Move point to the beginning of a block-start. -Which block depends on the value of NEST-LEVEL, which defaults to zero. -If NOERROR is non-nil, it only returns nil if no matching start was found. -If GOTOTHEN is non-nil, point moves to the `then' following `if'." - (let ((nest-count (if nest-level nest-level 0)) - (found nil) - - (last-was-begin '()) - ;; List all keywords encountered while traversing - ;; something like '("end" "end" "begin") - ;; This is removed from the list when "package", "procedure",... - ;; are seen. The goal is to find whether a package has an elaboration - ;; part - - (pos nil)) - - ;; search backward for interesting keywords - (while (and - (not found) - (ada-search-ignore-string-comment ada-matching-start-re t)) - - (unless (and (looking-at "\\") - (save-excursion - (forward-word-strictly -1) - (looking-at "\\"))) - (progn - ;; calculate nest-depth - (cond - ;; found block end => increase nest depth - ((looking-at "end") - (push nil last-was-begin) - (setq nest-count (1+ nest-count))) - - ;; found loop/select/record/case/if => check if it starts or - ;; ends a block - ((looking-at "loop\\|select\\|record\\|case\\|if") - (setq pos (point)) - (save-excursion - ;; check if keyword follows 'end' - (ada-goto-previous-word) - (if (looking-at "\\[ \t]*[^;]") - (progn - ;; it ends a block => increase nest depth - (setq nest-count (1+ nest-count) - pos (point)) - (push nil last-was-begin)) - - ;; it starts a block => decrease nest depth - (setq nest-count (1- nest-count)) - - ;; Some nested "begin .. end" blocks with no "declare"? - ;; => remove those entries - (while (car last-was-begin) - (setq last-was-begin (cdr (cdr last-was-begin)))) - - (setq last-was-begin (cdr last-was-begin)) - )) - (goto-char pos) - ) - - ;; found package start => check if it really is a block - ((looking-at "package") - (save-excursion - ;; ignore if this is just a renames statement - (let ((current (point)) - (pos (ada-search-ignore-string-comment - "\\<\\(is\\|renames\\|;\\)\\>" nil))) - (if pos - (goto-char (car pos)) - (error (concat - "No matching `is' or `renames' for `package' at" - " line " - (number-to-string (count-lines 1 (1+ current))))))) - (unless (looking-at "renames") - (progn - (forward-word-strictly 1) - (ada-goto-next-non-ws) - ;; ignore it if it is only a declaration with 'new' - ;; We could have package Foo is new .... - ;; or package Foo is separate; - ;; or package Foo is begin null; end Foo - ;; for elaboration code (elaboration) - (if (and (not (looking-at "\\<\\(new\\|separate\\|begin\\)\\>")) - (not (car last-was-begin))) - (setq nest-count (1- nest-count)))))) - - (setq last-was-begin (cdr last-was-begin)) - ) - ;; found task start => check if it has a body - ((looking-at "task") - (save-excursion - (forward-word-strictly 1) - (ada-goto-next-non-ws) - (cond - ((looking-at "\\")) - ((looking-at "\\") - ;; In that case, do nothing if there is a "is" - (forward-word-strictly 2);; skip "type" - (ada-goto-next-non-ws);; skip type name - - ;; Do nothing if we are simply looking at a simple - ;; "task type name;" statement with no block - (unless (looking-at ";") - (progn - ;; Skip the parameters - (if (looking-at "(") - (ada-search-ignore-string-comment ")" nil)) - (let ((tmp (ada-search-ignore-string-comment - "\\<\\(is\\|;\\)\\>" nil))) - (if tmp - (progn - (goto-char (car tmp)) - (if (looking-at "is") - (setq nest-count (1- nest-count))))))))) - (t - ;; Check if that task declaration had a block attached to - ;; it (i.e do nothing if we have just "task name;") - (unless (progn (forward-word-strictly 1) - (looking-at "[ \t]*;")) - (setq nest-count (1- nest-count)))))) - (setq last-was-begin (cdr last-was-begin)) - ) - - ((looking-at "declare") - ;; remove entry for begin and end (include nested begin..end - ;; groups) - (setq last-was-begin (cdr last-was-begin)) - (let ((count 1)) - (while (and (> count 0)) - (if (equal (car last-was-begin) t) - (setq count (1+ count)) - (setq count (1- count))) - (setq last-was-begin (cdr last-was-begin)) - ))) - - ((looking-at "protected") - ;; Ignore if this is just a declaration - (save-excursion - (let ((pos (ada-search-ignore-string-comment - "\\(\\\\|\\\\|;\\)" nil))) - (if pos - (goto-char (car pos))) - (if (looking-at "is") - ;; remove entry for end - (setq last-was-begin (cdr last-was-begin))))) - (setq nest-count (1- nest-count))) - - ((or (looking-at "procedure") - (looking-at "function")) - ;; Ignore if this is just a declaration - (save-excursion - (let ((pos (ada-search-ignore-string-comment - "\\(\\\\|\\\\|)[ \t]*;\\)" nil))) - (if pos - (goto-char (car pos))) - (if (looking-at "is") - ;; remove entry for begin and end - (setq last-was-begin (cdr (cdr last-was-begin)))))) - ) - - ;; all the other block starts - (t - (push (looking-at "begin") last-was-begin) - (setq nest-count (1- nest-count))) - - ) - - ;; match is found, if nest-depth is zero - (setq found (zerop nest-count))))) ; end of loop - - (if (bobp) - (point) - (if found - ;; - ;; match found => is there anything else to do ? - ;; - (progn - (cond - ;; - ;; found 'if' => skip to 'then', if it's on a separate line - ;; and GOTOTHEN is non-nil - ;; - ((and - gotothen - (looking-at "if") - (save-excursion - (ada-search-ignore-string-comment "then" nil nil nil - 'word-search-forward) - (back-to-indentation) - (looking-at "\\"))) - (goto-char (match-beginning 0))) - - ;; - ;; found 'do' => skip back to 'accept' or 'return' - ;; - ((looking-at "do") - (unless (ada-search-ignore-string-comment - "\\" t) - (error "Missing `accept' or `return' in front of `do'")))) - (point)) - - (if noerror - nil - (error "No matching start")))))) - - -(defun ada-goto-matching-end (&optional nest-level noerror) - "Move point to the end of a block. -Which block depends on the value of NEST-LEVEL, which defaults to zero. -If NOERROR is non-nil, it only returns nil if no matching start found." - (let ((nest-count (or nest-level 0)) - (regex (eval-when-compile - (concat "\\<" - (regexp-opt '("end" "loop" "select" "begin" "case" - "if" "task" "package" "record" "do" - "procedure" "function") t) - "\\>"))) - found - pos - - ;; First is used for subprograms: they are generally handled - ;; recursively, but of course we do not want to do that the - ;; first time (see comment below about subprograms) - (first (not (looking-at "declare")))) - - ;; If we are already looking at one of the keywords, this shouldn't count - ;; in the nesting loop below, so we just make sure we don't count it. - ;; "declare" is a special case because we need to look after the "begin" - ;; keyword - (if (looking-at "\\") - (forward-char 1)) - - ;; - ;; search forward for interesting keywords - ;; - (while (and - (not found) - (ada-search-ignore-string-comment regex nil)) - - ;; - ;; calculate nest-depth - ;; - (backward-word-strictly 1) - (cond - ;; procedures and functions need to be processed recursively, in - ;; case they are defined in a declare/begin block, as in: - ;; declare -- NL 0 (nested level) - ;; A : Boolean; - ;; procedure B (C : D) is - ;; begin -- NL 1 - ;; null; - ;; end B; -- NL 0, and we would exit - ;; begin - ;; end; -- we should exit here - ;; processing them recursively avoids the need for any special - ;; handling. - ;; Nothing should be done if we have only the specs or a - ;; generic instantiation. - - ((and (looking-at "\\")) - (if first - (forward-word-strictly 1) - - (setq pos (point)) - (ada-search-ignore-string-comment "is\\|;") - (if (= (char-before) ?s) - (progn - (ada-goto-next-non-ws) - (unless (looking-at "\\") - (progn - (goto-char pos) - (ada-goto-matching-end 0 t))))))) - - ;; found block end => decrease nest depth - ((looking-at "\\") - (setq nest-count (1- nest-count) - found (<= nest-count 0)) - ;; skip the following keyword - (if (progn - (skip-chars-forward "end") - (ada-goto-next-non-ws) - (looking-at "\\<\\(loop\\|select\\|record\\|case\\|if\\)\\>")) - (forward-word-strictly 1))) - - ;; found package start => check if it really starts a block, and is not - ;; in fact a generic instantiation for instance - ((looking-at "\\") - (ada-search-ignore-string-comment "is" nil nil nil - 'word-search-forward) - (ada-goto-next-non-ws) - ;; ignore and skip it if it is only a 'new' package - (if (looking-at "\\") - (goto-char (match-end 0)) - (setq nest-count (1+ nest-count) - found (<= nest-count 0)))) - - ;; all the other block starts - (t - (if (not first) - (setq nest-count (1+ nest-count))) - (setq found (<= nest-count 0)) - (forward-word-strictly 1))) ; end of 'cond' - - (setq first nil)) - - (if found - t - (if noerror - nil - (error "No matching end"))) - )) - - -(defun ada-search-ignore-string-comment - (search-re &optional backward limit paramlists search-func) - "Regexp-search for SEARCH-RE, ignoring comments, strings. -Returns a cons cell of begin and end of match data or nil, if not found. -If BACKWARD is non-nil, search backward; search forward otherwise. -The search stops at pos LIMIT. -If PARAMLISTS is nil, ignore parameter lists. -The search is done using SEARCH-FUNC. SEARCH-FUNC can be optimized -in case we are searching for a constant string. -Point is moved at the beginning of the SEARCH-RE." - (let (found - begin - end - parse-result) - - ;; FIXME: need to pass BACKWARD to search-func! - (unless search-func - (setq search-func (if backward 're-search-backward 're-search-forward))) - - ;; - ;; search until found or end-of-buffer - ;; We have to test that we do not look further than limit - ;; - (with-syntax-table ada-mode-symbol-syntax-table - (while (and (not found) - (or (not limit) - (or (and backward (<= limit (point))) - (>= limit (point)))) - (funcall search-func search-re limit 1)) - (setq begin (match-beginning 0)) - (setq end (match-end 0)) - (setq parse-result (parse-partial-sexp (point-at-bol) (point))) - (cond - ;; - ;; If inside a string, skip it (and the following comments) - ;; - ((ada-in-string-p parse-result) - (if (featurep 'xemacs) - (search-backward "\"" nil t) - (goto-char (nth 8 parse-result))) - (unless backward (forward-sexp 1))) - ;; - ;; If inside a comment, skip it (and the following comments) - ;; There is a special code for comments at the end of the file - ;; - ((ada-in-comment-p parse-result) - (if (featurep 'xemacs) - (progn - (forward-line 1) - (beginning-of-line) - (forward-comment -1)) - (goto-char (nth 8 parse-result))) - (unless backward - ;; at the end of the file, it is not possible to skip a comment - ;; so we just go at the end of the line - (if (forward-comment 1) - (progn - (forward-comment 1000) - (beginning-of-line)) - (end-of-line)))) - ;; - ;; directly in front of a comment => skip it, if searching forward - ;; - ((and (= (char-after begin) ?-) (= (char-after (1+ begin)) ?-)) - (unless backward (progn (forward-char -1) (forward-comment 1000)))) - - ;; - ;; found a parameter-list but should ignore it => skip it - ;; - ((and (not paramlists) (ada-in-paramlist-p)) - (if backward - (search-backward "(" nil t) - (search-forward ")" nil t))) - ;; - ;; found what we were looking for - ;; - (t - (setq found t))))) ; end of loop - - (if found - (cons begin end) - nil))) - -;; ------------------------------------------------------- -;; -- Testing the position of the cursor -;; ------------------------------------------------------- - -(defun ada-in-decl-p () - "Return t if point is inside a declarative part. -Assumes point to be at the end of a statement." - (or (ada-in-paramlist-p) - (save-excursion - (ada-goto-decl-start t)))) - - -(defun ada-looking-at-semi-or () - "Return t if looking at an `or' following a semicolon." - (save-excursion - (and (looking-at "\\") - (progn - (forward-word-strictly 1) - (ada-goto-stmt-start) - (looking-at "\\"))))) - - -(defun ada-looking-at-semi-private () - "Return t if looking at the start of a private section in a package. -Return nil if the private is part of the package name, as in -'private package A is...' (this can only happen at top level)." - (save-excursion - (and (looking-at "\\") - (not (looking-at "\\")))))))) - - -(defun ada-in-paramlist-p () - "Return t if point is inside the parameter-list of a declaration, but not a subprogram call or aggregate." - (save-excursion - (and - (ada-search-ignore-string-comment "(\\|)" t nil t) - ;; inside parentheses ? - (= (char-after) ?\() - - ;; We could be looking at two things here: - ;; operator definition: function "." ( - ;; subprogram definition: procedure .... ( - ;; Let's skip back over the first one - (progn - (skip-chars-backward " \t\n") - (if (= (char-before) ?\") - (backward-char 3) - (backward-word-strictly 1)) - t) - - ;; and now over the second one - (backward-word-strictly 1) - - ;; We should ignore the case when the reserved keyword is in a - ;; comment (for instance, when we have: - ;; -- .... package - ;; Test (A) - ;; we should return nil - - (not (ada-in-string-or-comment-p)) - - ;; right keyword two words before parenthesis ? - ;; Type is in this list because of discriminants - ;; pragma is not, because the syntax is that of a subprogram call. - (looking-at (eval-when-compile - (concat "\\<\\(" - "procedure\\|function\\|body\\|" - "task\\|entry\\|accept\\|" - "access[ \t]+procedure\\|" - "access[ \t]+function\\|" - "type\\)\\>")))))) - -(defun ada-search-ignore-complex-boolean (regexp backwardp) - "Search for REGEXP, ignoring comments, strings, `and then', `or else'. -If BACKWARDP is non-nil, search backward; search forward otherwise." - (let (result) - (while (and (setq result (ada-search-ignore-string-comment regexp backwardp)) - (save-excursion (forward-word-strictly -1) - (looking-at "and then\\|or else")))) - result)) - -(defun ada-in-open-paren-p () - "Non-nil if in an open parenthesis. -Return value is the position of the first non-ws behind the last unclosed -parenthesis, or nil." - (save-excursion - (let ((parse (parse-partial-sexp - (point) - (or (car (ada-search-ignore-complex-boolean - "\\<\\(;\\|is\\|then\\|loop\\|begin\\|else\\)\\>" - t)) - (point-min))))) - - (if (nth 1 parse) - (progn - (goto-char (1+ (nth 1 parse))) - - ;; Skip blanks, if they are not followed by a comment - ;; See: - ;; type A is ( Value_0, - ;; Value_1); - ;; type B is ( -- comment - ;; Value_2); - - (if (or (not ada-indent-handle-comment-special) - (not (looking-at "[ \t]+--"))) - (skip-chars-forward " \t")) - - (point)))))) - - -;; ----------------------------------------------------------- -;; -- Behavior Of TAB Key -;; ----------------------------------------------------------- - -(defun ada-tab () - "Do indenting or tabbing according to `ada-tab-policy'. -In Transient Mark mode, if the mark is active, operate on the contents -of the region. Otherwise, operate only on the current line." - (interactive) - (cond ((eq ada-tab-policy 'indent-rigidly) (ada-tab-hard)) - ((eq ada-tab-policy 'indent-auto) - (if (ada-region-selected) - (ada-indent-region (region-beginning) (region-end)) - (ada-indent-current))) - ((eq ada-tab-policy 'always-tab) (error "Not implemented")) - )) - -(defun ada-untab (_arg) - "Delete leading indenting according to `ada-tab-policy'." - ;; FIXME: ARG is ignored - (interactive "P") - (cond ((eq ada-tab-policy 'indent-rigidly) (ada-untab-hard)) - ((eq ada-tab-policy 'indent-auto) (error "Not implemented")) - ((eq ada-tab-policy 'always-tab) (error "Not implemented")) - )) - -(defun ada-indent-current-function () - "Ada mode version of the `indent-line-function'." - (interactive "*") - (let ((starting-point (point-marker))) - (beginning-of-line) - (ada-tab) - (if (< (point) starting-point) - (goto-char starting-point)) - (set-marker starting-point nil) - )) - -(defun ada-tab-hard () - "Indent current line to next tab stop." - (interactive) - (save-excursion - (beginning-of-line) - (insert-char ? ada-indent)) - (if (bolp) (forward-char ada-indent))) - -(defun ada-untab-hard () - "Indent current line to previous tab stop." - (interactive) - (indent-rigidly (point-at-bol) (point-at-eol) (- 0 ada-indent))) - - -;; ------------------------------------------------------------ -;; -- Miscellaneous -;; ------------------------------------------------------------ - -;; Not needed any more for Emacs 21.2, but still needed for backward -;; compatibility -(defun ada-remove-trailing-spaces () - "Remove trailing spaces in the whole buffer." - (interactive) - (save-match-data - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (while (re-search-forward "[ \t]+$" (point-max) t) - (replace-match "" nil nil)))))) - -(defun ada-gnat-style () - "Clean up comments, `(' and `,' for GNAT style checking switch." - (interactive) - (save-excursion - - ;; The \n is required, or the line after an empty comment line is - ;; simply ignored. - (goto-char (point-min)) - (while (re-search-forward "--[ \t]*\\([^-\n]\\)" nil t) - (replace-match "-- \\1") - (forward-line 1) - (beginning-of-line)) - - (goto-char (point-min)) - (while (re-search-forward "\\>(" nil t) - (if (not (ada-in-string-or-comment-p)) - (replace-match " ("))) - (goto-char (point-min)) - (while (re-search-forward ";--" nil t) - (forward-char -1) - (if (not (ada-in-string-or-comment-p)) - (replace-match "; --"))) - (goto-char (point-min)) - (while (re-search-forward "([ \t]+" nil t) - (if (not (ada-in-string-or-comment-p)) - (replace-match "("))) - (goto-char (point-min)) - (while (re-search-forward ")[ \t]+)" nil t) - (if (not (ada-in-string-or-comment-p)) - (replace-match "))"))) - (goto-char (point-min)) - (while (re-search-forward "\\>:" nil t) - (if (not (ada-in-string-or-comment-p)) - (replace-match " :"))) - - ;; Make sure there is a space after a ','. - ;; Always go back to the beginning of the match, since otherwise - ;; a statement like ('F','D','E') is incorrectly modified. - (goto-char (point-min)) - (while (re-search-forward ",[ \t]*\\(.\\)" nil t) - (if (not (save-excursion - (goto-char (match-beginning 0)) - (ada-in-string-or-comment-p))) - (replace-match ", \\1"))) - - ;; Operators should be surrounded by spaces. - (goto-char (point-min)) - (while (re-search-forward - "[ \t]*\\(/=\\|\\*\\*\\|:=\\|\\.\\.\\|[-:+*/]\\)[ \t]*" - nil t) - (goto-char (match-beginning 1)) - (if (or (looking-at "--") - (ada-in-string-or-comment-p)) - (progn - (forward-line 1) - (beginning-of-line)) - (cond - ((string= (match-string 1) "/=") - (replace-match " /= ")) - ((string= (match-string 1) "..") - (replace-match " .. ")) - ((string= (match-string 1) "**") - (replace-match " ** ")) - ((string= (match-string 1) ":=") - (replace-match " := ")) - (t - (replace-match " \\1 "))) - (forward-char 1))) - )) - - - -;; ------------------------------------------------------------- -;; -- Moving To Procedures/Packages/Statements -;; ------------------------------------------------------------- - -(defun ada-move-to-start () - "Move point to the matching start of the current Ada structure." - (interactive) - (let ((pos (point))) - (with-syntax-table ada-mode-symbol-syntax-table - - (save-excursion - ;; - ;; do nothing if in string or comment or not on 'end ...;' - ;; or if an error occurs during processing - ;; - (or - (ada-in-string-or-comment-p) - (and (progn - (or (looking-at "[ \t]*\\") - (backward-word-strictly 1)) - (or (looking-at "[ \t]*\\") - (backward-word-strictly 1)) - (or (looking-at "[ \t]*\\") - (error "Not on end ...;"))) - (ada-goto-matching-start 1) - (setq pos (point)) - - ;; - ;; on 'begin' => go on, according to user option - ;; - ada-move-to-declaration - (looking-at "\\") - (ada-goto-decl-start) - (setq pos (point)))) - - ) ; end of save-excursion - - ;; now really move to the found position - (goto-char pos)))) - -(defun ada-move-to-end () - "Move point to the end of the block around point. -Moves to `begin' if in a declarative part." - (interactive) - (let ((pos (point)) - decl-start) - (with-syntax-table ada-mode-symbol-syntax-table - - (save-excursion - - (cond - ;; Go to the beginning of the current word, and check if we are - ;; directly on 'begin' - ((save-excursion - (skip-syntax-backward "w") - (looking-at "\\")) - (ada-goto-matching-end 1)) - - ;; on first line of subprogram body - ;; Do nothing for specs or generic instantiation, since these are - ;; handled as the general case (find the enclosing block) - ;; We also need to make sure that we ignore nested subprograms - ((save-excursion - (and (skip-syntax-backward "w") - (looking-at "\\\\|\\" ) - (ada-search-ignore-string-comment "is\\|;") - (not (= (char-before) ?\;)) - )) - (skip-syntax-backward "w") - (ada-goto-matching-end 0 t)) - - ;; on first line of task declaration - ((save-excursion - (and (ada-goto-stmt-start) - (looking-at "\\" ) - (forward-word-strictly 1) - (ada-goto-next-non-ws) - (looking-at "\\"))) - (ada-search-ignore-string-comment "begin" nil nil nil - 'word-search-forward)) - ;; accept block start - ((save-excursion - (and (ada-goto-stmt-start) - (looking-at "\\" ))) - (ada-goto-matching-end 0)) - ;; package start - ((save-excursion - (setq decl-start (and (ada-goto-decl-start t) (point))) - (and decl-start (looking-at "\\"))) - (ada-goto-matching-end 1)) - - ;; On a "declare" keyword - ((save-excursion - (skip-syntax-backward "w") - (looking-at "\\")) - (ada-goto-matching-end 0 t)) - - ;; inside a 'begin' ... 'end' block - (decl-start - (goto-char decl-start) - (ada-goto-matching-end 0 t)) - - ;; (hopefully ;-) everything else - (t - (ada-goto-matching-end 1))) - (setq pos (point)) - ) - - ;; now really move to the position found - (goto-char pos)))) - -(defun ada-next-procedure () - "Move point to next procedure." - (interactive) - (end-of-line) - (if (re-search-forward ada-procedure-start-regexp nil t) - (goto-char (match-beginning 4)) - (error "No more functions/procedures/tasks"))) - -(defun ada-previous-procedure () - "Move point to previous procedure." - (interactive) - (beginning-of-line) - (if (re-search-backward ada-procedure-start-regexp nil t) - (goto-char (match-beginning 4)) - (error "No more functions/procedures/tasks"))) - -(defun ada-next-package () - "Move point to next package." - (interactive) - (end-of-line) - (if (re-search-forward ada-package-start-regexp nil t) - (goto-char (match-beginning 1)) - (error "No more packages"))) - -(defun ada-previous-package () - "Move point to previous package." - (interactive) - (beginning-of-line) - (if (re-search-backward ada-package-start-regexp nil t) - (goto-char (match-beginning 1)) - (error "No more packages"))) - - -;; ------------------------------------------------------------ -;; -- Define keymap and menus for Ada -;; ------------------------------------------------------------- - -(defun ada-create-keymap () - "Create the keymap associated with the Ada mode." - - ;; All non-standard keys go into ada-mode-extra-map - (define-key ada-mode-map ada-mode-extra-prefix ada-mode-extra-map) - - ;; Indentation and Formatting - (define-key ada-mode-map "\C-j" 'ada-indent-newline-indent-conditional) - (define-key ada-mode-map "\C-m" 'ada-indent-newline-indent-conditional) - (define-key ada-mode-map "\t" 'ada-tab) - (define-key ada-mode-map "\C-c\t" 'ada-justified-indent-current) - (define-key ada-mode-map "\C-c\C-l" 'ada-indent-region) - (define-key ada-mode-map [(shift tab)] 'ada-untab) - (define-key ada-mode-map "\C-c\C-f" 'ada-format-paramlist) - ;; We don't want to make meta-characters case-specific. - - ;; Movement - (define-key ada-mode-map "\M-\C-e" 'ada-next-procedure) - (define-key ada-mode-map "\M-\C-a" 'ada-previous-procedure) - (define-key ada-mode-map "\C-c\C-a" 'ada-move-to-start) - (define-key ada-mode-map "\C-c\C-e" 'ada-move-to-end) - - ;; Compilation - (unless (lookup-key ada-mode-map "\C-c\C-c") - (define-key ada-mode-map "\C-c\C-c" 'compile)) - - ;; Casing - (define-key ada-mode-map "\C-c\C-b" 'ada-adjust-case-buffer) - (define-key ada-mode-map "\C-c\C-t" 'ada-case-read-exceptions) - (define-key ada-mode-map "\C-c\C-y" 'ada-create-case-exception) - (define-key ada-mode-map "\C-c\C-\M-y" 'ada-create-case-exception-substring) - - ;; On XEmacs, you can easily specify whether DEL should deletes - ;; one character forward or one character backward. Take this into - ;; account - (define-key ada-mode-map - (if (boundp 'delete-key-deletes-forward) [backspace] "\177") - 'backward-delete-char-untabify) - - ;; Make body - (define-key ada-mode-map "\C-c\C-n" 'ada-make-subprogram-body) - - ;; Use predefined function of Emacs19 for comments (RE) - ;; FIXME: Made redundant with Emacs-21's standard comment-dwim binding on M-; - (define-key ada-mode-map "\C-c;" 'comment-region) - (define-key ada-mode-map "\C-c:" 'ada-uncomment-region) - - ;; The following keys are bound to functions defined in ada-xref.el or - ;; ada-prj,el., However, RMS rightly thinks that the code should be shared, - ;; and activated only if the right compiler is used - - (define-key ada-mode-map (if (featurep 'xemacs) '(shift button3) [S-mouse-3]) - 'ada-point-and-xref) - (define-key ada-mode-map [(control tab)] 'ada-complete-identifier) - - (define-key ada-mode-extra-map "o" 'ff-find-other-file) - (define-key ada-mode-map "\C-c5\C-d" 'ada-goto-declaration-other-frame) - (define-key ada-mode-map "\C-c\C-d" 'ada-goto-declaration) - (define-key ada-mode-map "\C-c\C-s" 'ada-xref-goto-previous-reference) - (define-key ada-mode-map "\C-c\C-c" 'ada-compile-application) - (define-key ada-mode-extra-map "c" 'ada-change-prj) - (define-key ada-mode-extra-map "d" 'ada-set-default-project-file) - (define-key ada-mode-extra-map "g" 'ada-gdb-application) - (define-key ada-mode-map "\C-c\C-m" 'ada-set-main-compile-application) - (define-key ada-mode-extra-map "r" 'ada-run-application) - (define-key ada-mode-map "\C-c\C-o" 'ada-goto-parent) - (define-key ada-mode-map "\C-c\C-r" 'ada-find-references) - (define-key ada-mode-extra-map "l" 'ada-find-local-references) - (define-key ada-mode-map "\C-c\C-v" 'ada-check-current) - (define-key ada-mode-extra-map "f" 'ada-find-file) - - (define-key ada-mode-extra-map "u" 'ada-prj-edit) - - (define-key ada-mode-map "\C-xnd" 'ada-narrow-to-defun); override narrow-to-defun - - ;; The templates, defined in ada-stmt.el - - (let ((map (make-sparse-keymap))) - (define-key map "h" 'ada-header) - (define-key map "\C-a" 'ada-array) - (define-key map "b" 'ada-exception-block) - (define-key map "d" 'ada-declare-block) - (define-key map "c" 'ada-case) - (define-key map "\C-e" 'ada-elsif) - (define-key map "e" 'ada-else) - (define-key map "\C-k" 'ada-package-spec) - (define-key map "k" 'ada-package-body) - (define-key map "\C-p" 'ada-procedure-spec) - (define-key map "p" 'ada-subprogram-body) - (define-key map "\C-f" 'ada-function-spec) - (define-key map "f" 'ada-for-loop) - (define-key map "i" 'ada-if) - (define-key map "l" 'ada-loop) - (define-key map "\C-r" 'ada-record) - (define-key map "\C-s" 'ada-subtype) - (define-key map "S" 'ada-tabsize) - (define-key map "\C-t" 'ada-task-spec) - (define-key map "t" 'ada-task-body) - (define-key map "\C-y" 'ada-type) - (define-key map "\C-v" 'ada-private) - (define-key map "u" 'ada-use) - (define-key map "\C-u" 'ada-with) - (define-key map "\C-w" 'ada-when) - (define-key map "w" 'ada-while-loop) - (define-key map "\C-x" 'ada-exception) - (define-key map "x" 'ada-exit) - (define-key ada-mode-extra-map "t" map)) - ) - - -(defun ada-create-menu () - "Create the Ada menu as shown in the menu bar." - (let ((m '("Ada" - ("Help" - ["Ada Mode" (info "ada-mode") t] - ["GNAT User's Guide" (info "gnat_ugn") - (eq ada-which-compiler 'gnat)] - ["GNAT Reference Manual" (info "gnat_rm") - (eq ada-which-compiler 'gnat)] - ["Gcc Documentation" (info "gcc") - (eq ada-which-compiler 'gnat)] - ["Gdb Documentation" (info "gdb") - (eq ada-which-compiler 'gnat)] - ["Ada95 Reference Manual" (info "arm95") t]) - ("Options" :included (derived-mode-p 'ada-mode) - ["Auto Casing" (setq ada-auto-case (not ada-auto-case)) - :style toggle :selected ada-auto-case] - ["Auto Indent After Return" - (setq ada-indent-after-return (not ada-indent-after-return)) - :style toggle :selected ada-indent-after-return] - ["Automatically Recompile For Cross-references" - (setq ada-xref-create-ali (not ada-xref-create-ali)) - :style toggle :selected ada-xref-create-ali - :included (eq ada-which-compiler 'gnat)] - ["Confirm Commands" - (setq ada-xref-confirm-compile (not ada-xref-confirm-compile)) - :style toggle :selected ada-xref-confirm-compile - :included (eq ada-which-compiler 'gnat)] - ["Show Cross-references In Other Buffer" - (setq ada-xref-other-buffer (not ada-xref-other-buffer)) - :style toggle :selected ada-xref-other-buffer - :included (eq ada-which-compiler 'gnat)] - ["Tight Integration With GNU Visual Debugger" - (setq ada-tight-gvd-integration (not ada-tight-gvd-integration)) - :style toggle :selected ada-tight-gvd-integration - :included (string-match "gvd" ada-prj-default-debugger)]) - ["Customize" (customize-group 'ada) - :included (fboundp 'customize-group)] - ["Check file" ada-check-current t] - ["Compile file" ada-compile-current t] - ["Set main and Build" ada-set-main-compile-application t] - ["Show main" ada-show-current-main t] - ["Build" ada-compile-application t] - ["Run" ada-run-application t] - ["Debug" ada-gdb-application (eq ada-which-compiler 'gnat)] - ["------" nil nil] - ("Project" - ["Show project" ada-show-current-project t] - ["Load..." ada-set-default-project-file t] - ["New..." ada-prj-new t] - ["Edit..." ada-prj-edit t]) - ("Goto" :included (derived-mode-p 'ada-mode) - ["Goto Declaration/Body" ada-goto-declaration - (eq ada-which-compiler 'gnat)] - ["Goto Body" ada-goto-body - (eq ada-which-compiler 'gnat)] - ["Goto Declaration Other Frame" - ada-goto-declaration-other-frame - (eq ada-which-compiler 'gnat)] - ["Goto Previous Reference" ada-xref-goto-previous-reference - (eq ada-which-compiler 'gnat)] - ["List Local References" ada-find-local-references - (eq ada-which-compiler 'gnat)] - ["List References" ada-find-references - (eq ada-which-compiler 'gnat)] - ["Goto Reference To Any Entity" ada-find-any-references - (eq ada-which-compiler 'gnat)] - ["Goto Parent Unit" ada-goto-parent - (eq ada-which-compiler 'gnat)] - ["--" nil nil] - ["Next compilation error" next-error t] - ["Previous Package" ada-previous-package t] - ["Next Package" ada-next-package t] - ["Previous Procedure" ada-previous-procedure t] - ["Next Procedure" ada-next-procedure t] - ["Goto Start Of Statement" ada-move-to-start t] - ["Goto End Of Statement" ada-move-to-end t] - ["-" nil nil] - ["Other File" ff-find-other-file t] - ["Other File Other Window" ada-ff-other-window t]) - ("Edit" :included (derived-mode-p 'ada-mode) - ["Search File On Source Path" ada-find-file t] - ["------" nil nil] - ["Complete Identifier" ada-complete-identifier t] - ["-----" nil nil] - ["Indent Line" ada-indent-current-function t] - ["Justify Current Indentation" ada-justified-indent-current t] - ["Indent Lines in Selection" ada-indent-region t] - ["Indent Lines in File" - (ada-indent-region (point-min) (point-max)) t] - ["Format Parameter List" ada-format-paramlist t] - ["-" nil nil] - ["Comment Selection" comment-region t] - ["Uncomment Selection" ada-uncomment-region t] - ["--" nil nil] - ["Fill Comment Paragraph" fill-paragraph t] - ["Fill Comment Paragraph Justify" - ada-fill-comment-paragraph-justify t] - ["Fill Comment Paragraph Postfix" - ada-fill-comment-paragraph-postfix t] - ["---" nil nil] - ["Adjust Case Selection" ada-adjust-case-region t] - ["Adjust Case in File" ada-adjust-case-buffer t] - ["Create Case Exception" ada-create-case-exception t] - ["Create Case Exception Substring" - ada-create-case-exception-substring t] - ["Reload Case Exceptions" ada-case-read-exceptions t] - ["----" nil nil] - ["Make body for subprogram" ada-make-subprogram-body t] - ["-----" nil nil] - ["Narrow to subprogram" ada-narrow-to-defun t]) - ("Templates" - :included (derived-mode-p 'ada-mode) - ["Header" ada-header t] - ["-" nil nil] - ["Package Body" ada-package-body t] - ["Package Spec" ada-package-spec t] - ["Function Spec" ada-function-spec t] - ["Procedure Spec" ada-procedure-spec t] - ["Proc/func Body" ada-subprogram-body t] - ["Task Body" ada-task-body t] - ["Task Spec" ada-task-spec t] - ["Declare Block" ada-declare-block t] - ["Exception Block" ada-exception-block t] - ["--" nil nil] - ["Entry" ada-entry t] - ["Entry family" ada-entry-family t] - ["Select" ada-select t] - ["Accept" ada-accept t] - ["Or accept" ada-or-accept t] - ["Or delay" ada-or-delay t] - ["Or terminate" ada-or-terminate t] - ["---" nil nil] - ["Type" ada-type t] - ["Private" ada-private t] - ["Subtype" ada-subtype t] - ["Record" ada-record t] - ["Array" ada-array t] - ["----" nil nil] - ["If" ada-if t] - ["Else" ada-else t] - ["Elsif" ada-elsif t] - ["Case" ada-case t] - ["-----" nil nil] - ["While Loop" ada-while-loop t] - ["For Loop" ada-for-loop t] - ["Loop" ada-loop t] - ["------" nil nil] - ["Exception" ada-exception t] - ["Exit" ada-exit t] - ["When" ada-when t]) - ))) - - (easy-menu-define ada-mode-menu ada-mode-map "Menu keymap for Ada mode" m) - (if (featurep 'xemacs) - (progn - (define-key ada-mode-map [menu-bar] ada-mode-menu) - (setq mode-popup-menu (cons "Ada mode" ada-mode-menu)))))) - - -;; ------------------------------------------------------- -;; Commenting/Uncommenting code -;; The following two calls are provided to enhance the standard -;; comment-region function, which only allows uncommenting if the -;; comment is at the beginning of a line. If the line have been re-indented, -;; we are unable to use comment-region, which makes no sense. -;; -;; In addition, we provide an interface to the standard comment handling -;; function for justifying the comments. -;; ------------------------------------------------------- - -(when (or (<= emacs-major-version 20) (featurep 'xemacs)) - (defadvice comment-region (before ada-uncomment-anywhere disable) - (if (and (consp arg) ;; a prefix with \C-u is of the form '(4), whereas - ;; \C-u 2 sets arg to '2' (fixed by S.Leake) - (derived-mode-p 'ada-mode)) - (save-excursion - (let ((cs (concat "^[ \t]*" (regexp-quote comment-start)))) - (goto-char beg) - (while (re-search-forward cs end t) - (replace-match comment-start)) - ))))) - -(defun ada-uncomment-region (beg end &optional arg) - "Uncomment region BEG .. END. -ARG gives number of comment characters." - (interactive "r\nP") - - ;; This advice is not needed anymore with Emacs21. However, for older - ;; versions, as well as for XEmacs, we still need to enable it. - (if (or (<= emacs-major-version 20) (featurep 'xemacs)) - (progn - (ad-activate 'comment-region) - (comment-region beg end (- (or arg 2))) - (ad-deactivate 'comment-region)) - (comment-region beg end (list (- (or arg 2)))) - (ada-indent-region beg end))) - -(defun ada-fill-comment-paragraph-justify () - "Fill current comment paragraph and justify each line as well." - (interactive) - (ada-fill-comment-paragraph 'full)) - -(defun ada-fill-comment-paragraph-postfix () - "Fill current comment paragraph and justify each line as well. -Adds `ada-fill-comment-postfix' at the end of each line." - (interactive) - (ada-fill-comment-paragraph 'full t)) - -(defun ada-fill-comment-paragraph (&optional justify postfix) - "Fill the current comment paragraph. -If JUSTIFY is non-nil, each line is justified as well. -If POSTFIX and JUSTIFY are non-nil, `ada-fill-comment-postfix' is appended -to each line filled and justified. -The paragraph is indented on the first line." - (interactive "P") - - ;; check if inside comment or just in front a comment - (if (and (not (ada-in-comment-p)) - (not (looking-at "[ \t]*--"))) - (error "Not inside comment")) - - (let* (indent from to - (opos (point-marker)) - - ;; Sets this variable to nil, otherwise it prevents - ;; fill-region-as-paragraph to work on Emacs <= 20.2 - (parse-sexp-lookup-properties nil) - - fill-prefix - (fill-column (current-fill-column))) - - ;; Find end of paragraph - (back-to-indentation) - (while (and (not (eobp)) (looking-at ".*--[ \t]*[^ \t\n]")) - (forward-line 1) - - ;; If we were at the last line in the buffer, create a dummy empty - ;; line at the end of the buffer. - (if (eobp) - (insert "\n") - (back-to-indentation))) - (beginning-of-line) - (setq to (point-marker)) - (goto-char opos) - - ;; Find beginning of paragraph - (back-to-indentation) - (while (and (not (bobp)) (looking-at ".*--[ \t]*[^ \t\n]")) - (forward-line -1) - (back-to-indentation)) - - ;; We want one line above the first one, unless we are at the beginning - ;; of the buffer - (unless (bobp) - (forward-line 1)) - (beginning-of-line) - (setq from (point-marker)) - - ;; Calculate the indentation we will need for the paragraph - (back-to-indentation) - (setq indent (current-column)) - ;; unindent the first line of the paragraph - (delete-region from (point)) - - ;; Remove the old postfixes - (goto-char from) - (while (re-search-forward "--\n" to t) - (replace-match "\n")) - - (goto-char (1- to)) - (setq to (point-marker)) - - ;; Indent and justify the paragraph - (setq fill-prefix ada-fill-comment-prefix) - (set-left-margin from to indent) - (if postfix - (setq fill-column (- fill-column (length ada-fill-comment-postfix)))) - - (fill-region-as-paragraph from to justify) - - ;; Add the postfixes if required - (if postfix - (save-restriction - (goto-char from) - (narrow-to-region from to) - (while (not (eobp)) - (end-of-line) - (insert-char ? (- fill-column (current-column))) - (insert ada-fill-comment-postfix) - (forward-line)) - )) - - ;; In Emacs <= 20.2 and XEmacs <=20.4, there is a bug, and a newline is - ;; inserted at the end. Delete it - (if (or (featurep 'xemacs) - (<= emacs-major-version 19) - (and (= emacs-major-version 20) - (<= emacs-minor-version 2))) - (progn - (goto-char to) - (end-of-line) - (delete-char 1))) - - (goto-char opos))) - - -;; --------------------------------------------------- -;; support for find-file.el -;; These functions are used by find-file to guess the file names from -;; unit names, and to find the other file (spec or body) from the current -;; file (body or spec). -;; It is also used to find in which function we are, so as to put the -;; cursor at the correct position. -;; Standard Ada does not force any relation between unit names and file names, -;; so some of these functions can only be a good approximation. However, they -;; are also overridden in `ada-xref'.el when we know that the user is using -;; GNAT. -;; --------------------------------------------------- - -;; Overridden when we work with GNAT, to use gnatkrunch -(defun ada-make-filename-from-adaname (adaname) - "Determine the filename in which ADANAME is found. -This matches the GNAT default naming convention, except for -pre-defined units." - (while (string-match "\\." adaname) - (setq adaname (replace-match "-" t t adaname))) - (downcase adaname) - ) - -(defun ada-other-file-name () - "Return the name of the other file. -The name returned is the body if `current-buffer' is the spec, -or the spec otherwise." - - (let ((is-spec nil) - (is-body nil) - (suffixes ada-spec-suffixes) - (name (buffer-file-name))) - - ;; Guess whether we have a spec or a body, and get the basename of the - ;; file. Since the extension may not start with '.', we can not use - ;; file-name-extension - (while (and (not is-spec) - suffixes) - (if (string-match (concat "\\(.*\\)" (car suffixes) "$") name) - (setq is-spec t - name (match-string 1 name))) - (setq suffixes (cdr suffixes))) - - (if (not is-spec) - (progn - (setq suffixes ada-body-suffixes) - (while (and (not is-body) - suffixes) - (if (string-match (concat "\\(.*\\)" (car suffixes) "$") name) - (setq is-body t - name (match-string 1 name))) - (setq suffixes (cdr suffixes))))) - - ;; If this wasn't in either list, return name itself - (if (not (or is-spec is-body)) - name - - ;; Else find the other possible names - (if is-spec - (setq suffixes ada-body-suffixes) - (setq suffixes ada-spec-suffixes)) - (setq is-spec name) - - (while suffixes - - ;; If we are using project file, search for the other file in all - ;; the possible src directories. - - (if (fboundp 'ada-find-src-file-in-dir) - (let ((other - (ada-find-src-file-in-dir - (file-name-nondirectory (concat name (car suffixes)))))) - (if other - (setq is-spec other))) - - ;; Else search in the current directory - (if (file-exists-p (concat name (car suffixes))) - (setq is-spec (concat name (car suffixes))))) - (setq suffixes (cdr suffixes))) - - is-spec))) - -(defun ada-which-function-are-we-in () - "Return the name of the function whose definition/declaration point is in. -Used in `ff-pre-load-hook'." - (setq ff-function-name nil) - (save-excursion - (end-of-line);; make sure we get the complete name - (or (if (re-search-backward ada-procedure-start-regexp nil t) - (setq ff-function-name (match-string 5))) - (if (re-search-backward ada-package-start-regexp nil t) - (setq ff-function-name (match-string 4)))) - )) - - -(defvar ada-last-which-function-line -1 - "Last line on which `ada-which-function' was called.") -(defvar ada-last-which-function-subprog 0 - "Last subprogram name returned by `ada-which-function'.") -(make-variable-buffer-local 'ada-last-which-function-subprog) -(make-variable-buffer-local 'ada-last-which-function-line) - - -(defun ada-which-function () - "Return the name of the function whose body the point is in. -This function works even in the case of nested subprograms, whereas the -standard Emacs function `which-function' does not. -Since the search can be long, the results are cached." - - (let ((line (count-lines 1 (point))) - (pos (point)) - end-pos - func-name indent - found) - - ;; If this is the same line as before, simply return the same result - (if (= line ada-last-which-function-line) - ada-last-which-function-subprog - - (save-excursion - ;; In case the current line is also the beginning of the body - (end-of-line) - - ;; Are we looking at "function Foo\n (paramlist)" - (skip-chars-forward " \t\n(") - - (condition-case nil - (up-list 1) - (error nil)) - - (skip-chars-forward " \t\n") - (if (looking-at "return") - (progn - (forward-word-strictly 1) - (skip-chars-forward " \t\n") - (skip-chars-forward "a-zA-Z0-9_'"))) - - ;; Can't simply do forward-word, in case the "is" is not on the - ;; same line as the closing parenthesis - (skip-chars-forward "is \t\n") - - ;; No look for the closest subprogram body that has not ended yet. - ;; Not that we expect all the bodies to be finished by "end ", - ;; or a simple "end;" indented in the same column as the start of - ;; the subprogram. The goal is to be as efficient as possible. - - (while (and (not found) - (re-search-backward ada-imenu-subprogram-menu-re nil t)) - - ;; Get the function name, but not the properties, or this changes - ;; the face in the mode line on Emacs 21 - (setq func-name (match-string-no-properties 3)) - (if (and (not (ada-in-comment-p)) - (not (save-excursion - (goto-char (match-end 0)) - (looking-at "[ \t\n]*new")))) - (save-excursion - (back-to-indentation) - (setq indent (current-column)) - (if (ada-search-ignore-string-comment - (concat "end[ \t]+" func-name "[ \t]*;\\|^" - (make-string indent ? ) "end;")) - (setq end-pos (point)) - (setq end-pos (point-max))) - (if (>= end-pos pos) - (setq found func-name)))) - ) - (setq ada-last-which-function-line line - ada-last-which-function-subprog found) - found)))) - -(defun ada-ff-other-window () - "Find other file in other window using `ff-find-other-file'." - (interactive) - (and (fboundp 'ff-find-other-file) - (ff-find-other-file t))) - -(defun ada-set-point-accordingly () - "Move to the function declaration that was set by `ff-which-function-are-we-in'." - (if ff-function-name - (progn - (goto-char (point-min)) - (unless (ada-search-ignore-string-comment - (concat ff-function-name "\\b") nil) - (goto-char (point-min)))))) - -(defun ada-get-body-name (&optional spec-name) - "Return the file name for the body of SPEC-NAME. -If SPEC-NAME is nil, return the body for the current package. -Return nil if no body was found." - (interactive) - - (unless spec-name (setq spec-name (buffer-file-name))) - - ;; Remove the spec extension. We can not simply remove the file extension, - ;; but we need to take into account the specific non-GNAT extensions that the - ;; user might have specified. - - (let ((suffixes ada-spec-suffixes) - end) - (while suffixes - (setq end (- (length spec-name) (length (car suffixes)))) - (if (string-equal (car suffixes) (substring spec-name end)) - (setq spec-name (substring spec-name 0 end))) - (setq suffixes (cdr suffixes)))) - - ;; If find-file.el was available, use its functions - (if (fboundp 'ff-get-file-name) - (ff-get-file-name ada-search-directories-internal - (ada-make-filename-from-adaname - (file-name-nondirectory - (file-name-sans-extension spec-name))) - ada-body-suffixes) - ;; Else emulate it very simply - (concat (ada-make-filename-from-adaname - (file-name-nondirectory - (file-name-sans-extension spec-name))) - ".adb"))) - - -;; --------------------------------------------------- -;; support for font-lock.el -;; Strings are a real pain in Ada because a single quote character is -;; overloaded as a string quote and type/instance delimiter. By default, a -;; single quote is given punctuation syntax in `ada-mode-syntax-table'. -;; So, for Font Lock mode purposes, we mark single quotes as having string -;; syntax when the gods that created Ada determine them to be. -;; -;; This only works in Emacs. See the comments before the grammar functions -;; at the beginning of this file for how this is done with XEmacs. -;; ---------------------------------------------------- - -(defconst ada-font-lock-syntactic-keywords - ;; Mark single quotes as having string quote syntax in 'c' instances. - ;; We used to explicitly avoid ''' as a special case for fear the buffer - ;; be highlighted as a string, but it seems this fear is unfounded. - ;; - ;; This sets the properties of the characters, so that ada-in-string-p - ;; correctly handles '"' too... - '(("[^a-zA-Z0-9)]\\('\\)[^\n]\\('\\)" (1 (7 . ?')) (2 (7 . ?'))) - ("^[ \t]*\\(#\\(if\\|else\\|elsif\\|end\\)\\)" (1 (11 . ?\n))))) - -(defvar ada-font-lock-keywords - (eval-when-compile - (list - ;; - ;; handle "type T is access function return S;" - (list "\\<\\(function[ \t]+return\\)\\>" '(1 font-lock-keyword-face) ) - - ;; preprocessor line - (list "^[ \t]*\\(#.*\n\\)" '(1 font-lock-type-face t)) - - ;; - ;; accept, entry, function, package (body), protected (body|type), - ;; pragma, procedure, task (body) plus name. - (list (concat - "\\<\\(" - "accept\\|" - "entry\\|" - "function\\|" - "package[ \t]+body\\|" - "package\\|" - "pragma\\|" - "procedure\\|" - "protected[ \t]+body\\|" - "protected[ \t]+type\\|" - "protected\\|" - "task[ \t]+body\\|" - "task[ \t]+type\\|" - "task" - "\\)\\>[ \t]*" - "\\(\\sw+\\(\\.\\sw*\\)*\\)?") - '(1 font-lock-keyword-face) '(2 font-lock-function-name-face nil t)) - ;; - ;; Optional keywords followed by a type name. - (list (concat ; ":[ \t]*" - "\\<\\(access[ \t]+all\\|access[ \t]+constant\\|access\\|constant\\|in[ \t]+reverse\\|\\|in[ \t]+out\\|in\\|out\\)\\>" - "[ \t]*" - "\\(\\sw+\\(\\.\\sw*\\)*\\)?") - '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t)) - - ;; - ;; Main keywords, except those treated specially below. - (concat "\\<" - (regexp-opt - '("abort" "abs" "abstract" "accept" "access" "aliased" "all" - "and" "array" "at" "begin" "case" "declare" "delay" "delta" - "digits" "do" "else" "elsif" "entry" "exception" "exit" "for" - "generic" "if" "in" "interface" "is" "limited" "loop" "mod" "not" - "null" "or" "others" "overriding" "private" "protected" "raise" - "range" "record" "rem" "renames" "requeue" "return" "reverse" - "select" "separate" "synchronized" "tagged" "task" "terminate" - "then" "until" "when" "while" "with" "xor") t) - "\\>") - ;; - ;; Anything following end and not already fontified is a body name. - '("\\<\\(end\\)\\>\\([ \t]+\\)?\\(\\(\\sw\\|[_.]\\)+\\)?" - (1 font-lock-keyword-face) (3 font-lock-function-name-face nil t)) - ;; - ;; Keywords followed by a type or function name. - (list (concat "\\<\\(" - "new\\|of\\|subtype\\|type" - "\\)\\>[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?[ \t]*\\((\\)?") - '(1 font-lock-keyword-face) - '(2 (if (match-beginning 4) - font-lock-function-name-face - font-lock-type-face) nil t)) - ;; - ;; Keywords followed by a (comma separated list of) reference. - ;; Note that font-lock only works on single lines, thus we can not - ;; correctly highlight a with_clause that spans multiple lines. - (list (concat "\\<\\(goto\\|raise\\|use\\|with\\)" - "[ \t]+\\([a-zA-Z0-9_., \t]+\\)\\W") - '(1 font-lock-keyword-face) '(2 font-lock-constant-face nil t)) - - ;; - ;; Goto tags. - '("<<\\(\\sw+\\)>>" 1 font-lock-constant-face) - - ;; Highlight based-numbers (R. Reagan ) - (list "\\([0-9]+#[[:xdigit:]_]+#\\)" '(1 font-lock-constant-face t)) - - ;; Ada unnamed numerical constants - (list "\\W\\([-+]?[0-9._]+\\)\\>" '(1 font-lock-constant-face)) - - )) - "Default expressions to highlight in Ada mode.") - - -;; --------------------------------------------------------- -;; Support for outline.el -;; --------------------------------------------------------- - -(defun ada-outline-level () - "This is so that `current-column' DTRT in otherwise-hidden text." - ;; patch from Dave Love - (let (buffer-invisibility-spec) - (save-excursion - (back-to-indentation) - (current-column)))) - -;; --------------------------------------------------------- -;; Support for narrow-to-region -;; --------------------------------------------------------- - -(defun ada-narrow-to-defun (&optional _arg) - "Make text outside current subprogram invisible. -The subprogram visible is the one that contains or follow point. -Optional ARG is ignored. -Use \\[widen] to go back to the full visibility for the buffer." - - (interactive) - (save-excursion - (let (end) - (widen) - (forward-line 1) - (ada-previous-procedure) - (setq end (point-at-bol)) - (ada-move-to-end) - (end-of-line) - (narrow-to-region end (point)) - (message - "Use M-x widen to get back to full visibility in the buffer")))) - -;; --------------------------------------------------------- -;; Automatic generation of code -;; The Ada mode has a set of function to automatically generate a subprogram -;; or package body from its spec. -;; These function only use a primary and basic algorithm, this could use a -;; lot of improvement. -;; When the user is using GNAT, we rather use gnatstub to generate an accurate -;; body. -;; ---------------------------------------------------------- - -(defun ada-gen-treat-proc (match) - "Make dummy body of a procedure/function specification. -MATCH is a cons cell containing the start and end locations of the last search -for `ada-procedure-start-regexp'." - (goto-char (car match)) - (let (func-found procname functype) - (cond - ((or (looking-at "^[ \t]*procedure") - (setq func-found (looking-at "^[ \t]*function"))) - ;; treat it as a proc/func - (forward-word-strictly 2) - (forward-word-strictly -1) - (setq procname (buffer-substring (point) (cdr match))) ; store proc name - - ;; goto end of procname - (goto-char (cdr match)) - - ;; skip over parameterlist - (unless (looking-at "[ \t\n]*\\(;\\|return\\)") - (forward-sexp)) - - ;; if function, skip over 'return' and result type. - (if func-found - (progn - (forward-word-strictly 1) - (skip-chars-forward " \t\n") - (setq functype (buffer-substring (point) - (progn - (skip-chars-forward - "a-zA-Z0-9_.") - (point)))))) - ;; look for next non WS - (cond - ((looking-at "[ \t]*;") - (delete-region (match-beginning 0) (match-end 0));; delete the ';' - (ada-indent-newline-indent) - (insert "is") - (ada-indent-newline-indent) - (if func-found - (progn - (insert "Result : " functype ";") - (ada-indent-newline-indent))) - (insert "begin") - (ada-indent-newline-indent) - (if func-found - (insert "return Result;") - (insert "null;")) - (ada-indent-newline-indent) - (insert "end " procname ";") - (ada-indent-newline-indent) - ) - - ((looking-at "[ \t\n]*is") - ;; do nothing - ) - - ((looking-at "[ \t\n]*rename") - ;; do nothing - ) - - (t - (message "unknown syntax")))) - (t - (if (looking-at "^[ \t]*task") - (progn - (message "Task conversion is not yet implemented") - (forward-word-strictly 2) - (if (looking-at "[ \t]*;") - (forward-line) - (ada-move-to-end)) - )))))) - -(defun ada-make-body () - "Create an Ada package body in the current buffer. -The spec must be the previously visited buffer. -This function typically is to be hooked into `ff-file-created-hook'." - (delete-region (point-min) (point-max)) - (insert-buffer-substring (car (cdr (buffer-list)))) - (goto-char (point-min)) - (ada-mode) - - (let (found ada-procedure-or-package-start-regexp) - (if (setq found - (ada-search-ignore-string-comment ada-package-start-regexp nil)) - (progn (goto-char (cdr found)) - (insert " body") - ) - (error "No package")) - - (setq ada-procedure-or-package-start-regexp - (concat ada-procedure-start-regexp - "\\|" - ada-package-start-regexp)) - - (while (setq found - (ada-search-ignore-string-comment - ada-procedure-or-package-start-regexp nil)) - (progn - (goto-char (car found)) - (if (looking-at ada-package-start-regexp) - (progn (goto-char (cdr found)) - (insert " body")) - (ada-gen-treat-proc found)))))) - - -(defun ada-make-subprogram-body () - "Create a dummy subprogram body in package body file from spec surrounding point." - (interactive) - (let* ((found (re-search-backward ada-procedure-start-regexp nil t)) - (spec (match-beginning 0)) - body-file) - (if found - (progn - (goto-char spec) - (if (and (re-search-forward "(\\|;" nil t) - (= (char-before) ?\()) - (progn - (ada-search-ignore-string-comment ")" nil) - (ada-search-ignore-string-comment ";" nil))) - (setq spec (buffer-substring spec (point))) - - ;; If find-file.el was available, use its functions - (setq body-file (ada-get-body-name)) - (if body-file - (find-file body-file) - (error "No body found for the package. Create it first")) - - (save-restriction - (widen) - (goto-char (point-max)) - (forward-comment -10000) - (re-search-backward "\\" nil t) - ;; Move to the beginning of the elaboration part, if any - (re-search-backward "^begin" nil t) - (newline) - (forward-char -1) - (insert spec) - (re-search-backward ada-procedure-start-regexp nil t) - (ada-gen-treat-proc (cons (match-beginning 0) (match-end 0))) - )) - (error "Not in subprogram spec")))) - -;; -------------------------------------------------------- -;; Global initializations -;; -------------------------------------------------------- - -;; Create the keymap once and for all. If we do that in ada-mode, -;; the keys changed in the user's .emacs have to be modified -;; every time -(ada-create-keymap) -(ada-create-menu) - -;; Add the default extensions (and set up speedbar) -(ada-add-extensions ".ads" ".adb") -;; This two files are generated by GNAT when running with -gnatD -(if (equal ada-which-compiler 'gnat) - (ada-add-extensions ".ads.dg" ".adb.dg")) - -;; Read the special cases for exceptions -(ada-case-read-exceptions) - -;; Setup auto-loading of the other Ada mode files. -(autoload 'ada-change-prj "ada-xref" nil t) -(autoload 'ada-check-current "ada-xref" nil t) -(autoload 'ada-compile-application "ada-xref" nil t) -(autoload 'ada-compile-current "ada-xref" nil t) -(autoload 'ada-complete-identifier "ada-xref" nil t) -(autoload 'ada-find-file "ada-xref" nil t) -(autoload 'ada-find-any-references "ada-xref" nil t) -(autoload 'ada-find-src-file-in-dir "ada-xref" nil t) -(autoload 'ada-find-local-references "ada-xref" nil t) -(autoload 'ada-find-references "ada-xref" nil t) -(autoload 'ada-gdb-application "ada-xref" nil t) -(autoload 'ada-goto-declaration "ada-xref" nil t) -(autoload 'ada-goto-declaration-other-frame "ada-xref" nil t) -(autoload 'ada-goto-parent "ada-xref" nil t) -(autoload 'ada-make-body-gnatstub "ada-xref" nil t) -(autoload 'ada-point-and-xref "ada-xref" nil t) -(autoload 'ada-reread-prj-file "ada-xref" nil t) -(autoload 'ada-run-application "ada-xref" nil t) -(autoload 'ada-set-default-project-file "ada-xref" nil t) -(autoload 'ada-xref-goto-previous-reference "ada-xref" nil t) -(autoload 'ada-set-main-compile-application "ada-xref" nil t) -(autoload 'ada-show-current-main "ada-xref" nil t) - -(autoload 'ada-customize "ada-prj" nil t) -(autoload 'ada-prj-edit "ada-prj" nil t) -(autoload 'ada-prj-new "ada-prj" nil t) -(autoload 'ada-prj-save "ada-prj" nil t) - -(autoload 'ada-array "ada-stmt" nil t) -(autoload 'ada-case "ada-stmt" nil t) -(autoload 'ada-declare-block "ada-stmt" nil t) -(autoload 'ada-else "ada-stmt" nil t) -(autoload 'ada-elsif "ada-stmt" nil t) -(autoload 'ada-exception "ada-stmt" nil t) -(autoload 'ada-exception-block "ada-stmt" nil t) -(autoload 'ada-exit "ada-stmt" nil t) -(autoload 'ada-for-loop "ada-stmt" nil t) -(autoload 'ada-function-spec "ada-stmt" nil t) -(autoload 'ada-header "ada-stmt" nil t) -(autoload 'ada-if "ada-stmt" nil t) -(autoload 'ada-loop "ada-stmt" nil t) -(autoload 'ada-package-body "ada-stmt" nil t) -(autoload 'ada-package-spec "ada-stmt" nil t) -(autoload 'ada-private "ada-stmt" nil t) -(autoload 'ada-procedure-spec "ada-stmt" nil t) -(autoload 'ada-record "ada-stmt" nil t) -(autoload 'ada-subprogram-body "ada-stmt" nil t) -(autoload 'ada-subtype "ada-stmt" nil t) -(autoload 'ada-tabsize "ada-stmt" nil t) -(autoload 'ada-task-body "ada-stmt" nil t) -(autoload 'ada-task-spec "ada-stmt" nil t) -(autoload 'ada-type "ada-stmt" nil t) -(autoload 'ada-use "ada-stmt" nil t) -(autoload 'ada-when "ada-stmt" nil t) -(autoload 'ada-while-loop "ada-stmt" nil t) -(autoload 'ada-with "ada-stmt" nil t) - -;;; provide ourselves -(provide 'ada-mode) - -;;; ada-mode.el ends here diff --git a/lisp/progmodes/ada-prj.el b/lisp/progmodes/ada-prj.el deleted file mode 100644 index d9fa77cb0e..0000000000 --- a/lisp/progmodes/ada-prj.el +++ /dev/null @@ -1,682 +0,0 @@ -;;; ada-prj.el --- GUI editing of project files for the ada-mode - -;; Copyright (C) 1998-2019 Free Software Foundation, Inc. - -;; Author: Emmanuel Briot -;; Maintainer: Stephen Leake -;; Keywords: languages, ada, project file -;; Package: ada-mode - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Commentary: - -;; This package provides a set of functions to easily edit the project -;; files used by the ada-mode. -;; The only function publicly available here is `ada-customize'. -;; See the documentation of the Ada mode for more information on the project -;; files. -;; Internally, a project file is represented as a property list, with each -;; field of the project file matching one property of the list. - -;;; Code: - - -;; ----- Requirements ----------------------------------------------------- - -(require 'cus-edit) -(require 'ada-xref) - -(eval-when-compile - (require 'ada-mode)) -(eval-when-compile (require 'cl-lib)) - -;; ----- Buffer local variables ------------------------------------------- - -(defvar ada-prj-current-values nil - "Hold the current value of the fields, This is a property list.") -(make-variable-buffer-local 'ada-prj-current-values) - -(defvar ada-prj-default-values nil - "Hold the default value for the fields, This is a property list.") -(make-variable-buffer-local 'ada-prj-default-values) - -(defvar ada-prj-ada-buffer nil - "Indicates what Ada source file was being edited.") - -(defvar ada-old-cross-prefix nil - "The cross-prefix associated with the currently loaded runtime library.") - - -;; ----- Functions -------------------------------------------------------- - -(defun ada-prj-new () - "Open a new project file." - (interactive) - (let* ((prj - (if (and ada-prj-default-project-file - (not (string= ada-prj-default-project-file ""))) - ada-prj-default-project-file - "default.adp")) - (filename (read-file-name "Project file: " - (if prj "" nil) - nil - nil - prj))) - (if (not (string= (file-name-extension filename t) ".adp")) - (error "File name extension for project files must be .adp")) - - (ada-customize nil filename))) - -(defun ada-prj-edit () - "Editing the project file associated with the current Ada buffer. -If there is none, opens a new project file." - (interactive) - (if ada-prj-default-project-file - (ada-customize) - (ada-prj-new))) - -(defun ada-prj-initialize-values (symbol _ada-buffer filename) - "Set SYMBOL to the property list of the project file FILENAME. -If FILENAME is null, read the file associated with ADA-BUFFER. -If no project file is found, return the default values." -;; FIXME: rationalize arguments; make ada-buffer optional? - (if (and filename - (not (string= filename "")) - (assoc filename ada-xref-project-files)) - (set symbol (copy-sequence (cdr (assoc filename ada-xref-project-files)))) - - ;; Set default values (except for the file name if this was given - ;; in the buffer - (set symbol (ada-default-prj-properties)) - (if (and filename (not (string= filename ""))) - (set symbol (plist-put (eval symbol) 'filename filename))) - )) - - -(defun ada-prj-save-specific-option (field) - "Return the string to print in the project file to save FIELD. -If the current value of FIELD is the default value, return an empty string." - (if (string= (plist-get ada-prj-current-values field) - (plist-get ada-prj-default-values field)) - "" - (concat (symbol-name field) - "=" (plist-get ada-prj-current-values field) "\n"))) - -(defun ada-prj-save () - "Save the edited project file." - (interactive) - (let ((file-name (or (plist-get ada-prj-current-values 'filename) - (read-file-name "Save project as: "))) - output) - (setq output - (concat - - ;; Save the fields that do not depend on the current buffer - ;; only if they are different from the default value - - (ada-prj-save-specific-option 'comp_opt) - (ada-prj-save-specific-option 'bind_opt) - (ada-prj-save-specific-option 'link_opt) - (ada-prj-save-specific-option 'gnatmake_opt) - (ada-prj-save-specific-option 'gnatfind_opt) - (ada-prj-save-specific-option 'cross_prefix) - (ada-prj-save-specific-option 'remote_machine) - (ada-prj-save-specific-option 'debug_cmd) - - ;; Always save the fields that depend on the current buffer - "main=" (plist-get ada-prj-current-values 'main) "\n" - "build_dir=" (plist-get ada-prj-current-values 'build_dir) "\n" - (ada-prj-set-list "check_cmd" - (plist-get ada-prj-current-values 'check_cmd)) "\n" - (ada-prj-set-list "make_cmd" - (plist-get ada-prj-current-values 'make_cmd)) "\n" - (ada-prj-set-list "comp_cmd" - (plist-get ada-prj-current-values 'comp_cmd)) "\n" - (ada-prj-set-list "run_cmd" - (plist-get ada-prj-current-values 'run_cmd)) "\n" - (ada-prj-set-list "src_dir" - (plist-get ada-prj-current-values 'src_dir) - t) "\n" - (ada-prj-set-list "obj_dir" - (plist-get ada-prj-current-values 'obj_dir) - t) "\n" - (ada-prj-set-list "debug_pre_cmd" - (plist-get ada-prj-current-values 'debug_pre_cmd)) - "\n" - (ada-prj-set-list "debug_post_cmd" - (plist-get ada-prj-current-values 'debug_post_cmd)) - "\n" - )) - - (find-file file-name) - (erase-buffer) - (insert output) - (save-buffer) - ;; kill the project buffer - (kill-buffer nil) - - ;; kill the editor buffer - (kill-buffer "*Edit Ada Mode Project*") - - ;; automatically set the new project file as the active one - (setq ada-prj-default-project-file file-name) - - ;; force Emacs to reread the project files - (ada-reread-prj-file file-name) - ) - ) - -(defun ada-prj-load-from-file (symbol) - "Load SYMBOL value from file. -One item per line should be found in the file." - (save-excursion - (let ((file (read-file-name "File name: " nil nil t)) - (buffer (current-buffer)) - line - list) - (find-file file) - (widen) - (goto-char (point-min)) - (while (not (eobp)) - (setq line (buffer-substring-no-properties (point) (point-at-eol))) - (cl-pushnew line list :test #'equal) - (forward-line 1)) - (kill-buffer nil) - (set-buffer buffer) - (setq ada-prj-current-values - (plist-put ada-prj-current-values - symbol - (append (plist-get ada-prj-current-values symbol) - (reverse list))))) - (ada-prj-display-page 2))) - -(defun ada-prj-subdirs-of (dir) - "Return a list of all the subdirectories of DIR, recursively." - (let ((subdirs (directory-files dir t "^[^.].*")) - (dirlist (list dir))) - (while subdirs - (if (file-directory-p (car subdirs)) - (let ((sub (ada-prj-subdirs-of (car subdirs)))) - (if sub - (setq dirlist (append sub dirlist))))) - (setq subdirs (cdr subdirs))) - dirlist)) - -(defun ada-prj-load-directory (field &optional file-name) - "Append to FIELD in the current project the subdirectories of FILE-NAME. -If FILE-NAME is nil, ask the user for the name." - - ;; Do not use an external dialog for this, since it wouldn't allow - ;; the user to select a directory - (let ((use-dialog-box nil)) - (unless file-name - (setq file-name (read-directory-name "Root directory: " nil nil t)))) - - (setq ada-prj-current-values - (plist-put ada-prj-current-values - field - (append (plist-get ada-prj-current-values field) - (reverse (ada-prj-subdirs-of - (expand-file-name file-name)))))) - (ada-prj-display-page 2)) - -(defun ada-prj-display-page (tab-num) - "Display page TAB-NUM in the notebook. -The current buffer must be the project editing buffer." - - (let ((inhibit-read-only t)) - (erase-buffer)) - - ;; Widget support in Emacs 21 requires that we clear the buffer first - (if (and (not (featurep 'xemacs)) (>= emacs-major-version 21)) - (progn - (setq widget-field-new nil - widget-field-list nil) - (mapc (lambda (x) (delete-overlay x)) (car (overlay-lists))) - (mapc (lambda (x) (delete-overlay x)) (cdr (overlay-lists))))) - - ;; Display the tabs - - (widget-insert "\n Project configuration.\n - ___________ ____________ ____________ ____________ ____________\n / ") - (widget-create 'push-button :notify - (lambda (&rest _dummy) (ada-prj-display-page 1)) "General") - (widget-insert " \\ / ") - (widget-create 'push-button :notify - (lambda (&rest _dummy) (ada-prj-display-page 2)) "Paths") - (widget-insert " \\ / ") - (widget-create 'push-button :notify - (lambda (&rest _dummy) (ada-prj-display-page 3)) "Switches") - (widget-insert " \\ / ") - (widget-create 'push-button :notify - (lambda (&rest _dummy) (ada-prj-display-page 4)) "Ada Menu") - (widget-insert " \\ / ") - (widget-create 'push-button :notify - (lambda (&rest _dummy) (ada-prj-display-page 5)) "Debugger") - (widget-insert " \\\n") - - ;; Display the currently selected page - - (cond - - ;; - ;; First page (General) - ;; - ((= tab-num 1) - (widget-insert "/ \\/______________\\/______________\\/______________\\/______________\\\n") - - (widget-insert "Project file name:\n") - (widget-insert (plist-get ada-prj-current-values 'filename)) - (widget-insert "\n\n") - (ada-prj-field 'casing "Casing Exceptions" -"List of files that contain casing exception -dictionaries. All these files contain one -identifier per line, with a special casing. -The first file has the highest priority." - t nil - (mapconcat (lambda(x) - (concat " " x)) - (ada-xref-get-project-field 'casing) - "\n") - ) - (ada-prj-field 'main "Executable file name" -"Name of the executable generated when you -compile your application. This should include -the full directory name, using ${build_dir} if -you wish.") - (ada-prj-field 'build_dir "Build directory" - "Reference directory for relative paths in -src_dir and obj_dir below. This is also the directory -where the compilation is done.") - (ada-prj-field 'remote_machine "Name of the remote machine (if any)" -"If you want to remotely compile, debug and -run your application, specify the name of a -remote machine here. This capability requires -the `rsh' protocol on the remote machine.") - (ada-prj-field 'cross_prefix "Prefix used in for the cross tool chain" -"When working on multiple cross targets, it is -most convenient to specify the prefix of the -tool chain here. For instance, on PowerPc -vxworks, you would enter `powerpc-wrs-vxworks-'. -To use JGNAT, enter `j'.") - ) - - - ;; - ;; Second page (Paths) - ;; - ((= tab-num 2) - (if (not (equal (plist-get ada-prj-current-values 'cross_prefix) - ada-old-cross-prefix)) - (progn - (setq ada-old-cross-prefix - (plist-get ada-prj-current-values 'cross_prefix)) - (ada-initialize-runtime-library ada-old-cross-prefix))) - - - (widget-insert "/_____________\\/ \\/______________\\/______________\\/______________\\\n") - (ada-prj-field 'src_dir "Source directories" -"Enter the list of directories where your Ada -sources can be found. These directories will be -used for the cross-references and for the default -compilation commands. -Note that src_dir includes both the build directory -and the standard runtime." - t t - (mapconcat (lambda(x) - (concat " " x)) - ada-xref-runtime-library-specs-path - "\n") - ) - (widget-insert "\n\n") - - (ada-prj-field 'obj_dir "Object directories" -"Enter the list of directories where the GNAT -library files (ALI files) can be found. These -files are used for cross-references and by the -gnatmake command. -Note that obj_dir includes both the build directory -and the standard runtime." - t t - (mapconcat (lambda(x) - (concat " " x)) - ada-xref-runtime-library-ali-path - "\n") - ) - (widget-insert "\n\n") - ) - - ;; - ;; Third page (Switches) - ;; - ((= tab-num 3) - (widget-insert "/_____________\\/______________\\/ \\/______________\\/______________\\\n") - (ada-prj-field 'comp_opt "Switches for the compiler" -"These switches are used in the default -compilation commands, both for compiling a -single file and rebuilding the whole project") - (ada-prj-field 'bind_opt "Switches for the binder" -"These switches are used in the default build -command and are passed to the binder") - (ada-prj-field 'link_opt "Switches for the linker" -"These switches are used in the default build -command and are passed to the linker") - (ada-prj-field 'gnatmake_opt "Switches for gnatmake" -"These switches are used in the default gnatmake -command.") - (ada-prj-field 'gnatfind_opt "Switches for gnatfind" -"The command gnatfind is run every time the Ada/Goto/List_References menu. -You should for instance add -a if you are working in an environment -where most ALI files are write-protected, since otherwise they get -ignored by gnatfind and you don't see the references within.") - ) - - ;; - ;; Fourth page - ;; - ((= tab-num 4) - (widget-insert "/_____________\\/______________\\/______________\\/ \\/______________\\\n") - (widget-insert -"All the fields below can use variable substitution. The syntax is ${name}, -where name is the name that appears after the Help buttons in this buffer. As -a special case, ${current} is replaced with the name of the file currently -edited, with directory name but no extension, whereas ${full_current} is -replaced with the name of the current file with directory name and -extension.\n") - (widget-insert -"The environment variables ADA_INCLUDE_PATH and ADA_OBJECTS_PATH are set to -${src_dir} and ${obj_dir} before running the compilation commands, so that you -don't need to specify the -aI and -aO switches on the command line\n") - (widget-insert -"You can reference any environment variable using the same ${...} syntax as -above, and put the name of the variable between the quotes.\n\n") - (ada-prj-field 'check_cmd - "Check syntax of a single file (menu Ada->Check File)" -"This command is run to check the syntax and semantics of a file. -The file name is added at the end of this command." t) - (ada-prj-field 'comp_cmd - "Compiling a single file (menu Ada->Compile File)" -"This command is run when the recompilation -of a single file is needed. The file name is -added at the end of this command." t) - (ada-prj-field 'make_cmd "Rebuilding the whole project (menu Ada->Build)" -"This command is run when you want to rebuild -your whole application. It is never issues -automatically and you will need to ask for it. -If remote_machine has been set, this command -will be executed on the remote machine." t) - (ada-prj-field 'run_cmd "Running the application (menu Ada->Run)" -"This command specifies how to run the -application, including any switch you need to -specify. If remote_machine has been set, this -command will be executed on the remote host." t) - ) - - ;; - ;; Fifth page - ;; - ((= tab-num 5) - (widget-insert "/_____________\\/______________\\/______________\\/______________\\/ \\\n") - (ada-prj-field 'debug_pre_cmd "Commands to execute before launching the -debugger" -"The following commands are executed one after the other before starting -the debugger. These can be used to set up your environment." t) - - (ada-prj-field 'debug_cmd "Debugging the application" -"Specifies how to debug the application, possibly -remotely if remote_machine has been set. We -recommend the following debuggers: - > gdb - > gvd --tty - > ddd --tty -fullname -toolbar") - - (ada-prj-field 'debug_post_cmd "Commands to execute in the debugger" -"The following commands are executed one in the debugger once it has been -started. These can be used to initialize the debugger, for instance to -connect to the target when working with cross-environments" t) - ) - - ) - - - (widget-insert "______________________________________________________________________\n\n ") - (widget-create 'push-button - :notify (lambda (&rest _ignore) - (setq ada-prj-current-values (ada-default-prj-properties)) - (ada-prj-display-page 1)) - "Reset to Default Values") - (widget-insert " ") - (widget-create 'push-button :notify (lambda (&rest _ignore) (kill-buffer nil)) - "Cancel") - (widget-insert " ") - (widget-create 'push-button :notify (lambda (&rest _ignore) (ada-prj-save)) - "Save") - (widget-insert "\n\n") - - (widget-setup) - (with-no-warnings - (beginning-of-buffer)) - ) - - -(defun ada-customize (&optional new-file filename) - "Edit the project file associated with the current buffer. -If there is none or NEW-FILE is non-nil, make a new one. -If FILENAME is given, edit that file." - (interactive) - - (let ((ada-buffer (current-buffer)) - (inhibit-read-only t)) - - ;; We can only edit interactively the standard ada-mode project files. If - ;; the user is using other formats for the project file (through hooks in - ;; `ada-load-project-hook', we simply edit the file - - (if (and (not new-file) - (or ada-prj-default-project-file filename) - (string= (file-name-extension - (or filename ada-prj-default-project-file)) - "gpr")) - (progn - (find-file ada-prj-default-project-file) - (add-hook 'after-save-hook 'ada-reread-prj-file t t) - ) - - (if filename - (ada-reread-prj-file filename) - (if (not (string= ada-prj-default-project-file "")) - (ada-reread-prj-file ada-prj-default-project-file) - (ada-reread-prj-file))) - - (switch-to-buffer "*Edit Ada Mode Project*") - - (ada-prj-initialize-values 'ada-prj-current-values - ada-buffer - ada-prj-default-project-file) - - (set (make-local-variable 'ada-prj-ada-buffer) ada-buffer) - - (use-local-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map custom-mode-map) - (define-key map "\C-x\C-s" 'ada-prj-save) - map)) - - ;; FIXME: Not sure if this works!! - (set (make-local-variable 'widget-keymap) - (let ((map (make-sparse-keymap))) - (set-keymap-parent map widget-keymap) - (define-key map "\C-x\C-s" 'ada-prj-save) - map)) - - (set (make-local-variable 'ada-old-cross-prefix) - (ada-xref-get-project-field 'cross-prefix)) - - (ada-prj-display-page 1) - ))) - -;; ---------------- Utilities -------------------------------- - -(defun ada-prj-set-list (string ada-list &optional is-directory) - "Prepend STRING to strings in ADA-LIST, return new-line separated string. -If IS-DIRECTORY is non-nil, each element of ADA-LIST is explicitly -converted to a directory name." - - (mapconcat (lambda (x) (concat string "=" - (if is-directory - (file-name-as-directory x) - x))) - ada-list "\n")) - - -(defun ada-prj-field-modified (widget &rest _dummy) - "Callback for modification of WIDGET. -Remaining args DUMMY are ignored. -Save the change in `ada-prj-current-values' so that selecting -another page and coming back keeps the new value." - (setq ada-prj-current-values - (plist-put ada-prj-current-values - (widget-get widget ':prj-field) - (widget-value widget)))) - -(defun ada-prj-display-help (widget _widget-modified event) - "Callback for help button in WIDGET. -Parameters WIDGET-MODIFIED, EVENT match :notify for the widget." - (let ((text (widget-get widget 'prj-help))) - (if event - ;; If we have a mouse-event, popup a menu - (widget-choose "Help" - (mapcar (lambda (a) (cons a t)) - (split-string text "\n")) - event) - ;; Else display the help string just before the next group of - ;; variables - (momentary-string-display - (concat "*****Help*****\n" text "\n**************\n") - (point-at-bol 2))))) - -(defun ada-prj-show-value (widget _widget-modified event) - "Show the current field value in WIDGET. -Parameters WIDGET-MODIFIED, EVENT match :notify for the widget." - (let* ((field (widget-get widget ':prj-field)) - (value (plist-get ada-prj-current-values field)) - (inhibit-read-only t) - w) - - ;; If the other widget is already visible, delete it - (if (widget-get widget 'prj-other-widget) - (progn - (widget-delete (widget-get widget 'prj-other-widget)) - (widget-put widget 'prj-other-widget nil) - (widget-put widget ':prj-field field) - (widget-default-value-set widget "Show Value") - ) - - ;; Else create it - (save-excursion - (mouse-set-point event) - (forward-line 1) - (beginning-of-line) - (setq w (widget-create 'editable-list - :entry-format "%i%d %v" - :notify 'ada-prj-field-modified - :help-echo (widget-get widget 'prj-help) - :value value - (list 'editable-field :keymap widget-keymap))) - (widget-put widget 'prj-other-widget w) - (widget-put w ':prj-field field) - (widget-put widget ':prj-field field) - (widget-default-value-set widget "Hide Value") - ) - ) - (widget-setup) - )) - -(defun ada-prj-field (field text help-text &optional is-list is-paths after-text) - "Create a widget to edit FIELD in the current buffer. -TEXT is a short explanation of what the field means, whereas HELP-TEXT -is the text displayed when the user pressed the help button. -If IS-LIST is non-nil, the field contains a list. Otherwise, it contains -a single string. -If IS-PATHS is true, some special buttons are added to load paths,... -AFTER-TEXT is inserted just after the widget." - (let ((value (plist-get ada-prj-current-values field)) - (inhibit-read-only t) - widget) - (unless value - (setq value - (if is-list '() ""))) - (widget-insert text) - (widget-insert ":") - (move-to-column 54 t) - (widget-put (widget-create 'push-button - :notify 'ada-prj-display-help - "Help") - 'prj-help - help-text) - (widget-insert (concat " (" (symbol-name field) ")\n")) - (if is-paths - (progn - (widget-create 'push-button - :notify - (list 'lambda '(&rest dummy) '(interactive) - (list 'ada-prj-load-from-file - (list 'quote field))) - "Load From File") - (widget-insert " ") - (widget-create 'push-button - :notify - (list 'lambda '(&rest dummy) '(interactive) - (list 'ada-prj-load-directory - (list 'quote field))) - "Load Recursive Directory") - (widget-insert "\n ${build_dir}\n"))) - - (setq widget - (if is-list - (if (< (length value) 15) - (widget-create 'editable-list - :entry-format "%i%d %v" - :notify 'ada-prj-field-modified - :help-echo help-text - :value value - (list 'editable-field :keymap widget-keymap)) - - (let ((w (widget-create 'push-button - :notify 'ada-prj-show-value - "Show value"))) - (widget-insert "\n") - (widget-put w 'prj-help help-text) - (widget-put w 'prj-other-widget nil) - w) - ) - (widget-create 'editable-field - :format "%v" - :notify 'ada-prj-field-modified - :help-echo help-text - :keymap widget-keymap - value))) - (widget-put widget ':prj-field field) - (if after-text - (widget-insert after-text)) - (widget-insert "\n") - )) - - -(provide 'ada-prj) - -;;; ada-prj.el ends here diff --git a/lisp/progmodes/ada-stmt.el b/lisp/progmodes/ada-stmt.el deleted file mode 100644 index ef42b0d936..0000000000 --- a/lisp/progmodes/ada-stmt.el +++ /dev/null @@ -1,486 +0,0 @@ -;;; ada-stmt.el --- an extension to Ada mode for inserting statement templates - -;; Copyright (C) 1987, 1993-1994, 1996-2019 Free Software Foundation, -;; Inc. - -;; Authors: Daniel Pfeiffer -;; Markus Heritsch -;; Rolf Ebert -;; Maintainer: Stephen Leake -;; Keywords: languages, ada -;; Package: ada-mode - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Commentary: -;; This file is now automatically loaded from ada-mode.el, and creates a submenu -;; in Ada/ on the menu bar. - -;;; History: - -;; Created May 1987. -;; Original version from V. Bowman as in ada.el of Emacs-18 -;; (borrowed heavily from Mick Jordan's Modula-2 package for GNU, -;; as modified by Peter Robinson, Michael Schmidt, and Tom Perrine.) -;; -;; Sep 1993. Daniel Pfeiffer (DP) -;; Introduced statement.el for smaller code and user configurability. -;; -;; Nov 1993. Rolf Ebert (RE) Moved the -;; skeleton generation into this separate file. The code still is -;; essentially written by DP -;; -;; Adapted Jun 1994. Markus Heritsch -;; (MH) -;; added menu bar support for templates -;; -;; 1994/12/02 Christian Egli -;; General cleanup and bug fixes. -;; -;; 1995/12/20 John Hutchison -;; made it work with skeleton.el from Emacs-19.30. Several -;; enhancements and bug fixes. - -;; BUGS: -;;;> I have the following suggestions for the function template: 1) I -;;;> don't want it automatically assigning it a name for the return variable. I -;;;> never want it to be called "Result" because that is nondescript. If you -;;;> must define a variable, give me the ability to specify its name. -;;;> -;;;> 2) You do not provide a type for variable 'Result'. Its type is the same -;;;> as the function's return type, which the template knows, so why force me -;;;> to type it in? -;;;> - -;;;It would be nice if one could configure such layout details separately -;;;without patching the LISP code. Maybe the metalanguage used in ada-stmt.el -;;;could be taken even further, providing the user with some nice syntax -;;;for describing layout. Then my own hacks would survive the next -;;;update of the package :-) - - -;;; Code: - -(require 'skeleton nil t) -(require 'easymenu) -(require 'ada-mode) - -(defun ada-func-or-proc-name () - "Return the name of the current function or procedure." - (save-excursion - (let ((case-fold-search t)) - (if (re-search-backward ada-procedure-start-regexp nil t) - (match-string 5) - "NAME?")))) - -;;; ---- statement skeletons ------------------------------------------ - -(define-skeleton ada-array - "Insert array type definition. -Prompt for component type and index subtypes." - () - "array (" ("index definition: " str ", " ) -2 ") of " _ ?\;) - - -(define-skeleton ada-case - "Build skeleton case statement. -Prompt for the selector expression. Also builds the first when clause." - "[selector expression]: " - "case " str " is" \n - > "when " ("discrete choice: " str " | ") -3 " =>" \n - > _ \n - < < "end case;") - - -(define-skeleton ada-when - "Start a case statement alternative with a when clause." - () - < "when " ("discrete choice: " str " | ") -3 " =>" \n - >) - - -(define-skeleton ada-declare-block - "Insert a block with a declare part. -Indent for the first declaration." - "[block name]: " - < str & ?: & \n - > "declare" \n - > _ \n - < "begin" \n - > \n - < "end " str | -1 ?\;) - - -(define-skeleton ada-exception-block - "Insert a block with an exception part. -Indent for the first line of code." - "[block name]: " - < str & ?: & \n - > "begin" \n - > _ \n - < "exception" \n - > \n - < "end " str | -1 ?\;) - - -(define-skeleton ada-exception - "Insert an indented exception part into a block." - () - < "exception" \n - >) - - -(define-skeleton ada-exit-1 - "Insert then exit condition of the exit statement, prompting for condition." - "[exit condition]: " - "when " str | -5) - - -(define-skeleton ada-exit - "Insert an exit statement, prompting for loop name and condition." - "[name of loop to exit]: " - "exit " str & ?\ (ada-exit-1) | -1 ?\;) - -;;;###autoload -(defun ada-header () - "Insert a descriptive header at the top of the file." - (interactive "*") - (save-excursion - (goto-char (point-min)) - (if (fboundp 'make-header) - (funcall (symbol-function 'make-header)) - (ada-header-tmpl)))) - - -(define-skeleton ada-header-tmpl - "Insert a comment block containing the module title, author, etc." - "[Description]: " - "-- -*- Mode: Ada -*-" - "\n" ada-fill-comment-prefix "Filename : " (buffer-name) - "\n" ada-fill-comment-prefix "Description : " str - "\n" ada-fill-comment-prefix "Author : " (user-full-name) - "\n" ada-fill-comment-prefix "Created On : " (current-time-string) - "\n" ada-fill-comment-prefix "Last Modified By: ." - "\n" ada-fill-comment-prefix "Last Modified On: ." - "\n" ada-fill-comment-prefix "Update Count : 0" - "\n" ada-fill-comment-prefix "Status : Unknown, Use with caution!" - "\n") - - -(define-skeleton ada-display-comment - "Inserts three comment lines, making a display comment." - () - "--\n" ada-fill-comment-prefix _ "\n--") - - -(define-skeleton ada-if - "Insert skeleton if statement, prompting for a boolean-expression." - "[condition]: " - "if " str " then" \n - > _ \n - < "end if;") - - -(define-skeleton ada-elsif - "Add an elsif clause to an if statement, -prompting for the boolean-expression." - "[condition]: " - < "elsif " str " then" \n - >) - - -(define-skeleton ada-else - "Add an else clause inside an if-then-end-if clause." - () - < "else" \n - >) - - -(define-skeleton ada-loop - "Insert a skeleton loop statement. The exit statement is added by hand." - "[loop name]: " - < str & ?: & \n - > "loop" \n - > _ \n - < "end loop " str | -1 ?\;) - - -(define-skeleton ada-for-loop-prompt-variable - "Prompt for the loop variable." - "[loop variable]: " - str) - - -(define-skeleton ada-for-loop-prompt-range - "Prompt for the loop range." - "[loop range]: " - str) - - -(define-skeleton ada-for-loop - "Build a skeleton for-loop statement, prompting for the loop parameters." - "[loop name]: " - < str & ?: & \n - > "for " - (ada-for-loop-prompt-variable) - " in " - (ada-for-loop-prompt-range) - " loop" \n - > _ \n - < "end loop " str | -1 ?\;) - - -(define-skeleton ada-while-loop-prompt-entry-condition - "Prompt for the loop entry condition." - "[entry condition]: " - str) - - -(define-skeleton ada-while-loop - "Insert a skeleton while loop statement." - "[loop name]: " - < str & ?: & \n - > "while " - (ada-while-loop-prompt-entry-condition) - " loop" \n - > _ \n - < "end loop " str | -1 ?\;) - - -(define-skeleton ada-package-spec - "Insert a skeleton package specification." - "[package name]: " - "package " str " is" \n - > _ \n - < "end " str ?\;) - - -(define-skeleton ada-package-body - "Insert a skeleton package body -- includes a begin statement." - "[package name]: " - "package body " str " is" \n - > _ \n -; < "begin" \n - < "end " str ?\;) - - -(define-skeleton ada-private - "Undent and start a private section of a package spec. Reindent." - () - < "private" \n - >) - - -(define-skeleton ada-function-spec-prompt-return - "Prompts for function result type." - "[result type]: " - str) - - -(define-skeleton ada-function-spec - "Insert a function specification. Prompts for name and arguments." - "[function name]: " - "function " str - " (" ("[parameter_specification]: " str "; " ) -2 ")" - " return " - (ada-function-spec-prompt-return) - ";" \n ) - - -(define-skeleton ada-procedure-spec - "Insert a procedure specification, prompting for its name and arguments." - "[procedure name]: " - "procedure " str - " (" ("[parameter_specification]: " str "; " ) -2 ")" - ";" \n ) - - -(define-skeleton ada-subprogram-body - "Insert frame for subprogram body. -Invoke right after `ada-function-spec' or `ada-procedure-spec'." - () - ;; Remove `;' from subprogram decl - (save-excursion - (let ((pos (1+ (point)))) - (ada-search-ignore-string-comment ada-subprog-start-re t nil) - (when (ada-search-ignore-string-comment "(" nil pos t 'search-forward) - (backward-char 1) - (forward-sexp 1))) - (if (looking-at ";") - (delete-char 1))) - " is" \n - _ \n - < "begin" \n - \n - < "exception" \n - "when others => null;" \n - < < "end " - (ada-func-or-proc-name) - ";" \n) - - -(define-skeleton ada-separate - "Finish a body stub with `separate'." - () - > "separate;" \n - <) - - -;(define-skeleton ada-with -; "Inserts a with clause, prompting for the list of units depended upon." -; "[list of units depended upon]: " -; "with " str ?\;) - -;(define-skeleton ada-use -; "Inserts a use clause, prompting for the list of packages used." -; "[list of packages used]: " -; "use " str ?\;) - - -(define-skeleton ada-record - "Insert a skeleton record type declaration." - () - "record" \n - > _ \n - < "end record;") - - -(define-skeleton ada-subtype - "Start insertion of a subtype declaration, prompting for the subtype name." - "[subtype name]: " - "subtype " str " is " _ ?\; - (not (message "insert subtype indication."))) - - -(define-skeleton ada-type - "Start insertion of a type declaration, prompting for the type name." - "[type name]: " - "type " str ?\( - ("[discriminant specs]: " str " ") - | (backward-delete-char 1) | ?\) - " is " - (not (message "insert type definition."))) - - -(define-skeleton ada-task-body - "Insert a task body, prompting for the task name." - "[task name]: " - "task body " str " is\n" - "begin\n" - > _ \n - < "end " str ";" ) - - -(define-skeleton ada-task-spec - "Insert a task specification, prompting for the task name." - "[task name]: " - "task " str - " (" ("[discriminant]: " str "; ") ") is\n" - > "entry " _ \n - <"end " str ";" ) - - -(define-skeleton ada-get-param1 - "Prompt for arguments and if any enclose them in brackets." - () - ("[parameter_specification]: " str "; " ) & -2 & ")") - - -(define-skeleton ada-get-param - "Prompt for arguments and if any enclose them in brackets." - () - " (" - (ada-get-param1) | -2) - - -(define-skeleton ada-entry - "Insert a task entry, prompting for the entry name." - "[entry name]: " - "entry " str - (ada-get-param) - ";" \n) - - -(define-skeleton ada-entry-family-prompt-discriminant - "Insert an entry specification, prompting for the entry name." - "[discriminant name]: " - str) - - -(define-skeleton ada-entry-family - "Insert an entry specification, prompting for the entry name." - "[entry name]: " - "entry " str - " (" (ada-entry-family-prompt-discriminant) ")" - (ada-get-param) - ";" \n) - - -(define-skeleton ada-select - "Insert a select block." - () - "select\n" - > _ \n - < "end select;") - - -(define-skeleton ada-accept-1 - "Insert a condition statement, prompting for the condition name." - "[condition]: " - "when " str | -5 ) - - -(define-skeleton ada-accept-2 - "Insert an accept statement, prompting for the name and arguments." - "[accept name]: " - > "accept " str - (ada-get-param) - " do" \n - > _ \n - < "end " str ";" ) - - -(define-skeleton ada-accept - "Insert an accept statement (prompt for condition, name and arguments)." - () - > (ada-accept-1) & " =>\n" - (ada-accept-2)) - - -(define-skeleton ada-or-accept - "Insert an accept alternative, prompting for the condition name." - () - < "or\n" - (ada-accept)) - - -(define-skeleton ada-or-delay - "Insert a delay alternative, prompting for the delay value." - "[delay value]: " - < "or\n" - > "delay " str ";") - - -(define-skeleton ada-or-terminate - "Insert a terminate alternative." - () - < "or\n" - > "terminate;") - - -(provide 'ada-stmt) - -;;; ada-stmt.el ends here diff --git a/lisp/progmodes/ada-xref.el b/lisp/progmodes/ada-xref.el deleted file mode 100644 index c9c923e1d6..0000000000 --- a/lisp/progmodes/ada-xref.el +++ /dev/null @@ -1,2359 +0,0 @@ -;; ada-xref.el --- for lookup and completion in Ada mode - -;; Copyright (C) 1994-2019 Free Software Foundation, Inc. - -;; Author: Markus Heritsch -;; Rolf Ebert -;; Emmanuel Briot -;; Maintainer: Stephen Leake -;; Keywords: languages ada xref -;; Package: ada-mode - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Commentary: - -;; This Package provides a set of functions to use the output of the -;; cross reference capabilities of the GNAT Ada compiler -;; for lookup and completion in Ada mode. -;; -;; If a file *.`adp' exists in the ada-file directory, then it is -;; read for configuration information. It is read only the first -;; time a cross-reference is asked for, and is not read later. - -;;; Code: - -;; ----- Requirements ----------------------------------------------------- - -(require 'compile) -(require 'comint) -(require 'find-file) -(require 'ada-mode) -(eval-when-compile (require 'cl-lib)) - -;; ------ User variables -(defcustom ada-xref-other-buffer t - "If nil, always display the cross-references in the same buffer. -Otherwise create either a new buffer or a new frame." - :type 'boolean :group 'ada) - -(defcustom ada-xref-create-ali nil - "If non-nil, run gcc whenever the cross-references are not up-to-date. -If nil, the cross-reference mode never runs gcc." - :type 'boolean :group 'ada) - -(defcustom ada-xref-confirm-compile nil - "If non-nil, ask for confirmation before compiling or running the application." - :type 'boolean :group 'ada) - -(defcustom ada-krunch-args "0" - "Maximum number of characters for filenames created by `gnatkr'. -Set to 0, if you don't use crunched filenames. This should be a string." - :type 'string :group 'ada) - -(defcustom ada-gnat-cmd "gnat" - "Default GNAT project file parser. -Will be run with args \"list -v -Pfile.gpr\". -Default is standard GNAT distribution; alternate \"gnatpath\" -is faster, available from Ada mode web site." - :type 'string :group 'ada) - -(defcustom ada-gnatls-args '("-v") - "Arguments to pass to `gnatls' to find location of the runtime. -Typical use is to pass `--RTS=soft-floats' on some systems that support it. - -You can also add `-I-' if you do not want the current directory to be included. -Otherwise, going from specs to bodies and back will first look for files in the -current directory. This only has an impact if you are not using project files, -but only ADA_INCLUDE_PATH." - :type '(repeat string) :group 'ada) - -(defcustom ada-prj-default-comp-opt "-gnatq -gnatQ" - "Default compilation options." - :type 'string :group 'ada) - -(defcustom ada-prj-default-bind-opt "" - "Default binder options." - :type 'string :group 'ada) - -(defcustom ada-prj-default-link-opt "" - "Default linker options." - :type 'string :group 'ada) - -(defcustom ada-prj-default-gnatmake-opt "-g" - "Default options for `gnatmake'." - :type 'string :group 'ada) - -(defcustom ada-prj-default-gpr-file "" - "Default GNAT project file. -If non-empty, this file is parsed to set the source and object directories for -the Ada mode project." - :type 'string :group 'ada) - -(defcustom ada-prj-ada-project-path-sep - (cond ((boundp 'path-separator) path-separator) ; 20.3+ - ((memq system-type '(windows-nt ms-dos)) ";") - (t ":")) - "Default separator for ada_project_path project variable." - :type 'string :group 'ada) - -(defcustom ada-prj-gnatfind-switches "-rf" - "Default switches to use for `gnatfind'. -You should modify this variable, for instance to add `-a', if you are working -in an environment where most ALI files are write-protected. -The command `gnatfind' is used every time you choose the menu -\"Show all references\"." - :type 'string :group 'ada) - -(defcustom ada-prj-default-check-cmd - (concat "${cross_prefix}gnatmake -u -c -gnatc ${gnatmake_opt} ${full_current}" - " -cargs ${comp_opt}") - "Default command to be used to compile a single file. -Emacs will substitute the current filename for ${full_current}, or add -the filename at the end. This is the same syntax as in the project file." - :type 'string :group 'ada) - -(defcustom ada-prj-default-comp-cmd - (concat "${cross_prefix}gnatmake -u -c ${gnatmake_opt} ${full_current} -cargs" - " ${comp_opt}") - "Default command to be used to compile a single file. -Emacs will substitute the current filename for ${full_current}, or add -the filename at the end. This is the same syntax as in the project file." - :type 'string :group 'ada) - -(defcustom ada-prj-default-debugger "${cross_prefix}gdb" - "Default name of the debugger." - :type 'string :group 'ada) - -(defcustom ada-prj-default-make-cmd - (concat "${cross_prefix}gnatmake -o ${main} ${main} ${gnatmake_opt} " - "-cargs ${comp_opt} -bargs ${bind_opt} -largs ${link_opt}") - "Default command to be used to compile the application. -This is the same syntax as in the project file." - :type 'string :group 'ada) - -(defcustom ada-prj-default-project-file "" - "Name of the current project file. -Emacs will not try to use the search algorithm to find the project file if -this string is not empty. It is set whenever a project file is found." - :type '(file :must-match t) :group 'ada) - -(defcustom ada-gnatstub-opts "-q -I${src_dir}" - "Options to pass to `gnatsub' to generate the body of a package. -This has the same syntax as in the project file (with variable substitution)." - :type 'string :group 'ada) - -(defcustom ada-always-ask-project nil - "If nil, use default values when no project file was found. -Otherwise, ask the user for the name of the project file to use." - :type 'boolean :group 'ada) - -(defconst ada-on-ms-windows (memq system-type '(windows-nt)) - "True if we are running on Windows.") - -(defcustom ada-tight-gvd-integration nil - "If non-nil, a new Emacs frame will be swallowed in GVD when debugging. -If GVD is not the debugger used, nothing happens." - :type 'boolean :group 'ada) - -(defcustom ada-xref-search-with-egrep t - "If non-nil, use grep -E to find the possible declarations for an entity. -This alternate method is used when the exact location was not found in the -information provided by GNAT. However, it might be expensive if you have a lot -of sources, since it will search in all the files in your project." - :type 'boolean :group 'ada) - -(defvar ada-load-project-hook nil - "Hook that is run when loading a project file. -Each function in this hook takes one argument FILENAME, that is the name of -the project file to load. -This hook should be used to support new formats for the project files. - -If the function can load the file with the given filename, it should create a -buffer that contains a conversion of the file to the standard format of the -project files, and return that buffer. (The usual \"src_dir=\" or \"obj_dir=\" -lines.) It should return nil if it doesn't know how to convert that project -file.") - - -;; ------- Nothing to be modified by the user below this -(defvar ada-last-prj-file "" - "Name of the last project file entered by the user.") - -(defconst ada-prj-file-extension ".adp" - "The extension used for project files.") - -(defvar ada-xref-runtime-library-specs-path '() - "Directories where the specs for the standard library is found. -This is used for cross-references.") - -(defvar ada-xref-runtime-library-ali-path '() - "Directories where the ali for the standard library is found. -This is used for cross-references.") - -(defvar ada-xref-pos-ring '() - "List of positions selected by the cross-references functions. -Used to go back to these positions.") - -(defvar ada-cd-command - (if (string-match "cmdproxy.exe" shell-file-name) - "cd /d" - "cd") - "Command to use to change to a specific directory. -On Windows systems using `cmdproxy.exe' as the shell, -we need to use `/d' or the drive is never changed.") - -(defvar ada-command-separator (if ada-on-ms-windows " && " "\n") - "Separator to use between multiple commands to `compile' or `start-process'. -`cmdproxy.exe' doesn't recognize multiple-line commands, so we have to use -\"&&\" for now.") - -(defconst ada-xref-pos-ring-max 16 - "Number of positions kept in the list `ada-xref-pos-ring'.") - -(defvar ada-operator-re - "\\+\\|-\\|/\\|\\*\\*\\|\\*\\|=\\|&\\|abs\\|mod\\|rem\\|and\\|not\\|or\\|xor\\|<=\\|<\\|>=\\|>" - "Regexp to match for operators.") - -(defvar ada-xref-project-files '() - "Associative list of project files with properties. -It has the format: (project project ...) -A project has the format: (project-file . project-plist) -\(See `apropos plist' for operations on property lists). -See `ada-default-prj-properties' for the list of valid properties. -The current project is retrieved with `ada-xref-current-project'. -Properties are retrieved with `ada-xref-get-project-field', set with -`ada-xref-set-project-field'. If project properties are accessed with no -project file, a (nil . default-properties) entry is created.") - - -;; ----- Identlist manipulation ------------------------------------------- -;; An identlist is a vector that is used internally to reference an identifier -;; To facilitate its use, we provide the following macros - -(defmacro ada-make-identlist () (make-vector 8 nil)) -(defmacro ada-name-of (identlist) (list 'aref identlist 0)) -(defmacro ada-line-of (identlist) (list 'aref identlist 1)) -(defmacro ada-column-of (identlist) (list 'aref identlist 2)) -(defmacro ada-file-of (identlist) (list 'aref identlist 3)) -(defmacro ada-ali-index-of (identlist) (list 'aref identlist 4)) -(defmacro ada-declare-file-of (identlist) (list 'aref identlist 5)) -(defmacro ada-references-of (identlist) (list 'aref identlist 6)) -(defmacro ada-on-declaration (identlist) (list 'aref identlist 7)) - -(defmacro ada-set-name (identlist name) (list 'aset identlist 0 name)) -(defmacro ada-set-line (identlist line) (list 'aset identlist 1 line)) -(defmacro ada-set-column (identlist col) (list 'aset identlist 2 col)) -(defmacro ada-set-file (identlist file) (list 'aset identlist 3 file)) -(defmacro ada-set-ali-index (identlist index) (list 'aset identlist 4 index)) -(defmacro ada-set-declare-file (identlist file) (list 'aset identlist 5 file)) -(defmacro ada-set-references (identlist ref) (list 'aset identlist 6 ref)) -(defmacro ada-set-on-declaration (ident value) (list 'aset ident 7 value)) - -(defsubst ada-get-ali-buffer (file) - "Read the ali file FILE into a new buffer, and return the buffer's name." - (find-file-noselect (ada-get-ali-file-name file))) - - -;; ----------------------------------------------------------------------- - -(defun ada-quote-cmd (cmd) - "Duplicate all `\\' characters in CMD so that it can be passed to `compile'." - (mapconcat 'identity (split-string cmd "\\\\") "\\\\")) - -(defun ada-find-executable (exec-name) - "Find the full path to the executable file EXEC-NAME. -If not found, throw an error. -On Windows systems, this will properly handle .exe extension as well." - (let ((result (or (ada-find-file-in-dir exec-name exec-path) - (ada-find-file-in-dir (concat exec-name ".exe") exec-path)))) - (if result - result - (error "`%s' not found in path" exec-name)))) - -(defun ada-initialize-runtime-library (cross-prefix) - "Initialize the variables for the runtime library location. -CROSS-PREFIX is the prefix to use for the `gnatls' command." - (let ((gnatls - (condition-case nil - ;; if gnatls not found, just give up (may not be using GNAT) - (ada-find-executable (concat cross-prefix "gnatls")) - (error nil)))) - (if gnatls - (save-excursion - (setq ada-xref-runtime-library-specs-path '() - ada-xref-runtime-library-ali-path '()) - (set-buffer (get-buffer-create "*gnatls*")) - (widen) - (erase-buffer) - ;; Even if we get an error, delete the *gnatls* buffer - (unwind-protect - (let ((status (apply 'call-process gnatls (append '(nil t nil) ada-gnatls-args)))) - (goto-char (point-min)) - - ;; Since we didn't provide all the inputs gnatls expects, it returns status 4 - (if (/= 4 status) - (error (buffer-substring (point) (line-end-position)))) - - ;; Source path - - (search-forward "Source Search Path:") - (forward-line 1) - (while (not (looking-at "^$")) - (back-to-indentation) - (add-to-list 'ada-xref-runtime-library-specs-path - (if (looking-at "") - "." - (buffer-substring-no-properties - (point) - (point-at-eol)))) - (forward-line 1)) - - ;; Object path - - (search-forward "Object Search Path:") - (forward-line 1) - (while (not (looking-at "^$")) - (back-to-indentation) - (add-to-list 'ada-xref-runtime-library-ali-path - (if (looking-at "") - "." - (buffer-substring-no-properties - (point) - (point-at-eol)))) - (forward-line 1)) - ) - (kill-buffer nil)))) - - (setq ada-xref-runtime-library-specs-path - (reverse ada-xref-runtime-library-specs-path)) - (setq ada-xref-runtime-library-ali-path - (reverse ada-xref-runtime-library-ali-path)) - )) - -(defun ada-gnat-parse-gpr (plist gpr-file) - "Set gpr_file, src_dir and obj_dir properties in PLIST by parsing GPR-FILE. -Return new value of PLIST. -GPR_FILE must be full path to file, normalized. -src_dir, obj_dir will include compiler runtime. -Assumes environment variable ADA_PROJECT_PATH is set properly." - (with-current-buffer (get-buffer-create "*gnatls*") - (erase-buffer) - - ;; this can take a long time; let the user know what's up - (message "Parsing %s ..." gpr-file) - - ;; Even if we get an error, delete the *gnatls* buffer - (unwind-protect - (let* ((cross-prefix (plist-get plist 'cross_prefix)) - (gnat (concat cross-prefix ada-gnat-cmd)) - ;; Putting quotes around gpr-file confuses gnatpath on Lynx; not clear why - (gpr-opt (concat "-P" gpr-file)) - (src-dir '()) - (obj-dir '()) - (status (call-process gnat nil t nil "list" "-v" gpr-opt))) - (goto-char (point-min)) - - (if (/= 0 status) - (error (buffer-substring (point) (line-end-position)))) - - ;; Source path - - (search-forward "Source Search Path:") - (forward-line 1) ; first directory in list - (while (not (looking-at "^$")) ; terminate on blank line - (back-to-indentation) ; skip whitespace - (cl-pushnew (if (looking-at "") - default-directory - (expand-file-name - (buffer-substring-no-properties - (point) (line-end-position)))) - src-dir :test #'equal) - (forward-line 1)) - - ;; Object path - - (search-forward "Object Search Path:") - (forward-line 1) - (while (not (looking-at "^$")) - (back-to-indentation) - (cl-pushnew (if (looking-at "") - default-directory - (expand-file-name - (buffer-substring-no-properties - (point) (line-end-position)))) - obj-dir :test #'equal) - (forward-line 1)) - - ;; Set properties - (setq plist (plist-put plist 'gpr_file gpr-file)) - (setq plist (plist-put plist 'src_dir src-dir)) - (plist-put plist 'obj_dir obj-dir) - ) - (kill-buffer nil) - (message "Parsing %s ... done" gpr-file) - ) - )) - -(defun ada-treat-cmd-string (cmd-string) - "Replace variable references ${var} in CMD-STRING with the appropriate value. -Also replace standard environment variables $var. -Assumes project exists. -As a special case, ${current} is replaced with the name of the current -file, minus extension but with directory, and ${full_current} is -replaced by the name including the extension." - - (while (string-match "\\(-[^-$IO]*[IO]\\)?\\${\\([^}]+\\)}" cmd-string) - (let (value - (name (match-string 2 cmd-string))) - (cond - ((string= name "current") - (setq value (file-name-sans-extension (buffer-file-name)))) - ((string= name "full_current") - (setq value (buffer-file-name))) - (t - (save-match-data - (setq value (ada-xref-get-project-field (intern name)))))) - - ;; Check if there is an environment variable with the same name - (if (null value) - (if (not (setq value (getenv name))) - (message "%s" (concat "No project or environment variable " name " found")))) - - (cond - ((null value) - (setq cmd-string (replace-match "" t t cmd-string))) - ((stringp value) - (setq cmd-string (replace-match value t t cmd-string))) - ((listp value) - (let ((prefix (match-string 1 cmd-string))) - (setq cmd-string (replace-match - (mapconcat (lambda(x) (concat prefix x)) value " ") - t t cmd-string))))) - )) - (substitute-in-file-name cmd-string)) - - -(defun ada-xref-get-project-field (field) - "Extract the value of FIELD from the current project file. -Project variables are substituted. - -Note that for src_dir and obj_dir, you should rather use -`ada-xref-get-src-dir-field' or `ada-xref-get-obj-dir-field' -which will in addition return the default paths." - - (let* ((project-plist (cdr (ada-xref-current-project))) - (value (plist-get project-plist field))) - - (cond - ((eq field 'gnatmake_opt) - (let ((gpr-file (plist-get project-plist 'gpr_file))) - (if (not (string= gpr-file "")) - (setq value (concat "-P\"" gpr-file "\" " value))))) - - ;; FIXME: check for src_dir, obj_dir here, rather than requiring user to do it - (t - nil)) - - ;; Substitute the ${...} constructs in all the strings, including - ;; inside lists - (cond - ((stringp value) - (ada-treat-cmd-string value)) - ((null value) - nil) - ((listp value) - (mapcar (lambda(x) (if x (ada-treat-cmd-string x) x)) value)) - (t - value) - ) - )) - -(defun ada-xref-get-src-dir-field () - "Return the full value for src_dir, including the default directories. -All the directories are returned as absolute directories." - - (let ((build-dir (ada-xref-get-project-field 'build_dir))) - (append - ;; Add ${build_dir} in front of the path - (list build-dir) - - (ada-get-absolute-dir-list (ada-xref-get-project-field 'src_dir) - build-dir) - - ;; Add the standard runtime at the end - ada-xref-runtime-library-specs-path))) - -(defun ada-xref-get-obj-dir-field () - "Return the full value for obj_dir, including the default directories. -All the directories are returned as absolute directories." - - (let ((build-dir (ada-xref-get-project-field 'build_dir))) - (append - ;; Add ${build_dir} in front of the path - (list build-dir) - - (ada-get-absolute-dir-list (ada-xref-get-project-field 'obj_dir) - build-dir) - - ;; Add the standard runtime at the end - ada-xref-runtime-library-ali-path))) - -(defun ada-xref-set-project-field (field value) - "Set FIELD to VALUE in current project. Assumes project exists." - ;; same algorithm to find project-plist as ada-xref-current-project - (let* ((file-name (ada-xref-current-project-file)) - (project-plist (cdr (assoc file-name ada-xref-project-files)))) - - (setq project-plist (plist-put project-plist field value)) - (setcdr (assoc file-name ada-xref-project-files) project-plist))) - -(defun ada-xref-update-project-menu () - "Update the menu Ada->Project, with the list of available project files." - ;; Create the standard items. - (let ((submenu - `("Project" - ["Load..." ada-set-default-project-file t] - ["New..." ada-prj-new t] - ["Edit..." ada-prj-edit t] - "---" - ;; Add the project files - ,@(mapcar - (lambda (x) - (let* ((name (or (car x) "")) - (command `(lambda () - "Select the current project file." - (interactive) - (ada-select-prj-file ,name)))) - (vector - (file-name-nondirectory name) - command - :button (cons - :toggle - (equal ada-prj-default-project-file - (car x)) - )))) - - (or ada-xref-project-files '(nil)))))) - - (easy-menu-add-item ada-mode-menu '() submenu))) - - -;;------------------------------------------------------------- -;;-- Searching a file anywhere on the source path. -;;-- -;;-- The following functions provide support for finding a file anywhere -;;-- on the source path, without providing an explicit directory. -;;-- They also provide file name completion in the minibuffer. -;;-- -;;-- Public subprograms: ada-find-file -;;-- -;;------------------------------------------------------------- - -(defun ada-do-file-completion (string predicate flag) - "Completion function when reading a file from the minibuffer. -Completion is attempted in all the directories in the source path, -as defined in the project file." - ;; FIXME: doc arguments - - ;; This function is not itself interactive, but it is called as part - ;; of the prompt of interactive functions, so we require a project - ;; file. - (ada-require-project-file) - (let (list - (dirs (ada-xref-get-src-dir-field))) - - (while dirs - (if (file-directory-p (car dirs)) - (setq list (append list (file-name-all-completions string (car dirs))))) - (setq dirs (cdr dirs))) - (cond ((equal flag 'lambda) - (assoc string list)) - (flag - list) - (t - (try-completion string - (mapcar (lambda (x) (cons x 1)) list) - predicate))))) - -;;;###autoload -(defun ada-find-file (filename) - "Open FILENAME, from anywhere in the source path. -Completion is available." - (interactive - (list (completing-read "File: " 'ada-do-file-completion))) - (let ((file (ada-find-src-file-in-dir filename))) - (if file - (find-file file) - (error "%s not found in src_dir" filename)))) - - -;; ----- Utilities ------------------------------------------------- - -(defun ada-require-project-file () - "If the current project does not exist, load or create a default one. -Should only be called from interactive functions." - (if (string= "" ada-prj-default-project-file) - (ada-reread-prj-file (ada-prj-find-prj-file t)))) - -(defun ada-xref-current-project-file () - "Return the current project file name; never nil. -Call `ada-require-project-file' first if a project must exist." - (if (not (string= "" ada-prj-default-project-file)) - ada-prj-default-project-file - (ada-prj-find-prj-file t))) - -(defun ada-xref-current-project () - "Return the current project. -Call `ada-require-project-file' first to ensure a project exists." - (let ((file-name (ada-xref-current-project-file))) - (assoc file-name ada-xref-project-files))) - -(defun ada-show-current-project () - "Display current project file name in message buffer." - (interactive) - (message (ada-xref-current-project-file))) - -(defun ada-show-current-main () - "Display current main file name in message buffer." - (interactive) - (message "ada-mode main: %s" (ada-xref-get-project-field 'main))) - -(defun ada-xref-push-pos (filename position) - "Push (FILENAME, POSITION) on the position ring for cross-references." - (setq ada-xref-pos-ring (cons (list position filename) ada-xref-pos-ring)) - (if (> (length ada-xref-pos-ring) ada-xref-pos-ring-max) - (setcdr (nthcdr (1- ada-xref-pos-ring-max) ada-xref-pos-ring) nil))) - -(defun ada-xref-goto-previous-reference () - "Go to the previous cross-reference we were on." - (interactive) - (if ada-xref-pos-ring - (let ((pos (car ada-xref-pos-ring))) - (setq ada-xref-pos-ring (cdr ada-xref-pos-ring)) - (find-file (car (cdr pos))) - (goto-char (car pos))))) - -(defun ada-set-default-project-file (file) - "Set FILE as the current project file." - (interactive "fProject file:") - (ada-parse-prj-file file) - (ada-select-prj-file file)) - -;; ------ Handling the project file ----------------------------- - -(defun ada-prj-find-prj-file (&optional no-user-question) - "Find the project file associated with the current buffer. -If the buffer is not in Ada mode, or not associated with a file, -return `ada-prj-default-project-file'. Otherwise, search for a file with -the same base name as the Ada file, but extension given by -`ada-prj-file-extension' (default .adp). If not found, search for *.adp -in the current directory; if several are found, and NO-USER-QUESTION -is non-nil, prompt the user to select one. If none are found, return -\"default.adp\"." - - (let (selected) - - (if (not (and (derived-mode-p 'ada-mode) - buffer-file-name)) - - ;; Not in an Ada buffer, or current buffer not associated - ;; with a file (for instance an emerge buffer) - (setq selected nil) - - ;; other cases: use a more complex algorithm - - (let* ((current-file (buffer-file-name)) - (first-choice (concat - (file-name-sans-extension current-file) - ada-prj-file-extension)) - (dir (file-name-directory current-file)) - - (prj-files (directory-files - dir t - (concat ".*" (regexp-quote - ada-prj-file-extension) "$"))) - (choice nil)) - - (cond - - ((file-exists-p first-choice) - ;; filename.adp - (setq selected first-choice)) - - ((= (length prj-files) 1) - ;; Exactly one project file was found in the current directory - (setq selected (car prj-files))) - - ((and (> (length prj-files) 1) (not no-user-question)) - ;; multiple project files in current directory, ask the user - (save-window-excursion - (with-output-to-temp-buffer "*choice list*" - (princ "There are more than one possible project file.\n") - (princ "Which one should we use ?\n\n") - (princ " no. file name \n") - (princ " --- ------------------------\n") - (let ((counter 1)) - (while (<= counter (length prj-files)) - (princ (format " %2d) %s\n" - counter - (nth (1- counter) prj-files))) - (setq counter (1+ counter)) - - ))) ; end of with-output-to ... - (setq choice nil) - (while (or - (not choice) - (not (integerp choice)) - (< choice 1) - (> choice (length prj-files))) - (setq choice (string-to-number - (read-from-minibuffer "Enter No. of your choice: ")))) - (setq selected (nth (1- choice) prj-files)))) - - ((= (length prj-files) 0) - ;; No project file in the current directory; ask user - (unless (or no-user-question (not ada-always-ask-project)) - (setq ada-last-prj-file - (read-file-name - (concat "project file [" ada-last-prj-file "]:") - nil ada-last-prj-file)) - (unless (string= ada-last-prj-file "") - (setq selected ada-last-prj-file)))) - ))) - - (or selected "default.adp") - )) - -(defun ada-default-prj-properties () - "Return the default project properties list with the current buffer as main." - - (let ((file (buffer-file-name nil))) - (list - ;; variable name alphabetical order - 'ada_project_path (or (getenv "ADA_PROJECT_PATH") "") - 'ada_project_path_sep ada-prj-ada-project-path-sep - 'bind_opt ada-prj-default-bind-opt - 'build_dir default-directory - 'casing (if (listp ada-case-exception-file) - ada-case-exception-file - (list ada-case-exception-file)) - 'check_cmd (list ada-prj-default-check-cmd) ;; FIXME: should not a list - 'comp_cmd (list ada-prj-default-comp-cmd) ;; FIXME: should not a list - 'comp_opt ada-prj-default-comp-opt - 'cross_prefix "" - 'debug_cmd (concat ada-prj-default-debugger - " ${main}" (if ada-on-ms-windows ".exe")) ;; FIXME: don't need .exe? - 'debug_post_cmd (list nil) - 'debug_pre_cmd (list (concat ada-cd-command " ${build_dir}")) - 'gnatmake_opt ada-prj-default-gnatmake-opt - 'gnatfind_opt ada-prj-gnatfind-switches - 'gpr_file ada-prj-default-gpr-file - 'link_opt ada-prj-default-link-opt - 'main (if file - (file-name-nondirectory - (file-name-sans-extension file)) - "") - 'make_cmd (list ada-prj-default-make-cmd) ;; FIXME: should not a list - 'obj_dir (list ".") - 'remote_machine "" - 'run_cmd (list (concat "./${main}" (if ada-on-ms-windows ".exe"))) - ;; FIXME: should not a list - ;; FIXME: don't need .exe? - 'src_dir (list ".") - ))) - -(defun ada-parse-prj-file (prj-file) - "Read PRJ-FILE, set project properties in `ada-xref-project-files'." - (let ((project (ada-default-prj-properties))) - - (setq prj-file (expand-file-name prj-file)) - (if (string= (file-name-extension prj-file) "gpr") - (setq project (ada-gnat-parse-gpr project prj-file)) - - (setq project (ada-parse-prj-file-1 prj-file project)) - ) - - ;; Store the project properties - (if (assoc prj-file ada-xref-project-files) - (setcdr (assoc prj-file ada-xref-project-files) project) - (add-to-list 'ada-xref-project-files (cons prj-file project))) - - (ada-xref-update-project-menu) - )) - -(defun ada-parse-prj-file-1 (prj-file project) - "Parse the Ada mode project file PRJ-FILE, set project properties in PROJECT. -Return new value of PROJECT." - (let ((ada-buffer (current-buffer)) - ;; fields that are lists or otherwise require special processing - ada_project_path casing comp_cmd check_cmd - debug_pre_cmd debug_post_cmd gpr_file make_cmd obj_dir src_dir run_cmd) - - ;; Give users a chance to use compiler-specific project file formats - (let ((buffer (run-hook-with-args-until-success - 'ada-load-project-hook prj-file))) - (unless buffer - ;; we load the project file with no warnings; if it does not - ;; exist, we stay in the Ada buffer; no project variable - ;; settings will be found. That works for the default - ;; "default.adp", which does not exist as a file. - (setq buffer (find-file-noselect prj-file nil))) - (set-buffer buffer)) - - (widen) - (goto-char (point-min)) - - ;; process each line - (while (not (eobp)) - - ;; ignore lines that don't have the format "name=value", put - ;; 'name', 'value' in match-string. - (if (looking-at "^\\([^=\n]+\\)=\\(.*\\)") - (cond - ;; FIXME: strip trailing spaces - ;; variable name alphabetical order - ((string= (match-string 1) "ada_project_path") - (cl-pushnew (expand-file-name - (substitute-in-file-name (match-string 2))) - ada_project_path :test #'equal)) - - ((string= (match-string 1) "build_dir") - (setq project - (plist-put project 'build_dir - (file-name-as-directory (match-string 2))))) - - ((string= (match-string 1) "casing") - (cl-pushnew (expand-file-name (substitute-in-file-name (match-string 2))) - casing :test #'equal)) - - ((string= (match-string 1) "check_cmd") - (cl-pushnew (match-string 2) check_cmd :test #'equal)) - - ((string= (match-string 1) "comp_cmd") - (cl-pushnew (match-string 2) comp_cmd :test #'equal)) - - ((string= (match-string 1) "debug_post_cmd") - (cl-pushnew (match-string 2) debug_post_cmd :test #'equal)) - - ((string= (match-string 1) "debug_pre_cmd") - (cl-pushnew (match-string 2) debug_pre_cmd :test #'equal)) - - ((string= (match-string 1) "gpr_file") - ;; expand now; path is relative to Emacs project file - (setq gpr_file (expand-file-name (match-string 2)))) - - ((string= (match-string 1) "make_cmd") - (cl-pushnew (match-string 2) make_cmd :test #'equal)) - - ((string= (match-string 1) "obj_dir") - (cl-pushnew (file-name-as-directory - (expand-file-name (match-string 2))) - obj_dir :test #'equal)) - - ((string= (match-string 1) "run_cmd") - (cl-pushnew (match-string 2) run_cmd :test #'equal)) - - ((string= (match-string 1) "src_dir") - (cl-pushnew (file-name-as-directory - (expand-file-name (match-string 2))) - src_dir :test #'equal)) - - (t - ;; any other field in the file is just copied - (setq project (plist-put project - (intern (match-string 1)) - (match-string 2)))))) - - (forward-line 1)) - - ;; done reading file - - ;; back to the user buffer - (set-buffer ada-buffer) - - ;; process accumulated lists - (if ada_project_path - (let ((sep (plist-get project 'ada_project_path_sep))) - (setq ada_project_path (reverse ada_project_path)) - (setq ada_project_path (mapconcat 'identity ada_project_path sep)) - (setq project (plist-put project 'ada_project_path ada_project_path)) - ;; env var needed now for ada-gnat-parse-gpr - (setenv "ADA_PROJECT_PATH" ada_project_path))) - - (if debug_post_cmd (setq project (plist-put project 'debug_post_cmd (reverse debug_post_cmd)))) - (if debug_pre_cmd (setq project (plist-put project 'debug_pre_cmd (reverse debug_pre_cmd)))) - (if casing (setq project (plist-put project 'casing (reverse casing)))) - (if check_cmd (setq project (plist-put project 'check_cmd (reverse check_cmd)))) - (if comp_cmd (setq project (plist-put project 'comp_cmd (reverse comp_cmd)))) - (if make_cmd (setq project (plist-put project 'make_cmd (reverse make_cmd)))) - (if run_cmd (setq project (plist-put project 'run_cmd (reverse run_cmd)))) - - (if gpr_file - (progn - (setq project (ada-gnat-parse-gpr project gpr_file)) - ;; append Ada source and object directories to others from Emacs project file - (setq src_dir (append (plist-get project 'src_dir) src_dir)) - (setq obj_dir (append (plist-get project 'obj_dir) obj_dir)) - (setq ada-xref-runtime-library-specs-path '() - ada-xref-runtime-library-ali-path '())) - ) - - ;; FIXME: gnatpath.exe doesn't output the runtime libraries, so always call ada-initialize-runtime-library - ;; if using a gpr_file, the runtime library directories are - ;; included in src_dir and obj_dir; otherwise they are in the - ;; 'runtime-library' variables. - ;; FIXME: always append to src_dir, obj_dir - (ada-initialize-runtime-library (or (ada-xref-get-project-field 'cross_prefix) "")) - ;;) - - (if obj_dir (setq project (plist-put project 'obj_dir (reverse obj_dir)))) - (if src_dir (setq project (plist-put project 'src_dir (reverse src_dir)))) - - project - )) - -(defun ada-select-prj-file (file) - "Select FILE as the current project file." - (interactive) - (setq ada-prj-default-project-file (expand-file-name file)) - - (let ((casing (ada-xref-get-project-field 'casing))) - (if casing - (progn - ;; FIXME: use ada-get-absolute-dir here - (setq ada-case-exception-file casing) - (ada-case-read-exceptions)))) - - (let ((ada_project_path (ada-xref-get-project-field 'ada_project_path))) - (if ada_project_path - ;; FIXME: use ada-get-absolute-dir, mapconcat here - (setenv "ADA_PROJECT_PATH" ada_project_path))) - - (setq compilation-search-path (ada-xref-get-src-dir-field)) - - (setq ada-search-directories-internal - ;; FIXME: why do we need directory-file-name here? - (append (mapcar 'directory-file-name compilation-search-path) - ada-search-directories)) - - ;; return t, for decent display in message buffer when called interactively - t) - -(defun ada-find-references (&optional pos arg local-only) - "Find all references to the entity under POS. -Calls gnatfind to find the references. -If ARG is non-nil, the contents of the old *gnatfind* buffer is preserved. -If LOCAL-ONLY is non-nil, only declarations in the current file are returned." - (interactive "d\nP") - (ada-require-project-file) - - (let* ((identlist (ada-read-identifier pos)) - (alifile (ada-get-ali-file-name (ada-file-of identlist))) - (process-environment (ada-set-environment))) - - (set-buffer (get-file-buffer (ada-file-of identlist))) - - ;; if the file is more recent than the executable - (if (or (buffer-modified-p (current-buffer)) - (file-newer-than-file-p (ada-file-of identlist) alifile)) - (ada-find-any-references (ada-name-of identlist) - (ada-file-of identlist) - nil nil local-only arg) - (ada-find-any-references (ada-name-of identlist) - (ada-file-of identlist) - (ada-line-of identlist) - (ada-column-of identlist) local-only arg))) - ) - -(defun ada-find-local-references (&optional pos arg) - "Find all references to the entity under POS. -Calls `gnatfind' to find the references. -If ARG is non-nil, the contents of the old *gnatfind* buffer is preserved." - (interactive "d\nP") - (ada-find-references pos arg t)) - -(defconst ada-gnatfind-buffer-name "*gnatfind*") - -(defun ada-find-any-references - (entity &optional file line column local-only append) - "Search for references to any entity whose name is ENTITY. -ENTITY was first found the location given by FILE, LINE and COLUMN. -If LOCAL-ONLY is non-nil, then list only the references in FILE, -which is much faster. -If APPEND is non-nil, then append the output of the command to the -existing buffer `*gnatfind*', if there is one." - (interactive "sEntity name: ") - (ada-require-project-file) - - ;; Prepare the gnatfind command. Note that we must protect the quotes - ;; around operators, so that they are correctly handled and can be - ;; processed (gnatfind \"+\":...). - (let* ((quote-entity - (if (= (aref entity 0) ?\") - (if ada-on-ms-windows - (concat "\\\"" (substring entity 1 -1) "\\\"") - (concat "'\"" (substring entity 1 -1) "\"'")) - entity)) - (switches (ada-xref-get-project-field 'gnatfind_opt)) - ;; FIXME: use gpr_file - (cross-prefix (ada-xref-get-project-field 'cross_prefix)) - (command (concat cross-prefix "gnat find " switches " " - quote-entity - (if file (concat ":" (file-name-nondirectory file))) - (if line (concat ":" line)) - (if column (concat ":" column)) - (if local-only (concat " " (file-name-nondirectory file))) - )) - old-contents) - - ;; If a project file is defined, use it - (if (and ada-prj-default-project-file - (not (string= ada-prj-default-project-file ""))) - (if (string-equal (file-name-extension ada-prj-default-project-file) - "gpr") - (setq command (concat command " -P\"" ada-prj-default-project-file "\"")) - (setq command (concat command " -p\"" ada-prj-default-project-file "\"")))) - - (if (and append (get-buffer ada-gnatfind-buffer-name)) - (with-current-buffer "*gnatfind*" - (setq old-contents (buffer-string)))) - - (let ((compilation-error "reference")) - (compilation-start command 'compilation-mode (lambda (_mode) ada-gnatfind-buffer-name))) - - ;; Hide the "Compilation" menu - (with-current-buffer ada-gnatfind-buffer-name - (local-unset-key [menu-bar compilation-menu]) - - (if old-contents - (progn - (goto-char 1) - (setq buffer-read-only nil) - (insert old-contents) - (setq buffer-read-only t) - (goto-char (point-max))))) - ) - ) - -(defalias 'ada-change-prj (symbol-function 'ada-set-default-project-file)) - -;; ----- Identifier Completion -------------------------------------------- -(defun ada-complete-identifier (pos) - "Try to complete the identifier around POS, using compiler cross-reference information." - (interactive "d") - (ada-require-project-file) - - ;; Initialize function-local variables and jump to the .ali buffer - ;; Note that for regexp search is case insensitive too - (let* ((curbuf (current-buffer)) - (identlist (ada-read-identifier pos)) - (sofar (concat "^[0-9]+[a-zA-Z][0-9]+[ *]\\(" - (regexp-quote (ada-name-of identlist)) - "[a-zA-Z0-9_]*\\)")) - (completed nil) - (symalist nil)) - - ;; Open the .ali file - (set-buffer (ada-get-ali-buffer (buffer-file-name))) - (goto-char (point-max)) - - ;; build an alist of possible completions - (while (re-search-backward sofar nil t) - (setq symalist (cons (cons (match-string 1) nil) symalist))) - - (setq completed (try-completion "" symalist)) - - ;; kills .ali buffer - (kill-buffer nil) - - ;; deletes the incomplete identifier in the buffer - (set-buffer curbuf) - (looking-at "[a-zA-Z0-9_]+") - (replace-match "") - ;; inserts the completed symbol - (insert completed) - )) - -;; ----- Cross-referencing ---------------------------------------- - -(defun ada-point-and-xref () - "Jump to the declaration of the entity below the cursor." - (interactive) - (mouse-set-point last-input-event) - (ada-goto-declaration (point))) - -(defun ada-point-and-xref-body () - "Jump to the body of the entity under the cursor." - (interactive) - (mouse-set-point last-input-event) - (ada-goto-body (point))) - -(defun ada-goto-body (pos &optional other-frame) - "Display the body of the entity around POS. -OTHER-FRAME non-nil means display in another frame. -If the entity doesn't have a body, display its declaration. -As a side effect, the buffer for the declaration is also open." - (interactive "d") - (ada-goto-declaration pos other-frame) - - ;; Temporarily force the display in the same buffer, since we - ;; already changed previously - (let ((ada-xref-other-buffer nil)) - (ada-goto-declaration (point) nil))) - -(defun ada-goto-declaration (pos &optional other-frame) - "Display the declaration of the identifier around POS. -The declaration is shown in another buffer if `ada-xref-other-buffer' is -non-nil. -If OTHER-FRAME is non-nil, display the cross-reference in another frame." - (interactive "d") - (ada-require-project-file) - (push-mark pos) - (ada-xref-push-pos (buffer-file-name) pos) - - ;; First try the standard algorithm by looking into the .ali file, but if - ;; that file was too old or even did not exist, try to look in the whole - ;; object path for a possible location. - (let ((identlist (ada-read-identifier pos))) - (condition-case err - (ada-find-in-ali identlist other-frame) - ;; File not found: print explicit error message - (ada-error-file-not-found - (message "%s%s" (error-message-string err) (nthcdr 1 err))) - - (error - (let ((ali-file (ada-get-ali-file-name (ada-file-of identlist)))) - - ;; If the ALI file was up-to-date, then we probably have a predefined - ;; entity, whose references are not given by GNAT - (if (and (file-exists-p ali-file) - (file-newer-than-file-p ali-file (ada-file-of identlist))) - (message "No cross-reference found -- may be a predefined entity.") - - ;; Else, look in every ALI file, except if the user doesn't want that - (if ada-xref-search-with-egrep - (ada-find-in-src-path identlist other-frame) - (message "Cross-referencing information is not up-to-date; please recompile.") - ))))))) - -(defun ada-goto-declaration-other-frame (pos) - "Display the declaration of the identifier around POS. -The declaration is shown in another frame if `ada-xref-other-buffer' is -non-nil." - (interactive "d") - (ada-goto-declaration pos t)) - -(defun ada-remote (command) - "Return the remote version of COMMAND, or COMMAND if remote_machine is nil." - (let ((machine (ada-xref-get-project-field 'remote_machine))) - (if (or (not machine) (string= machine "")) - command - (format "%s %s '(%s)'" - remote-shell-program - machine - command)))) - -(defun ada-get-absolute-dir-list (dir-list root-dir) - "Return the list of absolute directories found in DIR-LIST. -If a directory is a relative directory, ROOT-DIR is prepended. -Project and environment variables are substituted." - (mapcar (lambda (x) (expand-file-name x (ada-treat-cmd-string root-dir))) dir-list)) - -(defun ada-set-environment () - "Prepare an environment for Ada compilation. -This returns a new value to use for `process-environment', -but does not actually put it into use. -It modifies the source path and object path with the values found in the -project file." - (let ((include (getenv "ADA_INCLUDE_PATH")) - (objects (getenv "ADA_OBJECTS_PATH")) - (build-dir (ada-xref-get-project-field 'build_dir))) - (if include - (setq include (concat path-separator include))) - (if objects - (setq objects (concat path-separator objects))) - (cons - (concat "ADA_INCLUDE_PATH=" - (mapconcat (lambda(x) (expand-file-name x build-dir)) - (ada-xref-get-project-field 'src_dir) - path-separator) - include) - (cons - (concat "ADA_OBJECTS_PATH=" - (mapconcat (lambda(x) (expand-file-name x build-dir)) - (ada-xref-get-project-field 'obj_dir) - path-separator) - objects) - process-environment)))) - -(defun ada-compile-application (&optional arg) - "Compile the application, using the command found in the project file. -If ARG is not nil, ask for user confirmation." - (interactive "P") - (ada-require-project-file) - (let ((cmd (ada-xref-get-project-field 'make_cmd)) - (process-environment (ada-set-environment)) - (compilation-scroll-output t)) - - (setq compilation-search-path (ada-xref-get-src-dir-field)) - - ;; If no project file was found, ask the user - (unless cmd - (setq cmd '("") arg t)) - - ;; Make a single command from the list of commands, including the - ;; commands to run it on a remote machine. - (setq cmd (ada-remote (mapconcat 'identity cmd ada-command-separator))) - - (if (or ada-xref-confirm-compile arg) - (setq cmd (read-from-minibuffer "enter command to compile: " cmd))) - - ;; Insert newlines so as to separate the name of the commands to run - ;; and the output of the commands. This doesn't work with cmdproxy.exe, - ;; which gets confused by newline characters. - (if (not (string-match ".exe" shell-file-name)) - (setq cmd (concat cmd "\n\n"))) - - (compile (ada-quote-cmd cmd)))) - -(defun ada-set-main-compile-application () - "Set main project variable to current buffer, build main." - (interactive) - (ada-require-project-file) - (let* ((file (buffer-file-name (current-buffer))) - main) - (if (not file) - (error "No file for current buffer") - - (setq main - (if file - (file-name-nondirectory - (file-name-sans-extension file)) - "")) - (ada-xref-set-project-field 'main main) - (ada-compile-application)))) - -(defun ada-compile-current (&optional arg prj-field) - "Recompile the current file. -If ARG is non-nil, ask for user confirmation of the command. -PRJ-FIELD is the name of the field to use in the project file to get the -command, and should be either `comp_cmd' (default) or `check_cmd'." - (interactive "P") - (ada-require-project-file) - (let* ((field (if prj-field prj-field 'comp_cmd)) - (cmd (ada-xref-get-project-field field)) - (process-environment (ada-set-environment)) - (compilation-scroll-output t)) - - (unless cmd - (setq cmd '("") arg t)) - - ;; Make a single command from the list of commands, including the - ;; commands to run it on a remote machine. - (setq cmd (ada-remote (mapconcat 'identity cmd ada-command-separator))) - - ;; If no project file was found, ask the user - (if (or ada-xref-confirm-compile arg) - (setq cmd (read-from-minibuffer "enter command to compile: " cmd))) - - (compile (ada-quote-cmd cmd)))) - -(defun ada-check-current (&optional arg) - "Check the current file for syntax errors. -If ARG is non-nil, ask for user confirmation of the command." - (interactive "P") - (ada-compile-current arg 'check_cmd)) - -(defun ada-run-application (&optional arg) - "Run the application. -If ARG is non-nil, ask for user confirmation." - (interactive) - (ada-require-project-file) - - (let ((machine (ada-xref-get-project-field 'cross_prefix))) - (if (and machine (not (string= machine ""))) - (error "This feature is not supported yet for cross environments"))) - - (let ((command (ada-xref-get-project-field 'run_cmd))) - - ;; Guess the command if it wasn't specified - (if (not command) - (setq command (list (file-name-sans-extension (buffer-name))))) - - ;; Modify the command to run remotely - (setq command (ada-remote (mapconcat 'identity command - ada-command-separator))) - - ;; Ask for the arguments to the command if required - (if (or ada-xref-confirm-compile arg) - (setq command (read-from-minibuffer "Enter command to execute: " - command))) - - ;; Run the command - (with-current-buffer (get-buffer-create "*run*") - (setq buffer-read-only nil) - - (erase-buffer) - (start-process "run" (current-buffer) shell-file-name - "-c" command) - (comint-mode) - ;; Set these two variables to their default values, since otherwise - ;; the output buffer is scrolled so that only the last output line - ;; is visible at the top of the buffer. - (set (make-local-variable 'scroll-step) 0) - (set (make-local-variable 'scroll-conservatively) 0) - ) - (display-buffer "*run*") - - ;; change to buffer *run* for interactive programs - (other-window 1) - (switch-to-buffer "*run*") - )) - -(defun ada-gdb-application (&optional arg executable-name) - "Start the debugger on the application. -If ARG is non-nil, ask the user to confirm the command. -EXECUTABLE-NAME, if non-nil, is debugged instead of the file specified in the -project file." - (interactive "P") - (ada-require-project-file) - (let ((buffer (current-buffer)) - cmd pre-cmd post-cmd) - (setq cmd (if executable-name - (concat ada-prj-default-debugger " " executable-name) - (ada-xref-get-project-field 'debug_cmd)) - pre-cmd (ada-xref-get-project-field 'debug_pre_cmd) - post-cmd (ada-xref-get-project-field 'debug_post_cmd)) - - ;; If the command was not given in the project file, start a bare gdb - (if (not cmd) - (setq cmd (concat ada-prj-default-debugger - " " - (or executable-name - (file-name-sans-extension (buffer-file-name)))))) - - ;; For gvd, add an extra switch so that the Emacs window is completely - ;; swallowed inside the Gvd one - (if (and ada-tight-gvd-integration - (string-match "^[^ \t]*gvd" cmd)) - ;; Start a new frame, so that when gvd exists we do not kill Emacs - ;; We make sure that gvd swallows the new frame, not the one the - ;; user has been using until now - ;; The frame is made invisible initially, so that GtkPlug gets a - ;; chance to fully manage it. Then it works fine with Enlightenment - ;; as well - (let ((frame (make-frame '((visibility . nil))))) - (setq cmd (concat - cmd " --editor-window=" - (cdr (assoc 'outer-window-id (frame-parameters frame))))) - (select-frame frame))) - - ;; Add a -fullname switch - ;; Use the remote machine - (setq cmd (ada-remote (concat cmd " -fullname "))) - - ;; Ask for confirmation if required - (if (or arg ada-xref-confirm-compile) - (setq cmd (read-from-minibuffer "enter command to debug: " cmd))) - - (let ((old-comint-exec (symbol-function 'comint-exec))) - - ;; Do not add -fullname, since we can have a 'rsh' command in front. - ;; FIXME: This is evil but luckily a nop under Emacs-21.3.50 ! -stef - (fset 'gud-gdb-massage-args (lambda (_file args) args)) - - (setq pre-cmd (mapconcat 'identity pre-cmd ada-command-separator)) - (if (not (equal pre-cmd "")) - (setq pre-cmd (concat pre-cmd ada-command-separator))) - - (setq post-cmd (mapconcat 'identity post-cmd "\n")) - (if post-cmd - (setq post-cmd (concat post-cmd "\n"))) - - - ;; Temporarily replaces the definition of `comint-exec' so that we - ;; can execute commands before running gdb. - ;; FIXME: This is evil and not temporary !!! -stef - (fset 'comint-exec - `(lambda (buffer name command startfile switches) - (let (compilation-buffer-name-function) - (save-excursion - (setq compilation-buffer-name-function - (lambda(x) (buffer-name buffer))) - (compile (ada-quote-cmd - (concat ,pre-cmd - command " " - (mapconcat 'identity switches " ")))))) - )) - - ;; Tight integration should force the tty mode - (if (and (string-match "gvd" (comint-arguments cmd 0 0)) - ada-tight-gvd-integration - (not (string-match "--tty" cmd))) - (setq cmd (concat cmd "--tty"))) - - (if (and (string-match "jdb" (comint-arguments cmd 0 0)) - (boundp 'jdb)) - (funcall (symbol-function 'jdb) cmd) - (gdb cmd)) - - ;; Restore the standard fset command (or for instance C-U M-x shell - ;; wouldn't work anymore - - (fset 'comint-exec old-comint-exec) - - ;; Send post-commands to the debugger - (process-send-string (get-buffer-process (current-buffer)) post-cmd) - - ;; Move to the end of the debugger buffer, so that it is automatically - ;; scrolled from then on. - (goto-char (point-max)) - - ;; Display both the source window and the debugger window (the former - ;; above the latter). No need to show the debugger window unless it - ;; is going to have some relevant information. - (if (or (not (string-match "gvd" (comint-arguments cmd 0 0))) - (string-match "--tty" cmd)) - (split-window-below)) - (switch-to-buffer buffer) - ))) - -(defun ada-reread-prj-file (&optional filename) - "Reread either the current project, or FILENAME if non-nil. -If FILENAME is non-nil, set it as current project." - (interactive "P") - (if (not filename) - (setq filename ada-prj-default-project-file)) - (ada-parse-prj-file filename) - (ada-select-prj-file filename)) - -;; ------ Private routines - -(defun ada-xref-current (file &optional ali-file-name) - "Update the cross-references for FILE. -This in fact recompiles FILE to create ALI-FILE-NAME. -This function returns the name of the file that was recompiled to generate -the cross-reference information. Note that the ali file can then be deduced -by replacing the file extension with `.ali'." - ;; kill old buffer - (if (and ali-file-name - (get-file-buffer ali-file-name)) - (kill-buffer (get-file-buffer ali-file-name))) - - (let* ((name (convert-standard-filename file)) - (body-name (or (ada-get-body-name name) name))) - - ;; Always recompile the body when we can. We thus temporarily switch to a - ;; buffer than contains the body of the unit - (save-excursion - (let ((body-visible (find-buffer-visiting body-name)) - process) - (if body-visible - (set-buffer body-visible) - (find-file body-name)) - - ;; Execute the compilation. Note that we must wait for the end of the - ;; process, or the ALI file would still not be available. - ;; Unfortunately, the underlying `compile' command that we use is - ;; asynchronous. - (ada-compile-current) - (setq process (get-buffer-process "*compilation*")) - - (while (and process - (not (equal (process-status process) 'exit))) - (sit-for 1)) - - ;; remove the buffer for the body if it wasn't there before - (unless body-visible - (kill-buffer (find-buffer-visiting body-name))) - )) - body-name)) - -(defun ada-find-file-in-dir (file dir-list) - "Search for FILE in DIR-LIST." - (let (found) - (while (and (not found) dir-list) - (setq found (concat (file-name-as-directory (car dir-list)) - (file-name-nondirectory file))) - - (unless (file-exists-p found) - (setq found nil)) - (setq dir-list (cdr dir-list))) - found)) - -(defun ada-find-ali-file-in-dir (file) - "Find the ali file FILE, searching obj_dir for the current project. -Adds build_dir in front of the search path to conform to gnatmake's behavior, -and the standard runtime location at the end." - (ada-find-file-in-dir file (ada-xref-get-obj-dir-field))) - -(defun ada-find-src-file-in-dir (file) - "Find the source file FILE, searching src_dir for the current project. -Adds the standard runtime location at the end of the search path to conform -to gnatmake's behavior." - (ada-find-file-in-dir file (ada-xref-get-src-dir-field))) - -(defun ada-get-ali-file-name (file) - "Create the ali file name for the Ada file FILE. -The file is searched for in every directory shown in the obj_dir lines of -the project file." - - ;; This function has to handle the special case of non-standard - ;; file names (i.e. not .adb or .ads) - ;; The trick is the following: - ;; 1- replace the extension of the current file with .ali, - ;; and look for this file - ;; 2- If this file is found: - ;; grep the "^U" lines, and make sure we are not reading the - ;; .ali file for a spec file. If we are, go to step 3. - ;; 3- If the file is not found or step 2 failed: - ;; find the name of the "other file", ie the body, and look - ;; for its associated .ali file by substituting the extension - ;; - ;; We must also handle the case of separate packages and subprograms: - ;; 4- If no ali file was found, we try to modify the file name by removing - ;; everything after the last '-' or '.' character, so as to get the - ;; ali file for the parent unit. If we found an ali file, we check that - ;; it indeed contains the definition for the separate entity by checking - ;; the 'D' lines. This is done repeatedly, in case the direct parent is - ;; also a separate. - - (with-current-buffer (get-file-buffer file) - (let ((short-ali-file-name (concat (file-name-base file) ".ali")) - ali-file-name - is-spec) - - ;; If we have a non-standard file name, and this is a spec, we first - ;; look for the .ali file of the body, since this is the one that - ;; contains the most complete information. If not found, we will do what - ;; we can with the .ali file for the spec... - - (if (not (string= (file-name-extension file) "ads")) - (let ((specs ada-spec-suffixes)) - (while specs - (if (string-match (concat (regexp-quote (car specs)) "$") - file) - (setq is-spec t)) - (setq specs (cdr specs))))) - - (if is-spec - (setq ali-file-name - (ada-find-ali-file-in-dir - (concat (file-name-base (ada-other-file-name)) ".ali")))) - - - (setq ali-file-name - (or ali-file-name - - ;; Else we take the .ali file associated with the unit - (ada-find-ali-file-in-dir short-ali-file-name) - - - ;; else we did not find the .ali file Second chance: in case - ;; the files do not have standard names (such as for instance - ;; file_s.ada and file_b.ada), try to go to the other file - ;; and look for its ali file - (ada-find-ali-file-in-dir - (concat (file-name-base (ada-other-file-name)) ".ali")) - - - ;; If we still don't have an ali file, try to get the one - ;; from the parent unit, in case we have a separate entity. - (let ((parent-name (file-name-base file))) - - (while (and (not ali-file-name) - (string-match "^\\(.*\\)[.-][^.-]*" parent-name)) - - (setq parent-name (match-string 1 parent-name)) - (setq ali-file-name (ada-find-ali-file-in-dir - (concat parent-name ".ali"))) - ) - ali-file-name))) - - ;; If still not found, try to recompile the file - (if (not ali-file-name) - ;; Recompile only if the user asked for this, and search the ali - ;; filename again. We avoid a possible infinite recursion by - ;; temporarily disabling the automatic compilation. - - (if ada-xref-create-ali - (setq ali-file-name - (concat (file-name-sans-extension (ada-xref-current file)) - ".ali")) - - (error "`.ali' file not found; recompile your source file")) - - - ;; same if the .ali file is too old and we must recompile it - (if (and (file-newer-than-file-p file ali-file-name) - ada-xref-create-ali) - (ada-xref-current file ali-file-name))) - - ;; Always return the correct absolute file name - (expand-file-name ali-file-name)) - )) - -(defun ada-get-ada-file-name (file original-file) - "Create the complete file name (+directory) for FILE. -The original file (where the user was) is ORIGINAL-FILE. -Search in project file for possible paths." - - (save-excursion - - ;; If the buffer for original-file, use it to get the values from the - ;; project file, otherwise load the file and its project file - (let ((buffer (get-file-buffer original-file))) - (if buffer - (set-buffer buffer) - (find-file original-file))) - - ;; we choose the first possible completion and we - ;; return the absolute file name - (let ((filename (ada-find-src-file-in-dir file))) - (if filename - (expand-file-name filename) - (signal 'ada-error-file-not-found (file-name-nondirectory file))) - ))) - -(defun ada-find-file-number-in-ali (file) - "Return the file number for FILE in the associated ali file." - (set-buffer (ada-get-ali-buffer file)) - (goto-char (point-min)) - - (let ((begin (re-search-forward "^D"))) - (beginning-of-line) - (re-search-forward (concat "^D " (file-name-nondirectory file))) - (count-lines begin (point)))) - -(defun ada-read-identifier (pos) - "Return the identlist around POS and switch to the .ali buffer. -The returned list represents the entity, and can be manipulated through the -macros `ada-name-of', `ada-line-of', `ada-column-of', `ada-file-of',..." - - ;; If at end of buffer (e.g the buffer is empty), error - (if (>= (point) (point-max)) - (error "No identifier on point")) - - ;; goto first character of the identifier/operator (skip backward < and > - ;; since they are part of multiple character operators - (goto-char pos) - (skip-chars-backward "a-zA-Z0-9_<>") - - ;; check if it really is an identifier - (if (ada-in-comment-p) - (error "Inside comment")) - - (let (identifier identlist) - ;; Just in front of a string => we could have an operator declaration, - ;; as in "+", "-", .. - (if (= (char-after) ?\") - (forward-char 1)) - - ;; if looking at an operator - ;; This is only true if: - ;; - the symbol is +, -, ... - ;; - the symbol is made of letters, and not followed by _ or a letter - (if (and (looking-at ada-operator-re) - (or (not (= (char-syntax (char-after)) ?w)) - (not (or (= (char-syntax (char-after (match-end 0))) ?w) - (= (char-after (match-end 0)) ?_))))) - (progn - (if (and (= (char-before) ?\") - (= (char-after (+ (length (match-string 0)) (point))) ?\")) - (forward-char -1)) - (setq identifier (regexp-quote (concat "\"" (match-string 0) "\"")))) - - (if (ada-in-string-p) - (error "Inside string or character constant")) - (if (looking-at (concat ada-keywords "[^a-zA-Z_]")) - (error "No cross-reference available for reserved keyword")) - (if (looking-at "[a-zA-Z0-9_]+") - (setq identifier (match-string 0)) - (error "No identifier around"))) - - ;; Build the identlist - (setq identlist (ada-make-identlist)) - (ada-set-name identlist (downcase identifier)) - (ada-set-line identlist - (number-to-string (count-lines 1 (point)))) - (ada-set-column identlist - (number-to-string (1+ (current-column)))) - (ada-set-file identlist (buffer-file-name)) - identlist - )) - -(defun ada-get-all-references (identlist) - "Complete IDENTLIST with definition file and places where it is referenced. -Information is extracted from the ali file." - - (let ((ali-buffer (ada-get-ali-buffer (ada-file-of identlist))) - declaration-found) - (set-buffer ali-buffer) - (goto-char (point-min)) - (ada-set-on-declaration identlist nil) - - ;; First attempt: we might already be on the declaration of the identifier - ;; We want to look for the declaration only in a definite interval (after - ;; the "^X ..." line for the current file, and before the next "^X" line - - (if (re-search-forward - (concat "^X [0-9]+ " (file-name-nondirectory (ada-file-of identlist))) - nil t) - (let ((bound (save-excursion (re-search-forward "^X " nil t)))) - (setq declaration-found - (re-search-forward - (concat "^" (ada-line-of identlist) - "." (ada-column-of identlist) - "[ *]" (ada-name-of identlist) - "[{[(<= ]?\\(.*\\)$") bound t)) - (if declaration-found - (ada-set-on-declaration identlist t)) - )) - - ;; If declaration is still nil, then we were not on a declaration, and - ;; have to fall back on other algorithms - - (unless declaration-found - - ;; Since we already know the number of the file, search for a direct - ;; reference to it - (goto-char (point-min)) - (setq declaration-found t) - (ada-set-ali-index - identlist - (number-to-string (ada-find-file-number-in-ali - (ada-file-of identlist)))) - (unless (re-search-forward (concat (ada-ali-index-of identlist) - "|\\([0-9]+[^0-9][0-9]+\\(\n\\.\\)? \\)*" - (ada-line-of identlist) - "[^etpzkd<>=^]" - (ada-column-of identlist) "\\>") - nil t) - - ;; if we did not find it, it may be because the first reference - ;; is not required to have a 'unit_number|' item included. - ;; Or maybe we are already on the declaration... - (unless (re-search-forward - (concat - "^[0-9]+.[0-9]+[ *]" - (ada-name-of identlist) - "[ <{=([]\\(.\\|\n\\.\\)*\\<" - (ada-line-of identlist) - "[^0-9]" - (ada-column-of identlist) "\\>") - nil t) - - ;; If still not found, then either the declaration is unknown - ;; or the source file has been modified since the ali file was - ;; created - (setq declaration-found nil) - ) - ) - - ;; Last check to be completely sure we have found the correct line (the - ;; ali might not be up to date for instance) - (if declaration-found - (progn - (beginning-of-line) - ;; while we have a continuation line, go up one line - (while (looking-at "^\\.") - (forward-line -1) - (beginning-of-line)) - (unless (looking-at (concat "[0-9]+.[0-9]+[ *]" - (ada-name-of identlist) "[ <{=([]")) - (setq declaration-found nil)))) - - ;; Still no success ! The ali file must be too old, and we need to - ;; use a basic algorithm based on guesses. Note that this only happens - ;; if the user does not want us to automatically recompile files - ;; automatically - (unless declaration-found - (if (ada-xref-find-in-modified-ali identlist) - (setq declaration-found t) - ;; No more idea to find the declaration. Give up - (progn - (kill-buffer ali-buffer) - - (error "No declaration of %s found" (ada-name-of identlist)) - ))) - ) - - - ;; Now that we have found a suitable line in the .ali file, get the - ;; information available - (beginning-of-line) - (if declaration-found - (let ((current-line (buffer-substring - (point) (point-at-eol)))) - (save-excursion - (forward-line 1) - (beginning-of-line) - (while (looking-at "^\\.\\(.*\\)") - (setq current-line (concat current-line (match-string 1))) - (forward-line 1)) - ) - - (if (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9_.-]+\\)" nil t) - - ;; If we can find the file - (condition-case err - (ada-set-declare-file - identlist - (ada-get-ada-file-name (match-string 1) - (ada-file-of identlist))) - - ;; Else clean up the ali file - (ada-error-file-not-found - (signal (car err) (cdr err))) - (error - (kill-buffer ali-buffer) - (error (error-message-string err))) - )) - - (ada-set-references identlist current-line) - )) - )) - -(defun ada-xref-find-in-modified-ali (identlist) - "Find the matching position for IDENTLIST in the current ali buffer. -This function is only called when the file was not up-to-date, so we need -to make some guesses. -This function is disabled for operators, and only works for identifiers." - - (unless (= (string-to-char (ada-name-of identlist)) ?\") - (progn - (let ((declist '()) ;;; ( (line_in_ali_file line_in_ada) ( ... )) - (my-regexp (concat "[ *]" - (regexp-quote (ada-name-of identlist)) " ")) - (line-ada "--") - (col-ada "--") - (line-ali 0) - (len 0) - (choice 0) - (ali-buffer (current-buffer))) - - (goto-char (point-max)) - (while (re-search-backward my-regexp nil t) - (save-excursion - (setq line-ali (count-lines 1 (point))) - (beginning-of-line) - ;; have a look at the line and column numbers - (if (looking-at "^\\([0-9]+\\).\\([0-9]+\\)[ *]") - (progn - (setq line-ada (match-string 1)) - (setq col-ada (match-string 2))) - (setq line-ada "--") - (setq col-ada "--") - ) - ;; construct a list with the file names and the positions within - (if (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9._-]+\\)" nil t) - (cl-pushnew (list line-ali (match-string 1) line-ada col-ada) - declist :test #'equal) - ) - ) - ) - - ;; how many possible declarations have we found ? - (setq len (length declist)) - (cond - ;; none => error - ((= len 0) - (kill-buffer (current-buffer)) - (error "No declaration of %s recorded in .ali file" - (ada-name-of identlist))) - ;; one => should be the right one - ((= len 1) - (goto-char (point-min)) - (forward-line (1- (caar declist)))) - - ;; more than one => display choice list - (t - (save-window-excursion - (with-output-to-temp-buffer "*choice list*" - - (princ "Identifier is overloaded and Xref information is not up to date.\n") - (princ "Possible declarations are:\n\n") - (princ " no. in file at line col\n") - (princ " --- --------------------- ---- ----\n") - (let ((counter 0)) - (while (< counter len) - (princ (format " %2d) %-21s %4s %4s\n" - (1+ counter) - (ada-get-ada-file-name - (nth 1 (nth counter declist)) - (ada-file-of identlist)) - (nth 2 (nth counter declist)) - (nth 3 (nth counter declist)) - )) - (setq counter (1+ counter)) - ) ; end of while - ) ; end of let - ) ; end of with-output-to ... - (setq choice nil) - (while (or - (not choice) - (not (integerp choice)) - (< choice 1) - (> choice len)) - (setq choice - (string-to-number - (read-from-minibuffer "Enter No. of your choice: ")))) - ) - (set-buffer ali-buffer) - (goto-char (point-min)) - (forward-line (1- (car (nth (1- choice) declist)))) - )))))) - - -(defun ada-find-in-ali (identlist &optional other-frame) - "Look in the .ali file for the definition of the identifier in IDENTLIST. -If OTHER-FRAME is non-nil, and `ada-xref-other-buffer' is non-nil, -opens a new window to show the declaration." - - (ada-get-all-references identlist) - (let ((ali-line (ada-references-of identlist)) - (locations nil) - (start 0) - file line col) - - ;; Note: in some cases, an entity can have multiple references to the - ;; bodies (this is for instance the case for a separate subprogram, that - ;; has a reference both to the stub and to the real body). - ;; In that case, we simply go to each one in turn. - - ;; Get all the possible locations - (string-match "^\\([0-9]+\\)[a-zA-Z+*]\\([0-9]+\\)[ *]" ali-line) - (setq locations (list (list (match-string 1 ali-line) ;; line - (match-string 2 ali-line) ;; column - (ada-declare-file-of identlist)))) - (while (string-match "\\([0-9]+\\)[bc]\\(<[^>]+>\\)?\\([0-9]+\\)" - ali-line start) - (setq line (match-string 1 ali-line) - col (match-string 3 ali-line) - start (match-end 3)) - - ;; it there was a file number in the same line - ;; Make sure we correctly handle the case where the first file reference - ;; on the line is the type reference. - ;; 1U2 T(2|2r3) 34r23 - (if (string-match (concat "[^{(<0-9]\\([0-9]+\\)|\\([^|bc]+\\)?" - (match-string 0 ali-line)) - ali-line) - (let ((file-number (match-string 1 ali-line))) - (goto-char (point-min)) - (re-search-forward "^D \\([a-zA-Z0-9_.-]+\\)" nil t - (string-to-number file-number)) - (setq file (match-string 1)) - ) - ;; Else get the nearest file - (setq file (ada-declare-file-of identlist))) - - (setq locations (append locations (list (list line col file))))) - - ;; Add the specs at the end again, so that from the last body we go to - ;; the specs - (setq locations (append locations (list (car locations)))) - - ;; Find the new location we want to go to. - ;; If we are on none of the locations listed, we simply go to the specs. - - (setq line (caar locations) - col (nth 1 (car locations)) - file (nth 2 (car locations))) - - (while locations - (if (and (string= (caar locations) (ada-line-of identlist)) - (string= (nth 1 (car locations)) (ada-column-of identlist)) - (string= (file-name-nondirectory (nth 2 (car locations))) - (file-name-nondirectory (ada-file-of identlist)))) - (setq locations (cadr locations) - line (car locations) - col (nth 1 locations) - file (nth 2 locations) - locations nil) - (setq locations (cdr locations)))) - - ;; Find the file in the source path - (setq file (ada-get-ada-file-name file (ada-file-of identlist))) - - ;; Kill the .ali buffer - (kill-buffer (current-buffer)) - - ;; Now go to the buffer - (ada-xref-change-buffer file - (string-to-number line) - (1- (string-to-number col)) - identlist - other-frame) - )) - -(defun ada-find-in-src-path (identlist &optional other-frame) - "More general function for cross-references. -This function should be used when the standard algorithm that parses the -.ali file has failed, either because that file was too old or even did not -exist. -This function attempts to find the possible declarations for the identifier -anywhere in the object path. -This command requires the external `grep' program to be available. - -This works well when one is using an external library and wants to find -the declaration and documentation of the subprograms one is using." -;; FIXME: what does this function do? - (let (list - (dirs (ada-xref-get-obj-dir-field)) - (regexp (concat "[ *]" (ada-name-of identlist))) - line column - choice - file) - - ;; Do the grep in all the directories. We do multiple shell - ;; commands instead of one in case there is no .ali file in one - ;; of the directory and the shell stops because of that. - - (with-current-buffer (get-buffer-create "*grep*") - (while dirs - (insert (shell-command-to-string - (concat - "grep -E -i -h " - (shell-quote-argument (concat "^X|" regexp "( |$)")) - " " - (shell-quote-argument (file-name-as-directory (car dirs))) - "*.ali"))) - (setq dirs (cdr dirs))) - - ;; Now parse the output - (setq case-fold-search t) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (save-excursion - (beginning-of-line) - (if (not (= (char-after) ?X)) - (progn - (looking-at "\\([0-9]+\\).\\([0-9]+\\)") - (setq line (match-string 1) - column (match-string 2)) - (re-search-backward "^X [0-9]+ \\(.*\\)$") - (setq file (list (match-string 1) line column)) - - ;; There could be duplicate choices, because of the structure - ;; of the .ali files - (unless (member file list) - (setq list (append list (list file)))))))) - - ;; Current buffer is still "*grep*" - (kill-buffer "*grep*") - ) - - ;; Now display the list of possible matches - (cond - - ;; No choice found => Error - ((null list) - (error "No cross-reference found, please recompile your file")) - - ;; Only one choice => Do the cross-reference - ((= (length list) 1) - (setq file (ada-find-src-file-in-dir (caar list))) - (if file - (ada-xref-change-buffer file - (string-to-number (nth 1 (car list))) - (string-to-number (nth 2 (car list))) - identlist - other-frame) - (error "%s not found in src_dir" (caar list))) - (message "This is only a (good) guess at the cross-reference.") - ) - - ;; Else, ask the user - (t - (save-window-excursion - (with-output-to-temp-buffer "*choice list*" - - (princ "Identifier is overloaded and Xref information is not up to date.\n") - (princ "Possible declarations are:\n\n") - (princ " no. in file at line col\n") - (princ " --- --------------------- ---- ----\n") - (let ((counter 0)) - (while (< counter (length list)) - (princ (format " %2d) %-21s %4s %4s\n" - (1+ counter) - (nth 0 (nth counter list)) - (nth 1 (nth counter list)) - (nth 2 (nth counter list)) - )) - (setq counter (1+ counter)) - ))) - (setq choice nil) - (while (or (not choice) - (not (integerp choice)) - (< choice 1) - (> choice (length list))) - (setq choice - (string-to-number - (read-from-minibuffer "Enter No. of your choice: ")))) - ) - (setq choice (1- choice)) - (kill-buffer "*choice list*") - - (setq file (ada-find-src-file-in-dir (car (nth choice list)))) - (if file - (ada-xref-change-buffer file - (string-to-number (nth 1 (nth choice list))) - (string-to-number (nth 2 (nth choice list))) - identlist - other-frame) - (signal 'ada-error-file-not-found (car (nth choice list)))) - (message "This is only a (good) guess at the cross-reference.") - )))) - -(defun ada-xref-change-buffer - (file line column identlist &optional other-frame) - "Select and display FILE, at LINE and COLUMN. -If we do not end on the same identifier as IDENTLIST, find the -closest match. Kills the .ali buffer at the end. -If OTHER-FRAME is non-nil, creates a new frame to show the file." - - (let (declaration-buffer) - - ;; Select and display the destination buffer - (if ada-xref-other-buffer - (if other-frame - (find-file-other-frame file) - (setq declaration-buffer (find-file-noselect file)) - (set-buffer declaration-buffer) - (switch-to-buffer-other-window declaration-buffer) - ) - (find-file file) - ) - - ;; move the cursor to the correct position - (push-mark) - (goto-char (point-min)) - (forward-line (1- line)) - (move-to-column column) - - ;; If we are not on the identifier, the ali file was not up-to-date. - ;; Try to find the nearest position where the identifier is found, - ;; this is probably the right one. - (unless (looking-at (ada-name-of identlist)) - (ada-xref-search-nearest (ada-name-of identlist))) - )) - - -(defun ada-xref-search-nearest (name) - "Search for NAME nearest to the position recorded in the Xref file. -Return the position of the declaration in the buffer, or nil if not found." - (let ((orgpos (point)) - (newpos nil) - (diff nil)) - - (goto-char (point-max)) - - ;; loop - look for all declarations of name in this file - (while (search-backward name nil t) - - ;; check if it really is a complete Ada identifier - (if (and - (not (save-excursion - (goto-char (match-end 0)) - (looking-at "_"))) - (not (ada-in-string-or-comment-p)) - (or - ;; variable declaration ? - (save-excursion - (skip-chars-forward "a-zA-Z_0-9" ) - (ada-goto-next-non-ws) - (looking-at ":[^=]")) - ;; procedure, function, task or package declaration ? - (save-excursion - (ada-goto-previous-word) - (looking-at "\\<[pP][rR][oO][cC][eE][dD][uU][rR][eE]\\>\\|\\<[fF][uU][nN][cC][tT][iI][oO][nN]\\>\\|\\<[tT][yY][pP][eE]\\>\\|\\<[tT][aA][sS][kK]\\>\\|\\<[pP][aA][cC][kK][aA][gG][eE]\\>\\|\\<[bB][oO][dD][yY]\\>")))) - - ;; check if it is nearer than the ones before if any - (if (or (not diff) - (< (abs (- (point) orgpos)) diff)) - (progn - (setq newpos (point) - diff (abs (- newpos orgpos)))))) - ) - - (if newpos - (progn - (message "ATTENTION: this declaration is only a (good) guess ...") - (goto-char newpos)) - nil))) - - -;; Find the parent library file of the current file -(defun ada-goto-parent () - "Go to the parent library file." - (interactive) - (ada-require-project-file) - - (let ((buffer (ada-get-ali-buffer (buffer-file-name))) - (unit-name nil) - (body-name nil) - (ali-name nil)) - (with-current-buffer buffer - (goto-char (point-min)) - (re-search-forward "^U \\([^ \t%]+\\)%[bs][ \t]+\\([^ \t]+\\)") - (setq unit-name (match-string 1)) - (if (not (string-match "\\(.*\\)\\.[^.]+" unit-name)) - (progn - (kill-buffer buffer) - (error "No parent unit !")) - (setq unit-name (match-string 1 unit-name)) - ) - - ;; look for the file name for the parent unit specification - (goto-char (point-min)) - (re-search-forward (concat "^W " unit-name - "%s[ \t]+\\([^ \t]+\\)[ \t]+" - "\\([^ \t\n]+\\)")) - (setq body-name (match-string 1)) - (setq ali-name (match-string 2)) - (kill-buffer buffer) - ) - - (setq ali-name (ada-find-ali-file-in-dir ali-name)) - - (save-excursion - ;; Tries to open the new ali file to find the spec file - (if ali-name - (progn - (find-file ali-name) - (goto-char (point-min)) - (re-search-forward (concat "^U " unit-name "%s[ \t]+" - "\\([^ \t]+\\)")) - (setq body-name (match-string 1)) - (kill-buffer (current-buffer)) - ) - ) - ) - - (find-file body-name) - )) - -(defun ada-make-filename-from-adaname (adaname) - "Determine the filename in which ADANAME is found. -This is a GNAT specific function that uses gnatkrunch." - (let ((krunch-buf (generate-new-buffer "*gkrunch*")) - (cross-prefix (plist-get (cdr (ada-xref-current-project)) 'cross_prefix))) - (with-current-buffer krunch-buf - ;; send adaname to external process `gnatkr'. - ;; Add a dummy extension, since gnatkr versions have two different - ;; behaviors depending on the version: - ;; Up to 3.15: "AA.BB.CC" => aa-bb-cc - ;; After: "AA.BB.CC" => aa-bb.cc - (call-process (concat cross-prefix "gnatkr") nil krunch-buf nil - (concat adaname ".adb") ada-krunch-args) - ;; fetch output of that process - (setq adaname (buffer-substring - (point-min) - (progn - (goto-char (point-min)) - (end-of-line) - (point)))) - ;; Remove the extra extension we added above - (setq adaname (substring adaname 0 -4)) - - (kill-buffer krunch-buf))) - adaname - ) - -(defun ada-make-body-gnatstub (&optional interactive) - "Create an Ada package body in the current buffer. -This function uses the `gnat stub' program to create the body. -This function typically is to be hooked into `ff-file-created-hook'. -If INTERACTIVE is nil, assume this is called from `ff-file-created-hook'." - (interactive "p") - (ada-require-project-file) - - ;; If not interactive, assume we are being called from - ;; ff-file-created-hook. Then the current buffer is for the body - ;; file, but we will create a new one after gnat stub runs - (unless interactive - (set-buffer-modified-p nil) - (kill-buffer (current-buffer))) - - (save-some-buffers nil nil) - - ;; Make sure the current buffer is the spec, so gnat stub gets the - ;; right package parameter (this might not be the case if for - ;; instance the user was asked for a project file) - - (unless (buffer-file-name (car (buffer-list))) - (set-buffer (cadr (buffer-list)))) - - ;; Call the external process - (let* ((project-plist (cdr (ada-xref-current-project))) - (gnatstub-opts (ada-treat-cmd-string ada-gnatstub-opts)) - (gpr-file (plist-get project-plist 'gpr_file)) - (filename (buffer-file-name (car (buffer-list)))) - (output (concat (file-name-sans-extension filename) ".adb")) - (cross-prefix (plist-get project-plist 'cross_prefix)) - (gnatstub-cmd (concat cross-prefix "gnat stub" - (if (not (string= gpr-file "")) - (concat " -P\"" gpr-file "\"")) - " " gnatstub-opts " " filename)) - (buffer (get-buffer-create "*gnat stub*"))) - - (with-current-buffer buffer - (compilation-minor-mode 1) - (erase-buffer) - (insert gnatstub-cmd) - (newline) - ) - - (call-process shell-file-name nil buffer nil "-c" gnatstub-cmd) - - ;; clean up the output - - (if (file-exists-p output) - (progn - (find-file output) - (kill-buffer buffer)) - - ;; file not created; display the error message - (display-buffer buffer)))) - -(defun ada-xref-initialize () - "Function called by `ada-mode-hook' to initialize the ada-xref.el package. -For instance, it creates the gnat-specific menus, sets some hooks for -`find-file'." - (remove-hook 'ff-file-created-hook 'ada-make-body) ; from global hook - (remove-hook 'ff-file-created-hook 'ada-make-body t) ; from local hook - (add-hook 'ff-file-created-hook 'ada-make-body-gnatstub nil t) - - ;; Completion for file names in the mini buffer should ignore .ali files - (add-to-list 'completion-ignored-extensions ".ali") - - (ada-xref-update-project-menu) - ) - -;; ----- Add to ada-mode-hook --------------------------------------------- - -;; This must be done before initializing the Ada menu. -(add-hook 'ada-mode-hook 'ada-xref-initialize) - -;; Define a new error type -(define-error 'ada-error-file-not-found - "File not found in src-dir (check project file): " 'ada-mode-errors) - -(provide 'ada-xref) - -;;; ada-xref.el ends here commit fde614f4cc531f778ba082b0f29a7422be8ea433 Author: Michael Albinus Date: Tue Aug 20 21:32:34 2019 +0200 Another attempt to fix bug#32645 * test/lisp/autorevert-tests.el () (auto-revert-test02-auto-revert-deleted-file): * test/lisp/filenotify-tests.el (file-notify-test04-autorevert): Check `file-notify-valid-p', not that the descriptor is nil. diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el index c024739f6e..0ff3c5a407 100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el @@ -283,7 +283,8 @@ This expects `auto-revert--messages' to be bound by (write-region "any text" nil tmpfile nil 'no-message) (setq buf (find-file-noselect tmpfile)) (with-current-buffer buf - (should-not auto-revert-notify-watch-descriptor) + (should-not + (file-notify-valid-p auto-revert-notify-watch-descriptor)) (should (string-equal (buffer-string) "any text")) ;; `buffer-stale--default-function' checks for ;; `verify-visited-file-modtime'. We must ensure that @@ -314,7 +315,8 @@ This expects `auto-revert--messages' to be bound by ;; With w32notify, and on emba, the `stopped' events are not sent. (or (eq file-notify--library 'w32notify) (getenv "EMACS_EMBA_CI") - (should-not auto-revert-notify-watch-descriptor)) + (should-not + (file-notify-valid-p auto-revert-notify-watch-descriptor))) ;; Once the file has been recreated, the buffer shall be ;; reverted. diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el index 2027299197..0b6e66e73a 100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@ -946,7 +946,8 @@ delivered." (file-notify--test-wait-for-events timeout (null auto-revert-notify-watch-descriptor)) (should auto-revert-use-notify) - (should-not auto-revert-notify-watch-descriptor) + (should-not + (file-notify-valid-p auto-revert-notify-watch-descriptor)) ;; Modify file. We wait for two seconds, in order to ;; have another timestamp. One second seems to be too commit 68f086e66906a5aa9bb447cdebac71ced98a0663 Author: Stefan Kangas Date: Tue Aug 20 18:41:44 2019 +0200 ; * etc/NEWS: Move one incorrectly placed item. diff --git a/etc/NEWS b/etc/NEWS index 1737f8f18f..56e5fd2f83 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -129,9 +129,6 @@ This is intended mostly to help developers. ** Emacs now requires GTK 2.24 and GTK 3.10 for the GTK 2 and GTK 3 builds respectively. ---- -** The toolbar now shows the equivalent key binding in its tooltips. - * Startup Changes in Emacs 27.1 @@ -419,6 +416,9 @@ It is used for displaying file sizes and disk space in some cases. The X convention previously used differed slightly, particularly for RGB triplets with a single hexadecimal digit per component. +--- +** The toolbar now shows the equivalent key binding in its tooltips. + * Editing Changes in Emacs 27.1 commit af103ef3c9d6df07475e2b3a2f846246d7fd2a8b Merge: 989c85e799 615cff4258 Author: Glenn Morris Date: Tue Aug 20 09:04:53 2019 -0700 Merge from origin/emacs-26 615cff4 (origin/emacs-26) Fix process filter documentation (Bug#13400) beb1d22 Fix query-replace-regexp undo feature # Conflicts: # test/lisp/replace-tests.el commit 989c85e799b7c3a425d3d03f98ecd55d5cf76022 Merge: 8f68449c94 190565b239 Author: Glenn Morris Date: Tue Aug 20 09:01:55 2019 -0700 ; Merge from origin/emacs-26 The following commit was skipped: 190565b Support the new Japanese era name commit 8f68449c9476956425881bf1534fa727d5247448 Merge: 65dc07f563 0b810ebc9f Author: Glenn Morris Date: Tue Aug 20 09:01:55 2019 -0700 Merge from origin/emacs-26 0b810eb Fix a typo in char-width-table 3f00db7 Minor update in admin/notes/unicode bcd0115 Fix lisp indent infloop on unfinished strings (Bug#37045) 5f992d1 Improve commentary in composite.el 3a04be2 ; Improve commentary in xdisp.c 15de1d1 Fix markup in dired-x.texi bda7fc7 ; Fix typo in a doc string of speedbar.el 6f57ef9 * src/callproc.c (Fcall_process): Doc fix. # Conflicts: # doc/misc/dired-x.texi # lisp/international/characters.el # src/callproc.c commit 65dc07f563f229faadaa44312776941abbf6e1b6 Author: Ulrich Müller Date: Sun Aug 11 11:24:07 2019 +0200 * configure.ac (HAVE_JPEG): Test for window system. (Bug#36995) diff --git a/configure.ac b/configure.ac index 1400fcb5bc..6c83d61921 100644 --- a/configure.ac +++ b/configure.ac @@ -3606,44 +3606,46 @@ HAVE_JPEG=no LIBJPEG= if test "${NS_IMPL_COCOA}" = yes; then : # Cocoa provides its own jpeg support, so do nothing. -elif test "${with_jpeg}" != "no"; then - AC_CACHE_CHECK([for jpeglib 6b or later], - [emacs_cv_jpeglib], - [OLD_LIBS=$LIBS - for emacs_cv_jpeglib in yes -ljpeg no; do - case $emacs_cv_jpeglib in - yes) ;; - no) break;; - *) LIBS="$LIBS $emacs_cv_jpeglib";; - esac - AC_LINK_IFELSE( - [AC_LANG_PROGRAM( - [[#undef HAVE_STDLIB_H /* Avoid config.h/jpeglib.h collision. */ - #include /* jpeglib.h needs FILE and size_t. */ - #include - #include - char verify[JPEG_LIB_VERSION < 62 ? -1 : 1]; - struct jpeg_decompress_struct cinfo; - ]], - [[ - jpeg_create_decompress (&cinfo); - WARNMS (&cinfo, JWRN_JPEG_EOF); - jpeg_destroy_decompress (&cinfo); - ]])], - [emacs_link_ok=yes], - [emacs_link_ok=no]) - LIBS=$OLD_LIBS - test $emacs_link_ok = yes && break - done]) - if test "$emacs_cv_jpeglib" != no; then - HAVE_JPEG=yes - AC_DEFINE([HAVE_JPEG], 1, - [Define to 1 if you have the jpeg library (typically -ljpeg).]) - ### mingw32 doesn't use -ljpeg, since it loads the library - ### dynamically when needed, and doesn't want a run-time - ### dependency on the jpeglib DLL. - test "$emacs_cv_jpeglib" != yes && test "${opsys}" != "mingw32" \ - && LIBJPEG=$emacs_cv_jpeglib +elif test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes"; then + if test "${with_jpeg}" != "no"; then + AC_CACHE_CHECK([for jpeglib 6b or later], + [emacs_cv_jpeglib], + [OLD_LIBS=$LIBS + for emacs_cv_jpeglib in yes -ljpeg no; do + case $emacs_cv_jpeglib in + yes) ;; + no) break;; + *) LIBS="$LIBS $emacs_cv_jpeglib";; + esac + AC_LINK_IFELSE( + [AC_LANG_PROGRAM( + [[#undef HAVE_STDLIB_H /* Avoid config.h/jpeglib.h collision. */ + #include /* jpeglib.h needs FILE and size_t. */ + #include + #include + char verify[JPEG_LIB_VERSION < 62 ? -1 : 1]; + struct jpeg_decompress_struct cinfo; + ]], + [[ + jpeg_create_decompress (&cinfo); + WARNMS (&cinfo, JWRN_JPEG_EOF); + jpeg_destroy_decompress (&cinfo); + ]])], + [emacs_link_ok=yes], + [emacs_link_ok=no]) + LIBS=$OLD_LIBS + test $emacs_link_ok = yes && break + done]) + if test "$emacs_cv_jpeglib" != no; then + HAVE_JPEG=yes + AC_DEFINE([HAVE_JPEG], 1, + [Define to 1 if you have the jpeg library (typically -ljpeg).]) + ### mingw32 doesn't use -ljpeg, since it loads the library + ### dynamically when needed, and doesn't want a run-time + ### dependency on the jpeglib DLL. + test "$emacs_cv_jpeglib" != yes && test "${opsys}" != "mingw32" \ + && LIBJPEG=$emacs_cv_jpeglib + fi fi fi AC_SUBST(LIBJPEG) commit 4e0c5830dab466be2df99b8814b742a662d67ac7 Author: Mauro Aranda Date: Sat Aug 10 10:48:24 2019 -0300 Don't display wrong ElDoc information when inside ELisp strings or comments * lisp/progmodes/elisp-mode.el (elisp--fnsym-in-current-sexp): Since forward-sexp assumes point is not in a string or comment, avoid calling it and then checking if point is inside a string, since that sometimes will fail with awkward results. (Bug#35567) diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 36797fc6fd..516e4f9cd6 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -1571,14 +1571,12 @@ In the absence of INDEX, just call `eldoc-docstring-format-sym-doc'." ;; Return a list of current function name and argument index. (defun elisp--fnsym-in-current-sexp () (save-excursion - (let ((argument-index (1- (elisp--beginning-of-sexp)))) - ;; If we are at the beginning of function name, this will be -1. - (when (< argument-index 0) - (setq argument-index 0)) - ;; Don't do anything if current word is inside a string. - (if (= (or (char-after (1- (point))) 0) ?\") - nil - (list (elisp--current-symbol) argument-index))))) + (unless (nth 8 (syntax-ppss)) + (let ((argument-index (1- (elisp--beginning-of-sexp)))) + ;; If we are at the beginning of function name, this will be -1. + (when (< argument-index 0) + (setq argument-index 0)) + (list (elisp--current-symbol) argument-index))))) ;; Move to the beginning of current sexp. Return the number of nested ;; sexp the point was over or after. commit 08d7cabc923dad602dd3801c09f02386acda4e3b Author: Lars Ingebrigtsen Date: Mon Aug 19 19:39:05 2019 -0700 Output `auto-coding-alist' in `describe-current-coding-system' * lisp/international/mule-diag.el (describe-current-coding-system): Also output the contents of `auto-coding-alist', which take precedence over `file-coding-system-alist' (bug#9575). diff --git a/lisp/international/mule-diag.el b/lisp/international/mule-diag.el index 472529ffc0..dcdcafcea7 100644 --- a/lisp/international/mule-diag.el +++ b/lisp/international/mule-diag.el @@ -677,7 +677,8 @@ Priority order for recognizing coding systems when reading files:\n") (princ (cdr (car alist))) (princ "\n") (setq alist (cdr alist))))))) - (funcall func "File I/O" file-coding-system-alist) + (funcall func "File I/O" (append auto-coding-alist + file-coding-system-alist)) (funcall func "Process I/O" process-coding-system-alist) (funcall func "Network I/O" network-coding-system-alist)) (help-mode)))) commit afdf679841ad31664d41e7debca7083632add0f8 Author: Lars Ingebrigtsen Date: Mon Aug 19 19:21:53 2019 -0700 Add a new hook: `quit-window-hook' * doc/lispref/windows.texi (Quitting Windows): Mention in. * lisp/window.el (quit-restore-window): Run the new `quit-window-hook' before doing anything else (bug#9867). (quit-window): Note that the hook will be run in the doc string. * lisp/window.el (quit-window-hook): New variable. diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi index 1035739e2b..157f004cf3 100644 --- a/doc/lispref/windows.texi +++ b/doc/lispref/windows.texi @@ -4043,6 +4043,10 @@ the selected one. The function's behavior is determined by the four elements of the list specified by @var{window}'s @code{quit-restore} parameter (@pxref{Window Parameters}). +@vindex quit-window-hook +The functions in @code{quit-window-hook} are run before doing anything +else. + The first element of the @code{quit-restore} parameter is one of the symbols @code{window}, meaning that the window has been specially created by @code{display-buffer}; @code{frame}, a separate frame has diff --git a/etc/NEWS b/etc/NEWS index 23bf2b898a..1737f8f18f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2024,6 +2024,10 @@ valid event type. * Lisp Changes in Emacs 27.1 ++++ +** The new 'quit-window-hook' is now run first when executing the +'quit-window' command. + ** The variables 'help-enable-completion-auto-load', 'help-enable-auto-load' and 'vhdl-project-auto-load', as well as the 'vhdl-auto-load-project' have been renamed to have "autoload" without diff --git a/lisp/window.el b/lisp/window.el index 723671efa5..80dbd64f18 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -4848,6 +4848,12 @@ all window-local buffer lists." ;; Unrecord BUFFER in WINDOW. (unrecord-window-buffer window buffer))))) +(defcustom quit-window-hook nil + "Hook run before performing any other actions in the `quit-buffer' command." + :type 'hook + :version "27.1" + :group 'windows) + (defun quit-restore-window (&optional window bury-or-kill) "Quit WINDOW and deal with its buffer. WINDOW must be a live window and defaults to the selected one. @@ -4876,7 +4882,11 @@ nil means to not handle the buffer in a particular way. This most reliable remedy to not have `switch-to-prev-buffer' switch to this buffer again without killing the buffer. -`kill' means to kill WINDOW's buffer." +`kill' means to kill WINDOW's buffer. + +The functions in `quit-window-hook' will be run before doing +anything else." + (run-hooks 'quit-window-hook) (setq window (window-normalize-window window t)) (let* ((buffer (window-buffer window)) (quit-restore (window-parameter window 'quit-restore)) @@ -4971,7 +4981,10 @@ According to information stored in WINDOW's `quit-restore' window parameter either (1) delete WINDOW and its frame, (2) delete WINDOW, (3) restore the buffer previously displayed in WINDOW, or (4) make WINDOW display some other buffer than the present -one. If non-nil, reset `quit-restore' parameter to nil." +one. If non-nil, reset `quit-restore' parameter to nil. + +The functions in `quit-window-hook' will be run before doing +anything else." (interactive "P") (quit-restore-window window (if kill 'kill 'bury))) commit 221a3272ad4a1befb41dda2990d672782bc0257f Author: Paul Eggert Date: Mon Aug 19 18:04:56 2019 -0700 Fix org-table 65536-second bug * lisp/org/org-table.el (org-table-message-once-per-second): Fix bug when clock difference goes past a 65536-second boundary. Don’t assume particular format for current-time result. diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el index 513a534d9b..a65629b302 100644 --- a/lisp/org/org-table.el +++ b/lisp/org/org-table.el @@ -3169,7 +3169,7 @@ ARGS are passed as arguments to the `message' function. Returns current time if a message is printed, otherwise returns T1. If T1 is nil, always messages." (let ((curtime (current-time))) - (if (or (not t1) (< 0 (nth 1 (time-subtract curtime t1)))) + (if (or (not t1) (time-less-p 1 (time-subtract curtime t1))) (progn (apply 'message args) curtime) t1))) commit 2197ea89bf5afabc4c52a6499b13e92ae6621554 Author: Paul Eggert Date: Mon Aug 19 18:02:59 2019 -0700 Fix time-add/time-sub validity checking * src/timefns.c (time_arith): Check the first arg for validity even if the second arg is not finite. * test/src/timefns-tests.el (time-arith-tests): Test this. diff --git a/src/timefns.c b/src/timefns.c index 3948f87335..2d545a4f90 100644 --- a/src/timefns.c +++ b/src/timefns.c @@ -1035,12 +1035,12 @@ time_arith (Lisp_Object a, Lisp_Object b, bool subtract) double db = XFLOAT_DATA (Ffloat_time (b)); return make_float (subtract ? da - db : da + db); } - if (FLOATP (b) && !isfinite (XFLOAT_DATA (b))) - return subtract ? make_float (-XFLOAT_DATA (b)) : b; - enum timeform aform, bform; struct lisp_time ta = lisp_time_struct (a, &aform); + if (FLOATP (b) && !isfinite (XFLOAT_DATA (b))) + return subtract ? make_float (-XFLOAT_DATA (b)) : b; + /* Subtract nil from nil correctly, and handle other eq values quicker while we're at it. Compare here rather than earlier, to handle NaNs and check formats. */ diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el index 13ab7d83c3..a30b2de3a5 100644 --- a/test/src/timefns-tests.el +++ b/test/src/timefns-tests.el @@ -136,6 +136,10 @@ (cons (1+ most-positive-fixnum) 1000000000000) (cons 1000000000000 (1+ most-positive-fixnum))))) (dolist (a time-values) + (should-error (time-add a 'ouch)) + (should-error (time-add 'ouch a)) + (should-error (time-subtract a 'ouch)) + (should-error (time-subtract 'ouch a)) (dolist (b time-values) (let ((aa (time-subtract (time-add a b) b))) (should (or (time-equal-p a aa) (and (floatp aa) (isnan aa))))) commit 615cff42580a3521c1a4ea7c3ec467eb8259e1c7 Author: Noam Postavsky Date: Fri Jul 26 23:20:37 2019 -0400 Fix process filter documentation (Bug#13400) * doc/lispref/processes.texi (Asynchronous Processes): Note that input may read when sending data as well. (Output from Processes): Note that functions which send data may also trigger reading from processes. (Input to Processes, Filter Functions): Note that filter functions may be called recursively. diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index a93f4db428..bd807cdcee 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -588,9 +588,8 @@ process}. After an asynchronous process is created, it runs in parallel with Emacs, and Emacs can communicate with it using the functions described in the following sections (@pxref{Input to Processes}, and @pxref{Output from Processes}). Note that process -communication is only partially asynchronous: Emacs sends data to the -process only when certain functions are called, and Emacs accepts data -from the process only while waiting for input or for a time delay. +communication is only partially asynchronous: Emacs sends and receives +data to and from a process only when those functions are called. @cindex pty, when to use for subprocess communications @cindex pipe, when to use for subprocess communications @@ -1200,8 +1199,9 @@ the defaulting mechanism (@pxref{Default Coding Systems}). because the input buffer is full. When this happens, the send functions wait a short while, accepting output from subprocesses, and then try again. This gives the subprocess a chance to read more of its pending -input and make space in the buffer. It also allows filters, sentinels -and timers to run---so take account of that in writing your code. +input and make space in the buffer. It also allows filters (including +the one currently running), sentinels and timers to run---so take +account of that in writing your code. In these functions, the @var{process} argument can be a process or the name of a process, or a buffer or buffer name (which stands @@ -1416,9 +1416,10 @@ output, Emacs won't receive that output. Output from a subprocess can arrive only while Emacs is waiting: when reading terminal input (see the function @code{waiting-for-user-input-p}), -in @code{sit-for} and @code{sleep-for} (@pxref{Waiting}), and in -@code{accept-process-output} (@pxref{Accepting Output}). This -minimizes the problem of timing errors that usually plague parallel +in @code{sit-for} and @code{sleep-for} (@pxref{Waiting}), in +@code{accept-process-output} (@pxref{Accepting Output}), and in +functions which send data to processes (@pxref{Input to Processes}). +This minimizes the problem of timing errors that usually plague parallel programming. For example, you can safely create a process and only then specify its buffer or filter function; no output can arrive before you finish, if the code in between does not call any primitive @@ -1594,14 +1595,10 @@ outputs directly to the process buffer. By default, the error output from the process, if any, is also passed to the filter function, unless the destination for the standard error stream of the process was separated from the standard output -when the process was created (@pxref{Output from Processes}). - - The filter function can only be called when Emacs is waiting for -something, because process output arrives only at such times. Emacs -waits when reading terminal input (see the function -@code{waiting-for-user-input-p}), in @code{sit-for} and -@code{sleep-for} (@pxref{Waiting}), and in -@code{accept-process-output} (@pxref{Accepting Output}). +when the process was created. Emacs will only call the filter +function during certain function calls. @xref{Output from Processes}. +Note that if any of those functions are called by the filter, the +filter may be called recursively. A filter function must accept two arguments: the associated process and a string, which is output just received from it. The function is commit beb1d22260af2e03d80d34fcc1db212785a9d903 Author: Tino Calancha Date: Mon Aug 19 17:32:09 2019 +0200 Fix query-replace-regexp undo feature Ensure that non-regexp strings used with `looking-at' are quoted. * lisp/replace.el (perform-replace): Quote regexp (Bug#37073). * test/lisp/replace-tests.el (replace-tests-perform-replace-regexp-flag): New variable. (replace-tests-with-undo): Use it. (query-replace-undo-bug37073): Add tests. diff --git a/lisp/replace.el b/lisp/replace.el index 08feb8eae7..0ddebb1270 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -2614,7 +2614,8 @@ It must return a string." (setq real-match-data (save-excursion (goto-char (match-beginning 0)) - (looking-at search-string) + ;; We must quote the string (Bug#37073) + (looking-at (regexp-quote search-string)) (match-data t (nth 2 elt))) noedit (replace-match-maybe-edit @@ -2624,7 +2625,9 @@ It must return a string." real-match-data (save-excursion (goto-char (match-beginning 0)) - (looking-at next-replacement) + (if regexp-flag + (looking-at next-replacement) + (looking-at (regexp-quote next-replacement))) (match-data t (nth 2 elt)))) ;; Set replaced nil to keep in loop (when (eq def 'undo-all) diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el index cd30633e37..cd08a522e3 100644 --- a/test/lisp/replace-tests.el +++ b/test/lisp/replace-tests.el @@ -365,6 +365,9 @@ Each element has the format: (defvar replace-tests-bind-read-string nil "A string to bind `read-string' and avoid the prompt.") +(defvar replace-tests-perform-replace-regexp-flag t + "Value for regexp-flag argument passed to `perform-replace' in undo tests.") + (defmacro replace-tests-with-undo (input from to char-nums def-chr &rest body) "Helper to test `query-replace' undo feature. INPUT is a string to insert in a temporary buffer. @@ -412,7 +415,7 @@ Return the last evalled form in BODY." (if replace-tests-bind-read-string (lambda (&rest args) replace-tests-bind-read-string) (symbol-function 'read-string)))) - (perform-replace ,from ,to t t nil)) + (perform-replace ,from ,to t replace-tests-perform-replace-regexp-flag nil)) ,@body)))) (defun replace-tests--query-replace-undo (&optional comma) @@ -454,5 +457,26 @@ Return the last evalled form in BODY." input "a" "B" ((?\s . (1 2 3)) (?E . (4)) (?U . (5))) ?q (string= input (buffer-string)))))) +(ert-deftest query-replace-undo-bug37073 () + "Test for https://debbugs.gnu.org/37073 ." + (let ((input "theorem 1\ntheorem 2\ntheorem 3")) + (should + (replace-tests-with-undo + input "theorem \\([0-9]+\\)" + "theorem \\\\ref{theo_\\1}" + ((?\s . (1 2)) (?U . (3))) + ?q + (string= input (buffer-string))))) + ;; Now run a test with regexp-flag arg in `perform-replace' set to nil + (let ((input " ^theorem$ 1\n ^theorem$ 2\n ^theorem$ 3") + (replace-tests-perform-replace-regexp-flag nil) + (expected " theo 1\n ^theorem$ 2\n ^theorem$ 3")) + (should + (replace-tests-with-undo + input "^theorem$" + "theo" + ((?\s . (1 2 4)) (?U . (3))) + ?q + (string= expected (buffer-string)))))) ;;; replace-tests.el ends here commit 50dc4ca8d02a466a7236765edf83ae7cfb02d74c Author: Stefan Monnier Date: Mon Aug 19 05:44:43 2019 -0400 * lisp/erc/erc-stamp.el: Fix erc-echo-timestamp (bug#22700) Use lexical-binding. (erc-add-timestamp): Store the timestamp in a closure placed in cursor-sensor-functions rather than stashing it in an ad-hoc `timestamp` property. (erc-echo-timestamp): Simplify accordingly. diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el index b48803452a..a15d8bf7b3 100644 --- a/lisp/erc/erc-stamp.el +++ b/lisp/erc/erc-stamp.el @@ -1,4 +1,4 @@ -;;; erc-stamp.el --- Timestamping for ERC messages +;;; erc-stamp.el --- Timestamping for ERC messages -*- lexical-binding:t -*- ;; Copyright (C) 2002-2004, 2006-2019 Free Software Foundation, Inc. @@ -186,10 +186,11 @@ or `erc-send-modify-hook'." (funcall erc-insert-away-timestamp-function (erc-format-timestamp ct erc-away-timestamp-format))) (add-text-properties (point-min) (point-max) - (list 'timestamp ct)) - (add-text-properties (point-min) (point-max) + ;; It's important for the function to + ;; be different on different entries (bug#22700). (list 'cursor-sensor-functions - (list #'erc-echo-timestamp)))))) + (list (lambda (_window _before dir) + (erc-echo-timestamp dir ct)))))))) (defvar erc-timestamp-last-inserted nil "Last timestamp inserted into the buffer.") @@ -399,14 +400,12 @@ enabled when the message was inserted." (erc-munge-invisibility-spec))) (erc-buffer-list))) -(defun erc-echo-timestamp (window _before dir) +(defun erc-echo-timestamp (dir stamp) "Print timestamp text-property of an IRC message." (when (and erc-echo-timestamps (eq 'entered dir)) - (let* ((now (window-point window)) - (stamp (get-text-property now 'timestamp))) - (when stamp - (message "%s" (format-time-string erc-echo-timestamp-format - stamp)))))) + (when stamp + (message "%s" (format-time-string erc-echo-timestamp-format + stamp))))) (provide 'erc-stamp) commit 1b96e022b624d676d1457ff135000489c1a626f1 Author: Lars Ingebrigtsen Date: Sun Aug 18 16:50:08 2019 -0700 Allow set-frame-height/set-frame-width to be used interactively * doc/lispref/frames.texi (Frame Size): Document it. * src/frame.c (Fset_frame_height): (Fset_frame_width): Make into commands that use the numeric prefix to set height/width (bug#9970). diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index 629cec3c5f..618ea16fcf 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -1111,6 +1111,10 @@ The optional fourth argument @var{pixelwise} non-@code{nil} means that @code{frame-resize-pixelwise} is @code{nil}, some window managers may refuse to truly honor the request if it does not increase/decrease the frame height to a multiple of its character height. + +When used interactively, this command will set the height of the +currently selected frame to the number of lines specified by the +numeric prefix. @end defun @defun set-frame-width frame width &optional pretend pixelwise @@ -1123,6 +1127,10 @@ The optional fourth argument @var{pixelwise} non-@code{nil} means that @code{frame-resize-pixelwise} is @code{nil}, some window managers may refuse to fully honor the request if it does not increase/decrease the frame width to a multiple of its character width. + +When used interactively, this command will set the width of the +currently selected frame to the number of columns specified by the +numeric prefix. @end defun None of these three functions will make a frame smaller than needed to diff --git a/etc/NEWS b/etc/NEWS index 25c5ce658f..23bf2b898a 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -243,6 +243,11 @@ the call to 'desktop-read' in this hook, if you want the GUI settings to be restored, or if desktop.el needs to interact with you during restoration of the session. ++++ +** The functions 'set-frame-height' and 'set-frame-width' are now +commands, and will set the currently selected frame to the height/ +width specified by the numeric prefix. + +++ ** New function 'logcount' calculates an integer's Hamming weight. diff --git a/src/frame.c b/src/frame.c index d94de417e4..50a7f138b8 100644 --- a/src/frame.c +++ b/src/frame.c @@ -3491,7 +3491,8 @@ DEFUN ("frame-bottom-divider-width", Fbottom_divider_width, Sbottom_divider_widt return make_fixnum (FRAME_BOTTOM_DIVIDER_WIDTH (decode_any_frame (frame))); } -DEFUN ("set-frame-height", Fset_frame_height, Sset_frame_height, 2, 4, 0, +DEFUN ("set-frame-height", Fset_frame_height, Sset_frame_height, 2, 4, + "(list (selected-frame) current-prefix-arg)", doc: /* Set text height of frame FRAME to HEIGHT lines. Optional third arg PRETEND non-nil means that redisplay should use HEIGHT lines but that the idea of the actual height of the frame should @@ -3500,7 +3501,10 @@ not be changed. Optional fourth argument PIXELWISE non-nil means that FRAME should be HEIGHT pixels high. Note: When `frame-resize-pixelwise' is nil, some window managers may refuse to honor a HEIGHT that is not an integer -multiple of the default frame font height. */) +multiple of the default frame font height. + +When called interactively, HEIGHT is the numeric prefix and the +currenly selected frame will be set to this height. */) (Lisp_Object frame, Lisp_Object height, Lisp_Object pretend, Lisp_Object pixelwise) { struct frame *f = decode_live_frame (frame); @@ -3516,7 +3520,8 @@ multiple of the default frame font height. */) return Qnil; } -DEFUN ("set-frame-width", Fset_frame_width, Sset_frame_width, 2, 4, 0, +DEFUN ("set-frame-width", Fset_frame_width, Sset_frame_width, 2, 4, + "(list (selected-frame) current-prefix-arg)", doc: /* Set text width of frame FRAME to WIDTH columns. Optional third arg PRETEND non-nil means that redisplay should use WIDTH columns but that the idea of the actual width of the frame should not @@ -3525,7 +3530,10 @@ be changed. Optional fourth argument PIXELWISE non-nil means that FRAME should be WIDTH pixels wide. Note: When `frame-resize-pixelwise' is nil, some window managers may refuse to honor a WIDTH that is not an integer -multiple of the default frame font width. */) +multiple of the default frame font width. + +When called interactively, WIDTH is the numeric prefix and the +currenly selected frame will be set to this width. */) (Lisp_Object frame, Lisp_Object width, Lisp_Object pretend, Lisp_Object pixelwise) { struct frame *f = decode_live_frame (frame); commit b8c4a9e0f8d10b2c3948d8f12279238b1e58b76d Author: Štěpán Němec Date: Sun Aug 18 16:05:48 2019 -0700 Add an advice-add/interactive spec example * doc/lispref/functions.texi (Core Advising Primitives): Add an advice-add example that extends the `interactive' spec (bug#17871). diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index e65d398c43..d082225dd0 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -1752,6 +1752,30 @@ with such a spec would, and then return the corresponding list of arguments that was built. E.g., @code{(advice-eval-interactive-spec "r\nP")} will return a list of three elements, containing the boundaries of the region and the current prefix argument. + +For instance, if you want to make the @kbd{C-x m} +(@code{compose-mail}) command prompt for a @samp{From:} header, you +could say something like this: + +@example +(defun my-compose-mail-advice (orig &rest args) + "Read From: address interactively." + (interactive + (lambda (spec) + (let* ((user-mail-address + (completing-read "From: " + '("one.address@@example.net" + "alternative.address@@example.net"))) + (from (message-make-from user-full-name + user-mail-address)) + (spec (advice-eval-interactive-spec spec))) + ;; Put the From header into the OTHER-HEADERS argument. + (push (cons 'From from) (nth 2 spec)) + spec))) + (apply orig args)) + +(advice-add 'compose-mail :around #'my-compose-mail-advice) +@end example @end defun @node Advising Named Functions commit b82adee1f64231236d50b48662d3419417ba5d48 Author: Johan Claesson Date: Sun Aug 18 15:49:24 2019 -0700 Invalidate dir-locals-directory-cache when writing dir-local file * lisp/files-x.el (modify-dir-local-variable): Remove file from the cache when writing to ensure that we load the new version later (bug#13860). diff --git a/lisp/files-x.el b/lisp/files-x.el index b71e9204f3..6b04518fe4 100644 --- a/lisp/files-x.el +++ b/lisp/files-x.el @@ -491,6 +491,13 @@ from the MODE alist ignoring the input argument VALUE." (cons `(,mode . ((,variable . ,value))) variables)))) + ;; Invalidate cache (may be needed if this .dir-locals.el file + ;; will be written with the same timestamp as is already present + ;; in the cache, see bug#13860). + (setq dir-locals-directory-cache + (assoc-delete-all (file-name-directory variables-file) + dir-locals-directory-cache)) + ;; Insert modified alist of directory-local variables. (insert ";;; Directory Local Variables\n") (insert ";;; For more information see (info \"(emacs) Directory Variables\")\n\n") commit f9464020d403be8344f8293297b27276872571d4 Author: Noam Postavsky Date: Sun Aug 18 18:10:50 2019 -0400 Handle more subprocess chunking in M-x man (Bug#36927) * lisp/man.el (Man-bgproc-filter): Make sure not to chop man sections by narrowing. (Man-highlight-references0): Revert previous fix, as it's no longer needed. * test/lisp/man-tests.el (man-tests-filter-strings): New function. (man-bgproc-filter-buttonize-includes): New test. diff --git a/lisp/man.el b/lisp/man.el index 89d514423b..cef3d598eb 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -1296,21 +1296,7 @@ default type, `Man-xref-man-page' is used for the buttons." ;; Based on `Man-build-references-alist' (when (or (null start-section) ;; Search regardless of sections. ;; Section header is in this chunk. - (Man-find-section start-section) - ;; Section header was in one of the previous chunks. - (save-excursion - (save-restriction - (let ((orig-pos (point))) - (widen) - (if (Man-find-section start-section) - ;; We are in the right section of the next - ;; section is either not yet in the buffer, or - ;; it starts after the position where we should - ;; start highlighting. - (progn - (forward-line 1) - (or (null (re-search-forward Man-heading-regexp nil t)) - (> (point) orig-pos)))))))) + (Man-find-section start-section)) (let ((end (if start-section (progn (forward-line 1) @@ -1384,7 +1370,9 @@ command is run. Second argument STRING is the entire string of output." (narrow-to-region (save-excursion (goto-char beg) - (line-beginning-position)) + ;; Process whole sections (Bug#36927). + (Man-previous-section 1) + (point)) (point)) (if Man-fontify-manpage-flag (Man-fontify-manpage) diff --git a/test/lisp/man-tests.el b/test/lisp/man-tests.el index dca0ff1939..9932e03f21 100644 --- a/test/lisp/man-tests.el +++ b/test/lisp/man-tests.el @@ -24,6 +24,7 @@ (require 'ert) (require 'man) +(require 'seq) (defconst man-tests-parse-man-k-tests '(;; GNU/Linux: man-db-2.6.1 @@ -113,6 +114,53 @@ in the cdr of the element.") (dolist (test man-tests-parse-man-k-tests) (should (man-tests-parse-man-k-test-case test)))) +(defun man-tests-filter-strings (buffer strings) + "Run `Man-bgproc-filter' on each of STRINGS. +The formatted result will be inserted into BUFFER." + (let ((proc (start-process "dummy man-tests proc" (current-buffer) "cat"))) + (set-process-query-on-exit-flag proc nil) + (dolist (str strings) + (Man-bgproc-filter proc str)))) + +(ert-deftest man-bgproc-filter-buttonize-includes () + ;; Test with abridged version of printf man page (Bug#36927). + (let ((str "\ +PRINTF(3) Linux Programmer's Manual PRINTF(3) + +NAME + printf, fprintf, dprintf, sprintf, snprintf, vprintf, vfprintf, + +SYNOPSIS + #include + + int printf(const char *format, ...); + + #include + + int vsprintf(char *str, const char *format, va_list ap); + +DESCRIPTION + The functions in the printf() family produce output according\n")) + (with-temp-buffer + (dolist (chunks + (list + ;; Test a few different kinds of chunking. + (list str) + (seq-mapcat (lambda (line) + (list line "\n")) + (split-string str "\n")) + (mapcar #'string str))) + (erase-buffer) + (man-tests-filter-strings (current-buffer) chunks) + (goto-char (point-min)) + (ert-info ((format "%S" chunks) :prefix "Input: ") + (search-forward "#include ") + (let ((button (button-at (match-beginning 0)))) + (should (and button (eq 'Man-xref-header-file (button-type button))))) + (search-forward "#include ") + (let ((button (button-at (match-beginning 0)))) + (should (and button (eq 'Man-xref-header-file (button-type button)))))))))) + (provide 'man-tests) ;;; man-tests.el ends here commit 780509f29f0aa006a578744f7e871eb6d5ce5931 Author: Paul Eggert Date: Sun Aug 18 12:11:06 2019 -0700 Improve bignum_integer static checking * src/bignum.h (bignum_integer): Now returns pointer-to-const, to catch trivial mistakes where the caller might try to modify a Lisp bignum. Lisp bignums are supposed to be immutable. All callers changed. diff --git a/src/bignum.h b/src/bignum.h index 743a18fc0f..a9c7a0a09a 100644 --- a/src/bignum.h +++ b/src/bignum.h @@ -83,7 +83,7 @@ mpz_set_uintmax (mpz_t result, uintmax_t v) /* Return a pointer to an mpz_t that is equal to the Lisp integer I. If I is a bignum this returns a pointer to I's representation; otherwise this sets *TMP to I's value and returns TMP. */ -INLINE mpz_t * +INLINE mpz_t const * bignum_integer (mpz_t *tmp, Lisp_Object i) { if (FIXNUMP (i)) diff --git a/src/data.c b/src/data.c index 6db8ea144d..cf9f8e5613 100644 --- a/src/data.c +++ b/src/data.c @@ -2871,7 +2871,7 @@ static Lisp_Object bignum_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, ptrdiff_t argnum, intmax_t iaccum, Lisp_Object val) { - mpz_t *accum; + mpz_t const *accum; if (argnum == 0) { accum = bignum_integer (&mpz[0], val); @@ -2882,7 +2882,7 @@ bignum_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, while (true) { - mpz_t *next = bignum_integer (&mpz[1], val); + mpz_t const *next = bignum_integer (&mpz[1], val); switch (code) { @@ -3099,7 +3099,7 @@ integer_mod (Lisp_Object x, Lisp_Object y) } else { - mpz_t *ym = bignum_integer (&mpz[1], y); + mpz_t const *ym = bignum_integer (&mpz[1], y); bool neg_y = mpz_sgn (*ym) < 0; mpz_mod (mpz[0], *bignum_integer (&mpz[0], x), *ym); @@ -3269,7 +3269,7 @@ In this case, the sign bit is duplicated. */) } } - mpz_t *zval = bignum_integer (&mpz[0], value); + mpz_t const *zval = bignum_integer (&mpz[0], value); if (XFIXNUM (count) < 0) { if (TYPE_MAXIMUM (mp_bitcnt_t) < - XFIXNUM (count)) diff --git a/src/timefns.c b/src/timefns.c index bf49843aae..3948f87335 100644 --- a/src/timefns.c +++ b/src/timefns.c @@ -423,7 +423,7 @@ decode_float_time (double t, struct lisp_time *result) static Lisp_Object ticks_hz_list4 (Lisp_Object ticks, Lisp_Object hz) { - mpz_t *zticks = bignum_integer (&mpz[0], ticks); + mpz_t const *zticks = bignum_integer (&mpz[0], ticks); #if FASTER_TIMEFNS && TRILLION <= ULONG_MAX mpz_mul_ui (mpz[0], *zticks, TRILLION); #else @@ -557,8 +557,8 @@ frac_to_double (Lisp_Object numerator, Lisp_Object denominator) verify (FLT_RADIX == 2 || FLT_RADIX == 16); enum { LOG2_FLT_RADIX = FLT_RADIX == 2 ? 1 : 4 }; - mpz_t *n = bignum_integer (&mpz[0], numerator); - mpz_t *d = bignum_integer (&mpz[1], denominator); + mpz_t const *n = bignum_integer (&mpz[0], numerator); + mpz_t const *d = bignum_integer (&mpz[1], denominator); ptrdiff_t nbits = mpz_sizeinbase (*n, 2); ptrdiff_t dbits = mpz_sizeinbase (*d, 2); eassume (0 < nbits); @@ -1061,8 +1061,8 @@ time_arith (Lisp_Object a, Lisp_Object b, bool subtract) { /* The plan is to decompose ta into na/da and tb into nb/db. Start by computing da and db. */ - mpz_t *da = bignum_integer (&mpz[1], ta.hz); - mpz_t *db = bignum_integer (&mpz[2], tb.hz); + mpz_t const *da = bignum_integer (&mpz[1], ta.hz); + mpz_t const *db = bignum_integer (&mpz[2], tb.hz); /* The plan is to compute (na * (db/g) + nb * (da/g)) / lcm (da, db) where g = gcd (da, db). Start by computing g. */ @@ -1082,9 +1082,9 @@ time_arith (Lisp_Object a, Lisp_Object b, bool subtract) /* ticks = (fb * na) OPER (fa * nb), where OPER is + or -. OP is the multiply-add or multiply-sub form of OPER. */ - mpz_t *na = bignum_integer (&mpz[0], ta.ticks); + mpz_t const *na = bignum_integer (&mpz[0], ta.ticks); mpz_mul (mpz[0], *fb, *na); - mpz_t *nb = bignum_integer (&mpz[3], tb.ticks); + mpz_t const *nb = bignum_integer (&mpz[3], tb.ticks); (subtract ? mpz_submul : mpz_addmul) (mpz[0], *fa, *nb); ticks = make_integer_mpz (); } @@ -1144,8 +1144,8 @@ time_cmp (Lisp_Object a, Lisp_Object b) return 0; struct lisp_time tb = lisp_time_struct (b, 0); - mpz_t *za = bignum_integer (&mpz[0], ta.ticks); - mpz_t *zb = bignum_integer (&mpz[1], tb.ticks); + mpz_t const *za = bignum_integer (&mpz[0], ta.ticks); + mpz_t const *zb = bignum_integer (&mpz[1], tb.ticks); if (! (FASTER_TIMEFNS && EQ (ta.hz, tb.hz))) { /* This could be sped up by looking at the signs, sizes, and commit 190565b2396d80178fc5f6757117540e3a1ae9e1 Author: Eli Zaretskii Date: Sun Aug 18 19:36:31 2019 +0300 Support the new Japanese era name * admin/unidata/NormalizationTest.txt: * admin/unidata/UnicodeData.txt: Add U+32FF SQUARE ERA NAME REIWA. Do not merge to master. * test/lisp/international/ucs-normalize-tests.el (ucs-normalize-tests--failing-lines-part1) (ucs-normalize-tests--failing-lines-part2): Update. Do not merge to master. * etc/NEWS: Mention the change. diff --git a/admin/unidata/NormalizationTest.txt b/admin/unidata/NormalizationTest.txt index 72a31bcdf1..64914028a9 100644 --- a/admin/unidata/NormalizationTest.txt +++ b/admin/unidata/NormalizationTest.txt @@ -2149,6 +2149,7 @@ 32FC;32FC;32FC;30F0;30F0; # (㋼; ㋼; ㋼; ヰ; ヰ; ) CIRCLED KATAKANA WI 32FD;32FD;32FD;30F1;30F1; # (㋽; ㋽; ㋽; ヱ; ヱ; ) CIRCLED KATAKANA WE 32FE;32FE;32FE;30F2;30F2; # (㋾; ㋾; ㋾; ヲ; ヲ; ) CIRCLED KATAKANA WO +32FF;32FF;32FF;4EE4 548C;4EE4 548C; # (㋿; ㋿; ㋿; 令和; 令和; ) SQUARE ERA NAME REIWA 3300;3300;3300;30A2 30D1 30FC 30C8;30A2 30CF 309A 30FC 30C8; # (㌀; ㌀; ㌀; アパート; アハ◌゚ート; ) SQUARE APAATO 3301;3301;3301;30A2 30EB 30D5 30A1;30A2 30EB 30D5 30A1; # (㌁; ㌁; ㌁; アルファ; アルファ; ) SQUARE ARUHUA 3302;3302;3302;30A2 30F3 30DA 30A2;30A2 30F3 30D8 309A 30A2; # (㌂; ㌂; ㌂; アンペア; アンヘ◌゚ア; ) SQUARE ANPEA diff --git a/admin/unidata/UnicodeData.txt b/admin/unidata/UnicodeData.txt index ec32fafbce..e33f9b32e4 100644 --- a/admin/unidata/UnicodeData.txt +++ b/admin/unidata/UnicodeData.txt @@ -11836,6 +11836,7 @@ 32FC;CIRCLED KATAKANA WI;So;0;L; 30F0;;;;N;;;;; 32FD;CIRCLED KATAKANA WE;So;0;L; 30F1;;;;N;;;;; 32FE;CIRCLED KATAKANA WO;So;0;L; 30F2;;;;N;;;;; +32FF;SQUARE ERA NAME REIWA;So;0;L; 4EE4 548C;;;;N;;;;; 3300;SQUARE APAATO;So;0;L; 30A2 30D1 30FC 30C8;;;;N;SQUARED APAATO;;;; 3301;SQUARE ARUHUA;So;0;L; 30A2 30EB 30D5 30A1;;;;N;SQUARED ARUHUA;;;; 3302;SQUARE ANPEA;So;0;L; 30A2 30F3 30DA 30A2;;;;N;SQUARED ANPEA;;;; diff --git a/etc/NEWS b/etc/NEWS index 1b66862841..a4bc862d60 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -30,6 +30,11 @@ This allows disabling the new feature introduced in Emacs 26.1 which loads files during completion of 'C-h f' and 'C-h v' according to 'definition-prefixes'. +--- +** Emacs now supports the new Japanese Era name. +The newly assigned codepoint U+32FF was added to the Unicode Character +Database compiled into Emacs. + * Editing Changes in Emacs 26.3 diff --git a/test/lisp/international/ucs-normalize-tests.el b/test/lisp/international/ucs-normalize-tests.el index d31aa5b4a9..9f52003616 100644 --- a/test/lisp/international/ucs-normalize-tests.el +++ b/test/lisp/international/ucs-normalize-tests.el @@ -181,26 +181,25 @@ implementations: (should-not (ucs-normalize-tests--rule1-failing-for-partX 0))) (defconst ucs-normalize-tests--failing-lines-part1 - (list 15131 15132 15133 15134 15135 15136 15137 15138 - 15139 - 16149 16150 16151 16152 16153 16154 16155 16156 - 16157 16158 16159 16160 16161 16162 16163 16164 - 16165 16166 16167 16168 16169 16170 16171 16172 - 16173 16174 16175 16176 16177 16178 16179 16180 - 16181 16182 16183 16184 16185 16186 16187 16188 - 16189 16190 16191 16192 16193 16194 16195 16196 - 16197 16198 16199 16200 16201 16202 16203 16204 - 16205 16206 16207 16208 16209 16210 16211 16212 - 16213 16214 16215 16216 16217 16218 16219 16220 - 16221 16222 16223 16224 16225 16226 16227 16228 - 16229 16230 16231 16232 16233 16234 16235 16236 - 16237 16238 16239 16240 16241 16242 16243 16244 - 16245 16246 16247 16248 16249 16250 16251 16252 - 16253 16254 16255 16256 16257 16258 16259 16260 - 16261 16262 16263 16264 16265 16266 16267 16268 - 16269 16270 16271 16272 16273 16274 16275 16276 - 16277 16278 16279 16280 16281 16282 16283 16284 - 16285 16286 16287 16288 16289)) + (list 2152 15132 15133 15134 15135 15136 15137 15138 + 15139 15140 16150 16151 16152 16153 16154 16155 + 16156 16157 16158 16159 16160 16161 16162 16163 + 16164 16165 16166 16167 16168 16169 16170 16171 + 16172 16173 16174 16175 16176 16177 16178 16179 + 16180 16181 16182 16183 16184 16185 16186 16187 + 16188 16189 16190 16191 16192 16193 16194 16195 + 16196 16197 16198 16199 16200 16201 16202 16203 + 16204 16205 16206 16207 16208 16209 16210 16211 + 16212 16213 16214 16215 16216 16217 16218 16219 + 16220 16221 16222 16223 16224 16225 16226 16227 + 16228 16229 16230 16231 16232 16233 16234 16235 + 16236 16237 16238 16239 16240 16241 16242 16243 + 16244 16245 16246 16247 16248 16249 16250 16251 + 16252 16253 16254 16255 16256 16257 16258 16259 + 16260 16261 16262 16263 16264 16265 16266 16267 + 16268 16269 16270 16271 16272 16273 16274 16275 + 16276 16277 16278 16279 16280 16281 16282 16283 + 16284 16285 16286 16287 16288 16289 16290)) ;; Keep a record of failures, for consulting afterwards (the ert ;; backtrace only shows a truncated version of these lists). @@ -258,23 +257,21 @@ implementations: ucs-normalize-tests--failing-lines-part1))) (defconst ucs-normalize-tests--failing-lines-part2 - (list 17482 17532 17636 18338 18340 18342 18344 18346 - 18348 18350 18352 18354 18356 18358 18360 18362 - 18364 18366 18376 18378 18380 18382 18384 18386 - 18388 18390 18392 18394 18396 18398 18400 18402 - 18404 18406 18408 18410 18412 18414 18416 18418 - 18420 18422 18424 18426 18428 18430 18432 18434 - 18436 18438 18440 18442 18444 18446 18448 18450 - 18452 18454 18456 18458 18460 18462 18464 18466 - 18468 18470 18472 18474 18476 18478 18480 18482 - 18484 18486 18488 18490 18492 18494 18496 18564 - 18566 18568 18570 18572 18574 18576 18578 18580 - 18582 18584 18586 18588 18590 18592 18594 18596 - 18598 18600 18602 18604 18606 18608 18610 18612 - 18614 18616 18618 18620 18622 18624 18626 18628 - 18630 18632 18634 18636 18638 18640 18642 18644 - 18646 18648 18650 18652 18654 18656 18658 18660 - 18662 18664 18666)) + (list 18377 18379 18381 18383 18385 18387 18389 18391 + 18393 18395 18397 18399 18401 18403 18405 18407 + 18409 18411 18413 18415 18417 18419 18421 18423 + 18425 18427 18429 18431 18433 18435 18437 18439 + 18441 18443 18445 18447 18449 18451 18453 18455 + 18457 18459 18461 18463 18465 18467 18469 18471 + 18473 18475 18477 18479 18481 18483 18485 18487 + 18489 18491 18493 18495 18497 18565 18567 18569 + 18571 18573 18575 18577 18579 18581 18583 18585 + 18587 18589 18591 18593 18595 18597 18599 18601 + 18603 18605 18607 18609 18611 18613 18615 18617 + 18619 18621 18623 18625 18627 18629 18631 18633 + 18635 18637 18639 18641 18643 18645 18647 18649 + 18651 18653 18655 18657 18659 18661 18663 18665 + 18667)) (ert-deftest ucs-normalize-part2 () :tags '(:expensive-test) commit 0b810ebc9fe65e447e37832db40ccf634e5548d9 Author: Eli Zaretskii Date: Sun Aug 18 18:23:06 2019 +0300 Fix a typo in char-width-table * lisp/international/characters.el (char-width-table): Fix a typo in zero-width characters. diff --git a/lisp/international/characters.el b/lisp/international/characters.el index cdd8ba7c40..5682965915 100644 --- a/lisp/international/characters.el +++ b/lisp/international/characters.el @@ -986,8 +986,8 @@ with L, LRE, or LRO Unicode bidi character type.") (#x1039 . #x103A) (#x103D . #x103E) (#x1058 . #x1059) - (#x105E . #x1160) - (#x1171 . #x1074) + (#x105E . #x1060) + (#x1071 . #x1074) (#x1082 . #x1082) (#x1085 . #x1086) (#x108D . #x108D) commit f92d61c06c82d515ee83e340b8af4b1489778404 Author: Eli Zaretskii Date: Sun Aug 18 17:46:19 2019 +0300 Attempt to fix assertion violation in eval.c * src/eval.c (Fautoload): Fix an assertion violation in make_fixnum. Reported by martin rudalics . diff --git a/src/eval.c b/src/eval.c index cb9eb37b56..06d5c63f7f 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1995,7 +1995,7 @@ this does nothing and returns nil. */) and assumed the docstring will be provided by Snarf-documentation, so it passed us 0 instead. But that leads to accidental sharing in purecopy's hash-consing, so we use a (hopefully) unique integer instead. */ - docstring = make_fixnum (XHASH (function)); + docstring = make_ufixnum (XHASH (function)); return Fdefalias (function, list5 (Qautoload, file, docstring, interactive, type), Qnil); commit ee1c638cff27f3bcdd8936617d67f79fe07d6df1 Author: Lars Ingebrigtsen Date: Sat Aug 17 17:30:42 2019 -0700 Make `browse-url-of-buffer' work from zip files * lisp/net/browse-url.el (browse-url-of-buffer): Make `C-c C-v' work in HTML buffers visited from zip files and the like (bug#10318). diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 135f11f03c..3151dae0aa 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -714,16 +714,18 @@ narrowed." (and (not (buffer-narrowed-p)) (or buffer-file-name (and (boundp 'dired-directory) dired-directory))))) - (or file-name - (progn - (or browse-url-temp-file-name - (setq browse-url-temp-file-name - (convert-standard-filename - (make-temp-file - (expand-file-name "burl" browse-url-temp-dir) - nil ".html")))) - (setq file-name browse-url-temp-file-name) - (write-region (point-min) (point-max) file-name nil 'no-message))) + (when (or (not file-name) + ;; This can happen when we're looking at a file from a + ;; zip file buffer, for instance. + (not (file-exists-p file-name))) + (unless browse-url-temp-file-name + (setq browse-url-temp-file-name + (convert-standard-filename + (make-temp-file + (expand-file-name "burl" browse-url-temp-dir) + nil ".html")))) + (setq file-name browse-url-temp-file-name) + (write-region (point-min) (point-max) file-name nil 'no-message)) (browse-url-of-file file-name)))) (defun browse-url-delete-temp-file (&optional temp-file-name) commit 3d1c9a77c52664c8c3e4fa1ae25e1d13aab9b2f9 Author: Paul Eggert Date: Sat Aug 17 17:19:13 2019 -0700 Fix org-timer-show-remaining-time > 1 hour * lisp/org/org-timer.el (org-timer-show-remaining-time): Don’t assume the remaining time is less than one hour. Simplify. The simplification removes the need for a decode-time, and fixes a typo I introduced recently. diff --git a/lisp/org/org-timer.el b/lisp/org/org-timer.el index 20b33a1ef5..e1bbfa9709 100644 --- a/lisp/org/org-timer.el +++ b/lisp/org/org-timer.el @@ -380,17 +380,12 @@ VALUE can be `on', `off', or `paused'." (defun org-timer-show-remaining-time () "Display the remaining time before the timer ends." (interactive) - (require 'time) - (if (not org-timer-countdown-timer) - (message "No timer set") - (let* ((rtime (decode-time - (time-subtract (timer--time org-timer-countdown-timer) - nil) - 'integer)) - (rsecs (nth 0 rtime)) - (rmins (nth 1 rtime))) - (message "%d minute(s) %d seconds left before next time out" - rmins rsecs)))) + (message + (if (not org-timer-countdown-timer) + "No timer set" + (format-seconds + "%m minute(s) %s seconds left before next time out" + (time-subtract (timer--time org-timer-countdown-timer) nil))))) ;;;###autoload (defun org-timer-set-timer (&optional opt) commit f38a16ee89a03b838fc29c298e36f9b93a1ebfd2 Author: Lars Ingebrigtsen Date: Sat Aug 17 16:56:13 2019 -0700 Make `describe-function' say that disabled functions are disabled * lisp/help-fns.el (help-fns--disabled): New function (bug#10853). (help-fns-describe-function-functions): Add it to the list of function help functions. diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 7c059c25b7..90a3571520 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -593,6 +593,12 @@ FILE is the file where FUNCTION was probably defined." (insert " This function does not change global state, " "including the match data.\n"))) +(add-hook 'help-fns-describe-function-functions #'help-fns--disabled) +(defun help-fns--disabled (function) + (when (and (symbolp function) + (function-get function 'disabled)) + (insert " This function is disabled.\n"))) + (defun help-fns--first-release (symbol) "Return the likely first release that defined SYMBOL, or nil." ;; Code below relies on the etc/NEWS* files. commit 3efe59a8dd81e71597542e83eefc33fc6faab9a1 Author: Lars Ingebrigtsen Date: Sat Aug 17 16:47:16 2019 -0700 Make newline-and-indent take a numeric prefix * lisp/simple.el (newline-and-indent): Take a prefix argument to say how many times to perform its action (bug#10927). diff --git a/etc/NEWS b/etc/NEWS index 53408a871e..25c5ce658f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -417,6 +417,11 @@ RGB triplets with a single hexadecimal digit per component. * Editing Changes in Emacs 27.1 +--- +** The 'newline-and-indent' command (commonly bound to 'RET' in many +modes) now takes an optional numeric argument to specify how many +times is should insert newlines (and indent). + +++ ** New command 'make-empty-file'. diff --git a/lisp/simple.el b/lisp/simple.el index fdf7d893cd..84497c31b2 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -745,16 +745,21 @@ buffer if the variable `delete-trailing-lines' is non-nil." ;; Return nil for the benefit of `write-file-functions'. nil) -(defun newline-and-indent () +(defun newline-and-indent (&optional arg) "Insert a newline, then indent according to major mode. Indentation is done using the value of `indent-line-function'. In programming language modes, this is the same as TAB. In some text modes, where TAB inserts a tab, this command indents to the -column specified by the function `current-left-margin'." - (interactive "*") +column specified by the function `current-left-margin'. + +With ARG, perform this action that many times." + (interactive "*p") (delete-horizontal-space t) - (newline nil t) - (indent-according-to-mode)) + (unless arg + (setq arg 1)) + (dotimes (_ arg) + (newline nil t) + (indent-according-to-mode))) (defun reindent-then-newline-and-indent () "Reindent current line, insert newline, then indent the new line. commit 2b9145312c4cebfd95d2d0e78ba93dbbbc9019c4 Author: Lars Ingebrigtsen Date: Sat Aug 17 16:35:54 2019 -0700 Issue a message on `C-x o' and there's no other window * lisp/window.el (other-window): Issue a message when the user types `C-x o' and there's no other window to select (bug#10999). diff --git a/lisp/window.el b/lisp/window.el index 2345f398e7..723671efa5 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -3926,6 +3926,7 @@ select. The argument ALL-FRAMES has the same meaning as in always effectively nil." (interactive "p") (let* ((window (selected-window)) + (original-window window) (function (and (not ignore-window-parameters) (window-parameter window 'other-window))) old-window old-count) @@ -3968,6 +3969,10 @@ always effectively nil." (t (setq count (1+ count))))) + (when (and (eq window original-window) + (called-interactively-p 'interactive)) + (message "No other window to select")) + (select-window window) ;; Always return nil. nil)))) commit 78541163c63794a80c101c0011e05e7ac65734b2 Author: Lars Ingebrigtsen Date: Sat Aug 17 16:31:55 2019 -0700 Issue a message on `C-x 1' when there's nothing to do * lisp/window.el (delete-other-windows): Make `C-x 1' issue a message when there's no other windows to delete (bug#10999). diff --git a/lisp/window.el b/lisp/window.el index 5af66a036d..2345f398e7 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -4260,7 +4260,11 @@ any window whose `no-delete-other-windows' parameter is non-nil." (throw 'done nil))) ;; If WINDOW is the main window of its frame do nothing. - (unless (eq window main) + (if (eq window main) + ;; Give a message to the user if this has been called as a + ;; command. + (when (called-interactively-p 'interactive) + (message "No other windows to delete")) (delete-other-windows-internal window main) (window--check frame)) ;; Always return nil. commit 669599b0f4b59029fd977609be02f754a3b075eb Author: Lars Ingebrigtsen Date: Sat Aug 17 14:52:15 2019 -0700 Doc clarification in two comment-* functions * lisp/newcomment.el (comment-padright, comment-padleft): Note that `comment-normalize-vars' must be called first (bug#11944). diff --git a/lisp/newcomment.el b/lisp/newcomment.el index ac706b949b..027c20430c 100644 --- a/lisp/newcomment.el +++ b/lisp/newcomment.el @@ -825,7 +825,9 @@ If STR already contains padding, the corresponding amount is ignored from `comment-padding'. N defaults to 0. If N is `re', a regexp is returned instead, that would match -the string for any N." +the string for any N. + +Ensure that `comment-normalize-vars' has been called before you use this." (setq n (or n 0)) (when (and (stringp str) (string-match "\\S-" str)) ;; Separate the actual string from any leading/trailing padding @@ -860,8 +862,10 @@ It also adds N copies of the first non-whitespace chars of STR. If STR already contains padding, the corresponding amount is ignored from `comment-padding'. N defaults to 0. -If N is `re', a regexp is returned instead, that would match - the string for any N." +If N is `re', a regexp is returned instead, that would match the +string for any N. + +Ensure that `comment-normalize-vars' has been called before you use this." (setq n (or n 0)) (when (and (stringp str) (not (string= "" str))) ;; Only separate the left pad because we assume there is no right pad. commit c90a420779448fecf1941f063da3e8276dc3d0d7 Author: Paul Eggert Date: Sat Aug 17 15:39:18 2019 -0700 Add FIXMEs for subsecond support This adds FIXMEs to areas where Lisp code should support subsecond information in broken-down timestamps. It also fixes some unnecessary truncation of timestamps, and ports the code to a hypothetical future Emacs version where (decode-time) returns subsecond timestamps by default. * lisp/calc/calc-forms.el (calc-time, math-iso-dt-to-date) (calcFunc-now): * lisp/calendar/icalendar.el (icalendar--add-decoded-times): * lisp/calendar/iso8601.el (iso8601-parse-interval): Truncate seconds to an integer, and add a FIXME about subseconds support. * lisp/calendar/icalendar.el (icalendar--decode-isodatetime) (icalendar--decode-isoduration): Add a FIXME about subseconds support. * lisp/gnus/gnus-delay.el (gnus-delay-article): Don’t truncate seconds to an integer, as there’s no need to do that here. * lisp/gnus/gnus-util.el (gnus-seconds-today) (gnus-seconds-month, gnus-seconds-year): * lisp/gnus/message.el (message-make-expires-date): * lisp/org/org-timer.el (org-timer-show-remaining-time): * lisp/vc/ediff-mult.el (ediff-format-date): Truncate seconds to an integer, as that’s what’s wanted here. * lisp/midnight.el (midnight-next): Ceiling seconds to an integer, as that’s what wanted here. diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el index c410ffe449..7e8a8dcc9d 100644 --- a/lisp/calc/calc-forms.el +++ b/lisp/calc/calc-forms.el @@ -37,7 +37,7 @@ (defun calc-time () (interactive) (calc-wrapper - (let ((time (decode-time))) + (let ((time (decode-time nil nil 'integer))) ;; FIXME: Support subseconds. (calc-enter-result 0 "time" (list 'mod (list 'hms @@ -499,7 +499,8 @@ in the Gregorian calendar and the remaining part determines the time." (math-add (math-float date) (math-div (math-add (+ (* (nth 3 dt) 3600) (* (nth 4 dt) 60)) - (nth 5 dt)) + ;; FIXME: Support subseconds. + (time-convert (nth 5 dt) 'integer)) '(float 864 2))) date))) @@ -1327,7 +1328,8 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)." (math-parse-iso-date-validate isoyear isoweek isoweekday hour minute second))))) (defun calcFunc-now (&optional zone) - (let ((date (let ((now (decode-time))) + ;; FIXME: Support subseconds. + (let ((date (let ((now (decode-time nil nil 'integer))) (list 'date (math-dt-to-date (list (decoded-time-year now) (decoded-time-month now) diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index c2688705e3..3c46982c7b 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -628,6 +628,7 @@ FIXME: multiple comma-separated values should be allowed!" (when (> (length isodatetimestring) 14) ;; seconds present (setq second (read (substring isodatetimestring 13 15)))) + ;; FIXME: Support subseconds. (when (and (> (length isodatetimestring) 15) ;; UTC specifier present (char-equal ?Z (aref isodatetimestring 15))) @@ -703,6 +704,7 @@ FIXME: multiple comma-separated values should be allowed!" (setq minutes (read (substring isodurationstring (match-beginning 10) (match-end 10))))) + ;; FIXME: Support subseconds. (if (match-beginning 11) (setq seconds (read (substring isodurationstring (match-beginning 12) @@ -719,9 +721,12 @@ FIXME: multiple comma-separated values should be allowed!" "Add TIME1 to TIME2. Both times must be given in decoded form. One of these times must be valid (year > 1900 or something)." - ;; FIXME: does this function exist already? + ;; FIXME: does this function exist already? Can we use decoded-time-add? (decode-time (encode-time - (+ (decoded-time-second time1) (decoded-time-second time2)) + ;; FIXME: Support subseconds. + (time-convert (time-add (decoded-time-second time1) + (decoded-time-second time2)) + 'integer) (+ (decoded-time-minute time1) (decoded-time-minute time2)) (+ (decoded-time-hour time1) (decoded-time-hour time2)) (+ (decoded-time-day time1) (decoded-time-day time2)) diff --git a/lisp/calendar/iso8601.el b/lisp/calendar/iso8601.el index 30352c7e75..0f42c824e3 100644 --- a/lisp/calendar/iso8601.el +++ b/lisp/calendar/iso8601.el @@ -322,9 +322,10 @@ Return the number of minutes." duration)))) (list start end (or duration + ;; FIXME: Support subseconds. (decode-time (time-subtract (iso8601--encode-time end) (iso8601--encode-time start)) - (or (decoded-time-zone end) 0)))))) + (or (decoded-time-zone end) 0) 'integer))))) (defun iso8601--match (regexp string) (string-match (concat "\\`" regexp "\\'") string)) diff --git a/lisp/gnus/gnus-delay.el b/lisp/gnus/gnus-delay.el index aabf23924a..512011fa73 100644 --- a/lisp/gnus/gnus-delay.el +++ b/lisp/gnus/gnus-delay.el @@ -98,7 +98,7 @@ DELAY is a string, giving the length of the time. Possible values are: (setq hour (string-to-number (match-string 1 delay)) minute (string-to-number (match-string 2 delay))) ;; Use current time, except... - (setq deadline (decode-time)) + (setq deadline (decode-time nil nil t)) ;; ... for minute and hour. (setq deadline (apply #'encode-time (car deadline) minute hour (nthcdr 3 deadline))) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index c6be59fd19..f73af8e261 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -357,24 +357,24 @@ Symbols are also allowed; their print names are used instead." ;; the full date if it's older) (defun gnus-seconds-today () - "Return the number of seconds passed today." - (let ((now (decode-time))) + "Return the integer number of seconds passed today." + (let ((now (decode-time nil nil 'integer))) (+ (decoded-time-second now) (* (decoded-time-minute now) 60) (* (decoded-time-hour now) 3600)))) (defun gnus-seconds-month () - "Return the number of seconds passed this month." - (let ((now (decode-time))) + "Return the integer number of seconds passed this month." + (let ((now (decode-time nil nil 'integer))) (+ (decoded-time-second now) (* (decoded-time-minute now) 60) (* (decoded-time-hour now) 3600) (* (- (decoded-time-day now) 1) 3600 24)))) (defun gnus-seconds-year () - "Return the number of seconds passed this year." + "Return the integer number of seconds passed this year." (let* ((current (current-time)) - (now (decode-time current)) + (now (decode-time current nil 'integer)) (days (format-time-string "%j" current))) (+ (decoded-time-second now) (* (decoded-time-minute now) 60) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 0a540a6221..48d79107ea 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -5508,7 +5508,7 @@ If NOW, use that time instead." "Make date string for the Expires header. Expiry in DAYS days. In posting styles use `(\"Expires\" (make-expires-date 30))'." - (let* ((cur (decode-time)) + (let* ((cur (decode-time nil nil 'integer)) (nday (+ days (decoded-time-day cur)))) (setf (decoded-time-day cur) nday) (message-make-date (encode-time cur)))) diff --git a/lisp/midnight.el b/lisp/midnight.el index fa41d80a69..aad5236819 100644 --- a/lisp/midnight.el +++ b/lisp/midnight.el @@ -193,8 +193,8 @@ The default value is `clean-buffer-list'." :type 'hook) (defun midnight-next () - "Return the number of seconds till the next midnight." - (pcase-let ((`(,sec ,min ,hrs) (decode-time))) + "Return the number of whole or partial seconds till the next midnight." + (pcase-let ((`(,sec ,min ,hrs) (decode-time nil nil 'integer))) (- (* 24 60 60) (* 60 60 hrs) (* 60 min) sec))) ;;;###autoload diff --git a/lisp/org/org-timer.el b/lisp/org/org-timer.el index 6529a8b0dd..20b33a1ef5 100644 --- a/lisp/org/org-timer.el +++ b/lisp/org/org-timer.el @@ -385,7 +385,8 @@ VALUE can be `on', `off', or `paused'." (message "No timer set") (let* ((rtime (decode-time (time-subtract (timer--time org-timer-countdown-timer) - nil))) + nil) + 'integer)) (rsecs (nth 0 rtime)) (rmins (nth 1 rtime))) (message "%d minute(s) %d seconds left before next time out" diff --git a/lisp/vc/ediff-mult.el b/lisp/vc/ediff-mult.el index 1bdaca268e..66d14e6b06 100644 --- a/lisp/vc/ediff-mult.el +++ b/lisp/vc/ediff-mult.el @@ -1210,7 +1210,8 @@ behavior." (decoded-time-year time) (ediff-fill-leading-zero (decoded-time-hour time)) (ediff-fill-leading-zero (decoded-time-minute time)) - (ediff-fill-leading-zero (decoded-time-second time)))) + (ediff-fill-leading-zero (time-convert (decoded-time-second time) + 'integer)))) ;; Draw the directories (defun ediff-insert-dirs-in-meta-buffer (meta-list) commit 6616806896060d95355c965599517d7065c19b86 Author: Juri Linkov Date: Sun Aug 18 01:40:32 2019 +0300 * lisp/frameset.el (frameset-restore): Make sure last-focus frame has focus. Call select-frame-set-input-focus to restore focus on the frame that had last-focus-update frame parameter before saving frameset. (Bug#36894) diff --git a/lisp/frameset.el b/lisp/frameset.el index 60b6fe38ad..9a7a75f5ef 100644 --- a/lisp/frameset.el +++ b/lisp/frameset.el @@ -1346,6 +1346,16 @@ All keyword parameters default to nil." (error (delay-warning 'frameset (error-message-string err) :warning)))))) + ;; Make sure the frame with last-focus-update has focus. + (let ((last-focus-frame + (catch 'last-focus + (maphash (lambda (frame _) + (when (frame-parameter frame 'last-focus-update) + (throw 'last-focus frame))) + frameset--action-map)))) + (when last-focus-frame + (select-frame-set-input-focus last-focus-frame))) + ;; Make sure there's at least one visible frame. (unless (or (daemonp) (catch 'visible commit c81c041f605afe9c9fb64d4f821a153dafd6f94d Author: Lars Ingebrigtsen Date: Sat Aug 17 14:17:47 2019 -0700 Doc clarification for call-interactively * src/callint.c (Fcall_interactively): Be explicit about what we mean by "inquire" in the doc string (bug#15653). diff --git a/src/callint.c b/src/callint.c index 812287d365..d76836f32b 100644 --- a/src/callint.c +++ b/src/callint.c @@ -268,8 +268,9 @@ means unconditionally put this command in the variable `command-history'. Otherwise, this is done only if an arg is read using the minibuffer. Optional third arg KEYS, if given, specifies the sequence of events to -supply, as a vector, if the command inquires which events were used to -invoke it. If KEYS is omitted or nil, the return value of +supply, as a vector, if FUNCTION inquires which events were used to +invoke it (via an `interactive' spec that contains, for instance, an +\"e\" code letter). If KEYS is omitted or nil, the return value of `this-command-keys-vector' is used. */) (Lisp_Object function, Lisp_Object record_flag, Lisp_Object keys) { commit 643df79279d0a7264361780cc6a7ded54d921947 Author: Paul Eggert Date: Sat Aug 17 09:15:32 2019 -0700 Port test harness to Solaris 10 * test/Makefile.in (ELFILES): Port to Solaris 10, where ‘find’ does not support ‘-path’. diff --git a/test/Makefile.in b/test/Makefile.in index c18099587c..b795907208 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -200,8 +200,8 @@ EXCLUDE_TESTS = ## take longer than all the rest combined) at the start of the list. SLOW_TESTS = ${srcdir}/lisp/net/tramp-tests.el -ELFILES := $(sort $(shell find ${srcdir} -path "${srcdir}/manual" -prune -o \ - -path "${srcdir}/data" -prune -o \ +ELFILES := $(sort $(shell find ${srcdir} -name manual -prune -o \ + -name data -prune -o \ -name "*resources" -prune -o \ ${maybe_exclude_module_tests} \ -name "*.el" ! -name ".*" -print)) commit 3f00db7ca6d40312651a302842561e7fb168ee99 Author: Eli Zaretskii Date: Sat Aug 17 18:13:58 2019 +0300 Minor update in admin/notes/unicode * admin/notes/unicode: Mention changes to be done in setup-default-fontset in fontset.el. (Bug#14461) diff --git a/admin/notes/unicode b/admin/notes/unicode index d641e60ff7..da0b065572 100644 --- a/admin/notes/unicode +++ b/admin/notes/unicode @@ -49,6 +49,9 @@ of OTF script tags in otf-script-alist, whose source is on this page: https://docs.microsoft.com/en-us/typography/opentype/spec/scripttags Other databases in fontset.el might also need to be updated as needed. +One notable place to check is the function setup-default-fontset, +where new scripts will generally need some addition, most probably to +the list of "simple" scripts (search for "Simple"). The function 'ucs-names', defined in lisp/international/mule-cmds.el, might need to be updated because it knows about used and unused ranges commit bcd0115e4db49791a77566b80fabc4384d9ebf57 Author: Noam Postavsky Date: Fri Aug 16 07:26:40 2019 -0400 Fix lisp indent infloop on unfinished strings (Bug#37045) * lisp/emacs-lisp/lisp-mode.el (lisp-indent-calc-next): Stop trying to skip over strings if we've hit the end of buffer. * test/lisp/emacs-lisp/lisp-mode-tests.el (lisp-indent-unfinished-string): New test. diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 74bf0c87c5..bde0a4ea6d 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -810,7 +810,7 @@ by more than one line to cross a string literal." (setq last-sexp (nth 2 ppss))) (setq depth (car ppss)) ;; Skip over newlines within strings. - (nth 3 ppss)) + (and (not (eobp)) (nth 3 ppss))) (let ((string-start (nth 8 ppss))) (setq ppss (parse-partial-sexp (point) (point-max) nil nil ppss 'syntax-table)) @@ -826,17 +826,22 @@ by more than one line to cross a string literal." indent-stack))))) (prog1 (let (indent) - (cond ((= (forward-line 1) 1) nil) - ;; Negative depth, probably some kind of syntax error. + (cond ((= (forward-line 1) 1) + ;; Can't move to the next line, apparently end of buffer. + nil) ((null indent-stack) - ;; Reset state. + ;; Negative depth, probably some kind of syntax + ;; error. Reset the state. (setq ppss (parse-partial-sexp (point) (point)))) ((car indent-stack)) ((integerp (setq indent (calculate-lisp-indent ppss))) (setf (car indent-stack) indent)) ((consp indent) ; (COLUMN CONTAINING-SEXP-START) (car indent)) - ;; This only happens if we're in a string. + ;; This only happens if we're in a string, but the + ;; loop should always skip over strings (unless we hit + ;; end of buffer, which is taken care of by the first + ;; clause). (t (error "This shouldn't happen")))) (setf (lisp-indent-state-stack state) indent-stack) (setf (lisp-indent-state-ppss-point state) ppss-point) diff --git a/test/lisp/emacs-lisp/lisp-mode-tests.el b/test/lisp/emacs-lisp/lisp-mode-tests.el index 63632449ca..e4ba929ecb 100644 --- a/test/lisp/emacs-lisp/lisp-mode-tests.el +++ b/test/lisp/emacs-lisp/lisp-mode-tests.el @@ -284,7 +284,11 @@ Expected initialization file: `%s'\" (lisp-indent-line) (should (equal (buffer-string) "prompt> foo")))) - +(ert-deftest lisp-indent-unfinished-string () + "Don't infloop on unfinished string (Bug#37045)." + (with-temp-buffer + (insert "\"\n") + (lisp-indent-region (point-min) (point-max)))) (provide 'lisp-mode-tests) ;;; lisp-mode-tests.el ends here commit 5f992d1990d9f351cf907dcf2066f573e0fe9407 Author: Eli Zaretskii Date: Sat Aug 17 14:21:47 2019 +0300 Improve commentary in composite.el * lisp/composite.el (compose-gstring-for-graphic) (compose-gstring-for-terminal): Add comments that explain Unicode General Category mnemonics in human-readable terms. (Bug#14461) diff --git a/lisp/composite.el b/lisp/composite.el index e50e5d381e..76722f93c4 100644 --- a/lisp/composite.el +++ b/lisp/composite.el @@ -554,6 +554,11 @@ All non-spacing characters have this function in ;; This sequence doesn't start with a proper base character. ((memq (get-char-code-property (lgstring-char gstring 0) 'general-category) + ;; "Improper" base characters are of the following general + ;; categories: + ;; Mark (nonspacing, combining, enclosing) + ;; Separator (space, line, paragraph) + ;; Other (control, format, surrogate) '(Mn Mc Me Zs Zl Zp Cc Cf Cs)) nil) @@ -646,6 +651,7 @@ All non-spacing characters have this function in de (+ de yoff))) ((and (= class 0) (eq (get-char-code-property (lglyph-char glyph) + ;; Me = enclosing mark 'general-category) 'Me)) ;; Artificially laying out glyphs in an enclosing ;; mark is difficult. All we can do is to adjust @@ -771,7 +777,8 @@ prepending a space before it." 'general-category) 'Cf) (progn - ;; Compose by replacing with a space. + ;; Compose Cf (format) control characters by + ;; replacing with a space. (lglyph-set-char glyph 32) (lglyph-set-width glyph 1) (setq i (1+ i))) commit 9e2ac2559ab44767a56add8ff6e0993325f31971 Author: Paul Eggert Date: Sat Aug 17 03:27:58 2019 -0700 Update from Gnulib This incorporates: 2019-08-17 intprops: port to Oracle Developer Studio 12.6 2019-08-14 intprops: support uchar, ushort _WRAPV dests * lib/intprops.h: Copy from Gnulib. diff --git a/lib/intprops.h b/lib/intprops.h index d1785ac6f1..fe67c1f305 100644 --- a/lib/intprops.h +++ b/lib/intprops.h @@ -311,10 +311,9 @@ arguments should not have side effects. The WRAPV macros are not constant expressions. They support only - +, binary -, and *. The result type must be either signed, or an - unsigned type that is 'unsigned int' or wider. Because the WRAPV - macros convert the result, the report overflow in different - circumstances than the OVERFLOW macros do. + +, binary -, and *. Because the WRAPV macros convert the result, + they report overflow in different circumstances than the OVERFLOW + macros do. These macros are tuned for their last input argument being a constant. @@ -417,29 +416,41 @@ unsigned long int, 0, ULONG_MAX), \ long long int: \ _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long long int, \ - long long int, LLONG_MIN, LLONG_MAX), + long long int, LLONG_MIN, LLONG_MAX), \ unsigned long long int: \ _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long long int, \ - unsigned long long int, ULLONG_MIN, ULLONG_MAX))) + unsigned long long int, 0, ULLONG_MAX))) #else -/* This fallback implementation uses _GL_SIGNED_TYPE_OR_EXPR, and so - may guess wrong on some non-GNU pre-C11 compilers when the type of - *R is unsigned char or unsigned short. This is why the - documentation for INT_ADD_WRAPV says that the result type, if - unsigned, should be unsigned int or wider. */ +/* Store the low-order bits of A B into *R, where OP specifies + the operation and OVERFLOW the overflow predicate. If *R is + signed, its type is ST with bounds SMIN..SMAX; otherwise its type + is UT with bounds U..UMAX. ST and UT are narrower than int. + Return 1 if the result overflows. See above for restrictions. */ +# if _GL_HAVE___TYPEOF__ +# define _GL_INT_OP_WRAPV_SMALLISH(a,b,r,op,overflow,st,smin,smax,ut,umax) \ + (TYPE_SIGNED (__typeof__ (*(r))) \ + ? _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, st, smin, smax) \ + : _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, ut, 0, umax)) +# else +# define _GL_INT_OP_WRAPV_SMALLISH(a,b,r,op,overflow,st,smin,smax,ut,umax) \ + (overflow (a, b, smin, smax) \ + ? (overflow (a, b, 0, umax) \ + ? (*(r) = _GL_INT_OP_WRAPV_VIA_UNSIGNED (a,b,op,unsigned,st), 1) \ + : (*(r) = _GL_INT_OP_WRAPV_VIA_UNSIGNED (a,b,op,unsigned,st)) < 0) \ + : (overflow (a, b, 0, umax) \ + ? (*(r) = _GL_INT_OP_WRAPV_VIA_UNSIGNED (a,b,op,unsigned,st)) >= 0 \ + : (*(r) = _GL_INT_OP_WRAPV_VIA_UNSIGNED (a,b,op,unsigned,st), 0))) +# endif + # define _GL_INT_OP_WRAPV(a, b, r, op, builtin, overflow) \ (sizeof *(r) == sizeof (signed char) \ - ? (_GL_SIGNED_TYPE_OR_EXPR (*(r)) \ - ? _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ - signed char, SCHAR_MIN, SCHAR_MAX) \ - : _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ - unsigned char, 0, UCHAR_MAX)) \ + ? _GL_INT_OP_WRAPV_SMALLISH (a, b, r, op, overflow, \ + signed char, SCHAR_MIN, SCHAR_MAX, \ + unsigned char, UCHAR_MAX) \ : sizeof *(r) == sizeof (short int) \ - ? (_GL_SIGNED_TYPE_OR_EXPR (*(r)) \ - ? _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ - short int, SHRT_MIN, SHRT_MAX) \ - : _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ - unsigned short int, 0, USHRT_MAX)) \ + ? _GL_INT_OP_WRAPV_SMALLISH (a, b, r, op, overflow, \ + short int, SHRT_MIN, SHRT_MAX, \ + unsigned short int, USHRT_MAX) \ : sizeof *(r) == sizeof (int) \ ? (EXPR_SIGNED (*(r)) \ ? _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ @@ -541,8 +552,8 @@ <= -1 - (a))) \ : INT_NEGATE_OVERFLOW (_GL_INT_CONVERT (b, tmin)) && (b) == -1 \ ? (EXPR_SIGNED (a) \ - ? 0 < (a) + (tmin) \ - : 0 < (a) && -1 - (tmin) < (a) - 1) \ + ? 0 < (a) + (tmin) \ + : 0 < (a) && -1 - (tmin) < (a) - 1) \ : (tmin) / (b) < (a)) \ : (b) == 0 \ ? 0 \ commit c863170f0c0876b1f0f6740b9bfd25a9d9c87e20 Author: Eli Zaretskii Date: Sat Aug 17 13:02:29 2019 +0300 Improve support of the ancient Egyptian script * lisp/international/fontset.el (script-representative-chars) (setup-default-fontset): Add Egyptian. (Bug#15420) diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el index 0413646dfb..f3ab81633d 100644 --- a/lisp/international/fontset.el +++ b/lisp/international/fontset.el @@ -246,6 +246,7 @@ (makasar #x11EE0) (cuneiform #x12000) (cuneiform-numbers-and-punctuation #x12400) + (egyptian #x13000) (mro #x16A40) (bassa-vah #x16AD0) (pahawh-hmong #x16B11) @@ -708,8 +709,8 @@ ;; For simple scripts (dolist (script '(phonetic armenian - syriac thaana + syriac georgian cherokee canadian-aboriginal @@ -734,8 +735,9 @@ phoenician lydian kharoshthi - cuneiform cuneiform-numbers-and-punctuation + cuneiform + egyptian byzantine-musical-symbol musical-symbol ancient-greek-musical-notation commit abd3fdf7b8ce09b67012534c72fe0751c2f23f1e Merge: 6715e6af10 743cc86a05 Author: Eli Zaretskii Date: Sat Aug 17 12:25:32 2019 +0300 Merge branch 'master' of git.savannah.gnu.org:/srv/git/emacs commit 743cc86a053d536a4bfe8d519840c0b4cc2ce02e Author: Paul Eggert Date: Sat Aug 17 02:21:25 2019 -0700 Have time-add etc. respect CURRENT_TIME_LIST too * src/timefns.c (time_arith) [!CURRENT_TIME_LIST]: Don’t generate a list, since CURRENT_TIME_LIST is false. diff --git a/src/timefns.c b/src/timefns.c index 16c39c8349..bf49843aae 100644 --- a/src/timefns.c +++ b/src/timefns.c @@ -1090,11 +1090,14 @@ time_arith (Lisp_Object a, Lisp_Object b, bool subtract) } /* Return an integer if the timestamp resolution is 1, - otherwise the (TICKS . HZ) form if either argument is that way, - otherwise the (HI LO US PS) form for backward compatibility. */ + otherwise the (TICKS . HZ) form if !CURRENT_TIME_LIST or if + either input form supports timestamps that cannot be expressed + exactly in (HI LO US PS) form, otherwise the (HI LO US PS) form + for backward compatibility. */ return (EQ (hz, make_fixnum (1)) ? ticks - : timeform_sub_ps_p (aform) || timeform_sub_ps_p (bform) + : (!CURRENT_TIME_LIST + || timeform_sub_ps_p (aform) || timeform_sub_ps_p (bform)) ? Fcons (ticks, hz) : ticks_hz_list4 (ticks, hz)); } commit 3a04be20056f19c5ffbf448128ccce067d11e99e Author: Eli Zaretskii Date: Sat Aug 17 11:02:52 2019 +0300 ; Improve commentary in xdisp.c * src/xdisp.c: Add to the commentary the description of stop_charpos, and how it is used during iteration. diff --git a/src/xdisp.c b/src/xdisp.c index aa6e1bd2df..3b8cfab059 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -152,6 +152,8 @@ along with GNU Emacs. If not, see . */ description of the environment in which the text is to be displayed. But this is too early, read on. + Iteration over buffer and strings. + Characters and pixmaps displayed for a range of buffer text depend on various settings of buffers and windows, on overlays and text properties, on display tables, on selective display. The good news @@ -176,6 +178,46 @@ along with GNU Emacs. If not, see . */ current X and Y position, and lots of other stuff you can better see in dispextern.h. + The "stop position". + + Some of the fields maintained by the iterator change relatively + infrequently. These include the face of the characters, whether + text is invisible, the object (buffer or display or overlay string) + being iterated, character composition info, etc. For any given + buffer or string position, these sources of information that + affects the display can be determined by calling the appropriate + primitives, such as Fnext_single_property_change, but both these + calls and the processing of their return values is relatively + expensive. To optimize redisplay, the display engine checks these + sources of display information only when needed. To that end, it + always maintains the position of the next place where it must stop + and re-examine all those potential sources. This is called "stop + position" and is stored in the stop_charpos field of the iterator. + The stop position is updated by compute_stop_pos, which is called + whenever the iteration reaches the current stop position and + processes it. Processing a stop position is done by handle_stop, + which invokes a series of handlers, one each for every potential + source of display-related information; see the it_props array for + those handlers. For example, one handler is handle_face_prop, + which detects changes in face properties, and supplies the face ID + that the iterator will use for all the glyphs it generates up to + the next stop position; this face ID is the result of realizing the + face specified by the relevant text properties at this position. + Each handler called by handle_stop processes the sources of display + information for which it is "responsible", and returns a value + which tells handle_stop what to do next. + + Once handle_stop returns, the information it stores in the iterator + fields will not be refreshed until the iteration reaches the next + stop position, which is computed by compute_stop_pos called at the + end of handle_stop. compute_stop_pos examines the buffer's or + string's interval tree to determine where the text properties + change, finds the next position where overlays and character + composition can change, and stores in stop_charpos the closest + position where any of these factors should be reconsider. + + Producing glyphs. + Glyphs in a desired matrix are normally constructed in a loop calling get_next_display_element and then PRODUCE_GLYPHS. The call to PRODUCE_GLYPHS will fill the iterator structure with pixel @@ -191,23 +233,28 @@ along with GNU Emacs. If not, see . */ Frame matrices. That just couldn't be all, could it? What about terminal types not - supporting operations on sub-windows of the screen? To update the - display on such a terminal, window-based glyph matrices are not - well suited. To be able to reuse part of the display (scrolling - lines up and down), we must instead have a view of the whole - screen. This is what `frame matrices' are for. They are a trick. - - Frames on terminals like above have a glyph pool. Windows on such - a frame sub-allocate their glyph memory from their frame's glyph + supporting operations on sub-windows of the screen (a.k.a. "TTY" or + "text-mode terminal")? To update the display on such a terminal, + window-based glyph matrices are not well suited. To be able to + reuse part of the display (scrolling lines up and down), we must + instead have a view of the whole screen. This is what `frame + matrices' are for. They are a trick. + + Frames on text terminals have a glyph pool. Windows on such a + frame sub-allocate their glyph memory from their frame's glyph pool. The frame itself is given its own glyph matrices. By coincidence---or maybe something else---rows in window glyph matrices are slices of corresponding rows in frame matrices. Thus writing to window matrices implicitly updates a frame matrix which provides us with the view of the whole screen that we originally - wanted to have without having to move many bytes around. To be - honest, there is a little bit more done, but not much more. If you - plan to extend that code, take a look at dispnew.c. The function - build_frame_matrix is a good starting point. + wanted to have without having to move many bytes around. Then + updating all the visible windows on text-terminal frames is done by + using the frame matrices, which allows frame-global optimization of + what is actually written to the glass. + + To be honest, there is a little bit more done, but not much more. + If you plan to extend that code, take a look at dispnew.c. The + function build_frame_matrix is a good starting point. Bidirectional display. @@ -220,9 +267,10 @@ along with GNU Emacs. If not, see . */ concerned, the effect of calling bidi_move_to_visually_next, the main interface of the reordering engine, is that the iterator gets magically placed on the buffer or string position that is to be - displayed next. In other words, a linear iteration through the - buffer/string is replaced with a non-linear one. All the rest of - the redisplay is oblivious to the bidi reordering. + displayed next in the visual order. In other words, a linear + iteration through the buffer/string is replaced with a non-linear + one. All the rest of the redisplay is oblivious to the bidi + reordering. Well, almost oblivious---there are still complications, most of them due to the fact that buffer and string positions no longer @@ -231,7 +279,8 @@ along with GNU Emacs. If not, see . */ monotonously changing with vertical positions. Also, accounting for face changes, overlays, etc. becomes more complex because non-linear iteration could potentially skip many positions with - changes, and then cross them again on the way back... + changes, and then cross them again on the way back (see + handle_stop_backwards)... One other prominent effect of bidirectional display is that some paragraphs of text need to be displayed starting at the right @@ -252,7 +301,7 @@ along with GNU Emacs. If not, see . */ This way, the terminal-specific back-end can still draw the glyphs left to right, even for R2L lines. - Bidirectional display and character compositions + Bidirectional display and character compositions. Some scripts cannot be displayed by drawing each character individually, because adjacent characters change each other's shape @@ -272,15 +321,15 @@ along with GNU Emacs. If not, see . */ Each of these grapheme clusters is then delivered to PRODUCE_GLYPHS in the direction corresponding to the current bidi scan direction (recorded in the scan_dir member of the `struct bidi_it' object - that is part of the buffer iterator). In particular, if the bidi - iterator currently scans the buffer backwards, the grapheme - clusters are delivered back to front. This reorders the grapheme - clusters as appropriate for the current bidi context. Note that - this means that the grapheme clusters are always stored in the - LGSTRING object (see composite.c) in the logical order. + that is part of the iterator). In particular, if the bidi iterator + currently scans the buffer backwards, the grapheme clusters are + delivered back to front. This reorders the grapheme clusters as + appropriate for the current bidi context. Note that this means + that the grapheme clusters are always stored in the LGSTRING object + (see composite.c) in the logical order. Moving an iterator in bidirectional text - without producing glyphs + without producing glyphs. Note one important detail mentioned above: that the bidi reordering engine, driven by the iterator, produces characters in R2L rows commit 6715e6af10421b8bf5cc26e42e7c8e11f08769c8 Author: Eli Zaretskii Date: Sat Aug 17 09:28:52 2019 +0300 Fix a recent documentation change * doc/emacs/windows.texi (Other Window): Add a cross-reference to "Rebinding". (Bug#12431) diff --git a/doc/emacs/windows.texi b/doc/emacs/windows.texi index 64b61db1cb..19f6cff7bf 100644 --- a/doc/emacs/windows.texi +++ b/doc/emacs/windows.texi @@ -186,7 +186,8 @@ The @code{other-window} command will normally only switch to the next window in the current frame (unless otherwise configured). If you work in a multi-frame environment and you want windows in all frames to be part of the cycle, you can rebind @kbd{C-x o} to the -@code{next-multiframe-window} command. +@code{next-multiframe-window} command. (@xref{Rebinding}, for how to +rebind a command.) @kindex C-M-v @findex scroll-other-window commit 37257d6acadff17bd1e52cfa460950bcb684c5c3 Author: Paul Eggert Date: Fri Aug 16 22:09:04 2019 -0700 More-compatible subsecond calendrical timestamps Instead of appending a subseconds member to the result of ‘decode-time’, this keeps the format unchanged unless you give a new optional argument to ‘decode-time’. Also, the augmented format now puts the subsecond info in the SECONDS element, so the total number of elements is unchanged; this is more compatible with code that expects the traditional 9 elements, such as ‘(pcase decoded-time (`(,SEC ,MIN ,HOUR ,DAY ,MON ,YEAR ,DOW ,DST ,ZONE) ...) ...)’. * doc/lispref/os.texi, doc/misc/emacs-mime.texi, etc/NEWS: * lisp/net/soap-client.el (soap-decode-date-time): * lisp/simple.el (decoded-time): Document the new behavior. * lisp/calendar/icalendar.el (icalendar--decode-isodatetime): * lisp/calendar/iso8601.el (iso8601-parse) (iso8601-parse-time, iso8601-parse-duration) (iso8601--decoded-time): * lisp/calendar/parse-time.el (parse-time-string): * lisp/calendar/time-date.el (decoded-time-add) (decoded-time--alter-second): * lisp/org/org.el (org-parse-time-string): * lisp/simple.el (decoded-time): * src/timefns.c (Fdecode_time, Fencode_time): * test/lisp/calendar/icalendar-tests.el: (icalendar--decode-isodatetime): * test/lisp/calendar/iso8601-tests.el (test-iso8601-date-years) (test-iso8601-date-dates, test-iso8601-date-obsolete) (test-iso8601-date-weeks, test-iso8601-date-ordinals) (test-iso8601-time, test-iso8601-combined) (test-iso8601-duration, test-iso8601-intervals) (standard-test-dates, standard-test-time-of-day-fractions) (standard-test-time-of-day-beginning-of-day) (standard-test-time-of-day-utc) (standard-test-time-of-day-zone) (standard-test-date-and-time-of-day, standard-test-interval): * test/lisp/calendar/parse-time-tests.el (parse-time-tests): * test/src/timefns-tests.el (format-time-string-with-zone) (encode-time-dst-numeric-zone): Revert recent changes that added a SUBSECS member to calendrical timestamps, since that component is no longer present (the info, if any, is now in the SECONDS member). * lisp/calendar/time-date.el (decoded-time-add) (decoded-time--alter-second): Support fractional seconds in the new form. Simplify. * src/timefns.c (Fdecode_time): Support new arg FORM. (Fencode_time): Support subsecond resolution. * test/src/timefns-tests.el (format-time-string-with-zone) (decode-then-encode-time): Test subsecond calendrical timestamps. diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index 70ae39e6ab..49c07380c5 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -1478,23 +1478,23 @@ Although @code{(time-convert nil nil)} is equivalent to @end example @end defun -@defun decode-time &optional time zone +@defun decode-time &optional time zone form This function converts a time value into calendrical information. If you don't specify @var{time}, it decodes the current time, and similarly @var{zone} defaults to the current time zone rule. @xref{Time Zone Rules}. -The return value is a list of ten elements, as follows: +The @var{form} argument controls the form of the returned +@var{seconds} element, as described below. +The return value is a list of nine elements, as follows: @example -(@var{seconds} @var{minutes} @var{hour} @var{day} @var{month} @var{year} - @var{dow} @var{dst} @var{utcoff} @var{subsec}) +(@var{seconds} @var{minutes} @var{hour} @var{day} @var{month} @var{year} @var{dow} @var{dst} @var{utcoff}) @end example Here is what the elements mean: @table @var @item seconds -The number of seconds past the minute, as an integer between 0 and 59. -On some operating systems, this is 60 for leap seconds. +The number of seconds past the minute, with form described below. @item minutes The number of minutes past the hour, as an integer between 0 and 59. @item hour @@ -1514,22 +1514,33 @@ in effect, and @minus{}1 if this information is not available. @item utcoff An integer indicating the Universal Time offset in seconds, i.e., the number of seconds east of Greenwich. -@item subsec -The number of subseconds past the second, as either 0 or a Lisp -timestamp @code{(@var{ticks} . @var{hz})} representing a nonnegative -fraction less than 1. @end table +The @var{seconds} element is a Lisp timestamp that is nonnegative and +less than 61; it is less than 60 except during positive leap seconds +(assuming the operating system supports leap seconds). If the +optional @var{form} argument is @code{t}, @var{seconds} uses the same +precision as @var{time}; if @var{form} is @code{integer}, +@var{seconds} is truncated to an integer. For example, if @var{time} +is the timestamp @code{(1566009571321 . 1000)}, which represents +2019-08-17 02:39:31.321 UTC on typical systems that lack leap seconds, +then @code{(decode-time @var{time} t t)} returns @code{((31321 . 1000) +39 2 17 8 2019 6 nil 0)}, whereas @code{(decode-time @var{time} t +'integer)} returns @code{(31 39 2 17 8 2019 6 nil 0)}. If @var{form} +is omitted or @code{nil}, it currently defaults to @code{integer} but +this default may change in future Emacs releases, so callers requiring +a particular form should specify @var{form}. + @strong{Common Lisp Note:} Common Lisp has different meanings for -@var{dow} and @var{utcoff}, and lacks @var{subsec}. +@var{dow} and @var{utcoff}, and its @var{second} is an integer between +0 and 59 inclusive. To access (or alter) the elements in the time value, the @code{decoded-time-second}, @code{decoded-time-minute}, @code{decoded-time-hour}, @code{decoded-time-day}, @code{decoded-time-month}, @code{decoded-time-year}, -@code{decoded-time-weekday}, @code{decoded-time-dst}, -@code{decoded-time-zone} and @code{decoded-time-subsec} -accessors can be used. +@code{decoded-time-weekday}, @code{decoded-time-dst} and +@code{decoded-time-zone} accessors can be used. For instance, to increase the year in a decoded time, you could say: @@ -1551,7 +1562,7 @@ For instance, if you want ``same time next month'', you could say: @lisp -(let ((time (decode-time)) +(let ((time (decode-time nil nil t)) (delta (make-decoded-time :month 2))) (encode-time (decoded-time-add time delta))) @end lisp @@ -1585,22 +1596,21 @@ It can act as the inverse of @code{decode-time}. Ordinarily the first argument is a list @code{(@var{second} @var{minute} @var{hour} @var{day} @var{month} -@var{year} @var{ignored} @var{dst} @var{zone} @var{subsec})} that specifies a +@var{year} @var{ignored} @var{dst} @var{zone})} that specifies a decoded time in the style of @code{decode-time}, so that @code{(encode-time (decode-time ...))} works. For the meanings of these list members, see the table under @code{decode-time}. As an obsolescent calling convention, this function can be given six -through ten arguments. The first six arguments @var{second}, +or more arguments. The first six arguments @var{second}, @var{minute}, @var{hour}, @var{day}, @var{month}, and @var{year} -specify most of the components of a decoded time. If there are seven -through nine arguments the @emph{last} argument is used as @var{zone}, -and if there are ten arguments the ninth specifies @var{zone} and the -tenth specifies @var{subsec}; in either case any other extra arguments -are ignored, so that @code{(apply #'encode-time (decode-time ...))} -works. In this obsolescent convention, @var{zone} defaults to the -current time zone rule (@pxref{Time Zone Rules}), @var{subsec} -defaults to 0, and @var{dst} is treated as if it was @minus{}1. +specify most of the components of a decoded time. If there are more +than six arguments the @emph{last} argument is used as @var{zone} and +any other extra arguments are ignored, so that @code{(apply +#'encode-time (decode-time ...))} works. In this obsolescent +convention, @var{zone} defaults to the current time zone rule +(@pxref{Time Zone Rules}), and @var{dst} is treated as if it was +@minus{}1. Year numbers less than 100 are not treated specially. If you want them to stand for years above 1900, or years above 2000, you must alter them @@ -1615,9 +1625,8 @@ the latter to the former as follows: @end example You can perform simple date arithmetic by using out-of-range values for -@var{seconds}, @var{minutes}, @var{hour}, @var{day}, @var{month}, and -@var{subsec}; for example, day 0 means the day preceding the given -month. +@var{seconds}, @var{minutes}, @var{hour}, @var{day}, and @var{month}; +for example, day 0 means the day preceding the given month. The operating system puts limits on the range of possible time values; if the limits are exceeded while encoding the time, an error results. diff --git a/doc/misc/emacs-mime.texi b/doc/misc/emacs-mime.texi index c411bf3d68..eb829b0612 100644 --- a/doc/misc/emacs-mime.texi +++ b/doc/misc/emacs-mime.texi @@ -1535,7 +1535,7 @@ Here's a bunch of time/date/second/day examples: @example (parse-time-string "Sat Sep 12 12:21:54 1998 +0200") -@result{} (54 21 12 12 9 1998 6 -1 7200 0) +@result{} (54 21 12 12 9 1998 6 -1 7200) (time-convert (date-to-time "Sat Sep 12 12:21:54 1998 +0200") diff --git a/etc/NEWS b/etc/NEWS index edce7b3e57..53408a871e 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2116,10 +2116,20 @@ probing the innards of a timestamp directly, or creating a timestamp by hand. +++ -*** Decoded (calendrical) timestamps now have a new subsecond member. -This affects functions like decode-time and parse-time-string that -generate these timestamps, and functions like encode-time that accept -them. +*** Decoded (calendrical) timestamps now have subsecond resolution. +This affects decode-time, which generates these timestamps, as well as +functions like encode-time that accept them. The subsecond info is +present as a (TICKS . HZ) value in the seconds element of a decoded +timestamp, and decode-time has a new optional FORM argument specifying +the form of the seconds member. For example, if X is the timestamp +(1566009571321878186 . 1000000000), which represents 2019-08-17 +02:39:31.321878186 UTC, (decode-time X t t) returns ((31321878186 +. 1000000000) 39 2 17 8 2019 6 nil 0) instead of the traditional (31 +39 2 17 8 2019 6 nil 0) returned by plain (decode-time X t). Although +the default FORM is currently 'integer', which truncates the seconds +to an integer and is the traditional behavior, this default may change +in future Emacs versions, so callers requiring an integer should +specify FORM explicitly. +++ *** 'encode-time' supports a new API '(encode-time TIME)'. @@ -2152,8 +2162,8 @@ with POSIX.1-2017. *** To access (or alter) the elements a decoded time value, the 'decoded-time-second', 'decoded-time-minute', 'decoded-time-hour', 'decoded-time-day', 'decoded-time-month', 'decoded-time-year', -'decoded-time-weekday', 'decoded-time-dst', 'decoded-time-zone', -and 'decoded-time-subsec' accessors can be used. +'decoded-time-weekday', 'decoded-time-dst' and 'decoded-time-zone' +accessors can be used. *** The new functions 'date-days-in-month' (which will say how many days there are in a month in a specific year), 'date-ordinal-to-time' diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index 84f579ad44..c2688705e3 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -644,7 +644,7 @@ FIXME: multiple comma-separated values should be allowed!" ;; create the decoded date-time ;; FIXME!?! (let ((decoded-time (list second minute hour day month year - nil -1 zone 0))) + nil -1 zone))) (condition-case nil (decode-time (encode-time decoded-time)) (error diff --git a/lisp/calendar/iso8601.el b/lisp/calendar/iso8601.el index 51f5dff909..30352c7e75 100644 --- a/lisp/calendar/iso8601.el +++ b/lisp/calendar/iso8601.el @@ -129,8 +129,7 @@ well as variants like \"2008W32\" (week number) and (let ((time (iso8601-parse-time time-string))) (setf (decoded-time-hour date) (decoded-time-hour time)) (setf (decoded-time-minute date) (decoded-time-minute time)) - (setf (decoded-time-second date) (decoded-time-second time)) - (setf (decoded-time-subsec date) (decoded-time-subsec time)))) + (setf (decoded-time-second date) (decoded-time-second time)))) ;; The time zone is optional. (when zone-string (setf (decoded-time-zone date) @@ -237,8 +236,6 @@ well as variants like \"2008W32\" (week number) and (iso8601--decoded-time :hour hour :minute (or minute 0) :second (or second 0) - ;; FIXME: Support subsec. - :subsec 0 :zone (and zone (* 60 (iso8601-parse-zone zone))))))))) @@ -277,9 +274,7 @@ Return the number of minutes." :day (or (match-string 3 string) 0) :hour (or (match-string 5 string) 0) :minute (or (match-string 6 string) 0) - :second (or (match-string 7 string) 0) - ;; FIXME: Support subsec. - :subsec 0)) + :second (or (match-string 7 string) 0))) ;; PnW: Weeks. ((iso8601--match iso8601--duration-week-match string) (let ((weeks (string-to-number (match-string 1 string)))) @@ -341,7 +336,7 @@ Return the number of minutes." (cl-defun iso8601--decoded-time (&key second minute hour day month year - dst zone subsec) + dst zone) (list (iso8601--value second) (iso8601--value minute) (iso8601--value hour) @@ -350,8 +345,7 @@ Return the number of minutes." (iso8601--value year) nil dst - zone - subsec)) + zone)) (defun iso8601--encode-time (time) "Like `encode-time', but fill in nil values in TIME." diff --git a/lisp/calendar/parse-time.el b/lisp/calendar/parse-time.el index 9af93b5b1e..b0b277db77 100644 --- a/lisp/calendar/parse-time.el +++ b/lisp/calendar/parse-time.el @@ -148,7 +148,7 @@ letters, digits, plus or minus signs or colons." ;;;###autoload (defun parse-time-string (string) - "Parse the time in STRING into (SEC MIN HOUR DAY MON YEAR DOW DST TZ SUBSEC). + "Parse the time in STRING into (SEC MIN HOUR DAY MON YEAR DOW DST TZ). STRING should be something resembling an RFC 822 (or later) date-time, e.g., \"Fri, 25 Mar 2016 16:24:56 +0100\", but this function is somewhat liberal in what format it accepts, and will attempt to @@ -156,7 +156,7 @@ return a \"likely\" value even for somewhat malformed strings. The values returned are identical to those of `decode-time', but any unknown values other than DST are returned as nil, and an unknown DST value is returned as -1." - (let ((time (list nil nil nil nil nil nil nil -1 nil nil)) + (let ((time (list nil nil nil nil nil nil nil -1 nil)) (temp (parse-time-tokenize (downcase string)))) (while temp (let ((parse-time-elt (pop temp)) @@ -193,10 +193,6 @@ unknown DST value is returned as -1." (funcall this))) parse-time-val))) (setf (nth (pop slots) time) new-val)))))))) - ;; FIXME: Currently parse-time-string does not parse subseconds. - ;; So if seconds were found, set subseconds to zero. - (when (nth 0 time) - (setf (nth 9 time) 0)) time)) (defun parse-iso8601-time-string (date-string) diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index fa5e886869..f3d252f03c 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -420,26 +420,13 @@ changes in daylight saving time are not taken into account." ;; Do the time part, which is pretty simple (except for leap ;; seconds, I guess). - (setq seconds (+ (* (or (decoded-time-hour delta) 0) 3600) - (* (or (decoded-time-minute delta) 0) 60) - (or (decoded-time-second delta) 0))) - (when (decoded-time-subsec delta) - (let* ((subsec (time-convert (time-add (decoded-time-subsec time) - (decoded-time-subsec delta)) - t)) - (s (time-convert subsec 'integer))) - (setq seconds (+ seconds s)) - (setf (decoded-time-subsec time) (time-subtract subsec s)))) - ;; Time zone adjustments are basically the same as time adjustments. - (setq seconds (+ seconds (or (decoded-time-zone delta) 0))) - - (cond - ((> seconds 0) - (decoded-time--alter-second time seconds t)) - ((< seconds 0) - (decoded-time--alter-second time (abs seconds) nil))) + (setq seconds (time-add (+ (* (or (decoded-time-hour delta) 0) 3600) + (* (or (decoded-time-minute delta) 0) 60) + (or (decoded-time-zone delta) 0)) + (or (decoded-time-second delta) 0))) + (decoded-time--alter-second time seconds) time)) (defun decoded-time--alter-month (time increase) @@ -472,38 +459,31 @@ changes in daylight saving time are not taken into account." (date-days-in-month (decoded-time-year time) (decoded-time-month time)))))) -(defun decoded-time--alter-second (time seconds increase) - "Increase or decrease the time in TIME by SECONDS." - (let ((old (+ (* (or (decoded-time-hour time) 0) 3600) - (* (or (decoded-time-minute time) 0) 60) - (or (decoded-time-second time) 0)))) - - (if increase - (progn - (setq old (+ old seconds)) - (setf (decoded-time-second time) (% old 60) - (decoded-time-minute time) (% (/ old 60) 60) - (decoded-time-hour time) (% (/ old 3600) 24)) - ;; Hm... DST... - (let ((days (/ old (* 60 60 24)))) - (while (> days 0) - (decoded-time--alter-day time t) - (cl-decf days)))) - (setq old (abs (- old seconds))) - (setf (decoded-time-second time) (% old 60) - (decoded-time-minute time) (% (/ old 60) 60) - (decoded-time-hour time) (% (/ old 3600) 24)) - ;; Hm... DST... - (let ((days (/ old (* 60 60 24)))) - (while (> days 0) - (decoded-time--alter-day time nil) - (cl-decf days)))))) +(defun decoded-time--alter-second (time seconds) + "Increase the time in TIME by SECONDS." + (let* ((secsperday 86400) + (old (time-add (+ (* 3600 (or (decoded-time-hour time) 0)) + (* 60 (or (decoded-time-minute time) 0))) + (or (decoded-time-second time) 0))) + (new (time-add old seconds))) + ;; Hm... DST... + (while (time-less-p new 0) + (decoded-time--alter-day time nil) + (setq new (time-add new secsperday))) + (while (not (time-less-p new secsperday)) + (decoded-time--alter-day time t) + (setq new (time-subtract new secsperday))) + (let ((sec (time-convert new 'integer))) + (setf (decoded-time-second time) (time-add (% sec 60) + (time-subtract new sec)) + (decoded-time-minute time) (% (/ sec 60) 60) + (decoded-time-hour time) (/ sec 3600))))) (cl-defun make-decoded-time (&key second minute hour day month year - dst zone subsec) + dst zone) "Return a `decoded-time' structure with only the keywords given filled out." - (list second minute hour day month year nil dst zone subsec)) + (list second minute hour day month year nil dst zone)) (defun decoded-time-set-defaults (time &optional default-zone) "Set any nil values in `decoded-time' TIME to default values. @@ -533,9 +513,6 @@ TIME is modified and returned." (when (and (not (decoded-time-zone time)) default-zone) (setf (decoded-time-zone time) 0)) - - (unless (decoded-time-subsec time) - (setf (decoded-time-subsec time) 0)) time) (provide 'time-date) diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el index eb08511171..7ce7d79c74 100644 --- a/lisp/net/soap-client.el +++ b/lisp/net/soap-client.el @@ -561,8 +561,8 @@ gMonthDay, gDay or gMonth. Return a list in a format (SEC MINUTE HOUR DAY MONTH YEAR SEC-FRACTION DATATYPE ZONE). This format is meant to be similar to that returned by `decode-time' (and compatible with -`encode-time'). The differences are the SUBSEC (fractional -seconds) field is omitted, the DOW (day-of-week) field +`encode-time'). The differences are the SEC (seconds) +field is always an integer, the DOW (day-of-week) field is replaced with SEC-FRACTION, a float representing the fractional seconds, and the DST (daylight savings time) field is replaced with DATATYPE, a symbol representing the XSD primitive diff --git a/lisp/org/org.el b/lisp/org/org.el index 336c413c8c..ab29353ae8 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -17775,12 +17775,14 @@ NODEFAULT, hour and minute fields will be nil if not given." (string-to-number (match-string 4 s)) (string-to-number (match-string 3 s)) (string-to-number (match-string 2 s)) - nil nil nil 0)) + nil nil nil)) ((string-match "^<[^>]+>$" s) ;; FIXME: `decode-time' needs to be called with ZONE as its ;; second argument. However, this requires at least Emacs ;; 25.1. We can do it when we switch to this version as our ;; minimal requirement. + ;; FIXME: decode-time needs to be called with t as its + ;; third argument, but this requires at least Emacs 27. (decode-time (org-matcher-time s))) (t (error "Not a standard Org time string: %s" s)))) diff --git a/lisp/simple.el b/lisp/simple.el index cb938bb341..fdf7d893cd 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -9082,8 +9082,9 @@ to capitalize ARG words." (:copier nil) (:type list)) (second nil :documentation "\ -This is an integer between 0 and 60 (inclusive). (60 is a leap -second, which only some operating systems support.)") +This is an integer or a Lisp timestamp (TICKS . HZ) representing a nonnegative +number of seconds less than 61. (If not less than 60, it is a leap second, +which only some operating systems support.)") (minute nil :documentation "This is an integer between 0 and 59 (inclusive).") (hour nil :documentation "This is an integer between 0 and 23 (inclusive).") (day nil :documentation "This is an integer between 1 and 31 (inclusive).") @@ -9099,9 +9100,6 @@ available.") (zone nil :documentation "\ This is an integer indicating the UTC offset in seconds, i.e., the number of seconds east of Greenwich.") - (subsec nil :documentation "\ -This is 0, or is an integer pair (TICKS . HZ) indicating TICKS/HZ seconds, -where HZ is positive and TICKS is nonnegative and less than HZ.") ) diff --git a/src/timefns.c b/src/timefns.c index 979550c843..16c39c8349 100644 --- a/src/timefns.c +++ b/src/timefns.c @@ -1374,8 +1374,8 @@ usage: (format-time-string FORMAT-STRING &optional TIME ZONE) */) t, zone, &tm); } -DEFUN ("decode-time", Fdecode_time, Sdecode_time, 0, 2, 0, - doc: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF SUBSEC). +DEFUN ("decode-time", Fdecode_time, Sdecode_time, 0, 3, 0, + doc: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF). The optional TIME is the time value to convert. See `format-time-string' for the various forms of a time value. @@ -1385,29 +1385,33 @@ the TZ environment variable. It can also be a list (as from `current-time-zone') or an integer (the UTC offset in seconds) applied without consideration for daylight saving time. +The optional FORM specifies the form of the SEC member. If `integer', +SEC is an integer; if t, SEC uses the same resolution as TIME. An +omitted or nil FORM is currently treated like `integer', but this may +change in future Emacs versions. + To access (or alter) the elements in the time value, the `decoded-time-second', `decoded-time-minute', `decoded-time-hour', `decoded-time-day', `decoded-time-month', `decoded-time-year', -`decoded-time-weekday', `decoded-time-dst', `decoded-time-zone' and -`decoded-time-subsec' accessors can be used. +`decoded-time-weekday', `decoded-time-dst' and `decoded-time-zone' +accessors can be used. -The list has the following ten members: SEC is an integer between 0 -and 60; SEC is 60 for a leap second, which only some operating systems -support. MINUTE is an integer between 0 and 59. HOUR is an integer +The list has the following nine members: SEC is an integer or +Lisp timestamp representing a nonnegative value less than 60 +\(or less than 61 if the operating system supports leap seconds). +MINUTE is an integer between 0 and 59. HOUR is an integer between 0 and 23. DAY is an integer between 1 and 31. MONTH is an integer between 1 and 12. YEAR is an integer indicating the four-digit year. DOW is the day of week, an integer between 0 and 6, where 0 is Sunday. DST is t if daylight saving time is in effect, nil if it is not in effect, and -1 if daylight saving information is not available. UTCOFF is an integer indicating the UTC offset in -seconds, i.e., the number of seconds east of Greenwich. SUBSEC is -is either 0 or (TICKS . HZ) where HZ is a positive integer clock -resolution and TICKS is a nonnegative integer less than HZ. (Note -that Common Lisp has different meanings for DOW and UTCOFF, and lacks -SUBSEC.) +seconds, i.e., the number of seconds east of Greenwich. (Note that +Common Lisp has different meanings for DOW and UTCOFF, and its +SEC is always an integer between 0 and 59.) -usage: (decode-time &optional TIME ZONE) */) - (Lisp_Object specified_time, Lisp_Object zone) +usage: (decode-time &optional TIME ZONE FORM) */) + (Lisp_Object specified_time, Lisp_Object zone, Lisp_Object form) { struct lisp_time lt = lisp_time_struct (specified_time, 0); struct timespec ts = lisp_to_timespec (lt); @@ -1439,8 +1443,35 @@ usage: (decode-time &optional TIME ZONE) */) year = make_integer_mpz (); } + Lisp_Object hz = lt.hz, sec; + if (EQ (hz, make_fixnum (1)) || !EQ (form, Qt)) + sec = make_fixnum (local_tm.tm_sec); + else + { + Lisp_Object ticks; /* hz * tm_sec + mod (lt.ticks, hz) */ + intmax_t n; + if (FASTER_TIMEFNS && FIXNUMP (lt.ticks) && FIXNUMP (hz) + && !INT_MULTIPLY_WRAPV (XFIXNUM (hz), local_tm.tm_sec, &n) + && ! (INT_ADD_WRAPV + (n, (XFIXNUM (lt.ticks) % XFIXNUM (hz) + + (XFIXNUM (lt.ticks) % XFIXNUM (hz) < 0 + ? XFIXNUM (hz) : 0)), + &n))) + ticks = make_int (n); + else + { + mpz_fdiv_r (mpz[0], + *bignum_integer (&mpz[0], lt.ticks), + *bignum_integer (&mpz[1], hz)); + mpz_addmul_ui (mpz[0], *bignum_integer (&mpz[1], hz), + local_tm.tm_sec); + ticks = make_integer_mpz (); + } + sec = Fcons (ticks, hz); + } + return CALLN (Flist, - make_fixnum (local_tm.tm_sec), + sec, make_fixnum (local_tm.tm_min), make_fixnum (local_tm.tm_hour), make_fixnum (local_tm.tm_mday), @@ -1453,10 +1484,7 @@ usage: (decode-time &optional TIME ZONE) */) ? make_fixnum (tm_gmtoff (&local_tm)) : gmtime_r (&time_spec, &gmt_tm) ? make_fixnum (tm_diff (&local_tm, &gmt_tm)) - : Qnil), - (EQ (lt.hz, make_fixnum (1)) - ? make_fixnum (0) - : Fcons (integer_mod (lt.ticks, lt.hz), lt.hz))); + : Qnil)); } /* Return OBJ - OFFSET, checking that OBJ is a valid integer and that @@ -1487,7 +1515,7 @@ check_tm_member (Lisp_Object obj, int offset) DEFUN ("encode-time", Fencode_time, Sencode_time, 1, MANY, 0, doc: /* Convert TIME to a timestamp. -TIME is a list (SECOND MINUTE HOUR DAY MONTH YEAR IGNORED DST ZONE SUBSEC). +TIME is a list (SECOND MINUTE HOUR DAY MONTH YEAR IGNORED DST ZONE). in the style of `decode-time', so that (encode-time (decode-time ...)) works. In this list, ZONE can be nil for Emacs local time, t for Universal Time, `wall' for system wall clock time, or a string as in the TZ @@ -1496,23 +1524,16 @@ environment variable. It can also be a list (as from without consideration for daylight saving time. If ZONE specifies a time zone with daylight-saving transitions, DST is t for daylight saving time, nil for standard time, and -1 to cause the daylight -saving flag to be guessed. SUBSEC is either 0 or a Lisp timestamp -in (TICKS . HZ) form. +saving flag to be guessed. As an obsolescent calling convention, if this function is called with -6 through 10 arguments, the first 6 arguments are SECOND, MINUTE, -HOUR, DAY, MONTH, and YEAR, and specify the components of a decoded -time. If there are 7 through 9 arguments the *last* argument -specifies ZONE, and if there are 10 arguments the 9th specifies ZONE -and the 10th specifies SUBSEC; in either case any other extra -arguments are ignored, so that (apply #\\='encode-time (decode-time -...)) works. In this obsolescent convention, DST, ZONE, and SUBSEC -default to -1, nil and 0 respectively. - -Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed; -for example, a DAY of 0 means the day preceding the given month. -Year numbers less than 100 are treated just like other year numbers. -If you want them to stand for years in this century, you must do that yourself. +6 or more arguments, the first 6 arguments are SECOND, MINUTE, HOUR, +DAY, MONTH, and YEAR, and specify the components of a decoded time, +where DST assumed to be -1 and FORM is omitted. If there are more +than 6 arguments the *last* argument is used as ZONE and any other +extra arguments are ignored, so that (apply #\\='encode-time +(decode-time ...)) works. In this obsolescent convention, DST and +ZONE default to -1 and nil respectively. Years before 1970 are not guaranteed to work. On some systems, year values as low as 1901 do work. @@ -1521,27 +1542,27 @@ usage: (encode-time TIME &rest OBSOLESCENT-ARGUMENTS) */) (ptrdiff_t nargs, Lisp_Object *args) { struct tm tm; - Lisp_Object zone = Qnil, subsec = make_fixnum (0); + Lisp_Object zone = Qnil; Lisp_Object a = args[0]; + Lisp_Object secarg, minarg, hourarg, mdayarg, monarg, yeararg; tm.tm_isdst = -1; if (nargs == 1) { Lisp_Object tail = a; - for (int i = 0; i < 10; i++, tail = XCDR (tail)) + for (int i = 0; i < 9; i++, tail = XCDR (tail)) CHECK_CONS (tail); - tm.tm_sec = check_tm_member (XCAR (a), 0); a = XCDR (a); - tm.tm_min = check_tm_member (XCAR (a), 0); a = XCDR (a); - tm.tm_hour = check_tm_member (XCAR (a), 0); a = XCDR (a); - tm.tm_mday = check_tm_member (XCAR (a), 0); a = XCDR (a); - tm.tm_mon = check_tm_member (XCAR (a), 1); a = XCDR (a); - tm.tm_year = check_tm_member (XCAR (a), TM_YEAR_BASE); a = XCDR (a); + secarg = XCAR (a); a = XCDR (a); + minarg = XCAR (a); a = XCDR (a); + hourarg = XCAR (a); a = XCDR (a); + mdayarg = XCAR (a); a = XCDR (a); + monarg = XCAR (a); a = XCDR (a); + yeararg = XCAR (a); a = XCDR (a); a = XCDR (a); Lisp_Object dstflag = XCAR (a); a = XCDR (a); - zone = XCAR (a); a = XCDR (a); + zone = XCAR (a); if (SYMBOLP (dstflag) && !FIXNUMP (zone) && !CONSP (zone)) tm.tm_isdst = !NILP (dstflag); - subsec = XCAR (a); } else if (nargs < 6) xsignal2 (Qwrong_number_of_arguments, Qencode_time, make_fixnum (nargs)); @@ -1549,18 +1570,37 @@ usage: (encode-time TIME &rest OBSOLESCENT-ARGUMENTS) */) { if (6 < nargs) zone = args[nargs - 1]; - if (9 < nargs) - { - zone = args[8]; - subsec = args[9]; - } - tm.tm_sec = check_tm_member (a, 0); - tm.tm_min = check_tm_member (args[1], 0); - tm.tm_hour = check_tm_member (args[2], 0); - tm.tm_mday = check_tm_member (args[3], 0); - tm.tm_mon = check_tm_member (args[4], 1); - tm.tm_year = check_tm_member (args[5], TM_YEAR_BASE); + secarg = a; + minarg = args[1]; + hourarg = args[2]; + mdayarg = args[3]; + monarg = args[4]; + yeararg = args[5]; + } + + struct lisp_time lt; + decode_lisp_time (secarg, 0, <, 0); + Lisp_Object hz = lt.hz, sec, subsecticks; + if (FASTER_TIMEFNS && EQ (hz, make_fixnum (1))) + { + sec = lt.ticks; + subsecticks = make_fixnum (0); + } + else + { + mpz_fdiv_qr (mpz[0], mpz[1], + *bignum_integer (&mpz[0], lt.ticks), + *bignum_integer (&mpz[1], hz)); + sec = make_integer_mpz (); + mpz_swap (mpz[0], mpz[1]); + subsecticks = make_integer_mpz (); } + tm.tm_sec = check_tm_member (sec, 0); + tm.tm_min = check_tm_member (minarg, 0); + tm.tm_hour = check_tm_member (hourarg, 0); + tm.tm_mday = check_tm_member (mdayarg, 0); + tm.tm_mon = check_tm_member (monarg, 1); + tm.tm_year = check_tm_member (yeararg, TM_YEAR_BASE); timezone_t tz = tzlookup (zone, false); tm.tm_wday = -1; @@ -1571,25 +1611,17 @@ usage: (encode-time TIME &rest OBSOLESCENT-ARGUMENTS) */) if (tm.tm_wday < 0) time_error (mktime_errno); - if (CONSP (subsec)) + if (EQ (hz, make_fixnum (1))) + return (CURRENT_TIME_LIST + ? list2 (hi_time (value), lo_time (value)) + : INT_TO_INTEGER (value)); + else { - Lisp_Object subsecticks = XCAR (subsec); - if (INTEGERP (subsecticks)) - { - struct lisp_time val1 = { INT_TO_INTEGER (value), make_fixnum (1) }; - Lisp_Object - hz = XCDR (subsec), - secticks = lisp_time_hz_ticks (val1, hz), - ticks = lispint_arith (secticks, subsecticks, false); - return Fcons (ticks, hz); - } + struct lisp_time val1 = { INT_TO_INTEGER (value), make_fixnum (1) }; + Lisp_Object secticks = lisp_time_hz_ticks (val1, hz); + Lisp_Object ticks = lispint_arith (secticks, subsecticks, false); + return Fcons (ticks, hz); } - else if (INTEGERP (subsec)) - return (CURRENT_TIME_LIST && EQ (subsec, make_fixnum (0)) - ? list2 (hi_time (value), lo_time (value)) - : lispint_arith (INT_TO_INTEGER (value), subsec, false)); - - xsignal2 (Qerror, build_string ("Invalid subsec"), subsec); } DEFUN ("time-convert", Ftime_convert, Stime_convert, 1, 2, 0, diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el index 060cd8c909..baea480404 100644 --- a/test/lisp/calendar/icalendar-tests.el +++ b/test/lisp/calendar/icalendar-tests.el @@ -477,18 +477,18 @@ END:VEVENT ;; testcase: no time zone in input -> keep time as is ;; 1 Jan 2013 10:00 - (should (equal '(0 0 10 1 1 2013 2 nil 7200 0) + (should (equal '(0 0 10 1 1 2013 2 nil 7200) (icalendar--decode-isodatetime "20130101T100000"))) ;; 1 Aug 2013 10:00 (DST) - (should (equal '(0 0 10 1 8 2013 4 t 10800 0) + (should (equal '(0 0 10 1 8 2013 4 t 10800) (icalendar--decode-isodatetime "20130801T100000"))) ;; testcase: UTC time zone specifier in input -> convert to local time ;; 31 Dec 2013 23:00 UTC -> 1 Jan 2013 01:00 EET - (should (equal '(0 0 1 1 1 2014 3 nil 7200 0) + (should (equal '(0 0 1 1 1 2014 3 nil 7200) (icalendar--decode-isodatetime "20131231T230000Z"))) ;; 1 Aug 2013 10:00 UTC -> 1 Aug 2013 13:00 EEST - (should (equal '(0 0 13 1 8 2013 4 t 10800 0) + (should (equal '(0 0 13 1 8 2013 4 t 10800) (icalendar--decode-isodatetime "20130801T100000Z"))) ) diff --git a/test/lisp/calendar/iso8601-tests.el b/test/lisp/calendar/iso8601-tests.el index 3f1149c864..35c319ed03 100644 --- a/test/lisp/calendar/iso8601-tests.el +++ b/test/lisp/calendar/iso8601-tests.el @@ -24,65 +24,65 @@ (ert-deftest test-iso8601-date-years () (should (equal (iso8601-parse-date "1985") - '(nil nil nil nil nil 1985 nil nil nil nil))) + '(nil nil nil nil nil 1985 nil nil nil))) (should (equal (iso8601-parse-date "-0003") - '(nil nil nil nil nil -4 nil nil nil nil))) + '(nil nil nil nil nil -4 nil nil nil))) (should (equal (iso8601-parse-date "+1985") - '(nil nil nil nil nil 1985 nil nil nil nil)))) + '(nil nil nil nil nil 1985 nil nil nil)))) (ert-deftest test-iso8601-date-dates () (should (equal (iso8601-parse-date "1985-03-14") - '(nil nil nil 14 3 1985 nil nil nil nil))) + '(nil nil nil 14 3 1985 nil nil nil))) (should (equal (iso8601-parse-date "19850314") - '(nil nil nil 14 3 1985 nil nil nil nil))) + '(nil nil nil 14 3 1985 nil nil nil))) (should (equal (iso8601-parse-date "1985-02") - '(nil nil nil nil 2 1985 nil nil nil nil)))) + '(nil nil nil nil 2 1985 nil nil nil)))) (ert-deftest test-iso8601-date-obsolete () (should (equal (iso8601-parse-date "--02-01") - '(nil nil nil 1 2 nil nil nil nil nil))) + '(nil nil nil 1 2 nil nil nil nil))) (should (equal (iso8601-parse-date "--0201") - '(nil nil nil 1 2 nil nil nil nil nil)))) + '(nil nil nil 1 2 nil nil nil nil)))) (ert-deftest test-iso8601-date-weeks () (should (equal (iso8601-parse-date "2008W39-6") - '(nil nil nil 27 9 2008 nil nil nil nil))) + '(nil nil nil 27 9 2008 nil nil nil))) (should (equal (iso8601-parse-date "2009W01-1") - '(nil nil nil 29 12 2008 nil nil nil nil))) + '(nil nil nil 29 12 2008 nil nil nil))) (should (equal (iso8601-parse-date "2009W53-7") - '(nil nil nil 3 1 2010 nil nil nil nil)))) + '(nil nil nil 3 1 2010 nil nil nil)))) (ert-deftest test-iso8601-date-ordinals () (should (equal (iso8601-parse-date "1981-095") - '(nil nil nil 5 4 1981 nil nil nil nil)))) + '(nil nil nil 5 4 1981 nil nil nil)))) (ert-deftest test-iso8601-time () (should (equal (iso8601-parse-time "13:47:30") - '(30 47 13 nil nil nil nil nil nil 0))) + '(30 47 13 nil nil nil nil nil nil))) (should (equal (iso8601-parse-time "134730") - '(30 47 13 nil nil nil nil nil nil 0))) + '(30 47 13 nil nil nil nil nil nil))) (should (equal (iso8601-parse-time "1347") - '(0 47 13 nil nil nil nil nil nil 0)))) + '(0 47 13 nil nil nil nil nil nil)))) (ert-deftest test-iso8601-combined () (should (equal (iso8601-parse "2008-03-02T13:47:30") - '(30 47 13 2 3 2008 nil nil nil 0))) + '(30 47 13 2 3 2008 nil nil nil))) (should (equal (iso8601-parse "2008-03-02T13:47:30Z") - '(30 47 13 2 3 2008 nil nil 0 0))) + '(30 47 13 2 3 2008 nil nil 0))) (should (equal (iso8601-parse "2008-03-02T13:47:30+01:00") - '(30 47 13 2 3 2008 nil nil 3600 0))) + '(30 47 13 2 3 2008 nil nil 3600))) (should (equal (iso8601-parse "2008-03-02T13:47:30-01") - '(30 47 13 2 3 2008 nil nil -3600 0)))) + '(30 47 13 2 3 2008 nil nil -3600)))) (ert-deftest test-iso8601-duration () (should (equal (iso8601-parse-duration "P3Y6M4DT12H30M5S") - '(5 30 12 4 6 3 nil nil nil 0))) + '(5 30 12 4 6 3 nil nil nil))) (should (equal (iso8601-parse-duration "P1M") - '(0 0 0 0 1 0 nil nil nil 0))) + '(0 0 0 0 1 0 nil nil nil))) (should (equal (iso8601-parse-duration "PT1M") - '(0 1 0 0 0 0 nil nil nil 0))) + '(0 1 0 0 0 0 nil nil nil))) (should (equal (iso8601-parse-duration "P0003-06-04T12:30:05") - '(5 30 12 4 6 3 nil nil nil 0)))) + '(5 30 12 4 6 3 nil nil nil)))) (ert-deftest test-iso8601-invalid () (should-not (iso8601-valid-p " 2008-03-02T13:47:30-01")) @@ -94,149 +94,149 @@ (ert-deftest test-iso8601-intervals () (should (equal (iso8601-parse-interval "2007-03-01T13:00:00Z/2008-05-11T15:30:00Z") - '((0 0 13 1 3 2007 nil nil 0 0) - (0 30 15 11 5 2008 nil nil 0 0) + '((0 0 13 1 3 2007 nil nil 0) + (0 30 15 11 5 2008 nil nil 0) ;; Hm... can't really use decode-time for time differences... - (0 30 2 14 3 1971 0 nil 0 0)))) + (0 30 2 14 3 1971 0 nil 0)))) (should (equal (iso8601-parse-interval "2007-03-01T13:00:00Z/P1Y2M10DT2H30M") - '((0 0 13 1 3 2007 nil nil 0 0) - (0 30 15 11 5 2008 nil nil 0 0) - (0 30 2 10 2 1 nil nil nil 0)))) + '((0 0 13 1 3 2007 nil nil 0) + (0 30 15 11 5 2008 nil nil 0) + (0 30 2 10 2 1 nil nil nil)))) (should (equal (iso8601-parse-interval "P1Y2M10DT2H30M/2008-05-11T15:30:00Z") - '((0 0 13 1 3 2007 nil nil 0 0) - (0 30 15 11 5 2008 nil nil 0 0) - (0 30 2 10 2 1 nil nil nil 0))))) + '((0 0 13 1 3 2007 nil nil 0) + (0 30 15 11 5 2008 nil nil 0) + (0 30 2 10 2 1 nil nil nil))))) (ert-deftest standard-test-dates () (should (equal (iso8601-parse-date "19850412") - '(nil nil nil 12 4 1985 nil nil nil nil))) + '(nil nil nil 12 4 1985 nil nil nil))) (should (equal (iso8601-parse-date "1985-04-12") - '(nil nil nil 12 4 1985 nil nil nil nil))) + '(nil nil nil 12 4 1985 nil nil nil))) (should (equal (iso8601-parse-date "1985102") - '(nil nil nil 12 4 1985 nil nil nil nil))) + '(nil nil nil 12 4 1985 nil nil nil))) (should (equal (iso8601-parse-date "1985-102") - '(nil nil nil 12 4 1985 nil nil nil nil))) + '(nil nil nil 12 4 1985 nil nil nil))) (should (equal (iso8601-parse-date "1985W155") - '(nil nil nil 12 4 1985 nil nil nil nil))) + '(nil nil nil 12 4 1985 nil nil nil))) (should (equal (iso8601-parse-date "1985-W15-5") - '(nil nil nil 12 4 1985 nil nil nil nil))) + '(nil nil nil 12 4 1985 nil nil nil))) (should (equal (iso8601-parse-date "1985W15") - '(nil nil nil 7 4 1985 nil nil nil nil))) + '(nil nil nil 7 4 1985 nil nil nil))) (should (equal (iso8601-parse-date "1985-W15") - '(nil nil nil 7 4 1985 nil nil nil nil))) + '(nil nil nil 7 4 1985 nil nil nil))) (should (equal (iso8601-parse-date "1985-04") - '(nil nil nil nil 4 1985 nil nil nil nil))) + '(nil nil nil nil 4 1985 nil nil nil))) (should (equal (iso8601-parse-date "1985") - '(nil nil nil nil nil 1985 nil nil nil nil))) + '(nil nil nil nil nil 1985 nil nil nil))) (should (equal (iso8601-parse-date "+1985-04-12") - '(nil nil nil 12 4 1985 nil nil nil nil))) + '(nil nil nil 12 4 1985 nil nil nil))) (should (equal (iso8601-parse-date "+19850412") - '(nil nil nil 12 4 1985 nil nil nil nil)))) + '(nil nil nil 12 4 1985 nil nil nil)))) (ert-deftest standard-test-time-of-day-local-time () (should (equal (iso8601-parse-time "152746") - '(46 27 15 nil nil nil nil nil nil 0))) + '(46 27 15 nil nil nil nil nil nil))) (should (equal (iso8601-parse-time "15:27:46") - '(46 27 15 nil nil nil nil nil nil 0))) + '(46 27 15 nil nil nil nil nil nil))) (should (equal (iso8601-parse-time "1528") - '(0 28 15 nil nil nil nil nil nil 0))) + '(0 28 15 nil nil nil nil nil nil))) (should (equal (iso8601-parse-time "15:28") - '(0 28 15 nil nil nil nil nil nil 0))) + '(0 28 15 nil nil nil nil nil nil))) (should (equal (iso8601-parse-time "15") - '(0 0 15 nil nil nil nil nil nil 0)))) + '(0 0 15 nil nil nil nil nil nil)))) (ert-deftest standard-test-time-of-day-fractions () ;; decoded-time doesn't support sub-second times. ;; (should (equal (iso8601-parse-time "152735,5") - ;; '(46 27 15 nil nil nil nil nil nil (5 . 10)))) + ;; '(46 27 15 nil nil nil nil nil nil))) ;; (should (equal (iso8601-parse-time "15:27:35,5") - ;; '(46 27 15 nil nil nil nil nil nil (5 . 10)))) + ;; '(46 27 15 nil nil nil nil nil nil))) ) (ert-deftest standard-test-time-of-day-beginning-of-day () (should (equal (iso8601-parse-time "000000") - '(0 0 0 nil nil nil nil nil nil 0))) + '(0 0 0 nil nil nil nil nil nil))) (should (equal (iso8601-parse-time "00:00:00") - '(0 0 0 nil nil nil nil nil nil 0))) + '(0 0 0 nil nil nil nil nil nil))) (should (equal (iso8601-parse-time "0000") - '(0 0 0 nil nil nil nil nil nil 0))) + '(0 0 0 nil nil nil nil nil nil))) (should (equal (iso8601-parse-time "00:00") - '(0 0 0 nil nil nil nil nil nil 0)))) + '(0 0 0 nil nil nil nil nil nil)))) (ert-deftest standard-test-time-of-day-utc () (should (equal (iso8601-parse-time "232030Z") - '(30 20 23 nil nil nil nil nil 0 0))) + '(30 20 23 nil nil nil nil nil 0))) (should (equal (iso8601-parse-time "23:20:30Z") - '(30 20 23 nil nil nil nil nil 0 0))) + '(30 20 23 nil nil nil nil nil 0))) (should (equal (iso8601-parse-time "2320Z") - '(0 20 23 nil nil nil nil nil 0 0))) + '(0 20 23 nil nil nil nil nil 0))) (should (equal (iso8601-parse-time "23:20Z") - '(0 20 23 nil nil nil nil nil 0 0))) + '(0 20 23 nil nil nil nil nil 0))) (should (equal (iso8601-parse-time "23Z") - '(0 0 23 nil nil nil nil nil 0 0)))) + '(0 0 23 nil nil nil nil nil 0)))) (ert-deftest standard-test-time-of-day-zone () (should (equal (iso8601-parse-time "152746+0100") - '(46 27 15 nil nil nil nil nil 3600 0))) + '(46 27 15 nil nil nil nil nil 3600))) (should (equal (iso8601-parse-time "15:27:46+0100") - '(46 27 15 nil nil nil nil nil 3600 0))) + '(46 27 15 nil nil nil nil nil 3600))) (should (equal (iso8601-parse-time "152746+01") - '(46 27 15 nil nil nil nil nil 3600 0))) + '(46 27 15 nil nil nil nil nil 3600))) (should (equal (iso8601-parse-time "15:27:46+01") - '(46 27 15 nil nil nil nil nil 3600 0))) + '(46 27 15 nil nil nil nil nil 3600))) (should (equal (iso8601-parse-time "152746-0500") - '(46 27 15 nil nil nil nil nil -18000 0))) + '(46 27 15 nil nil nil nil nil -18000))) (should (equal (iso8601-parse-time "15:27:46-0500") - '(46 27 15 nil nil nil nil nil -18000 0))) + '(46 27 15 nil nil nil nil nil -18000))) (should (equal (iso8601-parse-time "152746-05") - '(46 27 15 nil nil nil nil nil -18000 0))) + '(46 27 15 nil nil nil nil nil -18000))) (should (equal (iso8601-parse-time "15:27:46-05") - '(46 27 15 nil nil nil nil nil -18000 0)))) + '(46 27 15 nil nil nil nil nil -18000)))) (ert-deftest standard-test-date-and-time-of-day () (should (equal (iso8601-parse "19850412T101530") - '(30 15 10 12 4 1985 nil nil nil 0))) + '(30 15 10 12 4 1985 nil nil nil))) (should (equal (iso8601-parse "1985-04-12T10:15:30") - '(30 15 10 12 4 1985 nil nil nil 0))) + '(30 15 10 12 4 1985 nil nil nil))) (should (equal (iso8601-parse "1985102T235030Z") - '(30 50 23 12 4 1985 nil nil 0 0))) + '(30 50 23 12 4 1985 nil nil 0))) (should (equal (iso8601-parse "1985-102T23:50:30Z") - '(30 50 23 12 4 1985 nil nil 0 0))) + '(30 50 23 12 4 1985 nil nil 0))) (should (equal (iso8601-parse "1985W155T235030") - '(30 50 23 12 4 1985 nil nil nil 0))) + '(30 50 23 12 4 1985 nil nil nil))) (should (equal (iso8601-parse "1985-W155T23:50:30") - '(30 50 23 12 4 1985 nil nil nil 0)))) + '(30 50 23 12 4 1985 nil nil nil)))) (ert-deftest standard-test-interval () ;; A time interval starting at 20 minutes and 50 seconds past 23 ;; hours on 12 April 1985 and ending at 30 minutes past 10 hours on ;; 25 June 1985. (should (equal (iso8601-parse-interval "19850412T232050Z/19850625T103000Z") - '((50 20 23 12 4 1985 nil nil 0 0) - (0 30 10 25 6 1985 nil nil 0 0) - (10 9 11 15 3 1970 0 nil 0 0)))) + '((50 20 23 12 4 1985 nil nil 0) + (0 30 10 25 6 1985 nil nil 0) + (10 9 11 15 3 1970 0 nil 0)))) (should (equal (iso8601-parse-interval "1985-04-12T23:20:50Z/1985-06-25T10:30:00Z") - '((50 20 23 12 4 1985 nil nil 0 0) - (0 30 10 25 6 1985 nil nil 0 0) - (10 9 11 15 3 1970 0 nil 0 0)))) + '((50 20 23 12 4 1985 nil nil 0) + (0 30 10 25 6 1985 nil nil 0) + (10 9 11 15 3 1970 0 nil 0)))) ;; A time interval starting at 12 April 1985 and ending on 25 June ;; 1985. @@ -251,41 +251,41 @@ ;; A time interval of 2 years, 10 months, 15 days, 10 hours, 20 ;; minutes and 30 seconds. (should (equal (iso8601-parse-duration "P2Y10M15DT10H20M30S") - '(30 20 10 15 10 2 nil nil nil 0))) + '(30 20 10 15 10 2 nil nil nil))) (should (equal (iso8601-parse-duration "P00021015T102030") - '(30 20 10 15 10 2 nil nil nil 0))) + '(30 20 10 15 10 2 nil nil nil))) (should (equal (iso8601-parse-duration "P0002-10-15T10:20:30") - '(30 20 10 15 10 2 nil nil nil 0))) + '(30 20 10 15 10 2 nil nil nil))) ;; A time interval of 1 year and 6 months. (should (equal (iso8601-parse-duration "P1Y6M") - '(0 0 0 0 6 1 nil nil nil 0))) + '(0 0 0 0 6 1 nil nil nil))) (should (equal (iso8601-parse-duration "P0001-06") - '(nil nil nil nil 6 1 nil nil nil nil))) + '(nil nil nil nil 6 1 nil nil nil))) ;; A time interval of seventy-two hours. (should (equal (iso8601-parse-duration "PT72H") - '(0 0 72 0 0 0 nil nil nil 0))) + '(0 0 72 0 0 0 nil nil nil))) ;; Defined by start and duration ;; A time interval of 1 year, 2 months, 15 days and 12 hours, ;; beginning on 12 April 1985 at 20 minutes past 23 hours. (should (equal (iso8601-parse-interval "19850412T232000/P1Y2M15DT12H") - '((0 20 23 12 4 1985 nil nil nil 0) - (0 20 11 28 6 1986 nil nil nil 0) - (0 0 12 15 2 1 nil nil nil 0)))) + '((0 20 23 12 4 1985 nil nil nil) + (0 20 11 28 6 1986 nil nil nil) + (0 0 12 15 2 1 nil nil nil)))) (should (equal (iso8601-parse-interval "1985-04-12T23:20:00/P1Y2M15DT12H") - '((0 20 23 12 4 1985 nil nil nil 0) - (0 20 11 28 6 1986 nil nil nil 0) - (0 0 12 15 2 1 nil nil nil 0)))) + '((0 20 23 12 4 1985 nil nil nil) + (0 20 11 28 6 1986 nil nil nil) + (0 0 12 15 2 1 nil nil nil)))) ;; Defined by duration and end ;; A time interval of 1 year, 2 months, 15 days and 12 hours, ending ;; on 12 April 1985 at 20 minutes past 23 hour. (should (equal (iso8601-parse-interval "P1Y2M15DT12H/19850412T232000") - '((0 20 11 28 1 1984 nil nil nil 0) - (0 20 23 12 4 1985 nil nil nil 0) - (0 0 12 15 2 1 nil nil nil 0))))) + '((0 20 11 28 1 1984 nil nil nil) + (0 20 23 12 4 1985 nil nil nil) + (0 0 12 15 2 1 nil nil nil))))) ;;; iso8601-tests.el ends here diff --git a/test/lisp/calendar/parse-time-tests.el b/test/lisp/calendar/parse-time-tests.el index 61a3838a52..7435620b71 100644 --- a/test/lisp/calendar/parse-time-tests.el +++ b/test/lisp/calendar/parse-time-tests.el @@ -28,23 +28,23 @@ (ert-deftest parse-time-tests () (should (equal (parse-time-string "Mon, 22 Feb 2016 19:35:42 +0100") - '(42 35 19 22 2 2016 1 -1 3600 0))) + '(42 35 19 22 2 2016 1 -1 3600))) (should (equal (parse-time-string "22 Feb 2016 19:35:42 +0100") - '(42 35 19 22 2 2016 nil -1 3600 0))) + '(42 35 19 22 2 2016 nil -1 3600))) (should (equal (parse-time-string "22 Feb 2016 +0100") - '(nil nil nil 22 2 2016 nil -1 3600 nil))) + '(nil nil nil 22 2 2016 nil -1 3600))) (should (equal (parse-time-string "Mon, 22 Feb 16 19:35:42 +0100") - '(42 35 19 22 2 2016 1 -1 3600 0))) + '(42 35 19 22 2 2016 1 -1 3600))) (should (equal (parse-time-string "Mon, 22 February 2016 19:35:42 +0100") - '(42 35 19 22 2 2016 1 -1 3600 0))) + '(42 35 19 22 2 2016 1 -1 3600))) (should (equal (parse-time-string "Mon, 22 feb 2016 19:35:42 +0100") - '(42 35 19 22 2 2016 1 -1 3600 0))) + '(42 35 19 22 2 2016 1 -1 3600))) (should (equal (parse-time-string "Monday, 22 february 2016 19:35:42 +0100") - '(42 35 19 22 2 2016 1 -1 3600 0))) + '(42 35 19 22 2 2016 1 -1 3600))) (should (equal (parse-time-string "Monday, 22 february 2016 19:35:42 PST") - '(42 35 19 22 2 2016 1 nil -28800 0))) + '(42 35 19 22 2 2016 1 nil -28800))) (should (equal (parse-time-string "Friday, 21 Sep 2018 13:47:58 PDT") - '(58 47 13 21 9 2018 5 t -25200 0))) + '(58 47 13 21 9 2018 5 t -25200))) (should (equal (format-time-string "%Y-%m-%d %H:%M:%S" (parse-iso8601-time-string "1998-09-12T12:21:54-0200") t) diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el index 362e7655a9..13ab7d83c3 100644 --- a/test/src/timefns-tests.el +++ b/test/src/timefns-tests.el @@ -40,25 +40,31 @@ (7879679999900 . 100000) (78796799999999999999 . 1000000000000))) ;; UTC. - (let ((subsec (time-subtract (time-convert look t) - (time-convert look 'integer)))) + (let ((sec (time-add 59 (time-subtract (time-convert look t) + (time-convert look 'integer))))) (should (string-equal (format-time-string "%Y-%m-%d %H:%M:%S.%3N %z" look t) "1972-06-30 23:59:59.999 +0000")) - (should (equal (decode-time look t) - (list 59 59 23 30 6 1972 5 nil 0 subsec))) + (should (equal (decode-time look t 'integer) + '(59 59 23 30 6 1972 5 nil 0))) + (should (equal (decode-time look t t) + (list sec 59 23 30 6 1972 5 nil 0))) ;; "UTC0". (should (string-equal (format-time-string format look "UTC0") "1972-06-30 23:59:59.999 +0000 (UTC)")) - (should (equal (decode-time look "UTC0") - (list 59 59 23 30 6 1972 5 nil 0 subsec))) + (should (equal (decode-time look "UTC0" 'integer) + '(59 59 23 30 6 1972 5 nil 0))) + (should (equal (decode-time look "UTC0" t) + (list sec 59 23 30 6 1972 5 nil 0))) ;; Negative UTC offset, as a Lisp list. (should (string-equal (format-time-string format look '(-28800 "PST")) "1972-06-30 15:59:59.999 -0800 (PST)")) - (should (equal (decode-time look '(-28800 "PST")) - (list 59 59 15 30 6 1972 5 nil -28800 subsec))) + (should (equal (decode-time look '(-28800 "PST") 'integer) + '(59 59 15 30 6 1972 5 nil -28800))) + (should (equal (decode-time look '(-28800 "PST") t) + (list sec 59 15 30 6 1972 5 nil -28800))) ;; Negative UTC offset, as a Lisp integer. (should (string-equal (format-time-string format look -28800) @@ -67,14 +73,18 @@ (if (eq system-type 'windows-nt) "1972-06-30 15:59:59.999 -0800 (ZZZ)" "1972-06-30 15:59:59.999 -0800 (-08)"))) - (should (equal (decode-time look -28800) - (list 59 59 15 30 6 1972 5 nil -28800 subsec))) + (should (equal (decode-time look -28800 'integer) + '(59 59 15 30 6 1972 5 nil -28800))) + (should (equal (decode-time look -28800 t) + (list sec 59 15 30 6 1972 5 nil -28800))) ;; Positive UTC offset that is not an hour multiple, as a string. (should (string-equal (format-time-string format look "IST-5:30") "1972-07-01 05:29:59.999 +0530 (IST)")) - (should (equal (decode-time look "IST-5:30") - (list 59 29 5 1 7 1972 6 nil 19800 subsec))))))) + (should (equal (decode-time look "IST-5:30" 'integer) + '(59 29 5 1 7 1972 6 nil 19800))) + (should (equal (decode-time look "IST-5:30" t) + (list sec 29 5 1 7 1972 6 nil 19800))))))) (ert-deftest decode-then-encode-time () (let ((time-values (list 0 -2 1 0.0 -0.0 -2.0 1.0 @@ -87,11 +97,13 @@ (cons (1+ most-positive-fixnum) 1000000000000) (cons 1000000000000 (1+ most-positive-fixnum))))) (dolist (a time-values) - (let* ((d (ignore-errors (decode-time a t))) + (let* ((d (ignore-errors (decode-time a t t))) + (d-integer (ignore-errors (decode-time a t 'integer))) (e (if d (encode-time d))) - (diff (float-time (time-subtract a e)))) - (should (or (not d) - (and (<= 0 diff) (< diff 1)))))))) + (e-integer (if d-integer (encode-time d-integer)))) + (should (or (not d) (time-equal-p a e))) + (should (or (not d-integer) (time-equal-p (time-convert a 'integer) + e-integer))))))) ;;; This should not dump core. (ert-deftest format-time-string-with-outlandish-zone () @@ -151,7 +163,7 @@ (ert-deftest encode-time-dst-numeric-zone () "Check for Bug#35502." (should (time-equal-p - (encode-time '(29 31 17 30 4 2019 2 t 7200 0)) + (encode-time '(29 31 17 30 4 2019 2 t 7200)) '(23752 27217)))) (ert-deftest float-time-precision () commit d7c9ed8445d13de7350be3360d68717362f89929 Author: Paul Eggert Date: Fri Aug 16 18:10:14 2019 -0700 Broaden format-seconds to Lisp timestamps * lisp/calendar/time-date.el (format-seconds): Accept any Lisp timestamp instead of insisting on a number. diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index c22f441420..fa5e886869 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -306,7 +306,7 @@ is output until the first non-zero unit is encountered." (push match usedunits))) (and zeroflag larger (error "Units are not in decreasing order of size")) - (setq seconds (floor seconds)) + (setq seconds (time-convert seconds 'integer)) (dolist (u units) (setq spec (car u) name (cadr u) commit f6dd46cba8b144cf1653f8314a4b629beee11be3 Author: Paul Eggert Date: Fri Aug 16 18:08:23 2019 -0700 Subtracting “now” from “now” should yield zero * src/timefns.c (time_arith): Arrange for (time-subtract nil nil) to yield 0, to be consistent with (time-equal-p nil nil). * test/lisp/calendar/time-date-tests.el (test-time-since): New test. diff --git a/src/timefns.c b/src/timefns.c index a4c1c4cb28..979550c843 100644 --- a/src/timefns.c +++ b/src/timefns.c @@ -1040,7 +1040,16 @@ time_arith (Lisp_Object a, Lisp_Object b, bool subtract) enum timeform aform, bform; struct lisp_time ta = lisp_time_struct (a, &aform); - struct lisp_time tb = lisp_time_struct (b, &bform); + + /* Subtract nil from nil correctly, and handle other eq values + quicker while we're at it. Compare here rather than earlier, to + handle NaNs and check formats. */ + struct lisp_time tb; + if (EQ (a, b)) + bform = aform, tb = ta; + else + tb = lisp_time_struct (b, &bform); + Lisp_Object ticks, hz; if (FASTER_TIMEFNS && EQ (ta.hz, tb.hz)) @@ -1125,8 +1134,9 @@ time_cmp (Lisp_Object a, Lisp_Object b) struct lisp_time ta = lisp_time_struct (a, 0); - /* Compare nil to nil correctly, and other eq values while we're at it. - Compare here rather than earlier, to handle NaNs and check formats. */ + /* Compare nil to nil correctly, and handle other eq values quicker + while we're at it. Compare here rather than earlier, to handle + NaNs and check formats. */ if (EQ (a, b)) return 0; diff --git a/test/lisp/calendar/time-date-tests.el b/test/lisp/calendar/time-date-tests.el index b46a247cd3..827d2c9800 100644 --- a/test/lisp/calendar/time-date-tests.el +++ b/test/lisp/calendar/time-date-tests.el @@ -104,6 +104,7 @@ (should (equal (decoded-time-add time (mdec :zone -7200)) '(12 15 14 8 7 2019 1 t 7200))))) -(require 'ert) +(ert-deftest test-time-since () + (should (time-equal-p 0 (time-since nil)))) ;;; time-date-tests.el ends here commit f9fd12a30b3d94eb48f7b309907d136d7b2682ac Author: Paul Eggert Date: Fri Aug 16 16:25:02 2019 -0700 Fix time-add rounding bug Without this fix, time arithmetic yielded results that were not mathematically accurate, even though the exact results were representable; for example, (time-add 0 1e-13) yielded a timestamp equal to 0 instead of to 1e-13. * lisp/timezone.el (timezone-time-from-absolute): Let time-add do its thing rather than using floating point internally, which has rounding errors. We now have bignums and so don’t need floating point to avoid overflow issues. * src/timefns.c (timeform_sub_ps_p): New function. (time_arith): If either argument is a float, represent the result exactly instead of discarding sub-ps info. * test/lisp/timezone-tests.el (timezone-tests-time-from-absolute): Don’t assume (HI LO US PS) timestamp format. * test/src/emacs-module-tests.el (mod-test-add-nanosecond/valid): Don’t assume that time-add discards sub-ns info. * test/src/timefns-tests.el (time-rounding-tests): Add regression test to detect time-add rounding bug. diff --git a/lisp/timezone.el b/lisp/timezone.el index ff0b266245..ce881a8c95 100644 --- a/lisp/timezone.el +++ b/lisp/timezone.el @@ -284,14 +284,14 @@ or an integer of the form +-HHMM, or a time zone name." (defun timezone-time-from-absolute (date seconds) "Compute the UTC time equivalent to DATE at time SECONDS after midnight. -Return a list suitable as an argument to `current-time-zone', +Return a Lisp timestamp suitable as an argument to `current-time-zone', or nil if the date cannot be thus represented. DATE is the number of days elapsed since the (imaginary) Gregorian date Sunday, December 31, 1 BC." (let* ((current-time-origin 719163) ;; (timezone-absolute-from-gregorian 1 1 1970) (days (- date current-time-origin)) - (seconds-per-day (float 86400)) + (seconds-per-day 86400) (day-seconds (* days seconds-per-day))) (condition-case nil (time-add day-seconds seconds) (range-error)))) diff --git a/src/timefns.c b/src/timefns.c index e9d1a9bf64..a4c1c4cb28 100644 --- a/src/timefns.c +++ b/src/timefns.c @@ -661,10 +661,18 @@ enum timeform TIMEFORM_HI_LO_US, /* seconds plus microseconds (HI LO US) */ TIMEFORM_NIL, /* current time in nanoseconds */ TIMEFORM_HI_LO_US_PS, /* seconds plus micro and picoseconds (HI LO US PS) */ + /* These two should be last; see timeform_sub_ps_p. */ TIMEFORM_FLOAT, /* time as a float */ TIMEFORM_TICKS_HZ /* fractional time: HI is ticks, LO is ticks per second */ }; +/* True if Lisp times of form FORM can express sub-picosecond timestamps. */ +static bool +timeform_sub_ps_p (enum timeform form) +{ + return TIMEFORM_FLOAT <= form; +} + /* From the valid form FORM and the time components HIGH, LOW, USEC and PSEC, generate the corresponding time value. If LOW is floating point, the other components should be zero and FORM should @@ -1016,8 +1024,8 @@ lispint_arith (Lisp_Object a, Lisp_Object b, bool subtract) /* Given Lisp operands A and B, add their values, and return the result as a Lisp timestamp that is in (TICKS . HZ) form if either A - or B are in that form, (HI LO US PS) form otherwise. Subtract - instead of adding if SUBTRACT. */ + or B are in that form or are floats, (HI LO US PS) form otherwise. + Subtract instead of adding if SUBTRACT. */ static Lisp_Object time_arith (Lisp_Object a, Lisp_Object b, bool subtract) { @@ -1077,7 +1085,7 @@ time_arith (Lisp_Object a, Lisp_Object b, bool subtract) otherwise the (HI LO US PS) form for backward compatibility. */ return (EQ (hz, make_fixnum (1)) ? ticks - : aform == TIMEFORM_TICKS_HZ || bform == TIMEFORM_TICKS_HZ + : timeform_sub_ps_p (aform) || timeform_sub_ps_p (bform) ? Fcons (ticks, hz) : ticks_hz_list4 (ticks, hz)); } diff --git a/test/lisp/timezone-tests.el b/test/lisp/timezone-tests.el index 4b5f5617ec..c374042fa5 100644 --- a/test/lisp/timezone-tests.el +++ b/test/lisp/timezone-tests.el @@ -135,9 +135,10 @@ (should (equal (timezone-zone-to-minute "*invalid*") 0))) (ert-deftest timezone-tests-time-from-absolute () - (should (equal (timezone-time-from-absolute (* 2020 365) ; Jan 1 2020 - (* 12 60 60)) ; 12:00 - '(23911 48704 0 0)))) + (should (time-equal-p + (timezone-time-from-absolute (* 2020 365) ; Jan 1 2020 + (* 12 60 60)) ; 12:00 + '(23911 48704 0 0)))) ;; TODO: Write tests for timezone-tests-time-zone-from-absolute, which is a ;; bit tricky since the results depend on `current-time-zone'. diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el index c44c386d30..c510784731 100644 --- a/test/src/emacs-module-tests.el +++ b/test/src/emacs-module-tests.el @@ -335,12 +335,15 @@ Interactively, you can try hitting \\[keyboard-quit] to quit." ;; New (TICKS . HZ) format. '(123456789 . 1000000000))) (ert-info ((format "input: %s" input)) - (let ((result (mod-test-add-nanosecond input))) + (let ((result (mod-test-add-nanosecond input)) + (desired-result + (let ((hz 1000000000)) + (time-add (time-convert input hz) (cons 1 hz))))) (should (consp result)) (should (integerp (car result))) (should (integerp (cdr result))) (should (cl-plusp (cdr result))) - (should (time-equal-p result (time-add input '(0 0 0 1000)))))))) + (should (time-equal-p result desired-result)))))) (ert-deftest mod-test-add-nanosecond/nil () (should (<= (float-time (mod-test-add-nanosecond nil)) diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el index 1b1032deaa..362e7655a9 100644 --- a/test/src/timefns-tests.el +++ b/test/src/timefns-tests.el @@ -145,6 +145,9 @@ (< 0.99 (/ (- (float-time a)) (float-time b)) 1.01)))))))) +(ert-deftest time-rounding-tests () + (should (time-equal-p 1e-13 (time-add 0 1e-13)))) + (ert-deftest encode-time-dst-numeric-zone () "Check for Bug#35502." (should (time-equal-p commit e82923c817159c751aa9c902093a46b9457e8499 Author: Lars Ingebrigtsen Date: Fri Aug 16 15:30:40 2019 -0700 Mention `next-multiframe-window' when talking about `other-window' * doc/emacs/windows.texi (Other Window): Mention the `next-multiframe-window' command here (which is otherwise not documented in the manual) (bug#12431). diff --git a/doc/emacs/windows.texi b/doc/emacs/windows.texi index 4aeb467dff..64b61db1cb 100644 --- a/doc/emacs/windows.texi +++ b/doc/emacs/windows.texi @@ -181,6 +181,13 @@ the minibuffer window to one of the other windows, and later switch back and finish supplying the minibuffer argument that is requested. @xref{Minibuffer Edit}. +@findex next-multiframe-window +The @code{other-window} command will normally only switch to the next +window in the current frame (unless otherwise configured). If you +work in a multi-frame environment and you want windows in all frames +to be part of the cycle, you can rebind @kbd{C-x o} to the +@code{next-multiframe-window} command. + @kindex C-M-v @findex scroll-other-window @kindex C-M-S-v commit e90c2176ea70006f8ab84f5ee3d0315173e96222 Author: Lars Ingebrigtsen Date: Fri Aug 16 14:39:52 2019 -0700 Add missing skeleton entries in autotype.texi * doc/misc/autotype.texi: Add missing entries found in the doc string to `skeleton-insert' (bug#12563). diff --git a/doc/misc/autotype.texi b/doc/misc/autotype.texi index 5eb45e2834..96262fcb53 100644 --- a/doc/misc/autotype.texi +++ b/doc/misc/autotype.texi @@ -240,7 +240,11 @@ alignment. Use @code{"\n"} as the first or last string element of a skeleton to insert a newline unconditionally. @item @code{_} Interesting point. When wrapping skeletons around successive regions, they are -put at these places. Point is left at first @code{_} where nothing is wrapped. +put at these places. Point is left at first @code{_} where nothing is +wrapped. +@item @code{-} +Interesting point with no inter-region interaction; overrides +interesting point set by @code{_}. @item @code{>} Indent line according to major mode. When following element is @code{_}, and there is an interregion that will be wrapped here, indent that interregion. @@ -250,6 +254,8 @@ something, do following element. @item @code{|} Logical xor. If preceding element didn't move point, i.e., usually inserted nothing, do following element. +@item @code{@@} +Add position to @code{skeleton-positions}. @item @code{-@var{number}} Delete preceding number characters. Depends on value of @code{skeleton-untabify}. @@ -275,6 +281,10 @@ prompt is a lisp-expression that returns successive list-elements. @item @code{resume:} Ignored. Execution resumes here if the user quits during skeleton interpretation. +@item @code{help} +Help form during interaction with the user or @code{nil}. +@item @code{input} +Initial input (a string or a cons with index) while reading the input. @item @code{quit} A constant which is non-@code{nil} when the @code{resume:} section was entered because the user quit. commit 496bab789d55ff20f150dd7a7d1d9bb837fb4534 Author: Alex Branham Date: Fri Aug 16 14:00:31 2019 -0700 Make checkdoc check cl-lib function docstrings * lisp/emacs-lisp/checkdoc.el (checkdoc-this-string-valid-engine): Remove calls to delete-region to avoid deleting final " (bug#26328). * lisp/emacs-lisp/checkdoc.el (checkdoc--next-docstring) (checkdoc-defun-info): Include cl-defun, cl-defgeneric, cl-defmethod. (checkdoc-this-string-valid-engine): Add cl-lib supported keywords. (checkdoc-defun-info): Ensure function parameters are a "flat" list (bug#37034). diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 3c69975021..8a88c5756f 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -933,7 +933,8 @@ don't move point." ;; Don't bug out if the file is empty (or a ;; definition ends prematurely. (end-of-file))) - (`(,(or 'defun 'defvar 'defcustom 'defmacro 'defconst 'defsubst 'defadvice) + (`(,(or 'defun 'defvar 'defcustom 'defmacro 'defconst 'defsubst 'defadvice + 'cl-defun 'cl-defgeneric 'cl-defmethod 'cl-defmacro) ,(pred symbolp) ;; Require an initializer, i.e. ignore single-argument `defvar' ;; forms, which never have a doc string. @@ -1675,7 +1676,10 @@ function,command,variable,option or symbol." ms1)))))) (last-pos 0) (found 1) (order (and (nth 3 fp) (car (nth 3 fp)))) - (nocheck (append '("&optional" "&rest") (nth 3 fp))) + (nocheck (append '("&optional" "&rest" "&key" "&aux" + "&context" "&environment" "&whole" + "&body" "&allow-other-keys") + (nth 3 fp))) (inopts nil)) (while (and args found (> found last-pos)) (if (or (member (car args) nocheck) @@ -1880,7 +1884,8 @@ the token checkdoc-order: exists, and TOKEN is a symbol read from the comment." (save-excursion (beginning-of-defun) - (let ((defun (looking-at "(def\\(un\\|macro\\|subst\\|advice\\)")) + (let ((defun (looking-at + "(\\(?:cl-\\)?def\\(un\\|macro\\|subst\\|advice\\|generic\\|method\\)")) (is-advice (looking-at "(defadvice")) (lst nil) (ret nil) @@ -1946,7 +1951,10 @@ from the comment." ;; This is because read will intern nil if it doesn't into the ;; new obarray. (if (not (listp lst)) (setq lst nil)) - (if is-advice nil + (unless is-advice + ;; lst here can be something like ((foo bar) baz) from + ;; cl-lib methods; flatten it: + (setq lst (flatten-tree lst)) (while lst (setq ret (cons (symbol-name (car lst)) ret) lst (cdr lst))))) commit 91c7c6a60260e3820d8f4bac1e17dbec382968f9 Author: Alex Branham Date: Fri Aug 16 13:55:27 2019 -0700 Avoid deleting closing quotation mark in checkdoc * lisp/emacs-lisp/checkdoc.el (checkdoc-this-string-valid-engine): Remove calls to delete-region to avoid deleting final " (bug#26328). diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 830743f5f8..3c69975021 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -1494,16 +1494,11 @@ may require more formatting") (if (and (re-search-forward "[.!?:\"]\\([ \t\n]+\\|\"\\)" (line-end-position) t) (< (current-column) numc)) - (if (checkdoc-autofix-ask-replace - p (1+ p) - "1st line not a complete sentence. Join these lines? " - " " t) - (progn - ;; They said yes. We have more fill work to do... - (goto-char (match-beginning 1)) - (delete-region (point) (match-end 1)) - (insert "\n") - (setq msg nil)))))) + (when (checkdoc-autofix-ask-replace + p (1+ p) + "1st line not a complete sentence. Join these lines? " + " " t) + (setq msg nil))))) (if msg (checkdoc-create-error msg s (save-excursion (goto-char s) commit a9d7ccfa56cf5985a9f4485b4d8b935871b721f9 Author: Thomas Fitzsimmons Date: Fri Aug 16 12:17:40 2019 -0400 Revert "package.el: Allow Package-Requires to span multiple lines (Bug#36301)" This reverts commit 19c1e4c81c7442dea48253e5961b6e54d78b6f0a. This commit broke some package tests, reverting for now. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index e6815fd964..a72522ad8f 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1028,7 +1028,6 @@ is wrapped around any parts requiring it." deps)))) (declare-function lm-header "lisp-mnt" (header)) -(declare-function lm-header-multiline "lisp-mnt" (header)) (declare-function lm-homepage "lisp-mnt" (&optional file)) (declare-function lm-keywords-list "lisp-mnt" (&optional file)) (declare-function lm-maintainer "lisp-mnt" (&optional file)) @@ -1055,8 +1054,7 @@ boundaries." (narrow-to-region start (point)) (require 'lisp-mnt) ;; Use some headers we've invented to drive the process. - (let* ((requires-str - (mapconcat 'identity (lm-header-multiline "package-requires") " ")) + (let* ((requires-str (lm-header "package-requires")) ;; Prefer Package-Version; if defined, the package author ;; probably wants us to use it. Otherwise try Version. (pkg-version commit 15de1d11334fd7da3255881e0836a22d08760482 Author: Eli Zaretskii Date: Fri Aug 16 16:45:57 2019 +0300 Fix markup in dired-x.texi * doc/misc/dired-x.texi (Omitting Variables) (Local Variables, Shell Command Guessing) (Advanced Cleaning Variables, Special Marking Function): Fix markup and indexing. (Bug#14212) diff --git a/doc/misc/dired-x.texi b/doc/misc/dired-x.texi index b8e1ad459d..05a8919b4e 100644 --- a/doc/misc/dired-x.texi +++ b/doc/misc/dired-x.texi @@ -127,7 +127,7 @@ original @file{dired-x.el}). @node Features @section Features -@cindex Features +@cindex Dired-x features Some features provided by Dired Extra: @@ -159,7 +159,7 @@ respectively (@pxref{Find File At Point}). @node Technical Details @section Technical Details -@cindex Modified functions +@cindex modified functions @cindex @file{dired-aux.el} When @file{dired-x.el} is loaded, some standard Dired functions from @@ -214,7 +214,7 @@ when you first type @kbd{C-x d}). @node Optional Installation Dired Jump @section Optional Installation Dired Jump -@cindex Autoloading @code{dired-jump} and @code{dired-jump-other-window} +@cindex autoloading @code{dired-jump} and @code{dired-jump-other-window} In order to have @code{dired-jump} and @code{dired-jump-other-window} (@pxref{Miscellaneous Commands}) work @emph{before} @code{dired} and @@ -235,7 +235,7 @@ for these functions. In your @file{.emacs} file put @node Optional Installation File At Point @section Optional Installation File At Point -@cindex Binding @code{dired-x-find-file} +@cindex binding @code{dired-x-find-file} If you choose to have @file{dired-x.el} bind @code{dired-x-find-file} over @code{find-file} (@pxref{Find File At Point}), then you will need to set @code{dired-x-hands-off-my-keys}. To do this, either set it @@ -254,8 +254,8 @@ or call @code{dired-x-bind-find-file} after changing the value. @node Omitting Files in Dired @chapter Omitting Files in Dired -@cindex Omitting Files in Dired -@cindex Uninteresting files +@cindex omitting Files in Dired +@cindex uninteresting files @dfn{Omitting} a file means removing it from the directory listing. Omitting is useful for keeping Dired buffers free of ``uninteresting'' files (for instance, auto-save, auxiliary, backup, and revision control files) so that @@ -310,18 +310,13 @@ inside @code{dired-load-hook} (@pxref{Installation}) and then evaluate @node Omitting Variables @section Omitting Variables -@cindex Customizing file omitting +@cindex customizing file omitting The following variables can be used to customize omitting. -@table @code - -@vindex dired-omit-mode -@item dired-omit-mode - -Default: @code{nil} - -@cindex How to make omitting the default in Dired +@cindex how to make omitting the default in Dired +@defvar dired-omit-mode If non-@code{nil}, ``uninteresting'' files are not listed. +The default is @code{nil}. Uninteresting files are files whose names match regexp @code{dired-omit-files}, plus files whose names end with extension in @code{dired-omit-extensions}. @kbd{C-x M-o} (@code{dired-omit-mode}) @@ -347,56 +342,49 @@ a directory local setting @noindent to a @file{.dir-locals.el} file in that directory. You can use the command @code{add-dir-local-variable} to do this. +@end defvar -@vindex dired-omit-files -@item dired-omit-files - -Default: @code{"^#\\|\\.$"} - -Files whose names match this buffer-local regexp will not be displayed. -This only has effect when @code{dired-omit-mode}'s value is @code{t}. +@defvar dired-omit-files +This buffer-local variable's value is a regexp, a string. Files whose +names match this regexp will not be displayed. This only has effect +when @code{dired-omit-mode}'s value is @code{t}. The default value omits the special directories @file{.} and @file{..} and autosave files (plus other files ending in @file{.}) (@pxref{Omitting Examples}). - -@vindex dired-omit-extensions -@item dired-omit-extensions - -Default: The elements of @code{completion-ignored-extensions}, -@code{dired-latex-unclean-extensions}, @code{dired-bibtex-unclean-extensions} -and @code{dired-texinfo-unclean-extensions}. - -If non-@code{nil}, a list of extensions (strings) to omit from Dired listings. -Its format is the same as that of @code{completion-ignored-extensions}. - -@vindex dired-omit-case-fold -@item dired-omit-case-fold - +@end defvar + +@defvar dired-omit-extensions +If non-@code{nil}, this variable's value is a list of extensions +(strings) to omit from Dired listings. Its format is the same as that +of @code{completion-ignored-extensions}. The default value is the +elements of @code{completion-ignored-extensions}, +@code{dired-latex-unclean-extensions}, +@code{dired-bibtex-unclean-extensions} and +@code{dired-texinfo-unclean-extensions}. +@end defvar + +@defvar dired-omit-case-fold Default: @code{filesystem} - +This variable controls whether file-name matching is case-insensitive. By default, when @code{dired-omit-case-fold} is set to @code{filesystem}, @code{dired-omit-mode} will match filenames and extensions case-sensitively on Dired buffers visiting case-sensitive filesystems, and case-insensitively on case-insensitive filesystems. Set it to @code{nil} to be always case-sensitive, and to @code{t} to be always case-insensitive. - -@vindex dired-omit-localp -@item dired-omit-localp - -Default: @code{no-dir} - -The @var{localp} argument @code{dired-omit-expunge} passes to -@code{dired-get-filename}. If it is @code{no-dir}, omitting is much faster, -but you can only match against the non-directory part of the file name. Set it -to @code{nil} if you need to match the whole file name or @code{t} to match the -file name relative to the buffer's top-level directory. - -@item dired-omit-marker-char -@vindex dired-omit-marker-char -@cindex Omitting additional files -Default: @kbd{C-o} - +@end defvar + +@defvar dired-omit-localp +This variable determines the @var{localp} argument +@code{dired-omit-expunge} passes to @code{dired-get-filename}. If it +is @code{no-dir}, teh default, omitting is much faster, but you can +only match against the non-directory part of the file name. Set it to +@code{nil} if you need to match the whole file name or @code{t} to +match the file name relative to the buffer's top-level directory. +@end defvar + +@cindex omitting additional files +@defvar dired-omit-marker-char Temporary marker used by Dired to implement omitting. Should never be used as marker by the user or other packages. There is one exception to this rule: by adding @@ -412,8 +400,8 @@ to your @file{~/.emacs}, you can bind the @kbd{C-o} key to insert a @kbd{C-o} marker, thus causing these files to be omitted in addition to the usually omitted files. Unfortunately the files you omitted manually this way will show up again after reverting the buffer, unlike the others. - -@end table +The default value is @kbd{C-o}. +@end defvar @node Omitting Examples @section Examples of Omitting Various File Types @@ -422,7 +410,7 @@ will show up again after reverting the buffer, unlike the others. @item @cindex RCS files, how to omit them in Dired -@cindex Omitting RCS files in Dired +@cindex omitting RCS files in Dired If you wish to avoid seeing RCS files and the @file{RCS} directory, then put @example @@ -438,8 +426,8 @@ in the @code{dired-load-hook} (@pxref{Installation}). This assumes @code{^} in the regexp. @item -@cindex Tib files, how to omit them in Dired -@cindex Omitting tib files in Dired +@cindex tib files, how to omit them in Dired +@cindex omitting tib files in Dired If you use @code{tib}, the bibliography program for use with @TeX{} and @LaTeX{}, and you want to omit the @file{INDEX} and the @file{*-t.tex} files, then put @@ -453,8 +441,8 @@ want to omit the @file{INDEX} and the @file{*-t.tex} files, then put in the @code{dired-load-hook} (@pxref{Installation}). @item -@cindex Dot files, how to omit them in Dired -@cindex Omitting dot files in Dired +@cindex dot files, how to omit them in Dired +@cindex omitting dot files in Dired If you do not wish to see @samp{dot} files (files starting with a @file{.}), then put @@ -480,8 +468,8 @@ in your @code{dired-mode-hook}. @node Local Variables @chapter Local Variables for Dired Directories +@cindex local Variables for Dired Directories -@cindex Local Variables for Dired Directories @vindex dired-local-variables-file @vindex dired-enable-local-variables @noindent @@ -530,28 +518,24 @@ Files,emacs,The GNU Emacs Manual}. @noindent The following variables affect Dired Local Variables -@table @code -@vindex dired-local-variables-file -@item dired-local-variables-file -Default: @code{".dired"} - -If non-@code{nil}, file name for local variables for Dired. If Dired finds a -file with that name in the current directory, it will temporarily insert it -into the Dired buffer and run @code{hack-local-variables}. +@defvar dired-local-variables-file +If non-@code{nil}, this variable specifies the file name for local +variables for Dired. If Dired finds a file with that name in the +current directory, it will temporarily insert it into the Dired buffer +and run @code{hack-local-variables}. The default is @file{.dired}. +@end defvar -@vindex dired-enable-local-variables -@item dired-enable-local-variables -Default: @code{t} - -Controls the use of local-variables lists in Dired. This variable +@defvar dired-enable-local-variables +This variable controls the use of local-variables lists in Dired. It temporarily overrides the value of @code{enable-local-variables} when -the Dired Local Variables are hacked. It takes the same values as that -variable. A value of @code{nil} means to ignore any Dired Local Variables. -@end table +the Dired Local Variables are hacked. It takes the same values as +that variable. A value of @code{nil} means to ignore any Dired Local +Variables. The default is @code{t}. +@end defvar @node Shell Command Guessing @chapter Shell Command Guessing -@cindex Guessing shell commands for files. +@cindex guessing shell commands for files. Based upon the name of a file, Dired tries to guess what shell command you might want to apply to it. For example, if you have point @@ -568,19 +552,22 @@ file, e.g., @samp{xtex} and @samp{dvips} for a @file{.dvi} file, you can type Dired only tries to guess a command for a single file, never for a list of marked files. -@table @code -@item dired-guess-shell-alist-default -@vindex dired-guess-shell-alist-default -Predefined rules for shell commands. Set this to @code{nil} to turn guessing off. -The elements of @code{dired-guess-shell-alist-user} (defined by the -user) will override these rules. - -@item dired-guess-shell-alist-user -@vindex dired-guess-shell-alist-user -If non-@code{nil}, a user-defined alist of file regexps and their suggested -commands. These rules take precedence over the predefined rules in the -variable @code{dired-guess-shell-alist-default} (to which they are prepended) -when @code{dired-do-shell-command} is run). +The following variables control guessing of shell commands: + +@defvar dired-guess-shell-alist-default +This variable specifies the predefined rules for guessing shell +commands suitable for certain files. Set this to @code{nil} to turn +guessing off. The elements of @code{dired-guess-shell-alist-user} +(defined by the user) will override these rules. +@end defvar + +@defvar dired-guess-shell-alist-user +If non-@code{nil}, this variables specifies the user-defined alist of +file regexps and their suggested commands. These rules take +precedence over the predefined rules in the variable +@code{dired-guess-shell-alist-default} (to which they are prepended) +when @code{dired-do-shell-command} is run). The default is +@code{nil}. Each element of the alist looks like @@ -613,54 +600,50 @@ to add rules for @samp{.foo} and @samp{.bar} file extensions, write @noindent This will override any predefined rules for the same extensions. +@end defvar -@item dired-guess-shell-case-fold-search -@vindex dired-guess-shell-case-fold-search -Default: @code{t} - -Non-@code{nil} means @code{dired-guess-shell-alist-default} and +@defvar dired-guess-shell-case-fold-search +If this variable is non-@code{nil}, +@code{dired-guess-shell-alist-default} and @code{dired-guess-shell-alist-user} are matched case-insensitively. +The default is @code{t}. +@end defvar + +@cindex passing GNU Tar its @samp{z} switch. +@defvar dired-guess-shell-gnutar +If this variable is non-@code{nil}, it specifies the name of the GNU +Tar executable (e.g., @file{tar} or @file{gnutar}). GNU Tar's +@samp{z} switch is used for compressed archives. If you don't have +GNU Tar, set this to @code{nil}: a pipe using @command{zcat} is then +used instead. The default is @code{nil}. +@end defvar -@item dired-guess-shell-gnutar -@vindex dired-guess-shell-gnutar -@cindex Passing GNU Tar its @samp{z} switch. -Default: @code{nil} - -If non-@code{nil}, this is the name of the GNU Tar executable (e.g., -@samp{tar} or @samp{gnutar}). GNU Tar's @samp{z} switch is used for -compressed tar files. -If you don't have GNU tar, set this to @code{nil}: a pipe using @samp{zcat} is -then used. - -@item dired-guess-shell-gzip-quiet -@vindex dired-guess-shell-gzip-quiet @cindex @code{gzip} -Default: @code{t} +@defvar dired-guess-shell-gzip-quiet +A non-@code{nil} value of this variable means that @samp{-q} is passed +to @command{gzip}, possibly overriding a verbose option in the @env{GZIP} +environment variable. The default is @code{t}. +@end defvar -A non-@code{nil} value means that @samp{-q} is passed to @code{gzip} -overriding a verbose option in the @env{GZIP} environment variable. - -@item dired-guess-shell-znew-switches nil -@vindex dired-guess-shell-znew-switches @cindex @code{znew} -Default: @code{nil} - -A string of switches passed to @code{znew}. An example is -@samp{-K} which will make @code{znew} keep a @file{.Z} file when it is -smaller than the @file{.gz} file. - -@item dired-shell-command-history nil -@vindex dired-shell-command-history - -History list for commands that read dired-shell commands. -@end table +@defvar dired-guess-shell-znew-switches nil +This variable specifies a string of switches passed to @command{znew}. +An example is @samp{-K} which will make @command{znew} keep a @file{.Z} +file when it is smaller than the @file{.gz} file. The default is +@code{nil}: no additional switches are passed to @command{znew}. +@end defvar + +@defvar dired-shell-command-history nil +This variable holds the history list for commands that read +dired-shell commands. +@end defvar @node Virtual Dired @chapter Virtual Dired -@cindex Virtual Dired -@cindex Perusing @code{ls} listings -@cindex @code{ls} listings, how to peruse them in Dired +@cindex virtual Dired +@cindex perusing @code{ls} listings +@cindex @command{ls} listings, how to peruse them in Dired Using @dfn{Virtual Dired} means putting a buffer with Dired-like contents in Dired mode. The files described by the buffer contents need not actually exist. This is useful if you want to peruse an @samp{ls -lR} @@ -702,8 +685,8 @@ local-variable files. @table @kbd @item F @kindex F -@cindex Visiting several files at once -@cindex Simultaneous visiting of several files +@cindex visiting several files at once +@cindex simultaneous visiting of several files @findex dired-do-find-marked-files (@code{dired-do-find-marked-files}) Find all marked files at once displaying them simultaneously. If optional @var{noselect} is non-@code{nil} then just @@ -791,41 +774,36 @@ and @file{*.dvi} files for deletion. @node Advanced Cleaning Variables @section Advanced Cleaning Variables -@noindent Variables used by the above cleaning commands (and in the default value for -variable @code{dired-omit-extensions}, @pxref{Omitting Variables}) - -@table @code -@item dired-patch-unclean-extensions -@vindex dired-patch-unclean-extensions -Default: @code{(".rej" ".orig")} - -List of extensions of dispensable files created by the @samp{patch} program. - -@item dired-tex-unclean-extensions -@vindex dired-tex-unclean-extensions -Default: @code{(".toc" ".log" ".aux")} - -List of extensions of dispensable files created by @TeX{}. - -@item dired-texinfo-unclean-extensions -@vindex dired-texinfo-unclean-extensions -Default: @code{(".cp" ".cps" ".fn" ".fns" ".ky" ".kys"} -@code{".pg" ".pgs" ".tp" ".tps" ".vr" ".vrs")} - -List of extensions of dispensable files created by @samp{texinfo}. - -@item dired-latex-unclean-extensions -@vindex dired-latex-unclean-extensions -Default: @code{(".idx" ".lof" ".lot" ".glo")} - -List of extensions of dispensable files created by @LaTeX{}. - -@item dired-bibtex-unclean-extensions -@vindex dired-bibtex-unclean-extensions -Default: @code{(".blg" ".bbl")} - -List of extensions of dispensable files created by Bib@TeX{}. -@end table +Variables used by the above cleaning commands (and in the default value for +variable @code{dired-omit-extensions}, @pxref{Omitting Variables}): + +@defvar dired-patch-unclean-extensions +This variable specifies the list of extensions of dispensable files +created by the @samp{patch} program. The default is @w{@code{(".rej" +".orig")}}. +@end defvar + +@defvar dired-tex-unclean-extensions +This variable specifies the list of extensions of dispensable files +created by @TeX{}. The default is @w{@code{(".toc" ".log" ".aux")}}. +@end defvar + +@defvar dired-texinfo-unclean-extensions +This variable holds the list of extensions of dispensable files +created by @samp{texinfo}. The default is @w{@code{(".cp" ".cps" ".fn" +".fns" ".ky" ".kys"} @code{".pg" ".pgs" ".tp" ".tps" ".vr" ".vrs")}} +@end defvar + +@defvar dired-latex-unclean-extensions +This variable specifies the list of extensions of dispensable files +created by @LaTeX{}. The default is @w{@code{(".idx" ".lof" ".lot" +".glo")}}. +@end defvar + +@defvar dired-bibtex-unclean-extensions +This variable specifies the list of extensions of dispensable files +created by Bib@TeX{}. The default is @w{@code{(".blg" ".bbl")}}. +@end defvar @node Special Marking Function @section Special Marking Function @@ -834,10 +812,11 @@ List of extensions of dispensable files created by Bib@TeX{}. @item M-( @kindex M-( @findex dired-mark-sexp -@cindex Lisp expression, marking files with in Dired -@cindex Mark file by Lisp expression -(@code{dired-mark-sexp}) Mark files for which @var{predicate} returns -non-@code{nil}. With a prefix argument, unflag those files instead. +@cindex lisp expression, marking files with in Dired +@cindex mark file by Lisp expression +Mark files for which @var{predicate} returns non-@code{nil} +(@code{dired-mark-sexp}). With a prefix argument, unflag those files +instead. The @var{predicate} is a Lisp expression that can refer to the following symbols: @@ -886,8 +865,8 @@ to mark all @file{.el} files without a corresponding @file{.elc} file. @node Multiple Dired Directories @chapter Multiple Dired Directories and Non-Dired Commands -@cindex Multiple Dired directories -@cindex Working directory +@cindex multiple Dired directories +@cindex working directory An Emacs buffer can have but one working directory, stored in the buffer-local variable @code{default-directory}. A Dired buffer may have several subdirectories inserted, but it still has only one working @@ -905,8 +884,8 @@ Dired buffers, is like @code{shell-command}, but it runs with @node Find File At Point @chapter Find File At Point -@cindex Visiting a file mentioned in a buffer -@cindex Finding a file at point +@cindex visiting a file mentioned in a buffer +@cindex finding a file at point @file{dired-x} provides a method of visiting or editing a file mentioned in the buffer you are viewing (e.g., a mail buffer, a news article, a @@ -1014,7 +993,7 @@ inserted subdirectories. @item dired-jump @findex dired-jump @kindex C-x C-j -@cindex Jumping to Dired listing containing file. +@cindex jumping to Dired listing containing file. Bound to @kbd{C-x C-j}. Jump back to Dired: If in a file, edit the current directory and move to file's line. If in Dired already, pop up a level and go to old directory's line. In case the proper Dired file line cannot be @@ -1034,7 +1013,7 @@ bound to @kbd{C-x C-j} and @code{dired-jump-other-window} will not be bound to @kbd{C-x 4 C-j}. @item dired-vm -@cindex Reading mail. +@cindex reading mail. @kindex V @findex dired-vm Bound to @kbd{V} if @code{dired-bind-vm} is @code{t}. Run VM on this @@ -1054,14 +1033,14 @@ If the variable @code{dired-bind-vm} is @code{t}, @code{dired-vm} will be bound to @kbd{V}. Otherwise, @code{dired-bind-rmail} will be bound. @item dired-rmail -@cindex Reading mail. +@cindex reading mail. @findex dired-rmail Bound to @kbd{V} if @code{dired-bind-vm} is @code{nil}. Run Rmail on this file (assumed to be mail folder in Rmail format). @item dired-info @kindex I -@cindex Running info. +@cindex running info. @findex dired-info Bound to @kbd{I}. Run Info on this file (assumed to be a file in Info format). @@ -1071,7 +1050,7 @@ If the variable @code{dired-bind-info} is @code{nil}, @code{dired-info} will not be bound to @kbd{I}. @item dired-man -@cindex Running man. +@cindex running man. @kindex N @findex dired-man Bound to @kbd{N}. Run man on this file (assumed to be a file in @code{nroff} @@ -1082,7 +1061,7 @@ If the variable @code{dired-bind-man} is @code{nil}, @code{dired-man} will not be bound to @kbd{N}. @item dired-do-relsymlink -@cindex Relative symbolic links. +@cindex relative symbolic links. @kindex Y @findex dired-do-relsymlink Bound to @kbd{Y}. Relative symlink all marked (or next ARG) files into a @@ -1111,7 +1090,7 @@ info. @node Bugs @chapter Bugs -@cindex Bugs +@cindex bugs @noindent If you encounter a bug in this package, or wish to suggest an commit 405f851f4bf64e2290e841b65ffabf37c61187f4 Author: Lars Ingebrigtsen Date: Fri Aug 16 00:04:13 2019 -0700 Mention that text properties are removed in substitute-command-keys * src/doc.c (Fsubstitute_command_keys): Restore the bit in the doc string that mentions that text properties is removed (bug#17052). diff --git a/src/doc.c b/src/doc.c index 8b663f0f24..247be79ada 100644 --- a/src/doc.c +++ b/src/doc.c @@ -721,7 +721,7 @@ into the output, \\=\\=\\=\\[ puts \\=\\[ into the output, and \\=\\=\\=` puts \ output. Return the original STRING if no substitutions are made. -Otherwise, return a new string. */) +Otherwise, return a new string (without any text properties). */) (Lisp_Object string) { char *buf; @@ -984,7 +984,7 @@ Otherwise, return a new string. */) { /* Nothing has changed other than quoting, so copy the string’s text properties. FIXME: Text properties should survive other - changes too. */ + changes too; see bug#17052. */ INTERVAL interval_copy = copy_intervals (string_intervals (string), 0, SCHARS (string)); if (interval_copy) commit d1d738c8264b3e756259e3ba2112ff96b8ecf829 Author: Lars Ingebrigtsen Date: Thu Aug 15 23:57:57 2019 -0700 Add some examples in "Adding Generalized Variables" * doc/lispref/variables.texi (Adding Generalized Variables): Add examples for `gv-define-expander' and `gv-letplace' (bug#13343). diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi index 6e6448ec1e..d62a5aa3af 100644 --- a/doc/lispref/variables.texi +++ b/doc/lispref/variables.texi @@ -2533,14 +2533,43 @@ set. An example of using this macro is: @end example @end defmac -@findex gv-define-expander -@findex gv-letplace -@c FIXME? Not sure what or how much to say about these. -@c See cl.texi for an example of using gv-letplace. -For more control over the expansion, see the macro @code{gv-define-expander}. +@defmac gv-define-expander name handler +For more control over the expansion, the @code{gv-define-expander} +macro can be used. For instance, a settable @code{substring} could be +implemented this way: + +@example +(gv-define-expander substring + (lambda (do place from &optional to) + (gv-letplace (getter setter) place + (macroexp-let2* nil ((start from) (end to)) + (funcall do `(substring ,getter ,start ,end) + (lambda (v) + (funcall setter `(cl--set-substring + ,getter ,start ,end ,v)))))))) +@end example +@end defmac + +@defmac gv-letplace (getter setter) place &rest body The macro @code{gv-letplace} can be useful in defining macros that perform similarly to @code{setf}; for example, the @code{incf} macro -of Common Lisp. Consult the source file @file{gv.el} for more details. +of Common Lisp could be implemented this way: + +@example +(defmacro incf (place &optional n) + (gv-letplace (getter setter) place + (macroexp-let2 nil v (or n 1) + (funcall setter `(+ ,v ,getter))))) +@end example + +@var{getter} will be bound to a copyable expression that returns the +value of @var{place}. @var{setter} will be bound to a function that +takes an expression @var{v} and returns a new expression that sets +@var{place} to @var{v}. @var{body} should return a Emacs Lisp +expression manipulating @var{place} via @var{getter} and @var{setter}. +@end defmac + +Consult the source file @file{gv.el} for more details. @cindex CL note---no @code{setf} functions @quotation commit bda7fc75dfd1991d8596eaab06b65309afa62b40 Author: Eli Zaretskii Date: Fri Aug 16 09:39:51 2019 +0300 ; Fix typo in a doc string of speedbar.el * lisp/speedbar.el (speedbar-supported-extension-expressions): Fix a typo in the doc string. (Bug#37041) diff --git a/lisp/speedbar.el b/lisp/speedbar.el index c43db0f678..2e710e808d 100644 --- a/lisp/speedbar.el +++ b/lisp/speedbar.el @@ -700,7 +700,7 @@ singular expression. This variable will be turned into function `speedbar-add-supported-extension' to add a new extension at runtime, or use the configuration dialog to set it in your init file. If you add an extension to this list, and it does not appear, you may -need to also modify `completion-ignored-extension' which will also help +need to also modify `completion-ignored-extensions' which will also help file completion." :group 'speedbar :type '(repeat (regexp :tag "Extension Regexp")) commit 19c1e4c81c7442dea48253e5961b6e54d78b6f0a Author: Thomas Fitzsimmons Date: Thu Aug 15 23:57:55 2019 -0400 package.el: Allow Package-Requires to span multiple lines (Bug#36301) * lisp/emacs-lisp/package.el (lm-header-multiline): Declare function. (package-buffer-info): Parse Package-Requires with lm-header-multiline instead of lm-header. (Bug#36301) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index a72522ad8f..e6815fd964 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1028,6 +1028,7 @@ is wrapped around any parts requiring it." deps)))) (declare-function lm-header "lisp-mnt" (header)) +(declare-function lm-header-multiline "lisp-mnt" (header)) (declare-function lm-homepage "lisp-mnt" (&optional file)) (declare-function lm-keywords-list "lisp-mnt" (&optional file)) (declare-function lm-maintainer "lisp-mnt" (&optional file)) @@ -1054,7 +1055,8 @@ boundaries." (narrow-to-region start (point)) (require 'lisp-mnt) ;; Use some headers we've invented to drive the process. - (let* ((requires-str (lm-header "package-requires")) + (let* ((requires-str + (mapconcat 'identity (lm-header-multiline "package-requires") " ")) ;; Prefer Package-Version; if defined, the package author ;; probably wants us to use it. Otherwise try Version. (pkg-version commit c02f3125cd6c1843731ab96f156c8ea24dcfe898 Author: Thomas Fitzsimmons Date: Thu Aug 15 23:12:50 2019 -0400 Do not recreate full URL for proxied HTTPS requests (Bug#35969) * lisp/url/url-http.el (url-http-create-request): Do not recreate full URL for proxied HTTPS requests. (url-https-proxy-after-change-function): Do not bind url-http-proxy to nil before calling url-http-create-request. (Bug#35969) diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 94d1ba9668..bfc106c2a5 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -329,7 +329,10 @@ Use `url-http-referer' as the Referer-header (subject to `url-privacy-level')." ;; The request (or url-http-method "GET") " " (url-http--encode-string - (if using-proxy (url-recreate-url url-http-target-url) real-fname)) + (if (and using-proxy + ;; Bug#35969. + (not (equal "https" (url-type url-http-target-url)))) + (url-recreate-url url-http-target-url) real-fname)) " HTTP/" url-http-version "\r\n" ;; Version of MIME we speak "MIME-Version: 1.0\r\n" @@ -1439,9 +1442,7 @@ The return value of this function is the retrieval buffer." 'url-http-wait-for-headers-change-function) (set-process-filter tls-connection 'url-http-generic-filter) (process-send-string tls-connection - ;; Use the non-proxy form of the request - (let (url-http-proxy) - (url-http-create-request)))) + (url-http-create-request))) (gnutls-error (url-http-activate-callback) (error "gnutls-error: %s" e)) commit 3393364b6b925ec6ad4b2570ed8ea5358170b312 Author: Andreas Merziger Date: Thu Aug 15 18:39:27 2019 -0700 Make diary-european-date-forms elements mutually exclusive * lisp/calendar/calendar.el (diary-european-date-forms): Make the elements mutually exclusive (bug#13536). diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index 14604a673d..e7a7bd47d6 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -799,7 +799,7 @@ but `diary-date-forms' (which see)." '((day "/" month "[^/0-9]") (day "/" month "/" year "[^0-9]") (backup day " *" monthname "\\W+\\<\\([^*0-9]\\|\\([0-9]+[:aApP]\\)\\)") - (day " *" monthname " *" year "[^0-9]") + (day " *" monthname " *" year "[^0-9:aApP]") (dayname "\\W")) "List of pseudo-patterns describing the European style of dates. The defaults are: DAY/MONTH; DAY/MONTH/YEAR; DAY MONTHNAME; commit 1cf489c1657378e95057d795234c99df128391a6 Author: Lars Ingebrigtsen Date: Thu Aug 15 18:10:22 2019 -0700 Fix up previous cl-def* changes in bovine * lisp/cedet/semantic/bovine/el.el (lambda): cl-defun* doesn't exist (bug#17005). (lambda): Add cl-defstruct. (semantic-up-context): Add cl- forms. diff --git a/lisp/cedet/semantic/bovine/el.el b/lisp/cedet/semantic/bovine/el.el index ba8307d2a4..b4217080b6 100644 --- a/lisp/cedet/semantic/bovine/el.el +++ b/lisp/cedet/semantic/bovine/el.el @@ -249,7 +249,6 @@ Return a bovination list to use." defsubst defmacro cl-defun - cl-defun* cl-defsubst cl-defmacro define-overload ;; @todo - remove after cleaning up semantic. @@ -396,6 +395,7 @@ Return a bovination list to use." (cons nil nil) ))) defstruct + cl-defstruct ) (semantic-elisp-setup-form-parser @@ -614,7 +614,7 @@ Returns non-nil it is not possible to go up a context." (let ((last-up (semantic-up-context-default))) (while (and (not (looking-at - "(\\(let\\*?\\|def\\(un\\|method\\|generic\\|\ + "(\\(let\\*?\\|\\(?:cl-\\)?def\\(un\\|method\\|generic\\|\ define-mode-overload\\)\ \\|with-slots\\)")) (not last-up)) commit ab8a96977f6fc91d9a6ba4fe8a2a959c0525e339 Author: Lars Ingebrigtsen Date: Thu Aug 15 18:00:08 2019 -0700 Reimplement the `fill-flowed' function to respect space stuffing * lisp/mail/flow-fill.el (fill-flowed): Reimplement the function to respect space-stuffing (bug#17190). * test/lisp/mail/flow-fill-tests.el (fill-flow-tests-fill-flowed-stuffed): New test. (fill-flow-tests-fill-flowed-decode): Rename the test so that it actually runs. diff --git a/lisp/mail/flow-fill.el b/lisp/mail/flow-fill.el index 948a7d799f..7b50fcd96e 100644 --- a/lisp/mail/flow-fill.el +++ b/lisp/mail/flow-fill.el @@ -120,55 +120,49 @@ If BUFFER is nil, default to the current buffer. If DELETE-SPACE, delete RFC2646 spaces padding at the end of lines." (with-current-buffer (or buffer (current-buffer)) - (goto-char (point-min)) - ;; Remove space stuffing. - (while (re-search-forward "^\\( \\|>+ $\\)" nil t) - (delete-char -1) - (forward-line 1)) - (goto-char (point-min)) - (while (re-search-forward " $" nil t) - (when (save-excursion - (beginning-of-line) - (looking-at "^\\(>*\\)\\( ?\\)")) - (let ((quote (match-string 1)) - sig) - (if (string= quote "") - (setq quote nil)) - (when (and quote (string= (match-string 2) "")) - (save-excursion - ;; insert SP after quote for pleasant reading of quoted lines - (beginning-of-line) - (when (> (skip-chars-forward ">") 0) - (insert " ")))) - ;; XXX slightly buggy handling of "-- " - (while (and (save-excursion - (ignore-errors (backward-char 3)) - (setq sig (looking-at "-- ")) - (looking-at "[^-][^-] ")) - (save-excursion - (unless (eobp) - (forward-char 1) - (looking-at (format "^\\(%s\\)\\([^>\n\r]\\)" - (or quote " ?")))))) - (save-excursion - (replace-match (if (string= (match-string 2) " ") - "" "\\2"))) - (backward-delete-char -1) - (when delete-space - (delete-char -1)) - (end-of-line)) - (unless sig - (condition-case nil - (let ((fill-prefix (when quote (concat quote " "))) - (fill-column (eval fill-flowed-display-column)) - adaptive-fill-mode) - (fill-region (point-at-bol) - (min (1+ (point-at-eol)) - (point-max)) - 'left 'nosqueeze)) - (error - (forward-line 1) - nil)))))))) + (let ((fill-column (eval fill-flowed-display-column))) + (goto-char (point-min)) + (while (not (eobp)) + (cond + ((and (looking-at "^>+") + (eq (char-before (line-end-position)) ?\s)) + (let ((prefix (match-string 0))) + ;; Insert a space character after the quote signs for more + ;; pleasant reading of quoted lines. + (goto-char (match-end 0)) + (unless (looking-at " ") + (insert " ")) + (end-of-line) + (when (and (not (eobp)) + (save-excursion + (forward-line 1) + (looking-at (format "\\(%s ?\\)[^>]" prefix)))) + ;; Delete the newline and the quote at the start of the + ;; next line. + (delete-region (point) (match-end 1)) + (ignore-errors + (let ((fill-prefix (concat prefix " ")) + adaptive-fill-mode) + (fill-region (line-beginning-position) + (line-end-position) + 'left 'nosqueeze)))))) + (t + ;; Delete the newline. + (when (eq (following-char) ?\s) + (delete-char 1)) + ;; Hack: Don't do the flowing on the signature line. + (when (and (not (looking-at "-- $")) + (eq (char-before (line-end-position)) ?\s)) + (end-of-line) + (when delete-space + (delete-char -1)) + (delete-char 1) + (ignore-errors + (let ((fill-prefix "")) + (fill-region (line-beginning-position) + (line-end-position) + 'left 'nosqueeze)))))) + (forward-line 1))))) (make-obsolete-variable 'fill-flowed-encode-tests nil "27.1") (defvar fill-flowed-encode-tests) diff --git a/test/lisp/mail/flow-fill-tests.el b/test/lisp/mail/flow-fill-tests.el index a05950bb70..2dd516b91d 100644 --- a/test/lisp/mail/flow-fill-tests.el +++ b/test/lisp/mail/flow-fill-tests.el @@ -24,7 +24,7 @@ (require 'ert) (require 'flow-fill) -(ert-deftest fill-flow-tests-fill-flowed-encode () +(ert-deftest fill-flow-tests-fill-flowed-decode () (let ((input (concat "> Thou villainous ill-breeding spongy dizzy-eyed \n" @@ -53,6 +53,7 @@ (with-temp-buffer (insert input) (fill-flowed) + (message "foo") (should (equal (buffer-string) output))))) (ert-deftest fill-flow-tests-fill-flowed-encode () @@ -88,5 +89,18 @@ (fill-flowed-encode) (should (equal (buffer-string) output))))) +(ert-deftest fill-flow-tests-fill-flowed-stuffed () + (let ((input + (concat + " > From space-stuffed with a \n" + "continuation.\n")) + (output + "> From space-stuffed with a continuation.\n") + (fill-flowed-display-column 69)) + (with-temp-buffer + (insert input) + (fill-flowed) + (should (equal (buffer-string) output))))) + (provide 'flow-fill-tests) ;;; flow-fill-tests.el ends here commit 1ee0192b792124663a0a40a729dd83c047d21535 Author: Alex Branham Date: Wed Jun 26 13:59:06 2019 -0500 Fix eshell-mode-map initialization * lisp/eshell/esh-mode.el (eshell-mode-map, eshell-command-map): Set up normal keymaps and prefix commands rather than re-initializing them in each eshell buffer * lisp/eshell/em-cmpl.el (eshell-cmpl-mode-map, eshell-cmpl-mode) (eshell-cmpl-initialize): * lisp/eshell/em-hist.el (eshell-hist-mode-map, eshell-hist-mode) (eshell-hist-initialize): * lisp/eshell/em-pred.el (eshell-pred-mode-map, eshell-pred-mode) (eshell-pred-initialize): * lisp/eshell/em-prompt.el (eshell-prompt-mode-map, eshell-prompt-mode) (eshell-prompt-initialize): * lisp/eshell/em-rebind.el (eshell-rebind-mode-map, eshell-rebind-mode) (eshell-rebind-initialize): * lisp/eshell/esh-arg.el (eshell-arg-mode-map, eshell-arg-mode) (eshell-arg-initialize): * lisp/eshell/esh-proc.el (eshell-proc-mode-map, eshell-proc-mode) (eshell-proc-initialize): * lisp/eshell/esh-var.el (eshell-var-mode-map, eshell-var-mode) (eshell-var-initialize): Create a new minor mode with a keymap and call it in the module initialization function. bug#33808 bug#22792 diff --git a/etc/NEWS b/etc/NEWS index 38825fd1da..edce7b3e57 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1355,6 +1355,12 @@ default, and not just the opening element. behave similarly, e.g. Pcomplete's default cycling can be obtained with '(setq completion-cycle-threshold 5)'. +--- +*** Eshell no longer re-initializes its keymap every call. +This allows users to use (define-key eshell-mode-map ...) as usual. +Some modules have their own minor mode now to account for these +changes. + +++ *** Expansion of history event designators is disabled by default. To restore the old behavior, use diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el index 8f6c6781b9..df4e24c88b 100644 --- a/lisp/eshell/em-cmpl.el +++ b/lisp/eshell/em-cmpl.el @@ -244,6 +244,26 @@ to writing a completion function." (let ((completion-at-point-functions '(lisp-completion-at-point))) (completion-at-point))) +(defvar eshell-cmpl-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [(control ?i)] #'completion-at-point) + ;; jww (1999-10-19): Will this work on anything but X? + (define-key map [backtab] #'pcomplete-reverse) + (define-key map [(meta ??)] #'completion-help-at-point) + (define-key map [(meta control ?i)] #'eshell-complete-lisp-symbol) + ;; C-c prefix: + (define-key map (kbd "C-c M-h") #'eshell-completion-help) + (define-key map (kbd "C-c TAB") #'pcomplete-expand-and-complete) + (define-key map (kbd "C-c C-i") #'pcomplete-expand-and-complete) + (define-key map (kbd "C-c SPC") #'pcomplete-expand) + map)) + +(define-minor-mode eshell-cmpl-mode + "Minor mode that provides a keymap when `eshell-cmpl' active. + +\\{eshell-cmpl-mode-map}" + :keymap eshell-cmpl-mode-map) + (defun eshell-cmpl-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the completions module." (set (make-local-variable 'pcomplete-command-completion-function) @@ -291,22 +311,9 @@ to writing a completion function." eshell-special-chars-outside-quoting))) nil t) (add-hook 'pcomplete-quote-arg-hook #'eshell-quote-backslash nil t) - ;;(define-key eshell-mode-map [(meta tab)] 'eshell-complete-lisp-symbol) ; Redundant - (define-key eshell-mode-map [(meta control ?i)] 'eshell-complete-lisp-symbol) - (define-key eshell-command-map [(meta ?h)] 'eshell-completion-help) - (define-key eshell-command-map [tab] 'pcomplete-expand-and-complete) - (define-key eshell-command-map [(control ?i)] - 'pcomplete-expand-and-complete) - (define-key eshell-command-map [space] 'pcomplete-expand) - (define-key eshell-command-map [? ] 'pcomplete-expand) - ;;(define-key eshell-mode-map [tab] 'completion-at-point) ;Redundant! - (define-key eshell-mode-map [(control ?i)] 'completion-at-point) (add-hook 'completion-at-point-functions #'pcomplete-completions-at-point nil t) - ;; jww (1999-10-19): Will this work on anything but X? - (define-key eshell-mode-map - (if (featurep 'xemacs) [iso-left-tab] [backtab]) 'pcomplete-reverse) - (define-key eshell-mode-map [(meta ??)] 'completion-help-at-point)) + (eshell-cmpl-mode)) (defun eshell-completion-command-name () "Return the command name, possibly sans globbing." diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el index adb028002b..9a9e6f0f39 100644 --- a/lisp/eshell/em-hist.el +++ b/lisp/eshell/em-hist.el @@ -202,6 +202,32 @@ element, regardless of any text on the command line. In that case, map) "Keymap used in isearch in Eshell.") +(defvar eshell-hist-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [up] #'eshell-previous-matching-input-from-input) + (define-key map [down] #'eshell-next-matching-input-from-input) + (define-key map [(control up)] #'eshell-previous-input) + (define-key map [(control down)] #'eshell-next-input) + (define-key map [(meta ?r)] #'eshell-previous-matching-input) + (define-key map [(meta ?s)] #'eshell-next-matching-input) + (define-key map (kbd "C-c M-r") #'eshell-previous-matching-input-from-input) + (define-key map (kbd "C-c M-s") #'eshell-next-matching-input-from-input) + ;; FIXME: Relies on `eshell-hist-match-partial' being set _before_ + ;; em-hist is loaded and won't respect changes. + (if eshell-hist-match-partial + (progn + (define-key map [(meta ?p)] 'eshell-previous-matching-input-from-input) + (define-key map [(meta ?n)] 'eshell-next-matching-input-from-input) + (define-key map (kbd "C-c M-p") #'eshell-previous-input) + (define-key map (kbd "C-c M-n") #'eshell-next-input)) + (define-key map [(meta ?p)] #'eshell-previous-input) + (define-key map [(meta ?n)] #'eshell-next-input) + (define-key map (kbd "C-c M-p") #'eshell-previous-matching-input-from-input) + (define-key map (kbd "C-c M-n") #'eshell-next-matching-input-from-input)) + (define-key map (kbd "C-c C-l") #'eshell-list-history) + (define-key map (kbd "C-c C-x") #'eshell-get-next-from-history) + map)) + (defvar eshell-rebind-keys-alist) ;;; Functions: @@ -216,6 +242,12 @@ Returns non-nil if INPUT is blank." Returns nil if INPUT is prepended by blank space, otherwise non-nil." (not (string-match-p "\\`\\s-+" input))) +(define-minor-mode eshell-hist-mode + "Minor mode for the eshell-hist module. + +\\{eshell-hist-mode-map}" + :keymap eshell-hist-mode-map) + (defun eshell-hist-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the history management code for one Eshell buffer." (when (eshell-using-module 'eshell-cmpl) @@ -242,30 +274,7 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil." (lambda () (setq overriding-terminal-local-map nil))) nil t)) - (define-key eshell-mode-map [up] 'eshell-previous-matching-input-from-input) - (define-key eshell-mode-map [down] 'eshell-next-matching-input-from-input) - (define-key eshell-mode-map [(control up)] 'eshell-previous-input) - (define-key eshell-mode-map [(control down)] 'eshell-next-input) - (define-key eshell-mode-map [(meta ?r)] 'eshell-previous-matching-input) - (define-key eshell-mode-map [(meta ?s)] 'eshell-next-matching-input) - (define-key eshell-command-map [(meta ?r)] - 'eshell-previous-matching-input-from-input) - (define-key eshell-command-map [(meta ?s)] - 'eshell-next-matching-input-from-input) - (if eshell-hist-match-partial - (progn - (define-key eshell-mode-map [(meta ?p)] - 'eshell-previous-matching-input-from-input) - (define-key eshell-mode-map [(meta ?n)] - 'eshell-next-matching-input-from-input) - (define-key eshell-command-map [(meta ?p)] 'eshell-previous-input) - (define-key eshell-command-map [(meta ?n)] 'eshell-next-input)) - (define-key eshell-mode-map [(meta ?p)] 'eshell-previous-input) - (define-key eshell-mode-map [(meta ?n)] 'eshell-next-input) - (define-key eshell-command-map [(meta ?p)] - 'eshell-previous-matching-input-from-input) - (define-key eshell-command-map [(meta ?n)] - 'eshell-next-matching-input-from-input))) + (eshell-hist-mode)) (make-local-variable 'eshell-history-size) (or eshell-history-size @@ -300,10 +309,7 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil." (add-hook 'kill-emacs-hook #'eshell-save-some-history) (make-local-variable 'eshell-input-filter-functions) - (add-hook 'eshell-input-filter-functions #'eshell-add-to-history nil t) - - (define-key eshell-command-map [(control ?l)] 'eshell-list-history) - (define-key eshell-command-map [(control ?x)] 'eshell-get-next-from-history)) + (add-hook 'eshell-input-filter-functions #'eshell-add-to-history nil t)) (defun eshell-save-some-history () "Save the history for any open Eshell buffers." diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el index 9bc856a296..cfef59f962 100644 --- a/lisp/eshell/em-pred.el +++ b/lisp/eshell/em-pred.el @@ -229,6 +229,12 @@ FOR LISTS OF ARGUMENTS: EXAMPLES: *.c(:o) sorted list of .c files") +(defvar eshell-pred-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c M-q") #'eshell-display-predicate-help) + (define-key map (kbd "C-c M-m") #'eshell-display-modifier-help) + map)) + ;;; Functions: (defun eshell-display-predicate-help () @@ -245,12 +251,17 @@ EXAMPLES: (lambda () (insert eshell-modifier-help-string))))) +(define-minor-mode eshell-pred-mode + "Minor mode for the eshell-pred module. + +\\{eshell-pred-mode-map}" + :keymap eshell-pred-mode-map) + (defun eshell-pred-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the predicate/modifier code." (add-hook 'eshell-parse-argument-hook #'eshell-parse-arg-modifier t t) - (define-key eshell-command-map [(meta ?q)] 'eshell-display-predicate-help) - (define-key eshell-command-map [(meta ?m)] 'eshell-display-modifier-help)) + (eshell-pred-mode)) (defun eshell-apply-modifiers (lst predicates modifiers) "Apply to LIST a series of PREDICATES and MODIFIERS." diff --git a/lisp/eshell/em-prompt.el b/lisp/eshell/em-prompt.el index adc68b6c85..993a740b82 100644 --- a/lisp/eshell/em-prompt.el +++ b/lisp/eshell/em-prompt.el @@ -97,8 +97,20 @@ arriving, or after." :options '(eshell-show-maximum-output) :group 'eshell-prompt) +(defvar eshell-prompt-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-n") #'eshell-next-prompt) + (define-key map (kbd "C-c C-p") #'eshell-previous-prompt) + map)) + ;;; Functions: +(define-minor-mode eshell-prompt-mode + "Minor mode for eshell-prompt module. + +\\{eshell-prompt-mode-map}" + :keymap eshell-prompt-mode-map) + (defun eshell-prompt-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the prompting code." (unless eshell-non-interactive-p @@ -110,9 +122,7 @@ arriving, or after." (set (make-local-variable 'eshell-skip-prompt-function) 'eshell-skip-prompt) - - (define-key eshell-command-map [(control ?n)] 'eshell-next-prompt) - (define-key eshell-command-map [(control ?p)] 'eshell-previous-prompt))) + (eshell-prompt-mode))) (defun eshell-emit-prompt () "Emit a prompt if eshell is being used interactively." diff --git a/lisp/eshell/em-rebind.el b/lisp/eshell/em-rebind.el index a817edbcc9..5fb6677e18 100644 --- a/lisp/eshell/em-rebind.el +++ b/lisp/eshell/em-rebind.el @@ -137,6 +137,11 @@ This is default behavior of shells like bash." :type '(repeat function) :group 'eshell-rebind) +(defvar eshell-rebind-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c M-l") #'eshell-lock-local-map) + map)) + ;; Internal Variables: (defvar eshell-input-keymap) @@ -145,6 +150,12 @@ This is default behavior of shells like bash." ;;; Functions: +(define-minor-mode eshell-rebind-mode + "Minor mode for the eshell-rebind module. + +\\{eshell-rebind-mode-map}" + :keymap eshell-rebind-mode-map) + (defun eshell-rebind-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the inputting code." (unless eshell-non-interactive-p @@ -154,7 +165,7 @@ This is default behavior of shells like bash." (make-local-variable 'overriding-local-map) (add-hook 'post-command-hook 'eshell-rebind-input-map nil t) (set (make-local-variable 'eshell-lock-keymap) nil) - (define-key eshell-command-map [(meta ?l)] 'eshell-lock-local-map))) + (eshell-rebind-mode))) (defun eshell-lock-local-map (&optional arg) "Lock or unlock the current local keymap. diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el index 026edc5980..4685095826 100644 --- a/lisp/eshell/esh-arg.el +++ b/lisp/eshell/esh-arg.el @@ -155,14 +155,22 @@ treated as a literal character." :type 'hook :group 'eshell-arg) +(defvar eshell-arg-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c M-b") #'eshell-insert-buffer-name) + map)) + ;;; Functions: +(define-minor-mode eshell-arg-mode + "Minor mode for the arg eshell module. + +\\{eshell-arg-mode-map}" + :keymap eshell-arg-mode-map) + (defun eshell-arg-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the argument parsing code." - ;; This is supposedly run after enabling esh-mode, when eshell-mode-map - ;; already exists. - (defvar eshell-command-map) - (define-key eshell-command-map [(meta ?b)] 'eshell-insert-buffer-name) + (eshell-arg-mode) (set (make-local-variable 'eshell-inside-quote-regexp) nil) (set (make-local-variable 'eshell-outside-quote-regexp) nil)) diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index 80844c3a64..91204877f5 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -213,10 +213,7 @@ This is used by `eshell-watch-for-password-prompt'." ;; these are only set to nil initially for the sake of the ;; byte-compiler, when compiling other files which `require' this one (defvar eshell-mode nil) -(defvar eshell-mode-map nil) (defvar eshell-command-running-string "--") -(defvar eshell-command-map nil) -(defvar eshell-command-prefix nil) (defvar eshell-last-input-start nil) (defvar eshell-last-input-end nil) (defvar eshell-last-output-start nil) @@ -286,6 +283,32 @@ This is used by `eshell-watch-for-password-prompt'." (standard-syntax-table)) st)) +(defvar eshell-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [(control ?c)] 'eshell-command-map) + (define-key map "\r" #'eshell-send-input) + (define-key map "\M-\r" #'eshell-queue-input) + (define-key map [(meta control ?l)] #'eshell-show-output) + (define-key map [(control ?a)] #'eshell-bol) + map)) + +(defvar eshell-command-map + (let ((map (define-prefix-command 'eshell-command-map))) + (define-key map [(meta ?o)] #'eshell-mark-output) + (define-key map [(meta ?d)] #'eshell-toggle-direct-send) + (define-key map [(control ?a)] #'eshell-bol) + (define-key map [(control ?b)] #'eshell-backward-argument) + (define-key map [(control ?e)] #'eshell-show-maximum-output) + (define-key map [(control ?f)] #'eshell-forward-argument) + (define-key map [(control ?m)] #'eshell-copy-old-input) + (define-key map [(control ?o)] #'eshell-kill-output) + (define-key map [(control ?r)] #'eshell-show-output) + (define-key map [(control ?t)] #'eshell-truncate-buffer) + (define-key map [(control ?u)] #'eshell-kill-input) + (define-key map [(control ?w)] #'backward-kill-word) + (define-key map [(control ?y)] #'eshell-repeat-argument) + map)) + ;;; User Functions: (defun eshell-kill-buffer-function () @@ -304,10 +327,6 @@ and the hook `eshell-exit-hook'." "Emacs shell interactive mode." (setq-local eshell-mode t) - ;; FIXME: What the hell!? - (setq-local eshell-mode-map (make-sparse-keymap)) - (use-local-map eshell-mode-map) - (when eshell-status-in-mode-line (make-local-variable 'eshell-command-running-string) (let ((fmt (copy-sequence mode-line-format))) @@ -316,31 +335,6 @@ and the hook `eshell-exit-hook'." (if mode-line-elt (setcar mode-line-elt 'eshell-command-running-string)))) - (define-key eshell-mode-map "\r" 'eshell-send-input) - (define-key eshell-mode-map "\M-\r" 'eshell-queue-input) - (define-key eshell-mode-map [(meta control ?l)] 'eshell-show-output) - (define-key eshell-mode-map [(control ?a)] 'eshell-bol) - - (setq-local eshell-command-prefix (make-symbol "eshell-command-prefix")) - (fset eshell-command-prefix (make-sparse-keymap)) - (setq-local eshell-command-map (symbol-function eshell-command-prefix)) - (define-key eshell-mode-map [(control ?c)] eshell-command-prefix) - - (define-key eshell-command-map [(meta ?o)] 'eshell-mark-output) - (define-key eshell-command-map [(meta ?d)] 'eshell-toggle-direct-send) - - (define-key eshell-command-map [(control ?a)] 'eshell-bol) - (define-key eshell-command-map [(control ?b)] 'eshell-backward-argument) - (define-key eshell-command-map [(control ?e)] 'eshell-show-maximum-output) - (define-key eshell-command-map [(control ?f)] 'eshell-forward-argument) - (define-key eshell-command-map [(control ?m)] 'eshell-copy-old-input) - (define-key eshell-command-map [(control ?o)] 'eshell-kill-output) - (define-key eshell-command-map [(control ?r)] 'eshell-show-output) - (define-key eshell-command-map [(control ?t)] 'eshell-truncate-buffer) - (define-key eshell-command-map [(control ?u)] 'eshell-kill-input) - (define-key eshell-command-map [(control ?w)] 'backward-kill-word) - (define-key eshell-command-map [(control ?y)] 'eshell-repeat-argument) - (setq local-abbrev-table eshell-mode-abbrev-table) (set (make-local-variable 'list-buffers-directory) diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el index 32a3eecb52..a6d6aae678 100644 --- a/lisp/eshell/esh-proc.el +++ b/lisp/eshell/esh-proc.el @@ -109,6 +109,16 @@ information, for example." (defvar eshell-process-list nil "A list of the current status of subprocesses.") +(defvar eshell-proc-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c M-i") #'eshell-insert-process) + (define-key map (kbd "C-c C-c") #'eshell-interrupt-process) + (define-key map (kbd "C-c C-k") #'eshell-kill-process) + (define-key map (kbd "C-c C-d") #'eshell-send-eof-to-process) + (define-key map (kbd "C-c C-s") #'list-processes) + (define-key map (kbd "C-c C-\\") #'eshell-quit-process) + map)) + ;;; Functions: (defun eshell-kill-process-function (proc status) @@ -121,20 +131,16 @@ PROC and STATUS to functions on the latter." (eshell-reset-after-proc status) (run-hook-with-args 'eshell-kill-hook proc status)) +(define-minor-mode eshell-proc-mode + "Minor mode for the proc eshell module. + +\\{eshell-proc-mode-map}" + :keymap eshell-proc-mode-map) + (defun eshell-proc-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the process handling code." (make-local-variable 'eshell-process-list) - ;; This is supposedly run after enabling esh-mode, when eshell-command-map - ;; already exists. - (defvar eshell-command-map) - (define-key eshell-command-map [(meta ?i)] 'eshell-insert-process) - (define-key eshell-command-map [(control ?c)] 'eshell-interrupt-process) - (define-key eshell-command-map [(control ?k)] 'eshell-kill-process) - (define-key eshell-command-map [(control ?d)] 'eshell-send-eof-to-process) -; (define-key eshell-command-map [(control ?q)] 'eshell-continue-process) - (define-key eshell-command-map [(control ?s)] 'list-processes) -; (define-key eshell-command-map [(control ?z)] 'eshell-stop-process) - (define-key eshell-command-map [(control ?\\)] 'eshell-quit-process)) + (eshell-proc-mode)) (defun eshell-reset-after-proc (status) "Reset the command input location after a process terminates. diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index b08a5d242f..6ec58464c5 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -197,8 +197,19 @@ function), and the arguments passed to this function would be the list (put 'eshell-variable-aliases-list 'risky-local-variable t) +(defvar eshell-var-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c M-v") #'eshell-insert-envvar) + map)) + ;;; Functions: +(define-minor-mode eshell-var-mode + "Minor mode for the esh-var module. + +\\{eshell-var-mode-map}" + :keymap eshell-var-mode-map) + (defun eshell-var-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the variable handle code." ;; Break the association with our parent's environment. Otherwise, @@ -207,11 +218,6 @@ function), and the arguments passed to this function would be the list (set (make-local-variable 'process-environment) (eshell-copy-environment))) - ;; This is supposedly run after enabling esh-mode, when eshell-command-map - ;; already exists. - (defvar eshell-command-map) - (define-key eshell-command-map [(meta ?v)] 'eshell-insert-envvar) - (set (make-local-variable 'eshell-special-chars-inside-quoting) (append eshell-special-chars-inside-quoting '(?$))) (set (make-local-variable 'eshell-special-chars-outside-quoting) commit b3713265cbb8eb591ac832ae4c35bf8185544467 Author: Lars Ingebrigtsen Date: Thu Aug 15 16:02:20 2019 -0700 Rename variables and functions with "auto-load" in their names * doc/emacs/building.texi (Lisp Libraries): Adjust documentation. * lisp/help-fns.el (help--symbol-completion-table): Adjust usage. * lisp/help-fns.el (help-enable-completion-autoload): Change name from auto-load and declare an obsolete alias (bug#13418). * lisp/help.el (help-enable-autoload): Ditto. * lisp/progmodes/vhdl-mode.el: Ditto. (vhdl-create-mode-menu, vhdl-mode): Adjust usage. (vhdl-autoload-project): Rename from auto-load and declare an obsolete alias. diff --git a/doc/emacs/building.texi b/doc/emacs/building.texi index 6e16588861..990b82d10e 100644 --- a/doc/emacs/building.texi +++ b/doc/emacs/building.texi @@ -1513,19 +1513,19 @@ call it, Emacs automatically loads the @code{compile} library first. In contrast, the command @kbd{M-x recompile} is not autoloaded, so it is unavailable until you load the @code{compile} library. -@vindex help-enable-auto-load +@vindex help-enable-autoload Automatic loading can also occur when you look up the documentation of an autoloaded command (@pxref{Name Help}), if the documentation refers to other functions and variables in its library (loading the library lets Emacs properly set up the hyperlinks in the @file{*Help*} buffer). To disable this feature, change the variable -@code{help-enable-auto-load} to @code{nil}. +@code{help-enable-autoload} to @code{nil}. -@vindex help-enable-completion-auto-load +@vindex help-enable-completion-autoload Automatic loading also occurs when completing names for @code{describe-variable} and @code{describe-function}, based on the prefix being completed. To disable this feature, change the variable -@code{help-enable-completion-auto-load} to @code{nil}. +@code{help-enable-completion-autoload} to @code{nil}. @vindex load-dangerous-libraries @cindex Lisp files byte-compiled by XEmacs diff --git a/etc/NEWS b/etc/NEWS index 361668c46d..38825fd1da 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2008,6 +2008,12 @@ valid event type. * Lisp Changes in Emacs 27.1 +** The variables 'help-enable-completion-auto-load', +'help-enable-auto-load' and 'vhdl-project-auto-load', as well as the +'vhdl-auto-load-project' have been renamed to have "autoload" without +the hyphen in their names. Obsolete aliases from the old names have +been added. + +++ ** Buttons (created with 'make-button' and related functions) can now use the 'button-data' property. If present, the data in this diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index 40567e141d..14646a2ab1 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -222,7 +222,7 @@ exiting the minibuffer." t)) ;; superemulates behavior of completing_read in src/minibuf.c -;; Use \\ so that help-enable-auto-load can +;; Use \\ so that help-enable-autoload can ;; do its thing. Any keymap that is defined will do. ;;;###autoload (defun completing-read-multiple diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 1207353ba3..e5c1d9cec4 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -320,7 +320,7 @@ programming features." (set-window-start window warning-series)) (sit-for 0))))))))) -;; Use \\ so that help-enable-auto-load can do its thing. +;; Use \\ so that help-enable-autoload can do its thing. ;; Any keymap that is defined will do. ;;;###autoload (defun lwarn (type level message &rest args) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 0b5c547d6b..7c059c25b7 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -104,7 +104,11 @@ and the output should go to `standard-output'.") (with-demoted-errors "while loading: %S" (load file 'noerror 'nomessage)))))) -(defcustom help-enable-completion-auto-load t + +(define-obsolete-variable-alias 'help-enable-completion-auto-load + 'help-enable-completion-autoload "27.1") + +(defcustom help-enable-completion-autoload t "Whether completion for Help commands can perform autoloading. If non-nil, whenever invoking completion for `describe-function' or `describe-variable' load files that might contain definitions @@ -115,11 +119,11 @@ with the current prefix. The files are chosen according to :version "26.3") (defun help--symbol-completion-table (string pred action) - (when help-enable-completion-auto-load + (when help-enable-completion-autoload (let ((prefixes (radix-tree-prefixes (help-definition-prefixes) string))) (help--load-prefixes prefixes))) (let ((prefix-completions - (and help-enable-completion-auto-load + (and help-enable-completion-autoload (mapcar #'intern (all-completions string definition-prefixes))))) (complete-with-action action obarray string (if pred (lambda (sym) @@ -799,7 +803,7 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." ;; If the function is autoloaded, and its docstring has ;; key substitution constructs, load the library. (and (autoloadp real-def) doc-raw - help-enable-auto-load + help-enable-autoload (string-match "\\([^\\]=\\|[^=]\\|\\`\\)\\\\[[{<]" doc-raw) (autoload-do-load real-def)) diff --git a/lisp/help.el b/lisp/help.el index 039d0c44e4..e40178de96 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1209,7 +1209,10 @@ by `with-help-window'." :group 'help :version "23.1") -(defcustom help-enable-auto-load t +(define-obsolete-variable-alias 'help-enable-auto-load + 'help-enable-autoload "27.1") + +(defcustom help-enable-autoload t "Whether Help commands can perform autoloading. If non-nil, whenever \\[describe-function] is called for an autoloaded function whose docstring contains any key substitution diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index 2c947f3b05..8cdf9cd34a 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -692,7 +692,7 @@ browser. The current project can also be changed temporarily in the menu." replaced by the user name (allows you to have user-specific project setups). The first entry is used as file name to import/export individual project setups. All entries are used to automatically import project setups at -startup (see option `vhdl-project-auto-load'). Projects loaded from the +startup (see option `vhdl-project-autoload'). Projects loaded from the first entry are automatically made current. Hint: specify local project setups in first entry, global setups in following entries; loading a local project setup will make it current, while loading the global setups @@ -702,7 +702,11 @@ in global directories)." :type '(repeat (string :tag "File name" "\\1.prj")) :group 'vhdl-project) -(defcustom vhdl-project-auto-load '(startup) + +(define-obsolete-variable-alias 'vhdl-project-auto-load + 'vhdl-project-autoload "27.1") + +(defcustom vhdl-project-autoload '(startup) "Automatically load project setups from files. All project setup files that match the file names specified in option `vhdl-project-file-name' are automatically loaded. The project of the @@ -3673,11 +3677,11 @@ STRING are replaced by `-' and substrings are converted to lower case." ["Setup File Name..." (customize-option 'vhdl-project-file-name) t] ("Auto Load Setup File" ["At Startup" - (customize-set-variable 'vhdl-project-auto-load - (if (memq 'startup vhdl-project-auto-load) - (delq 'startup vhdl-project-auto-load) - (cons 'startup vhdl-project-auto-load))) - :style toggle :selected (memq 'startup vhdl-project-auto-load)]) + (customize-set-variable 'vhdl-project-autoload + (if (memq 'startup vhdl-project-autoload) + (delq 'startup vhdl-project-autoload) + (cons 'startup vhdl-project-autoload))) + :style toggle :selected (memq 'startup vhdl-project-autoload)]) ["Sort Projects" (customize-set-variable 'vhdl-project-sort (not vhdl-project-sort)) :style toggle :selected vhdl-project-sort] @@ -4683,7 +4687,7 @@ Usage: Emacs with VHDL Mode (i.e. load a VHDL file or use \"emacs -l vhdl-mode\") in a directory with an existing project setup file, it is automatically loaded and its project activated if option - `vhdl-project-auto-load' is non-nil. Names/paths of the project setup + `vhdl-project-autoload' is non-nil. Names/paths of the project setup files can be specified in option `vhdl-project-file-name'. Multiple project setups can be automatically loaded from global directories. This is an alternative to specifying project setups with option @@ -13126,7 +13130,7 @@ File statistics: \"%s\"\n\ (list (cons new-name project-entry)))) (vhdl-update-mode-menu))) -(defun vhdl-auto-load-project () +(defun vhdl-autoload-project () "Automatically load project setup at startup." (let ((file-name-list vhdl-project-file-name) file-list list-length) @@ -13145,12 +13149,14 @@ File statistics: \"%s\"\n\ (not (> list-length 0))) (setq list-length (1- list-length)) (setq file-list (cdr file-list))))) +(define-obsolete-function-alias 'vhdl-auto-load-project + #'vhdl-autoload-project "27.1") ;; automatically load project setup when idle after startup -(when (memq 'startup vhdl-project-auto-load) +(when (memq 'startup vhdl-project-autoload) (if noninteractive - (vhdl-auto-load-project) - (vhdl-run-when-idle .1 nil 'vhdl-auto-load-project))) + (vhdl-autoload-project) + (vhdl-run-when-idle .1 nil 'vhdl-autoload-project))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -17635,7 +17641,7 @@ specified by a target." 'vhdl-project-alist 'vhdl-project 'vhdl-project-file-name - 'vhdl-project-auto-load + 'vhdl-project-autoload 'vhdl-project-sort 'vhdl-compiler-alist 'vhdl-compiler commit 7aefbe86f22a1c0b7d329c1931d0297f801e1f83 Author: Lars Ingebrigtsen Date: Thu Aug 15 15:27:01 2019 -0700 Remove mentions of XEmacs from the Gnus manual and faq * doc/misc/gnus-faq.texi: * doc/misc/gnus.texi: Remove references to XEmacs throughout. diff --git a/doc/misc/gnus-faq.texi b/doc/misc/gnus-faq.texi index 840cc08205..e2cfa79619 100644 --- a/doc/misc/gnus-faq.texi +++ b/doc/misc/gnus-faq.texi @@ -104,7 +104,6 @@ misprints are the Gnus team's fault, sorry. * FAQ 1-5:: I sometimes read references to No Gnus and Oort Gnus, what are those? * FAQ 1-6:: Which version of Emacs do I need? -* FAQ 1-7:: How do I run Gnus on both Emacs and XEmacs? @end menu @node FAQ 1-1 @@ -161,10 +160,9 @@ Where and how to get Gnus? @subsubheading Answer -Gnus is released independent from releases of Emacs and XEmacs. -Therefore, the version bundled with Emacs or the version in XEmacs's -package system might not be up to date (e.g., Gnus 5.9 bundled with Emacs -21 is outdated). +Gnus is released independent from releases of Emacs. Therefore, the +version bundled with Emacs might not be up to date (e.g., Gnus 5.9 +bundled with Emacs 21 is outdated). You can get the latest released version of Gnus from @uref{http://www.gnus.org/dist/gnus.tar.gz} or from @@ -187,13 +185,11 @@ tarball with some packer (e.g., Winace from and use the batch-file make.bat included in the tarball to install Gnus.) If you don't want to (or aren't allowed to) install Gnus system-wide, you can install it in your home directory and add the -following lines to your ~/.xemacs/init.el or ~/.emacs: +following lines to your ~/.emacs: @example (add-to-list 'load-path "/path/to/gnus/lisp") -(if (featurep 'xemacs) - (add-to-list 'Info-directory-list "/path/to/gnus/texi/") - (add-to-list 'Info-default-directory-list "/path/to/gnus/texi/")) +(add-to-list 'Info-default-directory-list "/path/to/gnus/texi/") @end example @noindent @@ -224,21 +220,9 @@ Which version of Emacs do I need? @subsubheading Answer Gnus 5.13 requires an Emacs version that is greater than or equal -to Emacs 23.1 or XEmacs 21.1, although there are some features that +to Emacs 23.1, although there are some features that only work on Emacs 24. -@node FAQ 1-7 -@subsubheading Question 1.7 - -How do I run Gnus on both Emacs and XEmacs? - -@subsubheading Answer - -You can't use the same copy of Gnus in both as the Lisp -files are byte-compiled to a format which is different -depending on which Emacs did the compilation. Get one copy -of Gnus for Emacs and one for XEmacs. - @node FAQ 2 - Startup / Group buffer @subsection Startup / Group buffer @@ -1389,9 +1373,8 @@ installed and in your Path. Then you need @uref{http://www.kdstevens.com/~stevens/ispell-page.html, ispell.el} and for on-the-fly spell-checking @uref{http://www-sop.inria.fr/members/Manuel.Serrano/flyspell/flyspell.html, flyspell.el}. -Ispell.el is shipped with Emacs and available through the XEmacs package system, -flyspell.el is shipped with Emacs and part of XEmacs text-modes package which is -available through the package system, so there should be no need to install them +Ispell.el is shipped with Emacs, +flyspell.el is shipped with Emacs, so there should be no need to install them manually. Ispell.el assumes you use ispell, if you choose aspell say @@ -1465,7 +1448,7 @@ node "Mail Aliases" in Message (not Gnus) manual for details. However, what you really want is the Insidious Big Brother -Database bbdb. Get it through the XEmacs package system or from +Database bbdb. Get it from @uref{http://bbdb.sourceforge.net/, bbdb's homepage}. Now place the following in @file{~/.gnus.el}, to activate bbdb for Gnus: @@ -1774,9 +1757,7 @@ more then one article." (let ((archive-name (format "nnml:1.%s" - (if (featurep 'xemacs) - (replace-in-string gnus-newsgroup-name "^.*:" "") - (replace-regexp-in-string "^.*:" "" gnus-newsgroup-name))))) + (replace-in-string gnus-newsgroup-name "^.*:" "")))) (gnus-summary-copy-article n archive-name))) @end example @noindent @@ -2289,8 +2270,8 @@ whatever-server which offers Gnus a standardized interface to functions like "get message", "get Headers" etc. @item Emacs -When the term Emacs is used in this FAQ, it means either GNU -Emacs or XEmacs. +When the term Emacs is used in this FAQ, it means GNU +Emacs. @item Message In this FAQ message means either a mail or a posting to a diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index 81e3c1dda5..28a5eccc6a 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -821,7 +821,7 @@ Various * Undo:: Some actions can be undone. * Predicate Specifiers:: Specifying predicates. * Moderation:: What to do if you're a moderator. -* Image Enhancements:: Modern versions of Emacs/XEmacs can display images. +* Image Enhancements:: Modern versions of Emacs can display images. * Fuzzy Matching:: What's the big fuzz? * Thwarting Email Spam:: Simple ways to avoid unsolicited commercial email. * Spam Package:: A package for filtering and processing spam. @@ -876,7 +876,6 @@ Spam Statistics Package Appendices -* XEmacs:: Requirements for installing under XEmacs. * History:: How Gnus got where it is today. * On Writing Manuals:: Why this is not a beginner's guide. * Terminology:: We use really difficult, like, words here. @@ -924,7 +923,6 @@ Gnus Reference Guide * Ranges:: A handy format for storing mucho numbers. * Group Info:: The group info format. * Extended Interactive:: Symbolic prefixes and stuff. -* Emacs/XEmacs Code:: Gnus can be run under all modern Emacsen. * Various File Formats:: Formats of files that Gnus use. Back End Interface @@ -4319,9 +4317,7 @@ names: @item nnmail-pathname-coding-system @vindex nnmail-pathname-coding-system The value of this variable should be a coding system or @code{nil}. The -default is @code{nil} in Emacs, or is the aliasee of the coding system -named @code{file-name} (a certain coding system of which an alias is -@code{file-name}) in XEmacs. +default is @code{nil} in Emacs. The @code{nnml} back end, the @code{nnrss} back end, the agent, and the cache use non-@acronym{ASCII} group names in those files and @@ -4329,17 +4325,14 @@ directories. This variable overrides the value of @code{file-name-coding-system} which specifies the coding system used when encoding and decoding those file names and directory names. -In XEmacs (with the @code{mule} feature), @code{file-name-coding-system} -is the only means to specify the coding system used to encode and decode -file names. On the other hand, Emacs uses the value of -@code{default-file-name-coding-system} if @code{file-name-coding-system} -is @code{nil} or it is bound to the value of -@code{nnmail-pathname-coding-system} which is @code{nil}. +Emacs uses the value of @code{default-file-name-coding-system} if +@code{file-name-coding-system} is @code{nil} or it is bound to the +value of @code{nnmail-pathname-coding-system} which is @code{nil}. -Normally the value of @code{default-file-name-coding-system} in Emacs or -@code{nnmail-pathname-coding-system} in XEmacs is initialized according -to the locale, so you will need to do nothing if the value is suitable -to encode and decode non-@acronym{ASCII} group names. +Normally the value of @code{default-file-name-coding-system} is +initialized according to the locale, so you will need to do nothing if +the value is suitable to encode and decode non-@acronym{ASCII} group +names. The value of this variable (or @code{default-file-name-coding-system}) does not necessarily need to be the same value that is determined by @@ -12557,11 +12550,11 @@ still a pain, though. This variable controls which information should be exposed in the User-Agent header. It can be a list of symbols or a string. Valid -symbols are @code{gnus} (show Gnus version) and @code{emacs} (show Emacs -version). In addition to the Emacs version, you can add @code{codename} -(show (S)XEmacs codename) or either @code{config} (show system -configuration) or @code{type} (show system type). If you set it to a -string, be sure to use a valid format, see RFC 2616. +symbols are @code{gnus} (show Gnus version) and @code{emacs} (show +Emacs version). In addition to the Emacs version, you can add +@code{config} (show system configuration) or @code{type} (show system +type). If you set it to a string, be sure to use a valid format, see +RFC 2616. @end table @@ -17154,8 +17147,7 @@ The directory where @code{nnrss} stores its files. The default is @vindex nnrss-file-coding-system The coding system used when reading and writing the @code{nnrss} groups data files. The default is the value of -@code{mm-universal-coding-system} (which defaults to @code{emacs-mule} -in Emacs or @code{escape-quoted} in XEmacs). +@code{mm-universal-coding-system} (which defaults to @code{emacs-mule}). @item nnrss-ignore-article-fields @vindex nnrss-ignore-article-fields @@ -21102,13 +21094,7 @@ and `gnus-score-decay-scale'." (max gnus-score-decay-constant (* (abs score) gnus-score-decay-scale))))))) - (if (and (featurep 'xemacs) - ;; XEmacs's floor can handle only the floating point - ;; number below the half of the maximum integer. - (> (abs n) (lsh -1 -2))) - (string-to-number - (car (split-string (number-to-string n) "\\."))) - (floor n)))) + (floor n))) @end lisp @vindex gnus-score-decay-scale @@ -22270,7 +22256,7 @@ to you, using @kbd{G b u} and updating the group will usually fix this. * Predicate Specifiers:: Specifying predicates. * Moderation:: What to do if you're a moderator. * Fetching a Group:: Starting Gnus just to read a group. -* Image Enhancements:: Modern versions of Emacs/XEmacs can display images. +* Image Enhancements:: Modern versions of Emacs can display images. * Fuzzy Matching:: What's the big fuzz? * Thwarting Email Spam:: Simple ways to avoid unsolicited commercial email. * Spam Package:: A package for filtering and processing spam. @@ -22613,11 +22599,9 @@ special @code{balloon-help} property set to variables should be either strings or symbols naming functions that return a string. When the mouse passes over text with this property set, a balloon window will appear and display the string. Please -refer to @ref{Tooltips, ,Tooltips, emacs, The Emacs Manual}, -(in Emacs) or the doc string of @code{balloon-help-mode} (in -XEmacs) for more information on this. (For technical reasons, the -guillemets have been approximated as @samp{<<} and @samp{>>} in this -paragraph.) +refer to @ref{Tooltips, ,Tooltips, emacs, The Emacs Manual} for more +information on this. (For technical reasons, the guillemets have been +approximated as @samp{<<} and @samp{>>} in this paragraph.) Here's an alternative recipe for the group buffer: @@ -22698,8 +22682,7 @@ these countries, that's not true. @vindex gnus-use-correct-string-widths To help fix this, you can set @code{gnus-use-correct-string-widths} to @code{t}. This makes buffer generation slower, but the results will be -prettier. The default value under XEmacs is @code{t} but @code{nil} -for Emacs. +prettier. The default value is @code{nil}. @node Window Layout @@ -22878,9 +22861,7 @@ frame will be created where picons will be shown. As you can see, instead of the normal @code{1.0} top-level spec, each additional split should have a frame parameter alist as the size spec. @xref{Frame Parameters, , Frame Parameters, elisp, The GNU Emacs Lisp -Reference Manual}. Under XEmacs, a frame property list will be -accepted, too---for instance, @code{(height 5 width 15 left -1 top 1)} -is such a plist. +Reference Manual}. The list of all possible keys for @code{gnus-buffer-configuration} can be found in its default value. @@ -23417,8 +23398,8 @@ It takes the group name as a parameter. @node Image Enhancements @section Image Enhancements -XEmacs, as well as Emacs 21@footnote{Emacs 21 on MS Windows doesn't -support images, Emacs 22 does.} and up, are able to display pictures and +Emacs 21@footnote{Emacs 21 on MS Windows doesn't +support images, Emacs 22 does.} and up are able to display pictures and stuff, so Gnus has taken advantage of that. @menu @@ -23451,13 +23432,12 @@ readers. @c @anchor{X-Face} Viewing an @code{X-Face} header either requires an Emacs that has -@samp{compface} support (which most XEmacs versions have), or that you +@samp{compface} support, or that you have suitable conversion or display programs installed. If your Emacs has image support the default action is to display the face before the @code{From} header. If there's no native @code{X-Face} support, Gnus will try to convert the @code{X-Face} header using external programs -from the @code{pbmplus} package and friends, see below. For XEmacs it's -faster if XEmacs has been compiled with @code{X-Face} support. The +from the @code{pbmplus} package and friends, see below. The default action under Emacs without image support is to fork off the @code{display} program. @@ -23494,8 +23474,7 @@ default colors are black and white. @vindex gnus-face-properties-alist Alist of image types and properties applied to Face (@pxref{Face}) and X-Face images. The default value is @code{((pbm . (:face gnus-x-face)) -(png . nil))} for Emacs or @code{((xface . (:face gnus-x-face)))} for -XEmacs. Here are examples: +(png . nil))}. Here are examples: @lisp ;; Specify the altitude of Face and X-Face images in the From header. @@ -23512,9 +23491,7 @@ XEmacs. Here are examples: @xref{Image Descriptors,,, elisp, The Emacs Lisp Reference Manual}, for the valid properties for various image types. Currently, @code{pbm} is used for X-Face images and @code{png} is used for Face -images in Emacs. Only the @code{:face} property is effective on the -@code{xface} image type in XEmacs if it is built with the -@samp{libcompface} library. +images in Emacs. @end table If you use posting styles, you can use an @code{x-face-file} entry in @@ -23586,10 +23563,6 @@ displayed Face images. @xref{X-Face}. Viewing a @code{Face} header requires an Emacs that is able to display PNG images. -@c Maybe add this: -@c (if (featurep 'xemacs) -@c (featurep 'png) -@c (image-type-available-p 'png)) Gnus provides a few convenience functions and variables to allow easier insertion of Face headers in outgoing messages. @@ -26398,8 +26371,7 @@ This variable controls whether to add timestamps to messages that are controlled by @code{gnus-verbose} and @code{gnus-verbose-backends} and are issued. The default value is @code{nil} which means never to add timestamp. If it is @code{log}, add timestamps to only the messages -that go into the @file{*Messages*} buffer (in XEmacs, it is the -@w{@file{ *Message-Log*}} buffer). If it is neither @code{nil} nor +that go into the @file{*Messages*} buffer. If it is neither @code{nil} nor @code{log}, add timestamps not only to log messages but also to the ones displayed in the echo area. @@ -26511,7 +26483,6 @@ but at the common table.@* @chapter Appendices @menu -* XEmacs:: Requirements for installing under XEmacs. * History:: How Gnus got where it is today. * On Writing Manuals:: Why this is not a beginner's guide. * Terminology:: We use really difficult, like, words here. @@ -26523,19 +26494,6 @@ but at the common table.@* @end menu -@node XEmacs -@section XEmacs -@cindex XEmacs -@cindex installing under XEmacs - -XEmacs is distributed as a collection of packages. You should install -whatever packages the Gnus XEmacs package requires. The current -requirements are @samp{gnus}, @samp{mail-lib}, @samp{xemacs-base}, -@samp{eterm}, @samp{sh-script}, @samp{net-utils}, @samp{os-utils}, -@samp{dired}, @samp{mh-e}, @samp{sieve}, @samp{ps-print}, -@samp{pgg}, @samp{mailcrypt}, @samp{ecrypto}, and @samp{sasl}. - - @node History @section History @@ -26646,8 +26604,7 @@ and news from different sources. I have added hooks for customizations everywhere I could imagine it being useful. By doing so, I'm inviting every one of you to explore and invent. -May Gnus never be complete. @kbd{C-u 100 M-x all-hail-emacs} and -@kbd{C-u 100 M-x all-hail-xemacs}. +May Gnus never be complete. @kbd{C-u 100 M-x all-hail-emacs}. @node Compatibility @@ -26800,7 +26757,6 @@ know. @node Emacsen @subsection Emacsen @cindex Emacsen -@cindex XEmacs @cindex Mule @cindex Emacs @@ -26811,15 +26767,12 @@ This version of Gnus should work on: @item Emacs 23.1 and up. -@item -XEmacs 21.4 and up. - @end itemize This Gnus version will absolutely not work on any Emacsen older than that. Not reliably, at least. Older versions of Gnus may work on older Emacs versions. Particularly, Gnus 5.10.8 should also work on Emacs -20.7 and XEmacs 21.1. +20.7. @c No-merge comment: The paragraph added in v5-10 here must not be @c synced here! @@ -27374,7 +27327,7 @@ referred. Gnus can make use of GroupLens predictions. @item -Picons (personal icons) can be displayed under XEmacs (@pxref{Picons}). +Picons (personal icons) can be displayed (@pxref{Picons}). @item A @code{trn}-like tree buffer can be displayed (@pxref{Tree Display}). @@ -27945,28 +27898,6 @@ will shadow the latest one are detected. You can then remove those shadows manually or remove them using @code{make remove-installed-shadows}. -@item -New @file{make.bat} for compiling and installing Gnus under MS Windows - -Use @file{make.bat} if you want to install Gnus under MS Windows, the -first argument to the batch-program should be the directory where -@file{xemacs.exe} respectively @file{emacs.exe} is located, if you want -to install Gnus after compiling it, give @file{make.bat} @code{/copy} as -the second parameter. - -@file{make.bat} has been rewritten from scratch, it now features -automatic recognition of XEmacs and Emacs, generates -@file{gnus-load.el}, checks if errors occur while compilation and -generation of info files and reports them at the end of the build -process. It now uses @code{makeinfo} if it is available and falls -back to @file{infohack.el} otherwise. @file{make.bat} should now -install all files which are necessary to run Gnus and be generally a -complete replacement for the @code{configure; make; make install} -cycle used under Unix systems. - -The new @file{make.bat} makes @file{make-x.bat} and @file{xemacs.mak} -superfluous, so they have been removed. - @item @file{~/News/overview/} not used. @@ -28526,7 +28457,7 @@ message, Message Manual}). The tool bars have been updated to use GNOME icons in Group, Summary and Message mode. You can also customize the tool bars: @kbd{M-x customize-apropos @key{RET} -tool-bar$} should get you started. This is a new -feature in Gnus 5.10.10. (Only for Emacs, not in XEmacs.) +feature in Gnus 5.10.10. @item The tool bar icons are now (de)activated correctly in the group buffer, see the variable @code{gnus-group-update-tool-bar}. @@ -28599,9 +28530,6 @@ The following Emacs versions are supported by No Gnus: @itemize @bullet @item Emacs 22 and up -@item XEmacs 21.4 -@item XEmacs 21.5 -@item SXEmacs @end itemize @@ -28901,7 +28829,7 @@ messages are deleted again). @item The tool bar has been updated to use GNOME icons. You can also customize the tool bars: @kbd{M-x customize-apropos @key{RET} --tool-bar$} should get you started. (Only for Emacs, not in XEmacs.) +-tool-bar$} should get you started. @c FIXME: Document this in the manual @item The tool bar icons are now (de)activated correctly @@ -28909,9 +28837,6 @@ in the group buffer, see the variable @code{gnus-group-update-tool-bar}. Its default value depends on your Emacs version. @c FIXME: Document this in the manual -@item You can change the location of XEmacs's toolbars in Gnus buffers. -See @code{gnus-use-toolbar} and @code{message-use-toolbar}. - @end itemize @item Miscellaneous changes @@ -29610,7 +29535,6 @@ and general methods of operation. * Ranges:: A handy format for storing mucho numbers. * Group Info:: The group info format. * Extended Interactive:: Symbolic prefixes and stuff. -* Emacs/XEmacs Code:: Gnus can be run under all modern Emacsen. * Various File Formats:: Formats of files that Gnus use. @end menu @@ -30952,52 +30876,6 @@ function. @end table -@node Emacs/XEmacs Code -@subsection Emacs/XEmacs Code -@cindex XEmacs -@cindex Emacsen - -While Gnus runs under Emacs, XEmacs and Mule, I decided that one of the -platforms must be the primary one. I chose Emacs. Not because I don't -like XEmacs or Mule, but because it comes first alphabetically. - -This means that Gnus will byte-compile under Emacs with nary a warning, -while XEmacs will pump out gigabytes of warnings while byte-compiling. -As I use byte-compilation warnings to help me root out trivial errors in -Gnus, that's very useful. - -I've also consistently used Emacs function interfaces, but have used -Gnusey aliases for the functions. To take an example: Emacs defines a -@code{run-at-time} function while XEmacs defines a @code{start-itimer} -function. I then define a function called @code{gnus-run-at-time} that -takes the same parameters as the Emacs @code{run-at-time}. When running -Gnus under Emacs, the former function is just an alias for the latter. -However, when running under XEmacs, the former is an alias for the -following function: - -@lisp -(defun gnus-xmas-run-at-time (time repeat function &rest args) - (start-itimer - "gnus-run-at-time" - `(lambda () - (,function ,@@args)) - time repeat)) -@end lisp - -This sort of thing has been done for bunches of functions. Gnus does -not redefine any native Emacs functions while running under XEmacs---it -does this @code{defalias} thing with Gnus equivalents instead. Cleaner -all over. - -In the cases where the XEmacs function interface was obviously cleaner, -I used it instead. For example @code{gnus-region-active-p} is an alias -for @code{region-active-p} in XEmacs, whereas in Emacs it is a function. - -Of course, I could have chosen XEmacs as my native platform and done -mapping functions the other way around. But I didn't. The performance -hit these indirections impose on Gnus under XEmacs should be slight. - - @node Various File Formats @subsection Various File Formats commit 3c494946913e164e997c5e57cba7474813039355 Author: Lars Ingebrigtsen Date: Thu Aug 15 15:04:30 2019 -0700 Mention what effect nil has as the prompt for read-event/char/etc * doc/lispref/commands.texi (Reading One Event): Mention that "" has the same effect as nil as a prompt. * src/lread.c (Fread_event, Fread_char_exclusive, Fread_char): Mention what happens when PROMPT is nil/"" in the doc string (bug#15012). diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index c0df944f9c..1fd56d0284 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -2504,12 +2504,12 @@ The returned event may come directly from the user, or from a keyboard macro. It is not decoded by the keyboard's input coding system (@pxref{Terminal I/O Encoding}). -If the optional argument @var{prompt} is non-@code{nil}, it should be a -string to display in the echo area as a prompt. Otherwise, -@code{read-event} does not display any message to indicate it is waiting -for input; instead, it prompts by echoing: it displays descriptions of -the events that led to or were read by the current command. @xref{The -Echo Area}. +If the optional argument @var{prompt} is non-@code{nil}, it should be +a string to display in the echo area as a prompt. If @var{prompt} is +@code{nil} or the string @samp{""}, @code{read-event} does not display +any message to indicate it is waiting for input; instead, it prompts +by echoing: it displays descriptions of the events that led to or were +read by the current command. @xref{The Echo Area}. If @var{inherit-input-method} is non-@code{nil}, then the current input method (if any) is employed to make it possible to enter a diff --git a/src/lread.c b/src/lread.c index eec88760d4..1bfbf5aa86 100644 --- a/src/lread.c +++ b/src/lread.c @@ -762,9 +762,13 @@ If you want to read non-character events, or ignore them, call `read-event' or `read-char-exclusive' instead. If the optional argument PROMPT is non-nil, display that as a prompt. +If PROMPT is nil or the string \"\", the key sequence/events that led +to the current command is used as the prompt. + If the optional argument INHERIT-INPUT-METHOD is non-nil and some input method is turned on in the current buffer, that input method is used for reading a character. + If the optional argument SECONDS is non-nil, it should be a number specifying the maximum number of seconds to wait for input. If no input arrives in that time, return nil. SECONDS may be a @@ -784,9 +788,13 @@ floating-point value. */) DEFUN ("read-event", Fread_event, Sread_event, 0, 3, 0, doc: /* Read an event object from the input stream. If the optional argument PROMPT is non-nil, display that as a prompt. +If PROMPT is nil or the string \"\", the key sequence/events that led +to the current command is used as the prompt. + If the optional argument INHERIT-INPUT-METHOD is non-nil and some input method is turned on in the current buffer, that input method is used for reading a character. + If the optional argument SECONDS is non-nil, it should be a number specifying the maximum number of seconds to wait for input. If no input arrives in that time, return nil. SECONDS may be a @@ -809,9 +817,13 @@ character code: it will fail the `characterp' test. Use `event-basic-type' to recover the character code with the modifiers removed. If the optional argument PROMPT is non-nil, display that as a prompt. +If PROMPT is nil or the string \"\", the key sequence/events that led +to the current command is used as the prompt. + If the optional argument INHERIT-INPUT-METHOD is non-nil and some input method is turned on in the current buffer, that input method is used for reading a character. + If the optional argument SECONDS is non-nil, it should be a number specifying the maximum number of seconds to wait for input. If no input arrives in that time, return nil. SECONDS may be a commit dabefb2ae1e3abb4eaa54c0ed356867a4fbcd306 Author: Lars Ingebrigtsen Date: Thu Aug 15 14:55:26 2019 -0700 etc/NEWS: Note that `list-processes' includes port numbers now. diff --git a/etc/NEWS b/etc/NEWS index b9e9e28db4..361668c46d 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -497,6 +497,9 @@ current and the previous or the next line, as before. * Changes in Specialized Modes and Packages in Emacs 27.1 +** The 'list-processes' command now includes port numbers in the +network connection information (in addition to the host name). + ** The 'cl' package is now officially deprecated in favor of `cl-lib`. +++ commit 96ef76e4e7df73802bf1f2a19c96a143ae365b66 Author: Paul Eggert Date: Thu Aug 15 10:51:03 2019 -0700 Fix typeof portability issue with bitfields Problem reported by Glenn Morris in: https://lists.gnu.org/r/emacs-devel/2019-08/msg00300.html * src/lisp.h (lisp_h_make_fixnum): Use typeof (+(n)) instead of typeof (n), so that it works with compilers that do not allow typeof to be applied to a bitfield. diff --git a/src/lisp.h b/src/lisp.h index 1c98925fa8..56ad99b8e3 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -401,7 +401,7 @@ typedef EMACS_INT Lisp_Word; XIL ((EMACS_INT) (((EMACS_UINT) (n) << INTTYPEBITS) + Lisp_Int0)) # if defined HAVE_STATEMENT_EXPRESSIONS && defined HAVE_TYPEOF # define lisp_h_make_fixnum(n) \ - ({ typeof (n) lisp_h_make_fixnum_n = n; \ + ({ typeof (+(n)) lisp_h_make_fixnum_n = n; \ eassert (!FIXNUM_OVERFLOW_P (lisp_h_make_fixnum_n)); \ lisp_h_make_fixnum_wrap (lisp_h_make_fixnum_n); }) # else commit af82a6248ce77f1b14f89cfee677250ff024c2c4 Author: Paul Eggert Date: Thu Aug 15 10:40:11 2019 -0700 Fix rounding errors with float timestamps When converting from float to (TICKS . HZ) form, do the conversion exactly. When converting from (TICKS . HZ) form to float, round to even precisely. This way, successfully converting a float to (TICKS . HZ) and back yields a value numerically equal to the original. * src/timefns.c (flt_radix_power_size): New constant. (flt_radix_power): New static var. (decode_float_time): Convert the exact numeric value rather than guessing TIMESPEC_HZ resolution. (s_ns_to_double): Remove; no longer needed. (frac_to_double): New function. (decode_ticks_hz): It is now the caller’s responsibility to pass a valid TICKS and HZ. All callers changed. Use frac_to_double to round (TICKS . HZ) precisely. (decode_time_components): When decoding nil, use decode_ticks_hz since it rounds precisely. (syms_of_timefns): Initialize flt_radix_power. * test/src/timefns-tests.el (float-time-precision): New test. diff --git a/src/timefns.c b/src/timefns.c index 953e246a9a..e9d1a9bf64 100644 --- a/src/timefns.c +++ b/src/timefns.c @@ -368,31 +368,56 @@ lo_time (time_t t) return make_fixnum (t & ((1 << LO_TIME_BITS) - 1)); } +/* When converting a double to a fraction TICKS / HZ, HZ is equal to + FLT_RADIX * P where 0 <= P < FLT_RADIX_POWER_SIZE. The tiniest + nonzero double uses the maximum P. */ +enum { flt_radix_power_size = DBL_MANT_DIG - DBL_MIN_EXP + 1 }; + +/* A integer vector of size flt_radix_power_size. The Pth entry + equals FLT_RADIX**P. */ +static Lisp_Object flt_radix_power; + /* Convert T into an Emacs time *RESULT, truncating toward minus infinity. Return zero if successful, an error number otherwise. */ static int decode_float_time (double t, struct lisp_time *result) { - if (!isfinite (t)) - return isnan (t) ? EINVAL : EOVERFLOW; - /* Actual hz unknown; guess TIMESPEC_HZ. */ - mpz_set_d (mpz[1], t); - mpz_set_si (mpz[0], floor ((t - trunc (t)) * TIMESPEC_HZ)); - mpz_addmul_ui (mpz[0], mpz[1], TIMESPEC_HZ); - result->ticks = make_integer_mpz (); - result->hz = timespec_hz; + Lisp_Object ticks, hz; + if (t == 0) + { + ticks = make_fixnum (0); + hz = make_fixnum (1); + } + else + { + int exponent = ilogb (t); + if (exponent == FP_ILOGBNAN) + return EINVAL; + + /* An enormous or infinite T would make SCALE < 0 which would make + HZ < 1, which the (TICKS . HZ) representation does not allow. */ + if (DBL_MANT_DIG - 1 < exponent) + return EOVERFLOW; + + /* min so we don't scale tiny numbers as if they were normalized. */ + int scale = min (DBL_MANT_DIG - 1 - exponent, flt_radix_power_size - 1); + + double scaled = scalbn (t, scale); + eassert (trunc (scaled) == scaled); + ticks = double_to_integer (scaled); + hz = AREF (flt_radix_power, scale); + if (NILP (hz)) + { + mpz_ui_pow_ui (mpz[0], FLT_RADIX, scale); + hz = make_integer_mpz (); + ASET (flt_radix_power, scale, hz); + } + } + result->ticks = ticks; + result->hz = hz; return 0; } -/* Compute S + NS/TIMESPEC_HZ as a double. - Calls to this function suffer from double-rounding; - work around some of the problem by using long double. */ -static double -s_ns_to_double (long double s, long double ns) -{ - return s + ns / TIMESPEC_HZ; -} - /* Make a 4-element timestamp (HI LO US PS) from TICKS and HZ. Drop any excess precision. */ static Lisp_Object @@ -520,69 +545,111 @@ timespec_to_lisp (struct timespec t) return Fcons (timespec_ticks (t), timespec_hz); } -/* From what should be a valid timestamp (TICKS . HZ), generate the - corresponding time values. +/* Return NUMERATOR / DENOMINATOR, rounded to the nearest double. + Arguments must be Lisp integers, and DENOMINATOR must be nonzero. */ +static double +frac_to_double (Lisp_Object numerator, Lisp_Object denominator) +{ + intmax_t intmax_numerator; + if (FASTER_TIMEFNS && EQ (denominator, make_fixnum (1)) + && integer_to_intmax (numerator, &intmax_numerator)) + return intmax_numerator; + + verify (FLT_RADIX == 2 || FLT_RADIX == 16); + enum { LOG2_FLT_RADIX = FLT_RADIX == 2 ? 1 : 4 }; + mpz_t *n = bignum_integer (&mpz[0], numerator); + mpz_t *d = bignum_integer (&mpz[1], denominator); + ptrdiff_t nbits = mpz_sizeinbase (*n, 2); + ptrdiff_t dbits = mpz_sizeinbase (*d, 2); + eassume (0 < nbits); + eassume (0 < dbits); + ptrdiff_t ndig = (nbits + LOG2_FLT_RADIX - 1) / LOG2_FLT_RADIX; + ptrdiff_t ddig = (dbits + LOG2_FLT_RADIX - 1) / LOG2_FLT_RADIX; + + /* Scale with SCALE when doing integer division. That is, compute + (N * FLT_RADIX**SCALE) / D [or, if SCALE is negative, N / (D * + FLT_RADIX**-SCALE)] as a bignum, convert the bignum to double, + then divide the double by FLT_RADIX**SCALE. */ + ptrdiff_t scale = ddig - ndig + DBL_MANT_DIG + 1; + if (scale < 0) + { + mpz_mul_2exp (mpz[1], *d, - (scale * LOG2_FLT_RADIX)); + d = &mpz[1]; + } + else + { + /* min so we don't scale tiny numbers as if they were normalized. */ + scale = min (scale, flt_radix_power_size - 1); + + mpz_mul_2exp (mpz[0], *n, scale * LOG2_FLT_RADIX); + n = &mpz[0]; + } + + mpz_t *q = &mpz[2]; + mpz_t *r = &mpz[3]; + mpz_tdiv_qr (*q, *r, *n, *d); + + /* The amount to add to the absolute value of *Q so that truncating + it to double will round correctly. */ + int incr; + + /* Round the quotient before converting it to double. + If the quotient is less than FLT_RADIX ** DBL_MANT_DIG, + round to the nearest integer; otherwise, it is less than + FLT_RADIX ** (DBL_MANT_DIG + 1) and round it to the nearest + multiple of FLT_RADIX. Break ties to even. */ + if (mpz_sizeinbase (*q, 2) < DBL_MANT_DIG * LOG2_FLT_RADIX) + { + /* Converting to double will use the whole quotient so add 1 to + its absolute value as per round-to-even; i.e., if the doubled + remainder exceeds the denominator, or exactly equals the + denominator and adding 1 would make the quotient even. */ + mpz_mul_2exp (*r, *r, 1); + int cmp = mpz_cmpabs (*r, *d); + incr = cmp > 0 || (cmp == 0 && (FASTER_TIMEFNS && FLT_RADIX == 2 + ? mpz_odd_p (*q) + : mpz_tdiv_ui (*q, FLT_RADIX) & 1)); + } + else + { + /* Converting to double will discard the quotient's low-order digit, + so add FLT_RADIX to its absolute value as per round-to-even. */ + int lo_2digits = mpz_tdiv_ui (*q, FLT_RADIX * FLT_RADIX); + eassume (0 <= lo_2digits && lo_2digits < FLT_RADIX * FLT_RADIX); + int lo_digit = lo_2digits % FLT_RADIX; + incr = ((lo_digit > FLT_RADIX / 2 + || (lo_digit == FLT_RADIX / 2 && FLT_RADIX % 2 == 0 + && ((lo_2digits / FLT_RADIX) & 1 + || mpz_sgn (*r) != 0))) + ? FLT_RADIX : 0); + } + + /* Increment the absolute value of the quotient by INCR. */ + if (!FASTER_TIMEFNS || incr != 0) + (mpz_sgn (*n) < 0 ? mpz_sub_ui : mpz_add_ui) (*q, *q, incr); + + return scalbn (mpz_get_d (*q), -scale); +} + +/* From a valid timestamp (TICKS . HZ), generate the corresponding + time values. If RESULT is not null, store into *RESULT the converted time. Otherwise, store into *DRESULT the number of seconds since the - start of the POSIX Epoch. Unsuccessful calls may or may not store - results. + start of the POSIX Epoch. - Return zero if successful, an error number if (TICKS . HZ) would not - be a valid new-format timestamp. */ + Return zero, which indicates success. */ static int decode_ticks_hz (Lisp_Object ticks, Lisp_Object hz, struct lisp_time *result, double *dresult) { - int ns; - mpz_t *q = &mpz[0]; - - if (! (INTEGERP (ticks) - && ((FIXNUMP (hz) && 0 < XFIXNUM (hz)) - || (BIGNUMP (hz) && 0 < mpz_sgn (XBIGNUM (hz)->value))))) - return EINVAL; - if (result) { result->ticks = ticks; result->hz = hz; } else - { - if (FASTER_TIMEFNS && EQ (hz, timespec_hz)) - { - if (FIXNUMP (ticks)) - { - verify (1 < TIMESPEC_HZ); - EMACS_INT s = XFIXNUM (ticks) / TIMESPEC_HZ; - ns = XFIXNUM (ticks) % TIMESPEC_HZ; - if (ns < 0) - s--, ns += TIMESPEC_HZ; - *dresult = s_ns_to_double (s, ns); - return 0; - } - ns = mpz_fdiv_q_ui (*q, XBIGNUM (ticks)->value, TIMESPEC_HZ); - } - else if (FASTER_TIMEFNS && EQ (hz, make_fixnum (1))) - { - ns = 0; - if (FIXNUMP (ticks)) - { - *dresult = XFIXNUM (ticks); - return 0; - } - q = &XBIGNUM (ticks)->value; - } - else - { - mpz_mul_ui (*q, *bignum_integer (&mpz[1], ticks), TIMESPEC_HZ); - mpz_fdiv_q (*q, *q, *bignum_integer (&mpz[1], hz)); - ns = mpz_fdiv_q_ui (*q, *q, TIMESPEC_HZ); - } - - *dresult = s_ns_to_double (mpz_get_d (*q), ns); - } - + *dresult = frac_to_double (ticks, hz); return 0; } @@ -621,7 +688,10 @@ decode_time_components (enum timeform form, return EINVAL; case TIMEFORM_TICKS_HZ: - return decode_ticks_hz (high, low, result, dresult); + if (INTEGERP (high) + && (!NILP (Fnatnump (low)) && !EQ (low, make_fixnum (0)))) + return decode_ticks_hz (high, low, result, dresult); + return EINVAL; case TIMEFORM_FLOAT: { @@ -636,17 +706,8 @@ decode_time_components (enum timeform form, } case TIMEFORM_NIL: - { - struct timespec now = current_timespec (); - if (result) - { - result->ticks = timespec_ticks (now); - result->hz = timespec_hz; - } - else - *dresult = s_ns_to_double (now.tv_sec, now.tv_nsec); - return 0; - } + return decode_ticks_hz (timespec_ticks (current_timespec ()), + timespec_hz, result, dresult); default: break; @@ -1814,6 +1875,10 @@ syms_of_timefns (void) defsubr (&Scurrent_time_string); defsubr (&Scurrent_time_zone); defsubr (&Sset_time_zone_rule); + + flt_radix_power = make_vector (flt_radix_power_size, Qnil); + staticpro (&flt_radix_power); + #ifdef NEED_ZTRILLION_INIT pdumper_do_now_and_after_load (syms_of_timefns_for_pdumper); #endif diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el index feb8fc7905..1b1032deaa 100644 --- a/test/src/timefns-tests.el +++ b/test/src/timefns-tests.el @@ -150,3 +150,21 @@ (should (time-equal-p (encode-time '(29 31 17 30 4 2019 2 t 7200 0)) '(23752 27217)))) + +(ert-deftest float-time-precision () + (should (< 0 (float-time '(1 . 10000000000)))) + (should (< (float-time '(-1 . 10000000000)) 0)) + + (let ((x 1.0)) + (while (not (zerop x)) + (dolist (multiplier '(-1.9 -1.5 -1.1 -1 1 1.1 1.5 1.9)) + (let ((xmult (* x multiplier))) + (should (= xmult (float-time (time-convert xmult t)))))) + (setq x (/ x 2)))) + + (let ((x 1.0)) + (while (ignore-errors (time-convert x t)) + (dolist (divisor '(-1.9 -1.5 -1.1 -1 1 1.1 1.5 1.9)) + (let ((xdiv (/ x divisor))) + (should (= xdiv (float-time (time-convert xdiv t)))))) + (setq x (* x 2))))) commit f6ae51c71d69b4d1a02fc8f6536f3f8cc0dc1009 Author: Michael Albinus Date: Thu Aug 15 16:40:53 2019 +0200 Give auto-revert-test02-auto-revert-deleted-file a chance on hydra * test/lisp/autorevert-tests.el (auto-revert-test02-auto-revert-deleted-file): Don't skip on hydra. diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el index 37301ffe43..c024739f6e 100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el @@ -274,7 +274,7 @@ This expects `auto-revert--messages' to be bound by :tags '(:expensive-test) ;; Repeated unpredictable failures, bug#32645. ;; Unlikely to be hydra-specific? - (skip-unless (not (getenv "EMACS_HYDRA_CI"))) +; (skip-unless (not (getenv "EMACS_HYDRA_CI"))) (let ((tmpfile (make-temp-file "auto-revert-test")) buf desc) commit 975f78ae2172d844043e9d1c83fedfdaa8f7c35e Author: Michael Albinus Date: Thu Aug 15 14:35:02 2019 +0200 Improve Tramp manual * doc/misc/tramp.texi (GVFS based methods): Explain using `ftp' and `smb' methods. diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 5d88ac111b..d48fa319fb 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -1266,6 +1266,18 @@ to include are @option{ftp}, @option{http}, @option{https} and @option{smb}. These methods are not intended to be used directly as GVFS based method. Instead, they are added here for the benefit of @ref{Archive file names}. + +If you want to use GVFS-based @option{ftp} or @option{smb} methods, +you must add them to @code{tramp-gvfs-methods}, and you must disable +the corresponding Tramp package by setting @code{tramp-ftp-method} or +@code{tramp-smb-method} to @code{nil}, respectively: + +@lisp +@group +(add-to-list 'tramp-gvfs-methods "ftp") +(customize-set-variable 'tramp-ftp-method nil) +@end group +@end lisp @end defopt commit 3548fd8a53869ce6b42c47f690660cb8eddb8aab Author: Paul Eggert Date: Thu Aug 15 02:18:06 2019 -0700 Debug out-of-range make_fixnum args With --enable-checking, make_fixnum (N) now checks that N is in fixnum range. Suggested by Pip Cet in: https://lists.gnu.org/r/emacs-devel/2019-07/msg00548.html A new function make_ufixnum (N) is for the rare cases where N is intended to be unsigned and is in the range 0..INTMASK. * configure.ac (AC_C_TYPEOF): Add. (HAVE_STATEMENT_EXPRESSIONS): Resurrect this macro. * src/fns.c (Frandom, hashfn_eq, hashfn_equal, hashfn_user_defined): * src/profiler.c (hashfn_profiler): Use make_ufixnum rather than make_fixum, since the argument is an unsigned integer in the range 0..INTMASK rather than a signed integer in the range MOST_NEGATIVE_FIXNUM..MOST_POSITIVE_FIXNUM. Typically this is for hashes. * src/lisp.h (lisp_h_make_fixnum_wrap) [USE_LSB_TAG]: Rename from lisp_h_make_fixnum. (lisp_h_make_fixnum): Redefine in terms of lisp_h_make_fixnum_wrap. Check for fixnum overflow on compilers like GCC that have statement expressions and typeof. (FIXNUM_OVERFLOW_P): Move up. (make_fixnum): Check for fixnum overflow. (make_ufixnum): New function, which checks that the arg fits into 0..INTMASK range. diff --git a/configure.ac b/configure.ac index c093d8650d..1400fcb5bc 100644 --- a/configure.ac +++ b/configure.ac @@ -5371,6 +5371,19 @@ if test "$emacs_cv_struct_alignment" = yes; then structure to an N-byte boundary.]) fi +AC_C_TYPEOF + +AC_CACHE_CHECK([for statement expressions], + [emacs_cv_statement_expressions], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([], [[return ({ int x = 5; x-x; });]])], + [emacs_cv_statement_expressions=yes], + [emacs_cv_statement_expressions=no])]) +if test "$emacs_cv_statement_expressions" = yes; then + AC_DEFINE([HAVE_STATEMENT_EXPRESSIONS], 1, + [Define to 1 if statement expressions work.]) +fi + if test "${GNU_MALLOC}" = "yes" ; then AC_DEFINE(GNU_MALLOC, 1, [Define to 1 if you want to use the GNU memory allocator.]) diff --git a/src/fns.c b/src/fns.c index acc6d46db8..920addeaf1 100644 --- a/src/fns.c +++ b/src/fns.c @@ -87,7 +87,7 @@ See Info node `(elisp)Random Numbers' for more details. */) return make_fixnum (remainder); val = get_random (); } - return make_fixnum (val); + return make_ufixnum (val); } /* Random data-structure functions. */ @@ -3994,7 +3994,7 @@ cmpfn_user_defined (Lisp_Object key1, Lisp_Object key2, static Lisp_Object hashfn_eq (Lisp_Object key, struct Lisp_Hash_Table *h) { - return make_fixnum (XHASH (key) ^ XTYPE (key)); + return make_ufixnum (XHASH (key) ^ XTYPE (key)); } /* Ignore HT and return a hash code for KEY which uses 'equal' to compare keys. @@ -4003,7 +4003,7 @@ hashfn_eq (Lisp_Object key, struct Lisp_Hash_Table *h) Lisp_Object hashfn_equal (Lisp_Object key, struct Lisp_Hash_Table *h) { - return make_fixnum (sxhash (key, 0)); + return make_ufixnum (sxhash (key, 0)); } /* Ignore HT and return a hash code for KEY which uses 'eql' to compare keys. @@ -4023,7 +4023,7 @@ hashfn_user_defined (Lisp_Object key, struct Lisp_Hash_Table *h) { Lisp_Object args[] = { h->test.user_hash_function, key }; Lisp_Object hash = hash_table_user_defined_call (ARRAYELTS (args), args, h); - return FIXNUMP (hash) ? hash : make_fixnum (sxhash (hash, 0)); + return FIXNUMP (hash) ? hash : make_ufixnum (sxhash (hash, 0)); } struct hash_table_test const diff --git a/src/lisp.h b/src/lisp.h index 0370c52fad..1c98925fa8 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -397,8 +397,16 @@ typedef EMACS_INT Lisp_Word; (eassert (CONSP (a)), XUNTAG (a, Lisp_Cons, struct Lisp_Cons)) #define lisp_h_XHASH(a) XUFIXNUM_RAW (a) #if USE_LSB_TAG -# define lisp_h_make_fixnum(n) \ +# define lisp_h_make_fixnum_wrap(n) \ XIL ((EMACS_INT) (((EMACS_UINT) (n) << INTTYPEBITS) + Lisp_Int0)) +# if defined HAVE_STATEMENT_EXPRESSIONS && defined HAVE_TYPEOF +# define lisp_h_make_fixnum(n) \ + ({ typeof (n) lisp_h_make_fixnum_n = n; \ + eassert (!FIXNUM_OVERFLOW_P (lisp_h_make_fixnum_n)); \ + lisp_h_make_fixnum_wrap (lisp_h_make_fixnum_n); }) +# else +# define lisp_h_make_fixnum(n) lisp_h_make_fixnum_wrap (n) +# endif # define lisp_h_XFIXNUM_RAW(a) (XLI (a) >> INTTYPEBITS) # define lisp_h_XTYPE(a) ((enum Lisp_Type) (XLI (a) & ~VALMASK)) #endif @@ -1125,12 +1133,18 @@ enum More_Lisp_Bits #define MOST_POSITIVE_FIXNUM (EMACS_INT_MAX >> INTTYPEBITS) #define MOST_NEGATIVE_FIXNUM (-1 - MOST_POSITIVE_FIXNUM) +/* True if the possibly-unsigned integer I doesn't fit in a fixnum. */ + +#define FIXNUM_OVERFLOW_P(i) \ + (! ((0 <= (i) || MOST_NEGATIVE_FIXNUM <= (i)) && (i) <= MOST_POSITIVE_FIXNUM)) + #if USE_LSB_TAG INLINE Lisp_Object (make_fixnum) (EMACS_INT n) { - return lisp_h_make_fixnum (n); + eassert (!FIXNUM_OVERFLOW_P (n)); + return lisp_h_make_fixnum_wrap (n); } INLINE EMACS_INT @@ -1139,6 +1153,13 @@ INLINE EMACS_INT return lisp_h_XFIXNUM_RAW (a); } +INLINE Lisp_Object +make_ufixnum (EMACS_INT n) +{ + eassert (0 <= n && n <= INTMASK); + return lisp_h_make_fixnum_wrap (n); +} + #else /* ! USE_LSB_TAG */ /* Although compiled only if ! USE_LSB_TAG, the following functions @@ -1149,6 +1170,7 @@ INLINE EMACS_INT INLINE Lisp_Object make_fixnum (EMACS_INT n) { + eassert (! FIXNUM_OVERFLOW_P (n)); EMACS_INT int0 = Lisp_Int0; if (USE_LSB_TAG) { @@ -1179,6 +1201,22 @@ XFIXNUM_RAW (Lisp_Object a) return i >> INTTYPEBITS; } +INLINE Lisp_Object +make_ufixnum (EMACS_INT n) +{ + eassert (0 <= n && n <= INTMASK); + EMACS_INT int0 = Lisp_Int0; + if (USE_LSB_TAG) + { + EMACS_UINT u = n; + n = u << INTTYPEBITS; + n += int0; + } + else + n += int0 << VALBITS; + return XIL (n); +} + #endif /* ! USE_LSB_TAG */ INLINE bool @@ -1232,11 +1270,6 @@ INLINE bool return lisp_h_EQ (x, y); } -/* True if the possibly-unsigned integer I doesn't fit in a fixnum. */ - -#define FIXNUM_OVERFLOW_P(i) \ - (! ((0 <= (i) || MOST_NEGATIVE_FIXNUM <= (i)) && (i) <= MOST_POSITIVE_FIXNUM)) - INLINE intmax_t clip_to_bounds (intmax_t lower, intmax_t num, intmax_t upper) { diff --git a/src/profiler.c b/src/profiler.c index 6b482abf33..6943905062 100644 --- a/src/profiler.c +++ b/src/profiler.c @@ -566,7 +566,7 @@ hashfn_profiler (Lisp_Object bt, struct Lisp_Hash_Table *h) } else hash = XHASH (bt); - return make_fixnum (SXHASH_REDUCE (hash)); + return make_ufixnum (SXHASH_REDUCE (hash)); } static void syms_of_profiler_for_pdumper (void); commit 6cbf73b5f9f51b5e25b855bf9f521c1ef070dd4a Author: Paul Eggert Date: Thu Aug 15 02:16:26 2019 -0700 Fix some fixnum overflow problems in ccl.c * src/ccl.c (ccl_driver, Fccl_execute, Fccl_execute_on_string): Don’t assume CCL registers fit into fixnums. diff --git a/src/ccl.c b/src/ccl.c index ff42c6f25f..9505436625 100644 --- a/src/ccl.c +++ b/src/ccl.c @@ -1291,7 +1291,9 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size : -1)); h = GET_HASH_TABLE (eop); - eop = hash_lookup (h, make_fixnum (reg[RRR]), NULL); + eop = (FIXNUM_OVERFLOW_P (reg[RRR]) + ? -1 + : hash_lookup (h, make_fixnum (reg[RRR]), NULL)); if (eop >= 0) { Lisp_Object opl; @@ -1318,7 +1320,9 @@ ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size i = CCL_DECODE_CHAR (reg[RRR], reg[rrr]); h = GET_HASH_TABLE (eop); - eop = hash_lookup (h, make_fixnum (i), NULL); + eop = (FIXNUM_OVERFLOW_P (i) + ? -1 + : hash_lookup (h, make_fixnum (i), NULL)); if (eop >= 0) { Lisp_Object opl; @@ -1990,9 +1994,13 @@ programs. */) error ("Length of vector REGISTERS is not 8"); for (i = 0; i < 8; i++) - ccl.reg[i] = (TYPE_RANGED_FIXNUMP (int, AREF (reg, i)) - ? XFIXNUM (AREF (reg, i)) - : 0); + { + intmax_t n; + ccl.reg[i] = ((INTEGERP (AREF (reg, i)) + && integer_to_intmax (AREF (reg, i), &n) + && INT_MIN <= n && n <= INT_MAX) + ? n : 0); + } ccl_driver (&ccl, NULL, NULL, 0, 0, Qnil); maybe_quit (); @@ -2000,7 +2008,7 @@ programs. */) error ("Error in CCL program at %dth code", ccl.ic); for (i = 0; i < 8; i++) - ASET (reg, i, make_fixnum (ccl.reg[i])); + ASET (reg, i, make_int (ccl.reg[i])); return Qnil; } @@ -2059,12 +2067,15 @@ usage: (ccl-execute-on-string CCL-PROGRAM STATUS STRING &optional CONTINUE UNIBY { if (NILP (AREF (status, i))) ASET (status, i, make_fixnum (0)); - if (TYPE_RANGED_FIXNUMP (int, AREF (status, i))) - ccl.reg[i] = XFIXNUM (AREF (status, i)); + intmax_t n; + if (INTEGERP (AREF (status, i)) + && integer_to_intmax (AREF (status, i), &n) + && INT_MIN <= n && n <= INT_MAX) + ccl.reg[i] = n; } - if (FIXNUMP (AREF (status, 8))) + intmax_t ic; + if (INTEGERP (AREF (status, 8)) && integer_to_intmax (AREF (status, 8), &ic)) { - EMACS_INT ic = XFIXNUM (AREF (status, 8)); if (ccl.ic < ic && ic < ccl.size) ccl.ic = ic; } @@ -2139,8 +2150,8 @@ usage: (ccl-execute-on-string CCL-PROGRAM STATUS STRING &optional CONTINUE UNIBY error ("CCL program interrupted at %dth code", ccl.ic); for (i = 0; i < 8; i++) - ASET (status, i, make_fixnum (ccl.reg[i])); - ASET (status, 8, make_fixnum (ccl.ic)); + ASET (status, i, make_int (ccl.reg[i])); + ASET (status, 8, make_int (ccl.ic)); val = make_specified_string ((const char *) outbuf, produced_chars, outp - outbuf, NILP (unibyte_p)); commit 311fcab8f805cd5cc6eacfe37e97423cd73a795b Author: Paul Eggert Date: Thu Aug 15 02:06:04 2019 -0700 Port mod-test-nanoseconds to 32-bit Emacs * test/src/emacs-module-tests.el (mod-test-nanoseconds): Don’t assume -1000000000 is a fixnum. diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el index 96a604f982..c44c386d30 100644 --- a/test/src/emacs-module-tests.el +++ b/test/src/emacs-module-tests.el @@ -368,7 +368,7 @@ Interactively, you can try hitting \\[keyboard-quit] to quit." (let ((input (car test-case)) (expected (cdr test-case))) (ert-info ((format "input: %S, expected result: %d" input expected)) - (should (eq (mod-test-nanoseconds input) expected)))))) + (should (= (mod-test-nanoseconds input) expected)))))) (ert-deftest mod-test-double () (dolist (input (list 0 1 2 -1 42 12345678901234567890 commit ec13c46bbd15a917ce9f2dd2c6d241088446d769 Author: Lars Ingebrigtsen Date: Thu Aug 15 00:16:02 2019 -0700 Include port numbers in `M-x list-processes' * lisp/simple.el (list-processes--refresh): Include the port numbers in the network connection list (bug#13604). diff --git a/lisp/simple.el b/lisp/simple.el index bec58addca..cb938bb341 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -4112,12 +4112,17 @@ Also, delete any process that is exited or signaled." "datagram" "network") (if (plist-get contact :server) - (format "server on %s" - (or - (plist-get contact :host) - (plist-get contact :local))) - (format "connection to %s" - (plist-get contact :host)))) + (format + "server on %s" + (if (plist-get contact :host) + (format "%s:%s" + (plist-get contact :host) + (plist-get + contact :service)) + (plist-get contact :local))) + (format "connection to %s:%s" + (plist-get contact :host) + (plist-get contact :service)))) (format "(serial port %s%s)" (or (plist-get contact :port) "?") (let ((speed (plist-get contact :speed))) commit 64538328da7c37482e8cb5c0f15c2eae1e8f16c5 Author: Lars Ingebrigtsen Date: Thu Aug 15 00:05:33 2019 -0700 Add some cl- concept index entries * doc/misc/cl.texi (Argument Lists): Add a couple of concept index entried (bug#13606). diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi index afe8f01f59..246f86bfd1 100644 --- a/doc/misc/cl.texi +++ b/doc/misc/cl.texi @@ -323,6 +323,7 @@ arranges for the processing of keyword arguments, default values, etc., to be done at compile-time whenever possible. @end defmac +@cindex &allow-other-keys @defmac cl-defmacro name arglist body@dots{} This is identical to the regular @code{defmacro} form, except that @var{arglist} is allowed to be a full Common Lisp @@ -438,6 +439,7 @@ function call, like this: (bar :a 10 'baz 42) @end example +@cindex &allow-other-keys Ordinarily, it is an error to pass an unrecognized keyword to a function, e.g., @code{(foo 1 2 :c 3 :goober 4)}. You can ask Lisp to ignore unrecognized keywords, either by adding the commit e67503dc48ace83df0a521c40f4395dae96f0d53 Author: Lars Ingebrigtsen Date: Wed Aug 14 22:43:24 2019 -0700 Clarify the doc string of complete-with-action * lisp/minibuffer.el (complete-with-action): Doc string clarification (bug#13993). diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 52455ccc40..3fa637f2ac 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -154,14 +154,20 @@ Like CL's `some'." (or res (if firsterror (signal (car firsterror) (cdr firsterror)))))) -(defun complete-with-action (action table string pred) - "Perform completion ACTION. -STRING is the string to complete. -TABLE is the completion table. -PRED is a completion predicate. -ACTION can be one of nil, t or `lambda'." +(defun complete-with-action (action collection string predicate) + "Perform completion according to ACTION. +STRING, COLLECTION and PREDICATE are used as in `try-completion'. + +If COLLECTION is a function, it will be called directly to +perform completion, no matter what ACTION is. + +If ACTION is `metadata' or a list where the first element is +`boundaries', return nil. If ACTION is nil, this function works +like `try-completion'; if it's t, this function works like +`all-completion'; and any other values makes it work like +`test-completion'." (cond - ((functionp table) (funcall table string pred action)) + ((functionp collection) (funcall collection string predicate action)) ((eq (car-safe action) 'boundaries) nil) ((eq action 'metadata) nil) (t @@ -170,7 +176,7 @@ ACTION can be one of nil, t or `lambda'." ((null action) 'try-completion) ((eq action t) 'all-completions) (t 'test-completion)) - string table pred)))) + string collection predicate)))) (defun completion-table-dynamic (fun &optional switch-buffer) "Use function FUN as a dynamic completion table. commit 3580950a3fabe66cd7ece8dbe179e69c86aeceea Author: Lars Ingebrigtsen Date: Wed Aug 14 22:26:13 2019 -0700 Clean up Gnus manual reference to XEmacs variables * doc/misc/gnus.texi (XVarious): Remove section about XEmacs variables that have been removed. diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index 32d98abd7e..81e3c1dda5 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -849,7 +849,6 @@ Image Enhancements meant to be shown. * Picons:: How to display pictures of what you're reading. * Gravatars:: Display the avatar of people you read. -* XVarious:: Other XEmacsy Gnusey variables. Thwarting Email Spam @@ -23428,7 +23427,6 @@ stuff, so Gnus has taken advantage of that. * Smileys:: Show all those happy faces the way they were meant to be shown. * Picons:: How to display pictures of what you're reading. * Gravatars:: Display the avatar of people you read. -* XVarious:: Other XEmacsy Gnusey variables. @end menu @@ -23816,23 +23814,6 @@ If you want to see them in the Cc and To fields, set: @end lisp -@node XVarious -@subsection Various XEmacs Variables - -@table @code -@item gnus-xmas-glyph-directory -@vindex gnus-xmas-glyph-directory -This is where Gnus will look for pictures. Gnus will normally -auto-detect this directory, but you may set it manually if you have an -unusual directory structure. - -@item gnus-xmas-modeline-glyph -@vindex gnus-xmas-modeline-glyph -A glyph displayed in all Gnus mode lines. It is a tiny gnu head by -default. - -@end table - @subsubsection Toolbar @table @code commit 9754486c8783dfb9aeb62d14b8f9dabc0e6a29ab Author: Lars Ingebrigtsen Date: Wed Aug 14 22:07:10 2019 -0700 Minor Scroll Bars clarification * doc/emacs/frames.texi (Scroll Bars): Clarify what we mean by "customize" here (bug#14321). diff --git a/doc/emacs/frames.texi b/doc/emacs/frames.texi index 55eb18f8b6..367ac43a0a 100644 --- a/doc/emacs/frames.texi +++ b/doc/emacs/frames.texi @@ -989,13 +989,14 @@ frame, use the command @kbd{M-x toggle-scroll-bar}. @vindex scroll-bar-mode To control the use of vertical scroll bars at startup, customize the -variable @code{scroll-bar-mode}. Its value should be either -@code{right} (put scroll bars on the right side of windows), @code{left} -(put them on the left), or @code{nil} (disable vertical scroll bars). -By default, Emacs puts scroll bars on the right if it was compiled with -GTK+ support on the X Window System, and on MS-Windows or macOS; Emacs -puts scroll bars on the left if compiled on the X Window System without -GTK+ support (following the old convention for X applications). +variable @code{scroll-bar-mode} (@pxref{Customization}). Its value +should be either @code{right} (put scroll bars on the right side of +windows), @code{left} (put them on the left), or @code{nil} (disable +vertical scroll bars). By default, Emacs puts scroll bars on the +right if it was compiled with GTK+ support on the X Window System, and +on MS-Windows or macOS; Emacs puts scroll bars on the left if compiled +on the X Window System without GTK+ support (following the old +convention for X applications). @vindex scroll-bar-width @cindex width of the vertical scroll bar commit a5e7c6c617bb4d33e5fbd19b81db90f039fd3060 Author: Lars Ingebrigtsen Date: Wed Aug 14 20:22:36 2019 -0700 Arrange custom-face-attributes closer to how heavy they are * lisp/cus-face.el (custom-face-attributes): Arrange the weights more in order of how heavy they are (bug#15526). diff --git a/lisp/cus-face.el b/lisp/cus-face.el index 0ee6a8dcc8..d73bce42c3 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -84,22 +84,22 @@ (choice :tag "Weight" :help-echo "Font weight." :value normal ; default - (const :tag "black" ultra-bold) - (const :tag "bold" bold) - (const :tag "book" semi-light) - (const :tag "demibold" semi-bold) + (const :tag "ultralight" ultra-light) (const :tag "extralight" extra-light) - (const :tag "extrabold" extra-bold) - (const :tag "heavy" extra-bold) (const :tag "light" light) - (const :tag "medium" normal) + (const :tag "thin" thin) + (const :tag "semilight" semi-light) + (const :tag "book" semi-light) (const :tag "normal" normal) (const :tag "regular" normal) + (const :tag "medium" normal) (const :tag "semibold" semi-bold) - (const :tag "semilight" semi-light) - (const :tag "ultralight" ultra-light) + (const :tag "demibold" semi-bold) + (const :tag "bold" bold) + (const :tag "extrabold" extra-bold) + (const :tag "heavy" extra-bold) (const :tag "ultrabold" ultra-bold) - (const :tag "thin" thin))) + (const :tag "black" ultra-bold))) (:slant (choice :tag "Slant" commit 65606077447f052f1276f206199cda195c39c26a Author: Lars Ingebrigtsen Date: Wed Aug 14 20:14:33 2019 -0700 Use gnus-summary-button-forward in gnus-summary-mode-map * lisp/gnus/gnus-sum.el (gnus-summary-mode-map): Use `gnus-summary-button-forward' instead of the obsolete `gnus-summary-widget-forward'. diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 73478f4cbd..b8f96158e6 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -1983,7 +1983,7 @@ increase the score of each group you read." "a" gnus-summary-post-news "x" gnus-summary-limit-to-unread "s" gnus-summary-isearch-article - "\t" gnus-summary-widget-forward + "\t" gnus-summary-button-forward [backtab] gnus-summary-widget-backward "w" gnus-summary-browse-url "t" gnus-summary-toggle-header @@ -2150,7 +2150,7 @@ increase the score of each group you read." "W" gnus-warp-to-article "g" gnus-summary-show-article "s" gnus-summary-isearch-article - "\t" gnus-summary-widget-forward + "\t" gnus-summary-button-forward [backtab] gnus-summary-widget-backward "w" gnus-summary-browse-url "P" gnus-summary-print-article commit 2098e8afaf1c5235ba38c0156f680b8e435d9fdd Author: Paul Eggert Date: Wed Aug 14 18:24:02 2019 -0700 Remove INT_ADD_WRAPV bug workarounds * src/alloc.c (free_cons): * src/casefiddle.c (do_casify_multibyte_string): * src/editfns.c (styled_format): * src/image.c (png_load_body): Remove recent workarounds for INT_ADD_WRAPV bugs since the bugs have been fixed (Bug#37006). diff --git a/src/alloc.c b/src/alloc.c index 0548a09cb8..bb8e97f873 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -2543,10 +2543,7 @@ free_cons (struct Lisp_Cons *ptr) ptr->u.s.u.chain = cons_free_list; ptr->u.s.car = dead_object (); cons_free_list = ptr; - /* Use a temporary signed variable, since otherwise INT_ADD_WRAPV - might incorrectly return non-zero. */ - int incr = sizeof *ptr; - if (INT_ADD_WRAPV (consing_until_gc, incr, &consing_until_gc)) + if (INT_ADD_WRAPV (consing_until_gc, sizeof *ptr, &consing_until_gc)) consing_until_gc = INTMAX_MAX; gcstat.total_free_conses++; } diff --git a/src/casefiddle.c b/src/casefiddle.c index 741973e40a..ee292dda9b 100644 --- a/src/casefiddle.c +++ b/src/casefiddle.c @@ -265,11 +265,8 @@ do_casify_multibyte_string (struct casing_context *ctx, Lisp_Object obj) ptrdiff_t size = SCHARS (obj), n; USE_SAFE_ALLOCA; - /* Use a temporary signed variable, since otherwise INT_ADD_WRAPV - might incorrectly return non-zero. */ - ptrdiff_t casing_str_buf_size = sizeof (struct casing_str_buf); if (INT_MULTIPLY_WRAPV (size, MAX_MULTIBYTE_LENGTH, &n) - || INT_ADD_WRAPV (n, casing_str_buf_size, &n)) + || INT_ADD_WRAPV (n, sizeof (struct casing_str_buf), &n)) n = PTRDIFF_MAX; unsigned char *dst = SAFE_ALLOCA (n); unsigned char *dst_end = dst + n; diff --git a/src/editfns.c b/src/editfns.c index 19bbfdcd47..1b33f39711 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -3158,14 +3158,12 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) /* Upper bound on number of format specs. Each uses at least 2 chars. */ ptrdiff_t nspec_bound = SCHARS (args[0]) >> 1; - /* Use a temporary signed variable, since otherwise INT_ADD_WRAPV - might incorrectly return non-zero. */ - ptrdiff_t info_size = sizeof *info, alloca_size; - if (INT_MULTIPLY_WRAPV (nspec_bound, info_size, &info_size) + /* Allocate the info and discarded tables. */ + ptrdiff_t info_size, alloca_size; + if (INT_MULTIPLY_WRAPV (nspec_bound, sizeof *info, &info_size) || INT_ADD_WRAPV (formatlen, info_size, &alloca_size) || SIZE_MAX < alloca_size) memory_full (SIZE_MAX); - /* Allocate the info and discarded tables. */ info = SAFE_ALLOCA (alloca_size); /* discarded[I] is 1 if byte I of the format string was not copied into the output. diff --git a/src/image.c b/src/image.c index b37851f096..81d8cb4e2b 100644 --- a/src/image.c +++ b/src/image.c @@ -6463,6 +6463,7 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c) png_uint_32 row_bytes; bool transparent_p; struct png_memory_storage tbr; /* Data to be read */ + ptrdiff_t nbytes; Emacs_Pix_Container ximg, mask_img = NULL; /* Find out what file to load. */ @@ -6658,13 +6659,10 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c) /* Number of bytes needed for one row of the image. */ row_bytes = png_get_rowbytes (png_ptr, info_ptr); - /* Use a temporary signed variable, since otherwise - INT_MULTIPLY_WRAPV might incorrectly return non-zero. */ - ptrdiff_t nbytes = sizeof *pixels; - if (INT_MULTIPLY_WRAPV (row_bytes, nbytes, &nbytes) + /* Allocate memory for the image. */ + if (INT_MULTIPLY_WRAPV (row_bytes, sizeof *pixels, &nbytes) || INT_MULTIPLY_WRAPV (nbytes, height, &nbytes)) memory_full (SIZE_MAX); - /* Allocate memory for the image. */ c->pixels = pixels = xmalloc (nbytes); c->rows = rows = xmalloc (height * sizeof *rows); for (i = 0; i < height; ++i) commit b898528fdc69c9ac58895f8be81163dc304bd59b Author: Lars Ingebrigtsen Date: Wed Aug 14 18:15:22 2019 -0700 Add C-b/f/p/n keystrokes in `M-x snake' * lisp/play/snake.el (snake-mode-map): Add the C-b/f/p/n in addition to the cursor keys (bug#16720). diff --git a/lisp/play/snake.el b/lisp/play/snake.el index 7c19733f3d..d0f9457906 100644 --- a/lisp/play/snake.el +++ b/lisp/play/snake.el @@ -179,8 +179,13 @@ and then start moving it leftwards.") (define-key map [left] 'snake-move-left) (define-key map [right] 'snake-move-right) - (define-key map [up] 'snake-move-up) + (define-key map [up] 'snake-move-up) (define-key map [down] 'snake-move-down) + + (define-key map "\C-b" 'snake-move-left) + (define-key map "\C-f" 'snake-move-right) + (define-key map "\C-p" 'snake-move-up) + (define-key map "\C-n" 'snake-move-down) map)) (defvar snake-null-map commit aa1411b20fba73ca6fde90fc9ce62cc8a854bf20 Author: Paul Eggert Date: Wed Aug 14 18:13:27 2019 -0700 Update from Gnulib This incorporates: 2019-08-14 intprops: pacify picky GCC 2019-08-14 intprops: support unsigned *_WRAPV results 2019-08-12 verify: improve diagnostic quality in recent GCC * lib/intprops.h, lib/verify.h: Copy from Gnulib. diff --git a/lib/intprops.h b/lib/intprops.h index 1a44ae5565..d1785ac6f1 100644 --- a/lib/intprops.h +++ b/lib/intprops.h @@ -111,8 +111,8 @@ Subtract 1 for the sign bit if T is signed, and then add 1 more for a minus sign if needed. - Because _GL_SIGNED_TYPE_OR_EXPR sometimes returns 0 when its argument is - signed, this macro may overestimate the true bound by one byte when + Because _GL_SIGNED_TYPE_OR_EXPR sometimes returns 1 when its argument is + unsigned, this macro may overestimate the true bound by one byte when applied to unsigned types of size 2, 4, 16, ... bytes. */ #define INT_STRLEN_BOUND(t) \ (INT_BITS_STRLEN_BOUND (TYPE_WIDTH (t) - _GL_SIGNED_TYPE_OR_EXPR (t)) \ @@ -281,7 +281,9 @@ The INT__OVERFLOW macros return 1 if the corresponding C operators might not yield numerically correct answers due to arithmetic overflow. - The INT__WRAPV macros also store the low-order bits of the answer. + The INT__WRAPV macros compute the low-order bits of the sum, + difference, and product of two C integers, and return 1 if these + low-order bits are not numerically correct. These macros work correctly on all known practical hosts, and do not rely on undefined behavior due to signed arithmetic overflow. @@ -309,9 +311,12 @@ arguments should not have side effects. The WRAPV macros are not constant expressions. They support only - +, binary -, and *. The result type must be signed. + +, binary -, and *. The result type must be either signed, or an + unsigned type that is 'unsigned int' or wider. Because the WRAPV + macros convert the result, the report overflow in different + circumstances than the OVERFLOW macros do. - These macros are tuned for their last argument being a constant. + These macros are tuned for their last input argument being a constant. Return 1 if the integer expressions A * B, A - B, -A, A * B, A / B, A % B, and A << B would overflow, respectively. */ @@ -348,11 +353,21 @@ /* Store the low-order bits of A + B, A - B, A * B, respectively, into *R. Return 1 if the result overflows. See above for restrictions. */ #define INT_ADD_WRAPV(a, b, r) \ - _GL_INT_OP_WRAPV (a, b, r, +, __builtin_add_overflow, INT_ADD_OVERFLOW) + _GL_INT_OP_WRAPV (a, b, r, +, __builtin_add_overflow, \ + _GL_INT_ADD_RANGE_OVERFLOW) #define INT_SUBTRACT_WRAPV(a, b, r) \ - _GL_INT_OP_WRAPV (a, b, r, -, __builtin_sub_overflow, INT_SUBTRACT_OVERFLOW) + _GL_INT_OP_WRAPV (a, b, r, -, __builtin_sub_overflow, \ + _GL_INT_SUBTRACT_RANGE_OVERFLOW) #define INT_MULTIPLY_WRAPV(a, b, r) \ - _GL_INT_OP_WRAPV (a, b, r, *, __builtin_mul_overflow, INT_MULTIPLY_OVERFLOW) + _GL_INT_OP_WRAPV (a, b, r, *, _GL_BUILTIN_MUL_OVERFLOW, \ + _GL_INT_MULTIPLY_RANGE_OVERFLOW) + +/* Like __builtin_mul_overflow, but work around GCC bug 91450. */ +#define _GL_BUILTIN_MUL_OVERFLOW(a, b, r) \ + ((!_GL_SIGNED_TYPE_OR_EXPR (*(r)) && EXPR_SIGNED (a) && EXPR_SIGNED (b) \ + && _GL_INT_MULTIPLY_RANGE_OVERFLOW (a, b, 0, (__typeof__ (*(r))) -1)) \ + ? ((void) __builtin_mul_overflow (a, b, r), 1) \ + : __builtin_mul_overflow (a, b, r)) /* Nonzero if this compiler has GCC bug 68193 or Clang bug 25390. See: https://gcc.gnu.org/bugzilla/show_bug.cgi?id=68193 @@ -379,41 +394,79 @@ signed char: \ _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ signed char, SCHAR_MIN, SCHAR_MAX), \ + unsigned char: \ + _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ + unsigned char, 0, UCHAR_MAX), \ short int: \ _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ short int, SHRT_MIN, SHRT_MAX), \ + unsigned short int: \ + _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ + unsigned short int, 0, USHRT_MAX), \ int: \ _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ int, INT_MIN, INT_MAX), \ + unsigned int: \ + _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ + unsigned int, 0, UINT_MAX), \ long int: \ _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long int, \ long int, LONG_MIN, LONG_MAX), \ + unsigned long int: \ + _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long int, \ + unsigned long int, 0, ULONG_MAX), \ long long int: \ _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long long int, \ - long long int, LLONG_MIN, LLONG_MAX))) + long long int, LLONG_MIN, LLONG_MAX), + unsigned long long int: \ + _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long long int, \ + unsigned long long int, ULLONG_MIN, ULLONG_MAX))) #else +/* This fallback implementation uses _GL_SIGNED_TYPE_OR_EXPR, and so + may guess wrong on some non-GNU pre-C11 compilers when the type of + *R is unsigned char or unsigned short. This is why the + documentation for INT_ADD_WRAPV says that the result type, if + unsigned, should be unsigned int or wider. */ # define _GL_INT_OP_WRAPV(a, b, r, op, builtin, overflow) \ (sizeof *(r) == sizeof (signed char) \ - ? _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ - signed char, SCHAR_MIN, SCHAR_MAX) \ + ? (_GL_SIGNED_TYPE_OR_EXPR (*(r)) \ + ? _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ + signed char, SCHAR_MIN, SCHAR_MAX) \ + : _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ + unsigned char, 0, UCHAR_MAX)) \ : sizeof *(r) == sizeof (short int) \ - ? _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ - short int, SHRT_MIN, SHRT_MAX) \ + ? (_GL_SIGNED_TYPE_OR_EXPR (*(r)) \ + ? _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ + short int, SHRT_MIN, SHRT_MAX) \ + : _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ + unsigned short int, 0, USHRT_MAX)) \ : sizeof *(r) == sizeof (int) \ - ? _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ - int, INT_MIN, INT_MAX) \ + ? (EXPR_SIGNED (*(r)) \ + ? _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ + int, INT_MIN, INT_MAX) \ + : _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ + unsigned int, 0, UINT_MAX)) \ : _GL_INT_OP_WRAPV_LONGISH(a, b, r, op, overflow)) # ifdef LLONG_MAX # define _GL_INT_OP_WRAPV_LONGISH(a, b, r, op, overflow) \ (sizeof *(r) == sizeof (long int) \ - ? _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long int, \ - long int, LONG_MIN, LONG_MAX) \ - : _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long long int, \ - long long int, LLONG_MIN, LLONG_MAX)) + ? (EXPR_SIGNED (*(r)) \ + ? _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long int, \ + long int, LONG_MIN, LONG_MAX) \ + : _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long int, \ + unsigned long int, 0, ULONG_MAX)) \ + : (EXPR_SIGNED (*(r)) \ + ? _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long long int, \ + long long int, LLONG_MIN, LLONG_MAX) \ + : _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long long int, \ + unsigned long long int, 0, ULLONG_MAX))) # else # define _GL_INT_OP_WRAPV_LONGISH(a, b, r, op, overflow) \ - _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long int, \ - long int, LONG_MIN, LONG_MAX) + (EXPR_SIGNED (*(r)) \ + ? _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long int, \ + long int, LONG_MIN, LONG_MAX) \ + : _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long int, \ + unsigned long int, 0, ULONG_MAX)) # endif #endif @@ -422,13 +475,7 @@ overflow problems. *R's type is T, with extrema TMIN and TMAX. T must be a signed integer type. Return 1 if the result overflows. */ #define _GL_INT_OP_CALC(a, b, r, op, overflow, ut, t, tmin, tmax) \ - (sizeof ((a) op (b)) < sizeof (t) \ - ? _GL_INT_OP_CALC1 ((t) (a), (t) (b), r, op, overflow, ut, t, tmin, tmax) \ - : _GL_INT_OP_CALC1 (a, b, r, op, overflow, ut, t, tmin, tmax)) -#define _GL_INT_OP_CALC1(a, b, r, op, overflow, ut, t, tmin, tmax) \ - ((overflow (a, b) \ - || (EXPR_SIGNED ((a) op (b)) && ((a) op (b)) < (tmin)) \ - || (tmax) < ((a) op (b))) \ + (overflow (a, b, tmin, tmax) \ ? (*(r) = _GL_INT_OP_WRAPV_VIA_UNSIGNED (a, b, op, ut, t), 1) \ : (*(r) = _GL_INT_OP_WRAPV_VIA_UNSIGNED (a, b, op, ut, t), 0)) @@ -452,4 +499,57 @@ #define _GL_INT_OP_WRAPV_VIA_UNSIGNED(a, b, op, ut, t) \ ((t) ((ut) (a) op (ut) (b))) +/* Return true if the numeric values A + B, A - B, A * B fall outside + the range TMIN..TMAX. Arguments should be integer expressions + without side effects. TMIN should be signed and nonpositive. + TMAX should be positive, and should be signed unless TMIN is zero. */ +#define _GL_INT_ADD_RANGE_OVERFLOW(a, b, tmin, tmax) \ + ((b) < 0 \ + ? (((tmin) \ + ? ((EXPR_SIGNED (_GL_INT_CONVERT (a, (tmin) - (b))) || (b) < (tmin)) \ + && (a) < (tmin) - (b)) \ + : (a) <= -1 - (b)) \ + || ((EXPR_SIGNED (a) ? 0 <= (a) : (tmax) < (a)) && (tmax) < (a) + (b))) \ + : (a) < 0 \ + ? (((tmin) \ + ? ((EXPR_SIGNED (_GL_INT_CONVERT (b, (tmin) - (a))) || (a) < (tmin)) \ + && (b) < (tmin) - (a)) \ + : (b) <= -1 - (a)) \ + || ((EXPR_SIGNED (_GL_INT_CONVERT (a, b)) || (tmax) < (b)) \ + && (tmax) < (a) + (b))) \ + : (tmax) < (b) || (tmax) - (b) < (a)) +#define _GL_INT_SUBTRACT_RANGE_OVERFLOW(a, b, tmin, tmax) \ + (((a) < 0) == ((b) < 0) \ + ? ((a) < (b) \ + ? !(tmin) || -1 - (tmin) < (b) - (a) - 1 \ + : (tmax) < (a) - (b)) \ + : (a) < 0 \ + ? ((!EXPR_SIGNED (_GL_INT_CONVERT ((a) - (tmin), b)) && (a) - (tmin) < 0) \ + || (a) - (tmin) < (b)) \ + : ((! (EXPR_SIGNED (_GL_INT_CONVERT (tmax, b)) \ + && EXPR_SIGNED (_GL_INT_CONVERT ((tmax) + (b), a))) \ + && (tmax) <= -1 - (b)) \ + || (tmax) + (b) < (a))) +#define _GL_INT_MULTIPLY_RANGE_OVERFLOW(a, b, tmin, tmax) \ + ((b) < 0 \ + ? ((a) < 0 \ + ? (EXPR_SIGNED (_GL_INT_CONVERT (tmax, b)) \ + ? (a) < (tmax) / (b) \ + : ((INT_NEGATE_OVERFLOW (b) \ + ? _GL_INT_CONVERT (b, tmax) >> (TYPE_WIDTH (b) - 1) \ + : (tmax) / -(b)) \ + <= -1 - (a))) \ + : INT_NEGATE_OVERFLOW (_GL_INT_CONVERT (b, tmin)) && (b) == -1 \ + ? (EXPR_SIGNED (a) \ + ? 0 < (a) + (tmin) \ + : 0 < (a) && -1 - (tmin) < (a) - 1) \ + : (tmin) / (b) < (a)) \ + : (b) == 0 \ + ? 0 \ + : ((a) < 0 \ + ? (INT_NEGATE_OVERFLOW (_GL_INT_CONVERT (a, tmin)) && (a) == -1 \ + ? (EXPR_SIGNED (b) ? 0 < (b) + (tmin) : -1 - (tmin) < (b) - 1) \ + : (tmin) / (a) < (b)) \ + : (tmax) / (b) < (a))) + #endif /* _GL_INTPROPS_H */ diff --git a/lib/verify.h b/lib/verify.h index 9b8e1ed20f..afdc1ad81f 100644 --- a/lib/verify.h +++ b/lib/verify.h @@ -175,9 +175,11 @@ #define _GL_GENSYM(prefix) _GL_CONCAT (prefix, _GL_COUNTER) /* Verify requirement R at compile-time, as an integer constant expression - that returns 1. If R is false, fail at compile-time. */ + that returns 1. If R is false, fail at compile-time, preferably + with a diagnostic that includes the string-literal DIAGNOSTIC. */ -#define _GL_VERIFY_TRUE(R) (!!sizeof (_GL_VERIFY_TYPE (R))) +#define _GL_VERIFY_TRUE(R, DIAGNOSTIC) \ + (!!sizeof (_GL_VERIFY_TYPE (R, DIAGNOSTIC))) #ifdef __cplusplus # if !GNULIB_defined_struct__gl_verify_type @@ -187,15 +189,16 @@ template }; # define GNULIB_defined_struct__gl_verify_type 1 # endif -# define _GL_VERIFY_TYPE(R) _gl_verify_type<(R) ? 1 : -1> -#elif defined _GL_HAVE__STATIC_ASSERT1 -# define _GL_VERIFY_TYPE(R) \ +# define _GL_VERIFY_TYPE(R, DIAGNOSTIC) \ + _gl_verify_type<(R) ? 1 : -1> +#elif defined _GL_HAVE__STATIC_ASSERT +# define _GL_VERIFY_TYPE(R, DIAGNOSTIC) \ struct { \ - _Static_assert (R); \ + _Static_assert (R, DIAGNOSTIC); \ int _gl_dummy; \ } #else -# define _GL_VERIFY_TYPE(R) \ +# define _GL_VERIFY_TYPE(R, DIAGNOSTIC) \ struct { unsigned int _gl_verify_error_if_negative: (R) ? 1 : -1; } #endif @@ -214,7 +217,7 @@ template #else # define _GL_VERIFY(R, DIAGNOSTIC, ...) \ extern int (*_GL_GENSYM (_gl_verify_function) (void)) \ - [_GL_VERIFY_TRUE (R)] + [_GL_VERIFY_TRUE (R, DIAGNOSTIC)] #endif /* _GL_STATIC_ASSERT_H is defined if this code is copied into assert.h. */ @@ -242,17 +245,19 @@ template /* Verify requirement R at compile-time. Return the value of the expression E. */ -#define verify_expr(R, E) (_GL_VERIFY_TRUE (R) ? (E) : (E)) +#define verify_expr(R, E) \ + (_GL_VERIFY_TRUE (R, "verify_expr (" #R ", " #E ")") ? (E) : (E)) /* Verify requirement R at compile-time, as a declaration without a trailing ';'. verify (R) acts like static_assert (R) except that - it is portable to C11/C++14 and earlier, and its name is shorter - and may be more convenient. */ + it is portable to C11/C++14 and earlier, it can issue better + diagnostics, and its name is shorter and may be more convenient. */ -#ifdef _GL_HAVE__STATIC_ASSERT1 -# define verify(R) _Static_assert (R) -#else +#ifdef __PGI +/* PGI barfs if R is long. */ # define verify(R) _GL_VERIFY (R, "verify (...)", -) +#else +# define verify(R) _GL_VERIFY (R, "verify (" #R ")", -) #endif #ifndef __has_builtin commit 370f07046b13035948655d450ed1b58d20a0cdd4 Author: Lars Ingebrigtsen Date: Wed Aug 14 18:03:41 2019 -0700 Add cl-def* forms to bovine/el.el * lisp/cedet/semantic/bovine/el.el (lambda): Add the cl-def* variations to allow semantic to find the definitions (bug#17005). diff --git a/lisp/cedet/semantic/bovine/el.el b/lisp/cedet/semantic/bovine/el.el index d46b73ff30..ba8307d2a4 100644 --- a/lisp/cedet/semantic/bovine/el.el +++ b/lisp/cedet/semantic/bovine/el.el @@ -248,6 +248,10 @@ Return a bovination list to use." defun* defsubst defmacro + cl-defun + cl-defun* + cl-defsubst + cl-defmacro define-overload ;; @todo - remove after cleaning up semantic. define-overloadable-function ) commit bfb83e643f447f9f1ae55852b682ce5e78880185 Author: Lars Ingebrigtsen Date: Wed Aug 14 17:59:13 2019 -0700 Don't alter function name face height in manoj-dark theme * etc/themes/manoj-dark-theme.el (manoj-dark): Don't alter the height of function name faces, because this makes many tabulated modes not longer line up (bug#17042). diff --git a/etc/themes/manoj-dark-theme.el b/etc/themes/manoj-dark-theme.el index b6bf9bff1e..20e04cb754 100644 --- a/etc/themes/manoj-dark-theme.el +++ b/etc/themes/manoj-dark-theme.el @@ -83,7 +83,7 @@ jarring angry fruit salad look to reduce eye fatigue.") '(font-lock-regexp-grouping-construct ((t (:bold t :weight bold)))) '(font-lock-variable-name-face ((t (:foreground "Aquamarine")))) '(font-lock-function-name-face ((t (:foreground "mediumspringgreen" - :weight bold :height 1.1)))) + :weight bold)))) '(font-lock-string-face ((t (:foreground "RosyBrown1")))) '(font-lock-comment-face ((t (:italic t :slant oblique :foreground "chocolate1")))) '(font-lock-comment-delimiter-face ((t (:foreground "Salmon")))) commit d54eb7347f8d53741337884c45dd96a72d701893 Author: Lars Ingebrigtsen Date: Wed Aug 14 17:16:37 2019 -0700 Respect the BUFFER parameter in `fill-flowed' * lisp/mail/flow-fill.el (fill-flowed): `current-buffer' is always non-nil, so respect the BUFFER parameter. Also add a doc string. diff --git a/lisp/mail/flow-fill.el b/lisp/mail/flow-fill.el index ed6a2df87d..948a7d799f 100644 --- a/lisp/mail/flow-fill.el +++ b/lisp/mail/flow-fill.el @@ -114,7 +114,12 @@ RFC 2646 suggests 66 characters for readability." ;;;###autoload (defun fill-flowed (&optional buffer delete-space) - (with-current-buffer (or (current-buffer) buffer) + "Apply RFC2646 decoding to BUFFER. +If BUFFER is nil, default to the current buffer. + +If DELETE-SPACE, delete RFC2646 spaces padding at the end of +lines." + (with-current-buffer (or buffer (current-buffer)) (goto-char (point-min)) ;; Remove space stuffing. (while (re-search-forward "^\\( \\|>+ $\\)" nil t) commit 1a2055310055dffc664ab9d1095b38bc7afd3581 Author: Lars Ingebrigtsen Date: Wed Aug 14 16:35:16 2019 -0700 Output the maintainer and author(s) in the package description buffer * lisp/emacs-lisp/package.el (describe-package-1): Output maintainer and author(s) (bug#17573). (package--print-email-button): New function. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index e7e0bd1124..a72522ad8f 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2356,7 +2356,9 @@ The description is read from the installed package files." (installable (and archive (not built-in))) (status (if desc (package-desc-status desc) "orphan")) (incompatible-reason (package--incompatible-p desc)) - (signed (if desc (package-desc-signed desc)))) + (signed (if desc (package-desc-signed desc))) + (maintainer (cdr (assoc :maintainer extras))) + (authors (cdr (assoc :authors extras)))) (when (string= status "avail-obso") (setq status "available obsolete")) (when incompatible-reason @@ -2479,6 +2481,19 @@ The description is read from the installed package files." 'action 'package-keyword-button-action) (insert " ")) (insert "\n")) + (when maintainer + (package--print-help-section "Maintainer") + (package--print-email-button maintainer)) + (when authors + (package--print-help-section + (if (= (length authors) 1) + "Author" + "Authors")) + (package--print-email-button (pop authors)) + ;; If there's more than one author, indent the rest correctly. + (dolist (name authors) + (insert (make-string 13 ?\s)) + (package--print-email-button name))) (let* ((all-pkgs (append (cdr (assq name package-alist)) (cdr (assq name package-archive-contents)) (let ((bi (assq name package--builtins))) @@ -2577,6 +2592,21 @@ The description is read from the installed package files." (apply #'insert-text-button button-text 'face button-face 'follow-link t props))) +(defun package--print-email-button (name) + (when (car name) + (insert (car name))) + (when (and (car name) (cdr name)) + (insert " ")) + (when (cdr name) + (insert "<") + (insert-text-button (cdr name) + 'follow-link t + 'action (lambda (_) + (compose-mail + (format "%s <%s>" (car name) (cdr name))))) + (insert ">")) + (insert "\n")) + ;;;; Package menu mode. commit cad5418f18b496b0ec8f280201fb32cb39eefdfe Author: Juri Linkov Date: Thu Aug 15 00:06:07 2019 +0300 ; Fix typoes. diff --git a/doc/emacs/indent.texi b/doc/emacs/indent.texi index 5f40acba15..654c64a7b2 100644 --- a/doc/emacs/indent.texi +++ b/doc/emacs/indent.texi @@ -110,9 +110,9 @@ parentheses, or if the junction follows another newline. If there is a fill prefix, @kbd{M-^} deletes the fill prefix if it appears after the newline that is deleted. @xref{Fill Prefix}. -With a prefix argument, join the current line line to the following -line. If the region is active, and no prefix argument is given, join -all lines in the region instead. +With a prefix argument, join the current line to the following line. +If the region is active, and no prefix argument is given, join all +lines in the region instead. @item C-M-\ @kindex C-M-\ diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 57d803894c..ae35766ecd 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -957,7 +957,7 @@ Accepts the same arguments as `xref-show-xrefs-function'." nil nil nil 'xref--read-identifier-history def))) (if (equal id "") - (or def (user-error "There is no defailt identifier")) + (or def (user-error "There is no default identifier")) id))) (t def)))) commit 629068a89d1b2a7babbed7d3f5778834a970de16 Author: Eli Zaretskii Date: Wed Aug 14 17:53:14 2019 +0300 Fix fetching URLs with stuff that looks like HTTP headers * lisp/url/url-http.el (url-http-parse-headers): Narrow the buffer to the headers at the beginning to make sure url-handle-content-transfer-encoding uses the correct headers. (Bug#37023) diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 9b690778fc..94d1ba9668 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -949,6 +949,10 @@ should be shown to the user." class url-http-response-status))) (if (not success) (url-mark-buffer-as-dead buffer) + ;; Narrow the buffer for url-handle-content-transfer-encoding to + ;; find only the headers relevant to this transaction. + (and (not (buffer-narrowed-p) + (mail-narrow-to-head))) (url-handle-content-transfer-encoding)) (url-http-debug "Finished parsing HTTP headers: %S" success) (widen) commit f4974d6fe6137f436763998be27afafea9866098 Author: Paul Eggert Date: Tue Aug 13 12:28:53 2019 -0700 Don’t increase consing_until_gc when out of memory * src/alloc.c (memory_full): Don’t increase consing_until_gc. Suggested by Eli Zaretskii (Bug#37006#46). diff --git a/src/alloc.c b/src/alloc.c index 14b0a7b838..0548a09cb8 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3866,7 +3866,7 @@ memory_full (size_t nbytes) if (! enough_free_memory) { Vmemory_full = Qt; - consing_until_gc = memory_full_cons_threshold; + consing_until_gc = min (consing_until_gc, memory_full_cons_threshold); /* The first time we get here, free the spare memory. */ for (int i = 0; i < ARRAYELTS (spare_memory); i++) commit b80559be212292d44ce14ca5e94505cab4d9a868 Author: Paul Eggert Date: Tue Aug 13 12:20:40 2019 -0700 Let consing_until_gc exceed EMACS_INT_MAX This builds on the previous patch. * src/alloc.c (consing_until_gc): Now of type intmax_t, since gc-cons-threshold can be up to INTMAX_MAX. All uses changed. * src/lisp.h (CONSING_CT_MAX, consing_ct): Remove. diff --git a/src/alloc.c b/src/alloc.c index 7bed3f4488..14b0a7b838 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -224,7 +224,7 @@ struct emacs_globals globals; /* maybe_gc collects garbage if this goes negative. */ -consing_ct consing_until_gc; +intmax_t consing_until_gc; #ifdef HAVE_PDUMPER /* Number of finalizers run: used to loop over GC until we stop @@ -2547,7 +2547,7 @@ free_cons (struct Lisp_Cons *ptr) might incorrectly return non-zero. */ int incr = sizeof *ptr; if (INT_ADD_WRAPV (consing_until_gc, incr, &consing_until_gc)) - consing_until_gc = CONSING_CT_MAX; + consing_until_gc = INTMAX_MAX; gcstat.total_free_conses++; } @@ -5502,7 +5502,7 @@ staticpro (Lisp_Object const *varaddress) static void allow_garbage_collection (intmax_t consing) { - consing_until_gc = consing - (CONSING_CT_MAX - consing_until_gc); + consing_until_gc = consing - (INTMAX_MAX - consing_until_gc); garbage_collection_inhibited--; } @@ -5512,7 +5512,7 @@ inhibit_garbage_collection (void) ptrdiff_t count = SPECPDL_INDEX (); record_unwind_protect_intmax (allow_garbage_collection, consing_until_gc); garbage_collection_inhibited++; - consing_until_gc = CONSING_CT_MAX; + consing_until_gc = INTMAX_MAX; return count; } @@ -5818,7 +5818,7 @@ garbage_collect_1 (struct gcstat *gcst) /* In case user calls debug_print during GC, don't let that cause a recursive GC. */ - consing_until_gc = CONSING_CT_MAX; + consing_until_gc = INTMAX_MAX; /* Save what's currently displayed in the echo area. Don't do that if we are GC'ing because we've run out of memory, since @@ -5933,17 +5933,17 @@ garbage_collect_1 (struct gcstat *gcst) consing_until_gc = memory_full_cons_threshold; else { - consing_ct threshold = max (gc_cons_threshold, GC_DEFAULT_THRESHOLD / 10); + intmax_t threshold = max (gc_cons_threshold, GC_DEFAULT_THRESHOLD / 10); if (FLOATP (Vgc_cons_percentage)) { double tot = (XFLOAT_DATA (Vgc_cons_percentage) * total_bytes_of_live_objects ()); if (threshold < tot) { - if (tot < CONSING_CT_MAX) + if (tot < INTMAX_MAX) threshold = tot; else - threshold = CONSING_CT_MAX; + threshold = INTMAX_MAX; } } consing_until_gc = threshold; diff --git a/src/lisp.h b/src/lisp.h index 043f2f738e..0370c52fad 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3793,13 +3793,7 @@ extern void flush_stack_call_func (void (*func) (void *arg), void *arg); extern void garbage_collect (void); extern const char *pending_malloc_warning; extern Lisp_Object zero_vector; -#define CONSING_CT_MAX max (INTPTR_MAX, EMACS_INT_MAX) -#if CONSING_CT_MAX == INTPTR_MAX -typedef intptr_t consing_ct; -#else -typedef EMACS_INT consing_ct; -#endif -extern consing_ct consing_until_gc; +extern intmax_t consing_until_gc; #ifdef HAVE_PDUMPER extern int number_finalizers_run; #endif commit a354736e1dfe5a7e4ddbb1ee7f1373be2b5bbe09 Author: Paul Eggert Date: Tue Aug 13 12:11:35 2019 -0700 Let consing_until_gc exceed INTPTR_MAX Suggested by Eli Zaretskii (Bug#37006#46). * src/alloc.c (consing_until_gc): Now of type consing_ct. All uses changed, so gc-cons-threshold no longer saturates against OBJECT_CT_MAX. (object_ct): Move typedef here from lisp.h. * src/lisp.h (consing_ct, CONSING_CT_MAX): New type and macro. (OBJECT_CT_MAX): Remove. Replace all uses with CONSING_CT_MAX. diff --git a/src/alloc.c b/src/alloc.c index c7419e2fa5..7bed3f4488 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -224,7 +224,7 @@ struct emacs_globals globals; /* maybe_gc collects garbage if this goes negative. */ -object_ct consing_until_gc; +consing_ct consing_until_gc; #ifdef HAVE_PDUMPER /* Number of finalizers run: used to loop over GC until we stop @@ -236,9 +236,10 @@ int number_finalizers_run; bool gc_in_progress; -/* System byte counts reported by GC. */ +/* System byte and object counts reported by GC. */ typedef uintptr_t byte_ct; +typedef intptr_t object_ct; /* Number of live and free conses etc. */ @@ -2546,7 +2547,7 @@ free_cons (struct Lisp_Cons *ptr) might incorrectly return non-zero. */ int incr = sizeof *ptr; if (INT_ADD_WRAPV (consing_until_gc, incr, &consing_until_gc)) - consing_until_gc = OBJECT_CT_MAX; + consing_until_gc = CONSING_CT_MAX; gcstat.total_free_conses++; } @@ -5501,7 +5502,7 @@ staticpro (Lisp_Object const *varaddress) static void allow_garbage_collection (intmax_t consing) { - consing_until_gc = consing - (OBJECT_CT_MAX - consing_until_gc); + consing_until_gc = consing - (CONSING_CT_MAX - consing_until_gc); garbage_collection_inhibited--; } @@ -5511,7 +5512,7 @@ inhibit_garbage_collection (void) ptrdiff_t count = SPECPDL_INDEX (); record_unwind_protect_intmax (allow_garbage_collection, consing_until_gc); garbage_collection_inhibited++; - consing_until_gc = OBJECT_CT_MAX; + consing_until_gc = CONSING_CT_MAX; return count; } @@ -5817,7 +5818,7 @@ garbage_collect_1 (struct gcstat *gcst) /* In case user calls debug_print during GC, don't let that cause a recursive GC. */ - consing_until_gc = OBJECT_CT_MAX; + consing_until_gc = CONSING_CT_MAX; /* Save what's currently displayed in the echo area. Don't do that if we are GC'ing because we've run out of memory, since @@ -5932,19 +5933,17 @@ garbage_collect_1 (struct gcstat *gcst) consing_until_gc = memory_full_cons_threshold; else { - intptr_t threshold = min (max (GC_DEFAULT_THRESHOLD / 10, - gc_cons_threshold), - OBJECT_CT_MAX); + consing_ct threshold = max (gc_cons_threshold, GC_DEFAULT_THRESHOLD / 10); if (FLOATP (Vgc_cons_percentage)) { double tot = (XFLOAT_DATA (Vgc_cons_percentage) * total_bytes_of_live_objects ()); if (threshold < tot) { - if (tot < OBJECT_CT_MAX) + if (tot < CONSING_CT_MAX) threshold = tot; else - threshold = OBJECT_CT_MAX; + threshold = CONSING_CT_MAX; } } consing_until_gc = threshold; diff --git a/src/lisp.h b/src/lisp.h index 63baab5d63..043f2f738e 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3793,9 +3793,13 @@ extern void flush_stack_call_func (void (*func) (void *arg), void *arg); extern void garbage_collect (void); extern const char *pending_malloc_warning; extern Lisp_Object zero_vector; -typedef intptr_t object_ct; /* Signed type of object counts reported by GC. */ -#define OBJECT_CT_MAX INTPTR_MAX -extern object_ct consing_until_gc; +#define CONSING_CT_MAX max (INTPTR_MAX, EMACS_INT_MAX) +#if CONSING_CT_MAX == INTPTR_MAX +typedef intptr_t consing_ct; +#else +typedef EMACS_INT consing_ct; +#endif +extern consing_ct consing_until_gc; #ifdef HAVE_PDUMPER extern int number_finalizers_run; #endif commit 8882761440c3227850043dddf5aec5394c8cbe28 Author: Paul Eggert Date: Tue Aug 13 10:03:41 2019 -0700 Fix GC threshold typo Problem reported by Eli Zaretskii (Bug#37006#25). * src/alloc.c (garbage_collect_1): Fix typo in threshold calc. Go back to dividing by 10 since the numerator’s a constant now. Problem introduced in 2019-07-21T02:40:03Z!eggert@cs.ucla.edu. diff --git a/src/alloc.c b/src/alloc.c index 39833f8dec..c7419e2fa5 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -5932,8 +5932,8 @@ garbage_collect_1 (struct gcstat *gcst) consing_until_gc = memory_full_cons_threshold; else { - intptr_t threshold = min (max (GC_DEFAULT_THRESHOLD, - gc_cons_threshold >> 3), + intptr_t threshold = min (max (GC_DEFAULT_THRESHOLD / 10, + gc_cons_threshold), OBJECT_CT_MAX); if (FLOATP (Vgc_cons_percentage)) { commit c0e720cdd97b28d532f4deb66861518a70d062ac Author: Eli Zaretskii Date: Tue Aug 13 18:16:51 2019 +0300 Improve documentation of 'diff-font-lock-prettify' * lisp/vc/diff-mode.el (diff-font-lock-prettify): Doc fix. * etc/NEWS: Minor copyedits. diff --git a/etc/NEWS b/etc/NEWS index e8618152ed..b9e9e28db4 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -734,6 +734,10 @@ With a prefix argument asks for a command, so for example, 'C-u M-x vc-log-search RET git log -1 f302475 RET' will display just one log entry found by its revision number. +*** 'C-x v =' can now mimic Magit's diff format. +Set the new user option 'diff-font-lock-prettify' to t for that, see +below under "Diff mode". + ** Diff mode +++ *** Hunks are now automatically refined by font-lock. @@ -754,6 +758,8 @@ according to the appropriate major mode. Customize the new option *** File headers can be shortened, mimicking Magit's diff format. To enable it, set the new user option 'diff-font-lock-prettify' to t. +On GUI frames, this option also displays the insertion and deletion +indicators on the left fringe. +++ *** Prefix arg of 'diff-goto-source' means jump to the old revision diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index c4812e81d4..19f9c802d4 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -109,7 +109,11 @@ You can always manually refine a hunk with `diff-refine-hunk'." (const :tag "Refine hunks during navigation" navigation))) (defcustom diff-font-lock-prettify nil - "If non-nil, font-lock will try and make the format prettier." + "If non-nil, font-lock will try and make the format prettier. + +This mimics the Magit's diff format by making the hunk header +less cryptic, and on GUI frames also displays insertion and +deletion indicators on the left fringe (if it's available)." :version "27.1" :type 'boolean) commit c90975f92fd71be7282293e0ed1098c0fa5d62a0 Author: Eli Zaretskii Date: Tue Aug 13 17:49:51 2019 +0300 Fix initialization of user-defined fringe bitmaps in daemon mode * src/fringe.c (gui_init_fringe): Rename from w32_init_fringe or x_cr_init_fringe, and make unconditionally compiled; all callers changed. Do nothing if the frame's redisplay_interface doesn't implement the define_fringe_bitmap method. Set up any user-defined fringe bitmaps in addition to the standard bitmaps. Suggested by Liam Quinlan in https://lists.gnu.org/archive/html/emacs-devel/2019-08/msg00259.html. (w32_reset_fringes) [HAVE_NTGUI]: Do nothing if the frame's redisplay_interface doesn't implement the destroy_fringe_bitmap method. * src/w32fns.c (Fx_create_frame): Call gui_init_fringe when the first GUI frame is created for this session. * src/dispextern.h (w32_init_fringe): Rename to gui_init_fringe and make unconditional. (x_cr_init_fringe): Remove prototype. diff --git a/src/dispextern.h b/src/dispextern.h index 4e947daa25..05f199ff35 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -3360,13 +3360,11 @@ void draw_row_fringe_bitmaps (struct window *, struct glyph_row *); bool draw_window_fringes (struct window *, bool); bool update_window_fringes (struct window *, bool); +void gui_init_fringe (struct redisplay_interface *); + #ifdef HAVE_NTGUI -void w32_init_fringe (struct redisplay_interface *); void w32_reset_fringes (void); #endif -#ifdef USE_CAIRO -void x_cr_init_fringe (struct redisplay_interface *); -#endif extern unsigned row_hash (struct glyph_row *); diff --git a/src/fringe.c b/src/fringe.c index d0d599223d..4c5a4d748f 100644 --- a/src/fringe.c +++ b/src/fringe.c @@ -1765,27 +1765,32 @@ init_fringe (void) fringe_faces = xzalloc (max_fringe_bitmaps * sizeof *fringe_faces); } -#if defined (HAVE_NTGUI) || defined (USE_CAIRO) - void -#ifdef HAVE_NTGUI -w32_init_fringe (struct redisplay_interface *rif) -#else -x_cr_init_fringe (struct redisplay_interface *rif) -#endif +gui_init_fringe (struct redisplay_interface *rif) { int bt; - if (!rif) + if (!rif || !rif->define_fringe_bitmap) return; + /* Set up the standard fringe bitmaps. */ for (bt = NO_FRINGE_BITMAP + 1; bt < MAX_STANDARD_FRINGE_BITMAPS; bt++) { struct fringe_bitmap *fb = &standard_bitmaps[bt]; rif->define_fringe_bitmap (bt, fb->bits, fb->height, fb->width); } + + /* Set up user-defined fringe bitmaps that might have been defined + before the frame of this kind was initialized. This can happen + if Emacs is started as a daemon and the init files define fringe + bitmaps. */ + for ( ; bt < max_used_fringe_bitmap; bt++) + { + struct fringe_bitmap *fb = fringe_bitmaps[bt]; + if (fb) + rif->define_fringe_bitmap (bt, fb->bits, fb->height, fb->width); + } } -#endif #ifdef HAVE_NTGUI void @@ -1795,7 +1800,7 @@ w32_reset_fringes (void) int bt; struct redisplay_interface *rif = FRAME_RIF (SELECTED_FRAME ()); - if (!rif) + if (!rif || !rif->destroy_fringe_bitmap) return; for (bt = NO_FRINGE_BITMAP + 1; bt < max_used_fringe_bitmap; bt++) diff --git a/src/w32fns.c b/src/w32fns.c index fc80e01883..d6fd8f5349 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -5798,6 +5798,12 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, f->output_data.w32 = xzalloc (sizeof (struct w32_output)); FRAME_FONTSET (f) = -1; + /* Need to finish setting up of user-defined fringe bitmaps that + were defined before the first GUI frame was created (e.g., while + in daemon mode). */ + if (!f->terminal->reference_count) + gui_init_fringe (f->terminal->rif); + fset_icon_name (f, gui_display_get_arg (dpyinfo, parameters, Qicon_name, diff --git a/src/w32term.c b/src/w32term.c index ad96287a43..e5874f2d36 100644 --- a/src/w32term.c +++ b/src/w32term.c @@ -7299,7 +7299,7 @@ w32_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) horizontally reflected compared to how they appear on X, so we need to bitswap and convert to unsigned shorts before creating the bitmaps. */ - w32_init_fringe (terminal->rif); + gui_init_fringe (terminal->rif); unblock_input (); diff --git a/src/xterm.c b/src/xterm.c index bbe68ef622..0d224063d7 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -13531,7 +13531,7 @@ x_initialize (void) #endif #ifdef USE_CAIRO - x_cr_init_fringe (&x_redisplay_interface); + gui_init_fringe (&x_redisplay_interface); #endif /* Note that there is no real way portable across R3/R4 to get the commit 2b329ed420eb15f6738edd402697ac2876b2aa61 Author: Eli Zaretskii Date: Mon Aug 12 17:39:09 2019 +0300 ; Add commentary to recent changes * src/image.c (png_load_body): * src/editfns.c (styled_format): * src/casefiddle.c (do_casify_multibyte_string): * src/alloc.c (free_cons): Comment why we use a signed temporary integer variable. (Bug#37006) diff --git a/src/alloc.c b/src/alloc.c index 8227feadae..39833f8dec 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -2542,6 +2542,8 @@ free_cons (struct Lisp_Cons *ptr) ptr->u.s.u.chain = cons_free_list; ptr->u.s.car = dead_object (); cons_free_list = ptr; + /* Use a temporary signed variable, since otherwise INT_ADD_WRAPV + might incorrectly return non-zero. */ int incr = sizeof *ptr; if (INT_ADD_WRAPV (consing_until_gc, incr, &consing_until_gc)) consing_until_gc = OBJECT_CT_MAX; diff --git a/src/casefiddle.c b/src/casefiddle.c index 6fcb585214..741973e40a 100644 --- a/src/casefiddle.c +++ b/src/casefiddle.c @@ -265,6 +265,8 @@ do_casify_multibyte_string (struct casing_context *ctx, Lisp_Object obj) ptrdiff_t size = SCHARS (obj), n; USE_SAFE_ALLOCA; + /* Use a temporary signed variable, since otherwise INT_ADD_WRAPV + might incorrectly return non-zero. */ ptrdiff_t casing_str_buf_size = sizeof (struct casing_str_buf); if (INT_MULTIPLY_WRAPV (size, MAX_MULTIBYTE_LENGTH, &n) || INT_ADD_WRAPV (n, casing_str_buf_size, &n)) diff --git a/src/editfns.c b/src/editfns.c index 25f80bedb1..19bbfdcd47 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -3158,12 +3158,14 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) /* Upper bound on number of format specs. Each uses at least 2 chars. */ ptrdiff_t nspec_bound = SCHARS (args[0]) >> 1; - /* Allocate the info and discarded tables. */ + /* Use a temporary signed variable, since otherwise INT_ADD_WRAPV + might incorrectly return non-zero. */ ptrdiff_t info_size = sizeof *info, alloca_size; if (INT_MULTIPLY_WRAPV (nspec_bound, info_size, &info_size) || INT_ADD_WRAPV (formatlen, info_size, &alloca_size) || SIZE_MAX < alloca_size) memory_full (SIZE_MAX); + /* Allocate the info and discarded tables. */ info = SAFE_ALLOCA (alloca_size); /* discarded[I] is 1 if byte I of the format string was not copied into the output. diff --git a/src/image.c b/src/image.c index a59be0cd8f..b37851f096 100644 --- a/src/image.c +++ b/src/image.c @@ -6658,11 +6658,13 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c) /* Number of bytes needed for one row of the image. */ row_bytes = png_get_rowbytes (png_ptr, info_ptr); - /* Allocate memory for the image. */ + /* Use a temporary signed variable, since otherwise + INT_MULTIPLY_WRAPV might incorrectly return non-zero. */ ptrdiff_t nbytes = sizeof *pixels; if (INT_MULTIPLY_WRAPV (row_bytes, nbytes, &nbytes) || INT_MULTIPLY_WRAPV (nbytes, height, &nbytes)) memory_full (SIZE_MAX); + /* Allocate memory for the image. */ c->pixels = pixels = xmalloc (nbytes); c->rows = rows = xmalloc (height * sizeof *rows); for (i = 0; i < height; ++i) commit dbae38efc22e117c20f6cd9bfd8300d692055c70 Author: Óscar Fuentes Date: Mon Aug 12 16:22:34 2019 +0200 * lisp/password-cache.el: adapt test to change in password-in-cache-p diff --git a/test/lisp/password-cache-tests.el b/test/lisp/password-cache-tests.el index bb8064d4c6..1abb546113 100644 --- a/test/lisp/password-cache-tests.el +++ b/test/lisp/password-cache-tests.el @@ -29,7 +29,7 @@ (ert-deftest password-cache-tests-add-and-remove () (let ((password-data (copy-hash-table password-data))) (password-cache-add "foo" "bar") - (should (equal (password-in-cache-p "foo") "bar")) + (should (eq (password-in-cache-p "foo") t)) (password-cache-remove "foo") (should (not (password-in-cache-p "foo"))))) commit 88006cf542ed99ca8236c9b61c6b19b732353d6c Author: Michael Albinus Date: Mon Aug 12 16:18:59 2019 +0200 Quote file names properly in Tramp * lisp/net/tramp.el (tramp-handle-file-truename) (tramp-handle-insert-directory): * lisp/net/tramp-adb.el (tramp-adb-handle-file-truename): * lisp/net/tramp-sh.el (tramp-sh-handle-file-truename) (tramp-sh-handle-insert-directory): * lisp/net/tramp-smb.el (tramp-smb-handle-insert-directory): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-handle-file-truename): Use `tramp-compat-directory-name-p'. * lisp/net/tramp.el (tramp-drop-volume-letter) (tramp-handle-file-truename): * lisp/net/tramp-adb.el (tramp-adb-handle-file-truename): * lisp/net/tramp-sh.el (tramp-sh-handle-make-symbolic-link) (tramp-sh-handle-file-truename): * lisp/net/tramp-smb.el (tramp-smb-handle-make-symbolic-link): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-handle-file-truename): (tramp-sudoedit-handle-make-symbolic-link): Quote properly. * lisp/net/tramp-compat.el (tramp-compat-file-name-quote) (tramp-compat-file-name-unquote): Add optional argument TOP. diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 2192f7f025..df4778c9c9 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -232,96 +232,100 @@ pass to the OPERATION." ;; code could be shared? (defun tramp-adb-handle-file-truename (filename) "Like `file-truename' for Tramp files." - ;; Preserve trailing "/". + ;; Preserve trailing "/". (funcall - (if (string-equal (file-name-nondirectory filename) "") + (if (tramp-compat-directory-name-p filename) #'file-name-as-directory #'identity) - (with-parsed-tramp-file-name (expand-file-name filename) nil - (tramp-make-tramp-file-name - v - (with-tramp-file-property v localname "file-truename" - (let ((result nil) ; result steps in reverse order - (quoted (tramp-compat-file-name-quoted-p localname))) - (tramp-message v 4 "Finding true name for `%s'" filename) - (let* ((steps (split-string localname "/" 'omit)) - (localnamedir (tramp-run-real-handler - 'file-name-as-directory (list localname))) - (is-dir (string= localname localnamedir)) - (thisstep nil) - (numchase 0) - ;; Don't make the following value larger than - ;; necessary. People expect an error message in a - ;; timely fashion when something is wrong; otherwise - ;; they might think that Emacs is hung. Of course, - ;; correctness has to come first. - (numchase-limit 20) - symlink-target) - (while (and steps (< numchase numchase-limit)) - (setq thisstep (pop steps)) - (tramp-message - v 5 "Check %s" - (string-join - (append '("") (reverse result) (list thisstep)) "/")) - (setq symlink-target - (tramp-compat-file-attribute-type - (file-attributes - (tramp-make-tramp-file-name - v - (string-join - (append '("") (reverse result) (list thisstep)) "/"))))) - (cond ((string= "." thisstep) - (tramp-message v 5 "Ignoring step `.'")) - ((string= ".." thisstep) - (tramp-message v 5 "Processing step `..'") - (pop result)) - ((stringp symlink-target) - ;; It's a symlink, follow it. - (tramp-message v 5 "Follow symlink to %s" symlink-target) - (setq numchase (1+ numchase)) - (when (file-name-absolute-p symlink-target) - (setq result nil)) - ;; If the symlink was absolute, we'll get a string - ;; like "/user@host:/some/target"; extract the - ;; "/some/target" part from it. - (when (tramp-tramp-file-p symlink-target) - (unless (tramp-equal-remote filename symlink-target) - (tramp-error - v 'file-error - "Symlink target `%s' on wrong host" symlink-target)) - (setq symlink-target localname)) - (setq steps - (append (split-string symlink-target "/" 'omit) - steps))) - (t - ;; It's a file. - (setq result (cons thisstep result))))) - (when (>= numchase numchase-limit) - (tramp-error - v 'file-error - "Maximum number (%d) of symlinks exceeded" numchase-limit)) - (setq result (reverse result)) - ;; Combine list to form string. - (setq result - (if result - (string-join (cons "" result) "/") - "/")) - (when (and is-dir (or (string-empty-p result) - (not (string= (substring result -1) "/")))) - (setq result (concat result "/")))) - - ;; Detect cycle. - (when (and (file-symlink-p filename) - (string-equal result localname)) - (tramp-error - v 'file-error - "Apparent cycle of symbolic links for %s" filename)) - ;; If the resulting localname looks remote, we must quote it - ;; for security reasons. - (when (or quoted (file-remote-p result)) - (let (file-name-handler-alist) - (setq result (tramp-compat-file-name-quote result)))) - (tramp-message v 4 "True name of `%s' is `%s'" localname result) - result)))))) + ;; Quote properly. + (funcall + (if (tramp-compat-file-name-quoted-p filename) + #'tramp-compat-file-name-quote #'identity) + (with-parsed-tramp-file-name + (tramp-compat-file-name-unquote (expand-file-name filename)) nil + (tramp-make-tramp-file-name + v + (with-tramp-file-property v localname "file-truename" + (let (result) ; result steps in reverse order + (tramp-message v 4 "Finding true name for `%s'" filename) + (let* ((steps (split-string localname "/" 'omit)) + (localnamedir (tramp-run-real-handler + 'file-name-as-directory (list localname))) + (is-dir (string= localname localnamedir)) + (thisstep nil) + (numchase 0) + ;; Don't make the following value larger than + ;; necessary. People expect an error message in a + ;; timely fashion when something is wrong; otherwise + ;; they might think that Emacs is hung. Of course, + ;; correctness has to come first. + (numchase-limit 20) + symlink-target) + (while (and steps (< numchase numchase-limit)) + (setq thisstep (pop steps)) + (tramp-message + v 5 "Check %s" + (string-join + (append '("") (reverse result) (list thisstep)) "/")) + (setq symlink-target + (tramp-compat-file-attribute-type + (file-attributes + (tramp-make-tramp-file-name + v + (string-join + (append + '("") (reverse result) (list thisstep)) "/"))))) + (cond ((string= "." thisstep) + (tramp-message v 5 "Ignoring step `.'")) + ((string= ".." thisstep) + (tramp-message v 5 "Processing step `..'") + (pop result)) + ((stringp symlink-target) + ;; It's a symlink, follow it. + (tramp-message v 5 "Follow symlink to %s" symlink-target) + (setq numchase (1+ numchase)) + (when (file-name-absolute-p symlink-target) + (setq result nil)) + ;; If the symlink was absolute, we'll get a string + ;; like "/user@host:/some/target"; extract the + ;; "/some/target" part from it. + (when (tramp-tramp-file-p symlink-target) + (unless (tramp-equal-remote filename symlink-target) + (tramp-error + v 'file-error + "Symlink target `%s' on wrong host" symlink-target)) + (setq symlink-target localname)) + (setq steps + (append (split-string symlink-target "/" 'omit) + steps))) + (t + ;; It's a file. + (setq result (cons thisstep result))))) + (when (>= numchase numchase-limit) + (tramp-error + v 'file-error + "Maximum number (%d) of symlinks exceeded" numchase-limit)) + (setq result (reverse result)) + ;; Combine list to form string. + (setq result + (if result + (string-join (cons "" result) "/") + "/")) + (when (and is-dir (or (string-empty-p result) + (not (string= (substring result -1) "/")))) + (setq result (concat result "/")))) + + ;; Detect cycle. + (when (and (file-symlink-p filename) + (string-equal result localname)) + (tramp-error + v 'file-error + "Apparent cycle of symbolic links for %s" filename)) + ;; If the resulting localname looks remote, we must quote it + ;; for security reasons. + (when (file-remote-p result) + (setq result (tramp-compat-file-name-quote result 'top))) + (tramp-message v 4 "True name of `%s' is `%s'" localname result) + result))))))) (defun tramp-adb-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index fca2654bee..e83c1a1500 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -227,24 +227,31 @@ If NAME is a remote file name and TOP is nil, check the local part of NAME." (string-prefix-p "/:" (tramp-compat-file-local-name name)))))) (defalias 'tramp-compat-file-name-quote - (if (fboundp 'file-name-quote) + (if (and + (fboundp 'file-name-quote) + (equal (tramp-compat-funcall 'func-arity #'file-name-quote) '(1 . 2))) #'file-name-quote - (lambda (name) + (lambda (name &optional top) "Add the quotation prefix \"/:\" to file NAME. -If NAME is a remote file name, the local part of NAME is quoted." - (if (tramp-compat-file-name-quoted-p name) - name - (concat - (file-remote-p name) "/:" (tramp-compat-file-local-name name)))))) +If NAME is a remote file name and TOP is nil, the local part of NAME is quoted." + (let ((file-name-handler-alist (unless top file-name-handler-alist))) + (if (tramp-compat-file-name-quoted-p name top) + name + (concat + (file-remote-p name) "/:" (tramp-compat-file-local-name name))))))) (defalias 'tramp-compat-file-name-unquote - (if (fboundp 'file-name-unquote) + (if (and + (fboundp 'file-name-unquote) + (equal (tramp-compat-funcall 'func-arity #'file-name-unquote) '(1 . 2))) #'file-name-unquote - (lambda (name) + (lambda (name &optional top) "Remove quotation prefix \"/:\" from file NAME. -If NAME is a remote file name, the local part of NAME is unquoted." - (let ((localname (tramp-compat-file-local-name name))) - (when (tramp-compat-file-name-quoted-p localname) +If NAME is a remote file name and TOP is nil, the local part of +NAME is unquoted." + (let* ((file-name-handler-alist (unless top file-name-handler-alist)) + (localname (tramp-compat-file-local-name name))) + (when (tramp-compat-file-name-quoted-p localname top) (setq localname (if (= (length localname) 2) "/" (substring localname 2)))) (concat (file-remote-p name) localname))))) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 6e18e7330c..f1f0abc6e5 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1044,8 +1044,7 @@ component is used as the target of the symlink." ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) - (make-symbolic-link - (let (file-name-handler-alist) (tramp-compat-file-name-quote target)) + (make-symbolic-link (tramp-compat-file-name-quote target 'top) linkname ok-if-already-exists) (let ((ln (tramp-get-remote-ln v)) @@ -1090,108 +1089,113 @@ component is used as the target of the symlink." (defun tramp-sh-handle-file-truename (filename) "Like `file-truename' for Tramp files." - ;; Preserve trailing "/". + ;; Preserve trailing "/". (funcall - (if (string-equal (file-name-nondirectory filename) "") + (if (tramp-compat-directory-name-p filename) #'file-name-as-directory #'identity) - (with-parsed-tramp-file-name (expand-file-name filename) nil - (tramp-make-tramp-file-name - v - (with-tramp-file-property v localname "file-truename" - (let ((result nil) ; result steps in reverse order - (quoted (tramp-compat-file-name-quoted-p localname)) - (localname (tramp-compat-file-name-unquote localname))) - (tramp-message v 4 "Finding true name for `%s'" filename) - (cond - ;; Use GNU readlink --canonicalize-missing where available. - ((tramp-get-remote-readlink v) - (tramp-send-command-and-check - v - (format "%s --canonicalize-missing %s" - (tramp-get-remote-readlink v) - (tramp-shell-quote-argument localname))) - (with-current-buffer (tramp-get-connection-buffer v) - (goto-char (point-min)) - (setq result (buffer-substring (point-min) (point-at-eol))))) - - ;; Use Perl implementation. - ((and (tramp-get-remote-perl v) - (tramp-get-connection-property v "perl-file-spec" nil) - (tramp-get-connection-property v "perl-cwd-realpath" nil)) - (tramp-maybe-send-script - v tramp-perl-file-truename "tramp_perl_file_truename") - (setq result - (tramp-send-command-and-read - v - (format "tramp_perl_file_truename %s" - (tramp-shell-quote-argument localname))))) - - ;; Do it yourself. - (t (let ((steps (split-string localname "/" 'omit)) - (thisstep nil) - (numchase 0) - ;; Don't make the following value larger than - ;; necessary. People expect an error message in a - ;; timely fashion when something is wrong; - ;; otherwise they might think that Emacs is hung. - ;; Of course, correctness has to come first. - (numchase-limit 20) - symlink-target) - (while (and steps (< numchase numchase-limit)) - (setq thisstep (pop steps)) - (tramp-message - v 5 "Check %s" - (string-join - (append '("") (reverse result) (list thisstep)) "/")) - (setq symlink-target - (tramp-compat-file-attribute-type - (file-attributes - (tramp-make-tramp-file-name - v - (string-join - (append '("") (reverse result) (list thisstep)) "/") - 'nohop)))) - (cond ((string= "." thisstep) - (tramp-message v 5 "Ignoring step `.'")) - ((string= ".." thisstep) - (tramp-message v 5 "Processing step `..'") - (pop result)) - ((stringp symlink-target) - ;; It's a symlink, follow it. - (tramp-message - v 5 "Follow symlink to %s" symlink-target) - (setq numchase (1+ numchase)) - (when (file-name-absolute-p symlink-target) - (setq result nil)) - (setq steps - (append - (split-string symlink-target "/" 'omit) steps))) - (t - ;; It's a file. - (setq result (cons thisstep result))))) - (when (>= numchase numchase-limit) - (tramp-error - v 'file-error - "Maximum number (%d) of symlinks exceeded" numchase-limit)) - (setq result (reverse result)) - ;; Combine list to form string. - (setq result (if result (string-join (cons "" result) "/") "/")) - (when (string-empty-p result) (setq result "/"))))) - - ;; Detect cycle. - (when (and (file-symlink-p filename) - (string-equal result localname)) - (tramp-error - v 'file-error - "Apparent cycle of symbolic links for %s" filename)) - ;; If the resulting localname looks remote, we must quote it - ;; for security reasons. - (when (or quoted (file-remote-p result)) - (let (file-name-handler-alist) - (setq result (tramp-compat-file-name-quote result)))) - (tramp-message v 4 "True name of `%s' is `%s'" localname result) - result)) - 'nohop)))) + ;; Quote properly. + (funcall + (if (tramp-compat-file-name-quoted-p filename) + #'tramp-compat-file-name-quote #'identity) + (with-parsed-tramp-file-name + (tramp-compat-file-name-unquote (expand-file-name filename)) nil + (tramp-make-tramp-file-name + v + (with-tramp-file-property v localname "file-truename" + (let (result) ; result steps in reverse order + (tramp-message v 4 "Finding true name for `%s'" filename) + (cond + ;; Use GNU readlink --canonicalize-missing where available. + ((tramp-get-remote-readlink v) + (tramp-send-command-and-check + v + (format "%s --canonicalize-missing %s" + (tramp-get-remote-readlink v) + (tramp-shell-quote-argument localname))) + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (setq result (buffer-substring (point-min) (point-at-eol))))) + + ;; Use Perl implementation. + ((and (tramp-get-remote-perl v) + (tramp-get-connection-property v "perl-file-spec" nil) + (tramp-get-connection-property v "perl-cwd-realpath" nil)) + (tramp-maybe-send-script + v tramp-perl-file-truename "tramp_perl_file_truename") + (setq result + (tramp-send-command-and-read + v + (format "tramp_perl_file_truename %s" + (tramp-shell-quote-argument localname))))) + + ;; Do it yourself. + (t (let ((steps (split-string localname "/" 'omit)) + (thisstep nil) + (numchase 0) + ;; Don't make the following value larger than + ;; necessary. People expect an error message in a + ;; timely fashion when something is wrong; + ;; otherwise they might think that Emacs is hung. + ;; Of course, correctness has to come first. + (numchase-limit 20) + symlink-target) + (while (and steps (< numchase numchase-limit)) + (setq thisstep (pop steps)) + (tramp-message + v 5 "Check %s" + (string-join + (append '("") (reverse result) (list thisstep)) "/")) + (setq symlink-target + (tramp-compat-file-attribute-type + (file-attributes + (tramp-make-tramp-file-name + v + (string-join + (append + '("") (reverse result) (list thisstep)) "/") + 'nohop)))) + (cond ((string= "." thisstep) + (tramp-message v 5 "Ignoring step `.'")) + ((string= ".." thisstep) + (tramp-message v 5 "Processing step `..'") + (pop result)) + ((stringp symlink-target) + ;; It's a symlink, follow it. + (tramp-message + v 5 "Follow symlink to %s" symlink-target) + (setq numchase (1+ numchase)) + (when (file-name-absolute-p symlink-target) + (setq result nil)) + (setq steps + (append + (split-string symlink-target "/" 'omit) + steps))) + (t + ;; It's a file. + (setq result (cons thisstep result))))) + (when (>= numchase numchase-limit) + (tramp-error + v 'file-error + "Maximum number (%d) of symlinks exceeded" numchase-limit)) + (setq result (reverse result)) + ;; Combine list to form string. + (setq result + (if result (string-join (cons "" result) "/") "/")) + (when (string-empty-p result) (setq result "/"))))) + + ;; Detect cycle. + (when (and (file-symlink-p filename) + (string-equal result localname)) + (tramp-error + v 'file-error + "Apparent cycle of symbolic links for %s" filename)) + ;; If the resulting localname looks remote, we must quote it + ;; for security reasons. + (when (file-remote-p result) + (setq result (tramp-compat-file-name-quote result 'top))) + (tramp-message v 4 "True name of `%s' is `%s'" localname result) + result)) + 'nohop))))) ;; Basic functions. @@ -2676,7 +2680,7 @@ The method used must be an out-of-band method." (when (file-symlink-p filename) (goto-char (search-backward "->" beg 'noerror))) (search-backward - (if (zerop (length (file-name-nondirectory filename))) + (if (tramp-compat-directory-name-p filename) "." (file-name-nondirectory filename)) beg 'noerror) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index b619e77a52..5df26a1e33 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -986,7 +986,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq filename (expand-file-name filename)) (unless switches (setq switches "")) ;; Mark trailing "/". - (when (and (zerop (length (file-name-nondirectory filename))) + (when (and (tramp-compat-directory-name-p filename) (not full-directory-p)) (setq switches (concat switches "F"))) (if full-directory-p @@ -1175,8 +1175,7 @@ component is used as the target of the symlink." ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) - (make-symbolic-link - (let (file-name-handler-alist) (tramp-compat-file-name-quote target)) + (make-symbolic-link (tramp-compat-file-name-quote target 'top) linkname ok-if-already-exists) ;; Do the 'confirm if exists' thing. diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 5d5a3f1f75..80ce8f7874 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -533,34 +533,36 @@ the result will be a local, non-Tramp, file name." (defun tramp-sudoedit-handle-file-truename (filename) "Like `file-truename' for Tramp files." - ;; Preserve trailing "/". + ;; Preserve trailing "/". (funcall - (if (string-equal (file-name-nondirectory filename) "") + (if (tramp-compat-directory-name-p filename) #'file-name-as-directory #'identity) - (with-parsed-tramp-file-name (expand-file-name filename) nil - (tramp-make-tramp-file-name - v - (with-tramp-file-property v localname "file-truename" - (let ((quoted (tramp-compat-file-name-quoted-p localname)) - (localname (tramp-compat-file-name-unquote localname)) - result) - (tramp-message v 4 "Finding true name for `%s'" filename) - (setq result (tramp-sudoedit-send-command-string - v "readlink" "--canonicalize-missing" localname)) - ;; Detect cycle. - (when (and (file-symlink-p filename) - (string-equal result localname)) - (tramp-error - v 'file-error - "Apparent cycle of symbolic links for %s" filename)) - ;; If the resulting localname looks remote, we must quote it - ;; for security reasons. - (when (or quoted (file-remote-p result)) - (let (file-name-handler-alist) - (setq result (tramp-compat-file-name-quote result)))) - (tramp-message v 4 "True name of `%s' is `%s'" localname result) - result)) - 'nohop)))) + ;; Quote properly. + (funcall + (if (tramp-compat-file-name-quoted-p filename) + #'tramp-compat-file-name-quote #'identity) + (with-parsed-tramp-file-name + (tramp-compat-file-name-unquote (expand-file-name filename)) nil + (tramp-make-tramp-file-name + v + (with-tramp-file-property v localname "file-truename" + (let (result) + (tramp-message v 4 "Finding true name for `%s'" filename) + (setq result (tramp-sudoedit-send-command-string + v "readlink" "--canonicalize-missing" localname)) + ;; Detect cycle. + (when (and (file-symlink-p filename) + (string-equal result localname)) + (tramp-error + v 'file-error + "Apparent cycle of symbolic links for %s" filename)) + ;; If the resulting localname looks remote, we must quote it + ;; for security reasons. + (when (file-remote-p result) + (setq result (tramp-compat-file-name-quote result 'top))) + (tramp-message v 4 "True name of `%s' is `%s'" localname result) + result)) + 'nohop))))) (defun tramp-sudoedit-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." @@ -609,8 +611,7 @@ component is used as the target of the symlink." ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) - (make-symbolic-link - (let (file-name-handler-alist) (tramp-compat-file-name-quote target)) + (make-symbolic-link (tramp-compat-file-name-quote target 'top) linkname ok-if-already-exists) ;; Do the 'confirm if exists' thing. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 7bae434723..d419f9d87d 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2004,13 +2004,11 @@ locally on a remote file name. When the local system is a W32 system but the remote system is Unix, this introduces a superfluous drive letter into the file name. This function removes it." (save-match-data - (funcall - (if (tramp-compat-file-name-quoted-p name) - #'tramp-compat-file-name-quote #'identity) - (let ((name (tramp-compat-file-name-unquote name))) - (if (string-match "\\`[a-zA-Z]:/" name) - (replace-match "/" nil t name) - name))))) + (let ((quoted (tramp-compat-file-name-quoted-p name 'top)) + (result (tramp-compat-file-name-unquote name 'top))) + (setq result (if (string-match "\\`[a-zA-Z]:/" result) + (replace-match "/" nil t result) result)) + (if quoted (tramp-compat-file-name-quote result 'top) result)))) ;;; Config Manipulation Functions: @@ -3287,45 +3285,44 @@ User is always nil." "Like `file-truename' for Tramp files." ;; Preserve trailing "/". (funcall - (if (string-equal (file-name-nondirectory filename) "") + (if (tramp-compat-directory-name-p filename) #'file-name-as-directory #'identity) - (let ((result (expand-file-name filename)) - (numchase 0) - ;; Don't make the following value larger than necessary. - ;; People expect an error message in a timely fashion when - ;; something is wrong; otherwise they might think that Emacs - ;; is hung. Of course, correctness has to come first. - (numchase-limit 20) - symlink-target) - (with-parsed-tramp-file-name result v1 - ;; We cache only the localname. - (tramp-make-tramp-file-name - v1 - (with-tramp-file-property v1 v1-localname "file-truename" - (while (and (setq symlink-target (file-symlink-p result)) - (< numchase numchase-limit)) - (setq numchase (1+ numchase) - result - (with-parsed-tramp-file-name (expand-file-name result) v2 - (tramp-make-tramp-file-name - v2 - (funcall - (if (tramp-compat-file-name-quoted-p v2-localname) - #'tramp-compat-file-name-quote #'identity) - + ;; Quote properly. + (funcall + (if (tramp-compat-file-name-quoted-p filename) + #'tramp-compat-file-name-quote #'identity) + (let ((result (tramp-compat-file-name-unquote (expand-file-name filename))) + (numchase 0) + ;; Don't make the following value larger than necessary. + ;; People expect an error message in a timely fashion when + ;; something is wrong; otherwise they might think that Emacs + ;; is hung. Of course, correctness has to come first. + (numchase-limit 20) + symlink-target) + (with-parsed-tramp-file-name result v1 + ;; We cache only the localname. + (tramp-make-tramp-file-name + v1 + (with-tramp-file-property v1 v1-localname "file-truename" + (while (and (setq symlink-target (file-symlink-p result)) + (< numchase numchase-limit)) + (setq numchase (1+ numchase) + result + (with-parsed-tramp-file-name (expand-file-name result) v2 + (tramp-make-tramp-file-name + v2 (if (stringp symlink-target) (if (file-remote-p symlink-target) - (let (file-name-handler-alist) - (tramp-compat-file-name-quote symlink-target)) + (tramp-compat-file-name-quote symlink-target 'top) (expand-file-name symlink-target (file-name-directory v2-localname))) - v2-localname)) - 'nohop))) - (when (>= numchase numchase-limit) - (tramp-error - v1 'file-error - "Maximum number (%d) of symlinks exceeded" numchase-limit))) - (tramp-compat-file-local-name (directory-file-name result)))))))) + v2-localname) + 'nohop))) + (when (>= numchase numchase-limit) + (tramp-error + v1 'file-error + "Maximum number (%d) of symlinks exceeded" numchase-limit))) + (tramp-compat-file-local-name (directory-file-name result))))))))) (defun tramp-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." @@ -3360,7 +3357,7 @@ User is always nil." "Like `insert-directory' for Tramp files." (unless switches (setq switches "")) ;; Mark trailing "/". - (when (and (zerop (length (file-name-nondirectory filename))) + (when (and (tramp-compat-directory-name-p filename) (not full-directory-p)) (setq switches (concat switches "F"))) ;; Check, whether directory is accessible. commit f7b5e7d72d1648831fca3fc79cb134eab3407aa1 Author: Michael Albinus Date: Mon Aug 12 16:18:17 2019 +0200 Handle symbolic links properly in Tramp gfvs methods * lisp/net/tramp-gvfs.el (tramp-gvfs-handle-file-readable-p): Handle symbolic links. diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index f10476a7bc..b9b6b4b6d1 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -1261,6 +1261,12 @@ file-notify events." (with-tramp-file-property v localname "file-readable-p" (and (file-exists-p filename) (or (tramp-check-cached-permissions v ?r) + ;; `tramp-check-cached-permissions' doesn't handle + ;; symbolic links. + (and (stringp (file-symlink-p filename)) + (file-readable-p + (concat + (file-remote-p filename) (file-symlink-p filename)))) ;; If the user is different from what we guess to be ;; the user, we don't know. Let's check, whether ;; access is restricted explicitly. commit 55d82625c1565522e6162e38d0cc09e5c3c7ba3f Author: Michael Albinus Date: Mon Aug 12 16:17:39 2019 +0200 Fix caching problem in Tramp smb method * lisp/net/tramp-cache.el (tramp-flush-file-upper-properties): Add "file-entries", diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index b52203c79c..1380d0368c 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -205,7 +205,8 @@ Returns VALUE." (maphash (lambda (property _value) (when (string-match-p - "^\\(directory-\\|file-name-all-completions\\)" property) + "^\\(directory-\\|file-name-all-completions\\|file-entries\\)" + property) (tramp-flush-file-property key file property))) (tramp-get-hash-table key))))) commit 57fc1a5f7c49fbe7288de6ad567c934db2ceaf96 Author: Paul Eggert Date: Sun Aug 11 16:42:38 2019 -0700 Prefer signed when testing for signed overflow * src/alloc.c (free_cons): * src/casefiddle.c (do_casify_multibyte_string): * src/editfns.c (styled_format): * src/image.c (png_load_body): Use signed arguments to INT_MULTIPLY_WRAPV etc. This doesn’t fix any bugs, but GCC emits better code when all args are signed. Also, this removes the need for an if in free_cons (Bug#37006). diff --git a/src/alloc.c b/src/alloc.c index d9022ac46c..8227feadae 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -2542,9 +2542,8 @@ free_cons (struct Lisp_Cons *ptr) ptr->u.s.u.chain = cons_free_list; ptr->u.s.car = dead_object (); cons_free_list = ptr; - if (consing_until_gc <= 0) - consing_until_gc += sizeof *ptr; - else if (INT_ADD_WRAPV (consing_until_gc, sizeof *ptr, &consing_until_gc)) + int incr = sizeof *ptr; + if (INT_ADD_WRAPV (consing_until_gc, incr, &consing_until_gc)) consing_until_gc = OBJECT_CT_MAX; gcstat.total_free_conses++; } diff --git a/src/casefiddle.c b/src/casefiddle.c index ee292dda9b..6fcb585214 100644 --- a/src/casefiddle.c +++ b/src/casefiddle.c @@ -265,8 +265,9 @@ do_casify_multibyte_string (struct casing_context *ctx, Lisp_Object obj) ptrdiff_t size = SCHARS (obj), n; USE_SAFE_ALLOCA; + ptrdiff_t casing_str_buf_size = sizeof (struct casing_str_buf); if (INT_MULTIPLY_WRAPV (size, MAX_MULTIBYTE_LENGTH, &n) - || INT_ADD_WRAPV (n, sizeof (struct casing_str_buf), &n)) + || INT_ADD_WRAPV (n, casing_str_buf_size, &n)) n = PTRDIFF_MAX; unsigned char *dst = SAFE_ALLOCA (n); unsigned char *dst_end = dst + n; diff --git a/src/editfns.c b/src/editfns.c index 1b33f39711..25f80bedb1 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -3159,8 +3159,8 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) ptrdiff_t nspec_bound = SCHARS (args[0]) >> 1; /* Allocate the info and discarded tables. */ - ptrdiff_t info_size, alloca_size; - if (INT_MULTIPLY_WRAPV (nspec_bound, sizeof *info, &info_size) + ptrdiff_t info_size = sizeof *info, alloca_size; + if (INT_MULTIPLY_WRAPV (nspec_bound, info_size, &info_size) || INT_ADD_WRAPV (formatlen, info_size, &alloca_size) || SIZE_MAX < alloca_size) memory_full (SIZE_MAX); diff --git a/src/image.c b/src/image.c index 81d8cb4e2b..a59be0cd8f 100644 --- a/src/image.c +++ b/src/image.c @@ -6463,7 +6463,6 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c) png_uint_32 row_bytes; bool transparent_p; struct png_memory_storage tbr; /* Data to be read */ - ptrdiff_t nbytes; Emacs_Pix_Container ximg, mask_img = NULL; /* Find out what file to load. */ @@ -6660,7 +6659,8 @@ png_load_body (struct frame *f, struct image *img, struct png_load_context *c) row_bytes = png_get_rowbytes (png_ptr, info_ptr); /* Allocate memory for the image. */ - if (INT_MULTIPLY_WRAPV (row_bytes, sizeof *pixels, &nbytes) + ptrdiff_t nbytes = sizeof *pixels; + if (INT_MULTIPLY_WRAPV (row_bytes, nbytes, &nbytes) || INT_MULTIPLY_WRAPV (nbytes, height, &nbytes)) memory_full (SIZE_MAX); c->pixels = pixels = xmalloc (nbytes); commit f01365f62c921407acead13bb350816a313a8c42 Author: Óscar Fuentes Date: Mon Aug 12 01:42:16 2019 +0200 password-cache: differentiate null values from non-existent entries * password-cache.el (password-in-cache-p, password-cache-add): properly detect non-existent entry. (Bug#36834) diff --git a/lisp/password-cache.el b/lisp/password-cache.el index 5a09ae4859..6009fb491e 100644 --- a/lisp/password-cache.el +++ b/lisp/password-cache.el @@ -81,7 +81,8 @@ regulate cache behavior." "Check if KEY is in the cache." (and password-cache key - (gethash key password-data))) + (not (eq (gethash key password-data 'password-cache-no-data) + 'password-cache-no-data)))) (defun password-read (prompt &optional key) "Read password, for use with KEY, from user, or from cache if wanted. @@ -125,7 +126,9 @@ user again." (defun password-cache-add (key password) "Add password to cache. The password is removed by a timer after `password-cache-expiry' seconds." - (when (and password-cache-expiry (null (gethash key password-data))) + (when (and password-cache-expiry + (eq (gethash key password-data 'password-cache-no-data) + 'password-cache-no-data)) (run-at-time password-cache-expiry nil #'password-cache-remove key)) commit 94644d862c9a54a5ebe8265fbba04bdd0c973065 Author: Eli Zaretskii Date: Sun Aug 11 19:23:23 2019 +0300 Fix garbage collection * src/alloc.c (free_cons): Avoid false positives in INT_ADD_WRAPV. (Bug#37006) diff --git a/src/alloc.c b/src/alloc.c index 5e089311a2..d9022ac46c 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -2542,7 +2542,9 @@ free_cons (struct Lisp_Cons *ptr) ptr->u.s.u.chain = cons_free_list; ptr->u.s.car = dead_object (); cons_free_list = ptr; - if (INT_ADD_WRAPV (consing_until_gc, sizeof *ptr, &consing_until_gc)) + if (consing_until_gc <= 0) + consing_until_gc += sizeof *ptr; + else if (INT_ADD_WRAPV (consing_until_gc, sizeof *ptr, &consing_until_gc)) consing_until_gc = OBJECT_CT_MAX; gcstat.total_free_conses++; } commit 73877cb3a781d667b2c03ed5a30add5058d1333b Author: Eric Abrahamsen Date: Sun Aug 11 08:26:59 2019 -0700 Prompt for new sieve script names in sieve management * lisp/net/sieve.el (sieve-edit-script): Otherwise the user ends up with a script named '.sieve'. diff --git a/lisp/net/sieve.el b/lisp/net/sieve.el index 3337998bed..4485b8c730 100644 --- a/lisp/net/sieve.el +++ b/lisp/net/sieve.el @@ -210,7 +210,11 @@ require \"fileinto\"; (set-buffer-modified-p nil) (error "Sieve download failed: %s" err))) (switch-to-buffer (get-buffer-create "template.siv")) - (insert sieve-template)) + (insert sieve-template) + (setq name (read-string "Name for new script: ")) + (when (string-match "\\.sieve\\'" name) + ;; The server will append .sieve to the script name. + (setq name (replace-match "" t t name)))) (sieve-mode) (setq sieve-buffer-script-name name) (goto-char (point-min)) commit 95552e08db1688809b7f3979ed86033287fa5dc9 Author: Michael Albinus Date: Sun Aug 11 12:06:57 2019 +0200 Retrieve start time from remote machine, use compat attrib functions * lisp/net/tramp-compat.el (tramp-compat-file-attribute-access-time) (tramp-compat-file-attribute-status-change-time): New defaliases. * test/lisp/net/tramp-tests.el (tramp--test-start-time): New defvar. (tramp--test-file-attributes-equal-p) (tramp-test19-directory-files-and-attributes): Use it. (tramp-test18-file-attributes) (tramp--test-file-attributes-equal-p, tramp-test20-file-modes) (tramp-test22-file-times, tramp--test-check-files): Use `tramp-compat-file-attribute-*' functions. diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 4f01f8d372..fca2654bee 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -136,6 +136,14 @@ looked up, a numeric value, either an integer or a float, is returned." (nth 3 attributes)))) +(defalias 'tramp-compat-file-attribute-access-time + (if (fboundp 'file-attribute-access-time) + #'file-attribute-access-time + (lambda (attributes) + "The last access time in ATTRIBUTES returned by `file-attributes'. +This a Lisp timestamp in the style of `current-time'." + (nth 4 attributes)))) + (defalias 'tramp-compat-file-attribute-modification-time (if (fboundp 'file-attribute-modification-time) #'file-attribute-modification-time @@ -145,6 +153,16 @@ This is the time of the last change to the file's contents, and is a Lisp timestamp in the style of `current-time'." (nth 5 attributes)))) +(defalias 'tramp-compat-file-attribute-status-change-time + (if (fboundp 'file-attribute-status-change-time) + #'file-attribute-status-change-time + (lambda (attributes) + "The status modification time in ATTRIBUTES returned by `file-attributes'. +This is the time of last change to the file's attributes: owner +and group, access mode bits, etc., and is a Lisp timestamp in the +style of `current-time'." + (nth 6 attributes)))) + (defalias 'tramp-compat-file-attribute-size (if (fboundp 'file-attribute-size) #'file-attribute-size diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 095c145e69..180f746c64 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -3007,22 +3007,28 @@ This tests also `access-file', `file-readable-p', ;; We do not test inodes and device numbers. (setq attr (file-attributes tmp-name1)) (should (consp attr)) - (should (null (car attr))) - (should (numberp (nth 1 attr))) ;; Link. - (should (numberp (nth 2 attr))) ;; Uid. - (should (numberp (nth 3 attr))) ;; Gid. - ;; Last access time. - (should (stringp (current-time-string (nth 4 attr)))) - ;; Last modification time. - (should (stringp (current-time-string (nth 5 attr)))) - ;; Last status change time. - (should (stringp (current-time-string (nth 6 attr)))) - (should (numberp (nth 7 attr))) ;; Size. - (should (stringp (nth 8 attr))) ;; Modes. + (should (null (tramp-compat-file-attribute-type attr))) + (should (numberp (tramp-compat-file-attribute-link-number attr))) + (should (numberp (tramp-compat-file-attribute-user-id attr))) + (should (numberp (tramp-compat-file-attribute-group-id attr))) + (should + (stringp + (current-time-string + (tramp-compat-file-attribute-access-time attr)))) + (should + (stringp + (current-time-string + (tramp-compat-file-attribute-modification-time attr)))) + (should + (stringp + (current-time-string + (tramp-compat-file-attribute-status-change-time attr)))) + (should (numberp (tramp-compat-file-attribute-size attr))) + (should (stringp (tramp-compat-file-attribute-modes attr))) (setq attr (file-attributes tmp-name1 'string)) - (should (stringp (nth 2 attr))) ;; Uid. - (should (stringp (nth 3 attr))) ;; Gid. + (should (stringp (tramp-compat-file-attribute-user-id attr))) + (should (stringp (tramp-compat-file-attribute-group-id attr))) (tramp--test-ignore-make-symbolic-link-error (should-error @@ -3041,7 +3047,7 @@ This tests also `access-file', `file-readable-p', (string-equal (funcall (if quoted #'tramp-compat-file-name-quote #'identity) - (car attr)) + (tramp-compat-file-attribute-type attr)) (file-remote-p (file-truename tmp-name1) 'localname))) (delete-file tmp-name2)) @@ -3060,7 +3066,7 @@ This tests also `access-file', `file-readable-p', (setq attr (file-attributes tmp-name2)) (should (string-equal - (car attr) + (tramp-compat-file-attribute-type attr) (tramp-file-name-localname (tramp-dissect-file-name tmp-name3)))) (delete-file tmp-name2)) @@ -3076,24 +3082,22 @@ This tests also `access-file', `file-readable-p', (when (tramp--test-sh-p) (should (file-ownership-preserved-p tmp-name1 'group))) (setq attr (file-attributes tmp-name1)) - (should (eq (car attr) t))) + (should (eq (tramp-compat-file-attribute-type attr) t))) ;; Cleanup. (ignore-errors (delete-directory tmp-name1)) (ignore-errors (delete-file tmp-name1)) (ignore-errors (delete-file tmp-name2)))))) +(defvar tramp--test-start-time nil + "Keep the start time of the current test, a float number.") + (defsubst tramp--test-file-attributes-equal-p (attr1 attr2) "Check, whether file attributes ATTR1 and ATTR2 are equal. They might differ only in time attributes or directory size." (let ((attr1 (copy-sequence attr1)) (attr2 (copy-sequence attr2)) - (start-time - (- (float-time - (aref - (ert--stats-test-start-times ert--current-run-stats) - (ert--stats-test-pos ert--current-run-stats (ert-running-test)))) - 60))) + (start-time (- tramp--test-start-time 10))) ;; Access time. (setcar (nthcdr 4 attr1) tramp-time-dont-know) (setcar (nthcdr 4 attr2) tramp-time-dont-know) @@ -3101,30 +3105,47 @@ They might differ only in time attributes or directory size." ;; we cannot compare, and we normalize the time stamps. If the ;; time value is newer than the test start time, normalize it, ;; because due to caching the time stamps could differ slightly (a - ;; few seconds). We use a test start time minus 60 seconds, in - ;; order to compensate a possible time offset on local and remote - ;; machines. - (when (or (tramp-compat-time-equal-p (nth 5 attr1) tramp-time-dont-know) - (tramp-compat-time-equal-p (nth 5 attr2) tramp-time-dont-know)) + ;; few seconds). We use a test start time minus 10 seconds, in + ;; order to compensate a possible timestamp resolution higher than + ;; a second on the remote machine. + (when (or (tramp-compat-time-equal-p + (tramp-compat-file-attribute-modification-time attr1) + tramp-time-dont-know) + (tramp-compat-time-equal-p + (tramp-compat-file-attribute-modification-time attr2) + tramp-time-dont-know)) (setcar (nthcdr 5 attr1) tramp-time-dont-know) (setcar (nthcdr 5 attr2) tramp-time-dont-know)) - (when (< start-time (float-time (nth 5 attr1))) + (when (< start-time + (float-time (tramp-compat-file-attribute-modification-time attr1))) (setcar (nthcdr 5 attr1) tramp-time-dont-know)) - (when (< start-time (float-time (nth 5 attr2))) + (when (< start-time + (float-time (tramp-compat-file-attribute-modification-time attr2))) (setcar (nthcdr 5 attr2) tramp-time-dont-know)) ;; Status change time. Dito. - (when (or (tramp-compat-time-equal-p (nth 6 attr1) tramp-time-dont-know) - (tramp-compat-time-equal-p (nth 6 attr2) tramp-time-dont-know)) + (when (or (tramp-compat-time-equal-p + (tramp-compat-file-attribute-status-change-time attr1) + tramp-time-dont-know) + (tramp-compat-time-equal-p + (tramp-compat-file-attribute-status-change-time attr2) + tramp-time-dont-know)) (setcar (nthcdr 6 attr1) tramp-time-dont-know) (setcar (nthcdr 6 attr2) tramp-time-dont-know)) - (when (< start-time (float-time (nth 6 attr1))) + (when + (< start-time + (float-time + (tramp-compat-file-attribute-status-change-time attr1))) (setcar (nthcdr 6 attr1) tramp-time-dont-know)) - (when (< start-time (float-time (nth 6 attr2))) + (when + (< start-time + (float-time (tramp-compat-file-attribute-status-change-time attr2))) (setcar (nthcdr 6 attr2) tramp-time-dont-know)) ;; Size. Set it to 0 for directories, because it might have ;; changed. For example the upper directory "../". - (when (eq (car attr1) t) (setcar (nthcdr 7 attr1) 0)) - (when (eq (car attr2) t) (setcar (nthcdr 7 attr2) 0)) + (when (eq (tramp-compat-file-attribute-type attr1) t) + (setcar (nthcdr 7 attr1) 0)) + (when (eq (tramp-compat-file-attribute-type attr2) t) + (setcar (nthcdr 7 attr2) 0)) ;; The check. (unless (equal attr1 attr2) (tramp--test-message "%S\n%S" attr1 attr2)) (equal attr1 attr2))) @@ -3147,6 +3168,10 @@ They might differ only in time attributes or directory size." (progn (make-directory tmp-name1) (should (file-directory-p tmp-name1)) + (setq tramp--test-start-time + (float-time + (tramp-compat-file-attribute-modification-time + (file-attributes tmp-name1)))) (make-directory tmp-name2) (should (file-directory-p tmp-name2)) (write-region "foo" nil (expand-file-name "foo" tmp-name2)) @@ -3200,7 +3225,8 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (should (= (file-modes tmp-name) #o444)) (should-not (file-executable-p tmp-name)) ;; A file is always writable for user "root". - (unless (zerop (nth 2 (file-attributes tmp-name))) + (unless (zerop (tramp-compat-file-attribute-user-id + (file-attributes tmp-name))) (should-not (file-writable-p tmp-name)))) ;; Cleanup. @@ -3495,16 +3521,21 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (progn (write-region "foo" nil tmp-name1) (should (file-exists-p tmp-name1)) - (should (consp (nth 5 (file-attributes tmp-name1)))) + (should (consp (tramp-compat-file-attribute-modification-time + (file-attributes tmp-name1)))) ;; Skip the test, if the remote handler is not able to set ;; the correct time. (skip-unless (set-file-times tmp-name1 (seconds-to-time 1))) ;; Dumb remote shells without perl(1) or stat(1) are not ;; able to return the date correctly. They say "don't know". (unless (tramp-compat-time-equal-p - (nth 5 (file-attributes tmp-name1)) tramp-time-dont-know) + (tramp-compat-file-attribute-modification-time + (file-attributes tmp-name1)) + tramp-time-dont-know) (should - (equal (nth 5 (file-attributes tmp-name1)) (seconds-to-time 1))) + (equal (tramp-compat-file-attribute-modification-time + (file-attributes tmp-name1)) + (seconds-to-time 1))) (write-region "bla" nil tmp-name2) (should (file-exists-p tmp-name2)) (should (file-newer-than-file-p tmp-name2 tmp-name1)) @@ -5150,7 +5181,7 @@ This requires restrictions of file name syntax." (string-equal (funcall (if quoted #'tramp-compat-file-name-quote #'identity) - (car (file-attributes file3))) + (tramp-compat-file-attribute-type (file-attributes file3))) (file-remote-p (file-truename file1) 'localname))) ;; Check file contents. (with-temp-buffer commit 252704ded4657123d9ed95b9c2573ca5c1c38dc5 Author: Glenn Morris Date: Sat Aug 10 22:59:00 2019 -0700 Set custom :version for recently modified undo options * lisp/cus-start.el (undo-limit, undo-strong-limit, undo-outer-limit): Bump :version. diff --git a/lisp/cus-start.el b/lisp/cus-start.el index ddb9546ad1..15d33b43c0 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -495,8 +495,8 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of (const :tag "Silent" ignore) function)) ;; undo.c - (undo-limit undo integer) - (undo-strong-limit undo integer) + (undo-limit undo integer "27.1") + (undo-strong-limit undo integer "27.1") (undo-outer-limit undo (choice integer (const :tag "No limit" @@ -507,7 +507,7 @@ the undo info for the current command never gets discarded. This should only be chosen under exceptional circumstances, since it could result in memory overflow and make Emacs crash." nil)) - "22.1") + "27.1") ;; window.c (temp-buffer-show-function windows (choice (const nil) function)) (next-screen-context-lines windows integer) commit 75083b1568a710242da7165f63c4798288ff4612 Author: Stefan Kangas Date: Sat Aug 10 22:30:41 2019 +0200 * doc/emacs/calendar.texi (Time Intervals): Doc fix. diff --git a/doc/emacs/calendar.texi b/doc/emacs/calendar.texi index 138a24fd45..e337474d92 100644 --- a/doc/emacs/calendar.texi +++ b/doc/emacs/calendar.texi @@ -1618,12 +1618,12 @@ timeclock-change}. work today (assuming a typical average of 8 hours a day), and @kbd{M-x timeclock-when-to-leave} which will calculate when you're done. -@vindex timeclock-modeline-display -@findex timeclock-modeline-display +@vindex timeclock-mode-line-display +@findex timeclock-mode-line-display If you want Emacs to display the amount of time left of your workday in the mode line, either customize the -@code{timeclock-modeline-display} variable and set its value to -@code{t}, or invoke the @kbd{M-x timeclock-modeline-display} command. +@code{timeclock-mode-line-display} variable and set its value to +@code{t}, or invoke the @kbd{M-x timeclock-mode-line-display} command. @vindex timeclock-ask-before-exiting Terminating the current Emacs session might or might not mean that commit 6f57ef9d3cc5d3d934701e257fd6c8fd9f48f95f Author: Eli Zaretskii Date: Sat Aug 10 22:19:31 2019 +0300 * src/callproc.c (Fcall_process): Doc fix. diff --git a/src/callproc.c b/src/callproc.c index fa12d02e39..1b89d691b3 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -220,7 +220,7 @@ static mode_t const default_output_mode = 0666; DEFUN ("call-process", Fcall_process, Scall_process, 1, MANY, 0, doc: /* Call PROGRAM synchronously in separate process. The remaining arguments are optional. -The program's input comes from file INFILE (nil means `/dev/null'). +The program's input comes from file INFILE (nil means `null-device'). Third argument DESTINATION specifies how to handle program's output. If DESTINATION is a buffer, or t that stands for the current buffer, commit 94663726c0e95efc894c0227fb7a4e6623d67377 Author: Stefan Kangas Date: Sat Aug 10 15:17:33 2019 +0200 Double undo limits * src/undo.c (syms_of_undo) : Double undo limits. (Bug#31104) diff --git a/src/undo.c b/src/undo.c index 3c1251dae6..78e51ead66 100644 --- a/src/undo.c +++ b/src/undo.c @@ -442,7 +442,7 @@ value, the earlier commands that came before it are forgotten. The size is counted as the number of bytes occupied, which includes both saved text and other data. */); - undo_limit = 80000; + undo_limit = 160000; DEFVAR_INT ("undo-strong-limit", undo_strong_limit, doc: /* Don't keep more than this much size of undo information. @@ -454,7 +454,7 @@ is never discarded for this reason. The size is counted as the number of bytes occupied, which includes both saved text and other data. */); - undo_strong_limit = 120000; + undo_strong_limit = 240000; DEFVAR_LISP ("undo-outer-limit", Vundo_outer_limit, doc: /* Outer limit on size of undo information for one command. @@ -471,7 +471,7 @@ In fact, this calls the function which is the value of `undo-outer-limit-function' with one argument, the size. The text above describes the behavior of the function that variable usually specifies. */); - Vundo_outer_limit = make_fixnum (12000000); + Vundo_outer_limit = make_fixnum (24000000); DEFVAR_LISP ("undo-outer-limit-function", Vundo_outer_limit_function, doc: /* Function to call when an undo list exceeds `undo-outer-limit'. commit 7343474b79332b05abc1d51ae2bbc3e2ba43deeb Merge: 6bebfa77a9 0860ac0e9d Author: Glenn Morris Date: Sat Aug 10 08:44:31 2019 -0700 Merge from origin/emacs-26 0860ac0 (origin/emacs-26) Improve documentation of features that use ... fae1ff6 Fix docstrings in pong 82a2894 Improve doc strings of 'append-to-buffer' and friends cb0403d Fix octave-mode ElDoc support 691790b Avoid Groff hanging on MS-Windows when invoked by "M-x man" commit 6bebfa77a9ae8c63b29f159387600c097ea32eaa Merge: f47fc426df b83f83ccd4 Author: Glenn Morris Date: Sat Aug 10 08:44:31 2019 -0700 ; Merge from origin/emacs-26 The following commit was skipped: b83f83c Ignore pending_signals when checking for quits. commit f47fc426df57aef9f5d9b52578bf183ef9c8d47f Merge: ce26bb3539 e7818cb73f Author: Glenn Morris Date: Sat Aug 10 08:44:31 2019 -0700 Merge from origin/emacs-26 e7818cb Fix nnmail-expiry-wait docs and custom :types 8b7c776 * lisp/simple.el (kill-do-not-save-duplicates): Doc fix. (Bu... commit ce26bb35391c82f4aadc557e22a504a60d0c19d7 Merge: 2c5dd68018 5a5ad99d2f Author: Glenn Morris Date: Sat Aug 10 08:44:31 2019 -0700 ; Merge from origin/emacs-26 The following commits were skipped: 5a5ad99d Improve documentation of debugging Lisp syntax error 0148fc7 (emacs-26) ; Auto-commit of loaddefs files. commit 0860ac0e9db15ee0f094df7f6b0bbd5961bb08ac Author: Eli Zaretskii Date: Sat Aug 10 12:48:03 2019 +0300 Improve documentation of features that use the fringes * doc/emacs/display.texi (Fringes): Add cross-reference to where indicate-empty-lines is described. (Useless Whitespace): Add an @anchor for a more accurate cross-reference in "Fringes". diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi index ac1ce3606b..74bcc3283c 100644 --- a/doc/emacs/display.texi +++ b/doc/emacs/display.texi @@ -1110,7 +1110,8 @@ the arrows scrolls the display horizontally in the direction of the arrow. The fringes can also indicate other things, such as buffer -boundaries (@pxref{Displaying Boundaries}), and where a program you +boundaries (@pxref{Displaying Boundaries}), unused lines near the end +of the window (@pxref{indicate-empty-lines}), and where a program you are debugging is executing (@pxref{Debuggers}). @vindex overflow-newline-into-fringe @@ -1203,6 +1204,7 @@ extra spaces at the end of each line in the region. @vindex indicate-empty-lines @cindex unused lines @cindex fringes, and unused line indication +@anchor{indicate-empty-lines} On graphical displays, Emacs can indicate unused lines at the end of the window with a small image in the left fringe (@pxref{Fringes}). The image appears for screen lines that do not correspond to any commit 2c5dd680180e978303662d3d32cc9aa5121b4d29 Author: Michael Albinus Date: Sat Aug 10 11:34:13 2019 +0200 Use a time offset when comparing times of local and remote machines * test/lisp/net/tramp-tests.el (tramp--test-file-attributes-equal-p): Use a time offset in order to compensate different times on local and remote machines. diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 7a1ae5273e..095c145e69 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -3089,11 +3089,11 @@ They might differ only in time attributes or directory size." (let ((attr1 (copy-sequence attr1)) (attr2 (copy-sequence attr2)) (start-time - (floor - (float-time - (aref - (ert--stats-test-start-times ert--current-run-stats) - (ert--stats-test-pos ert--current-run-stats (ert-running-test))))))) + (- (float-time + (aref + (ert--stats-test-start-times ert--current-run-stats) + (ert--stats-test-pos ert--current-run-stats (ert-running-test)))) + 60))) ;; Access time. (setcar (nthcdr 4 attr1) tramp-time-dont-know) (setcar (nthcdr 4 attr2) tramp-time-dont-know) @@ -3101,23 +3101,25 @@ They might differ only in time attributes or directory size." ;; we cannot compare, and we normalize the time stamps. If the ;; time value is newer than the test start time, normalize it, ;; because due to caching the time stamps could differ slightly (a - ;; few seconds). + ;; few seconds). We use a test start time minus 60 seconds, in + ;; order to compensate a possible time offset on local and remote + ;; machines. (when (or (tramp-compat-time-equal-p (nth 5 attr1) tramp-time-dont-know) (tramp-compat-time-equal-p (nth 5 attr2) tramp-time-dont-know)) (setcar (nthcdr 5 attr1) tramp-time-dont-know) (setcar (nthcdr 5 attr2) tramp-time-dont-know)) - (when (<= start-time (floor (float-time (nth 5 attr1)))) + (when (< start-time (float-time (nth 5 attr1))) (setcar (nthcdr 5 attr1) tramp-time-dont-know)) - (when (<= start-time (floor (float-time (nth 5 attr2)))) + (when (< start-time (float-time (nth 5 attr2))) (setcar (nthcdr 5 attr2) tramp-time-dont-know)) ;; Status change time. Dito. (when (or (tramp-compat-time-equal-p (nth 6 attr1) tramp-time-dont-know) (tramp-compat-time-equal-p (nth 6 attr2) tramp-time-dont-know)) (setcar (nthcdr 6 attr1) tramp-time-dont-know) (setcar (nthcdr 6 attr2) tramp-time-dont-know)) - (when (<= start-time (floor (float-time (nth 6 attr1)))) + (when (< start-time (float-time (nth 6 attr1))) (setcar (nthcdr 6 attr1) tramp-time-dont-know)) - (when (<= start-time (floor (float-time (nth 6 attr2)))) + (when (< start-time (float-time (nth 6 attr2))) (setcar (nthcdr 6 attr2) tramp-time-dont-know)) ;; Size. Set it to 0 for directories, because it might have ;; changed. For example the upper directory "../". commit fae1ff69c3fd84f208b7b803adafeb95a36e44e7 Author: Mauro Aranda Date: Wed Aug 7 11:55:54 2019 -0300 Fix docstrings in pong * lisp/play/pong.el (pong-move-left pong-move-right): Refer to the right bats and directions of movement. (Bug#36959) diff --git a/lisp/play/pong.el b/lisp/play/pong.el index 555c1939d2..13fe8b82a4 100644 --- a/lisp/play/pong.el +++ b/lisp/play/pong.el @@ -262,7 +262,7 @@ (defun pong-move-left () - "Move bat 2 up. + "Move bat 1 up. This is called left for historical reasons, since in some pong implementations you move with left/right paddle." (interactive) @@ -274,7 +274,7 @@ implementations you move with left/right paddle." (defun pong-move-right () - "Move bat 2 up." + "Move bat 1 down." (interactive) (if (< (+ pong-bat-player1 pong-bat-width) (1- pong-height)) (and commit 7ff96f95d7d67fc1489fca9fd3ab4a99328a5b8a Author: Mauro Aranda Date: Tue Aug 6 21:48:41 2019 -0300 Fix pong collision detection * lisp/play/pong.el (pong-update-game): If the ball hit the bat where bats are positioned, draw again the bat cell in the old ball position. (Bug#20579). Also, avoid changing the direction of the ball right after hitting the bats, and improve the collision detection against the borders. diff --git a/lisp/play/pong.el b/lisp/play/pong.el index 555c1939d2..759dbb404c 100644 --- a/lisp/play/pong.el +++ b/lisp/play/pong.el @@ -349,46 +349,61 @@ detection and checks if a player scores." (let ((old-x pong-x) (old-y pong-y)) - + ;; Erase the last ball position. + (when (and (> old-y 0) + (< old-y (- pong-height 1))) + ;; If the ball hit the bat in the column where bats are positioned, + ;; and therefore changed its x direction, draw again the bat cell. + (if (or (and (= old-x 2) (< 0 pong-xx)) + (and (= old-x (- pong-width 3)) (> 0 pong-xx))) + (gamegrid-set-cell old-x old-y pong-bat) + (gamegrid-set-cell old-x old-y pong-blank))) + + ;; Update the ball position. (setq pong-x (+ pong-x pong-xx)) - (setq pong-y (+ pong-y pong-yy)) - - (if (and (> old-y 0) - (< old-y (- pong-height 1))) - (gamegrid-set-cell old-x old-y pong-blank)) - + ;; If the ball would go out of bounds, put it against the border. + (cond + ((<= (+ pong-y pong-yy) 0) + (setq pong-yy (- pong-yy)) + (setq pong-y 1)) + ((>= (+ pong-y pong-yy) (- pong-height 1)) + (setq pong-yy (- pong-yy)) + (setq pong-y (- pong-height 2))) + (t + (setq pong-y (+ pong-y pong-yy)) + ;; Check if the ball is against the border now, + ;; and change the y direction if it is. + (when (or (<= pong-y 1) (>= pong-y (- pong-height 2))) + (setq pong-yy (- pong-yy))))) + + ;; Draw the ball in its new position. (if (and (> pong-y 0) (< pong-y (- pong-height 1))) (gamegrid-set-cell pong-x pong-y pong-ball)) + ;; Hit bat, score a goal, or nothing. (cond - ((or (= pong-x 3) (= pong-x 2)) - (if (and (>= pong-y pong-bat-player1) - (< pong-y (+ pong-bat-player1 pong-bat-width))) - (and - (setq pong-yy (+ pong-yy - (cond - ((= pong-y pong-bat-player1) -1) - ((= pong-y (1+ pong-bat-player1)) 0) - (t 1)))) - (setq pong-xx (- pong-xx))))) - - ((or (= pong-x (- pong-width 4)) (= pong-x (- pong-width 3))) - (if (and (>= pong-y pong-bat-player2) - (< pong-y (+ pong-bat-player2 pong-bat-width))) - (and - (setq pong-yy (+ pong-yy - (cond - ((= pong-y pong-bat-player2) -1) - ((= pong-y (1+ pong-bat-player2)) 0) - (t 1)))) - (setq pong-xx (- pong-xx))))) - - ((<= pong-y 1) - (setq pong-yy (- pong-yy))) - - ((>= pong-y (- pong-height 2)) - (setq pong-yy (- pong-yy))) + ((and (or (= pong-x 3) (= pong-x 2)) + (> 0 pong-xx) ; Collide with the bat if headed towards it. + (>= pong-y pong-bat-player1) + (< pong-y (+ pong-bat-player1 pong-bat-width))) + (setq pong-yy (+ pong-yy + (cond + ((= pong-y pong-bat-player1) -1) + ((= pong-y (1+ pong-bat-player1)) 0) + (t 1)))) + (setq pong-xx (- pong-xx))) + + ((and (or (= pong-x (- pong-width 4)) (= pong-x (- pong-width 3))) + (< 0 pong-xx) ; Collide with the bat if headed towards it. + (>= pong-y pong-bat-player2) + (< pong-y (+ pong-bat-player2 pong-bat-width))) + (setq pong-yy (+ pong-yy + (cond + ((= pong-y pong-bat-player2) -1) + ((= pong-y (1+ pong-bat-player2)) 0) + (t 1)))) + (setq pong-xx (- pong-xx))) ((< pong-x 1) (setq pong-score-player2 (1+ pong-score-player2)) commit e503e9d35f80ff064c9f0ef24e514b00f5e214f9 Author: Alex Gramiak Date: Fri May 31 14:30:31 2019 -0600 Set up defined_color_hook for the initial frame * src/terminal.c (init_initial_terminal): Set up the defined_color_hook. This avoids crashes when running in batch mode with code that manipulates colors. (Bug#36019) diff --git a/src/terminal.c b/src/terminal.c index bb02d58661..dfcd5b0a83 100644 --- a/src/terminal.c +++ b/src/terminal.c @@ -622,6 +622,7 @@ init_initial_terminal (void) initial_terminal->kboard = initial_kboard; initial_terminal->delete_terminal_hook = &delete_initial_terminal; initial_terminal->delete_frame_hook = &initial_free_frame_resources; + initial_terminal->defined_color_hook = &tty_defined_color; /* xfaces.c */ /* Other hooks are NULL by default. */ return initial_terminal; commit 65e4ebdfb6e78abac68ba9b9422fa6cd77028c16 Author: Philippe Schnoebelen Date: Sun Jul 28 08:59:12 2019 +0200 Support bool-vectors in cl-extra.el * lisp/emacs-lisp/cl-extra.el (cl-coerce): Support bool-vector. Copyright-paperwork-exempt: yes diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 4dc2e9de58..3a6def733f 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -48,6 +48,8 @@ TYPE is a Common Lisp type specifier. \n(fn OBJECT TYPE)" (cond ((eq type 'list) (if (listp x) x (append x nil))) ((eq type 'vector) (if (vectorp x) x (vconcat x))) + ((eq type 'bool-vector) + (if (bool-vector-p x) x (apply #'bool-vector (cl-coerce x 'list)))) ((eq type 'string) (if (stringp x) x (concat x))) ((eq type 'array) (if (arrayp x) x (vconcat x))) ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0)) commit 721035d61c88967fe1f8f24c3c4a10f4b6237326 Author: Juri Linkov Date: Fri Aug 9 21:08:54 2019 +0300 * lisp/frameset.el (frameset--minibufferless-last-p): Add comments (bug#36894) diff --git a/lisp/frameset.el b/lisp/frameset.el index a8b16706c2..60b6fe38ad 100644 --- a/lisp/frameset.el +++ b/lisp/frameset.el @@ -1104,9 +1104,18 @@ It sorts minibuffer-owning frames before minibufferless ones. Internal use only." (pcase-let ((`(,hasmini1 . ,id-def1) (cdr (assq 'frameset--mini (car state1)))) (`(,hasmini2 . ,id-def2) (cdr (assq 'frameset--mini (car state2))))) - (cond ((eq id-def1 t) t) + ;; hasmini1 is t when 1st frame has its own minibuffer + ;; hasmini2 is t when 2nd frame has its own minibuffer + ;; id-def1 is t when 1st minibuffer-owning frame is the default-minibuffer-frame + ;; or frame-id of 1st frame if it's minibufferless + ;; id-def2 is t when 2nd minibuffer-owning frame is the default-minibuffer-frame + ;; or frame-id of 2nd frame if it's minibufferless + (cond ;; Sort the minibuffer-owning default-minibuffer-frame first + ((eq id-def1 t) t) ((eq id-def2 t) nil) - ((not (eq hasmini1 hasmini2)) (eq hasmini1 t)) + ;; Sort non-default minibuffer-owning frames before minibufferless + ((not (eq hasmini1 hasmini2)) (eq hasmini1 t)) ;; boolean xor + ;; Sort minibufferless frames with frame-id before some remaining ((eq hasmini1 nil) (or id-def1 id-def2)) (t t)))) commit 495b33bb3858fbb8912f7d357e1d277062b98bcd Author: Eli Zaretskii Date: Fri Aug 9 16:51:14 2019 +0300 Fix highlighting in man pages displayed by "M-x man" * lisp/man.el (Man-highlight-references0): Handle the case when a section is divided between 2 or more chunks of text received from the 'man' program. (Bug#36927) diff --git a/lisp/man.el b/lisp/man.el index d52ca2156d..8858451b38 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -1288,8 +1288,23 @@ default type, `Man-xref-man-page' is used for the buttons." (defun Man-highlight-references0 (start-section regexp button-pos target type) ;; Based on `Man-build-references-alist' - (when (or (null start-section) - (Man-find-section start-section)) + (when (or (null start-section) ;; Search regardless of sections. + ;; Section header is in this chunk. + (Man-find-section start-section) + ;; Section header was in one of the previous chunks. + (save-excursion + (save-restriction + (let ((orig-pos (point))) + (widen) + (if (Man-find-section start-section) + ;; We are in the right section of the next + ;; section is either not yet in the buffer, or + ;; it starts after the position where we should + ;; start highlighting. + (progn + (forward-line 1) + (or (null (re-search-forward Man-heading-regexp nil t)) + (> (point) orig-pos)))))))) (let ((end (if start-section (progn (forward-line 1) commit 82a2894be479ea88ebe28e72a7709b94203b096c Author: Eli Zaretskii Date: Fri Aug 9 10:31:39 2019 +0300 Improve doc strings of 'append-to-buffer' and friends * lisp/simple.el (append-to-buffer, prepend-to-buffer) (copy-to-buffer): Doc fixes. diff --git a/lisp/simple.el b/lisp/simple.el index b10c7861d1..b5c7052184 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -5268,8 +5268,10 @@ BUFFER may be a buffer or a buffer name." nil) (defun append-to-buffer (buffer start end) - "Append to specified buffer the text of the region. -It is inserted into that buffer before its point. + "Append to specified BUFFER the text of the region. +The text is inserted into that buffer before its point. +BUFFER can be a buffer or the name of a buffer; this +function will create BUFFER if it doesn't already exist. When calling from a program, give three arguments: BUFFER (or buffer name), START and END. @@ -5291,8 +5293,10 @@ START and END specify the portion of the current buffer to be copied." (set-window-point window (point)))))))) (defun prepend-to-buffer (buffer start end) - "Prepend to specified buffer the text of the region. -It is inserted into that buffer after its point. + "Prepend to specified BUFFER the text of the region. +The text is inserted into that buffer after its point. +BUFFER can be a buffer or the name of a buffer; this +function will create BUFFER if it doesn't already exist. When calling from a program, give three arguments: BUFFER (or buffer name), START and END. @@ -5305,8 +5309,10 @@ START and END specify the portion of the current buffer to be copied." (insert-buffer-substring oldbuf start end))))) (defun copy-to-buffer (buffer start end) - "Copy to specified buffer the text of the region. -It is inserted into that buffer, replacing existing text there. + "Copy to specified BUFFER the text of the region. +The text is inserted into that buffer, replacing existing text there. +BUFFER can be a buffer or the name of a buffer; this +function will create BUFFER if it doesn't already exist. When calling from a program, give three arguments: BUFFER (or buffer name), START and END. commit bf10b8c3e8d8c45be47bb3c529017d3cb5562178 Author: Eli Zaretskii Date: Fri Aug 9 10:02:23 2019 +0300 Fix doc strings modified in recent changes * src/xfns.c (Fx_change_window_property) (Fx_delete_window_property, Fx_window_property) (Fx_window_property_attributes): Doc fixes. diff --git a/src/xfns.c b/src/xfns.c index dfb48dd3a4..31ae4cc225 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -5737,8 +5737,8 @@ FORMAT gives the size in bits of each element if VALUE is a list. If OUTER-P is non-nil, the property is changed for the outer X window of FRAME. Default is to change on the edit X window. If WINDOW-ID is non-nil, change the property of that window instead - of FRAME; the number 0 denotes the root window. This argument is - separate from FRAME because window IDs are not unique across X + of FRAME's X window; the number 0 denotes the root window. This argument + is separate from FRAME because window IDs are not unique across X displays or screens on the same display, so FRAME provides context for the window ID. */) (Lisp_Object prop, Lisp_Object value, Lisp_Object frame, @@ -5840,12 +5840,12 @@ DEFUN ("x-delete-window-property", Fx_delete_window_property, doc: /* Remove window property PROP from X window of FRAME. FRAME nil or omitted means use the selected frame. If WINDOW-ID is non-nil, remove property from that window instead - of FRAME; the number 0 denotes the root window. This argument is - separate from FRAME because window IDs are not unique across X - displays or screens on the same display, so FRAME provides context - for the window ID. + of FRAME's X window; the number 0 denotes the root window. This + argument is separate from FRAME because window IDs are not unique + across X displays or screens on the same display, so FRAME provides + context for the window ID. -Return value is PROP. */) +Value is PROP. */) (Lisp_Object prop, Lisp_Object frame, Lisp_Object window_id) { struct frame *f = decode_window_system_frame (frame); @@ -5957,17 +5957,17 @@ If FRAME is nil or omitted, use the selected frame. On X Windows, the following optional arguments are also accepted: If TYPE is nil or omitted, get the property as a string. - Otherwise TYPE is the name of the atom that denotes the type expected. + Otherwise TYPE is the name of the atom that denotes the expected type. If WINDOW-ID is non-nil, get the property of that window instead of - FRAME; the number 0 denotes the root window. This argument is - separate from FRAME because window IDs are not unique across X + FRAME's X window; the number 0 denotes the root window. This argument + is separate from FRAME because window IDs are not unique across X displays or screens on the same display, so FRAME provides context for the window ID. If DELETE-P is non-nil, delete the property after retrieving it. -If VECTOR-RET-P is non-nil, don't return a string but a vector of values. +If VECTOR-RET-P is non-nil, return a vector of values instead of a string. Return value is nil if FRAME doesn't have a property with name PROP or -if PROP has no value of TYPE (always string in the MS Windows case). */) +if PROP has no value of TYPE (always a string in the MS Windows case). */) (Lisp_Object prop, Lisp_Object frame, Lisp_Object type, Lisp_Object window_id, Lisp_Object delete_p, Lisp_Object vector_ret_p) { @@ -6028,12 +6028,12 @@ DEFUN ("x-window-property-attributes", Fx_window_property_attributes, Sx_window_ doc: /* Retrieve metadata about window property PROP on FRAME. If FRAME is nil or omitted, use the selected frame. If WINDOW-ID is non-nil, get the property of that window instead of - FRAME; the number 0 denotes the root window. This argument is - separate from FRAME because window IDs are not unique across X - displays or screens on the same display, so FRAME provides context - for the window ID. + FRAME's X window; the number 0 denotes the root window. This + argument is separate from FRAME because window IDs are not unique + across X displays or screens on the same display, so FRAME provides + context for the window ID. -Return value is nil if FRAME doesn't have a property with name PROP. +Return value is nil if FRAME doesn't have a property named PROP. Otherwise, the return value is a vector with the following fields: 0. The property type, as an integer. The symbolic name of commit d6713add69c7a696627e68e2b84c4aa7aaf05000 Author: Noah Friedman Date: Thu Aug 8 23:17:56 2019 -0700 Provide better target window consistency across x window property functions. Use the argument name WINDOW-ID instead of SOURCE for same. Revise docstrings to clarify semantics of FRAME and WINDOW-ID. (Fx_change_window_property): Use `target_window' instead of `w'. This is consistent with other related functions. Finalize its value before blocking input. (Fx_window_property): (Fx_window_property_attributes): Use `window_id' instead of `source'. (Fx_delete_window_property): New optional arg window_id. diff --git a/src/xfns.c b/src/xfns.c index bc3490d59b..dfb48dd3a4 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -5730,14 +5730,17 @@ top bits and the cdr is the lower 16 bits. FRAME nil or omitted means use the selected frame. If TYPE is given and non-nil, it is the name of the type of VALUE. -If TYPE is not given or nil, the type is STRING. + If TYPE is not given or nil, the type is STRING. FORMAT gives the size in bits of each element if VALUE is a list. -It must be one of 8, 16 or 32. -If VALUE is a string or FORMAT is nil or not given, FORMAT defaults to 8. + It must be one of 8, 16 or 32. + If VALUE is a string or FORMAT is nil or not given, FORMAT defaults to 8. If OUTER-P is non-nil, the property is changed for the outer X window of -FRAME. Default is to change on the edit X window. -If WINDOW-ID is non-nil, set the property on that window instead of FRAME. -The number 0 denotes the root window. */) + FRAME. Default is to change on the edit X window. +If WINDOW-ID is non-nil, change the property of that window instead + of FRAME; the number 0 denotes the root window. This argument is + separate from FRAME because window IDs are not unique across X + displays or screens on the same display, so FRAME provides context + for the window ID. */) (Lisp_Object prop, Lisp_Object value, Lisp_Object frame, Lisp_Object type, Lisp_Object format, Lisp_Object outer_p, Lisp_Object window_id) @@ -5748,7 +5751,7 @@ The number 0 denotes the root window. */) int element_format = 8; unsigned char *data; int nelements; - Window w; + Window target_window; CHECK_STRING (prop); @@ -5796,6 +5799,20 @@ The number 0 denotes the root window. */) nelements = SBYTES (value) / elsize; } + if (! NILP (window_id)) + { + CONS_TO_INTEGER (window_id, Window, target_window); + if (! target_window) + target_window = FRAME_DISPLAY_INFO (f)->root_window; + } + else + { + if (! NILP (outer_p)) + target_window = FRAME_OUTER_WINDOW (f); + else + target_window = FRAME_X_WINDOW (f); + } + block_input (); prop_atom = XInternAtom (FRAME_X_DISPLAY (f), SSDATA (prop), False); if (! NILP (type)) @@ -5804,19 +5821,7 @@ The number 0 denotes the root window. */) target_type = XInternAtom (FRAME_X_DISPLAY (f), SSDATA (type), False); } - if (! NILP (window_id)) - { - CONS_TO_INTEGER (window_id, Window, w); - if (! w) - w = FRAME_DISPLAY_INFO (f)->root_window; - } - else - { - if (! NILP (outer_p)) w = FRAME_OUTER_WINDOW (f); - else w = FRAME_X_WINDOW (f); - } - - XChangeProperty (FRAME_X_DISPLAY (f), w, + XChangeProperty (FRAME_X_DISPLAY (f), target_window, prop_atom, target_type, element_format, PropModeReplace, data, nelements); @@ -5831,18 +5836,34 @@ The number 0 denotes the root window. */) DEFUN ("x-delete-window-property", Fx_delete_window_property, - Sx_delete_window_property, 1, 2, 0, + Sx_delete_window_property, 1, 3, 0, doc: /* Remove window property PROP from X window of FRAME. -FRAME nil or omitted means use the selected frame. Value is PROP. */) - (Lisp_Object prop, Lisp_Object frame) +FRAME nil or omitted means use the selected frame. +If WINDOW-ID is non-nil, remove property from that window instead + of FRAME; the number 0 denotes the root window. This argument is + separate from FRAME because window IDs are not unique across X + displays or screens on the same display, so FRAME provides context + for the window ID. + +Return value is PROP. */) + (Lisp_Object prop, Lisp_Object frame, Lisp_Object window_id) { struct frame *f = decode_window_system_frame (frame); + Window target_window = FRAME_X_WINDOW (f); Atom prop_atom; CHECK_STRING (prop); + + if (! NILP (window_id)) + { + CONS_TO_INTEGER (window_id, Window, target_window); + if (! target_window) + target_window = FRAME_DISPLAY_INFO (f)->root_window; + } + block_input (); prop_atom = XInternAtom (FRAME_X_DISPLAY (f), SSDATA (prop), False); - XDeleteProperty (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), prop_atom); + XDeleteProperty (FRAME_X_DISPLAY (f), target_window, prop_atom); /* Make sure the property is removed when we return. */ XFlush (FRAME_X_DISPLAY (f)); @@ -5936,16 +5957,19 @@ If FRAME is nil or omitted, use the selected frame. On X Windows, the following optional arguments are also accepted: If TYPE is nil or omitted, get the property as a string. -Otherwise TYPE is the name of the atom that denotes the type expected. -If SOURCE is non-nil, get the property on that window instead of from -FRAME. The number 0 denotes the root window. + Otherwise TYPE is the name of the atom that denotes the type expected. +If WINDOW-ID is non-nil, get the property of that window instead of + FRAME; the number 0 denotes the root window. This argument is + separate from FRAME because window IDs are not unique across X + displays or screens on the same display, so FRAME provides context + for the window ID. If DELETE-P is non-nil, delete the property after retrieving it. If VECTOR-RET-P is non-nil, don't return a string but a vector of values. -Value is nil if FRAME hasn't a property with name PROP or if PROP has -no value of TYPE (always string in the MS Windows case). */) +Return value is nil if FRAME doesn't have a property with name PROP or +if PROP has no value of TYPE (always string in the MS Windows case). */) (Lisp_Object prop, Lisp_Object frame, Lisp_Object type, - Lisp_Object source, Lisp_Object delete_p, Lisp_Object vector_ret_p) + Lisp_Object window_id, Lisp_Object delete_p, Lisp_Object vector_ret_p) { struct frame *f = decode_window_system_frame (frame); Atom prop_atom; @@ -5956,11 +5980,11 @@ no value of TYPE (always string in the MS Windows case). */) CHECK_STRING (prop); - if (! NILP (source)) + if (! NILP (window_id)) { - CONS_TO_INTEGER (source, Window, target_window); + CONS_TO_INTEGER (window_id, Window, target_window); if (! target_window) - target_window = FRAME_DISPLAY_INFO (f)->root_window; + target_window = FRAME_DISPLAY_INFO (f)->root_window; } block_input (); @@ -5982,7 +6006,7 @@ no value of TYPE (always string in the MS Windows case). */) &found); if (NILP (prop_value) && ! found - && NILP (source) + && NILP (window_id) && target_window != FRAME_OUTER_WINDOW (f)) { prop_value = x_window_property_intern (f, @@ -6003,17 +6027,20 @@ DEFUN ("x-window-property-attributes", Fx_window_property_attributes, Sx_window_ 1, 3, 0, doc: /* Retrieve metadata about window property PROP on FRAME. If FRAME is nil or omitted, use the selected frame. -If SOURCE is non-nil, get the property on that window instead of from -FRAME. The number 0 denotes the root window. +If WINDOW-ID is non-nil, get the property of that window instead of + FRAME; the number 0 denotes the root window. This argument is + separate from FRAME because window IDs are not unique across X + displays or screens on the same display, so FRAME provides context + for the window ID. -Return value is nil if FRAME hasn't a property with name PROP. +Return value is nil if FRAME doesn't have a property with name PROP. Otherwise, the return value is a vector with the following fields: 0. The property type, as an integer. The symbolic name of the type can be obtained with `x-get-atom-name'. 1. The format of each element; one of 8, 16, or 32. 2. The length of the property, in number of elements. */) - (Lisp_Object prop, Lisp_Object frame, Lisp_Object source) + (Lisp_Object prop, Lisp_Object frame, Lisp_Object window_id) { struct frame *f = decode_window_system_frame (frame); Window target_window = FRAME_X_WINDOW (f); @@ -6027,9 +6054,9 @@ Otherwise, the return value is a vector with the following fields: CHECK_STRING (prop); - if (! NILP (source)) + if (! NILP (window_id)) { - CONS_TO_INTEGER (source, Window, target_window); + CONS_TO_INTEGER (window_id, Window, target_window); if (! target_window) target_window = FRAME_DISPLAY_INFO (f)->root_window; } @@ -6043,7 +6070,7 @@ Otherwise, the return value is a vector with the following fields: &bytes_remaining, &tmp_data); if (rc == Success /* no invalid params */ && actual_format == 0 /* but prop not found */ - && NILP (source) + && NILP (window_id) && target_window != FRAME_OUTER_WINDOW (f)) { /* analogous behavior to x-window-property: if property isn't found commit 5a904c477be1787057965bdff023d9d9d89d9870 Author: Noah Friedman Date: Thu Aug 8 21:52:37 2019 -0700 (Fx_change_window_property): Rename SOURCE arg to WINDOW-ID diff --git a/src/xfns.c b/src/xfns.c index 5f5194d78f..bc3490d59b 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -5736,11 +5736,11 @@ It must be one of 8, 16 or 32. If VALUE is a string or FORMAT is nil or not given, FORMAT defaults to 8. If OUTER-P is non-nil, the property is changed for the outer X window of FRAME. Default is to change on the edit X window. -If SOURCE is non-nil, set the property on that window instead of from -FRAME. The number 0 denotes the root window. */) +If WINDOW-ID is non-nil, set the property on that window instead of FRAME. +The number 0 denotes the root window. */) (Lisp_Object prop, Lisp_Object value, Lisp_Object frame, Lisp_Object type, Lisp_Object format, Lisp_Object outer_p, - Lisp_Object source) + Lisp_Object window_id) { struct frame *f = decode_window_system_frame (frame); Atom prop_atom; @@ -5804,9 +5804,9 @@ FRAME. The number 0 denotes the root window. */) target_type = XInternAtom (FRAME_X_DISPLAY (f), SSDATA (type), False); } - if (! NILP (source)) + if (! NILP (window_id)) { - CONS_TO_INTEGER (source, Window, w); + CONS_TO_INTEGER (window_id, Window, w); if (! w) w = FRAME_DISPLAY_INFO (f)->root_window; } commit 8f93dce7c0bf0d1bb0b27a6f2416fd2d404cb6a9 Author: Noah Friedman Date: Wed Aug 7 18:18:32 2019 -0700 (Fx_change_window_property): Add optional arg SOURCE. This provides symmetry with Fx_window_property, so that the window need not be an actual emacs frame. This is useful for modifying properties of parent windows (specified with --parent-id to emacs) or generally assisting the window manager. diff --git a/src/xfns.c b/src/xfns.c index b8a1914186..5f5194d78f 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -5720,7 +5720,7 @@ x_sync (struct frame *f) ***********************************************************************/ DEFUN ("x-change-window-property", Fx_change_window_property, - Sx_change_window_property, 2, 6, 0, + Sx_change_window_property, 2, 7, 0, doc: /* Change window property PROP to VALUE on the X window of FRAME. PROP must be a string. VALUE may be a string or a list of conses, numbers and/or strings. If an element in the list is a string, it is @@ -5735,9 +5735,12 @@ FORMAT gives the size in bits of each element if VALUE is a list. It must be one of 8, 16 or 32. If VALUE is a string or FORMAT is nil or not given, FORMAT defaults to 8. If OUTER-P is non-nil, the property is changed for the outer X window of -FRAME. Default is to change on the edit X window. */) +FRAME. Default is to change on the edit X window. +If SOURCE is non-nil, set the property on that window instead of from +FRAME. The number 0 denotes the root window. */) (Lisp_Object prop, Lisp_Object value, Lisp_Object frame, - Lisp_Object type, Lisp_Object format, Lisp_Object outer_p) + Lisp_Object type, Lisp_Object format, Lisp_Object outer_p, + Lisp_Object source) { struct frame *f = decode_window_system_frame (frame); Atom prop_atom; @@ -5801,8 +5804,17 @@ FRAME. Default is to change on the edit X window. */) target_type = XInternAtom (FRAME_X_DISPLAY (f), SSDATA (type), False); } - if (! NILP (outer_p)) w = FRAME_OUTER_WINDOW (f); - else w = FRAME_X_WINDOW (f); + if (! NILP (source)) + { + CONS_TO_INTEGER (source, Window, w); + if (! w) + w = FRAME_DISPLAY_INFO (f)->root_window; + } + else + { + if (! NILP (outer_p)) w = FRAME_OUTER_WINDOW (f); + else w = FRAME_X_WINDOW (f); + } XChangeProperty (FRAME_X_DISPLAY (f), w, prop_atom, target_type, element_format, PropModeReplace, commit 0428d0e96be41686858b030eeb4ff27f52822566 Author: Stefan Kangas Date: Thu Jul 11 05:51:18 2019 +0200 Use "python -m pdb" when "pdb" is missing in M-x pdb * lisp/progmodes/gud.el (gud-pdb-command-name): Use "python -m pdb" when "pdb" is missing. (Bug#21521) diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index b6a4ad3cd0..30d4b19911 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -1673,9 +1673,10 @@ and source-file directory for your debugger." output)) -(defcustom gud-pdb-command-name "pdb" - "File name for executing the Python debugger. -This should be an executable on your path, or an absolute file name." +(defcustom gud-pdb-command-name + (if (executable-find "pdb") "pdb" "python -m pdb") + "Command that executes the Python debugger." + :version "27.1" :type 'string :group 'gud) commit b055ec0d85848987d0ba3962c32fb822b292dfd7 Author: Noam Postavsky Date: Thu Aug 8 19:35:53 2019 -0400 Say how to enable event designators in the eshell manual * doc/misc/eshell.texi (History): Mention that event designators need to be enabled. * etc/NEWS: Mark corresponding entry as documented in manual. diff --git a/doc/misc/eshell.texi b/doc/misc/eshell.texi index 716b4b7a50..9aba6006b1 100644 --- a/doc/misc/eshell.texi +++ b/doc/misc/eshell.texi @@ -462,10 +462,14 @@ The n-th entry of the history ring can be applied with the @samp{!n} command. If @code{n} is negative, the entry is counted from the end of the history ring. -@samp{!foo} expands to the last command beginning with @code{foo}, and -@samp{!?foo} to the last command containing @code{foo}. The n-th -argument of the last command beginning with @code{foo} is accessible -by @code{!foo:n}. +@cindex event designators +@findex eshell-expand-history-references +When history event designators are enabled (by adding +@code{eshell-expand-history-references} to +@code{eshell-expand-input-functions}), @samp{!foo} expands to the last +command beginning with @code{foo}, and @samp{!?foo} to the last +command containing @code{foo}. The n-th argument of the last command +beginning with @code{foo} is accessible by @code{!foo:n}. The history ring is loaded from a file at the start of every session, and written back to the file at the end of every session. The file path diff --git a/etc/NEWS b/etc/NEWS index 818875f7a0..e8618152ed 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1346,7 +1346,7 @@ default, and not just the opening element. behave similarly, e.g. Pcomplete's default cycling can be obtained with '(setq completion-cycle-threshold 5)'. ---- ++++ *** Expansion of history event designators is disabled by default. To restore the old behavior, use commit cb0403d7467502a1a9ef2699ccce826aac2ace7a Author: Mauro Aranda Date: Tue Aug 6 12:45:28 2019 -0300 Fix octave-mode ElDoc support * lisp/progmodes/octave.el (octave-eldoc-function-signatures): Fix the regexp used, so no match happens when there is no defined function FN. Also, tweak the regexp to support GNU Octave 4.2.x and newer. (Bug#36459) diff --git a/lisp/progmodes/octave.el b/lisp/progmodes/octave.el index 6caf8d93d3..76181892cd 100644 --- a/lisp/progmodes/octave.el +++ b/lisp/progmodes/octave.el @@ -1591,8 +1591,23 @@ code line." (list (format "print_usage ('%s');\n" fn))) (let (result) (dolist (line inferior-octave-output-list) + ;; The help output has changed a few times in GNU Octave. + ;; Earlier versions output "usage: " before the function signature. + ;; After deprecating the usage function, and up until GNU Octave 4.0.3, + ;; the output looks like this: + ;; -- Mapping Function: abs (Z). + ;; After GNU Octave 4.2.0, the output is less verbose and it looks like + ;; this: + ;; -- abs (Z) + ;; The following regexp matches these three formats. + ;; The "usage: " alternative matches the symbol, because a call to + ;; print_usage with a non-existent function (e.g., print_usage ('A')) + ;; would output: + ;; error: print_usage: 'A' not found + ;; and we wouldn't like to match anything in this case. + ;; See bug #36459. (when (string-match - "\\s-*\\(?:--[^:]+\\|usage\\):\\s-*\\(.*\\)$" + "\\s-*\\(?:--[^:]+:\\|\\_ Date: Thu Aug 8 16:47:29 2019 +0200 Work on Tramp backward compatibility * lisp/net/tramp-adb.el (tramp-adb-handle-copy-file) (tramp-adb-handle-rename-file): * lisp/net/tramp-gvfs.el (tramp-gvfs-do-copy-or-rename-file): * lisp/net/tramp-rclone.el (tramp-rclone-do-copy-or-rename-file): * lisp/net/tramp-sh.el (tramp-do-copy-or-rename-file): * lisp/net/tramp-smb.el (tramp-smb-handle-copy-file) (tramp-smb-handle-rename-file): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-do-copy-or-rename-file): Use `tramp-compat-directory-name-p'. diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 475f9a2e2b..2192f7f025 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -704,7 +704,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (with-parsed-tramp-file-name (if t1 filename newname) nil (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) (not (directory-name-p newname))) + (when (and (file-directory-p newname) + (not (tramp-compat-directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter @@ -781,7 +782,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (with-parsed-tramp-file-name (if t1 filename newname) nil (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) (not (directory-name-p newname))) + (when (and (file-directory-p newname) + (not (tramp-compat-directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 8cec5871cf..f10476a7bc 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -766,7 +766,8 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) (not (directory-name-p newname))) + (when (and (file-directory-p newname) + (not (tramp-compat-directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (if (or (and equal-remote diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index e0fd8e3441..866e7791bf 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -215,7 +215,8 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) (not (directory-name-p newname))) + (when (and (file-directory-p newname) + (not (tramp-compat-directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (if (or (and t1 (not (tramp-rclone-file-name-p filename))) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 54bf2ba773..6e18e7330c 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1993,7 +1993,8 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) (not (directory-name-p newname))) + (when (and (file-directory-p newname) + (not (tramp-compat-directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 594463d77f..b619e77a52 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -589,7 +589,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (directory-name-p newname))) + (not (tramp-compat-directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) ;; We must also flush the cache of the directory, because @@ -1334,7 +1334,8 @@ component is used as the target of the symlink." (if (tramp-tramp-file-p filename) filename newname) nil (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) (not (directory-name-p newname))) + (when (and (file-directory-p newname) + (not (tramp-compat-directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 0ec98bb069..5d5a3f1f75 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -243,7 +243,8 @@ absolute file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) (not (directory-name-p newname))) + (when (and (file-directory-p newname) + (not (tramp-compat-directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (if (or (and (file-remote-p filename) (not t1)) commit 78ddf6ba96039920d9ac0086b8a87a8a068227ef Author: Michael Albinus Date: Thu Aug 8 15:42:45 2019 +0200 Improve time arithmetic in tramp--test-file-attributes-equal-p * test/lisp/net/tramp-tests.el (tramp--test-file-attributes-equal-p): Improve time arithmetic. diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index bcc74cc3a2..7a1ae5273e 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -3089,9 +3089,11 @@ They might differ only in time attributes or directory size." (let ((attr1 (copy-sequence attr1)) (attr2 (copy-sequence attr2)) (start-time - (aref - (ert--stats-test-start-times ert--current-run-stats) - (ert--stats-test-pos ert--current-run-stats (ert-running-test))))) + (floor + (float-time + (aref + (ert--stats-test-start-times ert--current-run-stats) + (ert--stats-test-pos ert--current-run-stats (ert-running-test))))))) ;; Access time. (setcar (nthcdr 4 attr1) tramp-time-dont-know) (setcar (nthcdr 4 attr2) tramp-time-dont-know) @@ -3104,24 +3106,25 @@ They might differ only in time attributes or directory size." (tramp-compat-time-equal-p (nth 5 attr2) tramp-time-dont-know)) (setcar (nthcdr 5 attr1) tramp-time-dont-know) (setcar (nthcdr 5 attr2) tramp-time-dont-know)) - (when (time-less-p start-time (nth 5 attr1)) + (when (<= start-time (floor (float-time (nth 5 attr1)))) (setcar (nthcdr 5 attr1) tramp-time-dont-know)) - (when (time-less-p start-time (nth 5 attr2)) + (when (<= start-time (floor (float-time (nth 5 attr2)))) (setcar (nthcdr 5 attr2) tramp-time-dont-know)) ;; Status change time. Dito. (when (or (tramp-compat-time-equal-p (nth 6 attr1) tramp-time-dont-know) (tramp-compat-time-equal-p (nth 6 attr2) tramp-time-dont-know)) (setcar (nthcdr 6 attr1) tramp-time-dont-know) (setcar (nthcdr 6 attr2) tramp-time-dont-know)) - (when (time-less-p start-time (nth 6 attr1)) + (when (<= start-time (floor (float-time (nth 6 attr1)))) (setcar (nthcdr 6 attr1) tramp-time-dont-know)) - (when (time-less-p start-time (nth 6 attr2)) + (when (<= start-time (floor (float-time (nth 6 attr2)))) (setcar (nthcdr 6 attr2) tramp-time-dont-know)) ;; Size. Set it to 0 for directories, because it might have ;; changed. For example the upper directory "../". (when (eq (car attr1) t) (setcar (nthcdr 7 attr1) 0)) (when (eq (car attr2) t) (setcar (nthcdr 7 attr2) 0)) ;; The check. + (unless (equal attr1 attr2) (tramp--test-message "%S\n%S" attr1 attr2)) (equal attr1 attr2))) ;; This isn't 100% correct, but better than no explainer at all. commit 4084c16090d24e375d198c0f0e65b76afb6049a0 Author: Michael Albinus Date: Thu Aug 8 15:42:06 2019 +0200 Suppress false alarm in Tramp * lisp/net/tramp.el (tramp-dissect-file-name): Suppress false alarm. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 77d727e2f2..7bae434723 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1440,7 +1440,7 @@ default values are used." :method method :user user :domain domain :host host :port port :localname localname :hop hop)) ;; The method must be known. - (unless (or (tramp-completion-mode-p) + (unless (or nodefault (tramp-completion-mode-p) (string-equal method tramp-default-method-marker) (assoc method tramp-methods)) (tramp-user-error commit 691790b8ea5192395a2eeac0f89a2f41d74f2ddb Author: Eli Zaretskii Date: Thu Aug 8 16:17:51 2019 +0300 Avoid Groff hanging on MS-Windows when invoked by "M-x man" * lisp/man.el (Man-build-man-command): On MS-Windows, redirect stdin of 'man' to the null device, to make sure Groff exits immediately after formatting the man page. diff --git a/lisp/man.el b/lisp/man.el index 409fadb66b..731d480cbe 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -624,7 +624,13 @@ This is necessary if one wants to dump man.el with Emacs." ;; so we don't need `2>' even with DOS shells ;; which do support stderr redirection. ((not (fboundp 'make-process)) " %s") - ((concat " %s 2>" null-device))))) + ((concat " %s 2>" null-device + ;; Some MS-Windows ports of Groff + ;; try to read stdin after exhausting + ;; the command-line arguments; make + ;; them exit if/when they do. + (if (eq system-type 'windows-nt) + (concat " <" null-device))))))) (flist Man-filter-list)) (while (and flist (car flist)) (let ((pcom (car (car flist))) commit 2c0f6c3540ccad4b5832e9e00ece483a6a456bbb Author: Stefan Kangas Date: Fri Aug 2 16:46:08 2019 +0200 Suppress interactive-only warnings in undo-tests.el (Bug#36565) * test/src/undo-tests.el (undo-test-region-deletion) (undo-test-region-example, undo-test-marker-adjustment-nominal) (undo-test-region-t-marker, undo-test-marker-adjustment-moved) (undo-test-region-mark-adjustment): Suppress interactive-only warnings by using funcall-interactively. diff --git a/test/src/undo-tests.el b/test/src/undo-tests.el index 8395ba9909..fc2dfe027e 100644 --- a/test/src/undo-tests.el +++ b/test/src/undo-tests.el @@ -255,7 +255,7 @@ (insert "12345") (search-backward "4") (undo-boundary) - (delete-forward-char 1) + (funcall-interactively 'delete-forward-char 1) (search-backward "1") (undo-boundary) (insert "xxxx") @@ -299,7 +299,7 @@ undo-make-selective-list." (insert "ddd") (search-backward "ad") (undo-boundary) - (delete-forward-char 2) + (funcall-interactively 'delete-forward-char 2) (undo-boundary) ;; Select "dd" (push-mark (point) t t) @@ -348,7 +348,7 @@ undo-make-selective-list." (let ((m (make-marker))) (set-marker m 2 (current-buffer)) (goto-char (point-min)) - (delete-forward-char 3) + (funcall-interactively 'delete-forward-char 3) (undo-boundary) (should (= (point-min) (marker-position m))) (undo) @@ -369,7 +369,7 @@ undo-make-selective-list." (push-mark (point) t t) (setq mark-active t) (goto-char (point-min)) - (delete-forward-char 1) ;; delete region covering "ab" + (funcall-interactively 'delete-forward-char 1) ; delete region covering "ab" (undo-boundary) (should (= (point-min) (marker-position m))) ;; Resurrect "ab". m's insertion type means the reinsertion @@ -389,7 +389,7 @@ Demonstrates bug 16818." (let ((m (make-marker))) (set-marker m 2 (current-buffer)) ; m at b (goto-char (point-min)) - (delete-forward-char 3) ; m at d + (funcall-interactively 'delete-forward-char 3) ; m at d (undo-boundary) (set-marker m 4) ; m at g (undo) @@ -422,7 +422,7 @@ Demonstrates bug 16818." (push-mark (point) t t) (setq mark-active t) (goto-char (- (point) 3)) - (delete-forward-char 1) + (funcall-interactively 'delete-forward-char 1) (undo-boundary) (insert "bbb") commit d1ec33eaead82138ba5e65d59fd68c7da6d9e3a5 Author: Mattias Engdegård Date: Tue Aug 6 13:09:20 2019 +0200 Suppress relint errors in fortran.el * lisp/progmodes/fortran.el (fortran-indent-to-column): Suppress relint complaints about duplicated character in skip-set; it's intentional and harmless. diff --git a/lisp/progmodes/fortran.el b/lisp/progmodes/fortran.el index f01e866f55..ff7b408c20 100644 --- a/lisp/progmodes/fortran.el +++ b/lisp/progmodes/fortran.el @@ -1820,7 +1820,9 @@ notes: 1) A non-zero/non-blank character in column 5 indicates a continuation fortran-comment-indent-char)) (chars (string ?\s ?\t char))) (goto-char (match-end 0)) + ;; relint suppression: Duplicated character (skip-chars-backward chars) + ;; relint suppression: Duplicated character (delete-region (point) (progn (skip-chars-forward chars) (point))) (insert-char char (- col (current-column))))) commit f09dc0b81c23046c17574c2ef8d614907455f622 Author: Mattias Engdegård Date: Sat Aug 3 12:08:27 2019 +0200 Fix XTerm OSC 52 selection retrieval (bug#36879) When asking XTerm for the selection via OSC 52, use ST as string terminator in the request to get ST as terminator in the reply, because BEL is messy to receive in many ways. * lisp/term/xterm.el (gui-backend-get-selection): Use ST as string terminator in request and reply. Use a time-out when reading the reply. diff --git a/lisp/term/xterm.el b/lisp/term/xterm.el index c4b0a8fb6e..4b56b2ce4a 100644 --- a/lisp/term/xterm.el +++ b/lisp/term/xterm.el @@ -946,21 +946,31 @@ The title is constructed from `frame-title-format'." (type data-type &context (window-system nil) ;; Only applies to terminals which have it enabled. - ((terminal-parameter nil 'xterm--get-selection) (eql t))) + ((terminal-parameter nil 'xterm--get-selection) (eql t)) + ;; Doesn't work in screen; see bug#36879. + ((eq (terminal-parameter nil 'terminal-initted) + 'terminal-init-screen) + (eql nil))) (unless (eq data-type 'STRING) (error "Unsupported data type %S" data-type)) - (let* ((screen (eq (terminal-parameter nil 'terminal-initted) - 'terminal-init-screen)) - (query (concat "\e]52;" (xterm--selection-char type) ";"))) + (let ((query (concat "\e]52;" (xterm--selection-char type) ";"))) (with-temp-buffer (set-buffer-multibyte nil) (xterm--query - (concat (when screen "\eP") query "?\a" (when screen "\e\\")) - (list (cons query (lambda () - (while (let ((char (read-char))) - (unless (eq char ?\a) - (insert char) - t)))))) + ;; Use ST as query terminator to get ST as reply terminator (bug#36879). + (concat query "?\e\\") + (list (cons query + (lambda () + ;; Read data up to the string terminator, ST. + (let (char last) + (while (and (setq char (read-char + nil nil + xterm-query-timeout)) + (not (and (eq char ?\\) + (eq last ?\e)))) + (when last + (insert last)) + (setq last char)))))) 'no-async) (base64-decode-region (point-min) (point-max)) (decode-coding-region (point-min) (point-max) 'utf-8-unix t)))) commit d5622eb6fff94714c5d5a64c98c5e02bc1be478c Author: Glenn Morris Date: Wed Aug 7 09:24:15 2019 -0700 Tests need to be moved when source files are * test/lisp/obsolete/cl-tests.el: Move from test/lisp/emacs-lisp. diff --git a/test/lisp/emacs-lisp/cl-tests.el b/test/lisp/obsolete/cl-tests.el similarity index 100% rename from test/lisp/emacs-lisp/cl-tests.el rename to test/lisp/obsolete/cl-tests.el commit b83f83ccd47997b7fd581026d4e1b124fa4fefc2 Author: Philipp Stephani Date: Wed Jan 2 22:22:18 2019 +0100 Ignore pending_signals when checking for quits. pending_signals is often set if no quit is pending. This results in bugs in module code if the module returns but no quit is actually pending. * src/emacs-module.c (module_should_quit): Use QUITP macro to check whether the caller should quit. * src/eval.c: Remove obsolete comment. diff --git a/src/emacs-module.c b/src/emacs-module.c index 0abfd3f6f1..282012770e 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -665,13 +665,13 @@ module_vec_size (emacs_env *env, emacs_value vec) return ASIZE (lvec); } -/* This function should return true if and only if maybe_quit would do - anything. */ +/* This function should return true if and only if maybe_quit would + quit. */ static bool module_should_quit (emacs_env *env) { MODULE_FUNCTION_BEGIN_NO_CATCH (false); - return (! NILP (Vquit_flag) && NILP (Vinhibit_quit)) || pending_signals; + return QUITP; } diff --git a/src/eval.c b/src/eval.c index 0dc8639a8d..2409d3d2c4 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1484,10 +1484,7 @@ process_quit_flag (void) If quit-flag is set to `kill-emacs' the SIGINT handler has received a request to exit Emacs when it is safe to do. - When not quitting, process any pending signals. - - If you change this function, also adapt module_should_quit in - emacs-module.c. */ + When not quitting, process any pending signals. */ void maybe_quit (void) commit 2a82b5542661d181933b11f9c72323ef5da708ef Author: Michael Albinus Date: Wed Aug 7 16:36:00 2019 +0200 ; Still working on tramp--test-file-attributes-equal-p diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index c11997a5c0..bcc74cc3a2 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -3085,24 +3085,44 @@ This tests also `access-file', `file-readable-p', (defsubst tramp--test-file-attributes-equal-p (attr1 attr2) "Check, whether file attributes ATTR1 and ATTR2 are equal. -They might differ only in time attributes." - ;; Access time. - (setcar (nthcdr 4 attr1) tramp-time-dont-know) - (setcar (nthcdr 4 attr2) tramp-time-dont-know) - ;; Modification time. - (when (or (tramp-compat-time-equal-p (nth 5 attr1) tramp-time-dont-know) - (tramp-compat-time-equal-p (nth 5 attr2) tramp-time-dont-know) - (< (abs (tramp-time-diff (nth 5 attr1) (nth 5 attr2))) 5)) - (setcar (nthcdr 5 attr1) tramp-time-dont-know) - (setcar (nthcdr 5 attr2) tramp-time-dont-know)) - ;; Status change time. - (when (or (tramp-compat-time-equal-p (nth 6 attr1) tramp-time-dont-know) - (tramp-compat-time-equal-p (nth 6 attr2) tramp-time-dont-know) - (< (abs (tramp-time-diff (nth 6 attr1) (nth 6 attr2))) 5)) - (setcar (nthcdr 6 attr1) tramp-time-dont-know) - (setcar (nthcdr 6 attr2) tramp-time-dont-know)) - (unless (equal attr1 attr2) (tramp--test-message "%S\n%S" attr1 attr2)) - (equal attr1 attr2)) +They might differ only in time attributes or directory size." + (let ((attr1 (copy-sequence attr1)) + (attr2 (copy-sequence attr2)) + (start-time + (aref + (ert--stats-test-start-times ert--current-run-stats) + (ert--stats-test-pos ert--current-run-stats (ert-running-test))))) + ;; Access time. + (setcar (nthcdr 4 attr1) tramp-time-dont-know) + (setcar (nthcdr 4 attr2) tramp-time-dont-know) + ;; Modification time. If any of the time values is "don't know", + ;; we cannot compare, and we normalize the time stamps. If the + ;; time value is newer than the test start time, normalize it, + ;; because due to caching the time stamps could differ slightly (a + ;; few seconds). + (when (or (tramp-compat-time-equal-p (nth 5 attr1) tramp-time-dont-know) + (tramp-compat-time-equal-p (nth 5 attr2) tramp-time-dont-know)) + (setcar (nthcdr 5 attr1) tramp-time-dont-know) + (setcar (nthcdr 5 attr2) tramp-time-dont-know)) + (when (time-less-p start-time (nth 5 attr1)) + (setcar (nthcdr 5 attr1) tramp-time-dont-know)) + (when (time-less-p start-time (nth 5 attr2)) + (setcar (nthcdr 5 attr2) tramp-time-dont-know)) + ;; Status change time. Dito. + (when (or (tramp-compat-time-equal-p (nth 6 attr1) tramp-time-dont-know) + (tramp-compat-time-equal-p (nth 6 attr2) tramp-time-dont-know)) + (setcar (nthcdr 6 attr1) tramp-time-dont-know) + (setcar (nthcdr 6 attr2) tramp-time-dont-know)) + (when (time-less-p start-time (nth 6 attr1)) + (setcar (nthcdr 6 attr1) tramp-time-dont-know)) + (when (time-less-p start-time (nth 6 attr2)) + (setcar (nthcdr 6 attr2) tramp-time-dont-know)) + ;; Size. Set it to 0 for directories, because it might have + ;; changed. For example the upper directory "../". + (when (eq (car attr1) t) (setcar (nthcdr 7 attr1) 0)) + (when (eq (car attr2) t) (setcar (nthcdr 7 attr2) 0)) + ;; The check. + (equal attr1 attr2))) ;; This isn't 100% correct, but better than no explainer at all. (put #'tramp--test-file-attributes-equal-p 'ert-explainer #'ert--explain-equal) commit 2b6932b44070ad18e1622fbbb9496f2e05e3e809 Author: Michael Albinus Date: Wed Aug 7 14:59:19 2019 +0200 ; Instrument tramp--test-file-attributes-equal-p diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index bcc74cc3a2..c11997a5c0 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -3085,44 +3085,24 @@ This tests also `access-file', `file-readable-p', (defsubst tramp--test-file-attributes-equal-p (attr1 attr2) "Check, whether file attributes ATTR1 and ATTR2 are equal. -They might differ only in time attributes or directory size." - (let ((attr1 (copy-sequence attr1)) - (attr2 (copy-sequence attr2)) - (start-time - (aref - (ert--stats-test-start-times ert--current-run-stats) - (ert--stats-test-pos ert--current-run-stats (ert-running-test))))) - ;; Access time. - (setcar (nthcdr 4 attr1) tramp-time-dont-know) - (setcar (nthcdr 4 attr2) tramp-time-dont-know) - ;; Modification time. If any of the time values is "don't know", - ;; we cannot compare, and we normalize the time stamps. If the - ;; time value is newer than the test start time, normalize it, - ;; because due to caching the time stamps could differ slightly (a - ;; few seconds). - (when (or (tramp-compat-time-equal-p (nth 5 attr1) tramp-time-dont-know) - (tramp-compat-time-equal-p (nth 5 attr2) tramp-time-dont-know)) - (setcar (nthcdr 5 attr1) tramp-time-dont-know) - (setcar (nthcdr 5 attr2) tramp-time-dont-know)) - (when (time-less-p start-time (nth 5 attr1)) - (setcar (nthcdr 5 attr1) tramp-time-dont-know)) - (when (time-less-p start-time (nth 5 attr2)) - (setcar (nthcdr 5 attr2) tramp-time-dont-know)) - ;; Status change time. Dito. - (when (or (tramp-compat-time-equal-p (nth 6 attr1) tramp-time-dont-know) - (tramp-compat-time-equal-p (nth 6 attr2) tramp-time-dont-know)) - (setcar (nthcdr 6 attr1) tramp-time-dont-know) - (setcar (nthcdr 6 attr2) tramp-time-dont-know)) - (when (time-less-p start-time (nth 6 attr1)) - (setcar (nthcdr 6 attr1) tramp-time-dont-know)) - (when (time-less-p start-time (nth 6 attr2)) - (setcar (nthcdr 6 attr2) tramp-time-dont-know)) - ;; Size. Set it to 0 for directories, because it might have - ;; changed. For example the upper directory "../". - (when (eq (car attr1) t) (setcar (nthcdr 7 attr1) 0)) - (when (eq (car attr2) t) (setcar (nthcdr 7 attr2) 0)) - ;; The check. - (equal attr1 attr2))) +They might differ only in time attributes." + ;; Access time. + (setcar (nthcdr 4 attr1) tramp-time-dont-know) + (setcar (nthcdr 4 attr2) tramp-time-dont-know) + ;; Modification time. + (when (or (tramp-compat-time-equal-p (nth 5 attr1) tramp-time-dont-know) + (tramp-compat-time-equal-p (nth 5 attr2) tramp-time-dont-know) + (< (abs (tramp-time-diff (nth 5 attr1) (nth 5 attr2))) 5)) + (setcar (nthcdr 5 attr1) tramp-time-dont-know) + (setcar (nthcdr 5 attr2) tramp-time-dont-know)) + ;; Status change time. + (when (or (tramp-compat-time-equal-p (nth 6 attr1) tramp-time-dont-know) + (tramp-compat-time-equal-p (nth 6 attr2) tramp-time-dont-know) + (< (abs (tramp-time-diff (nth 6 attr1) (nth 6 attr2))) 5)) + (setcar (nthcdr 6 attr1) tramp-time-dont-know) + (setcar (nthcdr 6 attr2) tramp-time-dont-know)) + (unless (equal attr1 attr2) (tramp--test-message "%S\n%S" attr1 attr2)) + (equal attr1 attr2)) ;; This isn't 100% correct, but better than no explainer at all. (put #'tramp--test-file-attributes-equal-p 'ert-explainer #'ert--explain-equal) commit 25baa7d20ccc4b76c5a886a1e32b66f6c1a23485 Author: Michael Albinus Date: Wed Aug 7 14:12:14 2019 +0200 Continue to work on Bug#36940 * test/lisp/net/tramp-tests.el (tramp--test-file-attributes-equal-p): Make the check more precise. (Bug#36940) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 7ec709a4a6..bcc74cc3a2 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -3085,23 +3085,44 @@ This tests also `access-file', `file-readable-p', (defsubst tramp--test-file-attributes-equal-p (attr1 attr2) "Check, whether file attributes ATTR1 and ATTR2 are equal. -They might differ only in time attributes." - ;; Access time. - (setcar (nthcdr 4 attr1) tramp-time-dont-know) - (setcar (nthcdr 4 attr2) tramp-time-dont-know) - ;; Modification time. - (when (or (tramp-compat-time-equal-p (nth 5 attr1) tramp-time-dont-know) - (tramp-compat-time-equal-p (nth 5 attr2) tramp-time-dont-know) - (< (abs (tramp-time-diff (nth 5 attr1) (nth 5 attr2))) 5)) - (setcar (nthcdr 5 attr1) tramp-time-dont-know) - (setcar (nthcdr 5 attr2) tramp-time-dont-know)) - ;; Status change time. - (when (or (tramp-compat-time-equal-p (nth 6 attr1) tramp-time-dont-know) - (tramp-compat-time-equal-p (nth 6 attr2) tramp-time-dont-know) - (< (abs (tramp-time-diff (nth 6 attr1) (nth 6 attr2))) 5)) - (setcar (nthcdr 6 attr1) tramp-time-dont-know) - (setcar (nthcdr 6 attr2) tramp-time-dont-know)) - (equal attr1 attr2)) +They might differ only in time attributes or directory size." + (let ((attr1 (copy-sequence attr1)) + (attr2 (copy-sequence attr2)) + (start-time + (aref + (ert--stats-test-start-times ert--current-run-stats) + (ert--stats-test-pos ert--current-run-stats (ert-running-test))))) + ;; Access time. + (setcar (nthcdr 4 attr1) tramp-time-dont-know) + (setcar (nthcdr 4 attr2) tramp-time-dont-know) + ;; Modification time. If any of the time values is "don't know", + ;; we cannot compare, and we normalize the time stamps. If the + ;; time value is newer than the test start time, normalize it, + ;; because due to caching the time stamps could differ slightly (a + ;; few seconds). + (when (or (tramp-compat-time-equal-p (nth 5 attr1) tramp-time-dont-know) + (tramp-compat-time-equal-p (nth 5 attr2) tramp-time-dont-know)) + (setcar (nthcdr 5 attr1) tramp-time-dont-know) + (setcar (nthcdr 5 attr2) tramp-time-dont-know)) + (when (time-less-p start-time (nth 5 attr1)) + (setcar (nthcdr 5 attr1) tramp-time-dont-know)) + (when (time-less-p start-time (nth 5 attr2)) + (setcar (nthcdr 5 attr2) tramp-time-dont-know)) + ;; Status change time. Dito. + (when (or (tramp-compat-time-equal-p (nth 6 attr1) tramp-time-dont-know) + (tramp-compat-time-equal-p (nth 6 attr2) tramp-time-dont-know)) + (setcar (nthcdr 6 attr1) tramp-time-dont-know) + (setcar (nthcdr 6 attr2) tramp-time-dont-know)) + (when (time-less-p start-time (nth 6 attr1)) + (setcar (nthcdr 6 attr1) tramp-time-dont-know)) + (when (time-less-p start-time (nth 6 attr2)) + (setcar (nthcdr 6 attr2) tramp-time-dont-know)) + ;; Size. Set it to 0 for directories, because it might have + ;; changed. For example the upper directory "../". + (when (eq (car attr1) t) (setcar (nthcdr 7 attr1) 0)) + (when (eq (car attr2) t) (setcar (nthcdr 7 attr2) 0)) + ;; The check. + (equal attr1 attr2))) ;; This isn't 100% correct, but better than no explainer at all. (put #'tramp--test-file-attributes-equal-p 'ert-explainer #'ert--explain-equal) commit bc1cf28da5532c6052eade7b5d19bb59e7e1f7bf Author: Robert Pluim Date: Wed Aug 7 14:07:07 2019 +0200 Change nsm-should-check to look at local subnets * lisp/net/nsm.el (nsm-network-same-subnet): New function. Checks if an ip address is in the same subnet as another one. (nsm-should-check): Use nsm-network-same-subnet to see if we're connecting to a local subnet machine. Remove checks for RFC1918 addresses. * test/lisp/net/nsm-tests.el: New file. Test nsm-should-check functionality. diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index b59ea07d8a..b0eff81161 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -204,54 +204,51 @@ SETTINGS are the same as those supplied to each check function. RESULTS is an alist where the keys are the checks run and the values the results of the checks.") +(defun nsm-network-same-subnet (local-ip mask ip) + "Returns t if IP is in the same subnet as LOCAL-IP/MASK. +LOCAL-IP, MASK, and IP are specified as vectors of integers, and +are expected to have the same length. Works for both IPv4 and +IPv6 addresses." + (let ((matches t) + (length (length local-ip))) + (unless (memq length '(4 5 8 9)) + (error "Unexpected length of IP address %S" local-ip)) + (dotimes (i length) + (setq matches (and matches + (= + (logand (aref local-ip i) + (aref mask i)) + (logand (aref ip i) + (aref mask i)))))) + matches)) + (defun nsm-should-check (host) "Determines whether NSM should check for TLS problems for HOST. If `nsm-trust-local-network' is or returns non-nil, and if the -host address is a localhost address, a machine address, a direct -link or a private network address, this function returns -nil. Non-nil otherwise." - (let* ((address (or (nslookup-host-ipv4 host nil 'vector) - (nslookup-host-ipv6 host nil 'vector))) - (ipv4? (eq (length address) 4))) - (not - (or (if ipv4? - (or - ;; (0.x.x.x) this machine - (eq (aref address 0) 0) - ;; (127.x.x.x) localhost - (eq (aref address 0) 0)) - (or - ;; (::) IPv6 this machine - (not (cl-mismatch address [0 0 0 0 0 0 0 0])) - ;; (::1) IPv6 localhost - (not (cl-mismatch address [0 0 0 0 0 0 0 1])))) - (and (or (and (functionp nsm-trust-local-network) - (funcall nsm-trust-local-network)) - nsm-trust-local-network) - (if ipv4? - (or - ;; (10.x.x.x) private - (eq (aref address 0) 10) - ;; (172.16.x.x) private - (and (eq (aref address 0) 172) - (eq (aref address 0) 16)) - ;; (192.168.x.x) private - (and (eq (aref address 0) 192) - (eq (aref address 0) 168)) - ;; (198.18.x.x) private - (and (eq (aref address 0) 198) - (eq (aref address 0) 18)) - ;; (169.254.x.x) link-local - (and (eq (aref address 0) 169) - (eq (aref address 0) 254))) - (memq (aref address 0) - '( - 64512 ;; (fc00::) IPv6 unique local address - 64768 ;; (fd00::) IPv6 unique local address - 65152 ;; (fe80::) IPv6 link-local - ) - ))))))) +host address is a localhost address, or in the same subnet as one +of the local interfaces, this function returns nil. Non-nil +otherwise." + (let ((addresses (network-lookup-address-info host)) + (network-interface-list (network-interface-list)) + (off-net t)) + (when + (or (and (functionp nsm-trust-local-network) + (funcall nsm-trust-local-network)) + nsm-trust-local-network) + (mapc + (lambda (address) + (mapc + (lambda (iface) + (let ((info (network-interface-info (car iface)))) + (when + (nsm-network-same-subnet (substring (car info) 0 -1) + (substring (car (cddr info)) 0 -1) + address) + (setq off-net nil)))) + network-interface-list)) + addresses)) + off-net)) (defun nsm-check-tls-connection (process host port status settings) "Check TLS connection against potential security problems. diff --git a/test/lisp/net/nsm-tests.el b/test/lisp/net/nsm-tests.el new file mode 100644 index 0000000000..bf6ac04b52 --- /dev/null +++ b/test/lisp/net/nsm-tests.el @@ -0,0 +1,69 @@ +;;; network-stream-tests.el --- tests for network security manager -*- lexical-binding: t; -*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; Author: Robert Pluim + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + + +;;; Code: + +(require 'nsm) +(eval-when-compile (require 'cl-lib)) + +(ert-deftest nsm-check-local-subnet-ipv4 () + "Check that nsm can be avoided for local subnets." + (let ((local-ip '[172 26 128 160 0]) + (mask '[255 255 255 0 0]) + + (wrong-length-mask '[255 255 255]) + (wrong-mask '[255 255 255 255 0]) + (remote-ip-yes '[172 26 128 161 0]) + (remote-ip-no '[172 26 129 161 0])) + + (should (eq t (nsm-network-same-subnet local-ip mask remote-ip-yes))) + (should (eq nil (nsm-network-same-subnet local-ip mask remote-ip-no))) + (should-error (nsm-network-same-subnet local-ip wrong-length-mask remote-ip-yes)) + (should (eq nil (nsm-network-same-subnet local-ip wrong-mask remote-ip-yes))) + (should (eq t (nsm-should-check "google.com"))) + (should (eq t (nsm-should-check "127.1"))) + (should (eq t (nsm-should-check "localhost"))) + (let ((nsm-trust-local-network t)) + (should (eq t (nsm-should-check "google.com"))) + (should (eq nil (nsm-should-check "127.1"))) + (should (eq nil (nsm-should-check "localhost")))))) + +;; FIXME This will never return true, since +;; network-interface-list only gives the primary address of each +;; interface, which will be the IPv4 one +(defun nsm-ipv6-is-available () + (and (featurep 'make-network-process '(:family ipv6)) + (cl-rassoc-if + (lambda (elt) + (eq 9 (length elt))) + (network-interface-list)))) + +(ert-deftest nsm-check-local-subnet-ipv6 () + (skip-unless (nsm-ipv6-is-available)) + (should (eq t (nsm-should-check "::1"))) + (let ((nsm-trust-local-network t)) + (should (eq nil (nsm-should-check "::1"))))) + + +;;; nsm-tests.el ends here commit 76662cc47d0dd1482442914d0b1f5011f0c86c5e Author: Robert Pluim Date: Wed Aug 7 13:55:38 2019 +0200 fixup! Implement hostname->ip lookup function diff --git a/src/process.c b/src/process.c index 42909c4ba4..7b1723b9f5 100644 --- a/src/process.c +++ b/src/process.c @@ -2488,7 +2488,7 @@ usage: (make-pipe-process &rest ARGS) */) The address family of sa is not included in the result. */ Lisp_Object -conv_sockaddr_to_lisp (struct sockaddr *sa, ptrdiff_t len, bool include_port) +conv_sockaddr_to_lisp (struct sockaddr *sa, ptrdiff_t len) { Lisp_Object address; ptrdiff_t i; @@ -2507,12 +2507,9 @@ conv_sockaddr_to_lisp (struct sockaddr *sa, ptrdiff_t len, bool include_port) { DECLARE_POINTER_ALIAS (sin, struct sockaddr_in, sa); len = sizeof (sin->sin_addr) + 1; - if (!include_port) - len--; address = Fmake_vector (make_number (len), Qnil); p = XVECTOR (address); - if (include_port) - p->contents[--len] = make_number (ntohs (sin->sin_port)); + p->contents[--len] = make_number (ntohs (sin->sin_port)); cp = (unsigned char *) &sin->sin_addr; break; } @@ -2522,12 +2519,9 @@ conv_sockaddr_to_lisp (struct sockaddr *sa, ptrdiff_t len, bool include_port) DECLARE_POINTER_ALIAS (sin6, struct sockaddr_in6, sa); DECLARE_POINTER_ALIAS (ip6, uint16_t, &sin6->sin6_addr); len = sizeof (sin6->sin6_addr) / 2 + 1; - if (!include_port) - len--; address = Fmake_vector (make_number (len), Qnil); p = XVECTOR (address); - if (include_port) - p->contents[--len] = make_number (ntohs (sin6->sin6_port)); + p->contents[--len] = make_number (ntohs (sin6->sin6_port)); for (i = 0; i < len; i++) p->contents[i] = make_number (ntohs (ip6[i])); return address; @@ -2578,7 +2572,7 @@ conv_addrinfo_to_lisp (struct addrinfo *res) { Lisp_Object protocol = make_number (res->ai_protocol); eassert (XINT (protocol) == res->ai_protocol); - return Fcons (protocol, conv_sockaddr_to_lisp (res->ai_addr, res->ai_addrlen, true)); + return Fcons (protocol, conv_sockaddr_to_lisp (res->ai_addr, res->ai_addrlen)); } @@ -2720,8 +2714,7 @@ set up yet, this function will block until socket setup has completed. */) channel = XPROCESS (process)->infd; return conv_sockaddr_to_lisp (datagram_address[channel].sa, - datagram_address[channel].len, - true); + datagram_address[channel].len); } DEFUN ("set-process-datagram-address", Fset_process_datagram_address, Sset_process_datagram_address, @@ -3582,7 +3575,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, #endif contact = Fplist_put (contact, p->is_server? QClocal: QCremote, - conv_sockaddr_to_lisp (sa, addrlen, true)); + conv_sockaddr_to_lisp (sa, addrlen)); #ifdef HAVE_GETSOCKNAME if (!p->is_server) { @@ -3591,7 +3584,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object addrinfos, DECLARE_POINTER_ALIAS (psa1, struct sockaddr, &sa1); if (getsockname (s, psa1, &len1) == 0) contact = Fplist_put (contact, QClocal, - conv_sockaddr_to_lisp (psa1, len1, true)); + conv_sockaddr_to_lisp (psa1, len1)); } #endif } @@ -4255,8 +4248,7 @@ network_interface_list (void) namebuf[sizeof (ifq->ifr_name)] = 0; res = Fcons (Fcons (build_string (namebuf), conv_sockaddr_to_lisp (&ifq->ifr_addr, - sizeof (struct sockaddr), - true)), + sizeof (struct sockaddr))), res); } @@ -4459,9 +4451,9 @@ network_interface_info (Lisp_Object ifname) { any = 1; #ifdef HAVE_STRUCT_IFREQ_IFR_NETMASK - elt = conv_sockaddr_to_lisp (&rq.ifr_netmask, sizeof (rq.ifr_netmask), true); + elt = conv_sockaddr_to_lisp (&rq.ifr_netmask, sizeof (rq.ifr_netmask)); #else - elt = conv_sockaddr_to_lisp (&rq.ifr_addr, sizeof (rq.ifr_addr), true); + elt = conv_sockaddr_to_lisp (&rq.ifr_addr, sizeof (rq.ifr_addr)); #endif } #endif @@ -4472,7 +4464,7 @@ network_interface_info (Lisp_Object ifname) if (ioctl (s, SIOCGIFBRDADDR, &rq) == 0) { any = 1; - elt = conv_sockaddr_to_lisp (&rq.ifr_broadaddr, sizeof (rq.ifr_broadaddr), true); + elt = conv_sockaddr_to_lisp (&rq.ifr_broadaddr, sizeof (rq.ifr_broadaddr)); } #endif res = Fcons (elt, res); @@ -4482,7 +4474,7 @@ network_interface_info (Lisp_Object ifname) if (ioctl (s, SIOCGIFADDR, &rq) == 0) { any = 1; - elt = conv_sockaddr_to_lisp (&rq.ifr_addr, sizeof (rq.ifr_addr), true); + elt = conv_sockaddr_to_lisp (&rq.ifr_addr, sizeof (rq.ifr_addr)); } #endif res = Fcons (elt, res); @@ -4602,7 +4594,7 @@ nil if none were found. Each address is a vector of integers. */) for (lres = res; lres; lres = lres->ai_next) { addresses = Fcons (conv_sockaddr_to_lisp - (lres->ai_addr, lres->ai_addrlen, false), + (lres->ai_addr, lres->ai_addrlen), addresses); } addresses = Fnreverse (addresses); @@ -4879,12 +4871,12 @@ server_accept_connection (Lisp_Object server, int channel) if (!NILP (service)) contact = Fplist_put (contact, QCservice, service); contact = Fplist_put (contact, QCremote, - conv_sockaddr_to_lisp (&saddr.sa, len, true)); + conv_sockaddr_to_lisp (&saddr.sa, len)); #ifdef HAVE_GETSOCKNAME len = sizeof saddr; if (getsockname (s, &saddr.sa, &len) == 0) contact = Fplist_put (contact, QClocal, - conv_sockaddr_to_lisp (&saddr.sa, len, true)); + conv_sockaddr_to_lisp (&saddr.sa, len)); #endif pset_childp (p, contact); @@ -8116,7 +8108,7 @@ init_process_emacs (int sockfd) union u_sockaddr sa; socklen_t salen = sizeof sa; if (getsockname (sockfd, &sa.sa, &salen) == 0) - sockname = conv_sockaddr_to_lisp (&sa.sa, salen, true); + sockname = conv_sockaddr_to_lisp (&sa.sa, salen); } # endif Vinternal__daemon_sockname = sockname; diff --git a/src/process.h b/src/process.h index 504e5e6aaa..6bc22146a7 100644 --- a/src/process.h +++ b/src/process.h @@ -278,7 +278,7 @@ extern Lisp_Object system_process_attributes (Lisp_Object); extern void record_deleted_pid (pid_t, Lisp_Object); struct sockaddr; -extern Lisp_Object conv_sockaddr_to_lisp (struct sockaddr *, ptrdiff_t, bool); +extern Lisp_Object conv_sockaddr_to_lisp (struct sockaddr *, ptrdiff_t); extern void hold_keyboard_input (void); extern void unhold_keyboard_input (void); extern bool kbd_on_hold_p (void); diff --git a/src/w32.c b/src/w32.c index 4759b082eb..c848b33b2a 100644 --- a/src/w32.c +++ b/src/w32.c @@ -9210,8 +9210,7 @@ network_interface_get_info (Lisp_Object ifname) if (NILP (ifname)) res = Fcons (Fcons (build_string (namebuf), conv_sockaddr_to_lisp ((struct sockaddr*) &sa, - sizeof (struct sockaddr), - false)), + sizeof (struct sockaddr))), res); else if (strcmp (namebuf, SSDATA (ifname)) == 0) { @@ -9258,8 +9257,7 @@ network_interface_get_info (Lisp_Object ifname) sa.sin_addr.s_addr = net_mask; sa.sin_port = 0; res = Fcons (conv_sockaddr_to_lisp ((struct sockaddr *) &sa, - sizeof (struct sockaddr), - false), + sizeof (struct sockaddr)), res); } else @@ -9276,16 +9274,14 @@ network_interface_get_info (Lisp_Object ifname) sa.sin_addr.s_addr = bcast_addr; sa.sin_port = 0; res = Fcons (conv_sockaddr_to_lisp ((struct sockaddr *) &sa, - sizeof (struct sockaddr), - false), + sizeof (struct sockaddr)), res); /* IP address. */ sa.sin_addr.s_addr = ip_addr; sa.sin_port = 0; res = Fcons (conv_sockaddr_to_lisp ((struct sockaddr *) &sa, - sizeof (struct sockaddr), - false), + sizeof (struct sockaddr)), res); } else @@ -9303,8 +9299,7 @@ network_interface_get_info (Lisp_Object ifname) sa.sin_addr.s_addr = sys_inet_addr ("127.0.0.1"); res = Fcons (Fcons (build_string ("lo"), conv_sockaddr_to_lisp ((struct sockaddr*) &sa, - sizeof (struct sockaddr), - false)), + sizeof (struct sockaddr))), res); } else if (strcmp (SSDATA (ifname), "lo") == 0) @@ -9320,18 +9315,15 @@ network_interface_get_info (Lisp_Object ifname) res); sa.sin_addr.s_addr = sys_inet_addr ("255.0.0.0"); res = Fcons (conv_sockaddr_to_lisp ((struct sockaddr *) &sa, - sizeof (struct sockaddr), - false), + sizeof (struct sockaddr)), res); sa.sin_addr.s_addr = sys_inet_addr ("0.0.0.0"); res = Fcons (conv_sockaddr_to_lisp ((struct sockaddr *) &sa, - sizeof (struct sockaddr), - false), + sizeof (struct sockaddr)), res); sa.sin_addr.s_addr = sys_inet_addr ("127.0.0.1"); res = Fcons (conv_sockaddr_to_lisp ((struct sockaddr *) &sa, - sizeof (struct sockaddr), - false), + sizeof (struct sockaddr)), res); } commit 220f16cab6c40a1b0df1a5d2101c6602abbc6aae Author: Paul Eggert Date: Tue Aug 6 18:39:20 2019 -0700 Re-port dump_bitset_clear to -fsanitize=undefined * src/pdumper.c (dump_bitset_clear): Skip the memset if the size is zero, because in that case the destination might be NULL. This fixes a bug introduced in 2019-07-26T06:17:52Zeggert@cs.ucla.edu. Add a comment to make the bug less likely to reoccur. diff --git a/src/pdumper.c b/src/pdumper.c index e0ddc1c808..326a346a63 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -4931,7 +4931,10 @@ dump_bitset_set_bit (struct dump_bitset *bitset, size_t bit_number) static void dump_bitset_clear (struct dump_bitset *bitset) { - memset (bitset->bits, 0, bitset->number_words * sizeof bitset->bits[0]); + /* Skip the memset if bitset->number_words == 0, because then bitset->bits + might be NULL and the memset would have undefined behavior. */ + if (bitset->number_words) + memset (bitset->bits, 0, bitset->number_words * sizeof bitset->bits[0]); } struct pdumper_loaded_dump_private commit d9d58555d9de034ed78c61b054ef4c127dfad289 Author: Stefan Monnier Date: Tue Aug 6 20:42:59 2019 -0400 * lisp/gnus/message.el (message-sendmail-f-is-evil): Revert recent change (bug#36937) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 71e1750ba4..0a540a6221 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -836,14 +836,13 @@ symbol `never', the posting is not allowed. If it is the symbol (const ask))) (defcustom message-sendmail-f-is-evil - (if (boundp 'mail-specify-envelope-from) - (not mail-specify-envelope-from) - nil) + ;; FIXME: This is related to `mail-specify-envelope-from' but works + ;; differently (bug#36937). + nil "Non-nil means don't add \"-f username\" to the sendmail command line. Doing so would be even more evil than leaving it out." :group 'message-sending :link '(custom-manual "(message)Mail Variables") - :version "27.1" :type 'boolean) (defcustom message-sendmail-envelope-from commit 998f3612f7e3732d43d8cc6827a16a29008f5db5 Author: Michael Albinus Date: Tue Aug 6 21:47:57 2019 +0200 Fix Bug#36940 * test/lisp/net/tramp-tests.el (tramp--test-file-attributes-equal-p): Make the check more precise. (Bug#36940) (tramp-test19-directory-files-and-attributes): Move some checks to `tramp--test-file-attributes-equal-p'. diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index d49914797f..7ec709a4a6 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -3090,11 +3090,15 @@ They might differ only in time attributes." (setcar (nthcdr 4 attr1) tramp-time-dont-know) (setcar (nthcdr 4 attr2) tramp-time-dont-know) ;; Modification time. - (when (< (abs (tramp-time-diff (nth 5 attr1) (nth 5 attr2))) 5) + (when (or (tramp-compat-time-equal-p (nth 5 attr1) tramp-time-dont-know) + (tramp-compat-time-equal-p (nth 5 attr2) tramp-time-dont-know) + (< (abs (tramp-time-diff (nth 5 attr1) (nth 5 attr2))) 5)) (setcar (nthcdr 5 attr1) tramp-time-dont-know) (setcar (nthcdr 5 attr2) tramp-time-dont-know)) ;; Status change time. - (when (< (abs (tramp-time-diff (nth 6 attr1) (nth 6 attr2))) 5) + (when (or (tramp-compat-time-equal-p (nth 6 attr1) tramp-time-dont-know) + (tramp-compat-time-equal-p (nth 6 attr2) tramp-time-dont-know) + (< (abs (tramp-time-diff (nth 6 attr1) (nth 6 attr2))) 5)) (setcar (nthcdr 6 attr1) tramp-time-dont-know) (setcar (nthcdr 6 attr2) tramp-time-dont-know)) (equal attr1 attr2)) @@ -3122,27 +3126,22 @@ They might differ only in time attributes." (write-region "foo" nil (expand-file-name "foo" tmp-name2)) (write-region "bar" nil (expand-file-name "bar" tmp-name2)) (write-region "boz" nil (expand-file-name "boz" tmp-name2)) + (setq attr (directory-files-and-attributes tmp-name2)) (should (consp attr)) - ;; Dumb remote shells without perl(1) or stat(1) are not - ;; able to return the date correctly. They say "don't know". (dolist (elt attr) - (unless - (tramp-compat-time-equal-p - (nth - 5 (file-attributes (expand-file-name (car elt) tmp-name2))) - tramp-time-dont-know) - (should - (tramp--test-file-attributes-equal-p - (file-attributes (expand-file-name (car elt) tmp-name2)) - (cdr elt))))) + (should + (tramp--test-file-attributes-equal-p + (file-attributes (expand-file-name (car elt) tmp-name2)) + (cdr elt)))) + (setq attr (directory-files-and-attributes tmp-name2 'full)) + (should (consp attr)) (dolist (elt attr) - (unless (tramp-compat-time-equal-p - (nth 5 (file-attributes (car elt))) tramp-time-dont-know) - (should - (tramp--test-file-attributes-equal-p - (file-attributes (car elt)) (cdr elt))))) + (should + (tramp--test-file-attributes-equal-p + (file-attributes (car elt)) (cdr elt)))) + (setq attr (directory-files-and-attributes tmp-name2 nil "^b")) (should (equal (mapcar #'car attr) '("bar" "boz")))) commit 7f0de07b3ac67370bfe78faac9c6bffdd90d55ce Author: Alan Mackenzie Date: Tue Aug 6 16:49:29 2019 +0000 C++ Mode: Prevent End of statement being found after {} in "count << vec{} <<" * lisp/progmodes/cc-engine.el (c-beginning-of-statement-1): Check for operators which cannot start a statement, which may follow a closing brace. Don't recognise an end of statement in such a case. * lisp/progmodes/cc-langs.el (c-operator-re, c-bin-tern-operators) (c-unary-operators, c-non-after-{}-operators, c-non-after-{}-ops-re): New lang consts and vars. diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index a095277989..29ebe2eea1 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -1227,7 +1227,23 @@ comment at the start of cc-engine.el for more info." (not (looking-at c-opt-block-decls-with-vars-key)) (or comma-delim - (not (eq (char-after) ?\,))))))) + (not (eq (char-after) ?\,)))))) + ;; Is the {..} followed by an operator which + ;; prevents it being a statement in its own right? + (save-excursion + (and + (c-go-list-forward) + (progn + (c-forward-syntactic-ws) + (or + (not (looking-at c-non-after-{}-ops-re)) + (let + ((bad-op-len + (- (match-end 0) (match-beginning 0)))) + (and + (looking-at c-operator-re) + (> (- (match-end 0) (match-beginning 0)) + bad-op-len)))))))) (save-excursion (c-forward-sexp) (point))) ;; Just gone back over some paren block? diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el index 9d36f8f9e4..6ba14a8229 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el @@ -1205,6 +1205,36 @@ since CC Mode treats every identifier as an expression." ;; The operators as a flat list (without duplicates). t (c-filter-ops (c-lang-const c-operators) t t)) +(c-lang-defconst c-operator-re + ;; A regexp which matches any operator. + t (regexp-opt (c-lang-const c-operator-list))) +(c-lang-defvar c-operator-re (c-lang-const c-operator-re)) + +(c-lang-defconst c-bin-tern-operators + ;; All binary and ternary operators + t (c-filter-ops (c-lang-const c-operators) + '(left-assoc right-assoc right-assoc-sequence) + t)) + +(c-lang-defconst c-unary-operators + ;; All unary operators. + t (c-filter-ops (c-lang-const c-operators) + '(prefix postfix postfix-if-paren) + t)) + +(c-lang-defconst c-non-after-{}-operators + "Operators which can't appear after a block {..} construct." + t (c--set-difference (c-lang-const c-bin-tern-operators) + (c-lang-const c-unary-operators) + :test #'string-equal) + awk (remove "/" (c-lang-const c-non-after-{}-operators))) + +(c-lang-defconst c-non-after-{}-ops-re + ;; A regexp matching operators which can't appear after a block {..} + ;; construct. + t (regexp-opt (c-lang-const c-non-after-{}-operators))) +(c-lang-defvar c-non-after-{}-ops-re (c-lang-const c-non-after-{}-ops-re)) + (c-lang-defconst c-overloadable-operators "List of the operators that are overloadable, in their \"identifier form\". See also `c-op-identifier-prefix'." commit 96e672364cbd6f1a865511d78f3a218c0570345e Author: Eli Zaretskii Date: Tue Aug 6 17:53:03 2019 +0300 Fix minor compilation problems on MS-Windows * src/w32fns.c (Fdefault_printer_name): Fix size of local buffer. * src/image.c [WINDOWSNT]: Test __MINGW_MAJOR_VERSION as well to shut up compiler warnings. diff --git a/src/image.c b/src/image.c index 8cab860085..81d8cb4e2b 100644 --- a/src/image.c +++ b/src/image.c @@ -9290,13 +9290,13 @@ svg_image_p (Lisp_Object object) # ifdef WINDOWSNT /* Restore the original definition of __MINGW_MAJOR_VERSION. */ -# ifdef W32_SAVE_MINGW_VERSION -# undef __MINGW_MAJOR_VERSION -# define __MINGW_MAJOR_VERSION W32_SAVE_MINGW_VERSION -# ifdef __MINGW_MAJOR_VERSION -# undef W32_SAVE_MINGW_VERSION +# if defined W32_SAVE_MINGW_VERSION && defined __MINGW_MAJOR_VERSION +# undef __MINGW_MAJOR_VERSION +# define __MINGW_MAJOR_VERSION W32_SAVE_MINGW_VERSION +# ifdef __MINGW_MAJOR_VERSION +# undef W32_SAVE_MINGW_VERSION +# endif # endif -# endif /* SVG library functions. */ # if LIBRSVG_CHECK_VERSION (2, 32, 0) diff --git a/src/w32fns.c b/src/w32fns.c index a2a88b2588..fc80e01883 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -9230,7 +9230,7 @@ DEFUN ("default-printer-name", Fdefault_printer_name, Sdefault_printer_name, 0, 0, 0, doc: /* Return the name of Windows default printer device. */) (void) { - static char pname_buf[256]; + static char pname_buf[2 * MAX_UTF8_PATH + 3 - 1]; int err; HANDLE hPrn; PRINTER_INFO_2W *ppi2w = NULL; commit 4ce9c6d0b58bd77bc811d6c1c5caf955a5a0be2f Author: Mattias Engdegård Date: Tue Jul 30 17:33:19 2019 +0200 Fix various Calc date conversions (bug#36822) * lisp/calc/calc-forms.el (math-absolute-from-gregorian-dt): Rewrite in a way that I understand, and that actually seems to work. (math-absolute-from-julian-dt): Use Julian, not Gregorian, leap year rules for counting days within a year. (math-julian-date-beginning, math-julian-date-beginning-int): Change constants to be consistent with their doc strings and the code: use Rata Die epoch at Dec 31, 1 BC Gregorian proleptic, not Julian. * doc/misc/calc.texi (Date Forms): Correct difference between Julian Day and Rata Die. * test/lisp/calc/calc-tests.el (calc-test-calendar): New test. diff --git a/doc/misc/calc.texi b/doc/misc/calc.texi index 75bbae58b2..c13ba8b940 100644 --- a/doc/misc/calc.texi +++ b/doc/misc/calc.texi @@ -11055,9 +11055,9 @@ Another day counting system in common use is, confusingly, also called is the numbers of days since 12:00 noon (GMT) on November 24, 4714 BC in the Gregorian calendar (i.e., January 1, 4713 BC in the Julian calendar). In Calc's scheme (in GMT) the Julian day origin is -@mathit{-1721422.5}, because Calc starts at midnight instead of noon. +@mathit{-1721424.5}, because Calc starts at midnight instead of noon. Thus to convert a Calc date code obtained by unpacking a -date form into a Julian day number, simply add 1721422.5 after +date form into a Julian day number, simply add 1721424.5 after compensating for the time zone difference. The built-in @kbd{t J} command performs this conversion for you. diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el index bdfc0e44dd..c410ffe449 100644 --- a/lisp/calc/calc-forms.el +++ b/lisp/calc/calc-forms.el @@ -587,29 +587,15 @@ A DT is a list of the form (YEAR MONTH DAY)." "Return the DATE of the day given by the Gregorian day YEAR MONTH DAY. Recall that DATE is the number of days since December 31, -1 in the Gregorian calendar." - (if (eq year 0) (setq year -1)) - (let ((yearm1 (math-sub year 1))) - (math-sub - ;; Add the number of days of the year and the numbers of days - ;; in the previous years (leap year days to be added separately) - (math-add (math-day-in-year year month day) - (math-add (math-mul 365 yearm1) - ;; Add the number of Julian leap years - (if (math-posp year) - (math-quotient yearm1 4) - (math-sub 365 - (math-quotient (math-sub 3 year) - 4))))) - ;; Subtract the number of Julian leap years which are not - ;; Gregorian leap years. In C=4N+r centuries, there will - ;; be 3N+r of these days. The following will compute - ;; 3N+r. - (let* ((correction (math-mul (math-quotient yearm1 100) 3)) - (res (math-idivmod correction 4))) - (math-add (if (= (cdr res) 0) - 0 - 1) - (car res)))))) + (when (zerop year) ; Year -1 precedes year 1. + (setq year -1)) + (let* ((y (if (> year 0) year (+ year 1))) ; Astronomical year (with 0). + (y1 (- y 1))) ; Previous year. + (+ (* y1 365) ; Days up to the previous year... + (floor y1 4) ; ... including leap days. + (- (floor y1 100)) + (floor y1 400) + (math-day-in-year year month day)))) (defun math-absolute-from-julian-dt (year month day) "Return the DATE of the day given by the Julian day YEAR MONTH DAY. @@ -620,7 +606,7 @@ in the Gregorian calendar." (math-sub ;; Add the number of days of the year and the numbers of days ;; in the previous years (leap year days to be added separately) - (math-add (math-day-in-year year month day) + (math-add (math-day-in-year year month day t) (math-add (math-mul 365 yearm1) ;; Add the number of Julian leap years (if (math-posp year) @@ -714,11 +700,11 @@ in the Gregorian calendar." (setcdr math-fd-dt nil)) fmt)))) -(defconst math-julian-date-beginning '(float 17214225 -1) +(defconst math-julian-date-beginning '(float 17214245 -1) "The beginning of the Julian date calendar, as measured in the number of days before December 31, 1 BC (Gregorian).") -(defconst math-julian-date-beginning-int 1721423 +(defconst math-julian-date-beginning-int 1721425 "The beginning of the Julian date calendar, as measured in the integer number of days before December 31, 1 BC (Gregorian).") diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el index 77d939eb40..e1ee20b5d2 100644 --- a/test/lisp/calc/calc-tests.el +++ b/test/lisp/calc/calc-tests.el @@ -193,6 +193,27 @@ An existing calc stack is reused, otherwise a new one is created." (let ((calc-number-radix 36)) (should (equal (math-format-number 12345678901) "36#5,O6A,QT1"))))) +(ert-deftest calc-test-calendar () + "Test calendar conversions (bug#36822)." + (should (equal (calcFunc-julian (math-parse-date "2019-07-27")) 2458692)) + (should (equal (math-parse-date "2019-07-27") '(date 737267))) + (should (equal (calcFunc-julian '(date 0)) 1721425)) + (should (equal (math-date-to-gregorian-dt 1) '(1 1 1))) + (should (equal (math-date-to-gregorian-dt 0) '(-1 12 31))) + (should (equal (math-date-to-gregorian-dt -1721425) '(-4714 11 24))) + (should (equal (math-absolute-from-gregorian-dt 2019 7 27) 737267)) + (should (equal (math-absolute-from-gregorian-dt 1 1 1) 1)) + (should (equal (math-absolute-from-gregorian-dt -1 12 31) 0)) + (should (equal (math-absolute-from-gregorian-dt -99 12 31) -35795)) + (should (equal (math-absolute-from-gregorian-dt -4714 11 24) -1721425)) + (should (equal (calcFunc-julian '(date -1721425)) 0)) + (should (equal (math-date-to-julian-dt 1) '(1 1 3))) + (should (equal (math-date-to-julian-dt -1721425) '(-4713 1 1))) + (should (equal (math-absolute-from-julian-dt 2019 1 1) 737073)) + (should (equal (math-absolute-from-julian-dt 1 1 3) 1)) + (should (equal (math-absolute-from-julian-dt -101 1 1) -36892)) + (should (equal (math-absolute-from-julian-dt -101 3 1) -36832)) + (should (equal (math-absolute-from-julian-dt -4713 1 1) -1721425))) (provide 'calc-tests) ;;; calc-tests.el ends here commit c676444a43e4634c1f98ec286b5bd9e46b23216b Author: Mattias Engdegård Date: Wed Jul 31 19:45:06 2019 +0200 Add conditional operator xor to subr.el Suggested by Oleh Krehel and implemented by Basil Contovounesios in the following thread: https://lists.gnu.org/archive/html/emacs-devel/2019-07/msg00547.html * lisp/array.el (xor): Move unused function from here... * lisp/subr.el: ...to here, and improve. * lisp/gnus/spam.el (spam-xor): * lisp/play/5x5.el (5x5-xor): * lisp/proced.el (proced-xor): * lisp/progmodes/idlwave.el (idlwave-xor): * lisp/vc/diff-mode.el (diff-xor): Define as obsolete aliases of, and replace all uses with, xor. * lisp/jsonrpc.el: Remove unused dependency on array.el. * lisp/org/org.el (org-xor): Move from here... * lisp/org/org-compat.el (org-xor): ...to here, as a compatibility shim for xor. * lisp/progmodes/idlw-shell.el (idlwave-shell-enable-all-bp): * lisp/simple.el (exchange-point-and-mark): * lisp/windmove.el (windmove-display-in-direction): Use xor. * lisp/strokes.el (strokes-xor): Remove commented-out xor implementation. * doc/lispref/control.texi (Control Structures): Extend menu entry for new combining condition. (Combining Conditions): * etc/NEWS (Lisp Changes): Document xor. * test/lisp/subr-tests.el (subr-test-xor): New test. diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index e98daf66e9..31948fa079 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -38,7 +38,7 @@ structure constructs (@pxref{Macros}). @menu * Sequencing:: Evaluation in textual order. * Conditionals:: @code{if}, @code{cond}, @code{when}, @code{unless}. -* Combining Conditions:: @code{and}, @code{or}, @code{not}. +* Combining Conditions:: @code{and}, @code{or}, @code{not}, and friends. * Pattern-Matching Conditional:: How to use @code{pcase} and friends. * Iteration:: @code{while} loops. * Generators:: Generic sequences and coroutines. @@ -298,8 +298,8 @@ For example: @section Constructs for Combining Conditions @cindex combining conditions - This section describes three constructs that are often used together -with @code{if} and @code{cond} to express complicated conditions. The + This section describes constructs that are often used together with +@code{if} and @code{cond} to express complicated conditions. The constructs @code{and} and @code{or} can also be used individually as kinds of multiple conditional constructs. @@ -419,6 +419,15 @@ This is not completely equivalent because it can evaluate @var{arg1} or @var{arg3})} never evaluates any argument more than once. @end defspec +@defun xor condition1 condition2 +This function returns the boolean exclusive-or of @var{condition1} and +@var{condition2}. That is, @code{xor} returns @code{nil} if either +both arguments are @code{nil}, or both are non-@code{nil}. Otherwise, +it returns the value of that argument which is non-@code{nil}. + +Note that in contrast to @code{or}, both arguments are always evaluated. +@end defun + @node Pattern-Matching Conditional @section Pattern-Matching Conditional @cindex pcase diff --git a/etc/NEWS b/etc/NEWS index a078bcebfc..818875f7a0 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2512,6 +2512,13 @@ parameter to control descending into subdirectories, and a FOLLOW-SYMLINK parameter to say that symbolic links that point to other directories should be followed. ++++ +** New function 'xor' returns the boolean exclusive-or of its args. +The function was previously defined in array.el, but has been moved to +subr.el so that it is available by default. It now always returns the +non-nil argument when the other is nil. Several duplicates of 'xor' +in other packages are now obsolete aliases of 'xor'. + * Changes in Emacs 27.1 on Non-Free Operating Systems diff --git a/lisp/array.el b/lisp/array.el index 2fffe0197e..965e97ff55 100644 --- a/lisp/array.el +++ b/lisp/array.el @@ -740,11 +740,6 @@ of `array-rows-numbered'." ((> index limit) limit) (t index))) -(defun xor (pred1 pred2) - "Return the logical exclusive or of predicates PRED1 and PRED2." - (and (or pred1 pred2) - (not (and pred1 pred2)))) - (defun current-line () "Return the current buffer line at point. The first line is 0." (count-lines (point-min) (line-beginning-position))) diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index d752bf0efe..f990e0cba1 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -708,9 +708,7 @@ finds ham or spam.") "Clear the `spam-caches' entry for a check." (remhash symbol spam-caches)) -(defun spam-xor (a b) - "Logical A xor B." - (and (or a b) (not (and a b)))) +(define-obsolete-function-alias 'spam-xor 'xor "27.1") (defun spam-set-difference (list1 list2) "Return a set difference of LIST1 and LIST2. @@ -2550,7 +2548,7 @@ With a non-nil REMOVE, remove the ADDRESSES." (goto-char (point-min)) (dolist (article articles) (insert (spam-get-article-as-string article))) - (let* ((arg (if (spam-xor unregister article-is-spam-p) + (let* ((arg (if (xor unregister article-is-spam-p) "-spam" "-good")) (status diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 0fffee6866..85fd40ecd2 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -43,7 +43,6 @@ (require 'warnings) (require 'pcase) (require 'ert) ; to escape a `condition-case-unless-debug' -(require 'array) ; xor ;;; Public API diff --git a/lisp/org/org-compat.el b/lisp/org/org-compat.el index 062bb4c5ca..bb927fedf9 100644 --- a/lisp/org/org-compat.el +++ b/lisp/org/org-compat.el @@ -362,6 +362,14 @@ use of this function is for the stuck project list." ;;; Miscellaneous functions +;; `xor' was added in Emacs 27.1. +(defalias 'org-xor + (if (fboundp 'xor) + #'xor + (lambda (a b) + "Exclusive or." + (if a (not b) b)))) + (defun org-version-check (version feature level) (let* ((v1 (mapcar 'string-to-number (split-string version "[.]"))) (v2 (mapcar 'string-to-number (split-string emacs-version "[.]"))) diff --git a/lisp/org/org.el b/lisp/org/org.el index e4c075f8cd..336c413c8c 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -10068,10 +10068,6 @@ Note: this function also decodes single byte encodings like (char-to-string (string-to-number byte 16))) (cdr (split-string hex "%")) "")) -(defun org-xor (a b) - "Exclusive or." - (if a (not b) b)) - (defun org-fixup-message-id-for-http (s) "Replace special characters in a message id, so it can be used in an http query." (when (string-match "%" s) diff --git a/lisp/play/5x5.el b/lisp/play/5x5.el index 28748cc351..c5d4659123 100644 --- a/lisp/play/5x5.el +++ b/lisp/play/5x5.el @@ -435,8 +435,8 @@ should return a grid vector array that is the new solution." (dotimes (y 5x5-grid-size) (dotimes (x 5x5-grid-size) (5x5-set-cell xored y x - (5x5-xor (5x5-cell current y x) - (5x5-cell best y x))))) + (xor (5x5-cell current y x) + (5x5-cell best y x))))) (5x5-mutate-solution xored))) (defun 5x5-mutate-solution (solution) @@ -931,9 +931,7 @@ lest." ;; Support functions -(defun 5x5-xor (x y) - "Boolean exclusive-or of X and Y." - (and (or x y) (not (and x y)))) +(define-obsolete-function-alias '5x5-xor 'xor "27.1") (defun 5x5-y-or-n-p (prompt) "5x5 wrapper for `y-or-n-p' which respects the `5x5-hassle-me' setting." diff --git a/lisp/proced.el b/lisp/proced.el index db8bdb5ac8..24bc321f43 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -1194,10 +1194,7 @@ Return `equal' if T1 equals T2. Return nil otherwise." ;;; Sorting -(defsubst proced-xor (b1 b2) - "Return the logical exclusive or of args B1 and B2." - (and (or b1 b2) - (not (and b1 b2)))) +(define-obsolete-function-alias 'proced-xor 'xor "27.1") (defun proced-sort-p (p1 p2) "Predicate for sorting processes P1 and P2." @@ -1208,8 +1205,8 @@ Return `equal' if T1 equals T2. Return nil otherwise." (k2 (cdr (assq (car sorter) (cdr p2))))) ;; if the attributes are undefined, we should really abort sorting (if (and k1 k2) - (proced-xor (funcall (nth 1 sorter) k1 k2) - (nth 2 sorter)))) + (xor (funcall (nth 1 sorter) k1 k2) + (nth 2 sorter)))) (let ((sort-list proced-sort-internal) sorter predicate k1 k2) (catch 'done (while (setq sorter (pop sort-list)) @@ -1219,7 +1216,7 @@ Return `equal' if T1 equals T2. Return nil otherwise." (if (and k1 k2) (funcall (nth 1 sorter) k1 k2))) (if (not (eq predicate 'equal)) - (throw 'done (proced-xor predicate (nth 2 sorter))))) + (throw 'done (xor predicate (nth 2 sorter))))) (eq t predicate))))) (defun proced-sort (process-alist sorter descend) diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el index 188ec012cf..e4f46bf882 100644 --- a/lisp/progmodes/idlw-shell.el +++ b/lisp/progmodes/idlw-shell.el @@ -2604,7 +2604,7 @@ If ENABLE is non-nil, enable them instead." (let ((bpl (or bpl idlwave-shell-bp-alist)) disabled modified) (while bpl (setq disabled (idlwave-shell-bp-get (car bpl) 'disabled)) - (when (idlwave-xor (not disabled) (eq enable 'enable)) + (when (xor (not disabled) (eq enable 'enable)) (idlwave-shell-toggle-enable-current-bp (car bpl) (if (eq enable 'enable) 'enable 'disable) no-update) (push (car bpl) modified)) diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el index 614d73e23b..1b4b55c94f 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/progmodes/idlwave.el @@ -8813,9 +8813,8 @@ routines, and may have been scanned." ;; FIXME: Dynamically scoped vars need to use the `idlwave-' prefix. ;; (defvar type) -(defmacro idlwave-xor (a b) - `(and (or ,a ,b) - (not (and ,a ,b)))) + +(define-obsolete-function-alias 'idlwave-xor 'xor "27.1") (defun idlwave-routine-entry-compare (a b) "Compare two routine info entries for sorting. @@ -8919,17 +8918,17 @@ This expects NAME TYPE IDLWAVE-TWIN-CLASS to be bound to the right values." ;; Now: follow JD's ideas about sorting. Looks really simple now, ;; doesn't it? The difficult stuff is hidden above... (cond - ((idlwave-xor asysp bsysp) asysp) ; System entries first - ((idlwave-xor aunresp bunresp) bunresp) ; Unresolved last + ((xor asysp bsysp) asysp) ; System entries first + ((xor aunresp bunresp) bunresp) ; Unresolved last ((and idlwave-sort-prefer-buffer-info - (idlwave-xor abufp bbufp)) abufp) ; Buffers before non-buffers - ((idlwave-xor acompp bcompp) acompp) ; Compiled entries - ((idlwave-xor apathp bpathp) apathp) ; Library before non-library - ((idlwave-xor anamep bnamep) anamep) ; Correct file names first - ((and idlwave-twin-class anamep bnamep ; both file names match -> - (idlwave-xor adefp bdefp)) bdefp) ; __define after __method - ((> anpath bnpath) t) ; Who is first on path? - (t nil)))) ; Default + (xor abufp bbufp)) abufp) ; Buffers before non-buffers + ((xor acompp bcompp) acompp) ; Compiled entries + ((xor apathp bpathp) apathp) ; Library before non-library + ((xor anamep bnamep) anamep) ; Correct file names first + ((and idlwave-twin-class anamep bnamep ; both file names match -> + (xor adefp bdefp)) bdefp) ; __define after __method + ((> anpath bnpath) t) ; Who is first on path? + (t nil)))) ; Default (defun idlwave-routine-source-file (source) (if (nth 2 source) diff --git a/lisp/simple.el b/lisp/simple.el index 26b82479ff..da20de4ad9 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -5857,8 +5857,7 @@ mode temporarily." (goto-char omark) (cond (temp-highlight (setq-local transient-mark-mode (cons 'only transient-mark-mode))) - ((or (and arg (region-active-p)) ; (xor arg (not (region-active-p))) - (not (or arg (region-active-p)))) + ((xor arg (not (region-active-p))) (deactivate-mark)) (t (activate-mark))) nil)) diff --git a/lisp/strokes.el b/lisp/strokes.el index 0c671c43ac..6edf58c7b6 100644 --- a/lisp/strokes.el +++ b/lisp/strokes.el @@ -1524,12 +1524,6 @@ Encode/decode your strokes with \\[strokes-encode-buffer], (or (eq char ?\s) (eq char ?*))) -;;(defsubst strokes-xor (a b) ### Should I make this an inline function? ### -;; "T if one and only one of A and B is non-nil; otherwise, returns nil. -;;NOTE: Don't use this as a numeric xor since it treats all non-nil -;; values as t including `0' (zero)." -;; (eq (null a) (not (null b)))) - (defsubst strokes-xpm-encode-length-as-string (length) "Given some LENGTH in [0,62) do a fast lookup of its encoding." (aref strokes-base64-chars length)) diff --git a/lisp/subr.el b/lisp/subr.el index 518575f6b4..b22db65bb6 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -209,6 +209,14 @@ value of last one, or nil if there are none. (declare (indent 1) (debug t)) (cons 'if (cons cond (cons nil body)))) +(defsubst xor (cond1 cond2) + "Return the boolean exclusive-or of COND1 and COND2. +If only one of the arguments is non-nil, return it; otherwise +return nil." + (declare (pure t) (side-effect-free error-free)) + (cond ((not cond1) cond2) + ((not cond2) cond1))) + (defmacro dolist (spec &rest body) "Loop over a list. Evaluate BODY with VAR bound to each car from LIST, in turn. diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 81662cafed..c4812e81d4 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -1771,7 +1771,7 @@ Whitespace differences are ignored." (if (> (- (car forw) orig) (- orig (car back))) back forw) (or back forw)))) -(defsubst diff-xor (a b) (if a (if (not b) a) b)) +(define-obsolete-function-alias 'diff-xor 'xor "27.1") (defun diff-find-source-location (&optional other-file reverse noprompt) "Find current diff location within the source file. @@ -1791,7 +1791,7 @@ SRC and DST are the two variants of text as returned by `diff-hunk-text'. SRC is the variant that was found in the buffer. SWITCHED is non-nil if the patch is already applied." (save-excursion - (let* ((other (diff-xor other-file diff-jump-to-old-file)) + (let* ((other (xor other-file diff-jump-to-old-file)) (char-offset (- (point) (diff-beginning-of-hunk t))) ;; Check that the hunk is well-formed. Otherwise diff-mode and ;; the user may disagree on what constitutes the hunk @@ -1917,7 +1917,7 @@ With a prefix argument, REVERSE the hunk." (insert (car new))) ;; Display BUF in a window (set-window-point (display-buffer buf) (+ (car pos) (cdr new))) - (diff-hunk-status-msg line-offset (diff-xor switched reverse) nil) + (diff-hunk-status-msg line-offset (xor switched reverse) nil) (when diff-advance-after-apply-hunk (diff-hunk-next)))))) @@ -1929,7 +1929,7 @@ With a prefix argument, try to REVERSE the hunk." (pcase-let ((`(,buf ,line-offset ,pos ,src ,_dst ,switched) (diff-find-source-location nil reverse))) (set-window-point (display-buffer buf) (+ (car pos) (cdr src))) - (diff-hunk-status-msg line-offset (diff-xor reverse switched) t))) + (diff-hunk-status-msg line-offset (xor reverse switched) t))) (defun diff-kill-applied-hunks () @@ -1966,7 +1966,7 @@ revision of the file otherwise." (pop-to-buffer buf) (goto-char (+ (car pos) (cdr src))) (when buffer (next-error-found buffer (current-buffer))) - (diff-hunk-status-msg line-offset (diff-xor reverse switched) t)))) + (diff-hunk-status-msg line-offset (xor reverse switched) t)))) (defun diff-current-defun () @@ -2376,7 +2376,7 @@ fixed, visit it in a buffer." (interactive "P") (save-excursion (goto-char (point-min)) - (let* ((other (diff-xor other-file diff-jump-to-old-file)) + (let* ((other (xor other-file diff-jump-to-old-file)) (modified-buffers nil) (style (save-excursion (when (re-search-forward diff-hunk-header-re nil t) diff --git a/lisp/windmove.el b/lisp/windmove.el index ab47565dfa..f5f51480db 100644 --- a/lisp/windmove.el +++ b/lisp/windmove.el @@ -592,7 +592,7 @@ select the window with a displayed buffer, and the meaning of the prefix argument is reversed. When `switch-to-buffer-obey-display-actions' is non-nil, `switch-to-buffer' commands are also supported." - (let* ((no-select (not (eq (consp arg) windmove-display-no-select))) ; xor + (let* ((no-select (xor (consp arg) windmove-display-no-select)) (old-window (or (minibuffer-selected-window) (selected-window))) (new-window) (minibuffer-depth (minibuffer-depth)) diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 0023680738..b3c04cdc9a 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -125,6 +125,13 @@ (should (equal (macroexpand-all '(when a b c d)) '(if a (progn b c d))))) +(ert-deftest subr-test-xor () + "Test `xor'." + (should-not (xor nil nil)) + (should (eq (xor nil 'true) 'true)) + (should (eq (xor 'true nil) 'true)) + (should-not (xor t t))) + (ert-deftest subr-test-version-parsing () (should (equal (version-to-list ".5") '(0 5))) (should (equal (version-to-list "0.9 alpha1") '(0 9 -3 1))) commit 1d8b5bc8dd543ada2f3c46436e43ea27faa3cd0e Author: Stefan Monnier Date: Tue Aug 6 04:01:49 2019 -0400 Move cl.el to lisp/obsolete * lisp/emacs-lisp/cl.el: Move from here... * lisp/obsolete/cl.el: ...to here. * lisp/subr.el (do-after-load-evaluation): Use "deprecated" in the message when loading packages from lisp/obsolete. diff --git a/etc/NEWS b/etc/NEWS index 734d5fd8a8..a078bcebfc 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -497,6 +497,8 @@ current and the previous or the next line, as before. * Changes in Specialized Modes and Packages in Emacs 27.1 +** The 'cl' package is now officially deprecated in favor of `cl-lib`. + +++ ** winner *** A new variable, 'winner-boring-buffers-regexp', has been added. diff --git a/lisp/emacs-lisp/cl.el b/lisp/obsolete/cl.el similarity index 99% rename from lisp/emacs-lisp/cl.el rename to lisp/obsolete/cl.el index 71be1d1b49..417c757ed5 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/obsolete/cl.el @@ -3,6 +3,7 @@ ;; Copyright (C) 2012-2019 Free Software Foundation, Inc. ;; Author: Stefan Monnier +;; Deprecated-since: 27.1 ;; Keywords: extensions ;; This file is part of GNU Emacs. diff --git a/lisp/subr.el b/lisp/subr.el index eea4e045dd..518575f6b4 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -4453,7 +4453,7 @@ This function is called directly from the C code." (package (intern (substring file 0 (string-match "\\.elc?\\>" file)) obarray)) - (msg (format "Package %s is obsolete" package))) + (msg (format "Package %s is deprecated" package))) ;; Cribbed from cl--compiling-file. (when (or (not (fboundp 'byte-compile-warning-enabled-p)) (byte-compile-warning-enabled-p 'obsolete package)) commit 6231483b7e13f1ad34b8aec560e7cc640059d6f9 Author: Stefan Monnier Date: Tue Aug 6 03:58:50 2019 -0400 * lisp/mail/rfc2047.el (rfc2047-encodable-p): Don't require `message`. Use bound-and-true-p rather than requiring `message` to get message-posting-charset (since it defaults to nil anyway). diff --git a/lisp/mail/rfc2047.el b/lisp/mail/rfc2047.el index a02201ec32..188e5dc396 100644 --- a/lisp/mail/rfc2047.el +++ b/lisp/mail/rfc2047.el @@ -325,7 +325,6 @@ Should be called narrowed to the head of the message." (defun rfc2047-encodable-p () "Return non-nil if any characters in current buffer need encoding in headers. The buffer may be narrowed." - (require 'message) ; for message-posting-charset (let ((charsets (mm-find-mime-charset-region (point-min) (point-max)))) (goto-char (point-min)) @@ -334,7 +333,7 @@ The buffer may be narrowed." (re-search-forward rfc2047-encoded-word-regexp nil t) (goto-char (point-min)))) (and charsets - (not (equal charsets (list (car message-posting-charset)))))))) + (not (equal charsets (list (car (bound-and-true-p message-posting-charset))))))))) ;; Use this syntax table when parsing into regions that may need ;; encoding. Double quotes are string delimiters, backslash is commit 74b097b61c5201405ad7bc5bb76f1ca0e794184b Author: Stefan Monnier Date: Tue Aug 6 03:56:51 2019 -0400 * lisp/mh-e: Use cl-lib Also, use underscore prefixes and defvar in preparation for lexical binding * lisp/mh-e/mh-acros.el: Require cl-lib instead of cl. Rename all cl.el uses by adding `cl-` prefix. (mh-require-cl): Remove. Not needed any more. Remove all calls. (mh-defstruct): Remove. Replace all uses with cl-defstruct. (mh-dlet*): New macro. * lisp/mh-e/mh-comp.el (mh-user-agent-compose): Fold all ignored optional args into the &rest arg. * lisp/mh-e/mh-e.el: Require cl-lib instead of using mh-require-cl. (mh-variants): Don't add-to-list on a local var. * lisp/mh-e/mh-folder.el (mh-restore-desktop-buffer): Use shorter arg names that don't collide with global vars. * lisp/mh-e/mh-mime.el (mh-insert-mime-button): (mh-insert-mime-security-button): Use mh-dlet*. * lisp/mh-e/mh-search.el (mh-swish-next-result, mh-grep-next-result) (mh-namazu-next-result): Use `or`. * lisp/mh-e/mh-thread.el (mh-thread-generate) (mh-thread-prune-containers): Use underscore rather than declare+ignore. * lisp/mh-e/mh-tool-bar.el (mh-tool-bar-define): Use mh-dlet*. (mh-tool-bar-define): Prefer the more precise \`...\' regexp ops. Prefer Elisp's `eval-and-compile` over `cl-eval-when`. * lisp/mh-e/mh-xface.el (mh-picon-get-image): Don't use mh-funcall-if-exists for ietf-drums-parse-address. Avoid the use of `cl-return` and hence use plain `defun`. Replace some `cl-loop` with `dolist`. diff --git a/lisp/mh-e/mh-acros.el b/lisp/mh-e/mh-acros.el index 3bbf509989..c017419df2 100644 --- a/lisp/mh-e/mh-acros.el +++ b/lisp/mh-e/mh-acros.el @@ -40,30 +40,12 @@ ;;; Code: -(require 'cl) +(require 'cl-lib) ;;; Compatibility -;; TODO: Replace `cl' with `cl-lib'. -;; `cl' is deprecated in Emacs 24.3. Use `cl-lib' instead. However, -;; we'll likely have to insert `cl-' before each use of a Common Lisp -;; function. -;;;###mh-autoload -(defmacro mh-require-cl () - "Macro to load \"cl\" if needed. - -Emacs coding conventions require that the \"cl\" package not be -required at runtime. However, the \"cl\" package in Emacs 21.4 -and earlier left \"cl\" routines in their macro expansions. In -particular, the expansion of (setf (gethash ...) ...) used -functions in \"cl\" at run time. This macro recognizes that and -loads \"cl\" appropriately." - (if (eq (car (macroexpand '(setf (gethash foo bar) baz))) 'cl-puthash) - '(require 'cl) - '(eval-when-compile (require 'cl)))) - ;;;###mh-autoload (defmacro mh-do-in-gnu-emacs (&rest body) "Execute BODY if in GNU Emacs." @@ -81,6 +63,9 @@ loads \"cl\" appropriately." ;;;###mh-autoload (defmacro mh-funcall-if-exists (function &rest args) "Call FUNCTION with ARGS as parameters if it exists." + ;; FIXME: Not clear when this should be used. If the function happens + ;; not to exist at compile-time (e.g. because the corresponding package + ;; wasn't loaded), then it won't ever be used :-( (when (fboundp function) `(when (fboundp ',function) (funcall ',function ,@args)))) @@ -135,53 +120,6 @@ check if variable `transient-mark-mode' is active." '(and (boundp 'transient-mark-mode) transient-mark-mode (boundp 'mark-active) mark-active)))) -;; Shush compiler. -(mh-do-in-xemacs - (defvar struct) - (defvar x) - (defvar y)) - -;;;###mh-autoload -(defmacro mh-defstruct (name-spec &rest fields) - ;; FIXME: Use `cl-defstruct' instead: shouldn't emit warnings any - ;; more nor depend on run-time CL functions. - "Replacement for `defstruct' from the \"cl\" package. -The `defstruct' in the \"cl\" library produces compiler warnings, -and generates code that uses functions present in \"cl\" at -run-time. This is a partial replacement, that avoids these -issues. - -NAME-SPEC declares the name of the structure, while FIELDS -describes the various structure fields. Lookup `defstruct' for -more details." - (let* ((struct-name (if (atom name-spec) name-spec (car name-spec))) - (conc-name (or (and (consp name-spec) - (cadr (assoc :conc-name (cdr name-spec)))) - (format "%s-" struct-name))) - (predicate (intern (format "%s-p" struct-name))) - (constructor (or (and (consp name-spec) - (cadr (assoc :constructor (cdr name-spec)))) - (intern (format "make-%s" struct-name)))) - (fields (mapcar (lambda (x) - (if (atom x) - (list x nil) - (list (car x) (cadr x)))) - fields)) - (field-names (mapcar #'car fields)) - (struct (gensym "S")) - (x (gensym "X")) - (y (gensym "Y"))) - `(progn - (defun* ,constructor (&key ,@fields) - (list (quote ,struct-name) ,@field-names)) - (defun ,predicate (arg) - (and (consp arg) (eq (car arg) (quote ,struct-name)))) - ,@(loop for x from 1 - for y in field-names - collect `(defmacro ,(intern (format "%s%s" conc-name y)) (z) - (list 'nth ,x z))) - (quote ,struct-name)))) - ;;;###mh-autoload (defmacro with-mh-folder-updating (save-modification-flag &rest body) "Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG) &body BODY). @@ -327,6 +265,16 @@ MH-E functions." ,@body)))))))) (put 'mh-iterate-on-range 'lisp-indent-hook 'defun) +(defmacro mh-dlet* (binders &rest body) + "Like `let*' but always dynamically scoped." + (declare (debug let) (indent 1)) + ;; Works in both lexical and non-lexical mode. + `(progn + ,@(mapcar (lambda (binder) + `(defvar ,(if (consp binder) (car binder) binder))) + binders) + (let* ,binders ,@body))) + (provide 'mh-acros) ;; Local Variables: diff --git a/lisp/mh-e/mh-alias.el b/lisp/mh-e/mh-alias.el index c6cdfc40c9..2ff8801cd9 100644 --- a/lisp/mh-e/mh-alias.el +++ b/lisp/mh-e/mh-alias.el @@ -30,8 +30,6 @@ (require 'mh-e) -(mh-require-cl) - (require 'goto-addr) (defvar mh-alias-alist 'not-read @@ -308,7 +306,7 @@ Blind aliases or users from /etc/passwd are not expanded." (if (not mh-alias-expand-aliases-flag) mh-alias-alist (lambda (string pred action) - (case action + (cl-case action ((nil) (let ((res (try-completion string mh-alias-alist pred))) (if (or (eq res t) diff --git a/lisp/mh-e/mh-comp.el b/lisp/mh-e/mh-comp.el index a5614f5255..1ffe56a6db 100644 --- a/lisp/mh-e/mh-comp.el +++ b/lisp/mh-e/mh-comp.el @@ -217,7 +217,7 @@ TO, CC, and SUBJECT arguments are used." (defvar mh-error-if-no-draft nil) ;raise error over using old draft ;;;###autoload -(defun mh-smail-batch (&optional to subject other-headers &rest ignored) +(defun mh-smail-batch (&optional to subject _other-headers &rest _ignored) "Compose a message with the MH mail system. This function does not prompt the user for any header fields, and @@ -239,10 +239,7 @@ applications should use `mh-user-agent-compose'." 'mh-before-send-letter-hook) ;;;###autoload -(defun mh-user-agent-compose (&optional to subject other-headers continue - switch-function yank-action - send-actions return-action - &rest ignored) +(defun mh-user-agent-compose (&optional to subject other-headers &rest _ignored) "Set up mail composition draft with the MH mail system. This is the `mail-user-agent' entry point to MH-E. This function conforms to the contract specified by `define-mail-user-agent' @@ -256,8 +253,7 @@ OTHER-HEADERS is an alist specifying additional header fields. Elements look like (HEADER . VALUE) where both HEADER and VALUE are strings. -CONTINUE, SWITCH-FUNCTION, YANK-ACTION, SEND-ACTIONS, and -RETURN-ACTION and any additional arguments are IGNORED." +Any additional arguments are IGNORED." (mh-find-path) (let ((mh-error-if-no-draft t)) (mh-send to "" subject) @@ -266,9 +262,7 @@ RETURN-ACTION and any additional arguments are IGNORED." (cdr (car other-headers))) (setq other-headers (cdr other-headers))))) -;; Shush compiler. -(mh-do-in-xemacs - (defvar sendmail-coding-system)) +(defvar sendmail-coding-system) ;;;###autoload (defun mh-send-letter (&optional arg) @@ -1297,10 +1291,10 @@ discarded." "Check if current buffer is entirely composed of ASCII. The function doesn't work for XEmacs since `find-charset-region' doesn't exist there." - (loop for charset in (mh-funcall-if-exists - find-charset-region (point-min) (point-max)) - unless (eq charset 'ascii) return nil - finally return t)) + (cl-loop for charset in (mh-funcall-if-exists + find-charset-region (point-min) (point-max)) + unless (eq charset 'ascii) return nil + finally return t)) (provide 'mh-comp) diff --git a/lisp/mh-e/mh-compat.el b/lisp/mh-e/mh-compat.el index a459d27ee2..7c5bd3a987 100644 --- a/lisp/mh-e/mh-compat.el +++ b/lisp/mh-e/mh-compat.el @@ -143,7 +143,7 @@ introduced in Emacs 22." `(face-background ,face ,frame ,inherit))) (defun-mh mh-font-lock-add-keywords font-lock-add-keywords - (mode keywords &optional how) + (_mode _keywords &optional _how) "XEmacs does not have `font-lock-add-keywords'. This function returns nil on that system.") @@ -243,7 +243,7 @@ compatibility with versions of Emacs that lack the variable (delete image-directory (copy-sequence (or path load-path)))))) (defun-mh mh-image-search-load-path - image-search-load-path (file &optional path) + image-search-load-path (_file &optional _path) "Emacs 21 and XEmacs don't have `image-search-load-path'. This function returns nil on those systems." nil) @@ -292,7 +292,7 @@ introduced in Emacs 24." `(make-obsolete-variable ,obsolete-name ,current-name ,when ,access-type)))) (defun-mh mh-match-string-no-properties - match-string-no-properties (num &optional string) + match-string-no-properties (num &optional _string) "Return string of text matched by last search, without text properties. This function is used by XEmacs that lacks `match-string-no-properties'. The function `buffer-substring-no-properties' is used instead. @@ -301,7 +301,7 @@ The argument STRING is ignored." (match-beginning num) (match-end num))) (defun-mh mh-replace-regexp-in-string replace-regexp-in-string - (regexp rep string &optional fixedcase literal subexp start) + (regexp rep string &optional _fixedcase literal _subexp _start) "Replace REGEXP with REP everywhere in STRING and return result. This function is used by XEmacs that lacks `replace-regexp-in-string'. The function `replace-in-string' is used instead. @@ -311,7 +311,7 @@ The arguments FIXEDCASE, SUBEXP, and START, used by (replace-in-string string regexp rep literal))) (defun-mh mh-test-completion - test-completion (string collection &optional predicate) + test-completion (_string _collection &optional _predicate) "Return non-nil if STRING is a valid completion. XEmacs does not have `test-completion'. This function returns nil on that system." nil) @@ -352,7 +352,7 @@ The arguments RETURN-TO and EXIT-ACTION are ignored." (view-mode 1)) (defun-mh mh-window-full-height-p - window-full-height-p (&optional WINDOW) + window-full-height-p (&optional _window) "Return non-nil if WINDOW is not the result of a vertical split. This function is defined in XEmacs as it lacks `window-full-height-p'. The values of the functions diff --git a/lisp/mh-e/mh-e.el b/lisp/mh-e/mh-e.el index c70e11e773..7644f6e961 100644 --- a/lisp/mh-e/mh-e.el +++ b/lisp/mh-e/mh-e.el @@ -91,7 +91,7 @@ ;; for if it does it will introduce a require loop. (require 'mh-loaddefs) -(mh-require-cl) +(require 'cl-lib) (require 'mh-buffers) (require 'mh-compat) @@ -496,7 +496,7 @@ all the strings have been used." (push (buffer-substring-no-properties (point) (mh-line-end-position)) arg-list) - (incf count) + (cl-incf count) (forward-line)) (apply #'call-process cmd nil (list out nil) nil (nreverse arg-list)))) @@ -509,8 +509,8 @@ all the strings have been used." Adds double-quotes around entire string and quotes the characters \\, `, and $ with a backslash." (concat "\"" - (loop for x across string - concat (format (if (memq x '(?\\ ?` ?$)) "\\%c" "%c") x)) + (cl-loop for x across string + concat (format (if (memq x '(?\\ ?` ?$)) "\\%c" "%c") x)) "\"")) (defun mh-exec-cmd (command &rest args) @@ -527,7 +527,7 @@ parsed by MH-E." (save-excursion (goto-char start) (insert "Errors when executing: " command) - (loop for arg in args do (insert " " arg)) + (cl-loop for arg in args do (insert " " arg)) (insert "\n")) (save-window-excursion (switch-to-buffer-other-window mh-log-buffer) @@ -583,7 +583,7 @@ ARGS are passed to COMMAND as command line arguments." (push elem process-environment)) (apply #'mh-exec-cmd-daemon command filter args))) -(defun mh-process-daemon (process output) +(defun mh-process-daemon (_process output) "PROCESS daemon that puts OUTPUT into a temporary buffer. Any output from the process is displayed in an asynchronous pop-up window." @@ -683,11 +683,11 @@ ARGS is returned unchanged." `(if (boundp 'customize-package-emacs-version-alist) ,args (let (seen) - (loop for keyword in ,args - if (cond ((eq keyword ':package-version) (setq seen t) nil) - (seen (setq seen nil) nil) - (t t)) - collect keyword)))) + (cl-loop for keyword in ,args + if (cond ((eq keyword ':package-version) (setq seen t) nil) + (seen (setq seen nil) nil) + (t t)) + collect keyword)))) (defmacro defgroup-mh (symbol members doc &rest args) "Declare SYMBOL as a customization group containing MEMBERS. @@ -740,14 +740,14 @@ is described by the variable `mh-variants'." (let ((list-unique)) ;; Make a unique list of directories, keeping the given order. ;; We don't want the same MH variant to be listed multiple times. - (loop for dir in (append mh-path mh-sys-path exec-path) do - (setq dir (file-chase-links (directory-file-name dir))) - (add-to-list 'list-unique dir)) - (loop for dir in (nreverse list-unique) do - (when (and dir (file-accessible-directory-p dir)) - (let ((variant (mh-variant-info dir))) - (if variant - (add-to-list 'mh-variants variant))))) + (cl-loop for dir in (append mh-path mh-sys-path exec-path) do + (setq dir (file-chase-links (directory-file-name dir))) + (cl-pushnew dir list-unique :test #'equal)) + (cl-loop for dir in (nreverse list-unique) do + (when (and dir (file-accessible-directory-p dir)) + (let ((variant (mh-variant-info dir))) + (if variant + (add-to-list 'mh-variants variant))))) mh-variants))) (defun mh-variant-info (dir) @@ -858,22 +858,22 @@ variant." mh-progs progs mh-variant-in-use variant)))) ((symbolp variant) ;e.g. 'nmh (pick the first match) - (loop for variant-list in (mh-variants) - when (eq variant (cadr (assoc 'variant (cdr variant-list)))) - return (let* ((version (car variant-list)) - (alist (cdr variant-list)) - (lib-progs (cadr (assoc 'mh-lib-progs alist))) - (lib (cadr (assoc 'mh-lib alist))) - (progs (cadr (assoc 'mh-progs alist))) - (flists (cadr (assoc 'flists alist)))) - ;;(set-default mh-variant flavor) - (setq mh-x-mailer-string nil - mh-flists-present-flag flists - mh-lib-progs lib-progs - mh-lib lib - mh-progs progs - mh-variant-in-use version) - t))))) + (cl-loop for variant-list in (mh-variants) + when (eq variant (cadr (assoc 'variant (cdr variant-list)))) + return (let* ((version (car variant-list)) + (alist (cdr variant-list)) + (lib-progs (cadr (assoc 'mh-lib-progs alist))) + (lib (cadr (assoc 'mh-lib alist))) + (progs (cadr (assoc 'mh-progs alist))) + (flists (cadr (assoc 'flists alist)))) + ;;(set-default mh-variant flavor) + (setq mh-x-mailer-string nil + mh-flists-present-flag flists + mh-lib-progs lib-progs + mh-lib lib + mh-progs progs + mh-variant-in-use version) + t))))) (defun mh-variant-p (&rest variants) "Return t if variant is any of VARIANTS. @@ -1706,9 +1706,9 @@ The function is always called with SYMBOL bound to (set symbol value) ;XXX shouldn't this be set-default? (setq mh-junk-choice (or value - (loop for element in mh-junk-function-alist - until (executable-find (symbol-name (car element))) - finally return (car element))))) + (cl-loop for element in mh-junk-function-alist + until (executable-find (symbol-name (car element))) + finally return (car element))))) (defcustom-mh mh-junk-background nil "If on, spam programs are run in background. @@ -2885,9 +2885,9 @@ removed and entries from `mh-invisible-header-fields' are added." (when mh-invisible-header-fields-default ;; Remove entries from `mh-invisible-header-fields-default' (setq fields - (loop for x in fields - unless (member x mh-invisible-header-fields-default) - collect x))) + (cl-loop for x in fields + unless (member x mh-invisible-header-fields-default) + collect x))) (when (and (boundp 'mh-invisible-header-fields) mh-invisible-header-fields) (dolist (x mh-invisible-header-fields) @@ -3605,16 +3605,17 @@ specified colors." new-spec) ;; Remove entries with min-colors, or delete them if we have ;; fewer colors than they specify. - (loop for entry in (reverse spec) do - (let ((requirement (if (eq (car entry) t) - nil - (assq 'min-colors (car entry))))) - (if requirement - (when (>= cells (nth 1 requirement)) - (setq new-spec (cons (cons (delq requirement (car entry)) - (cdr entry)) - new-spec))) - (setq new-spec (cons entry new-spec))))) + (cl-loop + for entry in (reverse spec) do + (let ((requirement (if (eq (car entry) t) + nil + (assq 'min-colors (car entry))))) + (if requirement + (when (>= cells (nth 1 requirement)) + (setq new-spec (cons (cons (delq requirement (car entry)) + (cdr entry)) + new-spec))) + (setq new-spec (cons entry new-spec))))) new-spec)))) (defface-mh mh-folder-address diff --git a/lisp/mh-e/mh-folder.el b/lisp/mh-e/mh-folder.el index 5b4c34fb6a..7e7918e6c2 100644 --- a/lisp/mh-e/mh-folder.el +++ b/lisp/mh-e/mh-folder.el @@ -31,7 +31,6 @@ (require 'mh-e) (require 'mh-scan) -(mh-require-cl) ;; Dynamically-created functions not found in mh-loaddefs.el. (autoload 'mh-tool-bar-folder-buttons-init "mh-tool-bar") @@ -80,16 +79,14 @@ the MH mail system." (add-to-list 'desktop-buffer-mode-handlers '(mh-folder-mode . mh-restore-desktop-buffer))) -(defun mh-restore-desktop-buffer (desktop-buffer-file-name - desktop-buffer-name - desktop-buffer-misc) +(defun mh-restore-desktop-buffer (_file-name name _misc) "Restore an MH folder buffer specified in a desktop file. -When desktop creates a buffer, DESKTOP-BUFFER-FILE-NAME holds the -file name to visit, DESKTOP-BUFFER-NAME holds the desired buffer -name, and DESKTOP-BUFFER-MISC holds a list of miscellaneous info +When desktop creates a buffer, FILE-NAME holds the +file name to visit, NAME holds the desired buffer +name, and MISC holds a list of miscellaneous info used by the `desktop-buffer-mode-handlers' functions." (mh-find-path) - (mh-visit-folder desktop-buffer-name) + (mh-visit-folder name) (current-buffer)) @@ -932,9 +929,9 @@ many unread messages to skip." (setq count (1- count))) (not (car unread-sequence))) (message "No more unread messages")) - (t (loop for msg in unread-sequence - when (mh-goto-msg msg t) return nil - finally (message "No more unread messages")))))) + (t (cl-loop for msg in unread-sequence + when (mh-goto-msg msg t) return nil + finally (message "No more unread messages")))))) ;;;###mh-autoload (defun mh-page-msg (&optional lines) @@ -1030,9 +1027,9 @@ many unread messages to skip." (setq count (1- count))) (not (car unread-sequence))) (message "No more unread messages")) - (t (loop for msg in unread-sequence - when (mh-goto-msg msg t) return nil - finally (message "No more unread messages")))))) + (t (cl-loop for msg in unread-sequence + when (mh-goto-msg msg t) return nil + finally (message "No more unread messages")))))) ;;;###mh-autoload (defun mh-quit () @@ -1503,7 +1500,7 @@ function doesn't recenter the folder buffer." (let ((lines-from-end 2)) (save-excursion (while (> (point-max) (progn (forward-line) (point))) - (incf lines-from-end))) + (cl-incf lines-from-end))) (recenter (- lines-from-end)))) ;; '(4) is the same as C-u prefix argument. (t (recenter (or arg '(4)))))) @@ -1587,10 +1584,11 @@ after the commands are processed." ;; Preserve sequences in destination folder... (when mh-refile-preserves-sequences-flag (clrhash dest-map) - (loop for i from (1+ (or last 0)) - for msg in (sort (copy-sequence msgs) #'<) - do (loop for seq-name in (gethash msg seq-map) - do (push i (gethash seq-name dest-map)))) + (cl-loop + for i from (1+ (or last 0)) + for msg in (sort (copy-sequence msgs) #'<) + do (cl-loop for seq-name in (gethash msg seq-map) + do (push i (gethash seq-name dest-map)))) (maphash #'(lambda (seq msgs) ;; Can't be run in the background, since the @@ -1639,10 +1637,10 @@ after the commands are processed." (mh-delete-scan-msgs mh-whitelist) (when mh-whitelist-preserves-sequences-flag (clrhash white-map) - (loop for i from (1+ (or last 0)) - for msg in (sort (copy-sequence mh-whitelist) #'<) - do (loop for seq-name in (gethash msg seq-map) - do (push i (gethash seq-name white-map)))) + (cl-loop for i from (1+ (or last 0)) + for msg in (sort (copy-sequence mh-whitelist) #'<) + do (cl-loop for seq-name in (gethash msg seq-map) + do (push i (gethash seq-name white-map)))) (maphash #'(lambda (seq msgs) ;; Can't be run in background, since the current @@ -1922,10 +1920,11 @@ exist." (from (or (message-fetch-field "from") "")) folder-name) (setq folder-name - (loop for list in mh-default-folder-list - when (string-match (nth 0 list) (if (nth 2 list) to/cc from)) - return (nth 1 list) - finally return nil)) + (cl-loop for list in mh-default-folder-list + when (string-match (nth 0 list) + (if (nth 2 list) to/cc from)) + return (nth 1 list) + finally return nil)) ;; Make sure a result from `mh-default-folder-list' begins with "+" ;; since 'mh-expand-file-name below depends on it @@ -2026,8 +2025,8 @@ If MSG is nil then act on the message at point" (t (dolist (folder-msg-list mh-refile-list) (setf (cdr folder-msg-list) (remove msg (cdr folder-msg-list)))) - (setq mh-refile-list (loop for x in mh-refile-list - unless (null (cdr x)) collect x)))) + (setq mh-refile-list (cl-loop for x in mh-refile-list + unless (null (cdr x)) collect x)))) (mh-notate nil ? mh-cmd-note))) ;;;###mh-autoload diff --git a/lisp/mh-e/mh-funcs.el b/lisp/mh-e/mh-funcs.el index 9f603c0c71..1b3883db52 100644 --- a/lisp/mh-e/mh-funcs.el +++ b/lisp/mh-e/mh-funcs.el @@ -123,7 +123,7 @@ folder. This is useful for folders that are easily regenerated." (message "Folder %s removed" folder)) (message "Folder not removed"))) -(defun mh-rmf-daemon (process output) +(defun mh-rmf-daemon (_process output) "The rmf PROCESS puts OUTPUT in temporary buffer. Display the results only if something went wrong." (set-buffer (get-buffer-create mh-temp-buffer)) diff --git a/lisp/mh-e/mh-gnus.el b/lisp/mh-e/mh-gnus.el index 61d531fe99..1ca90d92a7 100644 --- a/lisp/mh-e/mh-gnus.el +++ b/lisp/mh-e/mh-gnus.el @@ -79,7 +79,7 @@ ;; Function from mm-decode.el used in PGP messages. Just define it with older ;; Gnus to avoid compiler warning. (defun-mh mh-mm-possibly-verify-or-decrypt - mm-possibly-verify-or-decrypt (parts ctl) + mm-possibly-verify-or-decrypt (_parts _ctl) nil) ;; Copy of macro in mm-decode.el. @@ -110,16 +110,16 @@ (and (> (current-column) length) (current-column)))) -(defun-mh mh-mm-keep-viewer-alive-p mm-keep-viewer-alive-p (handle) +(defun-mh mh-mm-keep-viewer-alive-p mm-keep-viewer-alive-p (_handle) ;; Released Gnus doesn't keep handles associated with externally displayed ;; MIME parts. So this will always return nil. nil) -(defun-mh mh-mm-destroy-parts mm-destroy-parts (list) +(defun-mh mh-mm-destroy-parts mm-destroy-parts (_list) "Older versions of Emacs don't have this function." nil) -(defun-mh mh-mm-uu-dissect-text-parts mm-uu-dissect-text-parts (handles) +(defun-mh mh-mm-uu-dissect-text-parts mm-uu-dissect-text-parts (_handles) "Emacs 21 and XEmacs don't have this function." nil) diff --git a/lisp/mh-e/mh-identity.el b/lisp/mh-e/mh-identity.el index 1d929e8f99..0b69839575 100644 --- a/lisp/mh-e/mh-identity.el +++ b/lisp/mh-e/mh-identity.el @@ -205,7 +205,7 @@ See `mh-identity-list'." (setq mh-identity-local identity)))) ;;;###mh-autoload -(defun mh-identity-handler-gpg-identity (field action &optional value) +(defun mh-identity-handler-gpg-identity (_field action &optional value) "Process header FIELD \":pgg-default-user-id\". The ACTION is one of `remove' or `add'. If `add', the VALUE is added. The buffer-local variable `mh-identity-pgg-default-user-id' is set to @@ -219,7 +219,7 @@ VALUE when action `add' is selected." (setq mh-identity-pgg-default-user-id value)))) ;;;###mh-autoload -(defun mh-identity-handler-signature (field action &optional value) +(defun mh-identity-handler-signature (_field action &optional value) "Process header FIELD \":signature\". The ACTION is one of `remove' or `add'. If `add', the VALUE is added." @@ -250,7 +250,7 @@ added." "Marker for the end of the attribution verb.") ;;;###mh-autoload -(defun mh-identity-handler-attribution-verb (field action &optional value) +(defun mh-identity-handler-attribution-verb (_field action &optional value) "Process header FIELD \":attribution-verb\". The ACTION is one of `remove' or `add'. If `add', the VALUE is added." diff --git a/lisp/mh-e/mh-inc.el b/lisp/mh-e/mh-inc.el index 21034bc550..9d7b719e09 100644 --- a/lisp/mh-e/mh-inc.el +++ b/lisp/mh-e/mh-inc.el @@ -33,7 +33,6 @@ ;;; Code: (require 'mh-e) -(mh-require-cl) (defvar mh-inc-spool-map-help nil "Help text for `mh-inc-spool-map'.") @@ -51,13 +50,13 @@ "Make all commands and defines keys for contents of `mh-inc-spool-list'." (setq mh-inc-spool-map-help nil) (when mh-inc-spool-list - (loop for elem in mh-inc-spool-list - do (let ((spool (nth 0 elem)) - (folder (nth 1 elem)) - (key (nth 2 elem))) - (progn - (mh-inc-spool-generator folder spool) - (mh-inc-spool-def-key key folder)))))) + (cl-loop for elem in mh-inc-spool-list + do (let ((spool (nth 0 elem)) + (folder (nth 1 elem)) + (key (nth 2 elem))) + (progn + (mh-inc-spool-generator folder spool) + (mh-inc-spool-def-key key folder)))))) (defalias 'mh-inc-spool-make-no-autoload 'mh-inc-spool-make) diff --git a/lisp/mh-e/mh-junk.el b/lisp/mh-e/mh-junk.el index db80f90494..f3ae91907b 100644 --- a/lisp/mh-e/mh-junk.el +++ b/lisp/mh-e/mh-junk.el @@ -32,7 +32,6 @@ (require 'mh-e) (require 'mh-scan) -(mh-require-cl) ;;;###mh-autoload (defun mh-junk-blacklist (range) diff --git a/lisp/mh-e/mh-limit.el b/lisp/mh-e/mh-limit.el index ee6fa83abb..8d1e542762 100644 --- a/lisp/mh-e/mh-limit.el +++ b/lisp/mh-e/mh-limit.el @@ -30,7 +30,6 @@ ;;; Code: (require 'mh-e) -(mh-require-cl) (require 'mh-scan) (autoload 'message-fetch-field "message") @@ -126,8 +125,8 @@ Use \\\\[mh-widen] to undo this command." (mh-quote-pick-expr (mh-current-message-header-field 'subject))))) (setq pick-expr (let ((case-fold-search t)) - (loop for s in pick-expr - collect (mh-replace-regexp-in-string "re: *" "" s)))) + (cl-loop for s in pick-expr + collect (mh-replace-regexp-in-string "re: *" "" s)))) (mh-narrow-to-header-field 'subject pick-expr)) ;;;###mh-autoload @@ -249,7 +248,7 @@ Return number of messages put in the sequence: (defun mh-edit-pick-expr (default) "With prefix arg edit a pick expression. If no prefix arg is given, then return DEFAULT." - (let ((default-string (loop for x in default concat (format " %s" x)))) + (let ((default-string (cl-loop for x in default concat (format " %s" x)))) (if (or current-prefix-arg (equal default-string "")) (mh-pick-args-list (read-string "Pick expression: " default-string)) @@ -291,18 +290,18 @@ For example, the string \"-subject a b c -from Joe User (let* ((field (or (message-fetch-field (format "%s" header-field)) "")) (field-option (format "-%s" header-field)) - (patterns (loop for x in (split-string field "[ ]*,[ ]*") - unless (equal x "") - collect (if (string-match "<\\(.*@.*\\)>" x) - (match-string 1 x) - x)))) + (patterns (cl-loop for x in (split-string field "[ ]*,[ ]*") + unless (equal x "") + collect (if (string-match "<\\(.*@.*\\)>" x) + (match-string 1 x) + x)))) (when patterns - (loop with accum = `(,field-option ,(car patterns)) - for e in (cdr patterns) - do (setq accum `(,field-option ,e "-or" ,@accum)) - finally return accum)))))))) + (cl-loop with accum = `(,field-option ,(car patterns)) + for e in (cdr patterns) + do (setq accum `(,field-option ,e "-or" ,@accum)) + finally return accum)))))))) -(defun mh-narrow-to-header-field (header-field pick-expr) +(defun mh-narrow-to-header-field (_header-field pick-expr) "Limit to messages whose HEADER-FIELD match PICK-EXPR. The MH command pick is used to do the match." (let ((folder mh-current-folder) diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el index 6f126967fe..d74e79f1cb 100644 --- a/lisp/mh-e/mh-mime.el +++ b/lisp/mh-e/mh-mime.el @@ -77,7 +77,7 @@ '(gethash (current-buffer) mh-globals-hash)) ;; Structure to keep track of MIME handles on a per buffer basis. -(mh-defstruct (mh-buffer-data (:conc-name mh-mime-) +(cl-defstruct (mh-buffer-data (:conc-name mh-mime-) (:constructor mh-make-buffer-data)) (handles ()) ; List of MIME handles (handles-cache (make-hash-table)) ; Cache to avoid multiple decodes of @@ -611,7 +611,7 @@ If message has been encoded for transfer take that into account." "Choose among the alternatives, HANDLES the part that will be displayed. If no part is preferred then all the parts are displayed." (let* ((preferred (mm-preferred-alternative handles)) - (others (loop for x in handles unless (eq x preferred) collect x))) + (others (cl-loop for x in handles unless (eq x preferred) collect x))) (cond ((and preferred (stringp (car preferred))) (mh-mime-display-part preferred) @@ -770,7 +770,7 @@ buttons need to be displayed multiple times (for instance when nested messages are opened)." (or (gethash handle (mh-mime-part-index-hash (mh-buffer-data))) (setf (gethash handle (mh-mime-part-index-hash (mh-buffer-data))) - (incf (mh-mime-parts-count (mh-buffer-data)))))) + (cl-incf (mh-mime-parts-count (mh-buffer-data)))))) (defun mh-small-image-p (handle) "Decide whether HANDLE is a \"small\" image that can be displayed inline. @@ -839,9 +839,7 @@ being used to highlight the signature in a MIME part." ;; Shush compiler. (mh-do-in-xemacs - (defvar dots) - (defvar type) - (defvar ov)) + (defvar ov)) (defun mh-insert-mime-button (handle index displayed) "Insert MIME button for HANDLE. @@ -857,23 +855,27 @@ by commands like \"K v\" which operate on individual MIME parts." (mail-content-type-get (mm-handle-type handle) 'url) "")) (type (mm-handle-media-type handle)) - (description (mail-decode-encoded-word-string - (or (mm-handle-description handle) ""))) - (dots (if (or displayed (mm-handle-displayed-p handle)) " " "...")) - long-type begin end) + begin end) (if (string-match ".*/" name) (setq name (substring name (match-end 0)))) - (setq long-type (concat type (and (not (equal name "")) - (concat "; " name)))) - (unless (equal description "") - (setq long-type (concat " --- " long-type))) - (unless (bolp) (insert "\n")) - (setq begin (point)) - (gnus-eval-format - mh-mime-button-line-format mh-mime-button-line-format-alist - `(,@(mh-gnus-local-map-property mh-mime-button-map) + ;; These vars are passed by dynamic-scoping to + ;; mh-mime-button-line-format-alist via gnus-eval-format. + (mh-dlet* ((index index) + (description (mail-decode-encoded-word-string + (or (mm-handle-description handle) ""))) + (dots (if (or displayed (mm-handle-displayed-p handle)) + " " "...")) + (long-type (concat type (and (not (equal name "")) + (concat "; " name))))) + (unless (equal description "") + (setq long-type (concat " --- " long-type))) + (unless (bolp) (insert "\n")) + (setq begin (point)) + (gnus-eval-format + mh-mime-button-line-format mh-mime-button-line-format-alist + `(,@(mh-gnus-local-map-property mh-mime-button-map) mh-callback mh-mm-display-part mh-part ,index - mh-data ,handle)) + mh-data ,handle))) (setq end (point)) (widget-convert-button 'link begin end @@ -888,8 +890,6 @@ by commands like \"K v\" which operate on individual MIME parts." ;; Shush compiler. (defvar mm-verify-function-alist) ; < Emacs 22 (defvar mm-decrypt-function-alist) ; < Emacs 22 -(mh-do-in-xemacs - (defvar pressed-details)) (defun mh-insert-mime-security-button (handle) "Display buttons for PGP message, HANDLE." @@ -897,42 +897,47 @@ by commands like \"K v\" which operate on individual MIME parts." (crypto-type (or (nth 2 (assoc protocol mm-verify-function-alist)) (nth 2 (assoc protocol mm-decrypt-function-alist)) "Unknown")) - (type (concat crypto-type - (if (equal (car handle) "multipart/signed") - " Signed" " Encrypted") - " Part")) - (info (or (mh-mm-handle-multipart-ctl-parameter handle 'gnus-info) - "Undecided")) - (details (mh-mm-handle-multipart-ctl-parameter handle 'gnus-details)) - pressed-details begin end face) - (setq details (if details (concat "\n" details) "")) - (setq pressed-details (if mh-mime-security-button-pressed details "")) - (setq face (mh-mime-security-button-face info)) - (unless (bolp) (insert "\n")) - (setq begin (point)) - (gnus-eval-format - mh-mime-security-button-line-format - mh-mime-security-button-line-format-alist - `(,@(mh-gnus-local-map-property mh-mime-security-button-map) + begin end face) + ;; These vars are passed by dynamic-scoping to + ;; mh-mime-security-button-line-format-alist via gnus-eval-format. + (mh-dlet* ((type (concat crypto-type + (if (equal (car handle) "multipart/signed") + " Signed" " Encrypted") + " Part")) + (info (or (mh-mm-handle-multipart-ctl-parameter + handle 'gnus-info) + "Undecided")) + (details (mh-mm-handle-multipart-ctl-parameter + handle 'gnus-details)) + pressed-details) + (setq details (if details (concat "\n" details) "")) + (setq pressed-details (if mh-mime-security-button-pressed details "")) + (setq face (mh-mime-security-button-face info)) + (unless (bolp) (insert "\n")) + (setq begin (point)) + (gnus-eval-format + mh-mime-security-button-line-format + mh-mime-security-button-line-format-alist + `(,@(mh-gnus-local-map-property mh-mime-security-button-map) mh-button-pressed ,mh-mime-security-button-pressed mh-callback mh-mime-security-press-button mh-line-format ,mh-mime-security-button-line-format mh-data ,handle)) - (setq end (point)) - (widget-convert-button 'link begin end - :mime-handle handle - :action 'mh-widget-press-button - :button-keymap mh-mime-security-button-map - :button-face face - :help-echo "Mouse-2 click or press RET (in show buffer) to see security details.") - (dolist (ov (mh-funcall-if-exists overlays-in begin end)) - (mh-funcall-if-exists overlay-put ov 'evaporate t)) - (when (equal info "Failed") - (let* ((type (if (equal (car handle) "multipart/signed") - "verification" "decryption")) - (warning (if (equal type "decryption") - "(passphrase may be incorrect)" ""))) - (message "%s %s failed %s" crypto-type type warning))))) + (setq end (point)) + (widget-convert-button 'link begin end + :mime-handle handle + :action 'mh-widget-press-button + :button-keymap mh-mime-security-button-map + :button-face face + :help-echo "Mouse-2 click or press RET (in show buffer) to see security details.") + (dolist (ov (mh-funcall-if-exists overlays-in begin end)) + (mh-funcall-if-exists overlay-put ov 'evaporate t)) + (when (equal info "Failed") + (let* ((type (if (equal (car handle) "multipart/signed") + "verification" "decryption")) + (warning (if (equal type "decryption") + "(passphrase may be incorrect)" ""))) + (message "%s %s failed %s" crypto-type type warning)))))) (defun mh-mime-security-button-face (info) "Return the button face to use for encrypted/signed mail based on INFO." @@ -995,7 +1000,7 @@ If CRITERION is a function or a symbol which has a function binding then that function must return non-nil at the button we stop." (unless (or (and (symbolp criterion) (fboundp criterion)) (functionp criterion)) - (setq criterion (lambda (x) t))) + (setq criterion (lambda (_) t))) ;; Move to the next button in the buffer satisfying criterion (goto-char (or (save-excursion (beginning-of-line) @@ -1015,7 +1020,7 @@ then that function must return non-nil at the button we stop." (not (if backward-flag (bobp) (eobp)))) (forward-line (if backward-flag -1 1))) ;; Stop at next MIME button if any exists. - (block loop + (cl-block loop (while (/= (progn (unless (= (forward-line (if backward-flag -1 1)) @@ -1028,11 +1033,11 @@ then that function must return non-nil at the button we stop." point-before-current-button) (when (and (get-text-property (point) 'mh-data) (funcall criterion (point))) - (return-from loop (point)))) + (cl-return-from loop (point)))) nil))) (point)))) -(defun mh-widget-press-button (widget el) +(defun mh-widget-press-button (widget _el) "Callback for widget, WIDGET. Parameter EL is unused." (goto-char (widget-get widget :from)) @@ -1596,7 +1601,7 @@ the possible security methods (see `mh-mml-method-default')." nil t nil 'mh-mml-cryptographic-method-history def)) mh-mml-method-default)) -(defun mh-secure-message (method mode &optional identity) +(defun mh-secure-message (method mode &optional _identity) "Add tag to encrypt or sign message. METHOD should be one of: \"pgpmime\", \"pgp\", \"smime\". @@ -1697,19 +1702,19 @@ buffer, while END defaults to the end of the buffer." (unless begin (setq begin (point-min))) (unless end (setq end (point-max))) (save-excursion - (block search-for-mh-directive + (cl-block search-for-mh-directive (goto-char begin) (while (re-search-forward "^#" end t) (let ((s (buffer-substring-no-properties (point) (mh-line-end-position)))) (cond ((equal s "")) ((string-match "^forw[ \t\n]+" s) - (return-from search-for-mh-directive t)) + (cl-return-from search-for-mh-directive t)) (t (let ((first-token (car (split-string s "[ \t;@]")))) (when (and first-token (string-match mh-media-type-regexp first-token)) - (return-from search-for-mh-directive t))))))) + (cl-return-from search-for-mh-directive t))))))) nil))) (defun mh-minibuffer-read-type (filename &optional default) diff --git a/lisp/mh-e/mh-search.el b/lisp/mh-e/mh-search.el index ca74b2e936..596f00961b 100644 --- a/lisp/mh-e/mh-search.el +++ b/lisp/mh-e/mh-search.el @@ -44,7 +44,6 @@ ;;; Code: (require 'mh-e) -(mh-require-cl) (require 'gnus-util) (require 'imenu) @@ -227,17 +226,17 @@ folder containing the index search results." mh-search-regexp-builder) (current-window-configuration) nil))) - (block mh-search + (cl-block mh-search ;; Redoing a sequence search? (when (and redo-search-flag mh-index-data mh-index-sequence-search-flag (not mh-flists-called-flag)) (let ((mh-flists-called-flag t)) (apply #'mh-index-sequenced-messages mh-index-previous-search)) - (return-from mh-search)) + (cl-return-from mh-search)) ;; We have fancy query parsing. (when (symbolp search-regexp) (mh-search-folder folder window-config) - (return-from mh-search)) + (cl-return-from mh-search)) ;; Begin search proper. (mh-checksum-choose) (let ((result-count 0) @@ -264,21 +263,22 @@ folder containing the index search results." ;; Parse searcher output. (message "Processing %s output... " mh-searcher) (goto-char (point-min)) - (loop for next-result = (funcall mh-search-next-result-function) - while next-result - do (unless (eq next-result 'error) - (unless (gethash (car next-result) folder-results-map) - (setf (gethash (car next-result) folder-results-map) - (make-hash-table :test #'equal))) - (setf (gethash (cadr next-result) - (gethash (car next-result) folder-results-map)) - t))) + (cl-loop for next-result = (funcall mh-search-next-result-function) + while next-result + do (unless (eq next-result 'error) + (unless (gethash (car next-result) folder-results-map) + (setf (gethash (car next-result) folder-results-map) + (make-hash-table :test #'equal))) + (setf (gethash (cadr next-result) + (gethash (car next-result) folder-results-map)) + t))) ;; Copy the search results over. (maphash #'(lambda (folder msgs) (let ((cur (car (mh-translate-range folder "cur"))) - (msgs (sort (loop for msg being the hash-keys of msgs - collect msg) + (msgs (sort (cl-loop + for msg being the hash-keys of msgs + collect msg) #'<))) (mh-exec-cmd "refile" msgs "-src" folder "-link" index-folder) @@ -287,10 +287,10 @@ folder containing the index search results." (mh-exec-cmd-quiet nil "mark" folder "-add" "-zero" "-sequence" "cur" (format "%s" cur))) - (loop for msg in msgs - do (incf result-count) - (setf (gethash result-count origin-map) - (cons folder msg))))) + (cl-loop for msg in msgs + do (cl-incf result-count) + (setf (gethash result-count origin-map) + (cons folder msg))))) folder-results-map) ;; Vist the results folder. @@ -315,14 +315,14 @@ folder containing the index search results." (message "%s found %s matches in %s folders" (upcase-initials (symbol-name mh-searcher)) - (loop for msg-hash being the hash-values of mh-index-data - sum (hash-table-count msg-hash)) - (loop for msg-hash being the hash-values of mh-index-data - count (> (hash-table-count msg-hash) 0))))))) + (cl-loop for msg-hash being the hash-values of mh-index-data + sum (hash-table-count msg-hash)) + (cl-loop for msg-hash being the hash-values of mh-index-data + count (> (hash-table-count msg-hash) 0))))))) ;; Shush compiler. (mh-do-in-xemacs - (defvar pick-folder)) + (defvar pick-folder)) ;FIXME: Why? (defun mh-search-folder (folder window-config) "Search FOLDER for messages matching a pattern. @@ -331,6 +331,7 @@ In a program, argument WINDOW-CONFIG is the current window configuration and is used when the search folder is dismissed." (interactive (list (mh-prompt-for-folder "Search" mh-current-folder nil nil t) (current-window-configuration))) + ;; FIXME: `pick-folder' is unused! (let ((pick-folder (if (equal folder "+") mh-current-folder folder))) (switch-to-buffer-other-window "search-pattern") (if (or (zerop (buffer-size)) @@ -401,10 +402,8 @@ or nothing to search all folders." mh-ticked-messages-folders))) (mh-index-sequenced-messages folders mh-tick-seq)) -;; Shush compiler. -(mh-do-in-xemacs - (defvar mh-mairix-folder) - (defvar mh-flists-search-folders)) +(defvar mh-mairix-folder) +(defvar mh-flists-search-folders) ;;;###mh-autoload (defun mh-index-sequenced-messages (folders sequence) @@ -471,9 +470,9 @@ recursively. All arguments are IGNORED." (mh-quote-for-shell mh-inbox)) ((eq mh-flists-search-folders nil) "") ((listp mh-flists-search-folders) - (loop for folder in mh-flists-search-folders - concat - (concat " " (mh-quote-for-shell folder))))) + (cl-loop for folder in mh-flists-search-folders + concat + (concat " " (mh-quote-for-shell folder))))) (if mh-recursive-folders-flag " -recurse" "") " -sequence " seq " -noshowzero -fast` ; do\n" (expand-file-name "mhpath" mh-progs) " \"+$folder\" " seq "\n" @@ -536,8 +535,9 @@ group of results." (when (or (not (get-buffer folder)) (y-or-n-p (format "Reuse buffer displaying %s? " folder))) (mh-visit-folder - folder (loop for x being the hash-keys of (gethash folder mh-index-data) - when (mh-msg-exists-p x folder) collect x))))) + folder (cl-loop + for x being the hash-keys of (gethash folder mh-index-data) + when (mh-msg-exists-p x folder) collect x))))) @@ -716,7 +716,7 @@ parsed." ((equal token "or") (push 'or op-stack)) ((equal token "and") (push 'and op-stack)) ((equal token ")") - (multiple-value-setq (op-stack operand-stack) + (cl-multiple-value-setq (op-stack operand-stack) (cl-values-list (mh-index-evaluate op-stack operand-stack))) (when (eq (car op-stack) 'not) (setq op-stack (cdr op-stack)) @@ -762,12 +762,12 @@ parsed." (defun mh-index-evaluate (op-stack operand-stack) "Read expression till starting paren based on OP-STACK and OPERAND-STACK." - (block mh-index-evaluate + (cl-block mh-index-evaluate (let (op oper1) (while op-stack (setq op (pop op-stack)) (cond ((eq op 'paren) - (return-from mh-index-evaluate (list op-stack operand-stack))) + (cl-return-from mh-index-evaluate (list op-stack operand-stack))) ((eq op 'not) (push `(not ,(pop operand-stack)) operand-stack)) ((or (eq op 'and) (eq op 'or)) @@ -806,7 +806,7 @@ The side-effects of this function are that the variables searcher in `mh-search-choices' present on the system. If optional argument SEARCHER is present, use it instead of `mh-search-program'." - (block nil + (cl-block nil (let ((program-alist (cond (searcher (list (assoc searcher mh-search-choices))) (mh-search-program @@ -821,7 +821,7 @@ optional argument SEARCHER is present, use it instead of (setq mh-search-function (nth 2 current)) (setq mh-search-next-result-function (nth 3 current)) (setq mh-search-regexp-builder (nth 4 current)) - (return mh-searcher)))) + (cl-return mh-searcher)))) nil))) ;;; Swish++ @@ -974,31 +974,31 @@ is used to search." (defun mh-swish-next-result () "Get the next result from swish output." (prog1 - (block nil + (cl-block nil (when (or (eobp) (equal (char-after (point)) ?.)) - (return nil)) + (cl-return nil)) (when (equal (char-after (point)) ?#) - (return 'error)) + (cl-return 'error)) (let* ((start (search-forward " " (mh-line-end-position) t)) (end (search-forward " " (mh-line-end-position) t))) (unless (and start end) - (return 'error)) + (cl-return 'error)) (setq end (1- end)) (unless (file-exists-p (buffer-substring-no-properties start end)) - (return 'error)) + (cl-return 'error)) (unless (search-backward "/" start t) - (return 'error)) + (cl-return 'error)) (list (let* ((s (buffer-substring-no-properties start (1+ (point))))) (unless (string-match mh-swish-folder s) - (return 'error)) + (cl-return 'error)) (if (and (string-match mh-user-path s) (< (match-end 0) (1- (length s)))) (format "+%s" (substring s (match-end 0) (1- (length s)))) - (return 'error))) + (cl-return 'error))) (let* ((s (buffer-substring-no-properties (1+ (point)) end)) (n (ignore-errors (string-to-number s)))) - (if n n (return 'error))) + (or n (cl-return 'error))) nil))) (forward-line))) @@ -1051,26 +1051,26 @@ SEARCH-REGEXP-LIST is used to search." (defun mh-mairix-next-result () "Return next result from mairix output." (prog1 - (block nil + (cl-block nil (when (or (eobp) (and (bolp) (eolp))) - (return nil)) + (cl-return nil)) (unless (eq (char-after) ?/) - (return 'error)) + (cl-return 'error)) (let ((start (point)) end msg-start) (setq end (mh-line-end-position)) (unless (search-forward mh-mairix-folder end t) - (return 'error)) + (cl-return 'error)) (goto-char (match-beginning 0)) (unless (equal (point) start) - (return 'error)) + (cl-return 'error)) (goto-char end) (unless (search-backward "/" start t) - (return 'error)) + (cl-return 'error)) (setq msg-start (1+ (point))) (goto-char start) (unless (search-forward mh-user-path end t) - (return 'error)) + (cl-return 'error)) (list (format "+%s" (buffer-substring-no-properties (point) (1- msg-start))) (string-to-number @@ -1119,8 +1119,8 @@ REGEXP-LIST is an alist of fields and values." (cond ((atom expr) `(or (and ,expr))) ((eq (car expr) 'or) (cons 'or - (loop for e in (mapcar #'mh-mairix-convert-to-sop* (cdr expr)) - append (cdr e)))) + (cl-loop for e in (mapcar #'mh-mairix-convert-to-sop* (cdr expr)) + append (cdr e)))) ((eq (car expr) 'and) (let ((conjuncts (mapcar #'mh-mairix-convert-to-sop* (cdr expr))) result next-factor) @@ -1196,22 +1196,22 @@ is used to search." (defun mh-namazu-next-result () "Get the next result from namazu output." (prog1 - (block nil - (when (eobp) (return nil)) + (cl-block nil + (when (eobp) (cl-return nil)) (let ((file-name (buffer-substring-no-properties (point) (mh-line-end-position)))) (unless (equal (string-match mh-namazu-folder file-name) 0) - (return 'error)) + (cl-return 'error)) (unless (file-exists-p file-name) - (return 'error)) + (cl-return 'error)) (string-match mh-user-path file-name) (let* ((folder/msg (substring file-name (match-end 0))) (mark (mh-search-from-end ?/ folder/msg))) - (unless mark (return 'error)) + (unless mark (cl-return 'error)) (list (format "+%s" (substring folder/msg 0 mark)) (let ((n (ignore-errors (string-to-number (substring folder/msg (1+ mark)))))) - (if n n (return 'error))) + (or n (cl-return 'error))) nil)))) (forward-line))) @@ -1235,25 +1235,25 @@ is used to search." (erase-buffer) (let ((folders (mh-folder-list (substring folder-path (length mh-user-path))))) - (loop for folder in folders do - (setq folder (concat "+" folder)) - (insert folder "\n") - (apply #'call-process (expand-file-name "pick" mh-progs) - nil '(t nil) nil folder "-list" search-regexp))) + (cl-loop for folder in folders do + (setq folder (concat "+" folder)) + (insert folder "\n") + (apply #'call-process (expand-file-name "pick" mh-progs) + nil '(t nil) nil folder "-list" search-regexp))) (goto-char (point-min))) (defun mh-pick-next-result () "Return the next pick search result." (prog1 - (block nil - (when (eobp) (return nil)) + (cl-block nil + (when (eobp) (cl-return nil)) (when (search-forward-regexp "^\\+" (mh-line-end-position) t) (setq mh-index-pick-folder (buffer-substring-no-properties (mh-line-beginning-position) (mh-line-end-position))) - (return 'error)) + (cl-return 'error)) (unless (search-forward-regexp "^[1-9][0-9]*$" (mh-line-end-position) t) - (return 'error)) + (cl-return 'error)) (list mh-index-pick-folder (string-to-number (buffer-substring-no-properties (mh-line-beginning-position) @@ -1331,29 +1331,29 @@ Parse it and return the message folder, message index and the match. If no other matches left then return nil. If the current record is invalid return 'error." (prog1 - (block nil + (cl-block nil (when (eobp) - (return nil)) + (cl-return nil)) (let ((eol-pos (mh-line-end-position)) (bol-pos (mh-line-beginning-position)) folder-start msg-end) (goto-char bol-pos) (unless (search-forward mh-user-path eol-pos t) - (return 'error)) + (cl-return 'error)) (setq folder-start (point)) (unless (search-forward ":" eol-pos t) - (return 'error)) + (cl-return 'error)) (let ((match (buffer-substring-no-properties (point) eol-pos))) (forward-char -1) (setq msg-end (point)) (unless (search-backward "/" folder-start t) - (return 'error)) + (cl-return 'error)) (list (format "+%s" (buffer-substring-no-properties folder-start (point))) (let ((n (ignore-errors (string-to-number (buffer-substring-no-properties (1+ (point)) msg-end))))) - (if n n (return 'error))) + (or n (cl-return 'error))) match)))) (forward-line))) @@ -1369,13 +1369,14 @@ being the list of messages originally from that folder." (save-excursion (goto-char (point-min)) (let ((result-table (make-hash-table :test #'equal))) - (loop for msg being the hash-keys of mh-index-msg-checksum-map - do (push msg (gethash (car (gethash - (gethash msg mh-index-msg-checksum-map) - mh-index-checksum-origin-map)) - result-table))) - (loop for x being the hash-keys of result-table - collect (cons x (nreverse (gethash x result-table))))))) + (cl-loop for msg being the hash-keys of mh-index-msg-checksum-map + do (push msg (gethash (car (gethash + (gethash msg + mh-index-msg-checksum-map) + mh-index-checksum-origin-map)) + result-table))) + (cl-loop for x being the hash-keys of result-table + collect (cons x (nreverse (gethash x result-table))))))) ;;;###mh-autoload (defun mh-index-insert-folder-headers () @@ -1443,9 +1444,7 @@ being the list of messages originally from that folder." "Non-nil means that this folder was generated by searching." mh-index-data) -;; Shush compiler -(mh-do-in-xemacs - (defvar mh-speed-flists-inhibit-flag)) +(defvar mh-speed-flists-inhibit-flag) ;;;###mh-autoload (defun mh-index-execute-commands () @@ -1478,23 +1477,24 @@ buffer." (setq mh-refile-list (mapcar (lambda (x) (cons (car x) - (loop for y in (cdr x) - unless (memq y msgs) collect y))) + (cl-loop for y in (cdr x) + unless (memq y msgs) + collect y))) old-refile-list) mh-delete-list - (loop for x in old-delete-list - unless (memq x msgs) collect x) + (cl-loop for x in old-delete-list + unless (memq x msgs) collect x) mh-blacklist - (loop for x in old-blacklist - unless (memq x msgs) collect x) + (cl-loop for x in old-blacklist + unless (memq x msgs) collect x) mh-whitelist - (loop for x in old-whitelist - unless (memq x msgs) collect x)) + (cl-loop for x in old-whitelist + unless (memq x msgs) collect x)) (mh-set-folder-modified-p (mh-outstanding-commands-p)) (when (mh-outstanding-commands-p) (mh-notate-deleted-and-refiled))))))) - (mh-index-matching-source-msgs (append (loop for x in mh-refile-list - append (cdr x)) + (mh-index-matching-source-msgs (append (cl-loop for x in mh-refile-list + append (cdr x)) mh-delete-list mh-blacklist mh-whitelist) @@ -1565,12 +1565,12 @@ If the folder returned doesn't exist then it is created." (unless (mh-folder-name-p name) (error "The argument should be a valid MH folder name")) (let ((chosen-name - (loop for i from 1 - for candidate = (if (equal i 1) name (format "%s-%s" name i)) - when (or (not (mh-folder-exists-p candidate)) - (equal (mh-index-folder-search-regexp candidate) - search-regexp)) - return candidate))) + (cl-loop for i from 1 + for candidate = (if (equal i 1) name (format "%s-%s" name i)) + when (or (not (mh-folder-exists-p candidate)) + (equal (mh-index-folder-search-regexp candidate) + search-regexp)) + return candidate))) ;; Do pending refiles/deletes... (when (get-buffer chosen-name) (mh-process-or-undo-commands chosen-name)) @@ -1603,37 +1603,37 @@ garbled." "Mirror sequences present in source folders in index folder." (let ((seq-hash (make-hash-table :test #'equal)) (seq-list ())) - (loop for folder being the hash-keys of mh-index-data - do (setf (gethash folder seq-hash) - (mh-create-sequence-map - (mh-read-folder-sequences folder nil)))) + (cl-loop for folder being the hash-keys of mh-index-data + do (setf (gethash folder seq-hash) + (mh-create-sequence-map + (mh-read-folder-sequences folder nil)))) (dolist (msg (mh-translate-range mh-current-folder "all")) (let* ((checksum (gethash msg mh-index-msg-checksum-map)) (pair (gethash checksum mh-index-checksum-origin-map)) (ofolder (car pair)) (omsg (cdr pair))) - (loop for seq in (ignore-errors - (gethash omsg (gethash ofolder seq-hash))) - do (if (assoc seq seq-list) - (push msg (cdr (assoc seq seq-list))) - (push (list seq msg) seq-list))))) - (loop for seq in seq-list - do (apply #'mh-exec-cmd "mark" mh-current-folder - "-sequence" (symbol-name (car seq)) "-add" - (mapcar #'(lambda (x) (format "%s" x)) (cdr seq)))))) + (cl-loop for seq in (ignore-errors + (gethash omsg (gethash ofolder seq-hash))) + do (if (assoc seq seq-list) + (push msg (cdr (assoc seq seq-list))) + (push (list seq msg) seq-list))))) + (cl-loop for seq in seq-list + do (apply #'mh-exec-cmd "mark" mh-current-folder + "-sequence" (symbol-name (car seq)) "-add" + (mapcar #'(lambda (x) (format "%s" x)) (cdr seq)))))) ;;;###mh-autoload (defun mh-create-sequence-map (seq-list) "Return a map from msg number to list of sequences in which it is present. SEQ-LIST is an assoc list whose keys are sequence names and whose cdr is the list of messages in that sequence." - (loop with map = (make-hash-table) - for seq in seq-list - when (and (not (memq (car seq) (mh-unpropagated-sequences))) - (mh-valid-seq-p (car seq))) - do (loop for msg in (cdr seq) - do (push (car seq) (gethash msg map))) - finally return map)) + (cl-loop with map = (make-hash-table) + for seq in seq-list + when (and (not (memq (car seq) (mh-unpropagated-sequences))) + (mh-valid-seq-p (car seq))) + do (cl-loop for msg in (cdr seq) + do (push (car seq) (gethash msg map))) + finally return map)) ;;;###mh-autoload (defun mh-index-add-to-sequence (seq msgs) @@ -1741,7 +1741,7 @@ folder, is removed from `mh-index-data'." (print-level nil)) (with-temp-file outfile (mh-index-write-hashtable - data (lambda (x) (loop for y being the hash-keys of x collect y))) + data (lambda (x) (cl-loop for y being the hash-keys of x collect y))) (mh-index-write-hashtable msg-checksum-map #'identity) (mh-index-write-hashtable checksum-origin-map #'identity) (pp previous-search (current-buffer)) (insert "\n") @@ -1751,8 +1751,8 @@ folder, is removed from `mh-index-data'." "Write TABLE to `current-buffer'. PROC is used to serialize the values corresponding to the hash table keys." - (pp (loop for x being the hash-keys of table - collect (cons x (funcall proc (gethash x table)))) + (pp (cl-loop for x being the hash-keys of table + collect (cons x (funcall proc (gethash x table)))) (current-buffer)) (insert "\n")) @@ -1769,9 +1769,9 @@ table keys." (goto-char (point-min)) (setq t1 (mh-index-read-hashtable (lambda (data) - (loop with table = (make-hash-table :test #'equal) - for x in data do (setf (gethash x table) t) - finally return table))) + (cl-loop with table = (make-hash-table :test #'equal) + for x in data do (setf (gethash x table) t) + finally return table))) t2 (mh-index-read-hashtable #'identity) t3 (mh-index-read-hashtable #'identity) t4 (read (current-buffer)) @@ -1785,10 +1785,10 @@ table keys." (defun mh-index-read-hashtable (proc) "From BUFFER read a hash table serialized as a list. PROC is used to convert the value to actual data." - (loop with table = (make-hash-table :test #'equal) - for pair in (read (current-buffer)) - do (setf (gethash (car pair) table) (funcall proc (cdr pair))) - finally return table)) + (cl-loop with table = (make-hash-table :test #'equal) + for pair in (read (current-buffer)) + do (setf (gethash (car pair) table) (funcall proc (cdr pair))) + finally return table)) diff --git a/lisp/mh-e/mh-seq.el b/lisp/mh-e/mh-seq.el index 9989dc9f1c..818a6ceb31 100644 --- a/lisp/mh-e/mh-seq.el +++ b/lisp/mh-e/mh-seq.el @@ -31,7 +31,6 @@ ;;; Code: (require 'mh-e) -(mh-require-cl) (require 'mh-scan) (require 'font-lock) @@ -183,9 +182,9 @@ MESSAGE appears." (interactive "P") (if (not message) (setq message (mh-get-msg-num t))) - (let* ((dest-folder (loop for seq in mh-refile-list - when (member message (cdr seq)) return (car seq) - finally return nil)) + (let* ((dest-folder (cl-loop for seq in mh-refile-list + when (member message (cdr seq)) return (car seq) + finally return nil)) (deleted-flag (unless dest-folder (member message mh-delete-list)))) (message "Message %d%s is in sequences: %s" message @@ -721,9 +720,9 @@ completion is over." ((eq flag t) (all-completions last-word candidates predicate)) ((eq flag 'lambda) - (loop for x in candidates - when (equal x last-word) return t - finally return nil))))) + (cl-loop for x in candidates + when (equal x last-word) return t + finally return nil))))) (defun mh-seq-names (seq-list) "Return an alist containing the names of the SEQ-LIST." @@ -742,8 +741,8 @@ completion is over." (call-process (expand-file-name "flist" mh-progs) nil t nil "-showzero" "-norecurse" folder "-sequence" (symbol-name mh-unseen-seq)) (goto-char (point-min)) - (multiple-value-bind (folder unseen total) - (values-list + (cl-multiple-value-bind (folder unseen total) + (cl-values-list (mh-parse-flist-output-line (buffer-substring (point) (mh-line-end-position)))) (list total unseen folder)))) @@ -934,8 +933,8 @@ notated." (dolist (msg (mh-seq-msgs seq)) (push (car seq) (gethash msg msg-hash)))) (mh-iterate-on-range msg range - (loop for seq in (gethash msg msg-hash) - do (mh-add-sequence-notation msg (mh-internal-seq seq)))))) + (cl-loop for seq in (gethash msg msg-hash) + do (mh-add-sequence-notation msg (mh-internal-seq seq)))))) (defun mh-add-sequence-notation (msg internal-seq-flag) "Add sequence notation to the MSG on the current line. diff --git a/lisp/mh-e/mh-show.el b/lisp/mh-e/mh-show.el index 4f7068156e..176113934d 100644 --- a/lisp/mh-e/mh-show.el +++ b/lisp/mh-e/mh-show.el @@ -900,7 +900,7 @@ See also `mh-folder-mode'. ;; Don't allow Gnus to create buttons while highlighting, maybe this is bad ;; style? (mh-flet - ((gnus-article-add-button (&rest args) nil)) + ((gnus-article-add-button (&rest _args) nil)) (let* ((modified (buffer-modified-p)) (gnus-article-buffer (buffer-name)) (gnus-cite-face-list `(,@(cdr gnus-cite-face-list) diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el index fc661c882e..c615ba6913 100644 --- a/lisp/mh-e/mh-speed.el +++ b/lisp/mh-e/mh-speed.el @@ -31,7 +31,6 @@ ;;; Code: (require 'mh-e) -(mh-require-cl) (require 'gnus-util) (require 'speedbar) @@ -184,7 +183,7 @@ The optional arguments from speedbar are IGNORED." ;;; Support Routines ;;;###mh-autoload -(defun mh-folder-speedbar-buttons (buffer) +(defun mh-folder-speedbar-buttons (_buffer) "Interface function to create MH-E speedbar buffer. BUFFER is the MH-E buffer for which the speedbar buffer is to be created." @@ -438,7 +437,7 @@ flists is run only for that one folder." ;; Copied from mh-make-folder-list-filter... ;; XXX Refactor to use mh-make-folder-list-filer? -(defun mh-speed-parse-flists-output (process output) +(defun mh-speed-parse-flists-output (_process output) "Parse the incremental results from flists. PROCESS is the flists process and OUTPUT is the results that must be handled next." @@ -451,7 +450,7 @@ be handled next." mh-speed-partial-line (substring output position line-end)) mh-speed-partial-line "") - (multiple-value-setq (folder unseen total) + (cl-multiple-value-setq (folder unseen total) (cl-values-list (mh-parse-flist-output-line line mh-speed-current-folder))) (when (and folder unseen total @@ -555,12 +554,12 @@ The function invalidates the latest ancestor that is present." (last-slash (mh-search-from-end ?/ folder)) (ancestor folder) (ancestor-pos nil)) - (block while-loop + (cl-block while-loop (while last-slash (setq ancestor (substring ancestor 0 last-slash)) (setq ancestor-pos (gethash ancestor mh-speed-folder-map)) (when ancestor-pos - (return-from while-loop)) + (cl-return-from while-loop)) (setq last-slash (mh-search-from-end ?/ ancestor)))) (unless ancestor-pos (setq ancestor nil)) (goto-char (or ancestor-pos (gethash nil mh-speed-folder-map))) diff --git a/lisp/mh-e/mh-thread.el b/lisp/mh-e/mh-thread.el index 0fc560b90d..0f6f9f80ba 100644 --- a/lisp/mh-e/mh-thread.el +++ b/lisp/mh-e/mh-thread.el @@ -76,14 +76,14 @@ (require 'mh-e) (require 'mh-scan) -(mh-defstruct (mh-thread-message (:conc-name mh-message-) +(cl-defstruct (mh-thread-message (:conc-name mh-message-) (:constructor mh-thread-make-message)) (id nil) (references ()) (subject "") (subject-re-p nil)) -(mh-defstruct (mh-thread-container (:conc-name mh-container-) +(cl-defstruct (mh-thread-container (:conc-name mh-container-) (:constructor mh-thread-make-container)) message parent children (real-child-p t)) @@ -258,7 +258,7 @@ sibling." (beginning-of-line) (forward-char address-start-offset) (while (char-equal (char-after) ? ) - (incf level) + (cl-incf level) (forward-char)) level))) @@ -292,7 +292,7 @@ at the end." (setq begin (point)) (setq spaces (format (format "%%%ss" (1+ level)) "")) (forward-line) - (block nil + (cl-block nil (while (not (eobp)) (forward-char address-start-offset) (unless (equal (string-match spaces (buffer-substring-no-properties @@ -300,7 +300,7 @@ at the end." 0) (beginning-of-line) (backward-char) - (return)) + (cl-return)) (forward-line))) (list begin (point))))) @@ -388,8 +388,8 @@ the id-table is updated." (parent-container (mh-container-parent child-container))) (when parent-container (setf (mh-container-children parent-container) - (loop for elem in (mh-container-children parent-container) - unless (eq child-container elem) collect elem)) + (cl-loop for elem in (mh-container-children parent-container) + unless (eq child-container elem) collect elem)) (setf (mh-container-parent child-container) nil)))) (defsubst mh-thread-add-link (parent child &optional at-end-p) @@ -442,9 +442,9 @@ added to the end of the children list of PARENT." "Return t if ANCESTOR is really an ancestor of SUCCESSOR and nil otherwise. In the limit, the function returns t if ANCESTOR and SUCCESSOR are the same containers." - (block nil + (cl-block nil (while successor - (when (eq ancestor successor) (return t)) + (when (eq ancestor successor) (cl-return t)) (setq successor (mh-container-parent successor))) nil)) @@ -525,12 +525,12 @@ children." (cond ((and (mh-container-message container) (mh-message-id (mh-container-message container))) (mh-message-subject (mh-container-message container))) - (t (block nil + (t (cl-block nil (dolist (kid (mh-container-children container)) (when (and (mh-container-message kid) (mh-message-id (mh-container-message kid))) (let ((kid-message (mh-container-message kid))) - (return (mh-message-subject kid-message))))) + (cl-return (mh-message-subject kid-message))))) (error "This can't happen"))))) (defsubst mh-thread-update-id-index-maps (id index) @@ -595,9 +595,9 @@ Only information about messages in MSG-LIST are added to the tree." (goto-char (point-min)) (let ((roots ()) (case-fold-search t)) - (block nil + (cl-block nil (while (not (eobp)) - (block process-message + (cl-block process-message (let* ((index-line (prog1 (buffer-substring (point) (mh-line-end-position)) (forward-line))) @@ -616,26 +616,26 @@ Only information about messages in MSG-LIST are added to the tree." (forward-line))) (subject-re-p nil)) (unless (gethash index mh-thread-scan-line-map) - (return-from process-message)) - (unless (integerp index) (return)) ;Error message here - (multiple-value-setq (subject subject-re-p) - (values-list (mh-thread-prune-subject subject))) + (cl-return-from process-message)) + (unless (integerp index) (cl-return)) ;Error message here + (cl-multiple-value-setq (subject subject-re-p) + (cl-values-list (mh-thread-prune-subject subject))) (setq in-reply-to (mh-thread-process-in-reply-to in-reply-to)) - (setq refs (loop for x in (append (split-string refs) in-reply-to) - when (string-match mh-message-id-regexp x) - collect x)) + (setq refs + (cl-loop for x in (append (split-string refs) in-reply-to) + when (string-match mh-message-id-regexp x) + collect x)) (setq id (mh-thread-canonicalize-id id)) (mh-thread-update-id-index-maps id index) (setq refs (mapcar #'mh-thread-canonicalize-id refs)) (mh-thread-get-message id subject-re-p subject refs) - (do ((ancestors refs (cdr ancestors))) + (cl-do ((ancestors refs (cdr ancestors))) ((null (cdr ancestors)) (when (car ancestors) (mh-thread-remove-parent-link id) (mh-thread-add-link (car ancestors) id))) (mh-thread-add-link (car ancestors) (cadr ancestors))))))) - (maphash #'(lambda (k v) - (declare (ignore k)) + (maphash #'(lambda (_k v) (when (null (mh-container-parent v)) (push v roots))) mh-thread-id-table) @@ -720,8 +720,7 @@ For now it will take the last string inside angles." mh-thread-history) (mh-thread-remove-parent-link node))))) (let ((results ())) - (maphash #'(lambda (k v) - (declare (ignore k)) + (maphash #'(lambda (_k v) (when (and (null (mh-container-parent v)) (gethash (mh-message-id (mh-container-message v)) mh-thread-id-index-map)) @@ -751,17 +750,18 @@ For now it will take the last string inside angles." (mh-thread-last-ancestor nil)) (if (null mh-index-data) (mh-thread-generate-scan-lines thread-tree -2) - (loop for x in (mh-index-group-by-folder) - do (let* ((old-map mh-thread-scan-line-map) - (mh-thread-scan-line-map (make-hash-table))) - (setq mh-thread-last-ancestor nil) - (loop for msg in (cdr x) - do (let ((v (gethash msg old-map))) - (when v - (setf (gethash msg mh-thread-scan-line-map) v)))) - (when (> (hash-table-count mh-thread-scan-line-map) 0) - (insert (if (bobp) "" "\n") (car x) "\n") - (mh-thread-generate-scan-lines thread-tree -2)))) + (cl-loop for x in (mh-index-group-by-folder) + do (let* ((old-map mh-thread-scan-line-map) + (mh-thread-scan-line-map (make-hash-table))) + (setq mh-thread-last-ancestor nil) + (cl-loop for msg in (cdr x) + do (let ((v (gethash msg old-map))) + (when v + (setf (gethash msg mh-thread-scan-line-map) + v)))) + (when (> (hash-table-count mh-thread-scan-line-map) 0) + (insert (if (bobp) "" "\n") (car x) "\n") + (mh-thread-generate-scan-lines thread-tree -2)))) (mh-index-create-imenu-index)))) (defun mh-thread-generate-scan-lines (tree level) @@ -826,8 +826,8 @@ MSG is the message being notated with NOTATION at OFFSET." (let* ((msg (or msg (mh-get-msg-num nil))) (cur-scan-line (and mh-thread-scan-line-map (gethash msg mh-thread-scan-line-map))) - (old-scan-lines (loop for map in mh-thread-scan-line-map-stack - collect (and map (gethash msg map))))) + (old-scan-lines (cl-loop for map in mh-thread-scan-line-map-stack + collect (and map (gethash msg map))))) (when cur-scan-line (setf (aref (car cur-scan-line) offset) notation)) (dolist (line old-scan-lines) diff --git a/lisp/mh-e/mh-tool-bar.el b/lisp/mh-e/mh-tool-bar.el index 41610b253d..de7a519852 100644 --- a/lisp/mh-e/mh-tool-bar.el +++ b/lisp/mh-e/mh-tool-bar.el @@ -36,7 +36,7 @@ ;;; Tool Bar Commands -(defun mh-tool-bar-search (&optional arg) +(defun mh-tool-bar-search (&optional _arg) "Interactively call `mh-tool-bar-search-function'. Optional argument ARG is not used." (interactive "P") @@ -131,11 +131,12 @@ where, active. If it isn't present then the button is always active." ;; The following variable names have been carefully chosen to make code ;; generation easier. Modifying the names should be done carefully. - (let (folder-buttons folder-docs folder-button-setter sequence-button-setter - show-buttons show-button-setter show-seq-button-setter - letter-buttons letter-docs letter-button-setter - folder-defaults letter-defaults - folder-vectors show-vectors letter-vectors) + (mh-dlet* (folder-buttons + folder-docs folder-button-setter sequence-button-setter + show-buttons show-button-setter show-seq-button-setter + letter-buttons letter-docs letter-button-setter + folder-defaults letter-defaults + folder-vectors show-vectors letter-vectors) (dolist (x defaults) (cond ((eq (car x) :folder) (setq folder-defaults (cdr x))) ((eq (car x) :letter) (setq letter-defaults (cdr x))))) @@ -161,14 +162,14 @@ where, (append `(,(if (memq 'folder modes) :folder :sequence) ,name) functions)) (setq show-sym - (if (string-match "^mh-\\(.*\\)$" name-str) + (if (string-match "\\`mh-\\(.*\\)\\'" name-str) (intern (concat "mh-show-" (match-string 1 name-str))) name)) (setq functions (append `(,(if (memq 'folder modes) :show :show-seq) ,(if (fboundp show-sym) show-sym name)) functions))) - (do ((functions functions (cddr functions))) + (cl-do ((functions functions (cddr functions))) ((null functions)) (let* ((type (car functions)) (function (cadr functions)) @@ -209,15 +210,15 @@ where, (dolist (x letter-defaults) (unless (memq x letter-buttons) (error "Letter defaults contains unknown button %s" x))) - `(eval-when (compile load eval) + `(eval-and-compile ;; GNU Emacs tool bar specific code (mh-do-in-gnu-emacs (defun mh-buffer-exists-p (mode) "Test whether a buffer with major mode MODE is present." - (loop for buf in (buffer-list) - when (with-current-buffer buf - (eq major-mode mode)) - return t)) + (cl-loop for buf in (buffer-list) + when (with-current-buffer buf + (eq major-mode mode)) + return t)) ;; Tool bar initialization functions (defun mh-tool-bar-folder-buttons-init () (when (mh-buffer-exists-p 'mh-folder-mode) @@ -257,18 +258,18 @@ where, (defun mh-tool-bar-update (mode default-map sequence-map) "Update `tool-bar-map' in all buffers of MODE. Use SEQUENCE-MAP if display is limited; DEFAULT-MAP otherwise." - (loop for buf in (buffer-list) - do (with-current-buffer buf - (if (eq mode major-mode) - (let ((map (if mh-folder-view-stack - sequence-map - default-map))) - ;; Yes, make-local-variable is necessary since we - ;; get here during initialization when loading - ;; mh-e.el, after the +inbox buffer has been - ;; created, but before mh-folder-mode has run and - ;; created the local map. - (set (make-local-variable 'tool-bar-map) map)))))) + (cl-loop for buf in (buffer-list) + do (with-current-buffer buf + (when (eq mode major-mode) ;FIXME: derived-mode-p? + (let ((map (if mh-folder-view-stack + sequence-map + default-map))) + ;; Yes, make-local-variable is necessary since we + ;; get here during initialization when loading + ;; mh-e.el, after the +inbox buffer has been + ;; created, but before mh-folder-mode has run and + ;; created the local map. + (set (make-local-variable 'tool-bar-map) map)))))) (defun mh-tool-bar-folder-buttons-set (symbol value) "Construct tool bar for `mh-folder-mode' and `mh-show-mode'." (set-default symbol value) @@ -286,17 +287,17 @@ Use SEQUENCE-MAP if display is limited; DEFAULT-MAP otherwise." ;; XEmacs specific code (mh-do-in-xemacs (defvar mh-tool-bar-folder-vector-map - (list ,@(loop for button in folder-buttons - for vector in folder-vectors - collect `(cons ',button ,vector)))) + (list ,@(cl-loop for button in folder-buttons + for vector in folder-vectors + collect `(cons ',button ,vector)))) (defvar mh-tool-bar-show-vector-map - (list ,@(loop for button in show-buttons - for vector in show-vectors - collect `(cons ',button ,vector)))) + (list ,@(cl-loop for button in show-buttons + for vector in show-vectors + collect `(cons ',button ,vector)))) (defvar mh-tool-bar-letter-vector-map - (list ,@(loop for button in letter-buttons - for vector in letter-vectors - collect `(cons ',button ,vector)))) + (list ,@(cl-loop for button in letter-buttons + for vector in letter-vectors + collect `(cons ',button ,vector)))) (defvar mh-tool-bar-folder-buttons) (defvar mh-tool-bar-show-buttons) (defvar mh-tool-bar-letter-buttons) @@ -305,18 +306,20 @@ Use SEQUENCE-MAP if display is limited; DEFAULT-MAP otherwise." (set-default symbol value) (when mh-xemacs-has-tool-bar-flag (setq mh-tool-bar-letter-buttons - (loop for b in value - collect (cdr - (assoc b mh-tool-bar-letter-vector-map)))))) + (cl-loop + for b in value + collect (cdr (assoc b mh-tool-bar-letter-vector-map)))))) (defun mh-tool-bar-folder-buttons-set (symbol value) (set-default symbol value) (when mh-xemacs-has-tool-bar-flag (setq mh-tool-bar-folder-buttons - (loop for b in value - collect (cdr (assoc b mh-tool-bar-folder-vector-map)))) + (cl-loop + for b in value + collect (cdr (assoc b mh-tool-bar-folder-vector-map)))) (setq mh-tool-bar-show-buttons - (loop for b in value - collect (cdr (assoc b mh-tool-bar-show-vector-map)))))) + (cl-loop + for b in value + collect (cdr (assoc b mh-tool-bar-show-vector-map)))))) (defun mh-tool-bar-init (mode) "Install tool bar in MODE." (when mh-xemacs-use-tool-bar-flag @@ -354,9 +357,9 @@ Use SEQUENCE-MAP if display is limited; DEFAULT-MAP otherwise." "List of buttons to include in MH-Folder tool bar." :group 'mh-tool-bar :set 'mh-tool-bar-folder-buttons-set - :type '(set ,@(loop for x in folder-buttons - for y in folder-docs - collect `(const :tag ,y ,x))) + :type '(set ,@(cl-loop for x in folder-buttons + for y in folder-docs + collect `(const :tag ,y ,x))) ;;:package-version '(MH-E "7.1") ) (custom-declare-variable @@ -365,9 +368,9 @@ Use SEQUENCE-MAP if display is limited; DEFAULT-MAP otherwise." "List of buttons to include in MH-Letter tool bar." :group 'mh-tool-bar :set 'mh-tool-bar-letter-buttons-set - :type '(set ,@(loop for x in letter-buttons - for y in letter-docs - collect `(const :tag ,y ,x))) + :type '(set ,@(cl-loop for x in letter-buttons + for y in letter-docs + collect `(const :tag ,y ,x))) ;;:package-version '(MH-E "7.1") )))) diff --git a/lisp/mh-e/mh-utils.el b/lisp/mh-e/mh-utils.el index 0938729e78..9f39c1b9da 100644 --- a/lisp/mh-e/mh-utils.el +++ b/lisp/mh-e/mh-utils.el @@ -29,7 +29,6 @@ ;;; Code: (require 'mh-e) -(mh-require-cl) (require 'font-lock) @@ -40,9 +39,9 @@ "Return the position of last occurrence of CHAR in STRING. If CHAR is not present in STRING then return nil. The function is used in lieu of `search' in the CL package." - (loop for index from (1- (length string)) downto 0 - when (equal (aref string index) char) return index - finally return nil)) + (cl-loop for index from (1- (length string)) downto 0 + when (equal (aref string index) char) return index + finally return nil)) @@ -103,9 +102,9 @@ PICK-EXPR is a list of strings. Return nil if PICK-EXPR is nil." (dolist (string pick-expr) (when (and string (not (string-equal string ""))) - (loop for i from 0 to (1- (length mh-pick-regexp-chars)) do - (let ((s (string ?\\ (aref mh-pick-regexp-chars i)))) - (setq string (mh-replace-regexp-in-string s s string t t)))) + (cl-loop for i from 0 to (1- (length mh-pick-regexp-chars)) do + (let ((s (string ?\\ (aref mh-pick-regexp-chars i)))) + (setq string (mh-replace-regexp-in-string s s string t t)))) (setq quoted-pick-expr (append quoted-pick-expr (list string))))) quoted-pick-expr)) @@ -374,7 +373,7 @@ the cursor is not pointing to a message." (mh-exec-cmd-daemon "folders" 'mh-collect-folder-names-filter "-recurse" "-fast")))) -(defun mh-collect-folder-names-filter (process output) +(defun mh-collect-folder-names-filter (_process output) "Read folder names. PROCESS is the flists process that was run to collect folder names and the function is called when OUTPUT is available." @@ -402,15 +401,15 @@ names and the function is called when OUTPUT is available." (child2 (and parent (substring parent (1+ (or parent-slash 0))))) (grand-parent (and parent-slash (substring parent 0 parent-slash))) (cache-entry (gethash parent mh-sub-folders-cache))) - (unless (loop for x in cache-entry when (equal (car x) child1) return t - finally return nil) + (unless (cl-loop for x in cache-entry when (equal (car x) child1) return t + finally return nil) (push (list child1) cache-entry) (setf (gethash parent mh-sub-folders-cache) (sort cache-entry (lambda (x y) (string< (car x) (car y))))) (when parent - (loop for x in (gethash grand-parent mh-sub-folders-cache) - when (equal (car x) child2) - do (progn (setf (cdr x) t) (return))))))) + (cl-loop for x in (gethash grand-parent mh-sub-folders-cache) + when (equal (car x) child2) + do (progn (setf (cdr x) t) (cl-return))))))) (defun mh-normalize-folder-name (folder &optional empty-string-okay dont-remove-trailing-slash @@ -522,12 +521,12 @@ they will not be returned." (unless (null folder) (setq folder-list (list folder)) (setq folder (concat folder "/"))) - (loop for f in (mh-sub-folders folder) do - (setq folder-list - (append folder-list - (if (mh-children-p f) - (mh-folder-list (concat folder (car f))) - (list (concat folder (car f))))))) + (cl-loop for f in (mh-sub-folders folder) do + (setq folder-list + (append folder-list + (if (mh-children-p f) + (mh-folder-list (concat folder (car f))) + (list (concat folder (car f))))))) folder-list)) ;;;###mh-autoload @@ -583,10 +582,10 @@ Expects FOLDER to have already been normalized with (mh-line-beginning-position) t))) (when (integerp has-pos) (while (equal (char-after has-pos) ? ) - (decf has-pos)) - (incf has-pos) + (cl-decf has-pos)) + (cl-incf has-pos) (while (equal (char-after start-pos) ? ) - (incf start-pos)) + (cl-incf start-pos)) (let* ((name (buffer-substring start-pos has-pos)) (first-char (aref name 0)) (last-char (aref name (1- (length name))))) @@ -621,7 +620,7 @@ Here we will need to invalidate the cached sub-folders of +foo, otherwise completion on +foo won't tell us about the option +foo/bar!" (remhash folder mh-sub-folders-cache) - (block ancestor-found + (cl-block ancestor-found (let ((parent folder) (one-ancestor-found nil) last-slash) @@ -630,7 +629,7 @@ otherwise completion on +foo won't tell us about the option (unless (eq (gethash parent mh-sub-folders-cache 'none) 'none) (remhash parent mh-sub-folders-cache) (if one-ancestor-found - (return-from ancestor-found) + (cl-return-from ancestor-found) (setq one-ancestor-found t)))) (remhash nil mh-sub-folders-cache)))) @@ -702,11 +701,11 @@ See Info node `(elisp) Programmed Completion' for details." (name (substring name 1)) (t "")))) (cond ((eq (car-safe flag) 'boundaries) - (list* 'boundaries - (let ((slash (mh-search-from-end ?/ orig-name))) - (if slash (1+ slash) - (if (string-match "\\`\\+" orig-name) 1 0))) - (if (cdr flag) (string-match "/" (cdr flag))))) + (cl-list* 'boundaries + (let ((slash (mh-search-from-end ?/ orig-name))) + (if slash (1+ slash) + (if (string-match "\\`\\+" orig-name) 1 0))) + (if (cdr flag) (string-match "/" (cdr flag))))) ((eq flag nil) (let ((try-res (try-completion @@ -721,6 +720,8 @@ See Info node `(elisp) Programmed Completion' for details." (all-completions remainder (mh-sub-folders last-complete t) predicate)) ((eq flag 'lambda) + ;; FIXME: if name starts with "/", `path' will end + ;; being a relative name without a leading + nor / !? --Stef (let ((path (concat (unless (and (> (length name) 1) (eq (aref name 1) ?/)) mh-user-path) @@ -738,7 +739,7 @@ See Info node `(elisp) Programmed Completion' for details." If ALLOW-ROOT-FOLDER-FLAG is non-nil then \"+\" is allowed to be a folder name corresponding to `mh-user-path'." (mh-normalize-folder-name - (let ((completion-root-regexp "^[+/]") + (let ((completion-root-regexp "^[+/]") ;FIXME: Who/what uses that? (minibuffer-local-completion-map mh-folder-completion-map) (mh-allow-root-folder-flag allow-root-folder-flag)) (completing-read prompt 'mh-folder-completion-function nil nil nil @@ -876,12 +877,12 @@ in this situation." ;; In this situation, rfc822-goto-eoh doesn't go to the end of the ;; header. The replacement allows From_ lines in the mail header. (goto-char (point-min)) - (loop for p = (re-search-forward - "^\\([:\n]\\|[^: \t\n]+[ \t\n]\\)" nil 'move) - do (cond ((null p) (return)) - (t (goto-char (match-beginning 0)) - (unless (looking-at "From ") (return)) - (goto-char p)))) + (cl-loop for p = (re-search-forward + "^\\([:\n]\\|[^: \t\n]+[ \t\n]\\)" nil 'move) + do (cond ((null p) (cl-return)) + (t (goto-char (match-beginning 0)) + (unless (looking-at "From ") (cl-return)) + (goto-char p)))) (point))) ;;;###mh-autoload @@ -918,9 +919,9 @@ Handle RFC 822 (or later) continuation lines." (defun mh-letter-skipped-header-field-p (field) "Check if FIELD is to be skipped." (let ((field (downcase field))) - (loop for x in mh-compose-skipped-header-fields - when (equal (downcase x) field) return t - finally return nil))) + (cl-loop for x in mh-compose-skipped-header-fields + when (equal (downcase x) field) return t + finally return nil))) (defvar mh-hidden-header-keymap (let ((map (make-sparse-keymap))) diff --git a/lisp/mh-e/mh-xface.el b/lisp/mh-e/mh-xface.el index 4ff84a66f7..5ffcfe5e4b 100644 --- a/lisp/mh-e/mh-xface.el +++ b/lisp/mh-e/mh-xface.el @@ -28,7 +28,6 @@ ;;; Code: (require 'mh-e) -(mh-require-cl) (autoload 'message-fetch-field "message") @@ -74,8 +73,8 @@ in this order is used." (x-face (setq raw (mh-uncompface x-face) type 'pbm)) (url (setq type 'url)) - (t (multiple-value-setq (type raw) - (values-list (mh-picon-get-image))))) + (t (cl-multiple-value-setq (type raw) + (cl-values-list (mh-picon-get-image))))) (when type (goto-char (point-min)) (when (re-search-forward "^from:" (point-max) t) @@ -177,93 +176,97 @@ The directories are searched for in the order they appear in the list.") (defvar mh-picon-cache (make-hash-table :test #'equal)) (defvar mh-picon-image-types - (loop for type in '(xpm xbm gif) - when (or (mh-do-in-gnu-emacs - (ignore-errors - (mh-funcall-if-exists image-type-available-p type))) - (mh-do-in-xemacs (featurep type))) - collect type)) + (cl-loop for type in '(xpm xbm gif) + when (or (mh-do-in-gnu-emacs + (ignore-errors + (mh-funcall-if-exists image-type-available-p type))) + (mh-do-in-xemacs (featurep type))) + collect type)) (autoload 'message-tokenize-header "sendmail") -(defun* mh-picon-get-image () +(defun mh-picon-get-image () "Find the best possible match and return contents." (mh-picon-set-directory-list) (save-restriction (let* ((from-field (ignore-errors (car (message-tokenize-header (mh-get-header-field "from:"))))) (from (car (ignore-errors - (mh-funcall-if-exists ietf-drums-parse-address - from-field)))) + ;; Don't use mh-funcall-if-exists because + ;; ietf-drums-parse-address might exist at run-time but + ;; not at compile-time. + (when (fboundp 'ietf-drums-parse-address) + (ietf-drums-parse-address from-field))))) (host (and from (string-match "\\([^+]*\\)\\(\\+.*\\)?@\\(.*\\)" from) (downcase (match-string 3 from)))) (user (and host (downcase (match-string 1 from)))) (canonical-address (format "%s@%s" user host)) (cached-value (gethash canonical-address mh-picon-cache)) - (host-list (and host (delete "" (split-string host "\\.")))) - (match nil)) - (cond (cached-value (return-from mh-picon-get-image cached-value)) - ((not host-list) (return-from mh-picon-get-image nil))) - (setq match - (block loop - ;; u@h search - (loop for dir in mh-picon-existing-directory-list - do (loop for type in mh-picon-image-types - ;; [path]user@host - for file1 = (format "%s/%s.%s" - dir canonical-address type) - when (file-exists-p file1) - do (return-from loop file1) - ;; [path]user - for file2 = (format "%s/%s.%s" dir user type) - when (file-exists-p file2) - do (return-from loop file2) - ;; [path]host - for file3 = (format "%s/%s.%s" dir host type) - when (file-exists-p file3) - do (return-from loop file3))) - ;; facedb search - ;; Search order for user@foo.net: - ;; [path]net/foo/user - ;; [path]net/foo/user/face - ;; [path]net/user - ;; [path]net/user/face - ;; [path]net/foo/unknown - ;; [path]net/foo/unknown/face - ;; [path]net/unknown - ;; [path]net/unknown/face - (loop for u in (list user "unknown") - do (loop for dir in mh-picon-existing-directory-list - do (loop for x on host-list by #'cdr - for y = (mh-picon-generate-path x u dir) - do (loop for type in mh-picon-image-types - for z1 = (format "%s.%s" y type) - when (file-exists-p z1) - do (return-from loop z1) - for z2 = (format "%s/face.%s" - y type) - when (file-exists-p z2) - do (return-from loop z2))))))) - (setf (gethash canonical-address mh-picon-cache) - (mh-picon-file-contents match))))) + (host-list (and host (delete "" (split-string host "\\."))))) + (cond + (cached-value cached-value) + ((not host-list) nil) + (t + (let ((match + (cl-block loop + ;; u@h search + (dolist (dir mh-picon-existing-directory-list) + (cl-loop for type in mh-picon-image-types + ;; [path]user@host + for file1 = (format "%s/%s.%s" + dir canonical-address type) + when (file-exists-p file1) + do (cl-return-from loop file1) + ;; [path]user + for file2 = (format "%s/%s.%s" dir user type) + when (file-exists-p file2) + do (cl-return-from loop file2) + ;; [path]host + for file3 = (format "%s/%s.%s" dir host type) + when (file-exists-p file3) + do (cl-return-from loop file3))) + ;; facedb search + ;; Search order for user@foo.net: + ;; [path]net/foo/user + ;; [path]net/foo/user/face + ;; [path]net/user + ;; [path]net/user/face + ;; [path]net/foo/unknown + ;; [path]net/foo/unknown/face + ;; [path]net/unknown + ;; [path]net/unknown/face + (dolist (u (list user "unknown")) + (dolist (dir mh-picon-existing-directory-list) + (cl-loop for x on host-list by #'cdr + for y = (mh-picon-generate-path x u dir) + do (cl-loop for type in mh-picon-image-types + for z1 = (format "%s.%s" y type) + when (file-exists-p z1) + do (cl-return-from loop z1) + for z2 = (format "%s/face.%s" + y type) + when (file-exists-p z2) + do (cl-return-from loop z2)))))))) + (setf (gethash canonical-address mh-picon-cache) + (mh-picon-file-contents match)))))))) (defun mh-picon-set-directory-list () "Update `mh-picon-existing-directory-list' if needed." (when (eq mh-picon-existing-directory-list 'unset) (setq mh-picon-existing-directory-list - (loop for x in mh-picon-directory-list - when (file-directory-p x) collect x)))) + (cl-loop for x in mh-picon-directory-list + when (file-directory-p x) collect x)))) (defun mh-picon-generate-path (host-list user directory) "Generate the image file path. HOST-LIST is the parsed host address of the email address, USER the username and DIRECTORY is the directory relative to which the path is generated." - (loop with acc = "" - for elem in host-list - do (setq acc (format "%s/%s" elem acc)) - finally return (format "%s/%s%s" directory acc user))) + (cl-loop with acc = "" + for elem in host-list + do (setq acc (format "%s/%s" elem acc)) + finally return (format "%s/%s%s" directory acc user))) (defun mh-picon-file-contents (file) "Return details about FILE. @@ -437,7 +440,7 @@ actual display is carried out by the SENTINEL function." ;; Temporary failure (mh-x-image-set-download-state cache-file 'try-again))) -(defun mh-x-image-scale-and-display (process change) +(defun mh-x-image-scale-and-display (process _change) "When the wget PROCESS terminates scale and display image. The argument CHANGE is ignored." (when (eq (process-status process) 'exit) commit b06917a4912a60402025286d07d4a195749245c4 Author: Paul Eggert Date: Mon Aug 5 17:38:53 2019 -0700 decode-time now returns subsec too The list that decode-time returns now contains an extra trailing component that counts the subseconds part of the original timestamp (Bug#36549). This builds on a suggestion by Lars Ingebrigtsen in: https://lists.gnu.org/r/emacs-devel/2019-07/msg00734.html * doc/lispref/os.texi (Time Conversion): * doc/misc/emacs-mime.texi (time-date): * etc/NEWS: Document this. * lisp/calendar/icalendar.el (icalendar--decode-isodatetime): * lisp/calendar/iso8601.el (iso8601-parse) (iso8601-parse-time, iso8601-parse-duration) (iso8601--decoded-time): * lisp/calendar/parse-time.el (parse-time-string): * lisp/calendar/time-date.el (make-decoded-time) (decoded-time-set-defaults): * lisp/org/org.el (org-fix-decoded-time) (org-parse-time-string): * src/timefns.c (Fdecode_time): Generate subsec member for decoded time. * lisp/calendar/time-date.el (decoded-time-add) Add the decoded subsec too. * lisp/simple.el (decoded-time): New subsec member. * src/data.c (Frem): Simplify zero-check to match that of new Fmod. (integer_mod): New function, with most of the guts of the old Fmod. Remove redundant zero-check. (Fmod): Use it. * src/timefns.c (Fencode_time): Handle new subsec member or (with the obsolescent calling convention) subsec arg. It defaults to 0. * test/lisp/calendar/icalendar-tests.el: (icalendar--decode-isodatetime): * test/lisp/calendar/iso8601-tests.el (test-iso8601-date-years) (test-iso8601-date-dates, test-iso8601-date-obsolete) (test-iso8601-date-weeks, test-iso8601-date-ordinals) (test-iso8601-time, test-iso8601-combined) (test-iso8601-duration, test-iso8601-intervals) (standard-test-dates, standard-test-time-of-day-fractions) (standard-test-time-of-day-beginning-of-day) (standard-test-time-of-day-utc) (standard-test-time-of-day-zone) (standard-test-date-and-time-of-day, standard-test-interval): * test/lisp/calendar/parse-time-tests.el (parse-time-tests): * test/src/timefns-tests.el (format-time-string-with-zone) (encode-time-dst-numeric-zone): Adjust to match new behavior. diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index b26d903707..70ae39e6ab 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -1482,10 +1482,11 @@ Although @code{(time-convert nil nil)} is equivalent to This function converts a time value into calendrical information. If you don't specify @var{time}, it decodes the current time, and similarly @var{zone} defaults to the current time zone rule. @xref{Time Zone Rules}. -The return value is a list of nine elements, as follows: +The return value is a list of ten elements, as follows: @example -(@var{seconds} @var{minutes} @var{hour} @var{day} @var{month} @var{year} @var{dow} @var{dst} @var{utcoff}) +(@var{seconds} @var{minutes} @var{hour} @var{day} @var{month} @var{year} + @var{dow} @var{dst} @var{utcoff} @var{subsec}) @end example Here is what the elements mean: @@ -1513,17 +1514,22 @@ in effect, and @minus{}1 if this information is not available. @item utcoff An integer indicating the Universal Time offset in seconds, i.e., the number of seconds east of Greenwich. +@item subsec +The number of subseconds past the second, as either 0 or a Lisp +timestamp @code{(@var{ticks} . @var{hz})} representing a nonnegative +fraction less than 1. @end table @strong{Common Lisp Note:} Common Lisp has different meanings for -@var{dow} and @var{utcoff}. +@var{dow} and @var{utcoff}, and lacks @var{subsec}. To access (or alter) the elements in the time value, the @code{decoded-time-second}, @code{decoded-time-minute}, @code{decoded-time-hour}, @code{decoded-time-day}, @code{decoded-time-month}, @code{decoded-time-year}, -@code{decoded-time-weekday}, @code{decoded-time-dst} and -@code{decoded-time-zone} accessors can be used. +@code{decoded-time-weekday}, @code{decoded-time-dst}, +@code{decoded-time-zone} and @code{decoded-time-subsec} +accessors can be used. For instance, to increase the year in a decoded time, you could say: @@ -1579,21 +1585,22 @@ It can act as the inverse of @code{decode-time}. Ordinarily the first argument is a list @code{(@var{second} @var{minute} @var{hour} @var{day} @var{month} -@var{year} @var{ignored} @var{dst} @var{zone})} that specifies a +@var{year} @var{ignored} @var{dst} @var{zone} @var{subsec})} that specifies a decoded time in the style of @code{decode-time}, so that @code{(encode-time (decode-time ...))} works. For the meanings of these list members, see the table under @code{decode-time}. As an obsolescent calling convention, this function can be given six -or more arguments. The first six arguments @var{second}, +through ten arguments. The first six arguments @var{second}, @var{minute}, @var{hour}, @var{day}, @var{month}, and @var{year} -specify most of the components of a decoded time. If there are more -than six arguments the @emph{last} argument is used as @var{zone} and -any other extra arguments are ignored, so that @code{(apply -#'encode-time (decode-time ...))} works; otherwise @var{zone} defaults -to the current time zone rule (@pxref{Time Zone Rules}). The decoded -time's @var{dst} component is treated as if it was @minus{}1, and -@var{form} takes its default value. +specify most of the components of a decoded time. If there are seven +through nine arguments the @emph{last} argument is used as @var{zone}, +and if there are ten arguments the ninth specifies @var{zone} and the +tenth specifies @var{subsec}; in either case any other extra arguments +are ignored, so that @code{(apply #'encode-time (decode-time ...))} +works. In this obsolescent convention, @var{zone} defaults to the +current time zone rule (@pxref{Time Zone Rules}), @var{subsec} +defaults to 0, and @var{dst} is treated as if it was @minus{}1. Year numbers less than 100 are not treated specially. If you want them to stand for years above 1900, or years above 2000, you must alter them @@ -1608,8 +1615,9 @@ the latter to the former as follows: @end example You can perform simple date arithmetic by using out-of-range values for -@var{seconds}, @var{minutes}, @var{hour}, @var{day}, and @var{month}; -for example, day 0 means the day preceding the given month. +@var{seconds}, @var{minutes}, @var{hour}, @var{day}, @var{month}, and +@var{subsec}; for example, day 0 means the day preceding the given +month. The operating system puts limits on the range of possible time values; if the limits are exceeded while encoding the time, an error results. diff --git a/doc/misc/emacs-mime.texi b/doc/misc/emacs-mime.texi index eb829b0612..c411bf3d68 100644 --- a/doc/misc/emacs-mime.texi +++ b/doc/misc/emacs-mime.texi @@ -1535,7 +1535,7 @@ Here's a bunch of time/date/second/day examples: @example (parse-time-string "Sat Sep 12 12:21:54 1998 +0200") -@result{} (54 21 12 12 9 1998 6 -1 7200) +@result{} (54 21 12 12 9 1998 6 -1 7200 0) (time-convert (date-to-time "Sat Sep 12 12:21:54 1998 +0200") diff --git a/etc/NEWS b/etc/NEWS index 116bdb961c..734d5fd8a8 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2092,6 +2092,12 @@ format may change and that programs should use functions like probing the innards of a timestamp directly, or creating a timestamp by hand. ++++ +*** Decoded (calendrical) timestamps now have a new subsecond member. +This affects functions like decode-time and parse-time-string that +generate these timestamps, and functions like encode-time that accept +them. + +++ *** 'encode-time' supports a new API '(encode-time TIME)'. The old 'encode-time' API is still supported. @@ -2123,8 +2129,8 @@ with POSIX.1-2017. *** To access (or alter) the elements a decoded time value, the 'decoded-time-second', 'decoded-time-minute', 'decoded-time-hour', 'decoded-time-day', 'decoded-time-month', 'decoded-time-year', -'decoded-time-weekday', 'decoded-time-dst' and 'decoded-time-zone' -accessors can be used. +'decoded-time-weekday', 'decoded-time-dst', 'decoded-time-zone', +and 'decoded-time-subsec' accessors can be used. *** The new functions 'date-days-in-month' (which will say how many days there are in a month in a specific year), 'date-ordinal-to-time' diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index c2688705e3..84f579ad44 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -644,7 +644,7 @@ FIXME: multiple comma-separated values should be allowed!" ;; create the decoded date-time ;; FIXME!?! (let ((decoded-time (list second minute hour day month year - nil -1 zone))) + nil -1 zone 0))) (condition-case nil (decode-time (encode-time decoded-time)) (error diff --git a/lisp/calendar/iso8601.el b/lisp/calendar/iso8601.el index 30352c7e75..51f5dff909 100644 --- a/lisp/calendar/iso8601.el +++ b/lisp/calendar/iso8601.el @@ -129,7 +129,8 @@ well as variants like \"2008W32\" (week number) and (let ((time (iso8601-parse-time time-string))) (setf (decoded-time-hour date) (decoded-time-hour time)) (setf (decoded-time-minute date) (decoded-time-minute time)) - (setf (decoded-time-second date) (decoded-time-second time)))) + (setf (decoded-time-second date) (decoded-time-second time)) + (setf (decoded-time-subsec date) (decoded-time-subsec time)))) ;; The time zone is optional. (when zone-string (setf (decoded-time-zone date) @@ -236,6 +237,8 @@ well as variants like \"2008W32\" (week number) and (iso8601--decoded-time :hour hour :minute (or minute 0) :second (or second 0) + ;; FIXME: Support subsec. + :subsec 0 :zone (and zone (* 60 (iso8601-parse-zone zone))))))))) @@ -274,7 +277,9 @@ Return the number of minutes." :day (or (match-string 3 string) 0) :hour (or (match-string 5 string) 0) :minute (or (match-string 6 string) 0) - :second (or (match-string 7 string) 0))) + :second (or (match-string 7 string) 0) + ;; FIXME: Support subsec. + :subsec 0)) ;; PnW: Weeks. ((iso8601--match iso8601--duration-week-match string) (let ((weeks (string-to-number (match-string 1 string)))) @@ -336,7 +341,7 @@ Return the number of minutes." (cl-defun iso8601--decoded-time (&key second minute hour day month year - dst zone) + dst zone subsec) (list (iso8601--value second) (iso8601--value minute) (iso8601--value hour) @@ -345,7 +350,8 @@ Return the number of minutes." (iso8601--value year) nil dst - zone)) + zone + subsec)) (defun iso8601--encode-time (time) "Like `encode-time', but fill in nil values in TIME." diff --git a/lisp/calendar/parse-time.el b/lisp/calendar/parse-time.el index e28df97918..9af93b5b1e 100644 --- a/lisp/calendar/parse-time.el +++ b/lisp/calendar/parse-time.el @@ -27,7 +27,7 @@ ;; Emacs. However, parsing time strings is still largely a matter of ;; heuristics and no common interface has been designed. -;; `parse-time-string' parses a time in a string and returns a list of 9 +;; `parse-time-string' parses a time in a string and returns a list of ;; values, just like `decode-time', where unspecified elements in the ;; string are returned as nil (except unspecfied DST is returned as -1). ;; `encode-time' may be applied on these values to obtain an internal @@ -148,7 +148,7 @@ letters, digits, plus or minus signs or colons." ;;;###autoload (defun parse-time-string (string) - "Parse the time-string STRING into (SEC MIN HOUR DAY MON YEAR DOW DST TZ). + "Parse the time in STRING into (SEC MIN HOUR DAY MON YEAR DOW DST TZ SUBSEC). STRING should be something resembling an RFC 822 (or later) date-time, e.g., \"Fri, 25 Mar 2016 16:24:56 +0100\", but this function is somewhat liberal in what format it accepts, and will attempt to @@ -156,7 +156,7 @@ return a \"likely\" value even for somewhat malformed strings. The values returned are identical to those of `decode-time', but any unknown values other than DST are returned as nil, and an unknown DST value is returned as -1." - (let ((time (list nil nil nil nil nil nil nil -1 nil)) + (let ((time (list nil nil nil nil nil nil nil -1 nil nil)) (temp (parse-time-tokenize (downcase string)))) (while temp (let ((parse-time-elt (pop temp)) @@ -193,6 +193,10 @@ unknown DST value is returned as -1." (funcall this))) parse-time-val))) (setf (nth (pop slots) time) new-val)))))))) + ;; FIXME: Currently parse-time-string does not parse subseconds. + ;; So if seconds were found, set subseconds to zero. + (when (nth 0 time) + (setf (nth 9 time) 0)) time)) (defun parse-iso8601-time-string (date-string) diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index 7505332011..c22f441420 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -423,6 +423,13 @@ changes in daylight saving time are not taken into account." (setq seconds (+ (* (or (decoded-time-hour delta) 0) 3600) (* (or (decoded-time-minute delta) 0) 60) (or (decoded-time-second delta) 0))) + (when (decoded-time-subsec delta) + (let* ((subsec (time-convert (time-add (decoded-time-subsec time) + (decoded-time-subsec delta)) + t)) + (s (time-convert subsec 'integer))) + (setq seconds (+ seconds s)) + (setf (decoded-time-subsec time) (time-subtract subsec s)))) ;; Time zone adjustments are basically the same as time adjustments. (setq seconds (+ seconds (or (decoded-time-zone delta) 0))) @@ -494,9 +501,9 @@ changes in daylight saving time are not taken into account." (cl-defun make-decoded-time (&key second minute hour day month year - dst zone) + dst zone subsec) "Return a `decoded-time' structure with only the keywords given filled out." - (list second minute hour day month year nil dst zone)) + (list second minute hour day month year nil dst zone subsec)) (defun decoded-time-set-defaults (time &optional default-zone) "Set any nil values in `decoded-time' TIME to default values. @@ -526,6 +533,9 @@ TIME is modified and returned." (when (and (not (decoded-time-zone time)) default-zone) (setf (decoded-time-zone time) 0)) + + (unless (decoded-time-subsec time) + (setf (decoded-time-subsec time) 0)) time) (provide 'time-date) diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el index 95f208baf9..eb08511171 100644 --- a/lisp/net/soap-client.el +++ b/lisp/net/soap-client.el @@ -561,7 +561,8 @@ gMonthDay, gDay or gMonth. Return a list in a format (SEC MINUTE HOUR DAY MONTH YEAR SEC-FRACTION DATATYPE ZONE). This format is meant to be similar to that returned by `decode-time' (and compatible with -`encode-time'). The differences are the DOW (day-of-week) field +`encode-time'). The differences are the SUBSEC (fractional +seconds) field is omitted, the DOW (day-of-week) field is replaced with SEC-FRACTION, a float representing the fractional seconds, and the DST (daylight savings time) field is replaced with DATATYPE, a symbol representing the XSD primitive diff --git a/lisp/org/org.el b/lisp/org/org.el index cbf085a269..e4c075f8cd 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -17292,10 +17292,10 @@ The command returns the inserted time stamp." (put-text-property beg end 'display str))) (defun org-fix-decoded-time (time) - "Set 0 instead of nil for the first 6 elements of time. + "Set 0 instead of nil for the time-related elements of time. Don't touch the rest." (let ((n 0)) - (mapcar (lambda (x) (if (< (setq n (1+ n)) 7) (or x 0) x)) time))) + (mapcar (lambda (x) (if (or (< (setq n (1+ n)) 7) (= n 10)) (or x 0) x)) time))) (defun org-time-stamp-to-now (timestamp-string &optional seconds) "Difference between TIMESTAMP-STRING and now in days. @@ -17779,7 +17779,7 @@ NODEFAULT, hour and minute fields will be nil if not given." (string-to-number (match-string 4 s)) (string-to-number (match-string 3 s)) (string-to-number (match-string 2 s)) - nil nil nil)) + nil nil nil 0)) ((string-match "^<[^>]+>$" s) ;; FIXME: `decode-time' needs to be called with ZONE as its ;; second argument. However, this requires at least Emacs diff --git a/lisp/simple.el b/lisp/simple.el index 6f60004897..26b82479ff 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -9089,6 +9089,9 @@ available.") (zone nil :documentation "\ This is an integer indicating the UTC offset in seconds, i.e., the number of seconds east of Greenwich.") + (subsec nil :documentation "\ +This is 0, or is an integer pair (TICKS . HZ) indicating TICKS/HZ seconds, +where HZ is positive and TICKS is nonnegative and less than HZ.") ) diff --git a/src/data.c b/src/data.c index 46bd7e0e25..6db8ea144d 100644 --- a/src/data.c +++ b/src/data.c @@ -3067,7 +3067,7 @@ Both must be integers or markers. */) CHECK_INTEGER_COERCE_MARKER (y); /* A bignum can never be 0, so don't check that case. */ - if (FIXNUMP (y) && XFIXNUM (y) == 0) + if (EQ (y, make_fixnum (0))) xsignal0 (Qarith_error); if (FIXNUMP (x) && FIXNUMP (y)) @@ -3081,30 +3081,14 @@ Both must be integers or markers. */) } } -DEFUN ("mod", Fmod, Smod, 2, 2, 0, - doc: /* Return X modulo Y. -The result falls between zero (inclusive) and Y (exclusive). -Both X and Y must be numbers or markers. */) - (register Lisp_Object x, Lisp_Object y) +/* Return X mod Y. Both must be integers and Y must be nonzero. */ +Lisp_Object +integer_mod (Lisp_Object x, Lisp_Object y) { - CHECK_NUMBER_COERCE_MARKER (x); - CHECK_NUMBER_COERCE_MARKER (y); - - /* Note that a bignum can never be 0, so we don't need to check that - case. */ - if (FIXNUMP (y) && XFIXNUM (y) == 0) - xsignal0 (Qarith_error); - - if (FLOATP (x) || FLOATP (y)) - return fmod_float (x, y); - if (FIXNUMP (x) && FIXNUMP (y)) { EMACS_INT i1 = XFIXNUM (x), i2 = XFIXNUM (y); - if (i2 == 0) - xsignal0 (Qarith_error); - i1 %= i2; /* If the "remainder" comes out with the wrong sign, fix it. */ @@ -3128,6 +3112,22 @@ Both X and Y must be numbers or markers. */) } } +DEFUN ("mod", Fmod, Smod, 2, 2, 0, + doc: /* Return X modulo Y. +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); + + /* A bignum can never be 0, so don't check that case. */ + if (EQ (y, make_fixnum (0))) + xsignal0 (Qarith_error); + + return (FLOATP (x) || FLOATP (y) ? fmod_float : integer_mod) (x, y); +} + static Lisp_Object minmax_driver (ptrdiff_t nargs, Lisp_Object *args, enum Arith_Comparison comparison) diff --git a/src/lisp.h b/src/lisp.h index f437609fe1..63baab5d63 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3581,6 +3581,7 @@ extern void set_default_internal (Lisp_Object, Lisp_Object, extern Lisp_Object expt_integer (Lisp_Object, Lisp_Object); extern void syms_of_data (void); extern void swap_in_global_binding (struct Lisp_Symbol *); +extern Lisp_Object integer_mod (Lisp_Object, Lisp_Object); /* Defined in cmds.c */ extern void syms_of_cmds (void); diff --git a/src/timefns.c b/src/timefns.c index 4310409ab7..953e246a9a 100644 --- a/src/timefns.c +++ b/src/timefns.c @@ -1296,7 +1296,7 @@ usage: (format-time-string FORMAT-STRING &optional TIME ZONE) */) } DEFUN ("decode-time", Fdecode_time, Sdecode_time, 0, 2, 0, - doc: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF). + doc: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF SUBSEC). The optional TIME is the time value to convert. See `format-time-string' for the various forms of a time value. @@ -1309,10 +1309,10 @@ without consideration for daylight saving time. To access (or alter) the elements in the time value, the `decoded-time-second', `decoded-time-minute', `decoded-time-hour', `decoded-time-day', `decoded-time-month', `decoded-time-year', -`decoded-time-weekday', `decoded-time-dst' and `decoded-time-zone' -accessors can be used. +`decoded-time-weekday', `decoded-time-dst', `decoded-time-zone' and +`decoded-time-subsec' accessors can be used. -The list has the following nine members: SEC is an integer between 0 +The list has the following ten members: SEC is an integer between 0 and 60; SEC is 60 for a leap second, which only some operating systems support. MINUTE is an integer between 0 and 59. HOUR is an integer between 0 and 23. DAY is an integer between 1 and 31. MONTH is an @@ -1321,13 +1321,20 @@ four-digit year. DOW is the day of week, an integer between 0 and 6, where 0 is Sunday. DST is t if daylight saving time is in effect, nil if it is not in effect, and -1 if daylight saving information is not available. UTCOFF is an integer indicating the UTC offset in -seconds, i.e., the number of seconds east of Greenwich. (Note that -Common Lisp has different meanings for DOW and UTCOFF.) +seconds, i.e., the number of seconds east of Greenwich. SUBSEC is +is either 0 or (TICKS . HZ) where HZ is a positive integer clock +resolution and TICKS is a nonnegative integer less than HZ. (Note +that Common Lisp has different meanings for DOW and UTCOFF, and lacks +SUBSEC.) usage: (decode-time &optional TIME ZONE) */) (Lisp_Object specified_time, Lisp_Object zone) { - time_t time_spec = lisp_seconds_argument (specified_time); + struct lisp_time lt = lisp_time_struct (specified_time, 0); + struct timespec ts = lisp_to_timespec (lt); + if (! timespec_valid_p (ts)) + time_overflow (); + time_t time_spec = ts.tv_sec; struct tm local_tm, gmt_tm; timezone_t tz = tzlookup (zone, false); struct tm *tm = emacs_localtime_rz (tz, &time_spec, &local_tm); @@ -1367,7 +1374,10 @@ usage: (decode-time &optional TIME ZONE) */) ? make_fixnum (tm_gmtoff (&local_tm)) : gmtime_r (&time_spec, &gmt_tm) ? make_fixnum (tm_diff (&local_tm, &gmt_tm)) - : Qnil)); + : Qnil), + (EQ (lt.hz, make_fixnum (1)) + ? make_fixnum (0) + : Fcons (integer_mod (lt.ticks, lt.hz), lt.hz))); } /* Return OBJ - OFFSET, checking that OBJ is a valid integer and that @@ -1398,7 +1408,7 @@ check_tm_member (Lisp_Object obj, int offset) DEFUN ("encode-time", Fencode_time, Sencode_time, 1, MANY, 0, doc: /* Convert TIME to a timestamp. -TIME is a list (SECOND MINUTE HOUR DAY MONTH YEAR IGNORED DST ZONE). +TIME is a list (SECOND MINUTE HOUR DAY MONTH YEAR IGNORED DST ZONE SUBSEC). in the style of `decode-time', so that (encode-time (decode-time ...)) works. In this list, ZONE can be nil for Emacs local time, t for Universal Time, `wall' for system wall clock time, or a string as in the TZ @@ -1407,15 +1417,18 @@ environment variable. It can also be a list (as from without consideration for daylight saving time. If ZONE specifies a time zone with daylight-saving transitions, DST is t for daylight saving time, nil for standard time, and -1 to cause the daylight -saving flag to be guessed. +saving flag to be guessed. SUBSEC is either 0 or a Lisp timestamp +in (TICKS . HZ) form. As an obsolescent calling convention, if this function is called with -6 or more arguments, the first 6 arguments are SECOND, MINUTE, HOUR, -DAY, MONTH, and YEAR, and specify the components of a decoded time, -where DST assumed to be -1 and FORM is omitted. If there are more -than 6 arguments the *last* argument is used as ZONE and any other -extra arguments are ignored, so that (apply #'encode-time -(decode-time ...)) works; otherwise ZONE is assumed to be nil. +6 through 10 arguments, the first 6 arguments are SECOND, MINUTE, +HOUR, DAY, MONTH, and YEAR, and specify the components of a decoded +time. If there are 7 through 9 arguments the *last* argument +specifies ZONE, and if there are 10 arguments the 9th specifies ZONE +and the 10th specifies SUBSEC; in either case any other extra +arguments are ignored, so that (apply #\\='encode-time (decode-time +...)) works. In this obsolescent convention, DST, ZONE, and SUBSEC +default to -1, nil and 0 respectively. Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed; for example, a DAY of 0 means the day preceding the given month. @@ -1429,14 +1442,14 @@ usage: (encode-time TIME &rest OBSOLESCENT-ARGUMENTS) */) (ptrdiff_t nargs, Lisp_Object *args) { struct tm tm; - Lisp_Object zone = Qnil; + Lisp_Object zone = Qnil, subsec = make_fixnum (0); Lisp_Object a = args[0]; tm.tm_isdst = -1; if (nargs == 1) { Lisp_Object tail = a; - for (int i = 0; i < 9; i++, tail = XCDR (tail)) + for (int i = 0; i < 10; i++, tail = XCDR (tail)) CHECK_CONS (tail); tm.tm_sec = check_tm_member (XCAR (a), 0); a = XCDR (a); tm.tm_min = check_tm_member (XCAR (a), 0); a = XCDR (a); @@ -1445,11 +1458,11 @@ usage: (encode-time TIME &rest OBSOLESCENT-ARGUMENTS) */) tm.tm_mon = check_tm_member (XCAR (a), 1); a = XCDR (a); tm.tm_year = check_tm_member (XCAR (a), TM_YEAR_BASE); a = XCDR (a); a = XCDR (a); - Lisp_Object dstflag = XCAR (a); - a = XCDR (a); - zone = XCAR (a); + Lisp_Object dstflag = XCAR (a); a = XCDR (a); + zone = XCAR (a); a = XCDR (a); if (SYMBOLP (dstflag) && !FIXNUMP (zone) && !CONSP (zone)) tm.tm_isdst = !NILP (dstflag); + subsec = XCAR (a); } else if (nargs < 6) xsignal2 (Qwrong_number_of_arguments, Qencode_time, make_fixnum (nargs)); @@ -1457,6 +1470,11 @@ usage: (encode-time TIME &rest OBSOLESCENT-ARGUMENTS) */) { if (6 < nargs) zone = args[nargs - 1]; + if (9 < nargs) + { + zone = args[8]; + subsec = args[9]; + } tm.tm_sec = check_tm_member (a, 0); tm.tm_min = check_tm_member (args[1], 0); tm.tm_hour = check_tm_member (args[2], 0); @@ -1474,9 +1492,25 @@ usage: (encode-time TIME &rest OBSOLESCENT-ARGUMENTS) */) if (tm.tm_wday < 0) time_error (mktime_errno); - return (CURRENT_TIME_LIST - ? list2 (hi_time (value), lo_time (value)) - : INT_TO_INTEGER (value)); + if (CONSP (subsec)) + { + Lisp_Object subsecticks = XCAR (subsec); + if (INTEGERP (subsecticks)) + { + struct lisp_time val1 = { INT_TO_INTEGER (value), make_fixnum (1) }; + Lisp_Object + hz = XCDR (subsec), + secticks = lisp_time_hz_ticks (val1, hz), + ticks = lispint_arith (secticks, subsecticks, false); + return Fcons (ticks, hz); + } + } + else if (INTEGERP (subsec)) + return (CURRENT_TIME_LIST && EQ (subsec, make_fixnum (0)) + ? list2 (hi_time (value), lo_time (value)) + : lispint_arith (INT_TO_INTEGER (value), subsec, false)); + + xsignal2 (Qerror, build_string ("Invalid subsec"), subsec); } DEFUN ("time-convert", Ftime_convert, Stime_convert, 1, 2, 0, diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el index baea480404..060cd8c909 100644 --- a/test/lisp/calendar/icalendar-tests.el +++ b/test/lisp/calendar/icalendar-tests.el @@ -477,18 +477,18 @@ END:VEVENT ;; testcase: no time zone in input -> keep time as is ;; 1 Jan 2013 10:00 - (should (equal '(0 0 10 1 1 2013 2 nil 7200) + (should (equal '(0 0 10 1 1 2013 2 nil 7200 0) (icalendar--decode-isodatetime "20130101T100000"))) ;; 1 Aug 2013 10:00 (DST) - (should (equal '(0 0 10 1 8 2013 4 t 10800) + (should (equal '(0 0 10 1 8 2013 4 t 10800 0) (icalendar--decode-isodatetime "20130801T100000"))) ;; testcase: UTC time zone specifier in input -> convert to local time ;; 31 Dec 2013 23:00 UTC -> 1 Jan 2013 01:00 EET - (should (equal '(0 0 1 1 1 2014 3 nil 7200) + (should (equal '(0 0 1 1 1 2014 3 nil 7200 0) (icalendar--decode-isodatetime "20131231T230000Z"))) ;; 1 Aug 2013 10:00 UTC -> 1 Aug 2013 13:00 EEST - (should (equal '(0 0 13 1 8 2013 4 t 10800) + (should (equal '(0 0 13 1 8 2013 4 t 10800 0) (icalendar--decode-isodatetime "20130801T100000Z"))) ) diff --git a/test/lisp/calendar/iso8601-tests.el b/test/lisp/calendar/iso8601-tests.el index 35c319ed03..3f1149c864 100644 --- a/test/lisp/calendar/iso8601-tests.el +++ b/test/lisp/calendar/iso8601-tests.el @@ -24,65 +24,65 @@ (ert-deftest test-iso8601-date-years () (should (equal (iso8601-parse-date "1985") - '(nil nil nil nil nil 1985 nil nil nil))) + '(nil nil nil nil nil 1985 nil nil nil nil))) (should (equal (iso8601-parse-date "-0003") - '(nil nil nil nil nil -4 nil nil nil))) + '(nil nil nil nil nil -4 nil nil nil nil))) (should (equal (iso8601-parse-date "+1985") - '(nil nil nil nil nil 1985 nil nil nil)))) + '(nil nil nil nil nil 1985 nil nil nil nil)))) (ert-deftest test-iso8601-date-dates () (should (equal (iso8601-parse-date "1985-03-14") - '(nil nil nil 14 3 1985 nil nil nil))) + '(nil nil nil 14 3 1985 nil nil nil nil))) (should (equal (iso8601-parse-date "19850314") - '(nil nil nil 14 3 1985 nil nil nil))) + '(nil nil nil 14 3 1985 nil nil nil nil))) (should (equal (iso8601-parse-date "1985-02") - '(nil nil nil nil 2 1985 nil nil nil)))) + '(nil nil nil nil 2 1985 nil nil nil nil)))) (ert-deftest test-iso8601-date-obsolete () (should (equal (iso8601-parse-date "--02-01") - '(nil nil nil 1 2 nil nil nil nil))) + '(nil nil nil 1 2 nil nil nil nil nil))) (should (equal (iso8601-parse-date "--0201") - '(nil nil nil 1 2 nil nil nil nil)))) + '(nil nil nil 1 2 nil nil nil nil nil)))) (ert-deftest test-iso8601-date-weeks () (should (equal (iso8601-parse-date "2008W39-6") - '(nil nil nil 27 9 2008 nil nil nil))) + '(nil nil nil 27 9 2008 nil nil nil nil))) (should (equal (iso8601-parse-date "2009W01-1") - '(nil nil nil 29 12 2008 nil nil nil))) + '(nil nil nil 29 12 2008 nil nil nil nil))) (should (equal (iso8601-parse-date "2009W53-7") - '(nil nil nil 3 1 2010 nil nil nil)))) + '(nil nil nil 3 1 2010 nil nil nil nil)))) (ert-deftest test-iso8601-date-ordinals () (should (equal (iso8601-parse-date "1981-095") - '(nil nil nil 5 4 1981 nil nil nil)))) + '(nil nil nil 5 4 1981 nil nil nil nil)))) (ert-deftest test-iso8601-time () (should (equal (iso8601-parse-time "13:47:30") - '(30 47 13 nil nil nil nil nil nil))) + '(30 47 13 nil nil nil nil nil nil 0))) (should (equal (iso8601-parse-time "134730") - '(30 47 13 nil nil nil nil nil nil))) + '(30 47 13 nil nil nil nil nil nil 0))) (should (equal (iso8601-parse-time "1347") - '(0 47 13 nil nil nil nil nil nil)))) + '(0 47 13 nil nil nil nil nil nil 0)))) (ert-deftest test-iso8601-combined () (should (equal (iso8601-parse "2008-03-02T13:47:30") - '(30 47 13 2 3 2008 nil nil nil))) + '(30 47 13 2 3 2008 nil nil nil 0))) (should (equal (iso8601-parse "2008-03-02T13:47:30Z") - '(30 47 13 2 3 2008 nil nil 0))) + '(30 47 13 2 3 2008 nil nil 0 0))) (should (equal (iso8601-parse "2008-03-02T13:47:30+01:00") - '(30 47 13 2 3 2008 nil nil 3600))) + '(30 47 13 2 3 2008 nil nil 3600 0))) (should (equal (iso8601-parse "2008-03-02T13:47:30-01") - '(30 47 13 2 3 2008 nil nil -3600)))) + '(30 47 13 2 3 2008 nil nil -3600 0)))) (ert-deftest test-iso8601-duration () (should (equal (iso8601-parse-duration "P3Y6M4DT12H30M5S") - '(5 30 12 4 6 3 nil nil nil))) + '(5 30 12 4 6 3 nil nil nil 0))) (should (equal (iso8601-parse-duration "P1M") - '(0 0 0 0 1 0 nil nil nil))) + '(0 0 0 0 1 0 nil nil nil 0))) (should (equal (iso8601-parse-duration "PT1M") - '(0 1 0 0 0 0 nil nil nil))) + '(0 1 0 0 0 0 nil nil nil 0))) (should (equal (iso8601-parse-duration "P0003-06-04T12:30:05") - '(5 30 12 4 6 3 nil nil nil)))) + '(5 30 12 4 6 3 nil nil nil 0)))) (ert-deftest test-iso8601-invalid () (should-not (iso8601-valid-p " 2008-03-02T13:47:30-01")) @@ -94,149 +94,149 @@ (ert-deftest test-iso8601-intervals () (should (equal (iso8601-parse-interval "2007-03-01T13:00:00Z/2008-05-11T15:30:00Z") - '((0 0 13 1 3 2007 nil nil 0) - (0 30 15 11 5 2008 nil nil 0) + '((0 0 13 1 3 2007 nil nil 0 0) + (0 30 15 11 5 2008 nil nil 0 0) ;; Hm... can't really use decode-time for time differences... - (0 30 2 14 3 1971 0 nil 0)))) + (0 30 2 14 3 1971 0 nil 0 0)))) (should (equal (iso8601-parse-interval "2007-03-01T13:00:00Z/P1Y2M10DT2H30M") - '((0 0 13 1 3 2007 nil nil 0) - (0 30 15 11 5 2008 nil nil 0) - (0 30 2 10 2 1 nil nil nil)))) + '((0 0 13 1 3 2007 nil nil 0 0) + (0 30 15 11 5 2008 nil nil 0 0) + (0 30 2 10 2 1 nil nil nil 0)))) (should (equal (iso8601-parse-interval "P1Y2M10DT2H30M/2008-05-11T15:30:00Z") - '((0 0 13 1 3 2007 nil nil 0) - (0 30 15 11 5 2008 nil nil 0) - (0 30 2 10 2 1 nil nil nil))))) + '((0 0 13 1 3 2007 nil nil 0 0) + (0 30 15 11 5 2008 nil nil 0 0) + (0 30 2 10 2 1 nil nil nil 0))))) (ert-deftest standard-test-dates () (should (equal (iso8601-parse-date "19850412") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil nil nil nil))) (should (equal (iso8601-parse-date "1985-04-12") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil nil nil nil))) (should (equal (iso8601-parse-date "1985102") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil nil nil nil))) (should (equal (iso8601-parse-date "1985-102") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil nil nil nil))) (should (equal (iso8601-parse-date "1985W155") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil nil nil nil))) (should (equal (iso8601-parse-date "1985-W15-5") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil nil nil nil))) (should (equal (iso8601-parse-date "1985W15") - '(nil nil nil 7 4 1985 nil nil nil))) + '(nil nil nil 7 4 1985 nil nil nil nil))) (should (equal (iso8601-parse-date "1985-W15") - '(nil nil nil 7 4 1985 nil nil nil))) + '(nil nil nil 7 4 1985 nil nil nil nil))) (should (equal (iso8601-parse-date "1985-04") - '(nil nil nil nil 4 1985 nil nil nil))) + '(nil nil nil nil 4 1985 nil nil nil nil))) (should (equal (iso8601-parse-date "1985") - '(nil nil nil nil nil 1985 nil nil nil))) + '(nil nil nil nil nil 1985 nil nil nil nil))) (should (equal (iso8601-parse-date "+1985-04-12") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil nil nil nil))) (should (equal (iso8601-parse-date "+19850412") - '(nil nil nil 12 4 1985 nil nil nil)))) + '(nil nil nil 12 4 1985 nil nil nil nil)))) (ert-deftest standard-test-time-of-day-local-time () (should (equal (iso8601-parse-time "152746") - '(46 27 15 nil nil nil nil nil nil))) + '(46 27 15 nil nil nil nil nil nil 0))) (should (equal (iso8601-parse-time "15:27:46") - '(46 27 15 nil nil nil nil nil nil))) + '(46 27 15 nil nil nil nil nil nil 0))) (should (equal (iso8601-parse-time "1528") - '(0 28 15 nil nil nil nil nil nil))) + '(0 28 15 nil nil nil nil nil nil 0))) (should (equal (iso8601-parse-time "15:28") - '(0 28 15 nil nil nil nil nil nil))) + '(0 28 15 nil nil nil nil nil nil 0))) (should (equal (iso8601-parse-time "15") - '(0 0 15 nil nil nil nil nil nil)))) + '(0 0 15 nil nil nil nil nil nil 0)))) (ert-deftest standard-test-time-of-day-fractions () ;; decoded-time doesn't support sub-second times. ;; (should (equal (iso8601-parse-time "152735,5") - ;; '(46 27 15 nil nil nil nil nil nil))) + ;; '(46 27 15 nil nil nil nil nil nil (5 . 10)))) ;; (should (equal (iso8601-parse-time "15:27:35,5") - ;; '(46 27 15 nil nil nil nil nil nil))) + ;; '(46 27 15 nil nil nil nil nil nil (5 . 10)))) ) (ert-deftest standard-test-time-of-day-beginning-of-day () (should (equal (iso8601-parse-time "000000") - '(0 0 0 nil nil nil nil nil nil))) + '(0 0 0 nil nil nil nil nil nil 0))) (should (equal (iso8601-parse-time "00:00:00") - '(0 0 0 nil nil nil nil nil nil))) + '(0 0 0 nil nil nil nil nil nil 0))) (should (equal (iso8601-parse-time "0000") - '(0 0 0 nil nil nil nil nil nil))) + '(0 0 0 nil nil nil nil nil nil 0))) (should (equal (iso8601-parse-time "00:00") - '(0 0 0 nil nil nil nil nil nil)))) + '(0 0 0 nil nil nil nil nil nil 0)))) (ert-deftest standard-test-time-of-day-utc () (should (equal (iso8601-parse-time "232030Z") - '(30 20 23 nil nil nil nil nil 0))) + '(30 20 23 nil nil nil nil nil 0 0))) (should (equal (iso8601-parse-time "23:20:30Z") - '(30 20 23 nil nil nil nil nil 0))) + '(30 20 23 nil nil nil nil nil 0 0))) (should (equal (iso8601-parse-time "2320Z") - '(0 20 23 nil nil nil nil nil 0))) + '(0 20 23 nil nil nil nil nil 0 0))) (should (equal (iso8601-parse-time "23:20Z") - '(0 20 23 nil nil nil nil nil 0))) + '(0 20 23 nil nil nil nil nil 0 0))) (should (equal (iso8601-parse-time "23Z") - '(0 0 23 nil nil nil nil nil 0)))) + '(0 0 23 nil nil nil nil nil 0 0)))) (ert-deftest standard-test-time-of-day-zone () (should (equal (iso8601-parse-time "152746+0100") - '(46 27 15 nil nil nil nil nil 3600))) + '(46 27 15 nil nil nil nil nil 3600 0))) (should (equal (iso8601-parse-time "15:27:46+0100") - '(46 27 15 nil nil nil nil nil 3600))) + '(46 27 15 nil nil nil nil nil 3600 0))) (should (equal (iso8601-parse-time "152746+01") - '(46 27 15 nil nil nil nil nil 3600))) + '(46 27 15 nil nil nil nil nil 3600 0))) (should (equal (iso8601-parse-time "15:27:46+01") - '(46 27 15 nil nil nil nil nil 3600))) + '(46 27 15 nil nil nil nil nil 3600 0))) (should (equal (iso8601-parse-time "152746-0500") - '(46 27 15 nil nil nil nil nil -18000))) + '(46 27 15 nil nil nil nil nil -18000 0))) (should (equal (iso8601-parse-time "15:27:46-0500") - '(46 27 15 nil nil nil nil nil -18000))) + '(46 27 15 nil nil nil nil nil -18000 0))) (should (equal (iso8601-parse-time "152746-05") - '(46 27 15 nil nil nil nil nil -18000))) + '(46 27 15 nil nil nil nil nil -18000 0))) (should (equal (iso8601-parse-time "15:27:46-05") - '(46 27 15 nil nil nil nil nil -18000)))) + '(46 27 15 nil nil nil nil nil -18000 0)))) (ert-deftest standard-test-date-and-time-of-day () (should (equal (iso8601-parse "19850412T101530") - '(30 15 10 12 4 1985 nil nil nil))) + '(30 15 10 12 4 1985 nil nil nil 0))) (should (equal (iso8601-parse "1985-04-12T10:15:30") - '(30 15 10 12 4 1985 nil nil nil))) + '(30 15 10 12 4 1985 nil nil nil 0))) (should (equal (iso8601-parse "1985102T235030Z") - '(30 50 23 12 4 1985 nil nil 0))) + '(30 50 23 12 4 1985 nil nil 0 0))) (should (equal (iso8601-parse "1985-102T23:50:30Z") - '(30 50 23 12 4 1985 nil nil 0))) + '(30 50 23 12 4 1985 nil nil 0 0))) (should (equal (iso8601-parse "1985W155T235030") - '(30 50 23 12 4 1985 nil nil nil))) + '(30 50 23 12 4 1985 nil nil nil 0))) (should (equal (iso8601-parse "1985-W155T23:50:30") - '(30 50 23 12 4 1985 nil nil nil)))) + '(30 50 23 12 4 1985 nil nil nil 0)))) (ert-deftest standard-test-interval () ;; A time interval starting at 20 minutes and 50 seconds past 23 ;; hours on 12 April 1985 and ending at 30 minutes past 10 hours on ;; 25 June 1985. (should (equal (iso8601-parse-interval "19850412T232050Z/19850625T103000Z") - '((50 20 23 12 4 1985 nil nil 0) - (0 30 10 25 6 1985 nil nil 0) - (10 9 11 15 3 1970 0 nil 0)))) + '((50 20 23 12 4 1985 nil nil 0 0) + (0 30 10 25 6 1985 nil nil 0 0) + (10 9 11 15 3 1970 0 nil 0 0)))) (should (equal (iso8601-parse-interval "1985-04-12T23:20:50Z/1985-06-25T10:30:00Z") - '((50 20 23 12 4 1985 nil nil 0) - (0 30 10 25 6 1985 nil nil 0) - (10 9 11 15 3 1970 0 nil 0)))) + '((50 20 23 12 4 1985 nil nil 0 0) + (0 30 10 25 6 1985 nil nil 0 0) + (10 9 11 15 3 1970 0 nil 0 0)))) ;; A time interval starting at 12 April 1985 and ending on 25 June ;; 1985. @@ -251,41 +251,41 @@ ;; A time interval of 2 years, 10 months, 15 days, 10 hours, 20 ;; minutes and 30 seconds. (should (equal (iso8601-parse-duration "P2Y10M15DT10H20M30S") - '(30 20 10 15 10 2 nil nil nil))) + '(30 20 10 15 10 2 nil nil nil 0))) (should (equal (iso8601-parse-duration "P00021015T102030") - '(30 20 10 15 10 2 nil nil nil))) + '(30 20 10 15 10 2 nil nil nil 0))) (should (equal (iso8601-parse-duration "P0002-10-15T10:20:30") - '(30 20 10 15 10 2 nil nil nil))) + '(30 20 10 15 10 2 nil nil nil 0))) ;; A time interval of 1 year and 6 months. (should (equal (iso8601-parse-duration "P1Y6M") - '(0 0 0 0 6 1 nil nil nil))) + '(0 0 0 0 6 1 nil nil nil 0))) (should (equal (iso8601-parse-duration "P0001-06") - '(nil nil nil nil 6 1 nil nil nil))) + '(nil nil nil nil 6 1 nil nil nil nil))) ;; A time interval of seventy-two hours. (should (equal (iso8601-parse-duration "PT72H") - '(0 0 72 0 0 0 nil nil nil))) + '(0 0 72 0 0 0 nil nil nil 0))) ;; Defined by start and duration ;; A time interval of 1 year, 2 months, 15 days and 12 hours, ;; beginning on 12 April 1985 at 20 minutes past 23 hours. (should (equal (iso8601-parse-interval "19850412T232000/P1Y2M15DT12H") - '((0 20 23 12 4 1985 nil nil nil) - (0 20 11 28 6 1986 nil nil nil) - (0 0 12 15 2 1 nil nil nil)))) + '((0 20 23 12 4 1985 nil nil nil 0) + (0 20 11 28 6 1986 nil nil nil 0) + (0 0 12 15 2 1 nil nil nil 0)))) (should (equal (iso8601-parse-interval "1985-04-12T23:20:00/P1Y2M15DT12H") - '((0 20 23 12 4 1985 nil nil nil) - (0 20 11 28 6 1986 nil nil nil) - (0 0 12 15 2 1 nil nil nil)))) + '((0 20 23 12 4 1985 nil nil nil 0) + (0 20 11 28 6 1986 nil nil nil 0) + (0 0 12 15 2 1 nil nil nil 0)))) ;; Defined by duration and end ;; A time interval of 1 year, 2 months, 15 days and 12 hours, ending ;; on 12 April 1985 at 20 minutes past 23 hour. (should (equal (iso8601-parse-interval "P1Y2M15DT12H/19850412T232000") - '((0 20 11 28 1 1984 nil nil nil) - (0 20 23 12 4 1985 nil nil nil) - (0 0 12 15 2 1 nil nil nil))))) + '((0 20 11 28 1 1984 nil nil nil 0) + (0 20 23 12 4 1985 nil nil nil 0) + (0 0 12 15 2 1 nil nil nil 0))))) ;;; iso8601-tests.el ends here diff --git a/test/lisp/calendar/parse-time-tests.el b/test/lisp/calendar/parse-time-tests.el index 7435620b71..61a3838a52 100644 --- a/test/lisp/calendar/parse-time-tests.el +++ b/test/lisp/calendar/parse-time-tests.el @@ -28,23 +28,23 @@ (ert-deftest parse-time-tests () (should (equal (parse-time-string "Mon, 22 Feb 2016 19:35:42 +0100") - '(42 35 19 22 2 2016 1 -1 3600))) + '(42 35 19 22 2 2016 1 -1 3600 0))) (should (equal (parse-time-string "22 Feb 2016 19:35:42 +0100") - '(42 35 19 22 2 2016 nil -1 3600))) + '(42 35 19 22 2 2016 nil -1 3600 0))) (should (equal (parse-time-string "22 Feb 2016 +0100") - '(nil nil nil 22 2 2016 nil -1 3600))) + '(nil nil nil 22 2 2016 nil -1 3600 nil))) (should (equal (parse-time-string "Mon, 22 Feb 16 19:35:42 +0100") - '(42 35 19 22 2 2016 1 -1 3600))) + '(42 35 19 22 2 2016 1 -1 3600 0))) (should (equal (parse-time-string "Mon, 22 February 2016 19:35:42 +0100") - '(42 35 19 22 2 2016 1 -1 3600))) + '(42 35 19 22 2 2016 1 -1 3600 0))) (should (equal (parse-time-string "Mon, 22 feb 2016 19:35:42 +0100") - '(42 35 19 22 2 2016 1 -1 3600))) + '(42 35 19 22 2 2016 1 -1 3600 0))) (should (equal (parse-time-string "Monday, 22 february 2016 19:35:42 +0100") - '(42 35 19 22 2 2016 1 -1 3600))) + '(42 35 19 22 2 2016 1 -1 3600 0))) (should (equal (parse-time-string "Monday, 22 february 2016 19:35:42 PST") - '(42 35 19 22 2 2016 1 nil -28800))) + '(42 35 19 22 2 2016 1 nil -28800 0))) (should (equal (parse-time-string "Friday, 21 Sep 2018 13:47:58 PDT") - '(58 47 13 21 9 2018 5 t -25200))) + '(58 47 13 21 9 2018 5 t -25200 0))) (should (equal (format-time-string "%Y-%m-%d %H:%M:%S" (parse-iso8601-time-string "1998-09-12T12:21:54-0200") t) diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el index fae058edf9..feb8fc7905 100644 --- a/test/src/timefns-tests.el +++ b/test/src/timefns-tests.el @@ -40,23 +40,25 @@ (7879679999900 . 100000) (78796799999999999999 . 1000000000000))) ;; UTC. + (let ((subsec (time-subtract (time-convert look t) + (time-convert look 'integer)))) (should (string-equal (format-time-string "%Y-%m-%d %H:%M:%S.%3N %z" look t) "1972-06-30 23:59:59.999 +0000")) (should (equal (decode-time look t) - '(59 59 23 30 6 1972 5 nil 0))) + (list 59 59 23 30 6 1972 5 nil 0 subsec))) ;; "UTC0". (should (string-equal (format-time-string format look "UTC0") "1972-06-30 23:59:59.999 +0000 (UTC)")) (should (equal (decode-time look "UTC0") - '(59 59 23 30 6 1972 5 nil 0))) + (list 59 59 23 30 6 1972 5 nil 0 subsec))) ;; Negative UTC offset, as a Lisp list. (should (string-equal (format-time-string format look '(-28800 "PST")) "1972-06-30 15:59:59.999 -0800 (PST)")) (should (equal (decode-time look '(-28800 "PST")) - '(59 59 15 30 6 1972 5 nil -28800))) + (list 59 59 15 30 6 1972 5 nil -28800 subsec))) ;; Negative UTC offset, as a Lisp integer. (should (string-equal (format-time-string format look -28800) @@ -66,13 +68,13 @@ "1972-06-30 15:59:59.999 -0800 (ZZZ)" "1972-06-30 15:59:59.999 -0800 (-08)"))) (should (equal (decode-time look -28800) - '(59 59 15 30 6 1972 5 nil -28800))) + (list 59 59 15 30 6 1972 5 nil -28800 subsec))) ;; Positive UTC offset that is not an hour multiple, as a string. (should (string-equal (format-time-string format look "IST-5:30") "1972-07-01 05:29:59.999 +0530 (IST)")) (should (equal (decode-time look "IST-5:30") - '(59 29 5 1 7 1972 6 nil 19800)))))) + (list 59 29 5 1 7 1972 6 nil 19800 subsec))))))) (ert-deftest decode-then-encode-time () (let ((time-values (list 0 -2 1 0.0 -0.0 -2.0 1.0 @@ -146,5 +148,5 @@ (ert-deftest encode-time-dst-numeric-zone () "Check for Bug#35502." (should (time-equal-p - (encode-time '(29 31 17 30 4 2019 2 t 7200)) + (encode-time '(29 31 17 30 4 2019 2 t 7200 0)) '(23752 27217)))) commit 89c63b3522b62c0fd725f0b348927a2069238452 Author: Paul Eggert Date: Mon Aug 5 17:38:52 2019 -0700 New function time-convert This replaces the awkward reuse of encode-time to both convert calendrical timestamps to Lisp timestamps, and to convert Lisp timestamps to other forms. Now, encode-time does just the former and the new function does just the latter. The new function builds on a suggestion by Lars Ingebrigtsen in: https://lists.gnu.org/r/emacs-devel/2019-07/msg00801.html and refined by Stefan Monnier in: https://lists.gnu.org/r/emacs-devel/2019-07/msg00803.html * doc/lispref/os.texi (Time of Day, Time Conversion): * doc/misc/emacs-mime.texi (time-date): * etc/NEWS: Update documentation. * lisp/calendar/cal-dst.el (calendar-next-time-zone-transition): * lisp/calendar/time-date.el (seconds-to-time, days-to-time): * lisp/calendar/timeclock.el (timeclock-seconds-to-time): * lisp/cedet/ede/detect.el (ede-detect-qtest): * lisp/completion.el (cmpl-hours-since-origin): * lisp/ecomplete.el (ecomplete-add-item): * lisp/emacs-lisp/cl-extra.el (cl--random-time): * lisp/emacs-lisp/timer.el (timer--time-setter) (timer-next-integral-multiple-of-time): * lisp/find-lisp.el (find-lisp-format-time): * lisp/gnus/gnus-diary.el (gnus-user-format-function-d): * lisp/gnus/gnus-group.el (gnus-group-set-timestamp): * lisp/gnus/gnus-icalendar.el (gnus-icalendar-show-org-agenda): * lisp/gnus/nnrss.el (nnrss-normalize-date): * lisp/gnus/nnspool.el (nnspool-request-newgroups): * lisp/net/ntlm.el (ntlm-compute-timestamp): * lisp/net/pop3.el (pop3-uidl-dele): * lisp/obsolete/vc-arch.el (vc-arch-add-tagline): * lisp/org/org-clock.el (org-clock-get-clocked-time) (org-clock-resolve, org-resolve-clocks, org-clock-in) (org-clock-out, org-clock-sum): * lisp/org/org-id.el (org-id-uuid, org-id-time-to-b36): * lisp/org/ox-publish.el (org-publish-cache-ctime-of-src): * lisp/proced.el (proced-format-time): * lisp/progmodes/cc-cmds.el (c-progress-init) (c-progress-update): * lisp/progmodes/cperl-mode.el (cperl-time-fontification): * lisp/progmodes/flymake.el (flymake--schedule-timer-maybe): * lisp/progmodes/vhdl-mode.el (vhdl-update-progress-info) (vhdl-fix-case-region-1): * lisp/tar-mode.el (tar-octal-time): * lisp/time.el (emacs-uptime): * lisp/url/url-auth.el (url-digest-auth-make-cnonce): * lisp/url/url-util.el (url-lazy-message): * lisp/vc/vc-cvs.el (vc-cvs-parse-entry): * lisp/vc/vc-hg.el (vc-hg-state-fast): * lisp/xt-mouse.el (xterm-mouse-event): * test/lisp/emacs-lisp/timer-tests.el: (timer-next-integral-multiple-of-time-2): Use time-convert, not encode-time. * lisp/calendar/icalendar.el (icalendar--decode-isodatetime): Don’t use now-removed FORM argument for encode-time. It wasn’t crucial anyway. * lisp/emacs-lisp/byte-opt.el (side-effect-free-fns): Add time-convert. * lisp/emacs-lisp/elint.el (elint-unknown-builtin-args): Update encode-time signature to match current arg set. * lisp/emacs-lisp/timer.el (timer-next-integral-multiple-of-time): Use timer-convert with t rather than doing it by hand. * src/timefns.c (time_hz_ticks, time_form_stamp, lisp_time_form_stamp): Remove; no longer needed. (decode_lisp_time): Rturn the form instead of having a *PFORM arg. All uses changed. (time_arith): Just return TICKS if HZ is 1. (Fencode_time): Remove argument FORM. All callers changed. Do not attempt to encode time values; just encode decoded (calendrical) times. Unless CURRENT_TIME_LIST, just return VALUE since HZ is 1. (Ftime_convert): New function, which does the time value conversion that bleeding-edge encode-time formerly did. Return TIME if it is easy to see that it is already of the correct form. (Fcurrent_time): Mention in doc that the form is planned to change. * test/src/timefns-tests.el (decode-then-encode-time): Don’t use (encode-time nil). diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index 1f844478f7..1ff62118cd 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -1536,10 +1536,8 @@ Operating System Interface * System Environment:: Distinguish the name and kind of system. * User Identification:: Finding the name and user id of the user. * Time of Day:: Getting the current time. -* Time Conversion:: Converting a time from numeric form to - calendrical data and vice versa. -* Time Parsing:: Converting a time from numeric form to text - and vice versa. +* Time Conversion:: Converting among timestamp forms. +* Time Parsing:: Converting timestamps to text and vice versa. * Processor Run Time:: Getting the run time used by Emacs. * Time Calculations:: Adding, subtracting, comparing times, etc. * Timers:: Setting a timer to call a function at a diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index 7bb9833467..b26d903707 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -20,10 +20,8 @@ terminal and the screen. * User Identification:: Finding the name and user id of the user. * Time of Day:: Getting the current time. * Time Zone Rules:: Rules for time zones and daylight saving time. -* Time Conversion:: Converting a time from numeric form to - calendrical data and vice versa. -* Time Parsing:: Converting a time from numeric form to text - and vice versa. +* Time Conversion:: Converting among timestamp forms. +* Time Parsing:: Converting timestamps to text and vice versa. * Processor Run Time:: Getting the run time used by Emacs. * Time Calculations:: Adding, subtracting, comparing times, etc. * Timers:: Setting a timer to call a function at a certain time. @@ -1253,7 +1251,7 @@ represent absolute time by counting seconds since the @dfn{epoch} of Although traditionally Lisp timestamps were integer pairs, their form has evolved and programs ordinarily should not depend on the current default form. If your program needs a particular timestamp -form, you can use the @code{encode-time} function to convert it to the +form, you can use the @code{time-convert} function to convert it to the needed form. @xref{Time Conversion}. @cindex epoch @@ -1304,7 +1302,7 @@ time, a single floating-point number for seconds, or a list @var{low})} that is a truncated list timestamp with missing elements taken to be zero. You can convert a time value into a human-readable string using @code{format-time-string}, into a Lisp -timestamp using @code{encode-time}, and into other forms using +timestamp using @code{time-convert}, and into other forms using @code{decode-time} and @code{float-time}. These functions are described in the following sections. @@ -1334,6 +1332,11 @@ defaults to the current time zone rule. @xref{Time Zone Rules}. @defun current-time This function returns the current time as a Lisp timestamp. +Although the timestamp takes the form @code{(@var{high} @var{low} +@var{micro} @var{pico})} in the current Emacs release, this is +planned to change in a future Emacs version. You can use the +@code{time-convert} function to convert a timestamp to some other +form. @xref{Time Conversion}. @end defun @defun float-time &optional time @@ -1411,8 +1414,8 @@ defaults to the current time zone rule. @cindex calendrical information @cindex time conversion - These functions convert time values (@pxref{Time of Day}) into -calendrical information and vice versa. + These functions convert time values (@pxref{Time of Day}) to Lisp +timestamps, or into calendrical information and vice versa. Many 32-bit operating systems are limited to system times containing 32 bits of information in their seconds component; these systems @@ -1421,12 +1424,60 @@ typically handle only the times from 1901-12-13 20:45:52 through systems have larger seconds components, and can represent times far in the past or future. - Time conversion functions always use the Gregorian calendar, even + Calendrical conversion functions always use the Gregorian calendar, even for dates before the Gregorian calendar was introduced. Year numbers count the number of years since the year 1 B.C., and do not skip zero as traditional Gregorian years do; for example, the year number @minus{}37 represents the Gregorian year 38 B.C@. +@defun time-convert time &optional form +This function converts a time value into a Lisp timestamp. +If the time cannot be represented exactly, it is truncated +toward minus infinity. + +The optional @var{form} argument specifies the timestamp form to be +returned. If @var{form} is the symbol @code{integer}, this function +returns an integer count of seconds. If @var{form} is a positive +integer, it specifies a clock frequency and this function returns an +integer-pair timestamp @code{(@var{ticks} +. @var{form})}.@footnote{Currently a positive integer @var{form} +should be at least 65536 if the returned value is intended to be given +to standard functions expecting Lisp timestamps.} If @var{form} is +@code{t}, this function treats it as a positive integer suitable for +representing the timestamp; for example, it is treated as 1000000000 +if @var{time} is nil and the platform timestamp has nanosecond +resolution. If @var{form} is @code{list}, this function returns an +integer list @code{(@var{high} @var{low} @var{micro} @var{pico})}. +Although an omitted or @code{nil} @var{form} currently acts like +@code{list}, this is planned to change in a future Emacs version, so +callers requiring list timestamps should pass @code{list} explicitly. + +If @var{time} already has the proper form, this function might yield +@var{time} rather than a copy. + +Although @code{(time-convert nil nil)} is equivalent to +@code{(current-time)}, the latter may be a bit faster. + +@example +@group +(setq a (time-convert nil t)) +@result{} (1564826753904873156 . 1000000000) +@end group +@group +(time-convert a 100000) +@result{} (156482675390487 . 100000) +@end group +@group +(time-convert a 'integer) +@result{} 1564826753 +@end group +@group +(time-convert a 'list) +@result{} (23877 23681 904873 156000) +@end group +@end example +@end defun + @defun decode-time &optional time zone This function converts a time value into calendrical information. If you don't specify @var{time}, it decodes the current time, and similarly @@ -1522,37 +1573,17 @@ that represents ``two months'', you could say: @end lisp @end defun -@defun encode-time &optional time form &rest obsolescent-arguments +@defun encode-time time &rest obsolescent-arguments This function converts @var{time} to a Lisp timestamp. It can act as the inverse of @code{decode-time}. -The first argument can be a time value such as a number of seconds, a -pair @code{(@var{ticks} . @var{hz})}, a list @code{(@var{high} -@var{low} @var{micro} @var{pico})}, or @code{nil} (the default) for -the current time (@pxref{Time of Day}). It can also be a list +Ordinarily the first argument is a list @code{(@var{second} @var{minute} @var{hour} @var{day} @var{month} @var{year} @var{ignored} @var{dst} @var{zone})} that specifies a decoded time in the style of @code{decode-time}, so that @code{(encode-time (decode-time ...))} works. For the meanings of these list members, see the table under @code{decode-time}. -The optional @var{form} argument specifies the desired timestamp form -to be returned. If @var{form} is the symbol @code{integer}, this -function returns an integer count of seconds. If @var{form} is a -positive integer, it specifies a clock frequency and this function -returns an integer-pair timestamp @code{(@var{ticks} -. @var{form})}.@footnote{Currently a positive integer @var{form} -should be at least 65536 if the returned value is intended to be given -to standard functions expecting Lisp timestamps.} If @var{form} is -@code{t}, this function treats it as a positive integer suitable for -representing the timestamp; for example, it is treated as 1000000000 -if the platform timestamp has nanosecond resolution. If @var{form} is -@code{list}, this function returns an integer list @code{(@var{high} -@var{low} @var{micro} @var{pico})}. Although an omitted or @code{nil} -@var{form} currently acts like @code{list}, this is planned to change -in a future Emacs version, so callers requiring list timestamps should -pass @code{list} explicitly. - As an obsolescent calling convention, this function can be given six or more arguments. The first six arguments @var{second}, @var{minute}, @var{hour}, @var{day}, @var{month}, and @var{year} diff --git a/doc/misc/emacs-mime.texi b/doc/misc/emacs-mime.texi index 1f384f4f27..eb829b0612 100644 --- a/doc/misc/emacs-mime.texi +++ b/doc/misc/emacs-mime.texi @@ -1537,24 +1537,25 @@ Here's a bunch of time/date/second/day examples: (parse-time-string "Sat Sep 12 12:21:54 1998 +0200") @result{} (54 21 12 12 9 1998 6 -1 7200) -(encode-time (date-to-time "Sat Sep 12 12:21:54 1998 +0200") - 1000000) -@result{} (905595714000000 . 1000000) +(time-convert + (date-to-time "Sat Sep 12 12:21:54 1998 +0200") + 'integer) +@result{} 905595714 (float-time '(905595714000000 . 1000000)) @result{} 905595714.0 -(encode-time 905595714.0 1000000) +(time-convert 905595714.0 1000000) @result{} (905595714000000 . 1000000) (time-to-days '(905595714000000 . 1000000)) @result{} 729644 -(encode-time (days-to-time 729644) 1000000) -@result{} (63041241600000000 . 1000000) +(time-convert (days-to-time 729644) 'integer) +@result{} 63041241600 -(encode-time (time-since '(905595714000000 . 1000000)) - 1000000) +(time-convert (time-since '(905595714000000 . 1000000)) + 1000000) @result{} (631963244775642171 . 1000000000) (time-less-p '(905595714000000 . 1000000) @@ -1622,12 +1623,14 @@ These are the functions available: @item date-to-time Take a date and return a time. +@item time-convert +Take a time and return a timestamp in a specified form. + @item float-time Take a time and return seconds. @item encode-time -Take seconds (and other ways to represent time, notably decoded time -lists), and return a time. +Take a decoded time and return a timestamp. @item time-to-days Take a time and return days. diff --git a/etc/NEWS b/etc/NEWS index 7b8916edd6..116bdb961c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2077,21 +2077,24 @@ functions like 'process-id' that compute process IDs, and functions like ** Time values ++++ +*** New function time 'time-convert' converts Lisp time values +to Lisp timestamps of various forms, including a new timestamp form +(TICKS . HZ) where TICKS is an integer and HZ a positive integer +denoting a clock frequency. + +++ *** Although the default timestamp format is still '(HI LO US PS)', it is planned to change in a future Emacs version, to exploit bignums. The documentation has been updated to mention that the timestamp format may change and that programs should use functions like -'format-time-string', 'decode-time', and 'encode-time' rather than +'format-time-string', 'decode-time', and 'time-convert' rather than probing the innards of a timestamp directly, or creating a timestamp by hand. +++ -*** 'encode-time' supports a new API '(encode-time TIME &optional FORM)'. -This can convert decoded times and Lisp time values to Lisp timestamps -of various forms, including a new timestamp form '(TICKS . HZ)', where -TICKS is an integer and HZ is a positive integer denoting a clock -frequency. The old 'encode-time' API is still supported. +*** 'encode-time' supports a new API '(encode-time TIME)'. +The old 'encode-time' API is still supported. +++ *** A new package to parse ISO 8601 time, date, durations and diff --git a/lisp/calendar/cal-dst.el b/lisp/calendar/cal-dst.el index 510cd6808e..2d3b1f8c81 100644 --- a/lisp/calendar/cal-dst.el +++ b/lisp/calendar/cal-dst.el @@ -127,7 +127,7 @@ after midnight UTC on absolute date ABS-DATE." "Return the time of the next time zone transition after TIME. Both TIME and the result are acceptable arguments to `current-time-zone'. Return nil if no such transition can be found." - (let* ((time (encode-time time 'integer)) + (let* ((time (time-convert time 'integer)) (time-zone (current-time-zone time)) (time-utc-diff (car time-zone)) hi diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index cf3315b45d..c2688705e3 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -646,7 +646,7 @@ FIXME: multiple comma-separated values should be allowed!" (let ((decoded-time (list second minute hour day month year nil -1 zone))) (condition-case nil - (decode-time (encode-time decoded-time 'integer)) + (decode-time (encode-time decoded-time)) (error (message "Cannot decode \"%s\"" isodatetimestring) ;; Hope for the best.... diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index c0565b3cfb..7505332011 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -171,14 +171,14 @@ If DATE lacks timezone information, GMT is assumed." (defalias 'time-to-seconds 'float-time) ;;;###autoload -(defalias 'seconds-to-time 'encode-time) +(defalias 'seconds-to-time 'time-convert) ;;;###autoload (defun days-to-time (days) "Convert DAYS into a time value." - (let ((time (encode-time (* 86400 days)))) + (let ((time (time-convert (* 86400 days)))) ;; Traditionally, this returned a two-element list if DAYS was an integer. - ;; Keep that tradition if encode-time outputs timestamps in list form. + ;; Keep that tradition if time-convert outputs timestamps in list form. (if (and (integerp days) (consp (cdr time))) (setcdr (cdr time) nil)) time)) diff --git a/lisp/calendar/timeclock.el b/lisp/calendar/timeclock.el index 60586e7ace..ee7cf17b04 100644 --- a/lisp/calendar/timeclock.el +++ b/lisp/calendar/timeclock.el @@ -515,7 +515,7 @@ non-nil, the amount returned will be relative to past time worked." string))) (define-obsolete-function-alias 'timeclock-time-to-seconds 'float-time "26.1") -(define-obsolete-function-alias 'timeclock-seconds-to-time 'encode-time "26.1") +(define-obsolete-function-alias 'timeclock-seconds-to-time 'time-convert "26.1") ;; Should today-only be removed in favor of timeclock-relative? - gm (defsubst timeclock-when-to-leave (&optional today-only) diff --git a/lisp/cedet/ede/detect.el b/lisp/cedet/ede/detect.el index d65abce4b3..f65481b0c8 100644 --- a/lisp/cedet/ede/detect.el +++ b/lisp/cedet/ede/detect.el @@ -200,7 +200,7 @@ Return a cons cell: (ans (ede-detect-directory-for-project default-directory))) (if ans (message "Project found in %d sec @ %s of type %s" - (encode-time (time-since start) 'integer) + (time-convert (time-since start) 'integer) (car ans) (eieio-object-name-string (cdr ans))) (message "No Project found.") ))) diff --git a/lisp/completion.el b/lisp/completion.el index b9c3a21f5e..77761d695b 100644 --- a/lisp/completion.el +++ b/lisp/completion.el @@ -432,7 +432,7 @@ Used to decide whether to save completions.") (defun cmpl-hours-since-origin () - (floor (encode-time nil 'integer) 3600)) + (floor (time-convert nil 'integer) 3600)) ;;--------------------------------------------------------------------------- ;; "Symbol" parsing functions diff --git a/lisp/ecomplete.el b/lisp/ecomplete.el index d9f34ef0c0..1cacd47350 100644 --- a/lisp/ecomplete.el +++ b/lisp/ecomplete.el @@ -96,7 +96,7 @@ string that was matched." (defun ecomplete-add-item (type key text) "Add item TEXT of TYPE to the database, using KEY as the identifier." (let ((elems (assq type ecomplete-database)) - (now (encode-time nil 'integer)) + (now (time-convert nil 'integer)) entry) (unless elems (push (setq elems (list type)) ecomplete-database)) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index ecaa845fd3..22fea1b8da 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1234,7 +1234,7 @@ symbol-function symbol-name symbol-plist symbol-value string-make-unibyte string-make-multibyte string-as-multibyte string-as-unibyte string-to-multibyte - tan truncate + tan time-convert truncate unibyte-char-to-multibyte upcase user-full-name user-login-name user-original-login-name custom-variable-p vconcat diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index ca33c56a95..4dc2e9de58 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -437,7 +437,7 @@ as an integer unless JUNK-ALLOWED is non-nil." ;; Random numbers. (defun cl--random-time () - (car (encode-time nil t))) + (car (time-convert nil t))) ;;;###autoload (autoload 'cl-random-state-p "cl-extra") (cl-defstruct (cl--random-state diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index 6927921bda..b7ef6eeb2a 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -141,7 +141,7 @@ Set by `elint-initialize', if `elint-scan-preloaded' is non-nil.") (defconst elint-unknown-builtin-args ;; encode-time allows extra arguments for use with decode-time. ;; For some reason, some people seem to like to use them in other cases. - '((encode-time second minute hour day month year &rest zone)) + '((encode-time time &rest obsolescent-arguments)) "Those built-ins for which we can't find arguments, if any.") (defvar elint-extra-errors '(file-locked file-supersession ftp-error) diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 400f00a85b..561cc70078 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -57,7 +57,7 @@ (defun timer--time-setter (timer time) (timer--check timer) - (let ((lt (encode-time time 'list))) + (let ((lt (time-convert time 'list))) (setf (timer--high-seconds timer) (nth 0 lt)) (setf (timer--low-seconds timer) (nth 1 lt)) (setf (timer--usecs timer) (nth 2 lt)) @@ -96,10 +96,7 @@ fire each time Emacs is idle for that many seconds." "Yield the next value after TIME that is an integral multiple of SECS. More precisely, the next value, after TIME, that is an integral multiple of SECS seconds since the epoch. SECS may be a fraction." - (let* ((ticks-hz (if (and (consp time) (integerp (car time)) - (integerp (cdr time)) (< 0 (cdr time))) - time - (encode-time time 1000000000000))) + (let* ((ticks-hz (time-convert time t)) (ticks (car ticks-hz)) (hz (cdr ticks-hz)) trunc-s-ticks) @@ -109,7 +106,7 @@ of SECS seconds since the epoch. SECS may be a fraction." (setq ticks (ash ticks 1)) (setq hz (ash hz 1))) (let ((more-ticks (+ ticks trunc-s-ticks))) - (encode-time (cons (- more-ticks (% more-ticks trunc-s-ticks)) hz))))) + (time-convert (cons (- more-ticks (% more-ticks trunc-s-ticks)) hz))))) (defun timer-relative-time (time secs &optional usecs psecs) "Advance TIME by SECS seconds and optionally USECS microseconds diff --git a/lisp/find-lisp.el b/lisp/find-lisp.el index 073e2bc573..5a10ec3b47 100644 --- a/lisp/find-lisp.el +++ b/lisp/find-lisp.el @@ -342,7 +342,7 @@ list of ls option letters of which c and u are recognized). Use the same method as \"ls\" to decide whether to show time-of-day or year, depending on distance between file date and NOW." (let* ((time (nth (find-lisp-time-index switches) file-attr)) - (diff (encode-time (time-subtract time now) 'integer)) + (diff (time-convert (time-subtract time now) 'integer)) (past-cutoff -15778476) ; 1/2 of a Gregorian year (future-cutoff (* 60 60))) ; 1 hour (format-time-string diff --git a/lisp/gnus/gnus-diary.el b/lisp/gnus/gnus-diary.el index 0e78f2b899..16973074be 100644 --- a/lisp/gnus/gnus-diary.el +++ b/lisp/gnus/gnus-diary.el @@ -161,7 +161,7 @@ There are currently two built-in format functions: (now (current-time)) (occur (nndiary-next-occurrence sched now)) (real-time (time-subtract occur now))) - (let* ((sec (encode-time real-time 'integer)) + (let* ((sec (time-convert real-time 'integer)) (past (< sec 0)) delay) (and past (setq sec (- sec))) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 7e0ceec17b..b40379c4f5 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -4533,7 +4533,7 @@ and the second element is the address." This function can be used in hooks like `gnus-select-group-hook' or `gnus-group-catchup-group-hook'." (when gnus-newsgroup-name - (let ((time (encode-time nil 'integer))) + (let ((time (time-convert nil 'integer))) (gnus-group-set-parameter gnus-newsgroup-name 'timestamp time)))) (defsubst gnus-group-timestamp (group) diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index 529cafe23e..7d11b5699b 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -650,7 +650,7 @@ is searched." (defun gnus-icalendar-show-org-agenda (event) (let* ((time-delta (time-subtract (gnus-icalendar-event:end-time event) (gnus-icalendar-event:start-time event))) - (duration-days (1+ (floor (encode-time time-delta 'integer) 86400)))) + (duration-days (1+ (floor (time-convert time-delta 'integer) 86400)))) (org-agenda-list nil (gnus-icalendar-event:start event) duration-days))) (cl-defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-request) reply-status) diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index 958745d579..955432764e 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -455,7 +455,7 @@ which RSS 2.0 allows." (cond ((null date)) ; do nothing for this case ;; if the date is just digits (unix time stamp): ((string-match "^[0-9]+$" date) - (setq given (encode-time (string-to-number date)))) + (setq given (time-convert (string-to-number date)))) ;; RFC 822 ((string-match " [0-9]+ " date) (setq vector (timezone-parse-date date) diff --git a/lisp/gnus/nnspool.el b/lisp/gnus/nnspool.el index 767631c685..31ed3e97ef 100644 --- a/lisp/gnus/nnspool.el +++ b/lisp/gnus/nnspool.el @@ -305,7 +305,7 @@ there.") (while (and (not (looking-at "\\([^ ]+\\) +\\([0-9]+\\)[0-9][0-9][0-9] ")) (zerop (forward-line -1)))) - (let ((seconds (encode-time (date-to-time date) 'integer)) + (let ((seconds (time-convert (date-to-time date) 'integer)) groups) ;; Go through lines and add the latest groups to a list. (while (and (looking-at "\\([^ ]+\\) +[0-9]+ ") diff --git a/lisp/net/ntlm.el b/lisp/net/ntlm.el index 88c561910c..aae7700620 100644 --- a/lisp/net/ntlm.el +++ b/lisp/net/ntlm.el @@ -151,7 +151,7 @@ signed integer." ;; tenths of microseconds between ;; 1601-01-01 and 1970-01-01 "116444736000000000)") - 'rawnum (encode-time nil 'list))) + 'rawnum (time-convert nil 'list))) result-bytes) (dotimes (_byte 8) (push (calc-eval "and($1,16#FF)" 'rawnum tenths-of-us-since-jan-1-1601) diff --git a/lisp/net/pop3.el b/lisp/net/pop3.el index 4bf50c0d22..5f1cd94eb6 100644 --- a/lisp/net/pop3.el +++ b/lisp/net/pop3.el @@ -379,7 +379,7 @@ Use streaming commands." (defun pop3-uidl-dele (process) "Delete messages according to `pop3-leave-mail-on-server'. Return non-nil if it is necessary to update the local UIDL file." - (let* ((ctime (encode-time nil 'list)) + (let* ((ctime (time-convert nil 'list)) (age-limit (and (numberp pop3-leave-mail-on-server) (* 86400 pop3-leave-mail-on-server))) (srvr (assoc pop3-mailhost pop3-uidl-saved)) diff --git a/lisp/obsolete/vc-arch.el b/lisp/obsolete/vc-arch.el index 925289102c..1d41052037 100644 --- a/lisp/obsolete/vc-arch.el +++ b/lisp/obsolete/vc-arch.el @@ -133,7 +133,7 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches." (file-error (insert (format "%s <%s> %s" (current-time-string) user-mail-address - (+ (% (car (encode-time nil 1000000)) + (+ (% (car (time-convert nil 1000000)) 1000000) (buffer-size))))))) (comment-region beg (point)))) diff --git a/lisp/org/org-clock.el b/lisp/org/org-clock.el index 62c7cd92d1..4667890b42 100644 --- a/lisp/org/org-clock.el +++ b/lisp/org/org-clock.el @@ -723,7 +723,7 @@ menu\nmouse-2 will jump to task")) The time returned includes the time spent on this task in previous clocking intervals." (let ((currently-clocked-time - (floor (encode-time (time-since org-clock-start-time) 'integer) + (floor (time-convert (time-since org-clock-start-time) 'integer) 60))) (+ currently-clocked-time (or org-clock-total-time 0)))) @@ -1033,7 +1033,7 @@ to be CLOCKED OUT.")))) nil 45))) (and (not (memq char-pressed '(?i ?q))) char-pressed))))) (default - (floor (encode-time (time-since last-valid) 'integer) + (floor (time-convert (time-since last-valid) 'integer) 60)) (keep (and (memq ch '(?k ?K)) @@ -1102,8 +1102,8 @@ If `only-dangling-p' is non-nil, only ask to resolve dangling (lambda (clock) (format "Dangling clock started %d mins ago" - (floor (encode-time (time-since (cdr clock)) - 'integer) + (floor (time-convert (time-since (cdr clock)) + 'integer) 60))))) (or last-valid (cdr clock))))))))))) @@ -1321,7 +1321,7 @@ the default behavior." (y-or-n-p (format "You stopped another clock %d mins ago; start this one from then? " - (/ (encode-time + (/ (time-convert (time-subtract (org-current-time org-clock-rounding-minutes t) leftover) @@ -1576,10 +1576,10 @@ to, overriding the existing value of `org-clock-out-switch-to-state'." (delete-region (point) (point-at-eol)) (insert "--") (setq te (org-insert-time-stamp (or at-time now) 'with-hm 'inactive)) - (setq s (encode-time (time-subtract - (org-time-string-to-time te) - (org-time-string-to-time ts)) - 'integer) + (setq s (time-convert (time-subtract + (org-time-string-to-time te) + (org-time-string-to-time ts)) + 'integer) h (floor s 3600) m (floor (mod s 3600) 60)) (insert " => " (format "%2d:%02d" h m)) @@ -1833,7 +1833,7 @@ PROPNAME lets you set a custom text property instead of :org-clock-minutes." tend (>= (float-time org-clock-start-time) tstart) (<= (float-time org-clock-start-time) tend)) - (let ((time (floor (encode-time + (let ((time (floor (time-convert (time-since org-clock-start-time) 'integer) 60))) diff --git a/lisp/org/org-id.el b/lisp/org/org-id.el index fe439a7b89..34084bfa10 100644 --- a/lisp/org/org-id.el +++ b/lisp/org/org-id.el @@ -356,7 +356,7 @@ So a typical ID could look like \"Org:4nd91V40HI\"." "Return string with random (version 4) UUID." (let ((rnd (md5 (format "%s%s%s%s%s%s%s" (random) - (encode-time nil 'list) + (time-convert nil 'list) (user-uid) (emacs-pid) (user-full-name) @@ -418,7 +418,7 @@ using `org-id-decode'." ;; FIXME: If TIME represents N seconds after the epoch, then ;; this encoding assumes 0 <= N < 110075314176 = (* (expt 36 4) 65536), ;; i.e., that TIME is from 1970-01-01 00:00:00 to 5458-02-23 20:09:36 UTC. - (setq time (encode-time time 'list)) + (setq time (time-convert time 'list)) (concat (org-id-int-to-b36 (nth 0 time) 4) (org-id-int-to-b36 (nth 1 time) 4) (org-id-int-to-b36 (nth 2 time) 4))) diff --git a/lisp/org/ox-publish.el b/lisp/org/ox-publish.el index 9126647e7c..237b2ff816 100644 --- a/lisp/org/ox-publish.el +++ b/lisp/org/ox-publish.el @@ -1348,7 +1348,7 @@ does not exist." (expand-file-name (or (file-symlink-p file) file) (file-name-directory file))))) (if (not attr) (error "No such file: \"%s\"" file) - (encode-time (file-attribute-modification-time attr) 'integer)))) + (time-convert (file-attribute-modification-time attr) 'integer)))) (provide 'ox-publish) diff --git a/lisp/proced.el b/lisp/proced.el index 5f35fa34a0..db8bdb5ac8 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -1348,7 +1348,7 @@ Prefix ARG controls sort order, see `proced-sort-interactive'." (defun proced-format-time (time) "Format time interval TIME." - (let* ((ftime (encode-time time 'integer)) + (let* ((ftime (time-convert time 'integer)) (days (truncate ftime 86400)) (ftime (mod ftime 86400)) (hours (truncate ftime 3600)) diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el index 2ccdc1d0bc..acf4c4ad15 100644 --- a/lisp/progmodes/cc-cmds.el +++ b/lisp/progmodes/cc-cmds.el @@ -3611,7 +3611,7 @@ Otherwise reindent just the current line." (save-excursion (goto-char end) (point-marker)) - (encode-time nil 'integer) + (time-convert nil 'integer) context)) (message "Indenting region...")) )) @@ -3619,7 +3619,7 @@ Otherwise reindent just the current line." (defun c-progress-update () (if (not (and c-progress-info c-progress-interval)) nil - (let ((now (encode-time nil 'integer)) + (let ((now (time-convert nil 'integer)) (start (aref c-progress-info 0)) (end (aref c-progress-info 1)) (lastsecs (aref c-progress-info 2))) diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index d5c404c7d2..8e94da082a 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -8600,7 +8600,7 @@ start with default arguments, then refine the slowdown regions." (or l (setq l 1)) (or step (setq step 500)) (or lim (setq lim 40)) - (let* ((timems (function (lambda () (car (encode-time nil 1000))))) + (let* ((timems (function (lambda () (car (time-convert nil 1000))))) (tt (funcall timems)) (c 0) delta tot) (goto-char (point-min)) (forward-line (1- l)) diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index e8a4334fe9..6d47c8bb17 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -1022,7 +1022,7 @@ Do it only if `flymake-no-changes-timeout' is non-nil." (setq flymake-timer (run-with-idle-timer - ;; This can use encode-time instead of seconds-to-time, + ;; This can use time-convert instead of seconds-to-time, ;; once we can assume Emacs 27 or later. (seconds-to-time flymake-no-changes-timeout) nil diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index 9eedbf9cbc..2c947f3b05 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -7403,7 +7403,7 @@ only-lines." 100 (floor (* 100.0 (- pos (aref vhdl-progress-info 0))) delta)))) - (aset vhdl-progress-info 2 (encode-time nil 'integer)))) + (aset vhdl-progress-info 2 (time-convert nil 'integer)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Indentation commands @@ -8149,7 +8149,7 @@ depending on parameter UPPER-CASE." (message "Fixing case... (%2d%s)" (+ (* count 20) (/ (* 20 (- (point) beg)) (- end beg))) "%") - (setq last-update (encode-time nil 'integer)))) + (setq last-update (time-convert nil 'integer)))) (goto-char end))))) (defun vhdl-fix-case-region (beg end &optional arg) diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el index cf77781766..713f3d944b 100644 --- a/lisp/tar-mode.el +++ b/lisp/tar-mode.el @@ -1271,7 +1271,7 @@ for this to be permanent." (defun tar-octal-time (timeval) ;; Format a timestamp as 11 octal digits. - (format "%011o" (encode-time timeval 'integer))) + (format "%011o" (time-convert timeval 'integer))) (defun tar-subfile-save-buffer () "In tar subfile mode, save this buffer into its parent tar-file buffer. diff --git a/lisp/time.el b/lisp/time.el index 35157c5e80..95e095af5d 100644 --- a/lisp/time.el +++ b/lisp/time.el @@ -572,7 +572,7 @@ For example, the Unix uptime command format is \"%D, %z%2h:%.2m\"." (interactive) (let ((str (format-seconds (or format "%Y, %D, %H, %M, %z%S") - (encode-time + (time-convert (time-since before-init-time) 'integer)))) (if (called-interactively-p 'interactive) diff --git a/lisp/url/url-auth.el b/lisp/url/url-auth.el index b78544e3f3..b9643c279f 100644 --- a/lisp/url/url-auth.el +++ b/lisp/url/url-auth.el @@ -193,7 +193,7 @@ key cache `url-digest-auth-storage'." (defun url-digest-auth-make-cnonce () "Compute a new unique client nonce value." (base64-encode-string - (format "%016x%016x" (random) (car (encode-time nil t))) + (format "%016x%016x" (random) (car (time-convert nil t))) t)) (defun url-digest-auth-nonce-count (_nonce) diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el index a46e7bb385..0b3c283926 100644 --- a/lisp/url/url-util.el +++ b/lisp/url/url-util.el @@ -181,7 +181,7 @@ Will not do anything if `url-show-status' is nil." (null url-show-status) (active-minibuffer-window) (= url-lazy-message-time - (setq url-lazy-message-time (encode-time nil 'integer)))) + (setq url-lazy-message-time (time-convert nil 'integer)))) nil (apply 'message args))) diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el index b33a106f3a..d84700fc17 100644 --- a/lisp/vc/vc-cvs.el +++ b/lisp/vc/vc-cvs.el @@ -1183,8 +1183,8 @@ is non-nil." (decoded-time-second parsed-time) ;; Compare just the seconds part of the file time, ;; since CVS file time stamp resolution is just 1 second. - (= (encode-time mtime 'integer) - (encode-time parsed-time 'integer))) + (= (time-convert mtime 'integer) + (time-convert (encode-time parsed-time) 'integer))) (vc-file-setprop file 'vc-checkout-time mtime) (if set-state (vc-file-setprop file 'vc-state 'up-to-date))) (t diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index 876d824cea..f287adf242 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -1043,7 +1043,7 @@ hg binary." (let ((vc-hg-size (nth 2 dirstate-entry)) (vc-hg-mtime (nth 3 dirstate-entry)) (fs-size (file-attribute-size stat)) - (fs-mtime (encode-time + (fs-mtime (time-convert (file-attribute-modification-time stat) 'integer))) (if (and (eql vc-hg-size fs-size) (eql vc-hg-mtime fs-mtime)) diff --git a/lisp/xt-mouse.el b/lisp/xt-mouse.el index 5ff718292d..b53174b7bd 100644 --- a/lisp/xt-mouse.el +++ b/lisp/xt-mouse.el @@ -245,8 +245,8 @@ which is the \"1006\" extension implemented in Xterm >= 277." ;; for default value of mouse-1-click-follows-link (450msec). (timestamp (if (not xt-mouse-epoch) (progn (setq xt-mouse-epoch (float-time)) 0) - (car (encode-time (time-since xt-mouse-epoch) - 1000)))) + (car (time-convert (time-since xt-mouse-epoch) + 1000)))) (w (window-at x y)) (ltrb (window-edges w)) (left (nth 0 ltrb)) diff --git a/src/timefns.c b/src/timefns.c index ee43014979..4310409ab7 100644 --- a/src/timefns.c +++ b/src/timefns.c @@ -459,24 +459,6 @@ timespec_ticks (struct timespec t) /* Convert T to a Lisp integer counting HZ ticks, taking the floor. Assume T is valid, but check HZ. */ static Lisp_Object -time_hz_ticks (time_t t, Lisp_Object hz) -{ - if (FIXNUMP (hz)) - { - if (XFIXNUM (hz) <= 0) - invalid_hz (hz); - intmax_t ticks; - if (FASTER_TIMEFNS && !INT_MULTIPLY_WRAPV (t, XFIXNUM (hz), &ticks)) - return make_int (ticks); - } - else if (! (BIGNUMP (hz) && 0 < mpz_sgn (XBIGNUM (hz)->value))) - invalid_hz (hz); - - mpz_set_time (mpz[0], t); - mpz_mul (mpz[0], mpz[0], *bignum_integer (&mpz[1], hz)); - return make_integer_mpz (); -} -static Lisp_Object lisp_time_hz_ticks (struct lisp_time t, Lisp_Object hz) { if (FASTER_TIMEFNS && EQ (t.hz, hz)) @@ -538,32 +520,6 @@ timespec_to_lisp (struct timespec t) return Fcons (timespec_ticks (t), timespec_hz); } -/* Convert T to a Lisp timestamp. FORM specifies the timestamp format. */ -static Lisp_Object -time_form_stamp (time_t t, Lisp_Object form) -{ - if (NILP (form)) - form = CURRENT_TIME_LIST ? Qlist : Qt; - if (EQ (form, Qlist)) - return list2 (hi_time (t), lo_time (t)); - if (EQ (form, Qt) || EQ (form, Qinteger)) - return INT_TO_INTEGER (t); - return Fcons (time_hz_ticks (t, form), form); -} -static Lisp_Object -lisp_time_form_stamp (struct lisp_time t, Lisp_Object form) -{ - if (NILP (form)) - form = CURRENT_TIME_LIST ? Qlist : Qt; - if (EQ (form, Qlist)) - return ticks_hz_list4 (t.ticks, t.hz); - if (EQ (form, Qinteger)) - return lisp_time_seconds (t); - if (EQ (form, Qt)) - form = t.hz; - return Fcons (lisp_time_hz_ticks (t, form), form); -} - /* From what should be a valid timestamp (TICKS . HZ), generate the corresponding time values. @@ -754,16 +710,14 @@ enum { DECODE_SECS_ONLY = WARN_OBSOLETE_TIMESTAMPS + 1 }; old-format SPECIFIED_TIME. If FLAGS & WARN_OBSOLETE_TIMESTAMPS, diagnose what could be obsolete (HIGH . LOW) timestamps. - If PFORM is not null, store into *PFORM the form of SPECIFIED-TIME. If RESULT is not null, store into *RESULT the converted time; otherwise, store into *DRESULT the number of seconds since the start of the POSIX Epoch. Unsuccessful calls may or may not store results. - Signal an error if unsuccessful. */ -static void + Return the form of SPECIFIED-TIME. Signal an error if unsuccessful. */ +static enum timeform decode_lisp_time (Lisp_Object specified_time, int flags, - enum timeform *pform, struct lisp_time *result, double *dresult) { Lisp_Object high = make_fixnum (0); @@ -819,12 +773,11 @@ decode_lisp_time (Lisp_Object specified_time, int flags, form = TIMEFORM_INVALID; } - if (pform) - *pform = form; int err = decode_time_components (form, high, low, usec, psec, result, dresult); if (err) time_error (err); + return form; } /* Convert Z to time_t, returning true if it fits. */ @@ -928,12 +881,16 @@ list4_to_timespec (Lisp_Object high, Lisp_Object low, /* Decode a Lisp list SPECIFIED_TIME that represents a time. If SPECIFIED_TIME is nil, use the current time. - Signal an error if SPECIFIED_TIME does not represent a time. */ + Signal an error if SPECIFIED_TIME does not represent a time. + If PFORM, store the time's form into *PFORM. */ static struct lisp_time lisp_time_struct (Lisp_Object specified_time, enum timeform *pform) { struct lisp_time t; - decode_lisp_time (specified_time, WARN_OBSOLETE_TIMESTAMPS, pform, &t, 0); + enum timeform form + = decode_lisp_time (specified_time, WARN_OBSOLETE_TIMESTAMPS, &t, 0); + if (pform) + *pform = form; return t; } @@ -958,7 +915,7 @@ lisp_seconds_argument (Lisp_Object specified_time) { int flags = WARN_OBSOLETE_TIMESTAMPS | DECODE_SECS_ONLY; struct lisp_time lt; - decode_lisp_time (specified_time, flags, 0, <, 0); + decode_lisp_time (specified_time, flags, <, 0); struct timespec t = lisp_to_timespec (lt); if (! timespec_valid_p (t)) time_overflow (); @@ -1054,9 +1011,12 @@ time_arith (Lisp_Object a, Lisp_Object b, bool subtract) ticks = make_integer_mpz (); } - /* Return the (TICKS . HZ) form if either argument is that way, + /* Return an integer if the timestamp resolution is 1, + otherwise the (TICKS . HZ) form if either argument is that way, otherwise the (HI LO US PS) form for backward compatibility. */ - return (aform == TIMEFORM_TICKS_HZ || bform == TIMEFORM_TICKS_HZ + return (EQ (hz, make_fixnum (1)) + ? ticks + : aform == TIMEFORM_TICKS_HZ || bform == TIMEFORM_TICKS_HZ ? Fcons (ticks, hz) : ticks_hz_list4 (ticks, hz)); } @@ -1147,7 +1107,7 @@ or (if you need time as a string) `format-time-string'. */) (Lisp_Object specified_time) { double t; - decode_lisp_time (specified_time, 0, 0, 0, &t); + decode_lisp_time (specified_time, 0, 0, &t); return make_float (t); } @@ -1436,49 +1396,27 @@ check_tm_member (Lisp_Object obj, int offset) } DEFUN ("encode-time", Fencode_time, Sencode_time, 1, MANY, 0, - doc: /* Convert optional TIME to a timestamp. -Optional FORM specifies how the returned value should be encoded. -This can act as the reverse operation of `decode-time', which see. + doc: /* Convert TIME to a timestamp. -If TIME is a list (SECOND MINUTE HOUR DAY MONTH YEAR IGNORED DST ZONE) -it is a decoded time in the style of `decode-time', so that (encode-time -(decode-time ...)) works. TIME can also be a time value. -See `format-time-string' for the various forms of a time value. -For example, an omitted TIME stands for the current time. - -If FORM is a positive integer, the time is returned as a pair of -integers (TICKS . FORM), where TICKS is the number of clock ticks and FORM -is the clock frequency in ticks per second. (Currently the positive -integer should be at least 65536 if the returned value is expected to -be given to standard functions expecting Lisp timestamps.) If FORM is -t, the time is returned as (TICKS . PHZ), where PHZ is a platform dependent -clock frequency in ticks per second. If FORM is `integer', the time is -returned as an integer count of seconds. If FORM is `list', the time is -returned as an integer list (HIGH LOW USEC PSEC), where HIGH has the -most significant bits of the seconds, LOW has the least significant 16 -bits, and USEC and PSEC are the microsecond and picosecond counts. -Returned values are rounded toward minus infinity. Although an -omitted or nil FORM currently acts like `list', this is planned to -change, so callers requiring list timestamps should specify `list'. +TIME is a list (SECOND MINUTE HOUR DAY MONTH YEAR IGNORED DST ZONE). +in the style of `decode-time', so that (encode-time (decode-time ...)) works. +In this list, ZONE can be nil for Emacs local time, t for Universal +Time, `wall' for system wall clock time, or a string as in the TZ +environment variable. It can also be a list (as from +`current-time-zone') or an integer (as from `decode-time') applied +without consideration for daylight saving time. If ZONE specifies a +time zone with daylight-saving transitions, DST is t for daylight +saving time, nil for standard time, and -1 to cause the daylight +saving flag to be guessed. As an obsolescent calling convention, if this function is called with 6 or more arguments, the first 6 arguments are SECOND, MINUTE, HOUR, DAY, MONTH, and YEAR, and specify the components of a decoded time, where DST assumed to be -1 and FORM is omitted. If there are more than 6 arguments the *last* argument is used as ZONE and any other -extra arguments are ignored, so that (apply #\\='encode-time +extra arguments are ignored, so that (apply #'encode-time (decode-time ...)) works; otherwise ZONE is assumed to be nil. -If the input is a decoded time, ZONE is nil for Emacs local time, t -for Universal Time, `wall' for system wall clock time, or a string as -in the TZ environment variable. It can also be a list (as from -`current-time-zone') or an integer (as from `decode-time') applied -without consideration for daylight saving time. - -If the input is a decoded time and ZONE specifies a time zone with -daylight-saving transitions, DST is t for daylight saving time and nil -for standard time. If DST is -1, the daylight saving flag is guessed. - Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed; for example, a DAY of 0 means the day preceding the given month. Year numbers less than 100 are treated just like other year numbers. @@ -1487,26 +1425,19 @@ If you want them to stand for years in this century, you must do that yourself. Years before 1970 are not guaranteed to work. On some systems, year values as low as 1901 do work. -usage: (encode-time &optional TIME FORM &rest OBSOLESCENT-ARGUMENTS) */) +usage: (encode-time TIME &rest OBSOLESCENT-ARGUMENTS) */) (ptrdiff_t nargs, Lisp_Object *args) { struct tm tm; - Lisp_Object form = Qnil, zone = Qnil; + Lisp_Object zone = Qnil; Lisp_Object a = args[0]; tm.tm_isdst = -1; - if (nargs <= 2) + if (nargs == 1) { - if (nargs == 2) - form = args[1]; Lisp_Object tail = a; for (int i = 0; i < 9; i++, tail = XCDR (tail)) - if (! CONSP (tail)) - { - struct lisp_time t; - decode_lisp_time (a, 0, 0, &t, 0); - return lisp_time_form_stamp (t, form); - } + CHECK_CONS (tail); tm.tm_sec = check_tm_member (XCAR (a), 0); a = XCDR (a); tm.tm_min = check_tm_member (XCAR (a), 0); a = XCDR (a); tm.tm_hour = check_tm_member (XCAR (a), 0); a = XCDR (a); @@ -1543,7 +1474,43 @@ usage: (encode-time &optional TIME FORM &rest OBSOLESCENT-ARGUMENTS) */) if (tm.tm_wday < 0) time_error (mktime_errno); - return time_form_stamp (value, form); + return (CURRENT_TIME_LIST + ? list2 (hi_time (value), lo_time (value)) + : INT_TO_INTEGER (value)); +} + +DEFUN ("time-convert", Ftime_convert, Stime_convert, 1, 2, 0, + doc: /* Convert TIME value to a Lisp timestamp. +With optional FORM, convert to that timestamp form. +Truncate the returned value toward minus infinity. + +If FORM is nil (the default), return the the same form as `current-time'. +If FORM is a positive integer, return a pair of integers (TICKS . FORM), +where TICKS is the number of clock ticks and FORM is the clock frequency +in ticks per second. (Currently the positive integer should be at least +65536 if the returned value is expected to be given to standard functions +expecting Lisp timestamps.) If FORM is t, return (TICKS . PHZ), where +PHZ is a suitable clock frequency in ticks per second. If FORM is +`integer', return an integer count of seconds. If FORM is `list', +return an integer list (HIGH LOW USEC PSEC), where HIGH has the most +significant bits of the seconds, LOW has the least significant 16 +bits, and USEC and PSEC are the microsecond and picosecond counts. */) + (Lisp_Object time, Lisp_Object form) +{ + struct lisp_time t; + enum timeform input_form = decode_lisp_time (time, 0, &t, 0); + if (NILP (form)) + form = CURRENT_TIME_LIST ? Qlist : Qt; + if (EQ (form, Qlist)) + return ticks_hz_list4 (t.ticks, t.hz); + if (EQ (form, Qinteger)) + return FASTER_TIMEFNS && INTEGERP (time) ? time : lisp_time_seconds (t); + if (EQ (form, Qt)) + form = t.hz; + if (FASTER_TIMEFNS + && input_form == TIMEFORM_TICKS_HZ && EQ (form, XCDR (time))) + return time; + return Fcons (lisp_time_hz_ticks (t, form), form); } DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0, @@ -1551,9 +1518,12 @@ DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0, The time is returned as a list of integers (HIGH LOW USEC PSEC). HIGH has the most significant bits of the seconds, while LOW has the least significant 16 bits. USEC and PSEC are the microsecond and -picosecond counts. Use `encode-time' if you need a particular -timestamp form; for example, (encode-time nil \\='integer) returns the -current time in seconds. */) +picosecond counts. + +In a future Emacs version, the format of the returned timestamp is +planned to change. Use `time-convert' if you need a particular +timestamp form; for example, (time-convert nil \\='integer) returns +the current time in seconds. */) (void) { return make_lisp_time (current_timespec ()); @@ -1798,6 +1768,7 @@ syms_of_timefns (void) DEFSYM (Qencode_time, "encode-time"); defsubr (&Scurrent_time); + defsubr (&Stime_convert); defsubr (&Stime_add); defsubr (&Stime_subtract); defsubr (&Stime_less_p); diff --git a/test/lisp/emacs-lisp/timer-tests.el b/test/lisp/emacs-lisp/timer-tests.el index bd2dcbe554..676730ead2 100644 --- a/test/lisp/emacs-lisp/timer-tests.el +++ b/test/lisp/emacs-lisp/timer-tests.el @@ -49,14 +49,14 @@ (let* ((tc (current-time)) (delta-ticks 1000) (hz 128000) - (tce (encode-time tc hz)) + (tce (time-convert tc hz)) (tc+delta (time-add tce (cons delta-ticks hz))) - (tc+deltae (encode-time tc+delta hz)) + (tc+deltae (time-convert tc+delta hz)) (tc+delta-ticks (car tc+deltae)) (tc-nexte (cons (- tc+delta-ticks (% tc+delta-ticks delta-ticks)) hz)) (nt (timer-next-integral-multiple-of-time tc (/ (float delta-ticks) hz))) - (nte (encode-time nt hz))) + (nte (time-convert nt hz))) (should (equal tc-nexte nte)))) (ert-deftest timer-next-integral-multiple-of-time-3 () diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el index 2c90af757f..fae058edf9 100644 --- a/test/src/timefns-tests.el +++ b/test/src/timefns-tests.el @@ -86,7 +86,7 @@ (cons 1000000000000 (1+ most-positive-fixnum))))) (dolist (a time-values) (let* ((d (ignore-errors (decode-time a t))) - (e (encode-time d)) + (e (if d (encode-time d))) (diff (float-time (time-subtract a e)))) (should (or (not d) (and (<= 0 diff) (< diff 1)))))))) commit c6ba8100ea1db4616d3fe8485430b29143bc3d2e Author: Paul Eggert Date: Mon Aug 5 17:37:47 2019 -0700 Fix minor Org timestamp inefficiencies * lisp/org/org-id.el (org-id-time-to-b36): Remove unnecessary ‘or’. * lisp/org/org.el (org-parse-time-string): Remove unnecessary ‘encode-time’. diff --git a/lisp/org/org-id.el b/lisp/org/org-id.el index 8f9c132ad3..fe439a7b89 100644 --- a/lisp/org/org-id.el +++ b/lisp/org/org-id.el @@ -421,7 +421,7 @@ using `org-id-decode'." (setq time (encode-time time 'list)) (concat (org-id-int-to-b36 (nth 0 time) 4) (org-id-int-to-b36 (nth 1 time) 4) - (org-id-int-to-b36 (or (nth 2 time) 0) 4))) + (org-id-int-to-b36 (nth 2 time) 4))) (defun org-id-decode (id) "Split ID into the prefix and the time value that was used to create it. diff --git a/lisp/org/org.el b/lisp/org/org.el index 5aa49b29d6..cbf085a269 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -17785,7 +17785,7 @@ NODEFAULT, hour and minute fields will be nil if not given." ;; second argument. However, this requires at least Emacs ;; 25.1. We can do it when we switch to this version as our ;; minimal requirement. - (decode-time (encode-time (org-matcher-time s)))) + (decode-time (org-matcher-time s))) (t (error "Not a standard Org time string: %s" s)))) (defun org-timestamp-up (&optional arg) commit aa624a092db1e2c2e09345a08e3609095a9f9fc3 Author: Juri Linkov Date: Tue Aug 6 00:38:58 2019 +0300 * lisp/cus-start.el: Add :safe to display-fill-column-indicator (bug#36861) (display-fill-column-indicator) (display-fill-column-indicator-column) (display-fill-column-indicator-character): Add :safe predicates. diff --git a/lisp/cus-start.el b/lisp/cus-start.el index e1d0bce2ad..ddb9546ad1 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -616,52 +616,64 @@ since it could result in memory overflow and make Emacs crash." (const :tag "Grow only" :value grow-only)) "25.1") (display-raw-bytes-as-hex display boolean "26.1") - (display-line-numbers display-line-numbers - (choice - (const :tag "Off (nil)" :value nil) - (const :tag "Absolute line numbers" - :value t) - (const :tag "Relative line numbers" - :value relative) - (const :tag "Visually relative line numbers" - :value visual)) - "26.1") - (display-line-numbers-width display-line-numbers - (choice - (const :tag "Dynamically computed" - :value nil) - (integer :menu-tag "Fixed number of columns" - :value 2 - :format "%v")) - "26.1") - (display-line-numbers-current-absolute display-line-numbers - (choice - (const :tag "Display actual number of current line" - :value t) - (const :tag "Display zero as number of current line" - :value nil)) - "26.1") - (display-line-numbers-widen display-line-numbers - (choice - (const :tag "Disregard narrowing when calculating line numbers" - :value t) - (const :tag "Count lines from beginning of narrowed region" - :value nil)) - "26.1") + (display-line-numbers + display-line-numbers + (choice + (const :tag "Off (nil)" :value nil) + (const :tag "Absolute line numbers" + :value t) + (const :tag "Relative line numbers" + :value relative) + (const :tag "Visually relative line numbers" + :value visual)) + "26.1") + (display-line-numbers-width + display-line-numbers + (choice + (const :tag "Dynamically computed" + :value nil) + (integer :menu-tag "Fixed number of columns" + :value 2 + :format "%v")) + "26.1") + (display-line-numbers-current-absolute + display-line-numbers + (choice + (const :tag "Display actual number of current line" + :value t) + (const :tag "Display zero as number of current line" + :value nil)) + "26.1") + (display-line-numbers-widen + display-line-numbers + (choice + (const :tag "Disregard narrowing when calculating line numbers" + :value t) + (const :tag "Count lines from beginning of narrowed region" + :value nil)) + "26.1") - (display-fill-column-indicator display-fill-column-indicator - boolean "27.1") - (display-fill-column-indicator-column display-fill-column-indicator - (choice - (const :tag "Use fill-column variable" - :value t) - (const :tag "Fixed column number" - :value 70 - :format "%v") - integer) - "27.1") - (display-fill-column-indicator-character display-fill-column-indicator - character "27.1") + (display-fill-column-indicator + display-fill-column-indicator + boolean + "27.1" + :safe booleanp) + (display-fill-column-indicator-column + display-fill-column-indicator + (choice + (const :tag "Use fill-column variable" + :value t) + (const :tag "Fixed column number" + :value 70 + :format "%v") + integer) + "27.1" + :safe (lambda (value) (or (booleanp value) (integerp value)))) + (display-fill-column-indicator-character + display-fill-column-indicator + character + "27.1" + :safe characterp) ;; xfaces.c (scalable-fonts-allowed display boolean "22.1") ;; xfns.c commit 0c9075f0af275e4a44cda363d61313c2667c5e7d Author: Juri Linkov Date: Tue Aug 6 00:10:37 2019 +0300 * lisp/frameset.el (frameset--minibufferless-last-p): Fix pcase-let. This makes frameset sorting stable. (Bug#36894) diff --git a/lisp/frameset.el b/lisp/frameset.el index 73b2071a5a..a8b16706c2 100644 --- a/lisp/frameset.el +++ b/lisp/frameset.el @@ -1102,8 +1102,8 @@ Internal use only." "Predicate to sort frame states in an order suitable for creating frames. It sorts minibuffer-owning frames before minibufferless ones. Internal use only." - (pcase-let ((`(,hasmini1 ,id-def1) (assq 'frameset--mini (car state1))) - (`(,hasmini2 ,id-def2) (assq 'frameset--mini (car state2)))) + (pcase-let ((`(,hasmini1 . ,id-def1) (cdr (assq 'frameset--mini (car state1)))) + (`(,hasmini2 . ,id-def2) (cdr (assq 'frameset--mini (car state2))))) (cond ((eq id-def1 t) t) ((eq id-def2 t) nil) ((not (eq hasmini1 hasmini2)) (eq hasmini1 t)) commit bf276b792157023d2e469d6a32394cce9589e47e Author: Juri Linkov Date: Tue Aug 6 00:04:07 2019 +0300 * lisp/dired-x.el (dired-guess-shell-alist-default): Use git when possible. Check for Git backend and provide "git apply" for patch files (bug#36895). diff --git a/lisp/dired-x.el b/lisp/dired-x.el index 462fa4ee15..313a22725c 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -827,6 +827,7 @@ Also useful for `auto-mode-alist' like this: ;; install GNU zip's version of zcat. (autoload 'Man-support-local-filenames "man") +(autoload 'vc-responsible-backend "vc") (defvar dired-guess-shell-alist-default (list @@ -909,7 +910,10 @@ Also useful for `auto-mode-alist' like this: '(concat "znew" (if dired-guess-shell-gzip-quiet " -q") " " dired-guess-shell-znew-switches)) - '("\\.patch\\'" "cat * | patch") + (list "\\.patch\\'" + '(if (eq (ignore-errors (vc-responsible-backend default-directory)) 'Git) + "cat * | git apply" + "cat * | patch")) (list "\\.patch\\.g?z\\'" "gunzip -qc * | patch" ;; Optional decompression. '(concat "gunzip" (if dired-guess-shell-gzip-quiet " -q"))) commit f986269fe8e56210c0d1ca69fb5f4320e66e2736 Author: Juri Linkov Date: Mon Aug 5 23:56:36 2019 +0300 * lisp/dired.el (dired-special): Rename face from dired-socket (bug#24547). (dired-re-special): Rename from dired-re-socket. diff --git a/etc/NEWS b/etc/NEWS index 0c7e421ed9..7b8916edd6 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -658,7 +658,7 @@ remapped to these, respectively. command itself, not how many files are marked in total. --- -*** A new face, 'dired-socket', is used to highlight sockets, named +*** A new face, 'dired-special', is used to highlight sockets, named pipes, block devices and character devices. ** Find-Dired diff --git a/lisp/dired.el b/lisp/dired.el index c31176972f..854bc9f7d7 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -340,8 +340,8 @@ The directory name must be absolute, but need not be fully expanded.") ;; DOS/Windows-style drive letters in directory names, like in "d:/foo". (defvar dired-re-dir (concat dired-re-maybe-mark dired-re-inode-size "d[^:]")) (defvar dired-re-sym (concat dired-re-maybe-mark dired-re-inode-size "l[^:]")) -(defvar dired-re-socket (concat dired-re-maybe-mark dired-re-inode-size - "[bcsp][^:]")) +(defvar dired-re-special (concat dired-re-maybe-mark dired-re-inode-size + "[bcsp][^:]")) (defvar dired-re-exe;; match ls permission string of an executable file (mapconcat (lambda (x) (concat dired-re-maybe-mark dired-re-inode-size x)) @@ -447,7 +447,7 @@ Subexpression 2 must end right before the \\n.") (defvar dired-symlink-face 'dired-symlink "Face name used for symbolic links.") -(defface dired-socket +(defface dired-special '((t (:inherit font-lock-variable-name-face))) "Face used for sockets, pipes, block devices and char devices." :group 'dired-faces @@ -509,8 +509,8 @@ Subexpression 2 must end right before the \\n.") '(".+" (dired-move-to-filename) nil (0 dired-symlink-face))) ;; ;; Sockets, pipes, block devices, char devices. - (list dired-re-socket - '(".+" (dired-move-to-filename) nil (0 'dired-socket))) + (list dired-re-special + '(".+" (dired-move-to-filename) nil (0 'dired-special))) ;; ;; Files suffixed with `completion-ignored-extensions'. '(eval . commit 883438ef67cb483f5d986651110bbc0578683a82 Author: Juri Linkov Date: Mon Aug 5 23:37:32 2019 +0300 * lisp/isearch.el (isearch-define-mode-toggle): Ensure isearch-mode is active. Call 'isearch-mode' when it's nil. (Bug#36871) diff --git a/lisp/isearch.el b/lisp/isearch.el index 09729034d7..30f7fc7254 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -1971,6 +1971,7 @@ The command then executes BODY and updates the isearch prompt." ,(format "Toggle %s searching on or off.%s" mode (if docstring (concat "\n" docstring) "")) (interactive) + (unless isearch-mode (isearch-mode t)) ,@(when function `((setq isearch-regexp-function (unless (eq isearch-regexp-function #',function) commit 81b34c45c6e9a8e9ad344dc498a111273adc388e Author: Eli Zaretskii Date: Mon Aug 5 19:15:08 2019 +0300 Fix compilation with CHECK_STRUCTS * src/pdumper.c (dump_hash_table): Update hash of HASH_Lisp_Hash_Table. (Bug#36929) diff --git a/src/pdumper.c b/src/pdumper.c index 31f4f33adf..e0ddc1c808 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2696,7 +2696,7 @@ dump_hash_table (struct dump_context *ctx, Lisp_Object object, dump_off offset) { -#if CHECK_STRUCTS && !defined HASH_Lisp_Hash_Table_EF95ED06FF +#if CHECK_STRUCTS && !defined HASH_Lisp_Hash_Table_BB1ACF756E # error "Lisp_Hash_Table changed. See CHECK_STRUCTS comment in config.h." #endif const struct Lisp_Hash_Table *hash_in = XHASH_TABLE (object); commit 0bbcd89cf52c23e872b5b94d3e2f8f4161e2bf6e Author: Lars Ingebrigtsen Date: Mon Aug 5 15:49:28 2019 +0200 Revert "Make `view-lossage' output of chars read from `read-char' more logical" This reverts commit 1abf76877847226daa5ab7e07000ac1d4aba3478. This change apparently led to problems with kmacro. diff --git a/lisp/help.el b/lisp/help.el index ba76d26757..039d0c44e4 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -465,28 +465,18 @@ To record all your input, use `open-dribble-file'." (help-setup-xref (list #'view-lossage) (called-interactively-p 'interactive)) (with-help-window (help-buffer) - (with-current-buffer standard-output - (let ((prev-command nil)) - (mapc - (lambda (key) - (cond - ((and (consp key) (null (car key))) - (princ (format ";; %s\n" - (setq prev-command - (if (symbolp (cdr key)) - (cdr key) - "anonymous-command"))))) - ((eq key 'end-of-command) - (unless (bolp) - (princ (format ";; \n" (or prev-command - "unknown command"))))) - ((or (integerp key) (symbolp key) (listp key)) - (princ (single-key-description key)) - (princ " ")) - (t - (prin1 key) - (princ " ")))) - (recent-keys 'include-cmds)))) + (princ " ") + (princ (mapconcat (lambda (key) + (cond + ((and (consp key) (null (car key))) + (format ";; %s\n" (if (symbolp (cdr key)) (cdr key) + "anonymous-command"))) + ((or (integerp key) (symbolp key) (listp key)) + (single-key-description key)) + (t + (prin1-to-string key nil)))) + (recent-keys 'include-cmds) + " ")) (with-current-buffer standard-output (goto-char (point-min)) (let ((comment-start ";; ") diff --git a/src/keyboard.c b/src/keyboard.c index 158daba260..30686a2589 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -307,7 +307,6 @@ static Lisp_Object command_loop (void); static void echo_now (void); static ptrdiff_t echo_length (void); -static void record_char (Lisp_Object c); /* Incremented whenever a timer is run. */ unsigned timers_run; @@ -1422,8 +1421,6 @@ command_loop_1 (void) Fcons (Qnil, cmd)); if (++recent_keys_index >= NUM_RECENT_KEYS) recent_keys_index = 0; - /* Mark this as a complete command in recent_keys. */ - record_char (Qend_of_command); } Vthis_command = cmd; Vreal_this_command = cmd; @@ -1474,9 +1471,6 @@ command_loop_1 (void) safe_run_hooks (Qpost_command_hook); - /* Mark this as a complete command in recent_keys. */ - record_char (Qend_of_command); - /* If displaying a message, resize the echo area window to fit that message's size exactly. Do this only if the echo area window is the minibuffer window of the selected frame. See @@ -2095,6 +2089,7 @@ show_help_echo (Lisp_Object help, Lisp_Object window, Lisp_Object object, static Lisp_Object kbd_buffer_get_event (KBOARD **kbp, bool *used_mouse_menu, struct timespec *end_time); +static void record_char (Lisp_Object c); static Lisp_Object help_form_saved_window_configs; static void @@ -10001,9 +9996,7 @@ represented as pseudo-events of the form (nil . COMMAND). */) do { Lisp_Object e = AREF (recent_keys, i); - if (cmds - || ((!CONSP (e) || !NILP (XCAR (e))) - && !EQ (e, Qend_of_command))) + if (cmds || !CONSP (e) || !NILP (XCAR (e))) es = Fcons (e, es); if (++i >= NUM_RECENT_KEYS) i = 0; @@ -11073,8 +11066,6 @@ syms_of_keyboard (void) DEFSYM (Qundefined, "undefined"); - DEFSYM (Qend_of_command, "end-of-command"); - /* Hooks to run before and after each command. */ DEFSYM (Qpre_command_hook, "pre-command-hook"); DEFSYM (Qpost_command_hook, "post-command-hook"); commit 6c1d0d53b34d9350d55ebbd83ea56aa751a55f1b Author: Michael Albinus Date: Mon Aug 5 13:09:26 2019 +0200 Improve Tramp's caching * lisp/net/tramp.el (tramp-handle-add-name-to-file) (tramp-handle-write-region): * lisp/net/tramp-adb.el (tramp-adb-handle-make-directory) (tramp-adb-handle-delete-directory) (tramp-adb-handle-delete-file, tramp-adb-handle-write-region) (tramp-adb-handle-set-file-modes) (tramp-adb-handle-set-file-times, tramp-adb-handle-copy-file) (tramp-adb-handle-rename-file): * lisp/net/tramp-gvfs.el (tramp-gvfs-do-copy-or-rename-file) (tramp-gvfs-handle-delete-directory) (tramp-gvfs-handle-delete-file) (tramp-gvfs-handle-make-directory) (tramp-gvfs-handle-set-file-modes) (tramp-gvfs-handle-set-file-times, tramp-gvfs-set-file-uid-gid): * lisp/net/tramp-rclone.el (tramp-rclone-do-copy-or-rename-file) (tramp-rclone-handle-delete-directory) (tramp-rclone-handle-delete-file): * lisp/net/tramp-sh.el (tramp-sh-handle-make-symbolic-link) (tramp-sh-handle-set-file-modes, tramp-sh-handle-set-file-times) (tramp-sh-handle-add-name-to-file) (tramp-sh-handle-copy-directory, tramp-do-copy-or-rename-file) (tramp-sh-handle-delete-directory, tramp-sh-handle-delete-file) (tramp-sh-handle-write-region): * lisp/net/tramp-smb.el (tramp-smb-handle-add-name-to-file) (tramp-smb-handle-copy-directory, tramp-smb-handle-copy-file) (tramp-smb-handle-delete-directory) (tramp-smb-handle-delete-file) (tramp-smb-handle-make-directory-internal) (tramp-smb-handle-make-symbolic-link) (tramp-smb-handle-rename-file, tramp-smb-handle-write-region): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-handle-add-name-to-file) (tramp-sudoedit-do-copy-or-rename-file) (tramp-sudoedit-handle-delete-directory) (tramp-sudoedit-handle-delete-file) (tramp-sudoedit-handle-set-file-modes) (tramp-sudoedit-handle-set-file-times) (tramp-sudoedit-handle-make-symbolic-link): Do not flush all file properties of upper directory. * lisp/net/tramp-cache.el (tramp-flush-file-upper-properties): New defun. (tramp-flush-file-properties, tramp-flush-directory-properties): Use it. * test/lisp/net/tramp-tests.el (tramp-time-diff): Declare. (tramp--test-file-attributes-equal-p): Handle also modification and status change time. diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index fb84aa1108..475f9a2e2b 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -510,7 +510,6 @@ Emacs dired can't find files." (let ((par (expand-file-name ".." dir))) (unless (file-directory-p par) (make-directory par parents)))) - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-directory-properties v localname) (unless (or (tramp-adb-send-command-and-check v (format "mkdir %s" (tramp-shell-quote-argument localname))) @@ -521,10 +520,8 @@ Emacs dired can't find files." "Like `delete-directory' for Tramp files." (setq directory (expand-file-name directory)) (with-parsed-tramp-file-name (file-truename directory) nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-directory-properties v localname)) (with-parsed-tramp-file-name directory nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-directory-properties v localname) (tramp-adb-barf-unless-okay v (format "%s %s" @@ -536,7 +533,6 @@ Emacs dired can't find files." "Like `delete-file' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) (tramp-adb-barf-unless-okay v (format "rm %s" (tramp-shell-quote-argument localname)) @@ -627,7 +623,6 @@ But handle the case, if the \"test\" command is not available." ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) (let* ((curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) @@ -665,14 +660,12 @@ But handle the case, if the \"test\" command is not available." (defun tramp-adb-handle-set-file-modes (filename mode) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) (tramp-adb-send-command-and-check v (format "chmod %o %s" mode localname)))) (defun tramp-adb-handle-set-file-times (filename &optional time) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) (let ((time (if (or (null time) (tramp-compat-time-equal-p time tramp-time-doesnt-exist) @@ -722,7 +715,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; We must also flush the cache of the directory, ;; because `file-attributes' reads the values from ;; there. - (tramp-flush-file-properties v (file-name-directory l2)) (tramp-flush-file-properties v l2) ;; Short track. (tramp-adb-barf-unless-okay @@ -757,8 +749,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; We must also flush the cache of the directory, ;; because `file-attributes' reads the values from ;; there. - (tramp-flush-file-properties - v (file-name-directory localname)) (tramp-flush-file-properties v localname) (when (tramp-adb-execute-adb-command v "push" @@ -803,9 +793,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (l2 (tramp-compat-file-local-name newname))) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v (file-name-directory l1)) (tramp-flush-file-properties v l1) - (tramp-flush-file-properties v (file-name-directory l2)) (tramp-flush-file-properties v l2) ;; Short track. (tramp-adb-barf-unless-okay diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 40f74957f5..b52203c79c 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -193,6 +193,22 @@ Returns VALUE." (let ((var (intern (concat "tramp-cache-set-count-" property)))) (makunbound var)))) +(defun tramp-flush-file-upper-properties (key file) + "Remove some properties of FILE's upper directory." + (when (file-name-absolute-p file) + (let ((file (directory-file-name (file-name-directory file)))) + ;; Unify localname. Remove hop from `tramp-file-name' structure. + (setq file (tramp-compat-file-name-unquote file) + key (copy-tramp-file-name key)) + (setf (tramp-file-name-localname key) file + (tramp-file-name-hop key) nil) + (maphash + (lambda (property _value) + (when (string-match-p + "^\\(directory-\\|file-name-all-completions\\)" property) + (tramp-flush-file-property key file property))) + (tramp-get-hash-table key))))) + ;;;###tramp-autoload (defun tramp-flush-file-properties (key file) "Remove all properties of FILE in the cache context of KEY." @@ -209,7 +225,9 @@ Returns VALUE." ;; Remove file properties of symlinks. (when (and (stringp truename) (not (string-equal file (directory-file-name truename)))) - (tramp-flush-file-properties key truename)))) + (tramp-flush-file-properties key truename)) + ;; Remove selected properties of upper directory. + (tramp-flush-file-upper-properties key file))) ;;;###tramp-autoload (defun tramp-flush-directory-properties (key directory) @@ -231,7 +249,9 @@ Remove also properties of all files in subdirectories." ;; Remove file properties of symlinks. (when (and (stringp truename) (not (string-equal directory (directory-file-name truename)))) - (tramp-flush-directory-properties key truename)))) + (tramp-flush-directory-properties key truename)) + ;; Remove selected properties of upper directory. + (tramp-flush-file-upper-properties key directory))) ;; Reverting or killing a buffer should also flush file properties. ;; They could have been changed outside Tramp. In eshell, "ls" would diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index a606ba6717..8cec5871cf 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -817,12 +817,10 @@ file names." (when (and t1 (eq op 'rename)) (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname))) (when t2 (with-parsed-tramp-file-name newname nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname)))))))) (defun tramp-gvfs-handle-copy-file @@ -857,7 +855,6 @@ file names." (tramp-error v 'file-error "Couldn't delete non-empty %s" directory))) - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-directory-properties v localname) (unless (tramp-gvfs-send-command @@ -872,7 +869,6 @@ file names." (defun tramp-gvfs-handle-delete-file (filename &optional trash) "Like `delete-file' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) (unless (tramp-gvfs-send-command @@ -1296,7 +1292,6 @@ file-notify events." "Like `make-directory' for Tramp files." (setq dir (directory-file-name (expand-file-name dir))) (with-parsed-tramp-file-name dir nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-directory-properties v localname) (save-match-data (let ((ldir (file-name-directory dir))) @@ -1329,7 +1324,6 @@ file-notify events." (defun tramp-gvfs-handle-set-file-modes (filename mode) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) (tramp-gvfs-send-command v "gvfs-set-attribute" "-t" "uint32" @@ -1339,7 +1333,6 @@ file-notify events." (defun tramp-gvfs-handle-set-file-times (filename &optional time) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) (let ((time (if (or (null time) @@ -1355,7 +1348,6 @@ file-notify events." (defun tramp-gvfs-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) (when (natnump uid) (tramp-gvfs-send-command diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 9b3eab3477..e0fd8e3441 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -244,30 +244,22 @@ file names." (when (and t1 (eq op 'rename)) (with-parsed-tramp-file-name filename v1 - (tramp-flush-file-properties - v1 (file-name-directory v1-localname)) (tramp-flush-file-properties v1 v1-localname) (when (tramp-rclone-file-name-p filename) (tramp-rclone-flush-directory-cache v1) ;; The mount point's directory cache might need time ;; to flush. (while (file-exists-p filename) - (tramp-flush-file-properties - v1 (file-name-directory v1-localname)) (tramp-flush-file-properties v1 v1-localname))))) (when t2 (with-parsed-tramp-file-name newname v2 - (tramp-flush-file-properties - v2 (file-name-directory v2-localname)) (tramp-flush-file-properties v2 v2-localname) (when (tramp-rclone-file-name-p newname) (tramp-rclone-flush-directory-cache v2) ;; The mount point's directory cache might need time ;; to flush. (while (not (file-exists-p newname)) - (tramp-flush-file-properties - v2 (file-name-directory v2-localname)) (tramp-flush-file-properties v2 v2-localname)))))))))) (defun tramp-rclone-handle-copy-file @@ -292,7 +284,6 @@ file names." "Like `delete-directory' for Tramp files." (with-parsed-tramp-file-name (expand-file-name directory) nil (delete-directory (tramp-rclone-local-file-name directory) recursive trash) - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-directory-properties v localname) (tramp-rclone-flush-directory-cache v))) @@ -300,7 +291,6 @@ file names." "Like `delete-file' for Tramp files." (with-parsed-tramp-file-name (expand-file-name filename) nil (delete-file (tramp-rclone-local-file-name filename) trash) - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) (tramp-rclone-flush-directory-cache v))) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 3399b961b2..54bf2ba773 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1069,7 +1069,6 @@ component is used as the target of the symlink." (tramp-error v 'file-already-exists localname) (delete-file linkname))) - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) ;; Right, they are on the same host, regardless of user, @@ -1450,7 +1449,6 @@ of." (defun tramp-sh-handle-set-file-modes (filename mode) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) ;; FIXME: extract the proper text from chmod's stderr. (tramp-barf-unless-okay @@ -1462,7 +1460,6 @@ of." "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (when (tramp-get-remote-touch v) - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) (let ((time (if (or (null time) @@ -1875,7 +1872,6 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" v2-localname))))) (tramp-error v2 'file-already-exists newname) (delete-file newname))) - (tramp-flush-file-properties v2 (file-name-directory v2-localname)) (tramp-flush-file-properties v2 v2-localname) (tramp-barf-unless-okay v1 @@ -1942,7 +1938,6 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" ;; When newname did exist, we have wrong cached values. (when t2 (with-parsed-tramp-file-name newname nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname)))))) (defun tramp-sh-handle-rename-file @@ -2072,15 +2067,11 @@ file names." ;; In case of `rename', we must flush the cache of the source file. (when (and t1 (eq op 'rename)) (with-parsed-tramp-file-name filename v1 - (tramp-flush-file-properties - v1 (file-name-directory v1-localname)) (tramp-flush-file-properties v1 v1-localname))) ;; When newname did exist, we have wrong cached values. (when t2 (with-parsed-tramp-file-name newname v2 - (tramp-flush-file-properties - v2 (file-name-directory v2-localname)) (tramp-flush-file-properties v2 v2-localname)))))))) (defun tramp-do-copy-or-rename-file-via-buffer (op filename newname keep-date) @@ -2505,7 +2496,6 @@ The method used must be an out-of-band method." "Like `delete-directory' for Tramp files." (setq directory (expand-file-name directory)) (with-parsed-tramp-file-name directory nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-directory-properties v localname) (tramp-barf-unless-okay v (format "cd / && %s %s" @@ -2518,7 +2508,6 @@ The method used must be an out-of-band method." "Like `delete-file' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) (tramp-barf-unless-okay v (format "%s %s" @@ -3394,7 +3383,6 @@ the result will be a local, non-Tramp, file name." (when coding-system-used (set 'last-coding-system-used coding-system-used)))) - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) ;; We must protect `last-coding-system-used', now we have set it diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index cb8d2df084..594463d77f 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -371,7 +371,6 @@ pass to the OPERATION." (delete-file newname))) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v2 (file-name-directory v2-localname)) (tramp-flush-file-properties v2 v2-localname) (unless (tramp-smb-send-command @@ -548,7 +547,6 @@ pass to the OPERATION." ;; When newname did exist, we have wrong cached values. (when t2 (with-parsed-tramp-file-name newname nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname)))) ;; We must do it file-wise. @@ -596,7 +594,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) (unless (tramp-smb-get-share v) (tramp-error @@ -631,7 +628,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (with-parsed-tramp-file-name directory nil ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-directory-properties v localname) (unless (tramp-smb-send-command v (format @@ -657,7 +653,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (with-parsed-tramp-file-name filename nil ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) (unless (tramp-smb-send-command v (format @@ -1154,7 +1149,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (format "mkdir \"%s\"" file))) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname)) (unless (file-directory-p directory) (tramp-error v 'file-error "Couldn't make directory %s" directory))))) @@ -1202,7 +1196,6 @@ component is used as the target of the symlink." ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) (unless @@ -1358,11 +1351,7 @@ component is used as the target of the symlink." ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties - v1 (file-name-directory v1-localname)) (tramp-flush-file-properties v1 v1-localname) - (tramp-flush-file-properties - v2 (file-name-directory v2-localname)) (tramp-flush-file-properties v2 v2-localname) (unless (tramp-smb-get-share v2) (tramp-error @@ -1548,7 +1537,6 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) (let ((curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 0ded85fb55..0ec98bb069 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -189,7 +189,6 @@ pass to the OPERATION." v2-localname))))) (tramp-error v2 'file-already-exists newname) (delete-file newname))) - (tramp-flush-file-properties v2 (file-name-directory v2-localname)) (tramp-flush-file-properties v2 v2-localname) (unless (tramp-sudoedit-send-command @@ -291,14 +290,10 @@ absolute file names." (when (and t1 (eq op 'rename)) (with-parsed-tramp-file-name filename v1 - (tramp-flush-file-properties - v1 (file-name-directory v1-localname)) (tramp-flush-file-properties v1 v1-localname))) (when t2 (with-parsed-tramp-file-name newname v2 - (tramp-flush-file-properties - v2 (file-name-directory v2-localname)) (tramp-flush-file-properties v2 v2-localname))))))) (defun tramp-sudoedit-handle-copy-file @@ -323,7 +318,6 @@ absolute file names." "Like `delete-directory' for Tramp files." (setq directory (expand-file-name directory)) (with-parsed-tramp-file-name directory nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-directory-properties v localname) (unless (tramp-sudoedit-send-command @@ -335,7 +329,6 @@ absolute file names." (defun tramp-sudoedit-handle-delete-file (filename &optional trash) "Like `delete-file' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) (unless (tramp-sudoedit-send-command @@ -467,7 +460,6 @@ the result will be a local, non-Tramp, file name." (defun tramp-sudoedit-handle-set-file-modes (filename mode) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) (unless (tramp-sudoedit-send-command v "chmod" (format "%o" mode) @@ -526,7 +518,6 @@ the result will be a local, non-Tramp, file name." (defun tramp-sudoedit-handle-set-file-times (filename &optional time) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) (let ((time (if (or (null time) @@ -634,7 +625,6 @@ component is used as the target of the symlink." (tramp-error v 'file-already-exists localname) (delete-file linkname))) - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) (tramp-sudoedit-send-command v "ln" "-sf" diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index c589557132..77d727e2f2 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3006,7 +3006,6 @@ User is always nil." localname))))) (tramp-error v 'file-already-exists newname) (delete-file newname))) - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) (copy-file filename newname 'ok-if-already-exists 'keep-time @@ -3794,7 +3793,6 @@ of." (tramp-error v 'file-error "Couldn't write region to `%s'" filename)))) - (tramp-flush-file-properties v (file-name-directory localname)) (tramp-flush-file-properties v localname) ;; Set file modification time. diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index f60dea36bf..d49914797f 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -56,6 +56,7 @@ (declare-function tramp-list-tramp-buffers "tramp-cmds") (declare-function tramp-method-out-of-band-p "tramp-sh") (declare-function tramp-smb-get-localname "tramp-smb") +(declare-function tramp-time-diff "tramp") (defvar auto-save-file-name-transforms) (defvar tramp-connection-properties) (defvar tramp-copy-size-limit) @@ -3084,9 +3085,18 @@ This tests also `access-file', `file-readable-p', (defsubst tramp--test-file-attributes-equal-p (attr1 attr2) "Check, whether file attributes ATTR1 and ATTR2 are equal. -They might differ only in access time." +They might differ only in time attributes." + ;; Access time. (setcar (nthcdr 4 attr1) tramp-time-dont-know) (setcar (nthcdr 4 attr2) tramp-time-dont-know) + ;; Modification time. + (when (< (abs (tramp-time-diff (nth 5 attr1) (nth 5 attr2))) 5) + (setcar (nthcdr 5 attr1) tramp-time-dont-know) + (setcar (nthcdr 5 attr2) tramp-time-dont-know)) + ;; Status change time. + (when (< (abs (tramp-time-diff (nth 6 attr1) (nth 6 attr2))) 5) + (setcar (nthcdr 6 attr1) tramp-time-dont-know) + (setcar (nthcdr 6 attr2) tramp-time-dont-know)) (equal attr1 attr2)) ;; This isn't 100% correct, but better than no explainer at all. commit 1abf76877847226daa5ab7e07000ac1d4aba3478 Author: Lars Ingebrigtsen Date: Mon Aug 5 12:43:09 2019 +0200 Make `view-lossage' output of chars read from `read-char' more logical * lisp/help.el (view-lossage): Use the new data format to output data from `read-char' and the like in a more understandable fashion (bug#21867). * src/keyboard.c (command_loop_1): Record (in recent_keys) the end of commands. (Frecent_keys): Don't include `end-of-command' in non-command outputs. (syms_of_keyboard): Define `end-of-command'. diff --git a/lisp/help.el b/lisp/help.el index 039d0c44e4..ba76d26757 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -465,18 +465,28 @@ To record all your input, use `open-dribble-file'." (help-setup-xref (list #'view-lossage) (called-interactively-p 'interactive)) (with-help-window (help-buffer) - (princ " ") - (princ (mapconcat (lambda (key) - (cond - ((and (consp key) (null (car key))) - (format ";; %s\n" (if (symbolp (cdr key)) (cdr key) - "anonymous-command"))) - ((or (integerp key) (symbolp key) (listp key)) - (single-key-description key)) - (t - (prin1-to-string key nil)))) - (recent-keys 'include-cmds) - " ")) + (with-current-buffer standard-output + (let ((prev-command nil)) + (mapc + (lambda (key) + (cond + ((and (consp key) (null (car key))) + (princ (format ";; %s\n" + (setq prev-command + (if (symbolp (cdr key)) + (cdr key) + "anonymous-command"))))) + ((eq key 'end-of-command) + (unless (bolp) + (princ (format ";; \n" (or prev-command + "unknown command"))))) + ((or (integerp key) (symbolp key) (listp key)) + (princ (single-key-description key)) + (princ " ")) + (t + (prin1 key) + (princ " ")))) + (recent-keys 'include-cmds)))) (with-current-buffer standard-output (goto-char (point-min)) (let ((comment-start ";; ") diff --git a/src/keyboard.c b/src/keyboard.c index 30686a2589..158daba260 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -307,6 +307,7 @@ static Lisp_Object command_loop (void); static void echo_now (void); static ptrdiff_t echo_length (void); +static void record_char (Lisp_Object c); /* Incremented whenever a timer is run. */ unsigned timers_run; @@ -1421,6 +1422,8 @@ command_loop_1 (void) Fcons (Qnil, cmd)); if (++recent_keys_index >= NUM_RECENT_KEYS) recent_keys_index = 0; + /* Mark this as a complete command in recent_keys. */ + record_char (Qend_of_command); } Vthis_command = cmd; Vreal_this_command = cmd; @@ -1471,6 +1474,9 @@ command_loop_1 (void) safe_run_hooks (Qpost_command_hook); + /* Mark this as a complete command in recent_keys. */ + record_char (Qend_of_command); + /* If displaying a message, resize the echo area window to fit that message's size exactly. Do this only if the echo area window is the minibuffer window of the selected frame. See @@ -2089,7 +2095,6 @@ show_help_echo (Lisp_Object help, Lisp_Object window, Lisp_Object object, static Lisp_Object kbd_buffer_get_event (KBOARD **kbp, bool *used_mouse_menu, struct timespec *end_time); -static void record_char (Lisp_Object c); static Lisp_Object help_form_saved_window_configs; static void @@ -9996,7 +10001,9 @@ represented as pseudo-events of the form (nil . COMMAND). */) do { Lisp_Object e = AREF (recent_keys, i); - if (cmds || !CONSP (e) || !NILP (XCAR (e))) + if (cmds + || ((!CONSP (e) || !NILP (XCAR (e))) + && !EQ (e, Qend_of_command))) es = Fcons (e, es); if (++i >= NUM_RECENT_KEYS) i = 0; @@ -11066,6 +11073,8 @@ syms_of_keyboard (void) DEFSYM (Qundefined, "undefined"); + DEFSYM (Qend_of_command, "end-of-command"); + /* Hooks to run before and after each command. */ DEFSYM (Qpre_command_hook, "pre-command-hook"); DEFSYM (Qpost_command_hook, "post-command-hook"); commit f1f6f20ca0a3e3190defa79bcfcc59eb6aa3b4dc Author: Lars Ingebrigtsen Date: Mon Aug 5 12:18:40 2019 +0200 save-some-buffers-default-predicate doc clarification * lisp/files.el (save-some-buffers-default-predicate): Clarify calling convention. diff --git a/lisp/files.el b/lisp/files.el index 009f52a3c6..f76635017d 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -5425,8 +5425,12 @@ Before and after saving the buffer, this function runs (defcustom save-some-buffers-default-predicate nil "Default predicate for `save-some-buffers'. + This allows you to stop `save-some-buffers' from asking -about certain files that you'd usually rather not save." +about certain files that you'd usually rather not save. + +This function is called (with no parameters) from the buffer to +be saved." :group 'auto-save ;; FIXME nil should not be a valid option, let alone the default, ;; eg so that add-function can be used. commit 47a3e0dc2cb2f583fcb52599bfc06849ec2389d8 Author: Mattias Engdegård Date: Mon Aug 5 10:28:17 2019 +0200 ; * doc/lispref/searching.texi: Typo fix diff --git a/doc/lispref/searching.texi b/doc/lispref/searching.texi index d7810580b9..2088f16e47 100644 --- a/doc/lispref/searching.texi +++ b/doc/lispref/searching.texi @@ -1177,13 +1177,13 @@ explicit non-greedy forms above when such matching is required. @cindex @code{minimal-match} in rx Match @var{rx}, with @code{zero-or-more}, @code{0+}, @code{one-or-more}, @code{1+}, @code{zero-or-one}, @code{opt} and -@code{option} using non-greedy matching. +@code{optional} using non-greedy matching. @item (maximal-match @var{rx}) @cindex @code{maximal-match} in rx Match @var{rx}, with @code{zero-or-more}, @code{0+}, @code{one-or-more}, @code{1+}, @code{zero-or-one}, @code{opt} and -@code{option} using non-greedy matching. This is the default. +@code{optional} using non-greedy matching. This is the default. @end table @subsubheading Matching single characters commit 88be35e1ae05a50b9291153fed4cf5911564db0a Author: Martin Rudalics Date: Mon Aug 5 10:23:01 2019 +0200 Fix doc-strings of 'display-buffer-*' functions (Bug#19461) * lisp/window.el (display-buffer-in-atom-window) (display-buffer-in-side-window, display-buffer-record-window) (display-buffer-use-some-frame, display-buffer-same-window) (display-buffer-reuse-window, display-buffer-pop-up-frame) (display-buffer-pop-up-window, display-buffer-in-child-frame) (display-buffer-in-direction, display-buffer-below-selected) (display-buffer-at-bottom, display-buffer-in-previous-window) (display-buffer-use-some-window) (display-buffer--maybe-pop-up-frame-or-window) (display-buffer--maybe-pop-up-frame): Fix doc-strings (Bug#19461). diff --git a/lisp/window.el b/lisp/window.el index 70e2bba749..5af66a036d 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -666,9 +666,9 @@ new window to that atomic window. Operations like `split-window' or `delete-window', when applied to a constituent of an atomic window, are applied atomically to the root of that atomic window. -ALIST is an association list of action symbols and values. -See Info node `(elisp) Buffer Display Action Alists' for -details of such alists. The following symbols can be used: +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. The following two symbols have a special meaning: `window' specifies the existing window the new window shall be combined with. Use `window-atom-root' to make the new window a @@ -677,7 +677,7 @@ details of such alists. The following symbols can be used: atomic window too. If no window is specified, the new window becomes a sibling of the selected window. By default, the `window-atom' parameter of the existing window is set to `main' - provided it is live and was not set before. + provided the window is live and the parameter is not set yet. `side' denotes the side of the existing window where the new window shall be located. Valid values are `below', `right', @@ -685,7 +685,12 @@ details of such alists. The following symbols can be used: `window-atom' parameter of the new window is set to this value. The return value is the new window, nil when creating that window -failed." +failed. + +This is an action function for buffer display, see Info +node `(elisp) Buffer Display Action Functions'. It should be +called only by `display-buffer' or a function directly or +indirectly called by the latter." (let* ((ignore-window-parameters t) (window-combination-limit t) (window-combination-resize 'atom) @@ -1001,10 +1006,10 @@ and may be called only if no window on SIDE exists yet." (defun display-buffer-in-side-window (buffer alist) "Display BUFFER in a side window of the selected frame. -ALIST is an association list of action symbols and values. -See Info node `(elisp) Buffer Display Action Alists' for -details of such alists. -The following special symbols can be used in ALIST: +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. The following two symbols, when used in ALIST, have +a special meaning: `side' denotes the side of the frame where the new window shall be located. Valid values are `bottom', `right', `top' and @@ -1030,7 +1035,12 @@ for displaying BUFFER, nil if no suitable window can be found. This function installs the `window-side' and `window-slot' parameters and makes them persistent. It neither modifies ALIST nor installs any other window parameters unless they have been -explicitly provided via a `window-parameters' entry in ALIST." +explicitly provided via a `window-parameters' entry in ALIST. + +This is an action function for buffer display, see Info +node `(elisp) Buffer Display Action Functions'. It should be +called only by `display-buffer' or a function directly or +indirectly called by the latter." (let* ((side (or (cdr (assq 'side alist)) 'bottom)) (slot (or (cdr (assq 'slot alist)) 0)) (left-or-right (memq side '(left right)))) @@ -6166,16 +6176,16 @@ this function must be called before BUFFER is explicitly made WINDOW's buffer (although WINDOW may show BUFFER already). TYPE specifies the type of the calling operation and must be one -of the symbols 'reuse' (meaning that WINDOW exists already and -will be used for displaying BUFFER), 'window' (WINDOW was created -on an already existing frame) or 'frame' (WINDOW was created on a +of the symbols `reuse' (meaning that WINDOW exists already and +will be used for displaying BUFFER), `window' (WINDOW was created +on an already existing frame) or `frame' (WINDOW was created on a new frame). -This function installs or updates the 'quit-restore' parameter of -WINDOW. The 'quit-restore' parameter is a list of four elements: -The first element is one of the symbols 'window', 'frame', 'same' -or 'other'. The second element is either one of the symbols -'window' or 'frame' or a list whose elements are the buffer +This function installs or updates the `quit-restore' parameter of +WINDOW. The `quit-restore' parameter is a list of four elements: +The first element is one of the symbols `window', `frame', `same' +or `other'. The second element is either one of the symbols +`window' or `frame' or a list whose elements are the buffer previously shown in the window, that buffer's window start and window point, and the window's height. The third element is the window selected at the time the parameter was created. The @@ -7288,21 +7298,22 @@ The default predicate is to use any frame other than the selected frame. If successful, return the window used; otherwise return nil. -ALIST is an association list of action symbols and values. -See Info node `(elisp) Buffer Display Action Alists' for -details of such alists. +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. If ALIST has a non-nil `inhibit-switch-frame' entry, avoid -raising the frame. - -If ALIST has a non-nil `frame-predicate' entry, its value is a -function taking one argument (a frame), returning non-nil if the -frame is a candidate; this function replaces the default -predicate. - -If ALIST has a non-nil `inhibit-same-window' entry, avoid using -the currently selected window (only useful with a frame-predicate -that allows the selected frame)." +raising the frame. If it has a non-nil `frame-predicate' entry, +its value is a function taking one argument (a frame), returning +non-nil if the frame is a candidate; this function replaces the +default predicate. If ALIST has a non-nil `inhibit-same-window' +entry, avoid using the currently selected window (only useful +with a frame-predicate that allows using the selected frame). + +This is an action function for buffer display, see Info +node `(elisp) Buffer Display Action Functions'. It should be +called only by `display-buffer' or a function directly or +indirectly called by the latter." (let* ((predicate (or (cdr (assq 'frame-predicate alist)) (lambda (frame) @@ -7321,15 +7332,19 @@ that allows the selected frame)." (defun display-buffer-same-window (buffer alist) "Display BUFFER in the selected window. - -ALIST is an association list of action symbols and values. -See Info node `(elisp) Buffer Display Action Alists' for -details of such alists. +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. This function fails if ALIST has an `inhibit-same-window' element whose value is non-nil, or if the selected window is a minibuffer window or is dedicated to another buffer; in that case, -return nil. Otherwise, return the selected window." +return nil. Otherwise, return the selected window. + +This is an action function for buffer display, see Info +node `(elisp) Buffer Display Action Functions'. It should be +called only by `display-buffer' or a function directly or +indirectly called by the latter." (unless (or (cdr (assq 'inhibit-same-window alist)) (window-minibuffer-p) (window-dedicated-p)) @@ -7337,10 +7352,9 @@ return nil. Otherwise, return the selected window." (defun display-buffer--maybe-same-window (buffer alist) "Conditionally display BUFFER in the selected window. - -ALIST is an association list of action symbols and values. -See Info node `(elisp) Buffer Display Action Alists' for -details of such alists. +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. If `same-window-p' returns non-nil for BUFFER's name, call `display-buffer-same-window' and return its value. Otherwise, @@ -7353,29 +7367,34 @@ return nil." Preferably use a window on the selected frame if such a window exists. Return nil if no usable window is found. -ALIST is an association list of action symbols and values. -See Info node `(elisp) Buffer Display Action Alists' for -details of such alists. +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. -If ALIST has a non-nil 'inhibit-same-window' entry, the selected +If ALIST has a non-nil `inhibit-same-window' entry, the selected window is not eligible for reuse. -If ALIST contains a 'reusable-frames' entry, its value determines +If ALIST contains a `reusable-frames' entry, its value determines which frames to search for a reusable window: nil -- the selected frame (actually the last non-minibuffer frame) A frame -- just that frame - 'visible' -- all visible frames + `visible' -- all visible frames 0 -- all frames on the current terminal t -- all frames. -If ALIST contains no 'reusable-frames' entry, search just the +If ALIST contains no `reusable-frames' entry, search just the selected frame if `display-buffer-reuse-frames' and `pop-up-frames' are both nil; search all frames on the current terminal if either of those variables is non-nil. -If ALIST has a non-nil 'inhibit-switch-frame' entry, then in the +If ALIST has a non-nil `inhibit-switch-frame' entry, then in the event that a window on another frame is chosen, avoid raising -that frame." +that frame. + +This is an action function for buffer display, see Info +node `(elisp) Buffer Display Action Functions'. It should be +called only by `display-buffer' or a function directly or +indirectly called by the latter." (let* ((alist-entry (assq 'reusable-frames alist)) (frames (cond (alist-entry (cdr alist-entry)) ((if (eq pop-up-frames 'graphic-only) @@ -7412,9 +7431,9 @@ that frame." Display BUFFER in the returned window. Return nil if no usable window is found. -ALIST is an association list of action symbols and values. -See Info node `(elisp) Buffer Display Action Alists' for -details of such alists. +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. If ALIST contains a `mode' entry, its value is a major mode (a symbol) or a list of modes. A window is a candidate if it @@ -7425,7 +7444,12 @@ is used. The behavior is also controlled by entries for `inhibit-same-window', `reusable-frames' and `inhibit-switch-frame' as is done in the function -`display-buffer-reuse-window'." +`display-buffer-reuse-window'. + +This is an action function for buffer display, see Info +node `(elisp) Buffer Display Action Functions'. It should be +called only by `display-buffer' or a function directly or +indirectly called by the latter." (let* ((alist-entry (assq 'reusable-frames alist)) (alist-mode-entry (assq 'mode alist)) (frames (cond (alist-entry (cdr alist-entry)) @@ -7495,16 +7519,18 @@ See `display-buffer' for the format of display actions." This works by calling `pop-up-frame-function'. If successful, return the window used; otherwise return nil. -ALIST is an association list of action symbols and values. -See Info node `(elisp) Buffer Display Action Alists' for -details of such alists. +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. If ALIST has a non-nil `inhibit-switch-frame' entry, avoid -raising the new frame. +raising the new frame. A non-nil `pop-up-frame-parameters' entry +specifies an alist of frame parameters to give the new frame. -If ALIST has a non-nil `pop-up-frame-parameters' entry, the -corresponding value is an alist of frame parameters to give the -new frame." +This is an action function for buffer display, see Info +node `(elisp) Buffer Display Action Functions'. It should be +called only by `display-buffer' or a function directly or +indirectly called by the latter." (let* ((params (cdr (assq 'pop-up-frame-parameters alist))) (pop-up-frame-alist (append params pop-up-frame-alist)) (fun pop-up-frame-function) @@ -7525,13 +7551,18 @@ The new window is created on the selected frame, or in `last-nonminibuffer-frame' if no windows can be created there. If successful, return the new window; otherwise return nil. -ALIST is an association list of action symbols and values. -See Info node `(elisp) Buffer Display Action Alists' for -details of such alists. +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. If ALIST has a non-nil `inhibit-switch-frame' entry, then in the event that the new window is created on another frame, avoid -raising the frame." +raising the frame. + +This is an action function for buffer display, see Info +node `(elisp) Buffer Display Action Functions'. It should be +called only by `display-buffer' or a function directly or +indirectly called by the latter." (let ((frame (or (window--frame-usable-p (selected-frame)) (window--frame-usable-p (last-nonminibuffer-frame)))) window) @@ -7554,15 +7585,14 @@ raising the frame." (defun display-buffer--maybe-pop-up-frame-or-window (buffer alist) "Try displaying BUFFER based on `pop-up-frames' or `pop-up-windows'. -If `pop-up-frames' is non-nil (and not `graphic-only' on a -text-only terminal), try with `display-buffer-pop-up-frame'. - -ALIST is an association list of action symbols and values. -See Info node `(elisp) Buffer Display Action Alists' for -details of such alists. +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. -If that cannot be done, and `pop-up-windows' is non-nil, try -again with `display-buffer-pop-up-window'." +If `pop-up-frames' is non-nil (and not `graphic-only' on a +text-only terminal), try with `display-buffer-pop-up-frame'. If +that cannot be done, and `pop-up-windows' is non-nil, try again +with `display-buffer-pop-up-window'." (or (display-buffer--maybe-pop-up-frame buffer alist) (display-buffer--maybe-pop-up-window buffer alist))) @@ -7571,9 +7601,9 @@ again with `display-buffer-pop-up-window'." If `pop-up-frames' is non-nil (and not `graphic-only' on a text-only terminal), try with `display-buffer-pop-up-frame'. -ALIST is an association list of action symbols and values. -See Info node `(elisp) Buffer Display Action Alists' for -details of such alists." +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists." (and (if (eq pop-up-frames 'graphic-only) (display-graphic-p) pop-up-frames) @@ -7591,16 +7621,21 @@ By default, this either reuses a child frame of the selected frame or makes a new child frame of the selected frame. If successful, return the window used; otherwise return nil. -ALIST is an association list of action symbols and values. -See Info node `(elisp) Buffer Display Action Alists' for -details of such alists. +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. -If ALIST has a non-nil 'child-frame-parameters' entry, the +If ALIST has a non-nil `child-frame-parameters' entry, the corresponding value is an alist of frame parameters to give the -new frame. A 'parent-frame' parameter specifying the selected -frame is provided by default. If the child frame should be or +new frame. A `parent-frame' parameter specifying the selected +frame is provided by default. If the child frame shall be or become the child of any other frame, a corresponding entry must -be added to ALIST." +be added to ALIST. + +This is an action function for buffer display, see Info +node `(elisp) Buffer Display Action Functions'. It should be +called only by `display-buffer' or a function directly or +indirectly called by the latter." (let* ((parameters (append (cdr (assq 'child-frame-parameters alist)) @@ -7698,16 +7733,15 @@ ALIST is a buffer display alist." (defun display-buffer-in-direction (buffer alist) "Try to display BUFFER in a direction specified by ALIST. +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. -ALIST is an association list of action symbols and values. -See Info node `(elisp) Buffer Display Action Alists' for -details of such alists. +ALIST has to contain a `direction' entry whose value should be +one of `left', `above' (or `up'), `right' and `below' (or +'down'). Other values are usually interpreted as `below'. -ALIST has to contain a 'direction' entry whose value should be -one of 'left', 'above' (or 'up'), 'right', and 'below' (or -'down'). Other values are usually interpreted as 'below'. - -If ALIST also contains a 'window' entry, its value specifies a +If ALIST also contains a `window' entry, its value specifies a reference window. That value can be a special symbol like 'main' (which stands for the selected frame's main window) or 'root' (standings for the selected frame's root window) or an @@ -7717,13 +7751,18 @@ window. This function tries to reuse or split a window such that the window produced this way is on the side of the reference window -specified by the 'direction' entry. +specified by the `direction' entry. -Four special values for 'direction' entries allow to implicitly +Four special values for `direction' entries allow to implicitly specify the selected frame's main window as reference window: -'leftmost', 'top', 'rightmost' and 'bottom'. Hence, instead of -'(direction . left) (window . main)' one can simply write -'(direction . leftmost)'." +`leftmost', `top', `rightmost' and `bottom'. Hence, instead of +`(direction . left) (window . main)' one can simply write +`(direction . leftmost)'. + +This is an action function for buffer display, see Info +node `(elisp) Buffer Display Action Functions'. It should be +called only by `display-buffer' or a function directly or +indirectly called by the latter." (let ((direction (cdr (assq 'direction alist)))) (when direction (let ((window (cdr (assq 'window alist))) @@ -7791,15 +7830,20 @@ create a new window below the selected one and show BUFFER there. If that attempt fails as well and there is a non-dedicated window below the selected one, use that window. -ALIST is an association list of action symbols and values. -See Info node `(elisp) Buffer Display Action Alists' for -details of such alists. +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. -If ALIST contains a 'window-min-height' entry, this function +If ALIST contains a `window-min-height' entry, this function ensures that the window used is or can become at least as high as specified by that entry's value. Note that such an entry alone will not resize the window per se. In order to do that, ALIST -must also contain a 'window-height' entry with the same value." +must also contain a `window-height' entry with the same value. + +This is an action function for buffer display, see Info +node `(elisp) Buffer Display Action Functions'. It should be +called only by `display-buffer' or a function directly or +indirectly called by the latter." (let ((min-height (cdr (assq 'window-min-height alist))) window) (or (and (setq window (window-in-direction 'below)) @@ -7851,9 +7895,14 @@ already, splits a window at the bottom of the frame or the frame's root window, or reuses some window at the bottom of the selected frame. -ALIST is an association list of action symbols and values. -See Info node `(elisp) Buffer Display Action Alists' for -details of such alists." +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. + +This is an action function for buffer display, see Info +node `(elisp) Buffer Display Action Functions'. It should be +called only by `display-buffer' or a function directly or +indirectly called by the latter." (let (bottom-window bottom-window-shows-buffer window) (walk-window-tree (lambda (window) @@ -7877,10 +7926,9 @@ details of such alists." (defun display-buffer-in-previous-window (buffer alist) "Display BUFFER in a window previously showing it. - -ALIST is an association list of action symbols and values. -See Info node `(elisp) Buffer Display Action Alists' for -details of such alists. +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. If ALIST has a non-nil `inhibit-same-window' entry, the selected window is not usable. A dedicated window is usable only if it @@ -7904,14 +7952,19 @@ terminal if either of those variables is non-nil. If more than one window is usable according to these rules, apply the following order of preference: -- Use the window specified by any 'previous-window' ALIST entry, +- Use the window specified by any `previous-window' ALIST entry, provided it is not the selected window. - Use a window that showed BUFFER before, provided it is not the selected window. - Use the selected window if it is either specified by a - 'previous-window' ALIST entry or showed BUFFER before." + `previous-window' ALIST entry or showed BUFFER before. + +This is an action function for buffer display, see Info +node `(elisp) Buffer Display Action Functions'. It should be +called only by `display-buffer' or a function directly or +indirectly called by the latter." (let* ((alist-entry (assq 'reusable-frames alist)) (inhibit-same-window (cdr (assq 'inhibit-same-window alist))) @@ -7953,13 +8006,18 @@ apply the following order of preference: Search for a usable window, set that window to the buffer, and return the window. If no suitable window is found, return nil. -ALIST is an association list of action symbols and values. -See Info node `(elisp) Buffer Display Action Alists' for -details of such alists. +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. If ALIST has a non-nil `inhibit-switch-frame' entry, then in the -event that a window in another frame is chosen, avoid raising -that frame." +event that a window on another frame is chosen, avoid raising +that frame. + +This is an action function for buffer display, see Info +node `(elisp) Buffer Display Action Functions'. It should be +called only by `display-buffer' or a function directly or +indirectly called by the latter." (let* ((not-this-window (cdr (assq 'inhibit-same-window alist))) (frame (or (window--frame-usable-p (selected-frame)) (window--frame-usable-p (last-nonminibuffer-frame)))) @@ -7997,16 +8055,20 @@ that frame." (defun display-buffer-no-window (_buffer alist) "Display BUFFER in no window. - -ALIST is an association list of action symbols and values. -See Info node `(elisp) Buffer Display Action Alists' for -details of such alists. - -If ALIST has a non-nil `allow-no-window' entry, then don't display -a window at all. This makes possible to override the default action -and avoid displaying the buffer. It is assumed that when the caller -specifies a non-nil `allow-no-window' then it can handle a nil value -returned from `display-buffer' in this case." +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. + +If ALIST contains a non-nil `allow-no-window' entry, do nothing +and return `fail'. This allows `display-buffer' to override the +default action and avoid displaying the buffer. It is assumed +that when the caller specifies a non-nil `allow-no-window' ALIST +entry, it can handle a nil value returned by `display-buffer'. + +This is an action function for buffer display, see Info +node `(elisp) Buffer Display Action Functions'. It should be +called only by `display-buffer' or a function directly or +indirectly called by the latter." (when (cdr (assq 'allow-no-window alist)) 'fail)) commit 543568b602bcf2f3496d0a340317682c48a9a923 Author: Paul Eggert Date: Sun Aug 4 15:54:17 2019 -0700 Fix one more 2019-08-04 regex lint Problem clarified by Mattias Engdegård in: https://lists.gnu.org/r/emacs-devel/2019-08/msg00087.html * lisp/isearch.el (isearch-symbol-regexp): Remove \s@ from regexp as it cannot match. diff --git a/lisp/isearch.el b/lisp/isearch.el index 97c75b2978..09729034d7 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -2184,16 +2184,19 @@ matches arbitrary non-symbol whitespace. Otherwise if LAX is non-nil, the beginning or the end of the string need not match a symbol boundary." (let ((not-word-symbol-re ;; This regexp matches all syntaxes except word and symbol syntax. - ;; FIXME: Replace it with something shorter if possible (bug#14602). - "\\(?:\\s-\\|\\s.\\|\\s(\\|\\s)\\|\\s\"\\|\\s\\\\|\\s/\\|\\s$\\|\\s'\\|\\s<\\|\\s>\\|\\s@\\|\\s!\\|\\s|\\)+")) + "\\(?:\\s-\\|\\s.\\|\\s(\\|\\s)\\|\\s\"\\|\\s\\\\|\\s/\\|\\s$\\|\\s'\\|\\s<\\|\\s>\\|\\s!\\|\\s|\\)+")) (cond ((equal string "") "") - ((string-match-p (format "\\`%s\\'" not-word-symbol-re) string) not-word-symbol-re) + ((string-match-p (format "\\`%s\\'" not-word-symbol-re) string) + not-word-symbol-re) (t (concat - (if (string-match-p (format "\\`%s" not-word-symbol-re) string) not-word-symbol-re + (if (string-match-p (format "\\`%s" not-word-symbol-re) string) + not-word-symbol-re "\\_<") - (mapconcat 'regexp-quote (split-string string not-word-symbol-re t) not-word-symbol-re) - (if (string-match-p (format "%s\\'" not-word-symbol-re) string) not-word-symbol-re + (mapconcat 'regexp-quote (split-string string not-word-symbol-re t) + not-word-symbol-re) + (if (string-match-p (format "%s\\'" not-word-symbol-re) string) + not-word-symbol-re (unless lax "\\_>"))))))) ;; Search with lax whitespace commit 4cd41ba8def704ce3bd2f3806176815fd696fa57 Author: Basil L. Contovounesios Date: Thu Jul 11 15:11:35 2019 +0100 Support reverting Apropos buffers (bug#36588) * lisp/apropos.el (apropos--current): New variable akin to help-xref-stack-item storing information for revert-buffer. (apropos--revert-buffer): New function. (apropos-mode): Use it as revert-buffer-function. (apropos-command, apropos, apropos-library, apropos-value) (apropos-local-value, apropos-documentation): Set apropos--current in low-level commands, i.e., those which do not call other commands. diff --git a/lisp/apropos.el b/lisp/apropos.el index 1b86f5bcde..79e5a1518f 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -212,6 +212,12 @@ docstring. Each docstring is either nil or a string.") Each element is a list of words where the first word is the standard Emacs term, and the rest of the words are alternative terms.") +(defvar apropos--current nil + "List of current Apropos function followed by its arguments. +Used by `apropos--revert-buffer' to regenerate the current +Apropos buffer. Each Apropos command should ensure it is set +before `apropos-mode' makes it buffer-local.") + ;;; Button types used by apropos @@ -472,10 +478,18 @@ This requires at least two keywords (unless only one was given)." "Return t if DOC is really matched by the current keywords." (apropos-true-hit doc apropos-all-words)) +(defun apropos--revert-buffer (_ignore-auto noconfirm) + "Regenerate current Apropos buffer using `apropos--current'. +Intended as a value for `revert-buffer-function'." + (when (or noconfirm (yes-or-no-p "Revert apropos buffer? ")) + (apply #'funcall apropos--current))) + (define-derived-mode apropos-mode special-mode "Apropos" "Major mode for following hyperlinks in output of apropos commands. -\\{apropos-mode-map}") +\\{apropos-mode-map}" + (make-local-variable 'apropos--current) + (setq-local revert-buffer-function #'apropos--revert-buffer)) (defvar apropos-multi-type t "If non-nil, this apropos query concerns multiple types. @@ -550,6 +564,7 @@ while a list of strings is used as a word list." (if (or current-prefix-arg apropos-do-all) "command or function" "command")) current-prefix-arg)) + (setq apropos--current (list #'apropos-command pattern do-all var-predicate)) (apropos-parse-pattern pattern) (let ((message (let ((standard-output (get-buffer-create "*Apropos*"))) @@ -628,6 +643,7 @@ consider all symbols (if they match PATTERN). Returns list of symbols and documentation found." (interactive (list (apropos-read-pattern "symbol") current-prefix-arg)) + (setq apropos--current (list #'apropos pattern do-all)) (apropos-parse-pattern pattern) (apropos-symbols-internal (apropos-internal apropos-regexp @@ -670,6 +686,7 @@ the output includes key-bindings of commands." libs)) libs))) (list (completing-read "Describe library: " libs nil t)))) + (setq apropos--current (list #'apropos-library file)) (let ((symbols nil) ;; (autoloads nil) (provides nil) @@ -776,6 +793,7 @@ names and values of properties. Returns list of symbols and values found." (interactive (list (apropos-read-pattern "value") current-prefix-arg)) + (setq apropos--current (list #'apropos-value pattern do-all)) (apropos-parse-pattern pattern) (or do-all (setq do-all apropos-do-all)) (setq apropos-accumulator ()) @@ -815,6 +833,7 @@ This is like `apropos-value', but only for buffer-local variables. Optional arg BUFFER (default: current buffer) is the buffer to check." (interactive (list (apropos-read-pattern "value of buffer-local variable"))) (unless buffer (setq buffer (current-buffer))) + (setq apropos--current (list #'apropos-local-value pattern buffer)) (apropos-parse-pattern pattern) (setq apropos-accumulator ()) (let ((var nil)) @@ -856,6 +875,7 @@ Returns list of symbols and documentation found." ;; output, but I cannot see that that is true. (interactive (list (apropos-read-pattern "documentation") current-prefix-arg)) + (setq apropos--current (list #'apropos-documentation pattern do-all)) (apropos-parse-pattern pattern) (or do-all (setq do-all apropos-do-all)) (setq apropos-accumulator () apropos-files-scanned ()) commit a5b796a8798a809044d847568e6472cc5eca077e Author: Paul Eggert Date: Sun Aug 4 11:39:03 2019 -0700 Fix 2019-08-04 regex lint Problem reported by Mattias Engdegård in: https://lists.gnu.org/r/emacs-devel/2019-08/msg00085.html * lisp/calendar/diary-lib.el (diary-glob-file-regexp-prefix): Omit unnecessary ‘\’ before ordinary char. * lisp/cedet/inversion.el (inversion-decoders): * lisp/org/ob-haskell.el (org-babel-haskell-export-to-lhs): Omit unnecessary ‘?’ after nullable pattern. * lisp/org/org-capture.el (org-capture-fill-template): Match upper-case as well as lower-case letters. * lisp/progmodes/cc-mode.el (c-before-change-check-unbalanced-strings) (c-after-change-mark-abnormal-strings): Simplify ‘.|\r’ to ‘.’. * lisp/progmodes/gdb-mi.el (gdb-jsonify-buffer): Put ‘-’ at end of bracket expression. diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el index a0e90c439b..06f1161b44 100644 --- a/lisp/calendar/diary-lib.el +++ b/lisp/calendar/diary-lib.el @@ -109,7 +109,7 @@ are: `string', `symbol', `int', `tnil', `stringtnil.'" :tag "A string, t, or nil")))) :group 'diary) -(defcustom diary-glob-file-regexp-prefix "^\\#" +(defcustom diary-glob-file-regexp-prefix "^#" "Regular expression pre-pended to `diary-face-attrs' for file-wide specifiers." :type 'regexp :group 'diary) diff --git a/lisp/cedet/inversion.el b/lisp/cedet/inversion.el index c62a57ee48..3bed9d7053 100644 --- a/lisp/cedet/inversion.el +++ b/lisp/cedet/inversion.el @@ -79,9 +79,9 @@ (defconst inversion-decoders '( - (alpha "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.?\\([0-9]*\\)?\\s-*\\.?alpha\\([0-9]+\\)?$" 4) - (beta "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.?\\([0-9]*\\)?\\s-*\\.?beta\\([0-9]+\\)?$" 4) - (beta "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.?\\([0-9]*\\)?\\s-*\\.?(beta\\([0-9]+\\)?)$" 4) + (alpha "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.?\\([0-9]*\\)\\s-*\\.?alpha\\([0-9]+\\)?$" 4) + (beta "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.?\\([0-9]*\\)\\s-*\\.?beta\\([0-9]+\\)?$" 4) + (beta "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.?\\([0-9]*\\)\\s-*\\.?(beta\\([0-9]+\\)?)$" 4) (beta "^[^/]+/\\w+--\\w+--\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)--patch-\\([0-9]+\\)" 4) (beta "^\\w+: v\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)-\\([0-9]+\\)-\\(.*\\)" 5) (prerelease "^\\([0-9]+\\)\\.\\([0-9]+\\)\\s-*\\.?pre\\([0-9]+\\)?$" 3) diff --git a/lisp/org/ob-haskell.el b/lisp/org/ob-haskell.el index 3c0a102fb2..50d1b57969 100644 --- a/lisp/org/ob-haskell.el +++ b/lisp/org/ob-haskell.el @@ -160,7 +160,7 @@ constructs (header arguments, no-web syntax etc...) are ignored." (interactive "P") (let* ((contents (buffer-string)) (haskell-regexp - (concat "^\\([ \t]*\\)#\\+begin_src[ \t]haskell*\\(.*\\)?[\r\n]" + (concat "^\\([ \t]*\\)#\\+begin_src[ \t]haskell*\\(.*\\)[\r\n]" "\\([^\000]*?\\)[\r\n][ \t]*#\\+end_src.*")) (base-name (file-name-sans-extension (buffer-file-name))) (tmp-file (org-babel-temp-file "haskell-")) diff --git a/lisp/org/org-capture.el b/lisp/org/org-capture.el index cbcf6c72f9..829872c382 100644 --- a/lisp/org/org-capture.el +++ b/lisp/org/org-capture.el @@ -1683,7 +1683,7 @@ The template may still contain \"%?\" for cursor positioning." (org-capture-expand-embedded-elisp 'mark) ;; Expand non-interactive templates. - (let ((regexp "%\\(:[-a-za-z]+\\|<\\([^>\n]+\\)>\\|[aAcfFikKlntTuUx]\\)")) + (let ((regexp "%\\(:[-A-Za-z]+\\|<\\([^>\n]+\\)>\\|[aAcfFikKlntTuUx]\\)")) (save-excursion (while (re-search-forward regexp nil t) ;; `org-capture-escaped-%' may modify buffer and cripple diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index 60a9de5ddb..76f5de212f 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -1397,7 +1397,7 @@ Note that the style variables are always made local to the buffer." ;; Move to end of logical line (as it will be after the change, or as it ;; was before unescaping a NL.) - (re-search-forward "\\(\\\\\\(.\\|\n\\|\r\\)\\|[^\\\n\r]\\)*" nil t) + (re-search-forward "\\(\\\\\\(.\\|\n\\)\\|[^\\\n\r]\\)*" nil t) ;; We're at an EOLL or point-max. (if (equal (c-get-char-property (point) 'syntax-table) '(15)) (if (memq (char-after) '(?\n ?\r)) @@ -1505,7 +1505,7 @@ Note that the style variables are always made local to the buffer." (progn (goto-char (min (1+ end) ; 1+, in case a NL has become escaped. (point-max))) - (re-search-forward "\\(\\\\\\(.\\|\n\\|\r\\)\\|[^\\\n\r]\\)*" + (re-search-forward "\\(\\\\\\(.\\|\n\\)\\|[^\\\n\r]\\)*" nil t) (point)) c-new-END)) diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index 439e0dfc62..48c7dde9f5 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -2714,7 +2714,7 @@ If `default-directory' is remote, full file names are adapted accordingly." (insert "]")))))) (goto-char (point-min)) (insert "{") - (let ((re (concat "\\([[:alnum:]-_]+\\)="))) + (let ((re (concat "\\([[:alnum:]_-]+\\)="))) (while (re-search-forward re nil t) (replace-match "\"\\1\":" nil nil) (if (eq (char-after) ?\") (forward-sexp) (forward-char)))) commit 7748ef218cd7a9cffa984d165abe261cd60fae1a Author: Paul Eggert Date: Sun Aug 4 10:04:18 2019 -0700 Tweak time arithmetic performance * src/timefns.c (lispint_arith): New function, which should be a bit faster if B is 0, or if A is a bignum and B a fixnum with absolute value in unsigned long range. (time_arith): Use it. diff --git a/src/timefns.c b/src/timefns.c index cce9dd51ba..ee43014979 100644 --- a/src/timefns.c +++ b/src/timefns.c @@ -965,6 +965,37 @@ lisp_seconds_argument (Lisp_Object specified_time) return t.tv_sec; } +/* Return the sum of the Lisp integers A and B. + Subtract instead of adding if SUBTRACT. + This function is tuned for small B. */ +static Lisp_Object +lispint_arith (Lisp_Object a, Lisp_Object b, bool subtract) +{ + bool mpz_done = false; + + if (FASTER_TIMEFNS && FIXNUMP (b)) + { + if (EQ (b, make_fixnum (0))) + return a; + if (FIXNUMP (a)) + return make_int (subtract + ? XFIXNUM (a) - XFIXNUM (b) + : XFIXNUM (a) + XFIXNUM (b)); + if (eabs (XFIXNUM (b)) <= ULONG_MAX) + { + ((XFIXNUM (b) < 0) == subtract ? mpz_add_ui : mpz_sub_ui) + (mpz[0], XBIGNUM (a)->value, eabs (XFIXNUM (b))); + mpz_done = true; + } + } + + if (!mpz_done) + (subtract ? mpz_sub : mpz_add) (mpz[0], + *bignum_integer (&mpz[0], a), + *bignum_integer (&mpz[1], b)); + return make_integer_mpz (); +} + /* Given Lisp operands A and B, add their values, and return the result as a Lisp timestamp that is in (TICKS . HZ) form if either A or B are in that form, (HI LO US PS) form otherwise. Subtract @@ -989,18 +1020,7 @@ time_arith (Lisp_Object a, Lisp_Object b, bool subtract) if (FASTER_TIMEFNS && EQ (ta.hz, tb.hz)) { hz = ta.hz; - if (FIXNUMP (ta.ticks) && FIXNUMP (tb.ticks)) - ticks = make_int (subtract - ? XFIXNUM (ta.ticks) - XFIXNUM (tb.ticks) - : XFIXNUM (ta.ticks) + XFIXNUM (tb.ticks)); - else - { - (subtract ? mpz_sub : mpz_add) - (mpz[0], - *bignum_integer (&mpz[0], ta.ticks), - *bignum_integer (&mpz[1], tb.ticks)); - ticks = make_integer_mpz (); - } + ticks = lispint_arith (ta.ticks, tb.ticks, subtract); } else { commit 5f3f3884a0d2a88101d330b82ef5b584cfc02aa6 Author: Paul Eggert Date: Sun Aug 4 09:57:27 2019 -0700 Improve time function doc * doc/misc/emacs-mime.texi (time-date): Don’t give parse-iso8601-time-string in the example, as the function is not autoloaded. * lisp/gnus/nndiary.el (nndiary-compute-reminders): No need to call encode-time or use floating point here. diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index b3444838d3..7bb9833467 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -1559,7 +1559,7 @@ or more arguments. The first six arguments @var{second}, specify most of the components of a decoded time. If there are more than six arguments the @emph{last} argument is used as @var{zone} and any other extra arguments are ignored, so that @code{(apply -#\\='encode-time (decode-time ...))} works; otherwise @var{zone} defaults +#'encode-time (decode-time ...))} works; otherwise @var{zone} defaults to the current time zone rule (@pxref{Time Zone Rules}). The decoded time's @var{dst} component is treated as if it was @minus{}1, and @var{form} takes its default value. @@ -1581,7 +1581,7 @@ You can perform simple date arithmetic by using out-of-range values for for example, day 0 means the day preceding the given month. The operating system puts limits on the range of possible time values; -if you try to encode a time that is out of range, an error results. +if the limits are exceeded while encoding the time, an error results. For instance, years before 1970 do not work on some systems; on others, years as early as 1901 do work. @end defun diff --git a/doc/misc/emacs-mime.texi b/doc/misc/emacs-mime.texi index 6e95013c18..1f384f4f27 100644 --- a/doc/misc/emacs-mime.texi +++ b/doc/misc/emacs-mime.texi @@ -1541,10 +1541,6 @@ Here's a bunch of time/date/second/day examples: 1000000) @result{} (905595714000000 . 1000000) -(encode-time (parse-iso8601-time-string "1998-09-12T12:21:54+0200") - 1000000) -@result{} (905595714000000 . 1000000) - (float-time '(905595714000000 . 1000000)) @result{} 905595714.0 @@ -1627,7 +1623,7 @@ These are the functions available: Take a date and return a time. @item float-time -Take a time and return seconds. (This is a built-in function.) +Take a time and return seconds. @item encode-time Take seconds (and other ways to represent time, notably decoded time diff --git a/lisp/calendar/iso8601.el b/lisp/calendar/iso8601.el index c69156cbeb..30352c7e75 100644 --- a/lisp/calendar/iso8601.el +++ b/lisp/calendar/iso8601.el @@ -138,7 +138,7 @@ well as variants like \"2008W32\" (week number) and date))) (defun iso8601-parse-date (string) - "Parse STRING (which should be on ISO 8601 format) and return a time value." + "Parse STRING (in ISO 8601 format) and return a decoded time value." (cond ;; Just a year: [-+]YYYY. ((iso8601--match iso8601--year-match string) diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index 5b82b8ab0f..c0565b3cfb 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -374,8 +374,8 @@ January 1st being 1." (defun decoded-time-add (time delta) "Add DELTA to TIME, both of which are `decoded-time' structures. -TIME should represent a time, while DELTA should only have -non-nil integers for the values that should be altered. +TIME should represent a time, while DELTA should have non-nil +entries only for the values that should be altered. For instance, if you want to \"add two months\" to TIME, then leave all other fields but the month field in DELTA nil, and make diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index 2ad0634e6a..8cda5aa703 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -1278,27 +1278,27 @@ all. This may very well take some time.") (cond ((eq (cdr reminder) 'minute) (time-subtract (apply #'encode-time 0 (nthcdr 1 date-elts)) - (encode-time (* (car reminder) 60.0)))) + (* (car reminder) 60))) ((eq (cdr reminder) 'hour) (time-subtract (apply #'encode-time 0 0 (nthcdr 2 date-elts)) - (encode-time (* (car reminder) 3600.0)))) + (* (car reminder) 3600))) ((eq (cdr reminder) 'day) (time-subtract (apply #'encode-time 0 0 0 (nthcdr 3 date-elts)) - (encode-time (* (car reminder) 86400.0)))) + (* (car reminder) 86400))) ((eq (cdr reminder) 'week) (time-subtract (apply #'encode-time 0 0 0 monday (nthcdr 4 date-elts)) - (encode-time (* (car reminder) 604800.0)))) + (* (car reminder) 604800))) ((eq (cdr reminder) 'month) (time-subtract (apply #'encode-time 0 0 0 1 (nthcdr 4 date-elts)) - (encode-time (* (car reminder) 18748800.0)))) + (* (car reminder) 18748800))) ((eq (cdr reminder) 'year) (time-subtract (apply #'encode-time 0 0 0 1 1 (nthcdr 5 date-elts)) - (encode-time (* (car reminder) 400861056.0))))) + (* (car reminder) 400861056)))) res)) (sort res 'time-less-p))) diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el index 5526d624f9..95f208baf9 100644 --- a/lisp/net/soap-client.el +++ b/lisp/net/soap-client.el @@ -636,6 +636,7 @@ disallows them." (error "Invalid or unsupported time: %s" date-time-string)) ;; Return a value in a format similar to that returned by decode-time, and ;; suitable for (apply #'encode-time ...). + ;; FIXME: Nobody uses this idiosyncratic value. Perhaps stop returning it? (list second minute hour day month year second-fraction datatype (if has-time-zone (* (rng-xsd-time-to-seconds diff --git a/lisp/org/org-id.el b/lisp/org/org-id.el index 44cc7b2f14..8f9c132ad3 100644 --- a/lisp/org/org-id.el +++ b/lisp/org/org-id.el @@ -412,9 +412,12 @@ The input I may be a character, or a single-letter string." r)) (defun org-id-time-to-b36 (&optional time) - "Encode TIME as a 10-digit string. + "Encode TIME as a 12-digit string. This string holds the time to micro-second accuracy, and can be decoded using `org-id-decode'." + ;; FIXME: If TIME represents N seconds after the epoch, then + ;; this encoding assumes 0 <= N < 110075314176 = (* (expt 36 4) 65536), + ;; i.e., that TIME is from 1970-01-01 00:00:00 to 5458-02-23 20:09:36 UTC. (setq time (encode-time time 'list)) (concat (org-id-int-to-b36 (nth 0 time) 4) (org-id-int-to-b36 (nth 1 time) 4) @@ -423,7 +426,7 @@ using `org-id-decode'." (defun org-id-decode (id) "Split ID into the prefix and the time value that was used to create it. The return value is (prefix . time) where PREFIX is nil or a string, -and time is the usual three-integer representation of time." +and TIME is a Lisp time value (HI LO USEC)." (let (prefix time parts) (setq parts (org-split-string id ":")) (if (= 2 (length parts)) commit f01597a43ea2eac38cfbb829f301c2e6e3bcbe83 Author: Eli Zaretskii Date: Sun Aug 4 19:38:08 2019 +0300 Fix the MS-Windows build broken by recent changes * src/inotify.c (syms_of_inotify) : Don't define here... * src/coding.c (syms_of_coding) : ...define it here, because it is needed also on platforms that don't compile inotify.c. diff --git a/src/coding.c b/src/coding.c index 877177b188..2ddd34eb7b 100644 --- a/src/coding.c +++ b/src/coding.c @@ -11684,6 +11684,8 @@ syms_of_coding (void) symbol as a coding system. */ DEFSYM (Qcoding_system_define_form, "coding-system-define-form"); + DEFSYM (Qignored, "ignored"); + defsubr (&Scoding_system_p); defsubr (&Sread_coding_system); defsubr (&Sread_non_nil_coding_system); diff --git a/src/inotify.c b/src/inotify.c index e8891aefc7..7c1d699ce3 100644 --- a/src/inotify.c +++ b/src/inotify.c @@ -530,7 +530,10 @@ syms_of_inotify (void) DEFSYM (Qdont_follow, "dont-follow"); /* IN_DONT_FOLLOW */ DEFSYM (Qonlydir, "onlydir"); /* IN_ONLYDIR */ +#if 0 + /* Defined in coding.c, which uses it on all platforms. */ DEFSYM (Qignored, "ignored"); /* IN_IGNORED */ +#endif DEFSYM (Qisdir, "isdir"); /* IN_ISDIR */ DEFSYM (Qq_overflow, "q-overflow"); /* IN_Q_OVERFLOW */ DEFSYM (Qunmount, "unmount"); /* IN_UNMOUNT */ commit 3c459e3b05e699736b849cb2c4687aef3ce6810b Author: Paul Eggert Date: Sun Aug 4 09:18:46 2019 -0700 Minor fix to recent coding.c change * src/coding.c (get_buffer_gap_address): Don’t assume string or buffer length fits in int. Also, improve wording of comments. diff --git a/src/coding.c b/src/coding.c index ab0e15119f..877177b188 100644 --- a/src/coding.c +++ b/src/coding.c @@ -9520,7 +9520,7 @@ code_convert_string_norecord (Lisp_Object string, Lisp_Object coding_system, NBYTES, enlarge the gap in advance. */ static unsigned char * -get_buffer_gap_address (Lisp_Object buffer, int nbytes) +get_buffer_gap_address (Lisp_Object buffer, ptrdiff_t nbytes) { struct buffer *buf = XBUFFER (buffer); @@ -9546,9 +9546,9 @@ get_buffer_gap_address (Lisp_Object buffer, int nbytes) static unsigned char * get_char_bytes (int c, int *len) { - /* We uses two chaches considering the situation that - encode/decode_string_utf_8 are called repeatedly with the same - values for HANDLE_8_BIT and HANDLE_OVER_UNI arguments. */ + /* Use two caches, since encode/decode_string_utf_8 are called + repeatedly with the same values for HANDLE_8_BIT and + HANDLE_OVER_UNI arguments. */ static int chars[2]; static unsigned char bytes[2][6]; static int nbytes[2]; @@ -9572,55 +9572,51 @@ get_char_bytes (int c, int *len) /* Encode STRING by the coding system utf-8-unix. - Even if :pre-write-conversion and :encode-translation-table - properties are put to that coding system, they are ignored. + Ignore any :pre-write-conversion and :encode-translation-table + properties of that coding system. - It ignores :pre-write-conversion and :encode-translation-table - propeties of that coding system. - - This function assumes that arguments have values as described - below. The validity must be assured by callers. + Assume that arguments have values as described below. + The validity must be assured by callers. STRING is a multibyte string or an ASCII-only unibyte string. BUFFER is a unibyte buffer or Qnil. - If BUFFER is a unibyte buffer, the encoding result of UTF-8 - sequence is inserted after point of the buffer, and the number of - inserted characters is returned. Note that a caller should have - made BUFFER ready for modifying in advance (e.g. by calling - invalidate_buffer_caches). + If BUFFER is a unibyte buffer, insert the encoded result + after point of the buffer, and return the number of + inserted characters. The caller should have made BUFFER ready for + modifying in advance (e.g., by calling invalidate_buffer_caches). - If BUFFER is Qnil, a unibyte string is made from the encodnig - result of UTF-8 sequence, and it is returned. If NOCOPY and STRING - contains only Unicode characters (i.e. the encoding does not change - the byte sequence), STRING is returned even if it is multibyte. + If BUFFER is Qnil, return a unibyte string from the encoded result. + If NOCOPY, and if STRING contains only Unicode characters (i.e., + the encoding does not change the byte sequence), return STRING even + if it is multibyte. - HANDLE-8-BIT and HANDE-OVER-UNI specify how to handle a non-Unicode + HANDLE-8-BIT and HANDLE-OVER-UNI specify how to handle a non-Unicode character. The former is for an eight-bit character (represented - by 2-byte overlong sequence in multibyte STRING). The latter is - for an over-unicode character (a character whose code is greater - than the maximum Unicode character 0x10FFFF, and is represented by - 4 or 5-byte sequence in multibyte STRING). + by a 2-byte overlong sequence in a multibyte STRING). The latter is + for an over-Unicode character (a character whose code is greater + than the maximum Unicode character 0x10FFFF, represented by a 4 or + 5-byte sequence in a multibyte STRING). - If they are unibyte strings (typically "\357\277\275"; UTF-8 - sequence for the Unicode REPLACEMENT CHARACTER #xFFFD), a - non-Unicode character is encoded into that sequence. + If these two arguments are unibyte strings (typically + "\357\277\275", the UTF-8 sequence for the Unicode REPLACEMENT + CHARACTER #xFFFD), encode a non-Unicode character into that + unibyte sequence. - If they are characters, a non-Unicode chracters is encoded into the - corresponding UTF-8 sequences. + If the two arguments are characters, encode a non-Unicode + character as if it was the argument. - If they are Qignored, a non-Unicode character is skipped on - encoding. + If they are Qignored, skip a non-Unicode character. - If HANDLE-8-BIT is Qt, an eight-bit character is encoded into one + If HANDLE-8-BIT is Qt, encode an eight-bit character into one byte of the same value. - If HANDLE-OVER-UNI is Qt, an over-unicode character is encoded + If HANDLE-OVER-UNI is Qt, encode an over-unicode character into the the same 4 or 5-byte sequence. - If they are Qnil, Qnil is returned if STRING has a non-Unicode - character. */ + If the two arguments are Qnil, return Qnil if STRING has a + non-Unicode character. */ Lisp_Object encode_string_utf_8 (Lisp_Object string, Lisp_Object buffer, @@ -9633,7 +9629,7 @@ encode_string_utf_8 (Lisp_Object string, Lisp_Object buffer, return string; ptrdiff_t num_8_bit = 0; /* number of eight-bit chars in STRING */ - /* The following two vars are counted only if handle_over_uni is not Qt */ + /* The following two vars are counted only if handle_over_uni is not Qt. */ ptrdiff_t num_over_4 = 0; /* number of 4-byte non-Unicode chars in STRING */ ptrdiff_t num_over_5 = 0; /* number of 5-byte non-Unicode chars in STRING */ ptrdiff_t outbytes; /* number of bytes of decoding result. */ @@ -9828,25 +9824,23 @@ encode_string_utf_8 (Lisp_Object string, Lisp_Object buffer, /* Decode STRING by the coding system utf-8-unix. - Even if :post-read-conversion and :decode-translation-table - properties are put to that coding system, they are ignored. + Ignore any :pre-write-conversion and :encode-translation-table + properties of that coding system. - This function assumes that arguments have values as described - below. The validity must be assured by callers. + Assumes that arguments have values as described below. + The validity must be assured by callers. STRING is a unibyte string or an ASCII-only multibyte string. BUFFER is a multibyte buffer or Qnil. - If BUFFER is a multibyte buffer, the decoding result of Unicode - characters are inserted after point of the buffer, and the number - of inserted characters is returned. Note that a caller should have - made BUFFER ready for modifying in advance (e.g. by calling - invalidate_buffer_caches). + If BUFFER is a multibyte buffer, insert the decoding result of + Unicode characters after point of the buffer, and return the number + of inserted characters. The caller should have made BUFFER ready + for modifying in advance (e.g., by calling invalidate_buffer_caches). - If BUFFER is Qnil, a multibyte string is made from the decoding - result of Unicode characters, and it is returned. As a special - case, STRING itself is returned in the following cases: + If BUFFER is Qnil, return a multibyte string from the decoded result. + As a special case, return STRING itself in the following cases: 1. STRING contains only ASCII characters. 2. NOCOPY, and STRING contains only valid UTF-8 sequences. @@ -9858,24 +9852,26 @@ encode_string_utf_8 (Lisp_Object string, Lisp_Object buffer, than #x10FFFF). Note that this function does not treat an overlong UTF-8 sequence as invalid. - If they are strings (typically 1-char string of the Unicode - REPLACEMENT CHARACTER #xFFFD), an invalid sequence is decoded into - that string. They must be multibyte strings if they contain a - non-ASCII character. + If these two arguments are strings (typically a 1-char string of + the Unicode REPLACEMENT CHARACTER #xFFFD), decode an invalid byte + sequence into that string. They must be multibyte strings if they + contain a non-ASCII character. - If they are characters, an invalid sequence is decoded into the - corresponding multibyte representation of the characters. + If the two arguments are characters, decode an invalid byte + sequence into the corresponding multibyte representation of the + characters. - If they are Qignored, an invalid sequence is skipped on decoding. + If they are Qignored, skip an invalid byte sequence. - If HANDLE-8-BIT is Qt, an 1-byte invalid sequence is deoded into + If HANDLE-8-BIT is Qt, decode a 1-byte invalid sequence into the corresponding eight-bit character. - If HANDLE-OVER-UNI is Qt, a 4 or 5-byte invalid sequence that - follows Emacs' representation for an over-unicode character is - decoded into the corresponding character. + If HANDLE-OVER-UNI is Qt, decode a 4 or 5-byte invalid sequence + that follows Emacs' representation for an over-unicode character + into the corresponding character. - If they are Qnil, Qnil is returned if STRING has an invalid sequence. */ + If the two arguments are Qnil, return Qnil if STRING has an invalid + sequence. */ Lisp_Object decode_string_utf_8 (Lisp_Object string, Lisp_Object buffer, @@ -9883,7 +9879,7 @@ decode_string_utf_8 (Lisp_Object string, Lisp_Object buffer, Lisp_Object handle_over_uni) { /* This is like BYTES_BY_CHAR_HEAD, but it is assured that C >= 0x80 - and it returns 0 for invalid sequence. */ + and it returns 0 for an invalid sequence. */ #define UTF_8_SEQUENCE_LENGTH(c) \ ((c) < 0xC2 ? 0 \ : (c) < 0xE0 ? 2 \ @@ -9924,7 +9920,8 @@ decode_string_utf_8 (Lisp_Object string, Lisp_Object buffer, && (len == 3 || (UTF_8_EXTRA_OCTET_P (p[3]) && len == 4 - && string_char (p, NULL, NULL) <= MAX_UNICODE_CHAR))))) + && (string_char (p, NULL, NULL) + <= MAX_UNICODE_CHAR)))))) { p += len; continue; commit 1b20993baaeffa5aa69b282862b5066960604aab Author: Michael Albinus Date: Sun Aug 4 16:43:25 2019 +0200 * .dir-locals.el: Enable `bug-reference-mode' for further major modes. diff --git a/.dir-locals.el b/.dir-locals.el index ffd65c8802..35dc154375 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -5,18 +5,23 @@ (c-mode . ((c-file-style . "GNU") (c-noise-macro-names . ("INLINE" "ATTRIBUTE_NO_SANITIZE_UNDEFINED" "UNINIT" "CALLBACK" "ALIGN_STACK")) (electric-quote-comment . nil) - (electric-quote-string . nil))) + (electric-quote-string . nil) + (mode . bug-reference-prog))) (objc-mode . ((c-file-style . "GNU") (electric-quote-comment . nil) - (electric-quote-string . nil))) + (electric-quote-string . nil) + (mode . bug-reference-prog))) (log-edit-mode . ((log-edit-font-lock-gnu-style . t) (log-edit-setup-add-author . t))) (change-log-mode . ((add-log-time-zone-rule . t) (fill-column . 74) - (eval . (bug-reference-mode)))) + (mode . bug-reference))) (diff-mode . ((mode . whitespace))) (emacs-lisp-mode . ((indent-tabs-mode . nil) (electric-quote-comment . nil) - (electric-quote-string . nil))) + (electric-quote-string . nil) + (mode . bug-reference-prog))) (texinfo-mode . ((electric-quote-comment . nil) - (electric-quote-string . nil)))) + (electric-quote-string . nil) + (mode . bug-reference-prog))) + (outline-mode . ((mode . bug-reference)))) commit 21ada03d30dd90775523ef12caf76440d91831ba Author: Lars Ingebrigtsen Date: Sun Aug 4 14:50:07 2019 +0200 Capitalise a couple of node names * doc/lispref/functions.texi (Advising Functions): Capitalise node names (bug#17717). (Advice Combinators, Porting Old Advice): Capitalise. diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index c86f7f3dfb..1f844478f7 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -574,8 +574,8 @@ Advising Emacs Lisp Functions * Core Advising Primitives:: Primitives to manipulate advice. * Advising Named Functions:: Advising named functions. -* Advice combinators:: Ways to compose advice. -* Porting old advice:: Adapting code using the old defadvice. +* Advice Combinators:: Ways to compose advice. +* Porting Old Advice:: Adapting code using the old defadvice. Macros diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index 28da3cfb99..e65d398c43 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -1645,8 +1645,8 @@ ways to do it. The added function is also called a piece of @emph{advice}. @menu * Core Advising Primitives:: Primitives to manipulate advice. * Advising Named Functions:: Advising named functions. -* Advice combinators:: Ways to compose advice. -* Porting old advice:: Adapting code using the old defadvice. +* Advice Combinators:: Ways to compose advice. +* Porting Old Advice:: Adapting code using the old defadvice. @end menu @node Core Advising Primitives @@ -1659,7 +1659,7 @@ stored in @var{place} (@pxref{Generalized Variables}). @var{where} determines how @var{function} is composed with the existing function, e.g., whether @var{function} should be called before, or -after the original function. @xref{Advice combinators}, for the list of +after the original function. @xref{Advice Combinators}, for the list of available ways to compose the two functions. When modifying a variable (whose name will usually end with @code{-function}), @@ -1834,7 +1834,7 @@ named function @var{symbol}. @var{function} is called with two arguments: the advice function and its properties. @end defun -@node Advice combinators +@node Advice Combinators @subsection Ways to compose advice Here are the different possible values for the @var{where} argument of @@ -1947,7 +1947,7 @@ More specifically, the composition of the two functions behaves like: @end table -@node Porting old advice +@node Porting Old Advice @subsection Adapting code using the old defadvice @cindex old advices, porting @c NB: The following index entries deliberately avoid ``old'', commit bbb41a2071824415d8cf3127d0e3bcd706f5a420 Author: Michael Heerdegen Date: Sun Aug 4 14:43:43 2019 +0200 Clarify macroexp-let* doc string * lisp/emacs-lisp/macroexp.el (macroexp-let2*): Clarify doc string (bug#19371). diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index d27cc0a63c..72198c4400 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -406,7 +406,10 @@ cases where EXP is a constant." ,bodysym))))) (defmacro macroexp-let2* (test bindings &rest body) - "Bind each binding in BINDINGS as `macroexp-let2' does." + "Multiple binding version of `macroexp-let2'. + +BINDINGS is a list of elements of the form (SYM EXP). Each EXP +can refer to symbols specified earlier in the binding list." (declare (indent 2) (debug (sexp (&rest (sexp form)) body))) (pcase-exhaustive bindings ('nil (macroexp-progn body)) commit 9b7d25e481ebe2085aafbac983106d210b469b3a Merge: a8026dfde9 151a99cca9 Author: K. Handa Date: Sun Aug 4 21:15:27 2019 +0900 Merge branch 'master' of git.sv.gnu.org:/srv/git/emacs commit a8026dfde9734a03ad03a9872ec801871dd1d81a Author: K. Handa Date: Sun Aug 4 21:14:26 2019 +0900 Add Unicode-safe UTF-8 converter * src/coding.c (encode_string_utf_8, decode_string_utf_8): New functions. * src/coding.h (encode_string_utf_8, decode_string_utf_8): Extern them. diff --git a/src/coding.c b/src/coding.c index 189a4b39d1..ab0e15119f 100644 --- a/src/coding.c +++ b/src/coding.c @@ -9515,6 +9515,732 @@ code_convert_string_norecord (Lisp_Object string, Lisp_Object coding_system, return code_convert_string (string, coding_system, Qt, encodep, 0, 1); } + +/* Return the gap address of BUFFER. If the gap size is less than + NBYTES, enlarge the gap in advance. */ + +static unsigned char * +get_buffer_gap_address (Lisp_Object buffer, int nbytes) +{ + struct buffer *buf = XBUFFER (buffer); + + if (BUF_GPT (buf) != BUF_PT (buf)) + { + struct buffer *oldb = current_buffer; + + current_buffer = buf; + move_gap_both (PT, PT_BYTE); + current_buffer = oldb; + } + if (BUF_GAP_SIZE (buf) < nbytes) + make_gap_1 (buf, nbytes); + return BUF_GPT_ADDR (buf); +} + +/* Return a pointer to the byte sequence for C, and set the length in + LEN. This function is used to get a byte sequence for HANDLE_8_BIT + and HANDLE_OVER_UNI arguments of encode_string_utf_8 and + decode_string_utf_8 when those arguments are given by + characters. */ + +static unsigned char * +get_char_bytes (int c, int *len) +{ + /* We uses two chaches considering the situation that + encode/decode_string_utf_8 are called repeatedly with the same + values for HANDLE_8_BIT and HANDLE_OVER_UNI arguments. */ + static int chars[2]; + static unsigned char bytes[2][6]; + static int nbytes[2]; + static int last_index; + + if (chars[last_index] == c) + { + *len = nbytes[last_index]; + return bytes[last_index]; + } + if (chars[1 - last_index] == c) + { + *len = nbytes[1 - last_index]; + return bytes[1 - last_index]; + } + last_index = 1 - last_index; + chars[last_index] = c; + *len = nbytes[last_index] = CHAR_STRING (c, bytes[last_index]); + return bytes[last_index]; +} + +/* Encode STRING by the coding system utf-8-unix. + + Even if :pre-write-conversion and :encode-translation-table + properties are put to that coding system, they are ignored. + + It ignores :pre-write-conversion and :encode-translation-table + propeties of that coding system. + + This function assumes that arguments have values as described + below. The validity must be assured by callers. + + STRING is a multibyte string or an ASCII-only unibyte string. + + BUFFER is a unibyte buffer or Qnil. + + If BUFFER is a unibyte buffer, the encoding result of UTF-8 + sequence is inserted after point of the buffer, and the number of + inserted characters is returned. Note that a caller should have + made BUFFER ready for modifying in advance (e.g. by calling + invalidate_buffer_caches). + + If BUFFER is Qnil, a unibyte string is made from the encodnig + result of UTF-8 sequence, and it is returned. If NOCOPY and STRING + contains only Unicode characters (i.e. the encoding does not change + the byte sequence), STRING is returned even if it is multibyte. + + HANDLE-8-BIT and HANDE-OVER-UNI specify how to handle a non-Unicode + character. The former is for an eight-bit character (represented + by 2-byte overlong sequence in multibyte STRING). The latter is + for an over-unicode character (a character whose code is greater + than the maximum Unicode character 0x10FFFF, and is represented by + 4 or 5-byte sequence in multibyte STRING). + + If they are unibyte strings (typically "\357\277\275"; UTF-8 + sequence for the Unicode REPLACEMENT CHARACTER #xFFFD), a + non-Unicode character is encoded into that sequence. + + If they are characters, a non-Unicode chracters is encoded into the + corresponding UTF-8 sequences. + + If they are Qignored, a non-Unicode character is skipped on + encoding. + + If HANDLE-8-BIT is Qt, an eight-bit character is encoded into one + byte of the same value. + + If HANDLE-OVER-UNI is Qt, an over-unicode character is encoded + into the the same 4 or 5-byte sequence. + + If they are Qnil, Qnil is returned if STRING has a non-Unicode + character. */ + +Lisp_Object +encode_string_utf_8 (Lisp_Object string, Lisp_Object buffer, + bool nocopy, Lisp_Object handle_8_bit, + Lisp_Object handle_over_uni) +{ + ptrdiff_t nchars = SCHARS (string), nbytes = SBYTES (string); + if (NILP (buffer) && nchars == nbytes) + /* STRING contains only ASCII characters. */ + return string; + + ptrdiff_t num_8_bit = 0; /* number of eight-bit chars in STRING */ + /* The following two vars are counted only if handle_over_uni is not Qt */ + ptrdiff_t num_over_4 = 0; /* number of 4-byte non-Unicode chars in STRING */ + ptrdiff_t num_over_5 = 0; /* number of 5-byte non-Unicode chars in STRING */ + ptrdiff_t outbytes; /* number of bytes of decoding result. */ + unsigned char *p = SDATA (string); + unsigned char *pend = p + nbytes; + unsigned char *src = NULL, *dst = NULL; + unsigned char *replace_8_bit = NULL, *replace_over_uni = NULL; + int replace_8_bit_len = 0, replace_over_uni_len = 0; + Lisp_Object val; /* the return value */ + + /* Scan bytes in STRING twice. The first scan is to count non-Unicode + characters, and the second scan is to encode STRING. If the + encoding is trivial (no need of changing the byte sequence), + the second scan is avoided. */ + for (int scan_count = 0; scan_count < 2; scan_count++) + { + while (p < pend) + { + if (nchars == pend - p) + /* There is no multibyte character remaining. */ + break; + + int c = *p; + int len = BYTES_BY_CHAR_HEAD (c); + + nchars--; + if (len == 1 + || len == 3 + || (len == 2 ? ! CHAR_BYTE8_HEAD_P (c) + : (EQ (handle_over_uni, Qt) + || (len == 4 + && string_char (p, NULL, NULL) <= MAX_UNICODE_CHAR)))) + { + p += len; + continue; + } + + /* A character to change the byte sequence on encoding was + found. A rare case. */ + if (len == 2) + { + /* Handle an eight-bit character by handle_8_bit. */ + if (scan_count == 0) + { + if (NILP (handle_8_bit)) + return Qnil; + num_8_bit++; + } + else + { + if (src < p) + { + memcpy (dst, src, p - src); + dst += p - src; + } + if (replace_8_bit_len > 0) + { + memcpy (dst, replace_8_bit, replace_8_bit_len); + dst += replace_8_bit_len; + } + else if (EQ (handle_8_bit, Qt)) + { + int char8 = STRING_CHAR (p); + *dst++ = CHAR_TO_BYTE8 (char8); + } + } + } + else /* len == 4 or 5 */ + { + /* Handle an over-unicode character by handle_over_uni. */ + if (scan_count == 0) + { + if (NILP (handle_over_uni)) + return Qnil; + if (len == 4) + num_over_4++; + else + num_over_5++; + } + else + { + if (src < p) + { + memcpy (dst, src, p - src); + dst += p - src; + } + if (replace_over_uni_len > 0) + { + memcpy (dst, replace_over_uni, replace_over_uni_len); + dst += replace_over_uni_len; + } + } + } + p += len; + src = p; + } + + if (scan_count == 0) + { + /* End of the first scane */ + outbytes = nbytes; + if (num_8_bit == 0 + && (num_over_4 + num_over_5 == 0 || EQ (handle_over_uni, Qt))) + { + /* We can break the loop because there is no need of + changing the byte sequence. This is the typical + case. */ + scan_count = 1; + } + else + { + /* Prepare for the next scan to handle non-Unicode characters. */ + if (num_8_bit > 0) + { + if (CHARACTERP (handle_8_bit)) + replace_8_bit = get_char_bytes (XFIXNUM (handle_8_bit), + &replace_8_bit_len); + else if (STRINGP (handle_8_bit)) + { + replace_8_bit = SDATA (handle_8_bit); + replace_8_bit_len = SBYTES (handle_8_bit); + } + if (replace_8_bit) + outbytes += (replace_8_bit_len - 2) * num_8_bit; + else if (EQ (handle_8_bit, Qignored)) + outbytes -= 2 * num_8_bit; + else if (EQ (handle_8_bit, Qt)) + outbytes -= num_8_bit; + else + return Qnil; + } + if (num_over_4 + num_over_5 > 0) + { + if (CHARACTERP (handle_over_uni)) + replace_over_uni = get_char_bytes (XFIXNUM (handle_over_uni), + &replace_over_uni_len); + else if (STRINGP (handle_over_uni)) + { + replace_over_uni = SDATA (handle_over_uni); + replace_over_uni_len = SBYTES (handle_over_uni); + } + if (num_over_4 > 0) + { + if (replace_over_uni) + outbytes += (replace_over_uni_len - 4) * num_over_4; + else if (EQ (handle_over_uni, Qignored)) + outbytes -= 4 * num_over_4; + else if (! EQ (handle_over_uni, Qt)) + return Qnil; + } + if (num_over_5 > 0) + { + if (replace_over_uni) + outbytes += (replace_over_uni_len - 5) * num_over_5; + else if (EQ (handle_over_uni, Qignored)) + outbytes -= 5 * num_over_5; + else if (! EQ (handle_over_uni, Qt)) + return Qnil; + } + } + } + + /* Prepare a return value and a space to store the encoded bytes. */ + if (BUFFERP (buffer)) + { + val = make_fixnum (outbytes); + dst = get_buffer_gap_address (buffer, nbytes); + } + else + { + if (nocopy && (num_8_bit + num_over_4 + num_over_5) == 0) + return string; + val = make_uninit_string (outbytes); + dst = SDATA (val); + } + p = src = SDATA (string); + } + } + + if (src < pend) + memcpy (dst, src, pend - src); + if (BUFFERP (buffer)) + { + struct buffer *oldb = current_buffer; + + current_buffer = XBUFFER (buffer); + insert_from_gap (outbytes, outbytes, false); + current_buffer = oldb; + } + return val; +} + +/* Decode STRING by the coding system utf-8-unix. + + Even if :post-read-conversion and :decode-translation-table + properties are put to that coding system, they are ignored. + + This function assumes that arguments have values as described + below. The validity must be assured by callers. + + STRING is a unibyte string or an ASCII-only multibyte string. + + BUFFER is a multibyte buffer or Qnil. + + If BUFFER is a multibyte buffer, the decoding result of Unicode + characters are inserted after point of the buffer, and the number + of inserted characters is returned. Note that a caller should have + made BUFFER ready for modifying in advance (e.g. by calling + invalidate_buffer_caches). + + If BUFFER is Qnil, a multibyte string is made from the decoding + result of Unicode characters, and it is returned. As a special + case, STRING itself is returned in the following cases: + 1. STRING contains only ASCII characters. + 2. NOCOPY, and STRING contains only valid UTF-8 sequences. + + HANDLE-8-BIT and HANDLE-OVER-UNI specify how to handle a invalid + byte sequence. The former is for an 1-byte invalid sequence that + violates the fundamental UTF-8 encoding rule. The latter is for a + 4 or 5-byte invalid sequence that Emacs internally uses to + represent an over-unicode character (a character of code greater + than #x10FFFF). Note that this function does not treat an overlong + UTF-8 sequence as invalid. + + If they are strings (typically 1-char string of the Unicode + REPLACEMENT CHARACTER #xFFFD), an invalid sequence is decoded into + that string. They must be multibyte strings if they contain a + non-ASCII character. + + If they are characters, an invalid sequence is decoded into the + corresponding multibyte representation of the characters. + + If they are Qignored, an invalid sequence is skipped on decoding. + + If HANDLE-8-BIT is Qt, an 1-byte invalid sequence is deoded into + the corresponding eight-bit character. + + If HANDLE-OVER-UNI is Qt, a 4 or 5-byte invalid sequence that + follows Emacs' representation for an over-unicode character is + decoded into the corresponding character. + + If they are Qnil, Qnil is returned if STRING has an invalid sequence. */ + +Lisp_Object +decode_string_utf_8 (Lisp_Object string, Lisp_Object buffer, + bool nocopy, Lisp_Object handle_8_bit, + Lisp_Object handle_over_uni) +{ + /* This is like BYTES_BY_CHAR_HEAD, but it is assured that C >= 0x80 + and it returns 0 for invalid sequence. */ +#define UTF_8_SEQUENCE_LENGTH(c) \ + ((c) < 0xC2 ? 0 \ + : (c) < 0xE0 ? 2 \ + : (c) < 0xF0 ? 3 \ + : (c) < 0xF8 ? 4 \ + : (c) == 0xF8 ? 5 \ + : 0) + + ptrdiff_t nbytes = SBYTES (string); + unsigned char *p = SDATA (string), *pend = p + nbytes; + ptrdiff_t num_8_bit = 0; /* number of invalid 1-byte sequences. */ + ptrdiff_t num_over_4 = 0; /* number of invalid 4-byte sequences. */ + ptrdiff_t num_over_5 = 0; /* number of invalid 5-byte sequences. */ + ptrdiff_t outbytes = nbytes; /* number of decoded bytes. */ + ptrdiff_t outchars = 0; /* number of decoded characters. */ + unsigned char *src = NULL, *dst = NULL; + bool change_byte_sequence = false; + + /* Scan bytes in STRING twice. The first scan is to count invalid + sequences, and the second scan is to decode STRING. If the + decoding is trivial (no need of changing the byte sequence), + the second scan is avoided. */ + while (p < pend) + { + src = p; + /* Try short cut for an ASCII-only case. */ + while (p < pend && *p < 0x80) p++; + outchars += (p - src); + if (p == pend) + break; + int c = *p; + outchars++; + int len = UTF_8_SEQUENCE_LENGTH (c); + /* len == 0, 2, 3, 4, 5 */ + if (UTF_8_EXTRA_OCTET_P (p[1]) + && (len == 2 + || (UTF_8_EXTRA_OCTET_P (p[2]) + && (len == 3 + || (UTF_8_EXTRA_OCTET_P (p[3]) + && len == 4 + && string_char (p, NULL, NULL) <= MAX_UNICODE_CHAR))))) + { + p += len; + continue; + } + + /* A sequence to change on decoding was found. A rare case. */ + if (len == 0) + { + if (NILP (handle_8_bit)) + return Qnil; + num_8_bit++; + len = 1; + } + else /* len == 4 or 5 */ + { + if (NILP (handle_over_uni)) + return Qnil; + if (len == 4) + num_over_4++; + else + num_over_5++; + } + change_byte_sequence = true; + p += len; + } + + Lisp_Object val; /* the return value. */ + + if (! change_byte_sequence + && NILP (buffer)) + { + if (nocopy) + return string; + val = make_uninit_multibyte_string (outchars, outbytes); + memcpy (SDATA (val), SDATA (string), pend - SDATA (string)); + return val; + } + + /* Count the number of resulting chars and bytes. */ + unsigned char *replace_8_bit = NULL, *replace_over_uni = NULL; + int replace_8_bit_len = 0, replace_over_uni_len = 0; + + if (change_byte_sequence) + { + if (num_8_bit > 0) + { + if (CHARACTERP (handle_8_bit)) + replace_8_bit = get_char_bytes (XFIXNUM (handle_8_bit), + &replace_8_bit_len); + else if (STRINGP (handle_8_bit)) + { + replace_8_bit = SDATA (handle_8_bit); + replace_8_bit_len = SBYTES (handle_8_bit); + } + if (replace_8_bit) + outbytes += (replace_8_bit_len - 1) * num_8_bit; + else if (EQ (handle_8_bit, Qignored)) + { + outbytes -= num_8_bit; + outchars -= num_8_bit; + } + else /* EQ (handle_8_bit, Qt)) */ + outbytes += num_8_bit; + } + else if (num_over_4 + num_over_5 > 0) + { + if (CHARACTERP (handle_over_uni)) + replace_over_uni = get_char_bytes (XFIXNUM (handle_over_uni), + &replace_over_uni_len); + else if (STRINGP (handle_over_uni)) + { + replace_over_uni = SDATA (handle_over_uni); + replace_over_uni_len = SBYTES (handle_over_uni); + } + if (num_over_4 > 0) + { + if (replace_over_uni) + outbytes += (replace_over_uni_len - 4) * num_over_4; + else if (EQ (handle_over_uni, Qignored)) + { + outbytes -= 4 * num_over_4; + outchars -= num_over_4; + } + } + if (num_over_5 > 0) + { + if (replace_over_uni) + outbytes += (replace_over_uni_len - 5) * num_over_5; + else if (EQ (handle_over_uni, Qignored)) + { + outbytes -= 5 * num_over_5; + outchars -= num_over_5; + } + } + } + } + + /* Prepare a return value and a space to store the decoded bytes. */ + if (BUFFERP (buffer)) + { + val = make_fixnum (outchars); + dst = get_buffer_gap_address (buffer, outbytes); + } + else + { + if (nocopy && (num_8_bit + num_over_4 + num_over_5) == 0) + return string; + val = make_uninit_multibyte_string (outchars, outbytes); + dst = SDATA (val); + } + + src = SDATA (string); + if (change_byte_sequence) + { + p = src; + while (p < pend) + { + /* Try short cut for an ASCII-only case. */ + /* while (p < pend && *p < 0x80) p++; */ + /* if (p == pend) */ + /* break; */ + int c = *p; + if (c < 0x80) + { + p++; + continue; + } + int len = UTF_8_SEQUENCE_LENGTH (c); + if (len > 1) + { + int mlen; + for (mlen = 1; mlen < len && UTF_8_EXTRA_OCTET_P (p[mlen]); + mlen++); + if (mlen == len + && (len <= 3 + || (len == 4 + && string_char (p, NULL, NULL) <= MAX_UNICODE_CHAR) + || EQ (handle_over_uni, Qt))) + { + p += len; + continue; + } + } + + if (src < p) + { + memcpy (dst, src, p - src); + dst += p - src; + } + if (len == 0) + { + if (replace_8_bit) + { + memcpy (dst, replace_8_bit, replace_8_bit_len); + dst += replace_8_bit_len; + } + else if (EQ (handle_8_bit, Qt)) + { + dst += BYTE8_STRING (c, dst); + } + len = 1; + } + else /* len == 4 or 5 */ + { + /* Handle p[0]... by handle_over_uni */ + if (replace_over_uni) + { + memcpy (dst, replace_over_uni, replace_over_uni_len); + dst += replace_over_uni_len; + } + } + p += len; + src = p; + } + } + + if (src < pend) + memcpy (dst, src, pend - src); + if (BUFFERP (buffer)) + { + struct buffer *oldb = current_buffer; + + current_buffer = XBUFFER (buffer); + insert_from_gap (outchars, outbytes, false); + current_buffer = oldb; + } + return val; +} + +/* #define ENABLE_UTF_8_CONVERTER_TEST */ + +#ifdef ENABLE_UTF_8_CONVERTER_TEST + +/* These functions are useful for testing and benchmarking + encode_string_utf_8 and decode_string_utf_8. */ + +/* ENCODE_METHOD specifies which internal decoder to use. + If it is Qnil, use encode_string_utf_8. + Otherwise, use code_convert_string. + + COUNT, if integer, specifies how many times to call those functions + with the same arguments (for benchmarking). */ + +DEFUN ("internal-encode-string-utf-8", Finternal_encode_string_utf_8, + Sinternal_encode_string_utf_8, 7, 7, 0, + doc: /* Internal use only.*/) + (Lisp_Object string, Lisp_Object buffer, Lisp_Object nocopy, + Lisp_Object handle_8_bit, Lisp_Object handle_over_uni, + Lisp_Object encode_method, Lisp_Object count) +{ + int repeat_count; + Lisp_Object val; + + /* Check arguments. Return Qnil when an argmement is invalid. */ + if (! STRINGP (string)) + return Qnil; + if (! NILP (buffer) + && (! BUFFERP (buffer) + || ! NILP (BVAR (XBUFFER (buffer), enable_multibyte_characters)))) + return Qnil; + if (! NILP (handle_8_bit) && ! EQ (handle_8_bit, Qt) + && ! EQ (handle_8_bit, Qignored) + && ! CHARACTERP (handle_8_bit) + && (! STRINGP (handle_8_bit) || STRING_MULTIBYTE (handle_8_bit))) + return Qnil; + if (! NILP (handle_over_uni) && ! EQ (handle_over_uni, Qt) + && ! EQ (handle_over_uni, Qignored) + && ! CHARACTERP (handle_over_uni) + && (! STRINGP (handle_over_uni) || STRING_MULTIBYTE (handle_over_uni))) + return Qnil; + + CHECK_FIXNUM (count); + repeat_count = XFIXNUM (count); + + val = Qnil; + /* Run an encoder according to ENCODE_METHOD. */ + if (NILP (encode_method)) + { + for (int i = 0; i < repeat_count; i++) + val = encode_string_utf_8 (string, buffer, ! NILP (nocopy), + handle_8_bit, handle_over_uni); + } + else + { + for (int i = 0; i < repeat_count; i++) + val = code_convert_string (string, Qutf_8_unix, Qnil, true, + ! NILP (nocopy), true); + } + return val; +} + +/* DECODE_METHOD specifies which internal decoder to use. + If it is Qnil, use decode_string_utf_8. + If it is Qt, use code_convert_string. + Otherwise, use make_string_from_utf8. + + COUNT, if integer, specifies how many times to call those functions + with the same arguments (for benchmarking). */ + +DEFUN ("internal-decode-string-utf-8", Finternal_decode_string_utf_8, + Sinternal_decode_string_utf_8, 7, 7, 0, + doc: /* Internal use only.*/) + (Lisp_Object string, Lisp_Object buffer, Lisp_Object nocopy, + Lisp_Object handle_8_bit, Lisp_Object handle_over_uni, + Lisp_Object decode_method, Lisp_Object count) +{ + int repeat_count; + Lisp_Object val; + + /* Check arguments. Return Qnil when an argmement is invalid. */ + if (! STRINGP (string)) + return Qnil; + if (! NILP (buffer) + && (! BUFFERP (buffer) + || NILP (BVAR (XBUFFER (buffer), enable_multibyte_characters)))) + return Qnil; + if (! NILP (handle_8_bit) && ! EQ (handle_8_bit, Qt) + && ! EQ (handle_8_bit, Qignored) + && ! CHARACTERP (handle_8_bit) + && (! STRINGP (handle_8_bit) || ! STRING_MULTIBYTE (handle_8_bit))) + return Qnil; + if (! NILP (handle_over_uni) && ! EQ (handle_over_uni, Qt) + && ! EQ (handle_over_uni, Qignored) + && ! CHARACTERP (handle_over_uni) + && (! STRINGP (handle_over_uni) || ! STRING_MULTIBYTE (handle_over_uni))) + return Qnil; + + CHECK_FIXNUM (count); + repeat_count = XFIXNUM (count); + + val = Qnil; + /* Run a decoder according to DECODE_METHOD. */ + if (NILP (decode_method)) + { + for (int i = 0; i < repeat_count; i++) + val = decode_string_utf_8 (string, buffer, ! NILP (nocopy), + handle_8_bit, handle_over_uni); + } + else if (EQ (decode_method, Qt)) + { + if (! BUFFERP (buffer)) + buffer = Qt; + for (int i = 0; i < repeat_count; i++) + val = code_convert_string (string, Qutf_8_unix, buffer, false, + ! NILP (nocopy), true); + } + else if (! NILP (decode_method)) + { + for (int i = 0; i < repeat_count; i++) + val = make_string_from_utf8 ((char *) SDATA (string), SBYTES (string)); + } + return val; +} + +#endif /* ENABLE_UTF_8_CONVERTER_TEST */ + /* Encode or decode a file name, to or from a unibyte string suitable for passing to C library functions. */ Lisp_Object @@ -10974,6 +11700,10 @@ syms_of_coding (void) defsubr (&Sencode_coding_region); defsubr (&Sdecode_coding_string); defsubr (&Sencode_coding_string); +#ifdef ENABLE_UTF_8_CONVERTER_TEST + defsubr (&Sinternal_encode_string_utf_8); + defsubr (&Sinternal_decode_string_utf_8); +#endif /* ENABLE_UTF_8_CONVERTER_TEST */ defsubr (&Sdecode_sjis_char); defsubr (&Sencode_sjis_char); defsubr (&Sdecode_big5_char); diff --git a/src/coding.h b/src/coding.h index 70690d42d3..8efddbf55c 100644 --- a/src/coding.h +++ b/src/coding.h @@ -689,6 +689,10 @@ extern Lisp_Object code_convert_string (Lisp_Object, Lisp_Object, Lisp_Object, bool, bool, bool); extern Lisp_Object code_convert_string_norecord (Lisp_Object, Lisp_Object, bool); +extern Lisp_Object encode_string_utf_8 (Lisp_Object, Lisp_Object, bool, + Lisp_Object, Lisp_Object); +extern Lisp_Object decode_string_utf_8 (Lisp_Object, Lisp_Object, bool, + Lisp_Object, Lisp_Object); extern Lisp_Object encode_file_name (Lisp_Object); extern Lisp_Object decode_file_name (Lisp_Object); extern Lisp_Object raw_text_coding_system (Lisp_Object); commit 151a99cca92997dd4936e679c7efc2c2bafa0f72 Author: Lars Ingebrigtsen Date: Sun Aug 4 14:07:06 2019 +0200 Core Advising Primitives `interactive' clarification * doc/lispref/functions.texi (Core Advising Primitives): Clarify when the interactive spec is a function (bug#17871). diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index 6eb1af68de..28da3cfb99 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -1707,7 +1707,8 @@ If @var{function} is not interactive, then the combined function will inherit the interactive spec, if any, of the original function. Else, the combined function will be interactive and will use the interactive spec of @var{function}. One exception: if the interactive spec of @var{function} -is a function (rather than an expression or a string), then the interactive +is a function (i.e., a @code{lambda} expression or an @code{fbound} +symbol rather than an expression or a string), then the interactive spec of the combined function will be a call to that function with as sole argument the interactive spec of the original function. To interpret the spec received as argument, use @code{advice-eval-interactive-spec}. commit 2abcca23910d1fa5fe0bcac3ebc5b62df8e0a741 Author: Michael Albinus Date: Sun Aug 4 12:47:43 2019 +0200 Implement set-file-* functions for tramp-gvfs.el * lisp/net/tramp-gvfs.el (tramp-gvfs-gio-mapping): Add "gvfs-set-attribute". (tramp-gvfs-file-name-handler-alist): Add `tramp-gvfs-handle-set-file-modes', `tramp-gvfs-handle-set-file-times' and `tramp-gvfs-handle-set-file-uid-gid'. (tramp-gvfs-handle-set-file-modes) (tramp-gvfs-handle-set-file-times) (tramp-sh-handle-set-file-uid-gid): New defuns. * lisp/net/tramp.el (tramp-handle-write-region): Set file modes. * test/lisp/net/tramp-tests.el (tramp-test20-file-modes) (tramp-test22-file-times): Do not skip for tramp-gvfs.el. diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 9d45e6a8ce..a606ba6717 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -471,6 +471,7 @@ It has been changed in GVFS 1.14.") ("gvfs-mount" . "mount") ("gvfs-move" . "move") ("gvfs-rm" . "remove") + ("gvfs-set-attribute" . "set") ("gvfs-trash" . "trash")) "List of cons cells, mapping \"gvfs-\" to \"gio \".") @@ -590,15 +591,15 @@ It has been changed in GVFS 1.14.") (process-file . ignore) (rename-file . tramp-gvfs-handle-rename-file) (set-file-acl . ignore) - (set-file-modes . ignore) + (set-file-modes . tramp-gvfs-handle-set-file-modes) (set-file-selinux-context . ignore) - (set-file-times . ignore) + (set-file-times . tramp-gvfs-handle-set-file-times) (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) (shell-command . ignore) (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) - (tramp-set-file-uid-gid . ignore) + (tramp-set-file-uid-gid . tramp-gvfs-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) @@ -1325,6 +1326,48 @@ file-notify events." (tramp-run-real-handler #'rename-file (list filename newname ok-if-already-exists)))) +(defun tramp-gvfs-handle-set-file-modes (filename mode) + "Like `set-file-modes' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + (tramp-gvfs-send-command + v "gvfs-set-attribute" "-t" "uint32" + (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v)) + "unix::mode" (number-to-string mode)))) + +(defun tramp-gvfs-handle-set-file-times (filename &optional time) + "Like `set-file-times' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + (let ((time + (if (or (null time) + (tramp-compat-time-equal-p time tramp-time-doesnt-exist) + (tramp-compat-time-equal-p time tramp-time-dont-know)) + (current-time) + time))) + (tramp-gvfs-send-command + v "gvfs-set-attribute" "-t" "uint64" + (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v)) + "time::modified" (format-time-string "%s" time))))) + +(defun tramp-gvfs-set-file-uid-gid (filename &optional uid gid) + "Like `tramp-set-file-uid-gid' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) + (when (natnump uid) + (tramp-gvfs-send-command + v "gvfs-set-attribute" "-t" "uint32" + (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v)) + "unix::uid" (number-to-string uid))) + (when (natnump gid) + (tramp-gvfs-send-command + v "gvfs-set-attribute" "-t" "uint32" + (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v)) + "unix::gid" (number-to-string gid))))) + ;; File name conversions. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 717ced80f2..c589557132 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3772,9 +3772,16 @@ of." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (let ((tmpfile (tramp-compat-make-temp-file filename))) + (let ((tmpfile (tramp-compat-make-temp-file filename)) + (modes (save-excursion (tramp-default-file-modes filename)))) (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok)) + ;; The permissions of the temporary file should be set. If + ;; FILENAME does not exist (eq modes nil) it has been + ;; renamed to the backup file. This case `save-buffer' + ;; handles permissions. + ;; Ensure that it is still readable. + (set-file-modes tmpfile (logior (or modes 0) #o0400)) ;; We say `no-message' here because we don't want the visited file ;; modtime data to be clobbered from the temp file. We call ;; `set-visited-file-modtime' ourselves later on. diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 1404ef39d5..f60dea36bf 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -3143,7 +3143,13 @@ They might differ only in access time." "Check `file-modes'. This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-sh-p) (tramp--test-sudoedit-p))) + (skip-unless + (or (tramp--test-sh-p) (tramp--test-sudoedit-p) + ;; Not all tramp-gvfs.el methods support changing the file mode. + (and + (tramp--test-gvfs-p) + (string-match-p + "ftp" (file-remote-p tramp-test-temporary-file-directory 'method))))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) @@ -3443,7 +3449,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check `set-file-times' and `file-newer-than-file-p'." (skip-unless (tramp--test-enabled)) (skip-unless - (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sudoedit-p))) + (or (tramp--test-adb-p) (tramp--test-gvfs-p) + (tramp--test-sh-p) (tramp--test-sudoedit-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) commit 5ec3f70527e330abf4c0c3519fa4914c5f094358 Author: Martin Rudalics Date: Sun Aug 4 09:21:18 2019 +0200 Fix two mouse drag and drop issues (Bug#28620, Bug#36269) Allow 'mouse-drag-and-drop-region' to move/copy text from one frame to another (Bug#28620). Prevent mouse avoidance mode from interfering with 'mouse-drag-and-drop-region' (Bug#36269). * lisp/avoid.el (mouse-avoidance-ignore-p): Suspend avoidance when 'track-mouse' equals 'dropping'. * lisp/mouse.el (mouse-drag-and-drop-region): Set 'track-mouse' to 'dropping'. Continue reading events also when switching frames. * src/keyboard.c (Finternal_track_mouse): Rename from Ftrack_mouse. (some_mouse_moved): Return NULL also when mouse is not tracked. (show_help_echo, readable_events, kbd_buffer_get_event): Don't check whether mouse is tracked, some_mouse_moved does it now. (track_mouse): Rename variable from do_mouse_tracking. Adjust all users. In doc-string explain meanings of special values 'dragging' and 'dropping'. * src/nsterm.m (ns_mouse_position): During drag and drop consider last mouse frame only when there is no currently focused frame. * src/w32fns.c (w32_wnd_proc): Don't set mouse capture during a drag and drop operation. * src/w32term.c (w32_mouse_position): Track frame under mouse during mouse drag and drop. (mouse_or_wdesc_frame): New function. (w32_read_socket): Call mouse_or_wdesc_frame on mouse events. * src/xdisp.c (define_frame_cursor1): Don't change mouse cursor shape during mouse drag and drop. (syms_of_xdisp): New symbol Qdropping. * src/xterm.c (XTmouse_position): Allow mouse drag and drop move to another frame (mouse_or_wdesc_frame): New function. (handle_one_xevent): Use mouse_or_wdesc_frame for mouse events. diff --git a/lisp/avoid.el b/lisp/avoid.el index 7d69fa2a24..43e5062b76 100644 --- a/lisp/avoid.el +++ b/lisp/avoid.el @@ -327,6 +327,9 @@ redefine this function to suit your own tastes." executing-kbd-macro ; don't check inside macro (null (cadr mp)) ; don't move unless in an Emacs frame (not (eq (car mp) (selected-frame))) + ;; Don't interfere with ongoing `mouse-drag-and-drop-region' + ;; (Bug#36269). + (eq track-mouse 'dropping) ;; Don't do anything if last event was a mouse event. ;; FIXME: this code fails in the case where the mouse was moved ;; since the last key-press but without generating any event. diff --git a/lisp/mouse.el b/lisp/mouse.el index 4a532a15e5..e947e16d47 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -1296,7 +1296,7 @@ The region will be defined with mark and point." t (lambda () (setq track-mouse old-track-mouse) (setq auto-hscroll-mode auto-hscroll-mode-saved) - (deactivate-mark) + (deactivate-mark) (pop-mark))))) (defun mouse--drag-set-mark-and-point (start click click-count) @@ -2467,12 +2467,13 @@ is copied instead of being cut." (ignore-errors (track-mouse + (setq track-mouse 'dropping) ;; When event was "click" instead of "drag", skip loop. (while (progn (setq event (read-key)) ; read-event or read-key (or (mouse-movement-p event) ;; Handle `mouse-autoselect-window'. - (eq (car-safe event) 'select-window))) + (memq (car event) '(select-window switch-frame)))) ;; Obtain the dragged text in region. When the loop was ;; skipped, value-selection remains nil. (unless value-selection diff --git a/src/dispnew.c b/src/dispnew.c index 0131b63767..799ef2beae 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -3402,9 +3402,9 @@ update_window (struct window *w, bool force_p) if (!force_p) detect_input_pending_ignore_squeezables (); - /* If forced to complete the update, or if no input is pending, do - the update. */ - if (force_p || !input_pending || !NILP (do_mouse_tracking)) + /* If forced to complete the update, no input is pending, or we are + tracking the mouse, do the update. */ + if (force_p || !input_pending || !NILP (track_mouse)) { struct glyph_row *row, *end; struct glyph_row *mode_line_row; diff --git a/src/keyboard.c b/src/keyboard.c index db5ca4e547..30686a2589 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -1159,14 +1159,14 @@ DEFUN ("abort-recursive-edit", Fabort_recursive_edit, Sabort_recursive_edit, 0, user_error ("No recursive edit is in progress"); } -/* Restore mouse tracking enablement. See Ftrack_mouse for the only use - of this function. */ +/* Restore mouse tracking enablement. See Finternal_track_mouse for + the only use of this function. */ static void -tracking_off (Lisp_Object old_value) +tracking_off (Lisp_Object old_track_mouse) { - do_mouse_tracking = old_value; - if (NILP (old_value)) + track_mouse = old_track_mouse; + if (NILP (old_track_mouse)) { /* Redisplay may have been preempted because there was input available, and it assumes it will be called again after the @@ -1181,24 +1181,24 @@ tracking_off (Lisp_Object old_value) } } -DEFUN ("internal--track-mouse", Ftrack_mouse, Strack_mouse, 1, 1, 0, +DEFUN ("internal--track-mouse", Finternal_track_mouse, Sinternal_track_mouse, + 1, 1, 0, doc: /* Call BODYFUN with mouse movement events enabled. */) (Lisp_Object bodyfun) { ptrdiff_t count = SPECPDL_INDEX (); Lisp_Object val; - record_unwind_protect (tracking_off, do_mouse_tracking); + record_unwind_protect (tracking_off, track_mouse); - do_mouse_tracking = Qt; + track_mouse = Qt; val = call0 (bodyfun); return unbind_to (count, val); } -/* If mouse has moved on some frame, return one of those frames. - - Return 0 otherwise. +/* If mouse has moved on some frame and we are tracking the mouse, + return one of those frames. Return NULL otherwise. If ignore_mouse_drag_p is non-zero, ignore (implicit) mouse movement after resizing the tool-bar window. */ @@ -1210,11 +1210,8 @@ some_mouse_moved (void) { Lisp_Object tail, frame; - if (ignore_mouse_drag_p) - { - /* ignore_mouse_drag_p = false; */ - return 0; - } + if (NILP (track_mouse) || ignore_mouse_drag_p) + return NULL; FOR_EACH_FRAME (tail, frame) { @@ -1222,7 +1219,7 @@ some_mouse_moved (void) return XFRAME (frame); } - return 0; + return NULL; } @@ -2071,7 +2068,8 @@ show_help_echo (Lisp_Object help, Lisp_Object window, Lisp_Object object, This causes trouble if we are trying to read a mouse motion event (i.e., if we are inside a `track-mouse' form), so we restore the mouse_moved flag. */ - struct frame *f = NILP (do_mouse_tracking) ? NULL : some_mouse_moved (); + struct frame *f = some_mouse_moved (); + help = call1 (Qmouse_fixup_help_message, help); if (f) f->mouse_moved = true; @@ -3403,8 +3401,7 @@ readable_events (int flags) return 1; } - if (!(flags & READABLE_EVENTS_IGNORE_SQUEEZABLES) - && !NILP (do_mouse_tracking) && some_mouse_moved ()) + if (!(flags & READABLE_EVENTS_IGNORE_SQUEEZABLES) && some_mouse_moved ()) return 1; if (single_kboard) { @@ -3786,7 +3783,7 @@ kbd_buffer_get_event (KBOARD **kbp, if (kbd_fetch_ptr != kbd_store_ptr) break; - if (!NILP (do_mouse_tracking) && some_mouse_moved ()) + if (some_mouse_moved ()) break; /* If the quit flag is set, then read_char will return @@ -3802,7 +3799,7 @@ kbd_buffer_get_event (KBOARD **kbp, #endif if (kbd_fetch_ptr != kbd_store_ptr) break; - if (!NILP (do_mouse_tracking) && some_mouse_moved ()) + if (some_mouse_moved ()) break; if (end_time) { @@ -3941,8 +3938,9 @@ kbd_buffer_get_event (KBOARD **kbp, break; default: { - /* If this event is on a different frame, return a switch-frame this - time, and leave the event in the queue for next time. */ + /* If this event is on a different frame, return a + switch-frame this time, and leave the event in the queue + for next time. */ Lisp_Object frame; Lisp_Object focus; @@ -3956,14 +3954,13 @@ kbd_buffer_get_event (KBOARD **kbp, if (! NILP (focus)) frame = focus; - if (! EQ (frame, internal_last_event_frame) + if (!EQ (frame, internal_last_event_frame) && !EQ (frame, selected_frame)) obj = make_lispy_switch_frame (frame); internal_last_event_frame = frame; /* If we didn't decide to make a switch-frame event, go ahead and build a real event from the queue entry. */ - if (NILP (obj)) { obj = make_lispy_event (&event->ie); @@ -3995,7 +3992,7 @@ kbd_buffer_get_event (KBOARD **kbp, } } /* Try generating a mouse motion event. */ - else if (!NILP (do_mouse_tracking) && some_mouse_moved ()) + else if (some_mouse_moved ()) { struct frame *f = some_mouse_moved (); Lisp_Object bar_window; @@ -4027,7 +4024,7 @@ kbd_buffer_get_event (KBOARD **kbp, if (NILP (frame)) XSETFRAME (frame, f); - if (! EQ (frame, internal_last_event_frame) + if (!EQ (frame, internal_last_event_frame) && !EQ (frame, selected_frame)) obj = make_lispy_switch_frame (frame); internal_last_event_frame = frame; @@ -10935,7 +10932,7 @@ init_keyboard (void) recent_keys_index = 0; kbd_fetch_ptr = kbd_buffer; kbd_store_ptr = kbd_buffer; - do_mouse_tracking = Qnil; + track_mouse = Qnil; input_pending = false; interrupt_input_blocked = 0; pending_signals = false; @@ -11297,7 +11294,7 @@ syms_of_keyboard (void) defsubr (&Sread_key_sequence); defsubr (&Sread_key_sequence_vector); defsubr (&Srecursive_edit); - defsubr (&Strack_mouse); + defsubr (&Sinternal_track_mouse); defsubr (&Sinput_pending_p); defsubr (&Srecent_keys); defsubr (&Sthis_command_keys); @@ -11643,8 +11640,15 @@ and the minor mode maps regardless of `overriding-local-map'. */); doc: /* Keymap defining bindings for special events to execute at low level. */); Vspecial_event_map = list1 (Qkeymap); - DEFVAR_LISP ("track-mouse", do_mouse_tracking, - doc: /* Non-nil means generate motion events for mouse motion. */); + DEFVAR_LISP ("track-mouse", track_mouse, + doc: /* Non-nil means generate motion events for mouse motion. +The special values `dragging' and `dropping' assert that the mouse +cursor retains its appearance during mouse motion. Any non-nil value +but `dropping' asserts that motion events always relate to the frame +where the the mouse movement started. The value `dropping' asserts +that motion events relate to the frame where the mouse cursor is seen +when generating the event. If there's no such frame, such motion +events relate to the frame where the mouse movement started. */); DEFVAR_KBOARD ("system-key-alist", Vsystem_key_alist, doc: /* Alist of system-specific X windows key symbols. diff --git a/src/nsterm.m b/src/nsterm.m index b8754278f0..42ef4dd010 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -2480,7 +2480,11 @@ so some key presses (TAB) are swallowed by the system. */ XFRAME (frame)->mouse_moved = 0; dpyinfo->last_mouse_scroll_bar = nil; + f = dpyinfo->ns_focus_frame ? dpyinfo->ns_focus_frame : SELECTED_FRAME (); if (dpyinfo->last_mouse_frame + /* While dropping, use the last mouse frame only if there is no + currently focused frame. */ + && (!EQ (track_mouse, Qdropping) || !f) && FRAME_LIVE_P (dpyinfo->last_mouse_frame)) f = dpyinfo->last_mouse_frame; else diff --git a/src/term.c b/src/term.c index b058d8bdad..a88d47f923 100644 --- a/src/term.c +++ b/src/term.c @@ -3033,18 +3033,18 @@ read_menu_input (struct frame *sf, int *x, int *y, int min_y, int max_y, bool usable_input = 1; mi_result st = MI_CONTINUE; struct tty_display_info *tty = FRAME_TTY (sf); - Lisp_Object saved_mouse_tracking = do_mouse_tracking; + Lisp_Object old_track_mouse = track_mouse; /* Signal the keyboard reading routines we are displaying a menu on this terminal. */ tty->showing_menu = 1; /* We want mouse movements be reported by read_menu_command. */ - do_mouse_tracking = Qt; + track_mouse = Qt; do { cmd = read_menu_command (); } while (NILP (cmd)); tty->showing_menu = 0; - do_mouse_tracking = saved_mouse_tracking; + track_mouse = old_track_mouse; if (EQ (cmd, Qt) || EQ (cmd, Qtty_menu_exit) /* If some input switched frames under our feet, exit the diff --git a/src/w32fns.c b/src/w32fns.c index acd9c80528..a2a88b2588 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -4586,7 +4586,8 @@ w32_wnd_proc (HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) if (button_state & this) return 0; - if (button_state == 0) + /* Don't capture mouse when dropping. */ + if (button_state == 0 && !EQ (track_mouse, Qdropping)) SetCapture (hwnd); button_state |= this; @@ -4707,8 +4708,11 @@ w32_wnd_proc (HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) if (parse_button (msg, HIWORD (wParam), &button, &up)) { - if (up) ReleaseCapture (); - else SetCapture (hwnd); + if (up) + ReleaseCapture (); + /* Don't capture mouse when dropping. */ + else if (!EQ (track_mouse, Qdropping)) + SetCapture (hwnd); button = (button == 0) ? LMOUSE : ((button == 1) ? MMOUSE : RMOUSE); if (up) @@ -5351,8 +5355,9 @@ w32_wnd_proc (HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) else if (button_state & RMOUSE) flags |= TPM_RIGHTBUTTON; - /* Remember we did a SetCapture on the initial mouse down event, - so for safety, we make sure the capture is canceled now. */ + /* We may have done a SetCapture on the initial mouse down + event, so for safety, make sure the capture is canceled + now. */ ReleaseCapture (); button_state = 0; diff --git a/src/w32term.c b/src/w32term.c index c6e175e7e5..ad96287a43 100644 --- a/src/w32term.c +++ b/src/w32term.c @@ -3525,72 +3525,78 @@ w32_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, /* Now we have a position on the root; find the innermost window containing the pointer. */ - { - /* If mouse was grabbed on a frame, give coords for that - frame even if the mouse is now outside it. Otherwise - check for window under mouse on one of our frames. */ - if (gui_mouse_grabbed (dpyinfo)) - f1 = dpyinfo->last_mouse_frame; - else - { - HWND wfp = WindowFromPoint (pt); - if (wfp) - { - f1 = w32_window_to_frame (dpyinfo, wfp); - if (f1) - { - HWND cwfp = ChildWindowFromPoint (wfp, pt); + /* If mouse was grabbed on a frame and we are not dropping, + give coords for that frame even if the mouse is now outside + it. Otherwise check for window under mouse on one of our + frames. */ + if (gui_mouse_grabbed (dpyinfo) && !EQ (track_mouse, Qdropping)) + f1 = dpyinfo->last_mouse_frame; + else + { + HWND wfp = WindowFromPoint (pt); - if (cwfp) - { - struct frame *f2 = w32_window_to_frame (dpyinfo, cwfp); + if (wfp) + { + f1 = w32_window_to_frame (dpyinfo, wfp); + if (f1) + { + HWND cwfp = ChildWindowFromPoint (wfp, pt); - /* If a child window was found, make sure that its - frame is a child frame (Bug#26615, maybe). */ - if (f2 && FRAME_PARENT_FRAME (f2)) - f1 = f2; - } - } - } - } + if (cwfp) + { + struct frame *f2 = w32_window_to_frame (dpyinfo, cwfp); - /* If not, is it one of our scroll bars? */ - if (! f1) - { - struct scroll_bar *bar - = w32_window_to_scroll_bar (WindowFromPoint (pt), 2); + /* If a child window was found, make sure that its + frame is a child frame (Bug#26615, maybe). */ + if (f2 && FRAME_PARENT_FRAME (f2)) + f1 = f2; + } + } + } + } - if (bar) - f1 = XFRAME (WINDOW_FRAME (XWINDOW (bar->window))); - } + if (!f1 || FRAME_TOOLTIP_P (f1)) + /* Don't use a tooltip frame. */ + f1 = ((EQ (track_mouse, Qdropping) && gui_mouse_grabbed (dpyinfo)) + ? dpyinfo->last_mouse_frame + : NULL); - if (f1 == 0 && insist > 0) - f1 = SELECTED_FRAME (); + /* If not, is it one of our scroll bars? */ + if (!f1) + { + struct scroll_bar *bar + = w32_window_to_scroll_bar (WindowFromPoint (pt), 2); - if (f1) - { - /* Ok, we found a frame. Store all the values. - last_mouse_glyph is a rectangle used to reduce the - generation of mouse events. To not miss any motion - events, we must divide the frame into rectangles of the - size of the smallest character that could be displayed - on it, i.e. into the same rectangles that matrices on - the frame are divided into. */ - - dpyinfo = FRAME_DISPLAY_INFO (f1); - ScreenToClient (FRAME_W32_WINDOW (f1), &pt); - remember_mouse_glyph (f1, pt.x, pt.y, &dpyinfo->last_mouse_glyph); - dpyinfo->last_mouse_glyph_frame = f1; - - *bar_window = Qnil; - *part = scroll_bar_above_handle; - *fp = f1; - XSETINT (*x, pt.x); - XSETINT (*y, pt.y); - *time = dpyinfo->last_mouse_movement_time; - } - } + if (bar) + f1 = XFRAME (WINDOW_FRAME (XWINDOW (bar->window))); + } + + if (!f1 && insist > 0) + f1 = SELECTED_FRAME (); + + if (f1) + { + /* Ok, we found a frame. Store all the values. + last_mouse_glyph is a rectangle used to reduce the + generation of mouse events. To not miss any motion + events, we must divide the frame into rectangles of the + size of the smallest character that could be displayed + on it, i.e. into the same rectangles that matrices on + the frame are divided into. */ + + dpyinfo = FRAME_DISPLAY_INFO (f1); + ScreenToClient (FRAME_W32_WINDOW (f1), &pt); + remember_mouse_glyph (f1, pt.x, pt.y, &dpyinfo->last_mouse_glyph); + dpyinfo->last_mouse_glyph_frame = f1; + + *bar_window = Qnil; + *part = scroll_bar_above_handle; + *fp = f1; + XSETINT (*x, pt.x); + XSETINT (*y, pt.y); + *time = dpyinfo->last_mouse_movement_time; + } } unblock_input (); @@ -4667,6 +4673,37 @@ static short temp_buffer[100]; /* Temporarily store lead byte of DBCS input sequences. */ static char dbcs_lead = 0; +/** + mouse_or_wdesc_frame: When not dropping and the mouse was grabbed + for DPYINFO, return the frame where the mouse was seen last. If + there's no such frame, return the frame according to WDESC. When + dropping, return the frame according to WDESC. If there's no such + frame and the mouse was grabbed for DPYINFO, return the frame where + the mouse was seen last. In either case, never return a tooltip + frame. */ +static struct frame * +mouse_or_wdesc_frame (struct w32_display_info *dpyinfo, HWND wdesc) +{ + struct frame *lm_f = (gui_mouse_grabbed (dpyinfo) + ? dpyinfo->last_mouse_frame + : NULL); + + if (lm_f && !EQ (track_mouse, Qdropping)) + return lm_f; + else + { + struct frame *w_f = w32_window_to_frame (dpyinfo, wdesc); + + /* Do not return a tooltip frame. */ + if (!w_f || FRAME_TOOLTIP_P (w_f)) + return EQ (track_mouse, Qdropping) ? lm_f : NULL; + else + /* When dropping it would be probably nice to raise w_f + here. */ + return w_f; + } +} + /* Read events coming from the W32 shell. This routine is called by the SIGIO handler. We return as soon as there are no more events to be read. @@ -4940,15 +4977,13 @@ w32_read_socket (struct terminal *terminal, previous_help_echo_string = help_echo_string; help_echo_string = Qnil; - f = (gui_mouse_grabbed (dpyinfo) ? dpyinfo->last_mouse_frame - : w32_window_to_frame (dpyinfo, msg.msg.hwnd)); - if (hlinfo->mouse_face_hidden) { hlinfo->mouse_face_hidden = false; clear_mouse_face (hlinfo); } + f = mouse_or_wdesc_frame (dpyinfo, msg.msg.hwnd); if (f) { /* Maybe generate SELECT_WINDOW_EVENTs for @@ -5020,9 +5055,7 @@ w32_read_socket (struct terminal *terminal, int button = 0; int up = 0; - f = (gui_mouse_grabbed (dpyinfo) ? dpyinfo->last_mouse_frame - : w32_window_to_frame (dpyinfo, msg.msg.hwnd)); - + f = mouse_or_wdesc_frame (dpyinfo, msg.msg.hwnd); if (f) { w32_construct_mouse_click (&inev, &msg, f); @@ -5081,9 +5114,7 @@ w32_read_socket (struct terminal *terminal, case WM_MOUSEWHEEL: case WM_MOUSEHWHEEL: { - f = (gui_mouse_grabbed (dpyinfo) ? dpyinfo->last_mouse_frame - : w32_window_to_frame (dpyinfo, msg.msg.hwnd)); - + f = mouse_or_wdesc_frame (dpyinfo, msg.msg.hwnd); if (f) { if (!dpyinfo->w32_focus_frame @@ -5439,6 +5470,7 @@ w32_read_socket (struct terminal *terminal, if (any_help_event_p) do_help = -1; } + break; case WM_SETFOCUS: diff --git a/src/xdisp.c b/src/xdisp.c index 1bb5f5e0f2..7338d2b7d4 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -17289,7 +17289,7 @@ redisplay_window (Lisp_Object window, bool just_this_one_p) the mouse, resulting in an unwanted mouse-movement rather than a simple mouse-click. */ if (!w->start_at_line_beg - && NILP (do_mouse_tracking) + && NILP (track_mouse) && CHARPOS (startp) > BEGV && CHARPOS (startp) > BEG + beg_unchanged && CHARPOS (startp) <= Z - end_unchanged @@ -30279,7 +30279,7 @@ show_mouse_face (Mouse_HLInfo *hlinfo, enum draw_glyphs_face draw) #ifdef HAVE_WINDOW_SYSTEM /* Change the mouse cursor. */ - if (FRAME_WINDOW_P (f) && NILP (do_mouse_tracking)) + if (FRAME_WINDOW_P (f) && NILP (track_mouse)) { #ifndef HAVE_EXT_TOOL_BAR if (draw == DRAW_NORMAL_TEXT @@ -31226,7 +31226,7 @@ define_frame_cursor1 (struct frame *f, Emacs_Cursor cursor, Lisp_Object pointer) return; /* Do not change cursor shape while dragging mouse. */ - if (EQ (do_mouse_tracking, Qdragging)) + if (EQ (track_mouse, Qdragging) || EQ (track_mouse, Qdropping)) return; if (!NILP (pointer)) @@ -32956,6 +32956,7 @@ be let-bound around code that needs to disable messages temporarily. */); /* also Qtext */ DEFSYM (Qdragging, "dragging"); + DEFSYM (Qdropping, "dropping"); DEFSYM (Qinhibit_free_realized_faces, "inhibit-free-realized-faces"); diff --git a/src/xterm.c b/src/xterm.c index 75568a82a1..bbe68ef622 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -5196,20 +5196,15 @@ XTmouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, /* Figure out which root window we're on. */ XQueryPointer (FRAME_X_DISPLAY (*fp), DefaultRootWindow (FRAME_X_DISPLAY (*fp)), - /* The root window which contains the pointer. */ &root, - /* Trash which we can't trust if the pointer is on a different screen. */ &dummy_window, - /* The position on that root window. */ &root_x, &root_y, - /* More trash we can't trust. */ &dummy, &dummy, - /* Modifier keys and pointer buttons, about which we don't care. */ (unsigned int *) &dummy); @@ -5232,21 +5227,17 @@ XTmouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, x_catch_errors (FRAME_X_DISPLAY (*fp)); - if (gui_mouse_grabbed (dpyinfo)) + if (gui_mouse_grabbed (dpyinfo) && !EQ (track_mouse, Qdropping)) { /* If mouse was grabbed on a frame, give coords for that frame even if the mouse is now outside it. */ XTranslateCoordinates (FRAME_X_DISPLAY (*fp), - /* From-window. */ root, - /* To-window. */ FRAME_X_WINDOW (dpyinfo->last_mouse_frame), - /* From-position, to-position. */ root_x, root_y, &win_x, &win_y, - /* Child of win. */ &child); f1 = dpyinfo->last_mouse_frame; @@ -5256,16 +5247,12 @@ XTmouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, while (true) { XTranslateCoordinates (FRAME_X_DISPLAY (*fp), - /* From-window, to-window. */ root, win, - /* From-position, to-position. */ root_x, root_y, &win_x, &win_y, - /* Child of win. */ &child); - if (child == None || child == win) { #ifdef USE_GTK @@ -5328,13 +5315,35 @@ XTmouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, #endif /* USE_X_TOOLKIT */ } + if ((!f1 || FRAME_TOOLTIP_P (f1)) + && EQ (track_mouse, Qdropping) + && gui_mouse_grabbed (dpyinfo)) + { + /* When dropping then if we didn't get a frame or only a + tooltip frame and the mouse was grabbed on a frame, + give coords for that frame even if the mouse is now + outside it. */ + XTranslateCoordinates (FRAME_X_DISPLAY (*fp), + /* From-window. */ + root, + /* To-window. */ + FRAME_X_WINDOW (dpyinfo->last_mouse_frame), + /* From-position, to-position. */ + root_x, root_y, &win_x, &win_y, + /* Child of win. */ + &child); + f1 = dpyinfo->last_mouse_frame; + } + else if (f1 && FRAME_TOOLTIP_P (f1)) + f1 = NULL; + if (x_had_errors_p (FRAME_X_DISPLAY (*fp))) - f1 = 0; + f1 = NULL; x_uncatch_errors_after_check (); /* If not, is it one of our scroll bars? */ - if (! f1) + if (!f1) { struct scroll_bar *bar; @@ -5348,7 +5357,7 @@ XTmouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, } } - if (f1 == 0 && insist > 0) + if (!f1 && insist > 0) f1 = SELECTED_FRAME (); if (f1) @@ -7817,6 +7826,37 @@ flush_dirty_back_buffers (void) unblock_input (); } +/** + mouse_or_wdesc_frame: When not dropping and the mouse was grabbed + for DPYINFO, return the frame where the mouse was seen last. If + there's no such frame, return the frame according to WDESC. When + dropping, return the frame according to WDESC. If there's no such + frame and the mouse was grabbed for DPYINFO, return the frame where + the mouse was seen last. In either case, never return a tooltip + frame. */ +static struct frame * +mouse_or_wdesc_frame (struct x_display_info *dpyinfo, int wdesc) +{ + struct frame *lm_f = (gui_mouse_grabbed (dpyinfo) + ? dpyinfo->last_mouse_frame + : NULL); + + if (lm_f && !EQ (track_mouse, Qdropping)) + return lm_f; + else + { + struct frame *w_f = x_window_to_frame (dpyinfo, wdesc); + + /* Do not return a tooltip frame. */ + if (!w_f || FRAME_TOOLTIP_P (w_f)) + return EQ (track_mouse, Qdropping) ? lm_f : NULL; + else + /* When dropping it would be probably nice to raise w_f + here. */ + return w_f; + } +} + /* Handles the XEvent EVENT on display DPYINFO. *FINISH is X_EVENT_GOTO_OUT if caller should stop reading events. @@ -8749,15 +8789,14 @@ handle_one_xevent (struct x_display_info *dpyinfo, previous_help_echo_string = help_echo_string; help_echo_string = Qnil; - f = (gui_mouse_grabbed (dpyinfo) ? dpyinfo->last_mouse_frame - : x_window_to_frame (dpyinfo, event->xmotion.window)); - - if (hlinfo->mouse_face_hidden) + if (hlinfo->mouse_face_hidden) { hlinfo->mouse_face_hidden = false; clear_mouse_face (hlinfo); } + f = mouse_or_wdesc_frame (dpyinfo, event->xmotion.window); + #ifdef USE_GTK if (f && xg_event_is_for_scrollbar (f, event)) f = 0; @@ -8999,33 +9038,27 @@ handle_one_xevent (struct x_display_info *dpyinfo, dpyinfo->last_mouse_glyph_frame = NULL; x_display_set_last_user_time (dpyinfo, event->xbutton.time); - if (gui_mouse_grabbed (dpyinfo)) - f = dpyinfo->last_mouse_frame; - else + f = mouse_or_wdesc_frame (dpyinfo, event->xmotion.window); + if (f && event->xbutton.type == ButtonPress + && !popup_activated () + && !x_window_to_scroll_bar (event->xbutton.display, + event->xbutton.window, 2) + && !FRAME_NO_ACCEPT_FOCUS (f)) { - f = x_window_to_frame (dpyinfo, event->xbutton.window); + /* When clicking into a child frame or when clicking + into a parent frame with the child frame selected and + `no-accept-focus' is not set, select the clicked + frame. */ + struct frame *hf = dpyinfo->highlight_frame; - if (f && event->xbutton.type == ButtonPress - && !popup_activated () - && !x_window_to_scroll_bar (event->xbutton.display, - event->xbutton.window, 2) - && !FRAME_NO_ACCEPT_FOCUS (f)) + if (FRAME_PARENT_FRAME (f) || (hf && frame_ancestor_p (f, hf))) { - /* When clicking into a child frame or when clicking - into a parent frame with the child frame selected and - `no-accept-focus' is not set, select the clicked - frame. */ - struct frame *hf = dpyinfo->highlight_frame; - - if (FRAME_PARENT_FRAME (f) || (hf && frame_ancestor_p (f, hf))) - { - block_input (); - XSetInputFocus (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f), - RevertToParent, CurrentTime); - if (FRAME_PARENT_FRAME (f)) - XRaiseWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f)); - unblock_input (); - } + block_input (); + XSetInputFocus (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f), + RevertToParent, CurrentTime); + if (FRAME_PARENT_FRAME (f)) + XRaiseWindow (FRAME_X_DISPLAY (f), FRAME_OUTER_WINDOW (f)); + unblock_input (); } } commit 01661f33c11654d1fe5fe1013332db2500b7f449 Author: Noam Postavsky Date: Thu Jul 4 20:32:39 2019 -0400 Improved ChangeLog generation for vc log (Bug#16301) * lisp/vc/diff-mode.el (diff-find-source-location): Fix docstring. * lisp/vc/add-log.el (change-log-unindented-file-names-re) (change-log-read-entries, change-log-read-defuns) (change-log-insert-entries): * lisp/vc/diff-mode.el (diff-add-log-current-defuns): * lisp/vc/log-edit.el (log-edit--insert-filled-defuns) (log-edit-fill-entry): New functions. (log-edit-mode): Set `log-edit-fill-entry' as `fill-paragraph-function'. (log-edit-generate-changelog-from-diff): New command. (log-edit-mode-map): Bind it to C-c C-w. * doc/emacs/maintaining.texi (Types of Log File, Log Buffer): * CONTRIBUTE: Document it. * etc/NEWS: Announce it. * test/lisp/vc/log-edit-tests.el (log-edit-fill-entry) (log-edit-fill-entry-joining): New tests. diff --git a/CONTRIBUTE b/CONTRIBUTE index f257fc57f0..f480ffec9b 100644 --- a/CONTRIBUTE +++ b/CONTRIBUTE @@ -263,18 +263,22 @@ them right the first time, so here are guidelines for formatting them: ** Generating ChangeLog entries -- You can use Emacs functions to write ChangeLog entries; see +- If you use Emacs VC, you can use 'C-c C-w' to generate formatted + blank ChangeLog entries from the diff being committed, then use + 'M-q' to combine and fill them. See 'info "(emacs) Log Buffer"'. + +- Alternatively, you can use Emacs functions for ChangeLog files; see https://www.gnu.org/software/emacs/manual/html_node/emacs/Change-Log-Commands.html or run 'info "(emacs)Change Log Commands"'. -- If you use Emacs VC, one way to format ChangeLog entries is to create - a top-level ChangeLog file manually, and update it with 'C-x 4 a' as - usual. Do not register the ChangeLog file under git; instead, use - 'C-c C-a' to insert its contents into your *vc-log* buffer. - Or if 'log-edit-hook' includes 'log-edit-insert-changelog' (which it - does by default), they will be filled in for you automatically. + To format ChangeLog entries with Emacs VC, create a top-level + ChangeLog file manually, and update it with 'C-x 4 a' as usual. Do + not register the ChangeLog file under git; instead, use 'C-c C-a' to + insert its contents into your *vc-log* buffer. Or if + 'log-edit-hook' includes 'log-edit-insert-changelog' (which it does + by default), they will be filled in for you automatically. -- Alternatively, you can use the vc-dwim command to maintain commit +- Instead of Emacs VC, you can use the vc-dwim command to maintain commit messages. When you create a source directory, run the shell command 'git-changelog-symlink-init' to create a symbolic link from ChangeLog to .git/c/ChangeLog. Edit this ChangeLog via its symlink diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi index c3895bffb5..c6fe29ed27 100644 --- a/doc/emacs/maintaining.texi +++ b/doc/emacs/maintaining.texi @@ -396,8 +396,9 @@ policy, which you should follow. for each change just once, then put it into both logs. You can write the entry in @file{ChangeLog}, then copy it to the log buffer with @kbd{C-c C-a} when committing the change (@pxref{Log Buffer}). Or you -can write the entry in the log buffer while committing the change, and -later use the @kbd{C-x v a} command to copy it to @file{ChangeLog} +can write the entry in the log buffer while committing the change +(with the help of @kbd{C-c C-w}), and later use the @kbd{C-x v a} +command to copy it to @file{ChangeLog} @iftex (@pxref{Change Logs and VC,,,emacs-xtra, Specialized Emacs Features}). @end iftex @@ -677,6 +678,14 @@ of changes between the VC fileset and the version from which you started editing (@pxref{Old Revisions}), type @kbd{C-c C-d} (@code{log-edit-show-diff}). +@kindex C-c C-w @r{(Log Edit mode)} +@findex log-edit-generate-changelog + To help generate ChangeLog entries, type @kbd{C-c C-w} +(@code{log-edit-generate-changelog}), to generate skeleton ChangeLog +entries, listing all changed file and function names based on the diff +of the VC fileset. Consecutive entries left empty will be combined by +@kbd{C-q} (@code{fill-paragraph}). + @kindex C-c C-a @r{(Log Edit mode)} @findex log-edit-insert-changelog If the VC fileset includes one or more @file{ChangeLog} files diff --git a/etc/NEWS b/etc/NEWS index cefbe84fc8..0c7e421ed9 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -674,6 +674,10 @@ The default value is 'find-dired-sort-by-filename'. ** Change Logs and VC ++++ +*** New command 'log-edit-generate-changelog', bound to C-c C-w. +This generates ChangeLog entries from the VC fileset diff. + *** Recording ChangeLog entries doesn't require an actual file. If a ChangeLog file doesn't exist, and if the new variable 'add-log-dont-create-changelog-file' is non-nil (which is the diff --git a/lisp/vc/add-log.el b/lisp/vc/add-log.el index f9efd44c5c..47a68167fb 100644 --- a/lisp/vc/add-log.el +++ b/lisp/vc/add-log.el @@ -36,6 +36,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defgroup change-log nil "Change log maintenance." :group 'tools @@ -309,6 +311,43 @@ a case simply use the directory containing the changed file." (re-search-forward change-log-file-names-re nil t) (match-string-no-properties 2)))))) +(defconst change-log-unindented-file-names-re "^[*] \\([^ ,:([\n]+\\)") + +(defun change-log-read-entries (&optional end) + "Read ChangeLog entries at point until END. +Move point to the end of entries that were read. Return a list +in the same form as `diff-add-log-current-defuns'." + (cl-loop while (and (or (not end) (< (point) end)) + (looking-at change-log-unindented-file-names-re)) + do (goto-char (match-end 0)) + collect (cons (match-string-no-properties 1) + (change-log-read-defuns end)))) + +(defvar change-log-tag-re) ; add-log.el +(defun change-log-read-defuns (&optional end) + "Read ChangeLog formatted function names at point until END. +Move point to the end of names read and return the function names +as a list of strings." + (cl-loop while (and (skip-chars-forward ":\n[:blank:]" end) + (or (not end) (< (point) end)) + (looking-at change-log-tag-re)) + do (goto-char (match-end 0)) + nconc (split-string (match-string-no-properties 1) + ",[[:blank:]]*" t) + finally do (skip-chars-backward "\n[:blank:]"))) + +(defun change-log-insert-entries (changelogs) + "Format and insert CHANGELOGS into current buffer. +CHANGELOGS is a list in the form returned by +`diff-add-log-current-defuns'." + (cl-loop for (file . defuns) in changelogs do + (insert "* " file) + (if (not defuns) + (insert ":\n") + (insert " ") + (cl-loop for def in defuns + do (insert "(" def "):\n"))))) + (defun change-log-find-file () "Visit the file for the change under point." (interactive) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 0d5dc0e1c0..81662cafed 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -54,6 +54,7 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) (autoload 'vc-find-revision "vc") (autoload 'vc-find-revision-no-save "vc") @@ -1773,15 +1774,22 @@ Whitespace differences are ignored." (defsubst diff-xor (a b) (if a (if (not b) a) b)) (defun diff-find-source-location (&optional other-file reverse noprompt) - "Find out (BUF LINE-OFFSET POS SRC DST SWITCHED). + "Find current diff location within the source file. +OTHER-FILE, if non-nil, means to look at the diff's name and line + numbers for the old file. Furthermore, use `diff-vc-revisions' + if it's available. If `diff-jump-to-old-file' is non-nil, the + sense of this parameter is reversed. If the prefix argument is + 8 or more, `diff-jump-to-old-file' is set to OTHER-FILE. +REVERSE, if non-nil, switches the sense of SRC and DST (see below). +NOPROMPT, if non-nil, means not to prompt the user. +Return a list (BUF LINE-OFFSET (BEG . END) SRC DST SWITCHED). BUF is the buffer corresponding to the source file. LINE-OFFSET is the offset between the expected and actual positions of the text of the hunk or nil if the text was not found. -POS is a pair (BEG . END) indicating the position of the text in the buffer. +\(BEG . END) is a pair indicating the position of the text in the buffer. SRC and DST are the two variants of text as returned by `diff-hunk-text'. SRC is the variant that was found in the buffer. -SWITCHED is non-nil if the patch is already applied. -NOPROMPT, if non-nil, means not to prompt the user." +SWITCHED is non-nil if the patch is already applied." (save-excursion (let* ((other (diff-xor other-file diff-jump-to-old-file)) (char-offset (- (point) (diff-beginning-of-hunk t))) @@ -2210,6 +2218,121 @@ Call FUN with two args (BEG and END) for each hunk." (let ((inhibit-read-only t)) (undo arg))) +(defun diff-add-log-current-defuns () + "Return an alist of defun names for the current diff. +The elements of the alist are of the form (FILE . (DEFUN...)), +where DEFUN... is a list of function names found in FILE." + (save-excursion + (goto-char (point-min)) + (let ((defuns nil) + (hunk-end nil) + (hunk-mismatch-files nil) + (make-defun-context-follower + (lambda (goline) + (let ((eodefun nil) + (defname nil)) + (list + (lambda () ;; Check for end of current defun. + (when (and eodefun + (funcall goline) + (>= (point) eodefun)) + (setq defname nil) + (setq eodefun nil))) + (lambda (&optional get-current) ;; Check for new defun. + (if get-current + defname + (when-let* ((def (and (not eodefun) + (funcall goline) + (add-log-current-defun))) + (eof (save-excursion (end-of-defun) (point)))) + (setq eodefun eof) + (setq defname def))))))))) + (while + ;; Might need to skip over file headers between diff + ;; hunks (e.g., "diff --git ..." etc). + (re-search-forward diff-hunk-header-re nil t) + (setq hunk-end (save-excursion (diff-end-of-hunk))) + (pcase-let* ((filename (substring-no-properties (diff-find-file-name))) + (=lines 0) + (+lines 0) + (-lines 0) + (`(,buf ,line-offset (,beg . ,_end) + (,old-text . ,_old-offset) + (,new-text . ,_new-offset) + ,applied) + ;; Try to use the vc integration of + ;; `diff-find-source-location', unless it + ;; would look for non-existent files like + ;; /dev/null. + (diff-find-source-location + (not (equal "/dev/null" + (car (diff-hunk-file-names t)))))) + (other-buf nil) + (goto-otherbuf + ;; If APPLIED, we have NEW-TEXT in BUF, so we + ;; need to a buffer with OLD-TEXT to follow + ;; -lines. + (lambda () + (if other-buf (set-buffer other-buf) + (set-buffer (generate-new-buffer " *diff-other-text*")) + (insert (if applied old-text new-text)) + (funcall (buffer-local-value 'major-mode buf)) + (setq other-buf (current-buffer))) + (goto-char (point-min)) + (forward-line (+ =lines -1 + (if applied -lines +lines))))) + (gotobuf (lambda () + (set-buffer buf) + (goto-char beg) + (forward-line (+ =lines -1 + (if applied +lines -lines))))) + (`(,=ck-eodefun ,=ck-defun) + (funcall make-defun-context-follower gotobuf)) + (`(,-ck-eodefun ,-ck-defun) + (funcall make-defun-context-follower + (if applied goto-otherbuf gotobuf))) + (`(,+ck-eodefun ,+ck-defun) + (funcall make-defun-context-follower + (if applied gotobuf goto-otherbuf)))) + (unless (eql line-offset 0) + (cl-pushnew filename hunk-mismatch-files :test #'equal)) + ;; Some modes always return nil for `add-log-current-defun', + ;; make sure at least the filename is included. + (unless (assoc filename defuns) + (push (cons filename nil) defuns)) + (unwind-protect + (while (progn (forward-line) + (< (point) hunk-end)) + (let ((patch-char (char-after))) + (pcase patch-char + (?+ (cl-incf +lines)) + (?- (cl-incf -lines)) + (?\s (cl-incf =lines))) + (save-current-buffer + (funcall =ck-eodefun) + (funcall +ck-eodefun) + (funcall -ck-eodefun) + (when-let* ((def (cond + ((eq patch-char ?\s) + ;; Just updating context defun. + (ignore (funcall =ck-defun))) + ;; + or - in existing defun. + ((funcall =ck-defun t)) + ;; Check added or removed defun. + (t (funcall (if (eq ?+ patch-char) + +ck-defun -ck-defun)))))) + (cl-pushnew def (alist-get filename defuns + nil nil #'equal) + :test #'equal))))) + (when (buffer-live-p other-buf) + (kill-buffer other-buf))))) + (when hunk-mismatch-files + (message "Diff didn't match for %s." + (mapconcat #'identity hunk-mismatch-files ", "))) + (dolist (file-defuns defuns) + (cl-callf nreverse (cdr file-defuns))) + (nreverse defuns)))) + (defun diff-add-change-log-entries-other-window () "Iterate through the current diff and create ChangeLog entries. I.e. like `add-change-log-entry-other-window' but applied to all hunks." diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el index 91e18c1ec5..8d47d66ac3 100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el @@ -54,6 +54,7 @@ (easy-mmode-defmap log-edit-mode-map '(("\C-c\C-c" . log-edit-done) ("\C-c\C-a" . log-edit-insert-changelog) + ("\C-c\C-w" . log-edit-generate-changelog-from-diff) ("\C-c\C-d" . log-edit-show-diff) ("\C-c\C-f" . log-edit-show-files) ("\C-c\C-k" . log-edit-kill-buffer) @@ -488,10 +489,63 @@ commands (under C-x v for VC, for example). (set (make-local-variable 'font-lock-defaults) '(log-edit-font-lock-keywords t)) (setq-local jit-lock-contextually t) ;For the "first line is summary". + (setq-local fill-paragraph-function #'log-edit-fill-entry) (make-local-variable 'log-edit-comment-ring-index) (add-hook 'kill-buffer-hook 'log-edit-remember-comment nil t) (hack-dir-local-variables-non-file-buffer)) +(defun log-edit--insert-filled-defuns (func-names) + "Insert FUNC-NAMES, following ChangeLog formatting." + (if (not func-names) + (insert ":") + (unless (or (memq (char-before) '(?\n ?\s)) + (> (current-column) fill-column)) + (insert " ")) + (cl-loop for first-fun = t then nil + for def in func-names do + (when (> (+ (current-column) (string-width def)) fill-column) + (unless first-fun + (insert ")")) + (insert "\n")) + (insert (if (memq (char-before) '(?\n ?\s)) + "(" ", ") + def)) + (insert "):"))) + +(defun log-edit-fill-entry (&optional justify) + "Like \\[fill-paragraph], but handle ChangeLog entries. +Consecutive function entries without prose (i.e., lines of the +form \"(FUNCTION):\") will be combined into \"(FUNC1, FUNC2):\" +according to `fill-column'." + (save-excursion + (pcase-let ((`(,beg ,end) (log-edit-changelog-paragraph))) + (if (= beg end) + ;; Not a ChangeLog entry, fill as normal. + nil + (cl-callf copy-marker end) + (goto-char beg) + (cl-loop + for defuns-beg = + (and (< beg end) + (re-search-forward + (concat "\\(?1:" change-log-unindented-file-names-re + "\\)\\|^\\(?1:\\)(") + end t) + (copy-marker (match-end 1))) + ;; Fill prose between log entries. + do (let ((fill-indent-according-to-mode t) + (end (if defuns-beg (match-beginning 0) end)) + (beg (progn (goto-char beg) (line-beginning-position)))) + (when (<= (line-end-position) end) + (fill-region beg end justify))) + while defuns-beg + for defuns = (progn (goto-char defuns-beg) + (change-log-read-defuns end)) + do (progn (delete-region defuns-beg (point)) + (log-edit--insert-filled-defuns defuns) + (setq beg (point)))) + t)))) + (defun log-edit-hide-buf (&optional buf where) (when (setq buf (get-buffer (or buf log-edit-files-buf))) ;; FIXME: Should use something like `quit-windows-on' here, but @@ -726,6 +780,27 @@ to build the Fixes: header.") (replace-match (concat " " value) t t nil 1) (insert field ": " value "\n" (if (looking-at "\n") "" "\n")))) +(declare-function diff-add-log-current-defuns "diff-mode" ()) + +(defun log-edit-generate-changelog-from-diff () + "Insert a log message by looking at the current diff. +This command will generate a ChangeLog entries listing the +functions. You can then add a description where needed, and use +\\[fill-paragraph] to join consecutive function names." + (interactive) + (let* ((diff-buf nil) + ;; Unfortunately, `log-edit-show-diff' doesn't have a NO-SHOW + ;; option, so we try to work around it via display-buffer + ;; machinery. + (display-buffer-overriding-action + `(,(lambda (buf alist) + (setq diff-buf buf) + (display-buffer-no-window buf alist)) + . ((allow-no-window . t))))) + (change-log-insert-entries + (with-current-buffer (progn (log-edit-show-diff) diff-buf) + (diff-add-log-current-defuns))))) + (defun log-edit-insert-changelog (&optional use-first) "Insert a log message by looking at the ChangeLog. The idea is to write your ChangeLog entries first, and then use this diff --git a/test/lisp/vc/log-edit-tests.el b/test/lisp/vc/log-edit-tests.el new file mode 100644 index 0000000000..7d77eca87d --- /dev/null +++ b/test/lisp/vc/log-edit-tests.el @@ -0,0 +1,113 @@ +;;; log-edit-tests.el --- Unit tests for log-edit.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Unit tests for lisp/vc/log-edit.el. + +;;; Code: + +(require 'log-edit) +(require 'ert) + +(ert-deftest log-edit-fill-entry () + (with-temp-buffer + (insert "\ +* dir/file.ext (fun1): +\(fun2): +\(fun3): +* file2.txt (fun4): +\(fun5): +\(fun6): +\(fun7): Some prose. +\(fun8): A longer description of a complicated change.\ + Spread over a couple of sentencences.\ + Long enough to be filled for several lines. +\(fun9): Etc.") + (goto-char (point-min)) + (let ((fill-column 72)) (log-edit-fill-entry)) + (should (equal (buffer-string) "\ +* dir/file.ext (fun1, fun2, fun3): +* file2.txt (fun4, fun5, fun6, fun7): Some prose. +\(fun8): A longer description of a complicated change. Spread over a +couple of sentencences. Long enough to be filled for several lines. +\(fun9): Etc.")) + (let ((fill-column 20)) (log-edit-fill-entry)) + (should (equal (buffer-string) "\ +* dir/file.ext (fun1) +\(fun2, fun3): +* file2.txt (fun4) +\(fun5, fun6, fun7): +Some prose. +\(fun8): A longer +description of a +complicated change. +Spread over a couple +of sentencences. +Long enough to be +filled for several +lines. +\(fun9): Etc.")) + (let ((fill-column 40)) (log-edit-fill-entry)) + (should (equal (buffer-string) "\ +* dir/file.ext (fun1, fun2, fun3): +* file2.txt (fun4, fun5, fun6, fun7): +Some prose. +\(fun8): A longer description of a +complicated change. Spread over a +couple of sentencences. Long enough to +be filled for several lines. +\(fun9): Etc.")))) + +(ert-deftest log-edit-fill-entry-trailing-prose () + (with-temp-buffer + (insert "\ +* dir/file.ext (fun1): A longer description of a complicated change.\ + Spread over a couple of sentencences.\ + Long enough to be filled for several lines.") + (let ((fill-column 72)) (log-edit-fill-entry)) + (should (equal (buffer-string) "\ +* dir/file.ext (fun1): A longer description of a complicated change. +Spread over a couple of sentencences. Long enough to be filled for +several lines.")))) + +(ert-deftest log-edit-fill-entry-joining () + ;; Join short enough function names on the same line. + (with-temp-buffer + (insert "* dir/file.ext (fun1):\n(fun2):") + (let ((fill-column 72)) (log-edit-fill-entry)) + (should (equal (buffer-string) "* dir/file.ext (fun1, fun2):"))) + ;; Don't combine them if they're too long. + (with-temp-buffer + (insert "* dir/long-file-name.ext (a-really-long-function-name): +\(another-very-long-function-name):") + (let ((fill-column 72)) (log-edit-fill-entry)) + (should (equal (buffer-string) "* dir/long-file-name.ext (a-really-long-function-name) +\(another-very-long-function-name):"))) + ;; Put function name on next line, if the file name is too long. + (with-temp-buffer + (insert "\ +* a-very-long-directory-name/another-long-directory-name/and-a-long-file-name.ext\ + (a-really-long-function-name):") + (let ((fill-column 72)) (log-edit-fill-entry)) + (should (equal (buffer-string) "\ +* a-very-long-directory-name/another-long-directory-name/and-a-long-file-name.ext +\(a-really-long-function-name):")))) + +;;; log-edit-tests.el ends here commit 2d47483e815979d0ae0edd6f878b7fbb85fd72fa Author: Eric Abrahamsen Date: Sat Aug 3 17:01:52 2019 -0700 Fix Gnus group name reference in gnus-mark-xrefs-as-read * lisp/gnus/gnus-sum.el (gnus-mark-xrefs-as-read): There's already a local binding for "group", don't need another "name". This was left over from the obarray-to-hashtable change. diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index a6a0bdb228..73478f4cbd 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -6263,7 +6263,7 @@ The resulting hash table is returned, or nil if no Xrefs were found." (defun gnus-mark-xrefs-as-read (from-newsgroup headers unreads) "Look through all the headers and mark the Xrefs as read." (let ((virtual (gnus-virtual-group-p from-newsgroup)) - name info xref-hashtb method nth4) + info xref-hashtb method nth4) (with-current-buffer gnus-group-buffer (when (setq xref-hashtb (gnus-create-xref-hashtb from-newsgroup headers unreads)) @@ -6272,7 +6272,7 @@ The resulting hash table is returned, or nil if no Xrefs were found." (unless (string= from-newsgroup group) ;; Dead groups are not updated. (and (prog1 - (setq info (gnus-get-info name)) + (setq info (gnus-get-info group)) (when (stringp (setq nth4 (gnus-info-method info))) (setq nth4 (gnus-server-to-method nth4)))) ;; Only do the xrefs if the group has the same @@ -6290,7 +6290,7 @@ The resulting hash table is returned, or nil if no Xrefs were found." ;; Only do cross-references on subscribed ;; groups, if that is what is wanted. (<= (gnus-info-level info) gnus-level-subscribed)) - (gnus-group-make-articles-read name idlist)))) + (gnus-group-make-articles-read group idlist)))) xref-hashtb))))) (defun gnus-compute-read-articles (group articles) commit 727e0eab0a0d8043d09225f63f8bef2abc045562 Author: Eric Abrahamsen Date: Thu Jun 6 20:43:27 2019 -0700 Temporarily preserve encoded Gnus group names in Gnus files Non-ascii Gnus groups should be written to files in their encoded version until we're ready to bump Gnus' version and add an upgrade routine. * lisp/gnus/gnus-start.el (gnus-gnus-to-quick-newsrc-format): * lisp/gnus/gnus-agent.el (gnus-category-read): (gnus-category-write): Handle non-ascii group names appropriately. * lisp/gnus/gnus-registry.el (gnus-registry--munge-group-names): New function to encode/decode group names. (gnus-registry-fixup-registry): (gnus-registry-save): Use function. diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index d9c9e94070..dd30dda2a1 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -2693,52 +2693,74 @@ The following commands are available: "Read the category alist." (setq gnus-category-alist (or - (with-temp-buffer - (ignore-errors - (nnheader-insert-file-contents (nnheader-concat gnus-agent-directory "lib/categories")) - (goto-char (point-min)) - ;; This code isn't temp, it will be needed so long as - ;; anyone may be migrating from an older version. - - ;; Once we're certain that people will not revert to an - ;; earlier version, we can take out the old-list code in - ;; gnus-category-write. - (let* ((old-list (read (current-buffer))) - (new-list (ignore-errors (read (current-buffer))))) - (if new-list - new-list - ;; Convert from a positional list to an alist. - (mapcar - (lambda (c) - (setcdr c - (delq nil - (gnus-mapcar - (lambda (valu symb) - (if valu - (cons symb valu))) - (cdr c) - '(agent-predicate agent-score-file agent-groups)))) - c) - old-list))))) + (let ((list + (with-temp-buffer + (ignore-errors + (nnheader-insert-file-contents (nnheader-concat gnus-agent-directory "lib/categories")) + (goto-char (point-min)) + ;; This code isn't temp, it will be needed so long as + ;; anyone may be migrating from an older version. + + ;; Once we're certain that people will not revert to an + ;; earlier version, we can take out the old-list code in + ;; gnus-category-write. + (let* ((old-list (read (current-buffer))) + (new-list (ignore-errors (read (current-buffer))))) + (if new-list + new-list + ;; Convert from a positional list to an alist. + (mapcar + (lambda (c) + (setcdr c + (delq nil + (gnus-mapcar + (lambda (valu symb) + (if valu + (cons symb valu))) + (cdr c) + '(agent-predicate agent-score-file agent-groups)))) + c) + old-list))))))) + ;; Possibly decode group names. + (dolist (cat list) + (setf (alist-get 'agent-groups cat) + (mapcar (lambda (g) + (if (string-match-p "[^[:ascii:]]" g) + (decode-coding-string g 'utf-8-emacs) + g)) + (alist-get 'agent-groups cat)))) + list) (list (gnus-agent-cat-make 'default 'short))))) (defun gnus-category-write () "Write the category alist." (setq gnus-category-predicate-cache nil gnus-category-group-cache nil) - (gnus-make-directory (nnheader-concat gnus-agent-directory "lib")) - (with-temp-file (nnheader-concat gnus-agent-directory "lib/categories") - ;; This prin1 is temporary. It exists so that people can revert - ;; to an earlier version of gnus-agent. - (prin1 (mapcar (lambda (c) - (list (car c) - (cdr (assoc 'agent-predicate c)) - (cdr (assoc 'agent-score-file c)) - (cdr (assoc 'agent-groups c)))) - gnus-category-alist) - (current-buffer)) - (newline) - (prin1 gnus-category-alist (current-buffer)))) + ;; Temporarily encode non-ascii group names when saving to file, + ;; pending an upgrade of Gnus' file formats. + (let ((gnus-category-alist + (mapcar (lambda (cat) + (setf (alist-get 'agent-groups cat) + (mapcar (lambda (g) + (if (multibyte-string-p g) + (encode-coding-string g 'utf-8-emacs) + g)) + (alist-get 'agent-groups cat))) + cat) + (copy-tree gnus-category-alist)))) + (gnus-make-directory (nnheader-concat gnus-agent-directory "lib")) + (with-temp-file (nnheader-concat gnus-agent-directory "lib/categories") + ;; This prin1 is temporary. It exists so that people can revert + ;; to an earlier version of gnus-agent. + (prin1 (mapcar (lambda (c) + (list (car c) + (cdr (assoc 'agent-predicate c)) + (cdr (assoc 'agent-score-file c)) + (cdr (assoc 'agent-groups c)))) + gnus-category-alist) + (current-buffer)) + (newline) + (prin1 gnus-category-alist (current-buffer))))) (defun gnus-category-edit-predicate (category) "Edit the predicate for CATEGORY." diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index e488858ebe..e949179b3c 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -264,6 +264,50 @@ This can slow pruning down. Set to nil to perform no sorting." (cadr (assq 'creation-time r)) (cadr (assq 'creation-time l)))) +;; Remove this from the save routine (and fix it to only decode) at +;; next Gnus version bump. +(defun gnus-registry--munge-group-names (db &optional encode) + "Encode/decode group names in DB, before saving or after loading. +Encode names if ENCODE is non-nil, otherwise decode." + (let ((datahash (slot-value db 'data)) + (grouphash (registry-lookup-secondary db 'group)) + reset-pairs) + (when (hash-table-p grouphash) + (maphash + (lambda (group-name val) + (if encode + (when (multibyte-string-p group-name) + (remhash group-name grouphash) + (puthash (encode-coding-string group-name 'utf-8-emacs) + val grouphash)) + (when (string-match-p "[^[:ascii:]]" group-name) + (remhash group-name grouphash) + (puthash (decode-coding-string group-name 'utf-8-emacs) val grouphash)))) + grouphash)) + (maphash + (lambda (id data) + (let ((groups (cdr-safe (assq 'group data)))) + (when (seq-some (lambda (g) + (if encode + (multibyte-string-p g) + (string-match-p "[^[:ascii:]]" g))) + groups) + ;; Create a replacement DATA. + (push (list id (cons (cons 'group (mapcar + (lambda (g) + (funcall + (if encode + #'encode-coding-string + #'decode-coding-string) + g 'utf-8-emacs)) + groups)) + (assq-delete-all 'group data))) + reset-pairs)))) + datahash) + (pcase-dolist (`(,id ,data) reset-pairs) + (remhash id datahash) + (puthash id data datahash)))) + (defun gnus-registry-fixup-registry (db) (when db (let ((old (oref db tracked))) @@ -281,7 +325,8 @@ This can slow pruning down. Set to nil to perform no sorting." '(mark group keyword))) (when (not (equal old (oref db tracked))) (gnus-message 9 "Reindexing the Gnus registry (tracked change)") - (registry-reindex db)))) + (registry-reindex db)) + (gnus-registry--munge-group-names db))) db) (defun gnus-registry-make-db (&optional file) @@ -358,14 +403,20 @@ non-nil." (defun gnus-registry-save (&optional file db) "Save the registry cache file." (interactive) - (let ((file (or file gnus-registry-cache-file)) - (db (or db gnus-registry-db))) + (let* ((file (or file gnus-registry-cache-file)) + (db (or db gnus-registry-db)) + (clone (clone db))) (gnus-message 5 "Saving Gnus registry (%d entries) to %s..." (registry-size db) file) (registry-prune db gnus-registry-default-sort-function) + ;; Write a clone of the database with non-ascii group names + ;; encoded as 'utf-8. Let-bind `gnus-registry-db' so that + ;; functions in the munging process work on our clone. + (let ((gnus-registry-db clone)) + (gnus-registry--munge-group-names clone 'encode)) ;; TODO: call (gnus-string-remove-all-properties v) on all elements? - (eieio-persistent-save db file) + (eieio-persistent-save clone file) (gnus-message 5 "Saving Gnus registry (size %d) to %s...done" (registry-size db) file))) diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index f7ede54b10..930d522c41 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -42,6 +42,7 @@ (defvar gnus-agent-covered-methods) (defvar gnus-agent-file-loading-local) (defvar gnus-agent-file-loading-cache) +(defvar gnus-topic-alist) (defcustom gnus-startup-file (nnheader-concat gnus-home-directory ".newsrc") "Your `.newsrc' file. @@ -2869,7 +2870,12 @@ SPECIFIC-VARIABLES, or those in `gnus-variable-list'." (princ "(setq gnus-newsrc-file-version ") (princ (gnus-prin1-to-string gnus-version)) (princ ")\n")) - + ;; Sort `gnus-newsrc-alist' according to order in + ;; `gnus-group-list'. + (setq gnus-newsrc-alist + (mapcar (lambda (g) + (nth 1 (gethash g gnus-newsrc-hashtb))) + (delete "dummy.group" gnus-group-list))) (let* ((print-quoted t) (print-readably t) (print-escape-multibyte nil) @@ -2889,18 +2895,27 @@ SPECIFIC-VARIABLES, or those in `gnus-variable-list'." ;; Remove the `gnus-killed-list' from the list of variables ;; to be saved, if required. (delq 'gnus-killed-list (copy-sequence gnus-variable-list))))) + ;; Encode group names in `gnus-newsrc-alist' and + ;; `gnus-topic-alist' in order to keep newsrc.eld files + ;; compatible with older versions of Gnus. At some point, + ;; if/when a new version of Gnus is released, stop doing + ;; this and move the corresponding decode in + ;; `gnus-read-newsrc-el-file' into a conversion routine. + (gnus-newsrc-alist + (mapcar (lambda (info) + (cons (encode-coding-string (car info) 'utf-8-emacs) + (cdr info))) + gnus-newsrc-alist)) + (gnus-topic-alist + (when (memq 'gnus-topic-alist variables) + (mapcar (lambda (elt) + (cons (car elt) ; Topic name + (mapcar (lambda (g) + (encode-coding-string + g 'utf-8-emacs)) + (cdr elt)))) + gnus-topic-alist))) variable) - ;; A bit of a fake-out here: the original value of - ;; `gnus-newsrc-alist' isn't written to file, instead it is - ;; constructed at the last minute by combining the group - ;; ordering in `gnus-group-list' with the group infos from - ;; `gnus-newsrc-hashtb'. - (set (nth (seq-position gnus-variable-list 'gnus-newsrc-alist) - gnus-variable-list) - (mapcar (lambda (g) - (nth 1 (gethash g gnus-newsrc-hashtb))) - (delete "dummy.group" gnus-group-list))) - ;; Insert the variables into the file. (while variables (when (and (boundp (setq variable (pop variables))) commit cb12a84f2c519a48dd87453c925e3bc36d9944db Author: Eric Abrahamsen Date: Fri Nov 16 12:53:56 2018 -0800 Remove Gnus group name encoding/decoding This completes the process started in c1b63af445. Gnus group names are now fully decoded inside the Gnus system. * lisp/gnus/gnus-agent.el (gnus-agent-file-coding-system): Change default to utf-8-emacs. (gnus-agent-decoded-group-names, gnus-agent-decoded-group-name): Remove variable and function. Remove all usage in this file. * lisp/gnus/gnus-cache.el (gnus-cache-decoded-group-names, gnus-cache-unified-group-names, gnus-cache-decoded-group-name): Remove these variables and function. Remove all usage in this file. * lisp/gnus/gnus-group.el (gnus-tmp-decoded-group): Remove this variable, gnus-tmp-group is now decoded. (gnus-group-completing-read): Don't encode or decode group names here. (gnus-group-make-group): Remove ENCODED argument. * lisp/gnus/gnus-srvr.el (gnus-browse-foreign-server): Decode group names here. * lisp/gnus/gnus-start.el (gnus-make-hashtable-from-newsrc-alist): check for encoded group names and decode. (gnus-active-to-gnus-format): Make sure incoming group names are decoded. (gnus-read-newsrc-el-file): Check for encoded group names in gnus-topic-alist. * lisp/gnus/nnagent.el: Don't use a unibyte buffer. * lisp/gnus/nnheader.el (nnheader-file-coding-system): Switch default from 'raw-text to 'undecided, on the assumption that 'undecided will probably write 'utf-8-emacs unless the user has arranged things otherwise. * lisp/gnus/nnimap.el (nnimap-decode-gnus-group, nnimap-encode-gnus-group): Remove functions and their use. * lisp/gnus/nnmail.el (nnmail-parse-active): Remove encoding. (nnmail-active-file-coding-system): Default to 'utf-8-emacs instead of 'raw-text. (nnmail-group-names-not-encoded-p): Obsolete this variable; stop using it. * lisp/gnus/gnus-art.el: * lisp/gnus/gnus-cus.el: * lisp/gnus/gnus-msg.el: * lisp/gnus/gnus-start.el: * lisp/gnus/gnus-sum.el: * lisp/gnus/gnus.el: * lisp/gnus/nnml.el: * lisp/gnus/message.el: * lisp/gnus/nnrss.el: Stop using gnus-group-decoded-name in all these files. diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 40d0d24605..d9c9e94070 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -229,7 +229,7 @@ NOTES: "Cache of message subjects for spam messages. Actually a hash table holding subjects mapped to t.") (defvar gnus-agent-file-name nil) -(defvar gnus-agent-file-coding-system 'raw-text) +(defvar gnus-agent-file-coding-system 'utf-8-emacs) (defvar gnus-agent-file-loading-cache nil) (defvar gnus-agent-total-fetched-hashtb nil) (defvar gnus-agent-inhibit-update-total-fetched-for nil) @@ -406,8 +406,6 @@ manipulated as follows: (defun gnus-agent-read-group () "Read a group name in the minibuffer, with completion." (let ((def (or (gnus-group-group-name) gnus-newsgroup-name))) - (when def - (setq def (gnus-group-decoded-name def))) (gnus-group-completing-read nil nil t nil nil def))) ;;; Fetching setup functions. @@ -1330,7 +1328,10 @@ downloaded into the agent." (gnus-make-directory (file-name-directory file)) (with-temp-file file ;; Emacs got problem to match non-ASCII group in multibyte buffer. - (mm-disable-multibyte) + + ;; FIXME: Is this still an issue now that group names are + ;; always strings? + ;(mm-disable-multibyte) (when (file-exists-p file) (nnheader-insert-file-contents file) @@ -1360,7 +1361,7 @@ downloaded into the agent." (gnus-make-directory (file-name-directory file)) (with-temp-buffer ;; Emacs got problem to match non-ASCII group in multibyte buffer. - (mm-disable-multibyte) + ;(mm-disable-multibyte) (when (file-exists-p file) (nnheader-insert-file-contents file) @@ -1372,18 +1373,6 @@ downloaded into the agent." oactive-min (read (current-buffer))) ;; min (cons oactive-min oactive-max)))))))) -(defvar gnus-agent-decoded-group-names nil - "Alist of non-ASCII group names and decoded ones.") - -(defun gnus-agent-decoded-group-name (group) - "Return a decoded group name of GROUP." - (or (cdr (assoc group gnus-agent-decoded-group-names)) - (if (string-match "[^\000-\177]" group) - (let ((decoded (gnus-group-decoded-name group))) - (push (cons group decoded) gnus-agent-decoded-group-names) - decoded) - group))) - (defun gnus-agent-group-path (group) "Translate GROUP into a file name." @@ -1395,7 +1384,7 @@ downloaded into the agent." (nnheader-translate-file-chars (nnheader-replace-duplicate-chars-in-string (nnheader-replace-chars-in-string - (gnus-group-real-name (gnus-agent-decoded-group-name group)) + (gnus-group-real-name group) ?/ ?_) ?. ?_))) (if (or nnmail-use-long-file-names @@ -1409,7 +1398,7 @@ downloaded into the agent." ;; unplugged. The agent must, therefore, use the same directory ;; while plugged. (nnmail-group-pathname - (gnus-group-real-name (gnus-agent-decoded-group-name group)) + (gnus-group-real-name group) (if gnus-command-method (gnus-agent-directory) (let ((gnus-command-method (gnus-find-method-for-group group))) @@ -1437,7 +1426,7 @@ downloaded into the agent." (format " *Gnus agent %s history*" (gnus-agent-method))))) gnus-agent-history-buffers) - (mm-disable-multibyte) ;; everything is binary + ;(mm-disable-multibyte) ;; everything is binary (erase-buffer) (insert "\n") (let ((file (gnus-agent-lib-file "history"))) @@ -1525,8 +1514,7 @@ downloaded into the agent." (setq selected-sets (nreverse selected-sets)) (gnus-make-directory dir) - (gnus-message 7 "Fetching articles for %s..." - (gnus-agent-decoded-group-name group)) + (gnus-message 7 "Fetching articles for %s..." group) (unwind-protect (while (setq articles (pop selected-sets)) @@ -1537,8 +1525,7 @@ downloaded into the agent." (let (article) (while (setq article (pop articles)) (gnus-message 10 "Fetching article %s for %s..." - article - (gnus-agent-decoded-group-name group)) + article group) (when (or (gnus-backlog-request-article group article nntp-server-buffer) @@ -1875,8 +1862,7 @@ article numbers will be returned." (with-current-buffer nntp-server-buffer (if articles (progn - (gnus-message 8 "Fetching headers for %s..." - (gnus-agent-decoded-group-name group)) + (gnus-message 8 "Fetching headers for %s..." group) ;; Fetch them. (gnus-make-directory (nnheader-translate-file-chars @@ -3058,8 +3044,7 @@ FORCE is equivalent to setting the expiration predicates to true." ;; provided a non-nil active (let ((dir (gnus-agent-group-pathname group)) - (file-name-coding-system nnmail-pathname-coding-system) - (decoded (gnus-agent-decoded-group-name group))) + (file-name-coding-system nnmail-pathname-coding-system)) (gnus-agent-with-refreshed-group group (when (boundp 'gnus-agent-expire-current-dirs) @@ -3068,8 +3053,8 @@ FORCE is equivalent to setting the expiration predicates to true." (if (and (not force) (eq 'DISABLE (gnus-agent-find-parameter group 'agent-enable-expiration))) - (gnus-message 5 "Expiry skipping over %s" decoded) - (gnus-message 5 "Expiring articles in %s" decoded) + (gnus-message 5 "Expiry skipping over %s" group) + (gnus-message 5 "Expiring articles in %s" group) (gnus-agent-load-alist group) (let* ((bytes-freed 0) (size-files-deleted 0.0) @@ -3293,7 +3278,7 @@ line." (point) nov-file))) (keep (gnus-agent-message 10 "gnus-agent-expire: %s:%d: Kept %s article%s." - decoded article-number keep (if fetch-date " and file" "")) + group article-number keep (if fetch-date " and file" "")) (when fetch-date (unless (file-exists-p (concat dir (number-to-string @@ -3301,7 +3286,7 @@ line." (point) nov-file))) (setf (nth 1 entry) nil) (gnus-agent-message 3 "gnus-agent-expire cleared \ download flag on %s:%d as the cached article file is missing." - decoded (caar dlist))) + group (caar dlist))) (unless marker (gnus-message 1 "gnus-agent-expire detected a \ missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) @@ -3379,12 +3364,12 @@ article alist" type) actions)) (when actions (gnus-agent-message 8 "gnus-agent-expire: %s:%d: %s" - decoded article-number + group article-number (mapconcat #'identity actions ", "))))) (t (gnus-agent-message 10 "gnus-agent-expire: %s:%d: Article kept as \ -expiration tests failed." decoded article-number) +expiration tests failed." group article-number) (gnus-agent-append-to-list tail-alist (cons article-number fetch-date))) ) @@ -3835,7 +3820,7 @@ If REREAD is not nil, downloaded articles are marked as unread." (sit-for 1) t))))) (when group - (gnus-message 5 "Regenerating in %s" (gnus-agent-decoded-group-name group)) + (gnus-message 5 "Regenerating in %s" group) (let* ((gnus-command-method (or gnus-command-method (gnus-find-method-for-group group))) (file (gnus-agent-article-name ".overview" group)) @@ -3912,8 +3897,7 @@ If REREAD is not nil, downloaded articles are marked as unread." (> (car downloaded) (car nov-arts)))) ;; This entry is missing from the overview file (gnus-message 3 "Regenerating NOV %s %d..." - (gnus-agent-decoded-group-name group) - (car downloaded)) + group (car downloaded)) (let ((file (concat dir (number-to-string (car downloaded))))) (mm-with-unibyte-buffer (nnheader-insert-file-contents file) diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 8f5a313c61..af8ec68ddd 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -4506,9 +4506,7 @@ commands: (defun gnus-article-setup-buffer () "Initialize the article buffer." (let* ((name (if gnus-single-article-buffer "*Article*" - (concat "*Article " - (gnus-group-decoded-name gnus-newsgroup-name) - "*"))) + (concat "*Article " gnus-newsgroup-name "*"))) (original (progn (string-match "\\*Article" name) (concat " *Original Article" diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index afe8a8a416..f43c4344dc 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -430,41 +430,7 @@ Returns the list of articles removed." (and unread (memq 'unread class)) (and (not unread) (not ticked) (not dormant) (memq 'read class)))) -(defvar gnus-cache-decoded-group-names nil - "Alist of original group names and decoded group names. -Decoding is done according to `gnus-group-name-charset-method-alist' -or `gnus-group-name-charset-group-alist'.") - -(defvar gnus-cache-unified-group-names nil - "Alist of unified decoded group names and original group names. -A group name is decoded according to -`gnus-group-name-charset-method-alist' or -`gnus-group-name-charset-group-alist' first, and is encoded and -decoded again according to `nnmail-pathname-coding-system', -`file-name-coding-system', or `default-file-name-coding-system'. - -It is used when asking for an original group name from a cache -directory name, in which non-ASCII characters might have been unified -into the ones of a certain charset particularly if the `utf-8' coding -system for example was used.") - -(defun gnus-cache-decoded-group-name (group) - "Return a decoded group name of GROUP." - (or (cdr (assoc group gnus-cache-decoded-group-names)) - (let ((decoded (gnus-group-decoded-name group)) - (coding (or nnmail-pathname-coding-system - file-name-coding-system - default-file-name-coding-system))) - (push (cons group decoded) gnus-cache-decoded-group-names) - (push (cons (decode-coding-string - (encode-coding-string decoded coding) - coding) - group) - gnus-cache-unified-group-names) - decoded))) - (defun gnus-cache-file-name (group article) - (setq group (gnus-cache-decoded-group-name group)) (expand-file-name (if (stringp article) article (int-to-string article)) (file-name-as-directory @@ -733,12 +699,7 @@ If LOW, update the lower bound instead." (push (pop files) alphs))) ;; If we have nums, then this is probably a valid group. (when (setq nums (sort nums '<)) - ;; Use non-decoded group name. - ;; FIXME: this is kind of a workaround. The active file should - ;; be updated at the time articles are cached. It will make - ;; `gnus-cache-unified-group-names' needless. - (puthash (or (cdr (assoc group gnus-cache-unified-group-names)) - group) + (puthash group (cons (car nums) (car (last nums))) gnus-cache-active-hashtb)) ;; Go through all the other files. diff --git a/lisp/gnus/gnus-cus.el b/lisp/gnus/gnus-cus.el index fb8b300e35..3598ead761 100644 --- a/lisp/gnus/gnus-cus.el +++ b/lisp/gnus/gnus-cus.el @@ -396,7 +396,7 @@ category.")) :tag "topic parameters" "(gnus)Topic Parameters")) (widget-insert " for <") - (widget-insert (gnus-group-decoded-name (or group topic))) + (widget-insert (or group topic)) (widget-insert "> and press ") (widget-create 'push-button :tag "done" @@ -845,8 +845,7 @@ When called interactively, FILE defaults to the current score file. This can be changed using the `\\[gnus-score-change-score-file]' command." (interactive (list gnus-current-score-file)) (unless file - (error "No score file for %s" - (gnus-group-decoded-name gnus-newsgroup-name))) + (error "No score file for %s" gnus-newsgroup-name)) (let ((scores (gnus-score-load file)) (types (mapcar (lambda (entry) `(group :format "%v%h\n" diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 299ebdec50..7e0ceec17b 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -479,7 +479,6 @@ simple manner." (defvar gnus-tmp-news-method) (defvar gnus-tmp-colon) (defvar gnus-tmp-news-server) -(defvar gnus-tmp-decoded-group) (defvar gnus-tmp-header) (defvar gnus-tmp-process-marked) (defvar gnus-tmp-summary-live) @@ -518,14 +517,9 @@ simple manner." (?T (gnus-range-length (cdr (assq 'tick gnus-tmp-marked))) ?d) (?i (+ (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))) ?d) - (?g (if (boundp 'gnus-tmp-decoded-group) - gnus-tmp-decoded-group - gnus-tmp-group) - ?s) + (?g gnus-tmp-group ?s) (?G gnus-tmp-qualified-group ?s) - (?c (gnus-short-group-name (if (boundp 'gnus-tmp-decoded-group) - gnus-tmp-decoded-group - gnus-tmp-group)) + (?c (gnus-short-group-name gnus-tmp-group) ?s) (?C gnus-tmp-comment ?s) (?D gnus-tmp-newsgroup-description ?s) @@ -1398,8 +1392,7 @@ if it is a string, only list groups matching REGEXP." ((functionp regexp) (funcall regexp group)))) (add-text-properties (point) (prog1 (1+ (point)) - (insert " " mark " *: " - (gnus-group-decoded-name group) + (insert " " mark " *: " group "\n")) (list 'gnus-group group 'gnus-unread t @@ -1508,8 +1501,6 @@ if it is a string, only list groups matching REGEXP." "Insert a group line in the group buffer." (let* ((gnus-tmp-method (gnus-server-get-method gnus-tmp-group gnus-tmp-method)) - (group-name-charset (gnus-group-name-charset gnus-tmp-method - gnus-tmp-group)) (gnus-tmp-active (gnus-active gnus-tmp-group)) (gnus-tmp-number-total (if gnus-tmp-active @@ -1528,16 +1519,13 @@ if it is a string, only list groups matching REGEXP." ((= gnus-tmp-level gnus-level-zombie) ?Z) (t ?K))) (gnus-tmp-qualified-group - (gnus-group-name-decode (gnus-group-real-name gnus-tmp-group) - group-name-charset)) + (gnus-group-real-name gnus-tmp-group)) (gnus-tmp-comment (or (gnus-group-get-parameter gnus-tmp-group 'comment t) gnus-tmp-group)) (gnus-tmp-newsgroup-description (if gnus-description-hashtb - (or (gnus-group-name-decode - (gethash gnus-tmp-group gnus-description-hashtb) - group-name-charset) "") + (or (gethash gnus-tmp-group gnus-description-hashtb) "") "")) (gnus-tmp-moderated (if (and gnus-moderated-hashtb @@ -1574,9 +1562,7 @@ if it is a string, only list groups matching REGEXP." (point) (prog1 (1+ (point)) ;; Insert the text. - (let ((gnus-tmp-decoded-group (gnus-group-name-decode - gnus-tmp-group group-name-charset))) - (eval gnus-group-line-format-spec))) + (eval gnus-group-line-format-spec)) `(gnus-group ,gnus-tmp-group gnus-unread ,(if (numberp number) (string-to-number gnus-tmp-number-of-unread) @@ -2117,9 +2103,7 @@ be permanent." (defun gnus-group-name-at-point () "Return a group name from around point if it exists, or nil." (if (derived-mode-p 'gnus-group-mode) - (let ((group (gnus-group-group-name))) - (when group - (gnus-group-decoded-name group))) + (gnus-group-group-name) ;; FIXME: Use rx. (let ((regexp "[][\C-@-\t\v-*,/:-@\\^`{-\C-?]*\ \\(nn[a-z]+\\(?:\\+[^][\C-@-*,/:-@\\^`{-\C-?]+\\)?:\ @@ -2160,41 +2144,25 @@ be permanent." require-match initial-input hist def) "Read a group name with completion. -Non-ASCII group names are allowed. The arguments are the same as -`completing-read' except that COLLECTION and HIST default to -`gnus-active-hashtb' and `gnus-group-history' respectively if -they are omitted. Can handle COLLECTION as a list, hash table, -or vector." +The arguments are the same as `completing-read' except that +COLLECTION and HIST default to `gnus-active-hashtb' and +`gnus-group-history' respectively if they are omitted. Can +handle COLLECTION as a list, hash table, or vector." + ;; This function handles vectors for backwards compatibility. In + ;; theory, `collection' will only ever be a list or a hash table. (or collection (setq collection gnus-active-hashtb)) (let* ((choices - (mapcar - (lambda (g) - (if (string-match "[^\000-\177]" g) - (gnus-group-decoded-name g) - g)) (cond ((listp collection) collection) ((vectorp collection) (mapatoms #'symbol-name collection)) ((hash-table-p collection) - (hash-table-keys collection))))) + (hash-table-keys collection)))) (group (gnus-completing-read (or prompt "Group") (reverse choices) require-match initial-input (or hist 'gnus-group-history) def))) - (unless (cond ((and (listp collection) - (symbolp (car collection))) - (member group (mapcar 'symbol-name collection))) - ((listp collection) - (member group collection)) - ((vectorp collection) - (symbol-value (intern-soft group collection))) - ((hash-table-p collection) - (gethash group collection))) - (setq group - (encode-coding-string - group (gnus-group-name-charset nil group)))) (replace-regexp-in-string "\n" "" group))) ;;;###autoload @@ -2755,13 +2723,13 @@ The user will be prompted for GROUP." (interactive (list (gnus-group-completing-read))) (gnus-group-make-group (gnus-group-real-name group) (gnus-group-server group) - nil nil t)) + nil nil)) -(defun gnus-group-make-group (name &optional method address args encoded) +(defun gnus-group-make-group (name &optional method address args) "Add a new newsgroup. The user will be prompted for a NAME, for a select METHOD, and an ADDRESS. NAME should be a human-readable string (i.e., not be encoded -even if it contains non-ASCII characters) unless ENCODED is non-nil. +even if it contains non-ASCII characters). If the backend supports it, the group will also be created on the server." @@ -2772,10 +2740,6 @@ server." (when (stringp method) (setq method (or (gnus-server-to-method method) method))) - (unless encoded - (setq name (encode-coding-string - name - (gnus-group-name-charset method name)))) (let* ((meth (gnus-method-simplify (when (and method (not (gnus-server-equal method gnus-select-method))) @@ -2784,7 +2748,7 @@ server." (nname (if method (gnus-group-prefixed-name name meth) name)) backend info) (when (gnus-group-entry nname) - (error "Group %s already exists" (gnus-group-decoded-name nname))) + (error "Group %s already exists" nname)) ;; Subscribe to the new group. (gnus-group-change-level (setq info (list t nname gnus-level-default-subscribed nil nil meth)) @@ -2860,20 +2824,19 @@ be removed from the server, even when it's empty." (unless (gnus-check-backend-function 'request-delete-group group) (error "This back end does not support group deletion")) (prog1 - (let ((group-decoded (gnus-group-decoded-name group))) - (when (or no-prompt - (gnus-yes-or-no-p - (format - "Do you really want to delete %s%s? " - group-decoded (if force " and all its contents" "")))) - (gnus-message 6 "Deleting group %s..." group-decoded) - (if (not (gnus-request-delete-group group force)) - (gnus-error 3 "Couldn't delete group %s" group-decoded) - (gnus-message 6 "Deleting group %s...done" group-decoded) - (gnus-group-goto-group group) - (gnus-group-kill-group 1 t) - (gnus-set-active group nil) - t))) + (when (or no-prompt + (gnus-yes-or-no-p + (format + "Do you really want to delete %s%s? " + group (if force " and all its contents" "")))) + (gnus-message 6 "Deleting group %s..." group) + (if (not (gnus-request-delete-group group force)) + (gnus-error 3 "Couldn't delete group %s" group) + (gnus-message 6 "Deleting group %s...done" group) + (gnus-group-goto-group group) + (gnus-group-kill-group 1 t) + (gnus-set-active group nil) + t)) (gnus-group-position-point))) (defun gnus-group-rename-group (group new-name) @@ -2887,13 +2850,9 @@ and NEW-NAME will be prompted for." (error "This back end does not support renaming groups")) (setq new-name (gnus-read-group "Rename group to: " - (gnus-group-real-name (gnus-group-decoded-name group))) + (gnus-group-real-name group)) method (gnus-info-method (gnus-get-info group))) - (list group (encode-coding-string - new-name - (gnus-group-name-charset - method - (gnus-group-prefixed-name new-name method)))))) + (list group (gnus-group-prefixed-name new-name method)))) (unless (gnus-check-backend-function 'request-rename-group group) (error "This back end does not support renaming groups")) @@ -2912,34 +2871,30 @@ and NEW-NAME will be prompted for." (gnus-group-real-name new-name) (gnus-info-method (gnus-get-info group))))) - (let ((decoded-group (gnus-group-decoded-name group)) - (decoded-new-name (gnus-group-decoded-name new-name))) - (when (gnus-active new-name) - (error "The group %s already exists" decoded-new-name)) + (when (gnus-active new-name) + (error "The group %s already exists" new-name)) - (gnus-message 6 "Renaming group %s to %s..." - decoded-group decoded-new-name) - (prog1 - (if (progn - (gnus-group-goto-group group) - (not (when (< (gnus-group-group-level) gnus-level-zombie) - (gnus-request-rename-group group new-name)))) - (gnus-error 3 "Couldn't rename group %s to %s" - decoded-group decoded-new-name) - ;; We rename the group internally by killing it... - (gnus-group-kill-group) - ;; ... changing its name ... - (setcar (cdar gnus-list-of-killed-groups) new-name) - ;; ... and then yanking it. Magic! - (gnus-group-yank-group) - (gnus-set-active new-name (gnus-active group)) - (gnus-message 6 "Renaming group %s to %s...done" - decoded-group decoded-new-name) - new-name) - (setq gnus-killed-list (delete group gnus-killed-list)) - (gnus-set-active group nil) - (gnus-dribble-touch) - (gnus-group-position-point)))) + (gnus-message 6 "Renaming group %s to %s..." group new-name) + (prog1 + (if (progn + (gnus-group-goto-group group) + (not (when (< (gnus-group-group-level) gnus-level-zombie) + (gnus-request-rename-group group new-name)))) + (gnus-error 3 "Couldn't rename group %s to %s" + group new-name) + ;; We rename the group internally by killing it... + (gnus-group-kill-group) + ;; ... changing its name ... + (setcar (cdar gnus-list-of-killed-groups) new-name) + ;; ... and then yanking it. Magic! + (gnus-group-yank-group) + (gnus-set-active new-name (gnus-active group)) + (gnus-message 6 "Renaming group %s to %s...done" group new-name) + new-name) + (setq gnus-killed-list (delete group gnus-killed-list)) + (gnus-set-active group nil) + (gnus-dribble-touch) + (gnus-group-position-point))) (defun gnus-group-edit-group (group &optional part) "Edit the group on the current line." @@ -2966,7 +2921,7 @@ and NEW-NAME will be prompted for." ((eq part 'method) "select method") ((eq part 'params) "group parameters") (t "group info")) - (gnus-group-decoded-name group)) + group) `(lambda (form) (gnus-group-edit-group-done ',part ,group form))) (local-set-key @@ -3105,8 +3060,7 @@ If called with a prefix argument, ask for the file type." (coding (gnus-group-name-charset method name))) (setcar (cdr method) (encode-coding-string file coding)) (gnus-group-make-group - (encode-coding-string (gnus-group-real-name name) coding) - method nil nil t))) + (gnus-group-real-name name) method nil nil))) (defvar nnweb-type-definition) (defvar gnus-group-web-type-history nil) @@ -3611,7 +3565,7 @@ up is returned." "Do you really want to mark all articles in %s as read? " "Mark all unread articles in %s as read? ") (if (= (length groups) 1) - (gnus-group-decoded-name (car groups)) + (car groups) (format "these %d groups" (length groups))))))) n (while (setq group (pop groups)) @@ -3696,8 +3650,7 @@ Uses the process/prefix convention." (defun gnus-group-expire-articles-1 (group) (when (gnus-check-backend-function 'request-expire-articles group) - (gnus-message 6 "Expiring articles in %s..." - (gnus-group-decoded-name group)) + (gnus-message 6 "Expiring articles in %s..." group) (let* ((info (gnus-get-info group)) (expirable (if (gnus-group-total-expirable-p group) (cons nil (gnus-list-of-read-articles group)) @@ -3724,8 +3677,7 @@ Uses the process/prefix convention." ;; Just expire using the normal expiry values. (gnus-request-expire-articles articles-to-expire group)))) (gnus-close-group group)) - (gnus-message 6 "Expiring articles in %s...done" - (gnus-group-decoded-name group)) + (gnus-message 6 "Expiring articles in %s...done" group) ;; Return the list of un-expired articles. (cdr expirable)))) @@ -3762,7 +3714,7 @@ Uses the process/prefix convention." (dolist (group (gnus-group-process-prefix n)) (gnus-group-remove-mark group) (gnus-message 6 "Changed level of %s from %d to %d" - (gnus-group-decoded-name group) + group (or (gnus-group-group-level) gnus-level-killed) level) (gnus-group-change-level @@ -3909,7 +3861,7 @@ of groups killed." ;; `gnus-newsrc-hashtb', this check will always return nil. (when (numberp (gnus-group-unread group)) (gnus-request-update-group-status group 'unsubscribe)) - (message "Killed group %s" (gnus-group-decoded-name group))) + (message "Killed group %s" group)) ;; If there are lots and lots of groups to be killed, we use ;; this thing instead. (dolist (group (nreverse groups)) @@ -4047,7 +3999,7 @@ entail asking the server for the groups." (add-text-properties (point) (prog1 (1+ (point)) (insert " *: " - (gnus-group-decoded-name group) + group "\n")) (list 'gnus-group group 'gnus-unread t @@ -4494,9 +4446,9 @@ and the second element is the address." (prin1-to-string (car method))) (and (consp method) (nth 1 (gnus-info-method info))) - nil t) + nil) ;; It's a native group. - (gnus-group-make-group (gnus-info-group info) nil nil nil t))) + (gnus-group-make-group (gnus-info-group info) nil nil nil))) (gnus-message 6 "Note: New group created") (setq entry (gnus-group-entry (gnus-group-prefixed-name @@ -4685,7 +4637,7 @@ This command may read the active file." (while (setq point (text-property-not-all (point) (point-max) 'gnus-group nil)) (goto-char point) - (push (symbol-name (get-text-property point 'gnus-group)) groups) + (push (get-text-property point 'gnus-group) groups) (forward-char 1)) groups)) @@ -4776,21 +4728,20 @@ Note: currently only implemented in nnml." (error "No group to compact")) (unless (gnus-check-backend-function 'request-compact-group group) (error "This back end does not support group compaction")) - (let ((group-decoded (gnus-group-decoded-name group))) - (gnus-message 6 "\ + (gnus-message 6 "\ Compacting group %s... (this may take a long time)" - group-decoded) - (prog1 - (if (not (gnus-request-compact-group group)) - (gnus-error 3 "Couldn't compact group %s" group-decoded) - (gnus-message 6 "Compacting group %s...done" group-decoded) - t) - ;; Invalidate the "original article" buffer which might be out of date. - ;; #### NOTE: Yes, this might be a bit rude, but since compaction - ;; #### will not happen very often, I think this is acceptable. - (gnus-kill-buffer gnus-original-article-buffer) - ;; Update the group line to reflect new information (art number etc). - (gnus-group-update-group-line)))) + group) + (prog1 + (if (not (gnus-request-compact-group group)) + (gnus-error 3 "Couldn't compact group %s" group) + (gnus-message 6 "Compacting group %s...done" group) + t) + ;; Invalidate the "original article" buffer which might be out of date. + ;; #### NOTE: Yes, this might be a bit rude, but since compaction + ;; #### will not happen very often, I think this is acceptable. + (gnus-kill-buffer gnus-original-article-buffer) + ;; Update the group line to reflect new information (art number etc). + (gnus-group-update-group-line))) (provide 'gnus-group) diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index 819936d935..25efb8afda 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -391,7 +391,7 @@ only affect the Gcc copy, but not the original message." (defun gnus-inews-make-draft (articles) `(lambda () (gnus-inews-make-draft-meta-information - ,(gnus-group-decoded-name gnus-newsgroup-name) ',articles))) + ,gnus-newsgroup-name ',articles))) (autoload 'nnir-article-number "nnir" nil nil 'macro) (autoload 'nnir-article-group "nnir" nil nil 'macro) @@ -1680,7 +1680,6 @@ this is a reply." (defun gnus-inews-insert-gcc (&optional group) "Insert the Gcc to say where the article is to be archived." (let* ((group (or group gnus-newsgroup-name)) - (group (when group (gnus-group-decoded-name group))) (var (or gnus-outgoing-message-group gnus-message-archive-group)) (gcc-self-val (and group (not (gnus-virtual-group-p group)) diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index 972ff28e63..71c7807518 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -784,11 +784,13 @@ claim them." (while (not (eobp)) (ignore-errors (push (cons - (buffer-substring - (point) - (progn - (skip-chars-forward "^ \t") - (point))) + (decode-coding-string + (buffer-substring + (point) + (progn + (skip-chars-forward "^ \t") + (point))) + 'utf-8-emacs) (let ((last (read cur))) (cons (read cur) last))) groups)) @@ -796,18 +798,20 @@ claim them." (while (not (eobp)) (ignore-errors (push (cons - (if (eq (char-after) ?\") - (read cur) - (let ((p (point)) (name "")) - (skip-chars-forward "^ \t\\\\") - (setq name (buffer-substring p (point))) - (while (eq (char-after) ?\\) - (setq p (1+ (point))) - (forward-char 2) - (skip-chars-forward "^ \t\\\\") - (setq name (concat name (buffer-substring - p (point))))) - name)) + (decode-coding-string + (if (eq (char-after) ?\") + (read cur) + (let ((p (point)) (name "")) + (skip-chars-forward "^ \t\\\\") + (setq name (buffer-substring p (point))) + (while (eq (char-after) ?\\) + (setq p (1+ (point))) + (forward-char 2) + (skip-chars-forward "^ \t\\\\") + (setq name (concat name (buffer-substring + p (point))))) + name)) + 'utf-8-emacs) (let ((last (read cur))) (cons (read cur) last))) groups)) @@ -859,12 +863,7 @@ claim them." ((= level gnus-level-zombie) ?Z) (t ?K))) (max 0 (- (1+ (cddr group)) (cadr group))) - ;; Don't decode if name is ASCII - (if (eq (detect-coding-string name t) 'undecided) - name - (decode-coding-string - name - (inline (gnus-group-name-charset method name))))))) + name))) (list 'gnus-group name) ))) (switch-to-buffer (current-buffer))) diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index 0f91c4d9b4..f7ede54b10 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -35,6 +35,7 @@ (autoload 'gnus-agent-read-servers-validate "gnus-agent") (autoload 'gnus-agent-save-local "gnus-agent") (autoload 'gnus-agent-possibly-alter-active "gnus-agent") +(declare-function gnus-group-decoded-name "gnus-group" (string)) (eval-when-compile (require 'cl-lib)) @@ -1828,17 +1829,22 @@ The info element is shared with the same element of (if (setq rest (member method methods)) (gnus-info-set-method info (car rest)) (push method methods))) + ;; Check for encoded group names and decode them. + (when (string-match-p "[^[:ascii:]]" (setq gname (car info))) + (let ((decoded (gnus-group-decoded-name gname))) + (setf gname decoded + (car info) decoded))) ;; Check for duplicates. - (if (gethash (car info) gnus-newsrc-hashtb) + (if (gethash gname gnus-newsrc-hashtb) ;; Remove this entry from the alist. (setcdr alist (cddr alist)) (puthash - (car info) + gname ;; Preserve number of unread articles in groups. - (list (and ohashtb (car (gethash (car info) ohashtb))) + (list (and ohashtb (car (gethash gname ohashtb))) info) gnus-newsrc-hashtb) - (push (car info) gnus-group-list)) + (push gname gnus-group-list)) (setq alist (cdr alist))) (setq gnus-group-list (nreverse gnus-group-list)) ;; Make the same select-methods in `gnus-server-alist' identical @@ -2144,9 +2150,7 @@ The info element is shared with the same element of (cond ((numberp group) (number-to-string group)) ((symbolp group) - (encode-coding-string - (symbol-name group) - 'latin-1)) + (symbol-name group)) ((stringp group) group))))) (numberp (setq max (read cur))) @@ -2155,7 +2159,11 @@ The info element is shared with the same element of (skip-chars-forward " \t") (memq (char-after) '(?= ?x ?j))))) - (progn (puthash group (cons min max) hashtb) + (progn (when (string-match-p "[^[:ascii:]]" group) + ;; NNTP servers may give us encoded group + ;; names. + (setq group (gnus-group-decoded-name group))) + (puthash group (cons min max) hashtb) ;; If group is moderated, stick it in the ;; moderation cache. (when (eq (char-after) ?m) @@ -2394,6 +2402,17 @@ If FORCE is non-nil, the .newsrc file is read." (when gnus-newsrc-assoc (setq gnus-newsrc-alist gnus-newsrc-assoc)))) (gnus-make-hashtable-from-newsrc-alist) + (when gnus-topic-alist + (setq gnus-topic-alist + (mapcar + (lambda (elt) + (cons (car elt) + (mapcar (lambda (g) + (if (string-match-p "[^[:ascii:]]" g) + (gnus-group-decoded-name g) + g)) + (cdr elt)))) + gnus-topic-alist))) (when (file-newer-than-file-p file ding-file) ;; Old format quick file (gnus-message 5 "Reading %s..." file) @@ -2492,7 +2511,9 @@ If FORCE is non-nil, the .newsrc file is read." (read buf)) group (if (numberp group) (number-to-string group) - (symbol-name group))) + ;; newsrc files are written as 'raw-text. + (decode-coding-string + (symbol-name group) 'raw-text))) (widen) (cond ;; It's possible that "group" is actually an options line. @@ -2911,10 +2932,6 @@ SPECIFIC-VARIABLES, or those in `gnus-variable-list'." (setq default-directory (file-name-directory buffer-file-name)) (buffer-disable-undo) (erase-buffer) - ;; Use a unibyte buffer since group names are unibyte strings; - ;; in particular, non-ASCII group names are the ones encoded by - ;; a certain coding system. - (mm-disable-multibyte) ;; Write options. (when gnus-newsrc-options (insert gnus-newsrc-options)) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 73f0eb3918..a6a0bdb228 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -3500,8 +3500,7 @@ value of GROUP, and puts the buffer in `gnus-summary-mode'. Returns non-nil if the setup was successful." (let ((buffer (gnus-summary-buffer-name group)) - (dead-name (concat "*Dead Summary " - (gnus-group-decoded-name group) "*"))) + (dead-name (concat "*Dead Summary " group "*"))) ;; If a dead summary buffer exists, we kill it. (gnus-kill-buffer dead-name) (if (get-buffer buffer) @@ -3984,8 +3983,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." ;; (when (and (not (gnus-group-native-p group)) ;; (not (gethash group gnus-newsrc-hashtb))) ;; (error "Dead non-native groups can't be entered")) - (gnus-message 7 "Retrieving newsgroup: %s..." - (gnus-group-decoded-name group)) + (gnus-message 7 "Retrieving newsgroup: %s..." group) (let* ((new-group (gnus-summary-setup-buffer group)) (quit-config (gnus-group-quit-config group)) (did-select (and new-group (gnus-select-newsgroup @@ -4016,8 +4014,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (gnus-group-next-unread-group 1)) (gnus-handle-ephemeral-exit quit-config))) (if (null (gnus-list-of-unread-articles group)) - (gnus-message 3 "Group %s contains no messages" - (gnus-group-decoded-name group)) + (gnus-message 3 "Group %s contains no messages" group) (gnus-message 3 "Can't select group")) nil) ;; The user did a `C-g' while prompting for number of articles, @@ -5618,25 +5615,24 @@ or a straight list of headers." (defun gnus-fetch-headers (articles &optional limit force-new dependencies) "Fetch headers of ARTICLES." - (let ((name (gnus-group-decoded-name gnus-newsgroup-name))) - (gnus-message 7 "Fetching headers for %s..." name) - (prog1 - (if (eq 'nov - (setq gnus-headers-retrieved-by - (gnus-retrieve-headers - articles gnus-newsgroup-name - (or limit - ;; We might want to fetch old headers, but - ;; not if there is only 1 article. - (and (or (and - (not (eq gnus-fetch-old-headers 'some)) - (not (numberp gnus-fetch-old-headers))) - (> (length articles) 1)) - gnus-fetch-old-headers))))) - (gnus-get-newsgroup-headers-xover - articles force-new dependencies gnus-newsgroup-name t) - (gnus-get-newsgroup-headers dependencies force-new)) - (gnus-message 7 "Fetching headers for %s...done" name)))) + (gnus-message 7 "Fetching headers for %s..." gnus-newsgroup-name) + (prog1 + (if (eq 'nov + (setq gnus-headers-retrieved-by + (gnus-retrieve-headers + articles gnus-newsgroup-name + (or limit + ;; We might want to fetch old headers, but + ;; not if there is only 1 article. + (and (or (and + (not (eq gnus-fetch-old-headers 'some)) + (not (numberp gnus-fetch-old-headers))) + (> (length articles) 1)) + gnus-fetch-old-headers))))) + (gnus-get-newsgroup-headers-xover + articles force-new dependencies gnus-newsgroup-name t) + (gnus-get-newsgroup-headers dependencies force-new)) + (gnus-message 7 "Fetching headers for %s...done" gnus-newsgroup-name))) (defun gnus-select-newsgroup (group &optional read-all select-articles) "Select newsgroup GROUP. @@ -5649,13 +5645,12 @@ If SELECT-ARTICLES, only select those articles from GROUP." t gnus-summary-ignore-duplicates)) (info (nth 1 entry)) - charset articles fetched-articles cached) + articles fetched-articles cached) (unless (gnus-check-server (set (make-local-variable 'gnus-current-select-method) (gnus-find-method-for-group group))) (error "Couldn't open server")) - (setq charset (gnus-group-name-charset gnus-current-select-method group)) (or (and entry (not (eq (car entry) t))) ; Either it's active... (gnus-activate-group group) ; Or we can activate it... @@ -5663,16 +5658,12 @@ If SELECT-ARTICLES, only select those articles from GROUP." (when (derived-mode-p 'gnus-summary-mode) (gnus-kill-buffer (current-buffer))) (error - "Couldn't activate group %s: %s" - (decode-coding-string group charset) - (decode-coding-string (gnus-status-message group) charset)))) + "Couldn't activate group %s: %s" group (gnus-status-message group)))) (unless (gnus-request-group group t nil info) (when (derived-mode-p 'gnus-summary-mode) (gnus-kill-buffer (current-buffer))) - (error "Couldn't request group %s: %s" - (decode-coding-string group charset) - (decode-coding-string (gnus-status-message group) charset))) + (error "Couldn't request group %s: %s" group (gnus-status-message group))) (when (and gnus-agent (gnus-active group)) @@ -5938,13 +5929,11 @@ If SELECT-ARTICLES, only select those articles from GROUP." (if only-read-p (format "How many articles from %s (available %d, default %d): " - (gnus-group-real-name - (gnus-group-decoded-name gnus-newsgroup-name)) + (gnus-group-real-name gnus-newsgroup-name) number default) (format "How many articles from %s (%d default): " - (gnus-group-real-name - (gnus-group-decoded-name gnus-newsgroup-name)) + (gnus-group-real-name gnus-newsgroup-name) default)) nil nil @@ -5956,8 +5945,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (read-string (format "%s %s (%d scored, %d total): " "How many articles from" - (gnus-group-decoded-name - (gnus-group-real-name gnus-newsgroup-name)) + (gnus-group-real-name gnus-newsgroup-name) scored number)))) (if (string-match "^[ \t]*$" input) number input))) @@ -6199,8 +6187,7 @@ If WHERE is `summary', the summary mode line format will be used." (intern (format "gnus-%s-mode-line-format-spec" where)))) (gnus-tmp-group-name (gnus-mode-string-quote - (gnus-group-decoded-name - gnus-newsgroup-name))) + gnus-newsgroup-name)) (gnus-tmp-article-number (or gnus-current-article 0)) (gnus-tmp-unread gnus-newsgroup-unreads) (gnus-tmp-unread-and-unticked (length gnus-newsgroup-unreads)) @@ -7921,11 +7908,11 @@ If BACKWARD, the previous article is selected instead of the next." (not (gnus-ephemeral-group-p gnus-newsgroup-name))) (format " (Type %s for %s [%s])" (single-key-description cmd) - (gnus-group-decoded-name group) + group (gnus-group-unread group)) (format " (Type %s to exit %s)" (single-key-description cmd) - (gnus-group-decoded-name gnus-newsgroup-name))))) + gnus-newsgroup-name)))) ;; Confirm auto selection. (setq key (car (setq keve (gnus-read-event-char prompt))) ended t) @@ -10110,7 +10097,7 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (copy-buf (save-excursion (nnheader-set-temp-buffer " *copy article*"))) art-group to-method new-xref article to-groups - articles-to-update-marks encoded) + articles-to-update-marks) (unless (assq action names) (error "Unknown action %s" action)) ;; Read the newsgroup name. @@ -10132,22 +10119,12 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (symbol-value (intern (format "gnus-current-%s-group" action))) articles prefix) - encoded to-newsgroup to-method (gnus-server-to-method (gnus-group-method to-newsgroup))) - (set (intern (format "gnus-current-%s-group" action)) - (decode-coding-string - to-newsgroup - (gnus-group-name-charset to-method to-newsgroup)))) + (set (intern (format "gnus-current-%s-group" action)) to-newsgroup)) (unless to-method (setq to-method (or select-method (gnus-server-to-method (gnus-group-method to-newsgroup))))) - (setq to-newsgroup - (or encoded - (and to-newsgroup - (encode-coding-string - to-newsgroup - (gnus-group-name-charset to-method to-newsgroup))))) ;; Check the method we are to move this article to... (unless (gnus-check-backend-function 'request-accept-article (car to-method)) @@ -10157,7 +10134,7 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (gnus-message 6 "%s to %s: %s..." (caddr (assq action names)) (or (car select-method) - (gnus-group-decoded-name to-newsgroup)) + to-newsgroup) articles) ;; This `while' is not equivalent to a `dolist' (bug#33653#134). (while articles @@ -12469,27 +12446,23 @@ save those articles instead." (t (gnus-completing-read prom (nreverse split-name) nil nil 'gnus-group-history)))) - (to-method (gnus-server-to-method (gnus-group-method to-newsgroup))) - encoded) + (to-method (gnus-server-to-method (gnus-group-method to-newsgroup)))) (when to-newsgroup (if (or (string= to-newsgroup "") (string= to-newsgroup prefix)) (setq to-newsgroup default)) (unless to-newsgroup - (user-error "No group name entered")) - (setq encoded (encode-coding-string - to-newsgroup - (gnus-group-name-charset to-method to-newsgroup))) - (or (gnus-active encoded) - (gnus-activate-group encoded nil nil to-method) + (error "No group name entered")) + (or (gnus-active to-newsgroup) + (gnus-activate-group to-newsgroup nil nil to-method) (if (gnus-y-or-n-p (format "No such group: %s. Create it? " to-newsgroup)) - (or (and (gnus-request-create-group encoded to-method) - (gnus-activate-group encoded nil nil to-method) - (gnus-subscribe-group encoded)) + (or (and (gnus-request-create-group to-newsgroup to-method) + (gnus-activate-group to-newsgroup nil nil to-method) + (gnus-subscribe-group to-newsgroup)) (error "Couldn't create group %s" to-newsgroup))) - (user-error "No such group: %s" to-newsgroup)) - encoded))) + (error "No such group: %s" to-newsgroup)) + to-newsgroup))) (defvar gnus-summary-save-parts-counter) (declare-function mm-uu-dissect "mm-uu" (&optional noheader mime-type)) @@ -13156,7 +13129,7 @@ If ALL is a number, fetch this number of articles." (read-string (format "How many articles from %s (%s %d): " - (gnus-group-decoded-name gnus-newsgroup-name) + gnus-newsgroup-name (if initial "max" "default") len) nil nil diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 9ccdb83865..c6be59fd19 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -1173,16 +1173,9 @@ ARG is passed to the first function." "Return non-nil if all ELEMENTS are non-nil." (not (memq nil elements))) -;; gnus.el requires mm-util. -(declare-function mm-disable-multibyte "mm-util") - (defun gnus-write-active-file (file hashtb &optional full-names) - ;; `coding-system-for-write' should be `raw-text' or equivalent. (let ((coding-system-for-write nnmail-active-file-coding-system)) (with-temp-file file - ;; The buffer should be in the unibyte mode because group names - ;; are ASCII text or encoded non-ASCII text (i.e., unibyte). - (mm-disable-multibyte) (maphash (lambda (group active) (when active diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 9ee7db9e20..f990569a30 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -3444,11 +3444,9 @@ server is native)." "Return the prefix of the current group name." (< 0 (length (gnus-group-real-prefix group)))) -(declare-function gnus-group-decoded-name "gnus-group" (string)) - (defun gnus-summary-buffer-name (group) "Return the summary buffer name of GROUP." - (concat "*Summary " (gnus-group-decoded-name group) "*")) + (concat "*Summary " group "*")) (defun gnus-group-method (group) "Return the server or method used for selecting GROUP. diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 4900686b85..71e1750ba4 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -1894,7 +1894,6 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." (autoload 'gnus-delay-article "gnus-delay") (autoload 'gnus-extract-address-components "gnus-util") (autoload 'gnus-find-method-for-group "gnus") -(autoload 'gnus-group-decoded-name "gnus-group") (autoload 'gnus-group-name-charset "gnus-group") (autoload 'gnus-group-name-decode "gnus-group") (autoload 'gnus-groups-from-server "gnus") @@ -5628,7 +5627,7 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." (concat msg-id (if msg-id " (") (if (car name) - (if (string-match "[^\000-\177]" (car name)) + (if (string-match "[^[:ascii:]]" (car name)) ;; Quote a string containing non-ASCII characters. ;; It will make the RFC2047 encoder cause an error ;; if there are special characters. @@ -7285,12 +7284,11 @@ news, Source is the list of newsgroups is was posted to." (let* ((group (message-fetch-field "newsgroups")) (from (message-fetch-field "from")) (prefix - (if group - (gnus-group-decoded-name group) - (or (and from (or - (car (gnus-extract-address-components from)) - (cadr (gnus-extract-address-components from)))) - "(nowhere)")))) + (or group + (or (and from (or + (car (gnus-extract-address-components from)) + (cadr (gnus-extract-address-components from)))) + "(nowhere)")))) (concat "[" (if message-forward-decoded-p prefix @@ -7304,10 +7302,9 @@ Source is the sender, and if the original message was news, Source is the list of newsgroups is was posted to." (let* ((group (message-fetch-field "newsgroups")) (prefix - (if group - (gnus-group-decoded-name group) - (or (message-fetch-field "from") - "(nowhere)")))) + (or group + (or (message-fetch-field "from") + "(nowhere)")))) (concat "[" (if message-forward-decoded-p prefix diff --git a/lisp/gnus/nnagent.el b/lisp/gnus/nnagent.el index 64f3a86181..f0baf99bd4 100644 --- a/lisp/gnus/nnagent.el +++ b/lisp/gnus/nnagent.el @@ -117,18 +117,17 @@ (gnus-request-accept-article "nndraft:queue" nil t t)) (deffoo nnagent-request-set-mark (group action server) - (mm-with-unibyte-buffer - (insert "(gnus-agent-synchronize-group-flags \"" - group - "\" '") - (gnus-pp action) - (insert " \"" - (gnus-method-to-server gnus-command-method) - "\"") - (insert ")\n") - (let ((coding-system-for-write nnheader-file-coding-system)) - (write-region (point-min) (point-max) (gnus-agent-lib-file "flags") - t 'silent))) + (insert "(gnus-agent-synchronize-group-flags \"" + group + "\" '") + (gnus-pp action) + (insert " \"" + (gnus-method-to-server gnus-command-method) + "\"") + (insert ")\n") + (let ((coding-system-for-write nnheader-file-coding-system)) + (write-region (point-min) (point-max) (gnus-agent-lib-file "flags") + t 'silent)) ;; Also set the marks for the original back end that keeps marks in ;; the local system. (let ((gnus-agent nil)) diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el index 6ef324ae91..c87cfc8c7c 100644 --- a/lisp/gnus/nnheader.el +++ b/lisp/gnus/nnheader.el @@ -30,7 +30,6 @@ (defvar nnmail-extra-headers) (defvar gnus-newsgroup-name) -(defvar nnheader-file-coding-system) (defvar jka-compr-compression-info-list) ;; Requiring `gnus-util' at compile time creates a circular @@ -499,7 +498,8 @@ the line could be found." (defvar nntp-server-buffer nil) (defvar nntp-process-response nil) - +(defvar nnheader-file-coding-system 'undecided + "Coding system used in file backends of Gnus.") (defvar nnheader-callback-function nil) (defun nnheader-init-server-buffer () @@ -871,9 +871,6 @@ first. Otherwise, find the newest one, though it may take a time." (when (string-match (car ange-ftp-path-format) path) (ange-ftp-re-read-dir path))))) -(defvar nnheader-file-coding-system 'raw-text - "Coding system used in file backends of Gnus.") - (defun nnheader-insert-file-contents (filename &optional visit beg end replace) "Like `insert-file-contents', q.v., but only reads in the file. A buffer may be modified in several ways after reading into the buffer due diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index 0c5aaf32d4..6f2ebfb7fe 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -118,12 +118,6 @@ some servers.") (defvoo nnimap-namespace nil) -(defun nnimap-decode-gnus-group (group) - (decode-coding-string group 'utf-8)) - -(defun nnimap-encode-gnus-group (group) - (encode-coding-string group 'utf-8)) - (defvoo nnimap-fetch-partial-articles nil "If non-nil, Gnus will fetch partial articles. If t, Gnus will fetch only the first part. If a string, it @@ -208,8 +202,6 @@ textual parts.") (format "%s" (nreverse params)))) (deffoo nnimap-retrieve-headers (articles &optional group server _fetch-old) - (when group - (setq group (nnimap-decode-gnus-group group))) (with-current-buffer nntp-server-buffer (erase-buffer) (when (nnimap-change-group group server) @@ -644,8 +636,6 @@ textual parts.") nnimap-status-string) (deffoo nnimap-request-article (article &optional group server to-buffer) - (when group - (setq group (nnimap-decode-gnus-group group))) (with-current-buffer nntp-server-buffer (let ((result (nnimap-change-group group server)) parts structure) @@ -677,8 +667,6 @@ textual parts.") (cons group article))))))) (deffoo nnimap-request-head (article &optional group server to-buffer) - (when group - (setq group (nnimap-decode-gnus-group group))) (when (nnimap-change-group group server) (with-current-buffer (nnimap-buffer) (when (stringp article) @@ -696,8 +684,6 @@ textual parts.") (cons group article))))))) (deffoo nnimap-request-articles (articles &optional group server) - (when group - (setq group (nnimap-decode-gnus-group group))) (with-current-buffer nntp-server-buffer (let ((result (nnimap-change-group group server))) (when result @@ -847,7 +833,6 @@ textual parts.") (nreverse parts))) (deffoo nnimap-request-group (group &optional server dont-check info) - (setq group (nnimap-decode-gnus-group group)) (let ((result (nnimap-change-group ;; Don't SELECT the group if we're going to select it ;; later, anyway. @@ -874,11 +859,10 @@ textual parts.") (- (cdr active) (car active)) (car active) (cdr active) - (nnimap-encode-gnus-group group))) + group)) t)))) (deffoo nnimap-request-group-scan (group &optional server info) - (setq group (nnimap-decode-gnus-group group)) (when (nnimap-change-group nil server) (let (marks high low) (with-current-buffer (nnimap-buffer) @@ -910,23 +894,20 @@ textual parts.") (insert (format "211 %d %d %d %S\n" (1+ (- high low)) low high - (nnimap-encode-gnus-group group))) + group)) t)))) (deffoo nnimap-request-create-group (group &optional server _args) - (setq group (nnimap-decode-gnus-group group)) (when (nnimap-change-group nil server) (with-current-buffer (nnimap-buffer) (car (nnimap-command "CREATE %S" (nnimap-group-to-imap group)))))) (deffoo nnimap-request-delete-group (group &optional _force server) - (setq group (nnimap-decode-gnus-group group)) (when (nnimap-change-group nil server) (with-current-buffer (nnimap-buffer) (car (nnimap-command "DELETE %S" (nnimap-group-to-imap group)))))) (deffoo nnimap-request-rename-group (group new-name &optional server) - (setq group (nnimap-decode-gnus-group group)) (when (nnimap-change-group nil server) (with-current-buffer (nnimap-buffer) (nnimap-unselect-group) @@ -941,7 +922,6 @@ textual parts.") (nnimap-command "EXAMINE DOES.NOT.EXIST")) (deffoo nnimap-request-expunge-group (group &optional server) - (setq group (nnimap-decode-gnus-group group)) (when (nnimap-change-group group server) (with-current-buffer (nnimap-buffer) (car (nnimap-command "EXPUNGE"))))) @@ -970,9 +950,6 @@ textual parts.") (deffoo nnimap-request-move-article (article group server accept-form &optional _last internal-move-group) - (setq group (nnimap-decode-gnus-group group)) - (when internal-move-group - (setq internal-move-group (nnimap-decode-gnus-group internal-move-group))) (with-temp-buffer (mm-disable-multibyte) (when (funcall (if internal-move-group @@ -1006,7 +983,6 @@ textual parts.") result)))))) (deffoo nnimap-request-expire-articles (articles group &optional server force) - (setq group (nnimap-decode-gnus-group group)) (cond ((null articles) nil) @@ -1151,8 +1127,6 @@ If LIMIT, first try to limit the search to the N last articles." "delete this article now")))))) (deffoo nnimap-request-scan (&optional group server) - (when group - (setq group (nnimap-decode-gnus-group group))) (when (and (nnimap-change-group nil server) nnimap-inbox nnimap-split-methods) @@ -1171,7 +1145,6 @@ If LIMIT, first try to limit the search to the N last articles." flags)) (deffoo nnimap-request-update-group-status (group status &optional server) - (setq group (nnimap-decode-gnus-group group)) (when (nnimap-change-group nil server) (let ((command (assoc status @@ -1182,7 +1155,6 @@ If LIMIT, first try to limit the search to the N last articles." (nnimap-command "%s %S" (cadr command) (nnimap-group-to-imap group))))))) (deffoo nnimap-request-set-mark (group actions &optional server) - (setq group (nnimap-decode-gnus-group group)) (when (nnimap-change-group group server) (let (sequence) (with-current-buffer (nnimap-buffer) @@ -1217,8 +1189,7 @@ If LIMIT, first try to limit the search to the N last articles." ;; that's determined by the IMAP server later. So just ;; return the group name. (lambda (group) - (list (list group))))))) - (setq group (nnimap-decode-gnus-group group)) + (list (list group))))))) (when (nnimap-change-group nil server) (nnmail-check-syntax) (let ((message-id (message-field-value "message-id")) @@ -1296,7 +1267,6 @@ If LIMIT, first try to limit the search to the N last articles." result)) (deffoo nnimap-request-replace-article (article group buffer) - (setq group (nnimap-decode-gnus-group group)) (let (group-art) (when (and (nnimap-change-group group) ;; Put the article into the group. @@ -1380,8 +1350,7 @@ If LIMIT, first try to limit the search to the N last articles." (dolist (response responses) (let* ((sequence (car response)) (response (cadr response)) - (group (cadr (assoc sequence sequences))) - (egroup (nnimap-encode-gnus-group group))) + (group (cadr (assoc sequence sequences)))) (when (and group (equal (caar response) "OK")) (let ((uidnext (nnimap-find-parameter "UIDNEXT" response)) @@ -1393,14 +1362,14 @@ If LIMIT, first try to limit the search to the N last articles." (setq highest (1- (string-to-number (car uidnext))))) (cond ((null highest) - (insert (format "%S 0 1 y\n" egroup))) + (insert (format "%S 0 1 y\n" group))) ((zerop exists) ;; Empty group. - (insert (format "%S %d %d y\n" egroup + (insert (format "%S %d %d y\n" group highest (1+ highest)))) (t ;; Return the widest possible range. - (insert (format "%S %d 1 y\n" egroup + (insert (format "%S %d 1 y\n" group (or highest exists))))))))) t))))) @@ -1412,7 +1381,7 @@ If LIMIT, first try to limit the search to the N last articles." (nnimap-get-groups))) (unless (assoc group nnimap-current-infos) ;; Insert dummy numbers here -- they don't matter. - (insert (format "%S 0 1 y\n" (nnimap-encode-gnus-group group))))) + (insert (format "%S 0 1 y\n" group)))) t))) (deffoo nnimap-retrieve-group-data-early (server infos) @@ -1429,8 +1398,7 @@ If LIMIT, first try to limit the search to the N last articles." ;; what and how to request the data. (dolist (info infos) (setq params (gnus-info-params info) - group (nnimap-decode-gnus-group - (gnus-group-real-name (gnus-info-group info))) + group (gnus-group-real-name (gnus-info-group info)) active (cdr (assq 'active params)) unexist (assq 'unexist (gnus-info-marks info)) uidvalidity (cdr (assq 'uidvalidity params)) @@ -1511,16 +1479,13 @@ If LIMIT, first try to limit the search to the N last articles." (active (gnus-active group))) (when active (insert (format "%S %d %d y\n" - (nnimap-encode-gnus-group - (nnimap-decode-gnus-group - (gnus-group-real-name group))) + (gnus-group-real-name group) (cdr active) (car active)))))))))))) (defun nnimap-update-infos (flags infos) (dolist (info infos) - (let* ((group (nnimap-decode-gnus-group - (gnus-group-real-name (gnus-info-group info)))) + (let* ((group (gnus-group-real-name (gnus-info-group info))) (marks (cdr (assoc group flags)))) (when marks (nnimap-update-info info marks))))) @@ -1734,8 +1699,7 @@ If LIMIT, first try to limit the search to the N last articles." (nreverse result)))) (defun nnimap-store-info (info active) - (let* ((group (nnimap-decode-gnus-group - (gnus-group-real-name (gnus-info-group info)))) + (let* ((group (gnus-group-real-name (gnus-info-group info))) (entry (assoc group nnimap-current-infos))) (if entry (setcdr entry (list info active)) @@ -1860,8 +1824,6 @@ If LIMIT, first try to limit the search to the N last articles." (autoload 'nnir-search-thread "nnir") (deffoo nnimap-request-thread (header &optional group server) - (when group - (setq group (nnimap-decode-gnus-group group))) (if gnus-refer-thread-use-nnir (nnir-search-thread header) (when (nnimap-change-group group server) diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index 0699e81812..de6b01774d 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -665,9 +665,12 @@ nn*-request-list should have been called before calling this function." (condition-case err (progn (narrow-to-region (point) (point-at-eol)) - (setq group (read buffer)) - (unless (stringp group) - (setq group (encode-coding-string (symbol-name group) 'latin-1))) + (setq group (read buffer) + group + (cond ((symbolp group) + (symbol-name group)) + ((numberp group) + (number-to-string group)))) (if (and (numberp (setq max (read buffer))) (numberp (setq min (read buffer)))) (push (list group (cons min max)) @@ -677,7 +680,7 @@ nn*-request-list should have been called before calling this function." (forward-line 1)) group-assoc)) -(defcustom nnmail-active-file-coding-system 'raw-text +(defcustom nnmail-active-file-coding-system 'utf-8-emacs "Coding system for active file." :group 'nnmail-various :type 'coding-system) @@ -687,7 +690,7 @@ nn*-request-list should have been called before calling this function." (let ((coding-system-for-write nnmail-active-file-coding-system)) (when file-name (with-temp-file file-name - (mm-disable-multibyte) +; (mm-disable-multibyte) (nnmail-generate-active group-assoc))))) (defun nnmail-generate-active (alist) @@ -695,7 +698,7 @@ nn*-request-list should have been called before calling this function." (erase-buffer) (let (group) (while (setq group (pop alist)) - (insert (format "%S %d %d y\n" (intern (car group)) (cdadr group) + (insert (format "%s %d %d y\n" (car group) (cdadr group) (caadr group)))) (goto-char (point-max)) (while (search-backward "\\." nil t) @@ -1027,8 +1030,8 @@ If SOURCE is a directory spec, try to return the group name component." (nnmail-check-duplication message-id func artnum-func)) 1)) -(defvar nnmail-group-names-not-encoded-p nil - "Non-nil means group names are not encoded.") +(make-obsolete-variable 'nnmail-group-names-not-encoded-p + "Group names are always decoded" "27.1") (defun nnmail-split-incoming (incoming func &optional exit-func group artnum-func junk-func) @@ -1036,18 +1039,21 @@ If SOURCE is a directory spec, try to return the group name component." FUNC will be called with the buffer narrowed to each mail. INCOMING can also be a buffer object. In that case, the mail will be copied over from that buffer." - (let ( ;; If this is a group-specific split, we bind the split + (let (;; If this is a group-specific split, we bind the split ;; methods to just this group. (nnmail-split-methods (if (and group (not nnmail-resplit-incoming)) (list (list group "")) - nnmail-split-methods)) - (nnmail-group-names-not-encoded-p t)) + nnmail-split-methods))) ;; Insert the incoming file. (with-current-buffer (get-buffer-create nnmail-article-buffer) (erase-buffer) (if (bufferp incoming) (insert-buffer-substring incoming) + ;; The following coding system is set to + ;; `mm-text-coding-system', which is set to some flavor of + ;; 'raw-text "to get rid of ^Ms". But it's going to do a lot + ;; more than that, right? Shouldn't this also be 'undecided? (let ((coding-system-for-read nnmail-incoming-coding-system)) (mm-insert-file-contents incoming))) (prog1 diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el index 246f52c8d2..d62e1e9253 100644 --- a/lisp/gnus/nnmaildir.el +++ b/lisp/gnus/nnmaildir.el @@ -415,7 +415,7 @@ This variable is set by `nnmaildir-request-article'.") (t (signal (car err) (cdr err))))))))) (defun nnmaildir--update-nov (server group article) - (let ((nnheader-file-coding-system 'binary) + (let ((nnheader-file-coding-system 'undecided) (srv-dir (nnmaildir--srv-dir server)) (storage-version 1) ;; [version article-number msgid [...nov...]] dir gname pgname msgdir prefix suffix file attr mtime novdir novfile diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el index 89c8b23b65..302589bd6d 100644 --- a/lisp/gnus/nnml.el +++ b/lisp/gnus/nnml.el @@ -111,36 +111,9 @@ non-nil.") (nnoo-define-basics nnml) -(eval-when-compile - (defsubst nnml-group-name-charset (group server-or-method) - (gnus-group-name-charset - (if (stringp server-or-method) - (gnus-server-to-method - (if (string-match "\\+" server-or-method) - (concat (substring server-or-method 0 (match-beginning 0)) - ":" (substring server-or-method (match-end 0))) - (concat "nnml:" server-or-method))) - (or server-or-method gnus-command-method '(nnml ""))) - group))) - -(defun nnml-decoded-group-name (group &optional server-or-method) - "Return a decoded group name of GROUP on SERVER-OR-METHOD." - (if nnmail-group-names-not-encoded-p - group - (decode-coding-string - group - (nnml-group-name-charset group server-or-method)))) - -(defun nnml-encoded-group-name (group &optional server-or-method) - "Return an encoded group name of GROUP on SERVER-OR-METHOD." - (encode-coding-string - group - (nnml-group-name-charset group server-or-method))) - (defun nnml-group-pathname (group &optional file server) "Return an absolute file name of FILE for GROUP on SERVER." - (nnmail-group-pathname (inline (nnml-decoded-group-name group server)) - nnml-directory file)) + (nnmail-group-pathname group nnml-directory file)) (deffoo nnml-retrieve-headers (sequence &optional group server fetch-old) (when (nnml-possibly-change-directory group server) @@ -243,8 +216,7 @@ non-nil.") (string-to-number (file-name-nondirectory path))))))) (deffoo nnml-request-group (group &optional server dont-check info) - (let ((file-name-coding-system nnmail-pathname-coding-system) - (decoded (nnml-decoded-group-name group server))) + (let ((file-name-coding-system nnmail-pathname-coding-system)) (cond ((not (nnml-possibly-change-directory group server)) (nnheader-report 'nnml "Invalid group (no such directory)")) @@ -254,15 +226,15 @@ non-nil.") ((not (file-directory-p nnml-current-directory)) (nnheader-report 'nnml "%s is not a directory" nnml-current-directory)) (dont-check - (nnheader-report 'nnml "Group %s selected" decoded) + (nnheader-report 'nnml "Group %s selected" group) t) (t (nnheader-re-read-dir nnml-current-directory) (nnmail-activate 'nnml) (let ((active (nth 1 (assoc-string group nnml-group-alist)))) (if (not active) - (nnheader-report 'nnml "No such group: %s" decoded) - (nnheader-report 'nnml "Selected group %s" decoded) + (nnheader-report 'nnml "No such group: %s" group) + (nnheader-report 'nnml "Selected group %s" group) (nnheader-insert "211 %d %d %d %s\n" (max (1+ (- (cdr active) (car active))) 0) (car active) (cdr active) group))))))) @@ -332,7 +304,6 @@ non-nil.") (active-articles (nnml-directory-articles nnml-current-directory)) (is-old t) - (decoded (nnml-decoded-group-name group server)) article rest mod-time number target) (nnmail-activate 'nnml) @@ -370,7 +341,7 @@ non-nil.") (if target (progn (nnheader-message 5 "Deleting article %s in %s" - number decoded) + number group) (condition-case () (funcall nnmail-delete-file-function article) (file-error @@ -506,13 +477,12 @@ non-nil.") nnml-current-directory t (concat nnheader-numerical-short-files - "\\|" (regexp-quote nnml-nov-file-name) "$"))) - (decoded (nnml-decoded-group-name group server))) + "\\|" (regexp-quote nnml-nov-file-name) "$")))) (dolist (article articles) (when (file-writable-p article) (nnheader-message 5 "Deleting article %s in %s..." (file-name-nondirectory article) - decoded) + group) (funcall nnmail-delete-file-function article)))) ;; Try to delete the directory itself. (ignore-errors (delete-directory nnml-current-directory)))) @@ -687,15 +657,7 @@ article number. This function is called narrowed to an article." (if (stringp nnml-use-compressed-files) nnml-use-compressed-files ".gz"))) - decoded dec file first headers) - (when nnmail-group-names-not-encoded-p - (dolist (ga (prog1 group-art (setq group-art nil))) - (setq group-art (nconc group-art - (list (cons (nnml-encoded-group-name (car ga) - server) - (cdr ga)))) - decoded (nconc decoded (list (car ga))))) - (setq dec decoded)) + file first headers) (nnmail-insert-xref group-art) (run-hooks 'nnmail-prepare-save-mail-hook) (run-hooks 'nnml-prepare-save-mail-hook) @@ -705,16 +667,10 @@ article number. This function is called narrowed to an article." (forward-line 1)) ;; We save the article in all the groups it belongs in. (dolist (ga group-art) - (if nnmail-group-names-not-encoded-p - (progn - (nnml-possibly-create-directory (car decoded) server) - (setq file (nnmail-group-pathname - (pop decoded) nnml-directory - (concat (number-to-string (cdr ga)) extension)))) - (nnml-possibly-create-directory (car ga) server) - (setq file (nnml-group-pathname - (car ga) (concat (number-to-string (cdr ga)) extension) - server))) + (nnml-possibly-create-directory (car ga) server) + (setq file (nnml-group-pathname + (car ga) (concat (number-to-string (cdr ga)) extension) + server)) (if first ;; It was already saved, so we just make a hard link. (let ((file-name-coding-system nnmail-pathname-coding-system)) @@ -731,18 +687,13 @@ article number. This function is called narrowed to an article." (let ((func (if full-nov 'nnml-add-nov 'nnml-add-incremental-nov))) - (if nnmail-group-names-not-encoded-p - (dolist (ga group-art) - (funcall func (pop dec) (cdr ga) headers)) - (dolist (ga group-art) - (funcall func (car ga) (cdr ga) headers))))) + (dolist (ga group-art) + (funcall func (car ga) (cdr ga) headers)))) group-art) (defun nnml-active-number (group &optional server) "Compute the next article number in GROUP on SERVER." - (let* ((encoded (if nnmail-group-names-not-encoded-p - (nnml-encoded-group-name group server))) - (active (cadr (assoc-string (or encoded group) nnml-group-alist)))) + (let ((active (cadr (assoc-string group nnml-group-alist)))) ;; The group wasn't known to nnml, so we just create an active ;; entry for it. (unless active @@ -760,7 +711,7 @@ article number. This function is called narrowed to an article." (cons (caar nnml-article-file-alist) (caar (last nnml-article-file-alist))) (cons 1 0))) - (push (list (or encoded group) active) nnml-group-alist)) + (push (list group active) nnml-group-alist)) (setcdr active (1+ (cdr active))) (while (file-exists-p (nnml-group-pathname group (int-to-string (cdr active)) server)) @@ -821,16 +772,15 @@ article number. This function is called narrowed to an article." headers)))) (defun nnml-get-nov-buffer (group &optional incrementalp) - (let* ((decoded (nnml-decoded-group-name group)) - (buffer (get-buffer-create (format " *nnml %soverview %s*" + (let ((buffer (get-buffer-create (format " *nnml %soverview %s*" (if incrementalp "incremental " "") - decoded))) + group))) (file-name-coding-system nnmail-pathname-coding-system)) (with-current-buffer buffer (set (make-local-variable 'nnml-nov-buffer-file-name) - (nnmail-group-pathname decoded nnml-directory nnml-nov-file-name)) + (nnmail-group-pathname group nnml-directory nnml-nov-file-name)) (erase-buffer) (when (and (not incrementalp) (file-exists-p nnml-nov-buffer-file-name)) @@ -908,7 +858,7 @@ Unless no-active is non-nil, update the active file too." ;; Update the active info for this group. (let ((group (directory-file-name dir)) entry last) - (setq group (nnheader-file-to-group (nnml-encoded-group-name group) + (setq group (nnheader-file-to-group group nnml-directory) entry (assoc group nnml-group-alist) last (or (caadr entry) 0) diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index 82d3f57424..958745d579 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -368,7 +368,7 @@ for decoding when the cdr that the data specify is not available.") (with-current-buffer nntp-server-buffer (erase-buffer) (dolist (group groups) - (let ((elem (assoc-string (gnus-group-decoded-name group) nnrss-server-data))) + (let ((elem (assoc-string group nnrss-server-data))) (insert (format "%S %s 1 y\n" group (or (cadr elem) 0))))) 'active)) commit c6b4eed80ae3529ada01ca6a5ef5d5b196e97bde Author: Eric Abrahamsen Date: Sat Aug 3 14:43:44 2019 -0700 Fix ordering of Gnus groups after yanking * lisp/gnus/gnus-start.el (gnus-group-change-level): Fix docstring to note that the inserted group is inserted *before* the PREVIOUS group. Fix indexing -- shouldn't have been adding one to the index. diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index d726ee5aab..0f91c4d9b4 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -1257,7 +1257,7 @@ or a list (if FROMKILLED is t, it's a list on the format (NUM INFO-LIST), otherwise it's a list in the format of the `gnus-newsrc-hashtb' entries. LEVEL is the new level of the group, OLDLEVEL is the old level and PREVIOUS is the group (a -string name) to insert this group after." +string name) to insert this group before." (let (group info active num) ;; Glean what info we can from the arguments. (if (consp entry) @@ -1343,10 +1343,8 @@ string name) to insert this group after." (puthash group (list num info) gnus-newsrc-hashtb) (when (stringp previous) (setq previous (gnus-group-entry previous))) - (let* ((prev-idx (seq-position gnus-group-list (caadr previous))) - (idx (if prev-idx - (1+ prev-idx) - (length gnus-group-list)))) + (let ((idx (or (seq-position gnus-group-list (caadr previous)) + (length gnus-group-list)))) (push group (nthcdr idx gnus-group-list))) (gnus-dribble-enter (format "(gnus-group-set-info '%S)" info) commit da03988dd41e08060670d16b0e1db3ee4118d713 Author: Paul Eggert Date: Sat Aug 3 14:12:29 2019 -0700 Remove stale .pdmp files with ‘make clean’ Problem reported by Sven Joachim (Bug#36907). * admin/make-emacs: Simplify, now that clean does versionclean. * src/Makefile.in ($(etc)/DOC, versionclean, extraclean): Don’t ignore rm -f failures. (versionclean): Also remove emacs-*.*.*[0-9].pdmp and ../etc/DOC*. (clean): Depend on versionclean and simplify. diff --git a/admin/make-emacs b/admin/make-emacs index b7cca06e1c..e1be944e4c 100755 --- a/admin/make-emacs +++ b/admin/make-emacs @@ -109,7 +109,7 @@ shift @ARGV; } -system ("$make clean versionclean") if $all; +system ("$make clean") if $all; if ($wall) { diff --git a/src/Makefile.in b/src/Makefile.in index fd05a45df5..76aa6a1ec5 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -598,7 +598,7 @@ endif ## $(etc)/DOC: lisp.mk $(libsrc)/make-docfile$(EXEEXT) $(obj) $(lisp) $(AM_V_GEN)$(MKDIR_P) $(etc) - -$(AM_V_at)rm -f $(etc)/DOC + $(AM_V_at)rm -f $(etc)/DOC $(AM_V_at)$(libsrc)/make-docfile -d $(srcdir) \ $(SOME_MACHINE_OBJECTS) $(obj) > $(etc)/DOC $(AM_V_at)$(libsrc)/make-docfile -a $(etc)/DOC -d $(lispsource) \ @@ -699,9 +699,11 @@ mostlyclean: rm -f buildobj.h rm -f globals.h gl-stamp rm -f ./*.res ./*.tmp -clean: mostlyclean - rm -f emacs-*.*.*[0-9]$(EXEEXT) emacs-*.*.*[0-9].pdmp - rm -f emacs$(EXEEXT) $(DEPDIR)/* +versionclean: + rm -f emacs$(EXEEXT) emacs-*.*.*[0-9]$(EXEEXT) emacs-*.*.*[0-9].pdmp + rm -f ../etc/DOC* +clean: mostlyclean versionclean + rm -f $(DEPDIR)/* ## bootstrap-clean is used to clean up just before a bootstrap. ## It should remove all files generated during a compilation/bootstrap, @@ -720,10 +722,8 @@ distclean: bootstrap-clean maintainer-clean: distclean rm -f TAGS -versionclean: - -rm -f emacs$(EXEEXT) emacs-*.*.*[0-9]$(EXEEXT) ../etc/DOC* extraclean: distclean - -rm -f ./*~ \#* TAGS config.in + rm -f ./*~ \#* TAGS config.in ETAGS = ../lib-src/etags${EXEEXT} commit 7bb269ea2592e589bd39bf3c3eb546f01ab97c2a Author: Glenn Morris Date: Sat Aug 3 13:54:25 2019 -0700 * doc/lispref/display.texi (SVG Images): Remove menu. Not needed since SVG Path Commands was changed to not be a node. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index cd7eddcb01..7c0a56dcad 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -5776,9 +5776,6 @@ circle: (insert-image (svg-image svg))) @end lisp -@menu -* SVG Path Commands:: -@end menu @subsubheading SVG Path Commands commit af1509b28cf0855324df1a8f3f167861811d46bd Author: Lars Ingebrigtsen Date: Sat Aug 3 22:35:17 2019 +0200 Clarify hi-lock-file-patterns-prefix doc string * lisp/hi-lock.el (hi-lock-file-patterns-prefix): Clarify doc string (bug#17993). diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el index f790546747..65465d3b4c 100644 --- a/lisp/hi-lock.el +++ b/lisp/hi-lock.el @@ -245,7 +245,7 @@ Instead, each hi-lock command will cycle through the faces in "23.1") (defvar hi-lock-file-patterns-prefix "Hi-lock" - "Search target for finding hi-lock patterns at top of file.") + "String used to identify hi-lock patterns at the start of files.") (defvar hi-lock-archaic-interface-message-used nil "True if user alerted that `global-hi-lock-mode' is now the global switch. commit d084fd474119c7f967d2c7a95d93f5e6e77a4eea Author: Lars Ingebrigtsen Date: Sat Aug 3 22:23:47 2019 +0200 Mention `themed-value' in Variable Definitions node * doc/lispref/customize.texi (Variable Definitions): Mention `themed-value' (bug#17996). diff --git a/doc/lispref/customize.texi b/doc/lispref/customize.texi index 02eefe0f58..e4a500b069 100644 --- a/doc/lispref/customize.texi +++ b/doc/lispref/customize.texi @@ -486,8 +486,10 @@ Internally, @code{defcustom} uses the symbol property @code{saved-value} to record the value saved by the user with the customization buffer, and @code{customized-value} to record the value set by the user with the customization buffer, but not saved. -@xref{Symbol Properties}. These properties are lists, the car of -which is an expression that evaluates to the value. +@xref{Symbol Properties}. In addition, there's @code{themed-value}, +which is used to record the value set by a theme (@pxref{Custom +Themes}). These properties are lists, the car of which is an +expression that evaluates to the value. @defun custom-reevaluate-setting symbol This function re-evaluates the standard value of @var{symbol}, which commit 9fbae679ad59dfc7ea17f20aac73085b494b5512 Author: Oleh Krehel Date: Sat Aug 3 22:00:40 2019 +0200 calc mode line touch up * lisp/calc/calc.el (calc-set-mode-line): Don't put excessive white space in mode line (bug#18079). diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index 3a9a2804cf..8e76296273 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -1663,7 +1663,7 @@ See calc-keypad for details." (let* ((fmt (car calc-float-format)) (figs (nth 1 calc-float-format)) (new-mode-string - (format "Calc%s%s: %d %s %-14s" + (format "Calc%s%s: %d %s %s" (if (and calc-embedded-info (eq (aref calc-embedded-info 1) (current-buffer))) "Embed" "") commit 13fe8a27042b1539d43727e6df97c386c61c3053 Author: Paul Eggert Date: Sat Aug 3 12:45:19 2019 -0700 Fix rare undefined behaviors in replace-match * src/search.c (Freplace_match): Simplify by caching search_regs components. Fix sanity check for out-of-range subscripts; it incorrectly allowed negative subscripts, subscripts equal to search_regs.num_regs, and it had undefined behavior for subscripts outside ptrdiff_t range. Improve wording of newly-introduced replace-match diagnostic. Rework use of opoint, to avoid setting point to an out-of-range value in rare cases involving modification hooks. diff --git a/src/search.c b/src/search.c index 0e2ae059e8..9b674a5810 100644 --- a/src/search.c +++ b/src/search.c @@ -2389,44 +2389,32 @@ since only regular expressions have distinguished subexpressions. */) case_action = nochange; /* We tried an initialization */ /* but some C compilers blew it */ - if (search_regs.num_regs <= 0) + ptrdiff_t num_regs = search_regs.num_regs; + if (num_regs <= 0) error ("`replace-match' called before any match found"); if (NILP (subexp)) sub = 0; else { - CHECK_FIXNUM (subexp); + CHECK_RANGED_INTEGER (subexp, 0, num_regs - 1); sub = XFIXNUM (subexp); - /* Sanity check to see whether the subexp is larger than the - allowed number of sub-regexps. */ - if (sub >= 0 && sub > search_regs.num_regs) - args_out_of_range (subexp, make_fixnum (search_regs.num_regs)); } - /* Check whether the subexpression to replace is greater than the - number of subexpressions in the regexp. */ - if (sub > 0 && search_regs.start[sub] == -1) - args_out_of_range (build_string ("Attempt to replace regexp subexpression that doesn't exist"), - subexp); + ptrdiff_t sub_start = search_regs.start[sub]; + ptrdiff_t sub_end = search_regs.end[sub]; + eassert (sub_start <= sub_end); - /* Sanity check to see whether the text to replace is present in the - buffer/string. */ - if (NILP (string)) + /* Check whether the text to replace is present in the buffer/string. */ + if (! (NILP (string) + ? BEGV <= sub_start && sub_end <= ZV + : 0 <= sub_start && sub_end <= SCHARS (string))) { - if (search_regs.start[sub] < BEGV - || search_regs.start[sub] > search_regs.end[sub] - || search_regs.end[sub] > ZV) - args_out_of_range (make_fixnum (search_regs.start[sub]), - make_fixnum (search_regs.end[sub])); - } - else - { - if (search_regs.start[sub] < 0 - || search_regs.start[sub] > search_regs.end[sub] - || search_regs.end[sub] > SCHARS (string)) - args_out_of_range (make_fixnum (search_regs.start[sub]), - make_fixnum (search_regs.end[sub])); + if (sub_start < 0) + xsignal2 (Qerror, + build_string ("replace-match subexpression does not exist"), + subexp); + args_out_of_range (make_fixnum (sub_start), make_fixnum (sub_end)); } if (NILP (fixedcase)) @@ -2434,8 +2422,8 @@ since only regular expressions have distinguished subexpressions. */) /* Decide how to casify by examining the matched text. */ ptrdiff_t last; - pos = search_regs.start[sub]; - last = search_regs.end[sub]; + pos = sub_start; + last = sub_end; if (NILP (string)) pos_byte = CHAR_TO_BYTE (pos); @@ -2511,9 +2499,8 @@ since only regular expressions have distinguished subexpressions. */) { Lisp_Object before, after; - before = Fsubstring (string, make_fixnum (0), - make_fixnum (search_regs.start[sub])); - after = Fsubstring (string, make_fixnum (search_regs.end[sub]), Qnil); + before = Fsubstring (string, make_fixnum (0), make_fixnum (sub_start)); + after = Fsubstring (string, make_fixnum (sub_end), Qnil); /* Substitute parts of the match into NEWTEXT if desired. */ @@ -2542,12 +2529,12 @@ since only regular expressions have distinguished subexpressions. */) if (c == '&') { - substart = search_regs.start[sub]; - subend = search_regs.end[sub]; + substart = sub_start; + subend = sub_end; } else if (c >= '1' && c <= '9') { - if (c - '0' < search_regs.num_regs + if (c - '0' < num_regs && search_regs.start[c - '0'] >= 0) { substart = search_regs.start[c - '0']; @@ -2612,13 +2599,8 @@ since only regular expressions have distinguished subexpressions. */) return concat3 (before, newtext, after); } - /* Record point, then move (quietly) to the start of the match. */ - if (PT >= search_regs.end[sub]) - opoint = PT - ZV; - else if (PT > search_regs.start[sub]) - opoint = search_regs.end[sub] - ZV; - else - opoint = PT; + /* Record point. A nonpositive OPOINT is actually an offset from ZV. */ + opoint = PT <= sub_start ? PT : max (PT, sub_end) - ZV; /* If we want non-literal replacement, perform substitution on the replacement string. */ @@ -2687,7 +2669,7 @@ since only regular expressions have distinguished subexpressions. */) if (c == '&') idx = sub; - else if (c >= '1' && c <= '9' && c - '0' < search_regs.num_regs) + else if ('1' <= c && c <= '9' && c - '0' < num_regs) { if (search_regs.start[c - '0'] >= 1) idx = c - '0'; @@ -2745,25 +2727,11 @@ since only regular expressions have distinguished subexpressions. */) xfree (substed); } - /* The functions below modify the buffer, so they could trigger - various modification hooks (see signal_before_change and - signal_after_change). If these hooks clobber the match data we - error out since otherwise this will result in confusing bugs. */ - ptrdiff_t sub_start = search_regs.start[sub]; - ptrdiff_t sub_end = search_regs.end[sub]; - ptrdiff_t num_regs = search_regs.num_regs; - newpoint = search_regs.start[sub] + SCHARS (newtext); + newpoint = sub_start + SCHARS (newtext); + ptrdiff_t newstart = sub_start == sub_end ? newpoint : sub_start; /* Replace the old text with the new in the cleanest possible way. */ - replace_range (search_regs.start[sub], search_regs.end[sub], - newtext, 1, 0, 1, 1); - /* Update saved data to match adjustment made by replace_range. */ - { - ptrdiff_t change = newpoint - sub_end; - if (sub_start >= sub_end) - sub_start += change; - sub_end += change; - } + replace_range (sub_start, sub_end, newtext, 1, 0, 1, true); if (case_action == all_caps) Fupcase_region (make_fixnum (search_regs.start[sub]), @@ -2773,17 +2741,18 @@ since only regular expressions have distinguished subexpressions. */) Fupcase_initials_region (make_fixnum (search_regs.start[sub]), make_fixnum (newpoint)); - if (search_regs.start[sub] != sub_start - || search_regs.end[sub] != sub_end - || search_regs.num_regs != num_regs) + /* The replace_range etc. functions can trigger modification hooks + (see signal_before_change and signal_after_change). Try to error + out if these hooks clobber the match data since clobbering can + result in confusing bugs. Although this sanity check does not + catch all possible clobberings, it should catch many of them. */ + if (! (search_regs.num_regs == num_regs + && search_regs.start[sub] == newstart + && search_regs.end[sub] == newpoint)) error ("Match data clobbered by buffer modification hooks"); - /* Put point back where it was in the text. */ - if (opoint <= 0) - TEMP_SET_PT (opoint + ZV); - else - TEMP_SET_PT (opoint); - + /* Put point back where it was in the text, if possible. */ + TEMP_SET_PT (clip_to_bounds (BEGV, opoint + (opoint <= 0 ? ZV : 0), ZV)); /* Now move point "officially" to the start of the inserted replacement. */ move_if_not_intangible (newpoint); commit b60b6ffb35f4ffbeecb73381e58712ff5cdd7e40 Author: Pierre-Yves Luyten Date: Sat Aug 3 21:46:40 2019 +0200 cua-rect help: check for 'control value * lisp/emulation/cua-rect.el (cua-help-for-rectangle): Check for 'control value (bug#18120). Copyright-paperwork-exempt: yes diff --git a/lisp/emulation/cua-rect.el b/lisp/emulation/cua-rect.el index 1a19cc2910..14415585ef 100644 --- a/lisp/emulation/cua-rect.el +++ b/lisp/emulation/cua-rect.el @@ -1362,6 +1362,7 @@ With prefix arg, indent to that column." (let ((M (cond ((eq cua--rectangle-modifier-key 'hyper) " H-") ((eq cua--rectangle-modifier-key 'super) " s-") ((eq cua--rectangle-modifier-key 'alt) " A-") + ((eq cua--rectangle-modifier-key 'control) " C-") (t " M-")))) (message (concat (if help "C-?:help" "") commit 2e29a2580e22bb708c9578b9b25a0b9a9b862936 Author: Lars Ingebrigtsen Date: Sat Aug 3 21:14:23 2019 +0200 delete-backward/forward-char doc string clarification * lisp/simple.el (delete-backward-char): Doc string clarification (bug#18192). (delete-forward-char): Ditto. diff --git a/lisp/simple.el b/lisp/simple.el index 08021ce0e0..6f60004897 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -1125,8 +1125,9 @@ delete the text in the region and deactivate the mark instead. To disable this, set option `delete-active-region' to nil. Optional second arg KILLFLAG, if non-nil, means to kill (save in -kill ring) instead of delete. Interactively, N is the prefix -arg, and KILLFLAG is set if N is explicitly specified. +kill ring) instead of delete. If called interactively, a numeric +prefix argument specifies N, and KILLFLAG is also set if a prefix +argument is used. When killing, the killed text is filtered by `filter-buffer-substring' before it is saved in the kill ring, so @@ -1166,8 +1167,9 @@ delete the text in the region and deactivate the mark instead. To disable this, set variable `delete-active-region' to nil. Optional second arg KILLFLAG non-nil means to kill (save in kill -ring) instead of delete. Interactively, N is the prefix arg, and -KILLFLAG is set if N was explicitly specified. +ring) instead of delete. If called interactively, a numeric +prefix argument specifies N, and KILLFLAG is also set if a prefix +argument is used. When killing, the killed text is filtered by `filter-buffer-substring' before it is saved in the kill ring, so commit 2a941b843789dd4b2282f1ae3bc0837787b98075 Author: Lars Ingebrigtsen Date: Sat Aug 3 20:56:48 2019 +0200 ido-find-file doc string addition * lisp/ido.el (ido-find-file): Mention ido-reread-directory (bug#18275). Suggested by Rob Browning. diff --git a/lisp/ido.el b/lisp/ido.el index e14f015169..faa6e678f9 100644 --- a/lisp/ido.el +++ b/lisp/ido.el @@ -4318,8 +4318,8 @@ RET\tSelect the file at the front of the list of matches. \\[ido-toggle-case]\tToggle case-sensitive searching of file names. \\[ido-toggle-literal]\tToggle literal reading of this file. \\[ido-completion-help]\tShow list of matching files in separate window. -\\[ido-toggle-ignore]\tToggle ignoring files listed in `ido-ignore-files'." - +\\[ido-toggle-ignore]\tToggle ignoring files listed in `ido-ignore-files'. +\\[ido-reread-directory]\tReread the current directory." (interactive) (ido-file-internal ido-default-file-method)) commit 0e3e01221583185e7a9ab701d1f541f36d07fe0b Author: Kevin Ryde Date: Sat Aug 3 20:32:24 2019 +0200 easy-menu-define doc string fix * emacs-lisp/easymenu.el (easy-menu-define): Docstring :label and :help of the menu itself. diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el index 5bf046d41d..f274f62164 100644 --- a/lisp/emacs-lisp/easymenu.el +++ b/lisp/emacs-lisp/easymenu.el @@ -71,6 +71,17 @@ pairs: if the expression evaluates to a non-nil value. `:enable' is an alias for `:active'. + :label FORM + FORM is an expression that is dynamically evaluated and whose + value serves as the menu's label (the default is the first + element of MENU). + + :help HELP + HELP is a string, the help to display for the menu. + In a GUI this is a \"tooltip\" on the menu button. (Though + in Lucid :help is not shown for the top-level menu bar, only + for sub-menus.) + The rest of the elements in MENU are menu items. A menu item can be a vector of three elements: commit 9fa60c19d0470176b1b49e9d7d4ce8e030e75657 Author: Lars Ingebrigtsen Date: Sat Aug 3 19:19:17 2019 +0200 Add some function index entries for ido.texi * doc/misc/ido.texi: Add index entries for functions (bug#18691). diff --git a/doc/misc/ido.texi b/doc/misc/ido.texi index bb7e723265..29a204cf9e 100644 --- a/doc/misc/ido.texi +++ b/doc/misc/ido.texi @@ -65,6 +65,7 @@ Appendices * GNU Free Documentation License:: The license for this documentation. Indexes +* Function Index:: An entry for each documented function. * Variable Index:: An entry for each documented variable. @detailmenu @@ -175,6 +176,7 @@ record. @end defopt @c see (info "(elisp) File Name Completion") +@findex ido-reread-directory @defopt ido-max-dir-file-cache This user option specifies maximum number of working directories to be cached. This is the size of the cache of @@ -246,6 +248,7 @@ end of the list by pressing @kbd{C-s} or @kbd{}, or bring the last element to the head of the list by pressing @kbd{C-r} or @kbd{}. +@findex ido-complete The item in [...] indicates what can be added to your input by pressing @key{TAB} (@code{ido-complete}). In this case, you will get "3" added to your input. @@ -271,6 +274,7 @@ Since there is only one matching buffer left, it is given in [] and it is shown in the @code{ido-only-match} face (ForestGreen). You can now press @key{TAB} or @key{RET} to go to that buffer. +@findex ido-select-text If you want to create a new buffer named @file{234}, you can press @kbd{C-j} (@code{ido-select-text}) instead of @key{TAB} or @key{RET}. @@ -289,6 +293,7 @@ the quickest way to get to the @file{123456} file would be just to type @kbd{4} and then @key{RET} (assuming there isn't any newer buffer with @kbd{4} in its name). +@findex ido-find-file Likewise, if you use @kbd{C-x C-f} (@code{ido-find-file}), the list of files and directories in the current directory is provided in the same fashion as the buffers above. The files and directories are normally @@ -367,6 +372,7 @@ users Ido offers in addition to the default substring matching method the only difference to the description of the substring matching above. +@findex ido-toggle-prefix @cindex toggle prefix matching You can toggle prefix matching with @kbd{C-p} (@code{ido-toggle-prefix}). @@ -413,6 +419,7 @@ you to type @samp{[ch]$} for example and see all file names ending in @samp{c} or @samp{h}. @defopt ido-enable-regexp +@findex ido-toggle-regexp If the value of this user option is non-@code{nil}, Ido will do regexp matching. The value of this user option can be toggled within ido-mode using @code{ido-toggle-regexp}. @@ -426,6 +433,7 @@ enable regexp matching. @cindex highlighting @noindent +@vindex ido-use-faces The highlighting of matching items is controlled via @code{ido-use-faces}. The faces used are @code{ido-first-match}, @code{ido-only-match} and @code{ido-subdir}. @@ -443,6 +451,7 @@ substring you enter does not match any of the visible buffers or files, Ido will automatically look for completions among the hidden buffers or files. +@findex ido-toggle-ignore You can toggle display of the hidden buffers and files with @kbd{C-a} (@code{ido-toggle-ignore}). @@ -466,6 +475,7 @@ or customize a certain variable: M-x customize-variable @key{RET} ido-xxxxx @key{RET} @end example +@vindex ido-setup-hook To modify the keybindings, use the @code{ido-setup-hook}. For example: @example @@ -575,6 +585,7 @@ enable it: (setq ido-ignore-extensions t) @end example +@vindex completion-ignored-extensions Now you can customize @code{completion-ignored-extensions} as well. Go ahead and add all the useless object files, backup files, shared library files and other computing flotsam you don't want Ido to show. @@ -793,10 +804,10 @@ buffer name, a file name, or a directory name in the @emph{Ido} way. @appendix GNU Free Documentation License @include doclicense.texi -@c @node Function Index -@c @unnumbered Function Index +@node Function Index +@unnumbered Function Index -@c @printindex fn +@printindex fn @node Variable Index @unnumbered Variable Index commit 95d2250bcf762296ec88e78d88f0c3b310b119ae Author: Andreas Politz Date: Sat Aug 3 16:33:06 2019 +0200 Tweak tq queue processing * lisp/emacs-lisp/tq.el (tq-process-buffer): Pop the queue before calling the function because the function may add new entries to the queue (bug#19016). Also report errors. diff --git a/lisp/emacs-lisp/tq.el b/lisp/emacs-lisp/tq.el index 4249305fee..a8c7e89289 100644 --- a/lisp/emacs-lisp/tq.el +++ b/lisp/emacs-lisp/tq.el @@ -153,15 +153,18 @@ This produces more reliable results with some processes." (buffer-name buf))) (goto-char (point-min)) (if (re-search-forward (tq-queue-head-regexp tq) nil t) - (let ((answer (buffer-substring (point-min) (point)))) + (let ((answer (buffer-substring (point-min) (point))) + (fn (tq-queue-head-fn tq)) + (closure (tq-queue-head-closure tq))) (delete-region (point-min) (point)) - (unwind-protect - (condition-case nil - (funcall (tq-queue-head-fn tq) - (tq-queue-head-closure tq) - answer) - (error nil)) - (tq-queue-pop tq)) + ;; Pop the queue before calling the function because + ;; the function may add new functions to the head of + ;; the queue. + (tq-queue-pop tq) + (condition-case err + (funcall fn closure answer) + (error (message "Error while processing tq callback: %s" + (error-message-string err)))) (tq-process-buffer tq)))))))) (provide 'tq) commit d70bf3a1269281c8ae3315f2ae0684b945d5d680 Author: Lars Ingebrigtsen Date: Sat Aug 3 16:10:31 2019 +0200 Tweak tango-dark-theme hightlight face * etc/themes/tango-dark-theme.el (class): Make highlight a bit less yellow to make the cursor visible on it (bug#19189). diff --git a/etc/themes/tango-dark-theme.el b/etc/themes/tango-dark-theme.el index 87a5048634..91256208a3 100644 --- a/etc/themes/tango-dark-theme.el +++ b/etc/themes/tango-dark-theme.el @@ -60,7 +60,7 @@ Semantic, and Ansi-Color faces are included.") `(header-line ((,class (:background "#666")))) ;; Highlighting faces `(fringe ((,class (:background ,alum-7)))) - `(highlight ((,class (:foreground ,alum-6 :background ,butter-2)))) + `(highlight ((,class (:foreground ,alum-6 :background "#c0c000")))) `(region ((,class (:background ,alum-5)))) `(secondary-selection ((,class (:background ,blue-3)))) `(isearch ((,class (:foreground ,alum-1 :background ,orange-3)))) commit 18e163fd3455deaa30b1effd19f51a5094bc0885 Author: Lars Ingebrigtsen Date: Sat Aug 3 16:00:20 2019 +0200 Fix error message in replace-match for subexpressions * src/search.c (Freplace_match): Output a more understandable error message when replacing a subexpression (bug#19208). diff --git a/src/search.c b/src/search.c index 2fa8b27719..0e2ae059e8 100644 --- a/src/search.c +++ b/src/search.c @@ -2404,6 +2404,12 @@ since only regular expressions have distinguished subexpressions. */) args_out_of_range (subexp, make_fixnum (search_regs.num_regs)); } + /* Check whether the subexpression to replace is greater than the + number of subexpressions in the regexp. */ + if (sub > 0 && search_regs.start[sub] == -1) + args_out_of_range (build_string ("Attempt to replace regexp subexpression that doesn't exist"), + subexp); + /* Sanity check to see whether the text to replace is present in the buffer/string. */ if (NILP (string)) commit f77a39514687f57c947e9105172c3d3821a759cc Author: Lars Ingebrigtsen Date: Sat Aug 3 15:29:04 2019 +0200 Clarify Freplace_match logic * src/search.c (Freplace_match): Add some doc strings to clarify the logic and do a minor clean up (bug#19208). diff --git a/src/search.c b/src/search.c index fa574959fb..2fa8b27719 100644 --- a/src/search.c +++ b/src/search.c @@ -2397,11 +2397,15 @@ since only regular expressions have distinguished subexpressions. */) else { CHECK_FIXNUM (subexp); - if (! (0 <= XFIXNUM (subexp) && XFIXNUM (subexp) < search_regs.num_regs)) - args_out_of_range (subexp, make_fixnum (search_regs.num_regs)); sub = XFIXNUM (subexp); + /* Sanity check to see whether the subexp is larger than the + allowed number of sub-regexps. */ + if (sub >= 0 && sub > search_regs.num_regs) + args_out_of_range (subexp, make_fixnum (search_regs.num_regs)); } + /* Sanity check to see whether the text to replace is present in the + buffer/string. */ if (NILP (string)) { if (search_regs.start[sub] < BEGV commit 6c7ab768ee51352b2776d1fafbf2057cba5a36e4 Author: Lars Ingebrigtsen Date: Sat Aug 3 14:59:53 2019 +0200 Don't refer to non-existent functions in mode line examples * doc/lispintro/emacs-lisp-intro.texi (Mode Line): Ditto. * doc/lispref/modes.texi (Mode Line Top): In the :eval example, use a function that exists to avoid confusion (bug#19224). diff --git a/doc/lispintro/emacs-lisp-intro.texi b/doc/lispintro/emacs-lisp-intro.texi index c03fbfc47b..c97f6b7a52 100644 --- a/doc/lispintro/emacs-lisp-intro.texi +++ b/doc/lispintro/emacs-lisp-intro.texi @@ -17924,7 +17924,7 @@ My @file{.emacs} file has a section that looks like this: #(" %[(" 0 6 (help-echo "mouse-1: select window, mouse-2: delete others ...")) - (:eval (mode-line-mode-name)) + (:eval (format-time-string "%F")) mode-line-process minor-mode-alist #("%n" 0 2 (help-echo "mouse-2: widen" local-map (keymap ...))) diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi index d12f241424..764a67e362 100644 --- a/doc/lispref/modes.texi +++ b/doc/lispref/modes.texi @@ -2023,7 +2023,7 @@ be useful for Shell mode (in reality, Shell mode does not set " " 'global-mode-string " %[(" - '(:eval (mode-line-mode-name)) + '(:eval (format-time-string "%F")) 'mode-line-process 'minor-mode-alist "%n" commit e7818cb73ff042cb557332c7ea954fd512c87f69 Author: Basil L. Contovounesios Date: Fri Aug 2 15:54:09 2019 +0300 Fix nnmail-expiry-wait docs and custom :types * doc/misc/gnus.texi (Group Parameters, Expiring Mail): * lisp/gnus/gnus-cus.el (gnus-group-parameters): Clarify descriptions of nnmail-expiry, nnmail-expiry-wait, and nnmail-expiry-wait-function. * lisp/gnus/nnmail.el (nnmail-expiry-wait) (nnmail-expiry-wait-function): Clarify docstrings and fix custom :types (bug#36850). diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index f045884729..9c3ec41462 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -2917,9 +2917,9 @@ See also @code{gnus-total-expirable-newsgroups}. If the group parameter has an element that looks like @code{(expiry-wait . 10)}, this value will override any @code{nnmail-expiry-wait} and @code{nnmail-expiry-wait-function} -(@pxref{Expiring Mail}) when expiring expirable messages. The value -can either be a number of days (not necessarily an integer) or the -symbols @code{never} or @code{immediate}. +settings (@pxref{Expiring Mail}) when expiring expirable messages. +The value can be either a number of days (not necessarily an integer), +or one of the symbols @code{never} or @code{immediate}. @item expiry-target @cindex expiry-target @@ -15826,40 +15826,46 @@ don't really mix very well. @vindex nnmail-expiry-wait The @code{nnmail-expiry-wait} variable supplies the default time an -expirable article has to live. Gnus starts counting days from when the -message @emph{arrived}, not from when it was sent. The default is seven -days. +expirable article has to live. The value of this variable can be +either a number of days (not necessarily an integer), or one of the +symbols @code{immediate} or @code{never}, meaning an article is +immediately or never expirable, respectively. -Gnus also supplies a function that lets you fine-tune how long articles -are to live, based on what group they are in. Let's say you want to -have one month expiry period in the @samp{mail.private} group, a one day -expiry period in the @samp{mail.junk} group, and a six day expiry period -everywhere else: +Gnus starts counting days from when the message @emph{arrived}, not +from when it was sent. The default is seven days. @vindex nnmail-expiry-wait-function +The @code{nnmail-expiry-wait-function} variable lets you fine-tune how +long articles are to live, based on what group they are in. When set +to a function, its returned value, if non-@code{nil}, overrides that +of @code{nnmail-expiry-wait}. Otherwise, the value of +@code{nnmail-expiry-wait} is used instead. + +For example, let's say you want to have a one month expiry period in +the @samp{mail.private} group, a one day expiry period in the +@samp{mail.junk} group, and a six day expiry period everywhere else. +This can be achieved as follows: + @lisp (setq nnmail-expiry-wait-function (lambda (group) - (cond ((string= group "mail.private") + (cond ((string= group "mail.private") 31) - ((string= group "mail.junk") + ((string= group "mail.junk") 1) - ((string= group "important") + ((string= group "important") 'never) - (t + (t 6)))) @end lisp The group names this function is fed are ``unadorned'' group names---no @samp{nnml:} prefixes and the like. -The @code{nnmail-expiry-wait} variable and -@code{nnmail-expiry-wait-function} function can either be a number (not -necessarily an integer) or one of the symbols @code{immediate} or -@code{never}. - -You can also use the @code{expiry-wait} group parameter to selectively -change the expiry period (@pxref{Group Parameters}). +As an alternative to the variables @code{nnmail-expiry-wait} or +@code{nnmail-expiry-wait-function}, you can also use the +@code{expiry-wait} group parameter to selectively change the expiry +period (@pxref{Group Parameters}). @vindex nnmail-expiry-target The normal action taken when expiring articles is to delete them. diff --git a/lisp/gnus/gnus-cus.el b/lisp/gnus/gnus-cus.el index 66fa3e0590..80459a7d62 100644 --- a/lisp/gnus/gnus-cus.el +++ b/lisp/gnus/gnus-cus.el @@ -140,10 +140,10 @@ rules as described later).") :format "%v")) "\ When to expire. -Overrides any `nnmail-expiry-wait' and `nnmail-expiry-wait-function' -when expiring expirable messages. The value can either be a number of -days (not necessarily an integer) or the symbols `never' or -`immediate'.") +Overrides any `nnmail-expiry-wait' or `nnmail-expiry-wait-function' +settings when expiring expirable messages. The value can be +either a number of days (not necessarily an integer), or one of +the symbols `never' or `immediate'.") (expiry-target (choice :tag "Expiry Target" :value delete diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index c52bc03e10..0f560d300f 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -159,32 +159,33 @@ If nil, groups like \"mail.misc\" will end up in directories like (defcustom nnmail-expiry-wait 7 "Expirable articles that are older than this will be expired. -This variable can either be a number (which will be interpreted as a -number of days) -- this doesn't have to be an integer. This variable -can also be `immediate' and `never'." +This variable can be either a number of days (not necessarily an +integer), or one of the symbols `immediate' or `never', meaning +an article is immediately or never expirable, respectively. +For more granular control, see `nnmail-expiry-wait-function'." :group 'nnmail-expire - :type '(choice (const immediate) - (number :tag "days") - (const never))) + :type '(choice (const :tag "Immediate" immediate) + (const :tag "Never" never) + (number :tag "Days"))) (defcustom nnmail-expiry-wait-function nil - "Variable that holds function to specify how old articles should be before they are expired. -The function will be called with the name of the group that the expiry -is to be performed in, and it should return an integer that says how -many days an article can be stored before it is considered \"old\". -It can also return the values `never' and `immediate'. + "Function to determine how old articles should be before they are expired. +The function is called with the name of the group that the expiry +is to be performed in, and should return a value supported by +`nnmail-expiry-wait', which it overrides. If this variable is +nil, the value of `nnmail-expiry-wait' is used instead. E.g.: \(setq nnmail-expiry-wait-function - (lambda (newsgroup) - (cond ((string-match \"private\" newsgroup) 31) - ((string-match \"junk\" newsgroup) 1) - ((string-match \"important\" newsgroup) \\='never) - (t 7))))" + (lambda (group) + (cond ((string-match-p \"private\" group) 31) + ((string-match-p \"junk\" group) 1) + ((string-match-p \"important\" group) \\='never) + (t 7))))" :group 'nnmail-expire :type '(choice (const :tag "nnmail-expiry-wait" nil) - (function :format "%v" nnmail-))) + (function :tag "Custom function"))) (defcustom nnmail-expiry-target 'delete "Variable that says where expired messages should end up. commit 8edd4bc22af5a255dc4941469cd30a835dcd1234 Author: Lars Ingebrigtsen Date: Sat Aug 3 13:47:40 2019 +0200 Fix previous macroexp-progn doc string fix * lisp/emacs-lisp/macroexp.el (macroexp-progn): Fix previous doc string clarification. diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 9b29d0058c..d27cc0a63c 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -319,8 +319,9 @@ definitions to shadow the loaded ones for use in file byte-compilation." (cons (nreverse decls) body))) (defun macroexp-progn (exps) - "Return EXPS with `progn' prepended. -If EXPS is a single expression, `progn' is not prepended." + "Return EXPS (a list of expressions) with `progn' prepended. +If EXPS is a list with a single expression, `progn' is not +prepended, but that expression is returned instead." (if (cdr exps) `(progn ,@exps) (car exps))) (defun macroexp-unprogn (exp) commit 8b7c7762da516faea40ba761ee5f114e839dfd33 Author: Eli Zaretskii Date: Sat Aug 3 14:20:34 2019 +0300 * lisp/simple.el (kill-do-not-save-duplicates): Doc fix. (Bug#36827) diff --git a/lisp/simple.el b/lisp/simple.el index a0f2da7152..b10c7861d1 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -4353,7 +4353,7 @@ retrieved via \\[yank] \\[yank-pop]." :version "23.2") (defcustom kill-do-not-save-duplicates nil - "Do not add a new string to `kill-ring' if it duplicates the last one. + "If non-nil, don't add a string to `kill-ring' if it duplicates the last one. The comparison is done using `equal-including-properties'." :type 'boolean :group 'killing commit 3bff466aa687464f32d378aed01af41f45bbb239 Author: Eli Zaretskii Date: Sat Aug 3 14:15:16 2019 +0300 ; * etc/NEWS: Fix a typo. (Bug#36829) diff --git a/etc/NEWS b/etc/NEWS index e84c0d3ec5..cefbe84fc8 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -351,7 +351,7 @@ respects display actions specified by 'display-buffer-alist' and 'display-buffer-overriding-action'. ** New 'flex' completion style -An implementation of popular "flx/fuzzy/scatter" completion which +An implementation of popular "flex/fuzzy/scatter" completion which matches strings where the pattern appears as a subsequence. Put simply, makes "foo" complete to both "barfoo" and "frodo". Add 'flex' to 'completion-styles' or 'completion-category-overrides' to use it. commit 5ae1191e5b012030176a8ec2c39e66b6a8401779 Author: Eli Zaretskii Date: Sat Aug 3 12:59:18 2019 +0300 Minor doc fix in etags.el * lisp/progmodes/etags.el (etags-xref-find-definitions-tag-order): Doc fix. (Bug#32510) diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index a052ad2ce5..78f27295f0 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -2029,7 +2029,10 @@ for \\[find-tag] (which see)." (defvar etags-xref-find-definitions-tag-order '(tag-exact-match-p tag-implicit-name-match-p) - "Tag order used in `xref-backend-definitions' to look for definitions.") + "Tag order used in `xref-backend-definitions' to look for definitions. + +If you want `xref-find-definitions' to find the tagged files by their +file name, add `tag-partial-file-name-match-p' to the list value.") ;;;###autoload (defun etags--xref-backend () 'etags) commit 5a5ad99d2f5abc431e269e4f591fdabad9d59e70 Author: Eli Zaretskii Date: Sat Aug 3 12:41:35 2019 +0300 Improve documentation of debugging Lisp syntax error * doc/lispref/debugging.texi (Syntax Errors, Excess Open) (Excess Close): Name the commands invoked by the key sequences. Add cross-references to appropriate sections of the Emacs manual. (Bug#21385) (cherry picked from commit faafd467a374c9398ee4668cdc173611d35693ed) diff --git a/doc/lispref/debugging.texi b/doc/lispref/debugging.texi index 2576fbe39d..575ec75d40 100644 --- a/doc/lispref/debugging.texi +++ b/doc/lispref/debugging.texi @@ -796,9 +796,10 @@ parenthesis or missing open parenthesis, but does not say where the missing parenthesis belongs. How, then, to find what to change? If the problem is not simply an imbalance of parentheses, a useful -technique is to try @kbd{C-M-e} at the beginning of each defun, and see -if it goes to the place where that defun appears to end. If it does -not, there is a problem in that defun. +technique is to try @kbd{C-M-e} (@code{end-of-defun}, @pxref{Moving by +Defuns,,,emacs, The GNU Emacs Manual}) at the beginning of each defun, +and see if it goes to the place where that defun appears to end. If +it does not, there is a problem in that defun. @cindex unbalanced parentheses @cindex parenthesis mismatch, debugging @@ -818,29 +819,32 @@ find the mismatch.) The first step is to find the defun that is unbalanced. If there is an excess open parenthesis, the way to do this is to go to the end of -the file and type @kbd{C-u C-M-u}. This will move you to the -beginning of the first defun that is unbalanced. +the file and type @kbd{C-u C-M-u} (@code{backward-up-list}, +@pxref{Moving by Parens,,,emacs, The GNU Emacs Manual}). This will +move you to the beginning of the first defun that is unbalanced. The next step is to determine precisely what is wrong. There is no way to be sure of this except by studying the program, but often the existing indentation is a clue to where the parentheses should have been. The easiest way to use this clue is to reindent with @kbd{C-M-q} -and see what moves. @strong{But don't do this yet!} Keep reading, -first. +(@code{indent-pp-sexp}, @pxref{Multi-line Indent,,,emacs, The GNU +Emacs Manual}) and see what moves. @strong{But don't do this yet!} +Keep reading, first. Before you do this, make sure the defun has enough close parentheses. Otherwise, @kbd{C-M-q} will get an error, or will reindent all the rest of the file until the end. So move to the end of the defun and insert a -close parenthesis there. Don't use @kbd{C-M-e} to move there, since -that too will fail to work until the defun is balanced. +close parenthesis there. Don't use @kbd{C-M-e} (@code{end-of-defun}) to +move there, since that too will fail to work until the defun is balanced. Now you can go to the beginning of the defun and type @kbd{C-M-q}. Usually all the lines from a certain point to the end of the function will shift to the right. There is probably a missing close parenthesis, or a superfluous open parenthesis, near that point. (However, don't assume this is true; study the code to make sure.) Once you have found -the discrepancy, undo the @kbd{C-M-q} with @kbd{C-_}, since the old -indentation is probably appropriate to the intended parentheses. +the discrepancy, undo the @kbd{C-M-q} with @kbd{C-_} (@code{undo}), +since the old indentation is probably appropriate to the intended +parentheses. After you think you have fixed the problem, use @kbd{C-M-q} again. If the old indentation actually fit the intended nesting of parentheses, @@ -852,21 +856,24 @@ anything. @cindex excess close parentheses To deal with an excess close parenthesis, first go to the beginning -of the file, then type @kbd{C-u -1 C-M-u} to find the end of the first -unbalanced defun. +of the file, then type @kbd{C-u -1 C-M-u} (@code{backward-up-list} +with an argument of @minus{}1) to find the end of the first unbalanced +defun. Then find the actual matching close parenthesis by typing @kbd{C-M-f} +(@code{forward-sexp}, @pxref{Expressions,,,emacs, The GNU Emacs Manual}) at the beginning of that defun. This will leave you somewhere short of the place where the defun ought to end. It is possible that you will find a spurious close parenthesis in that vicinity. If you don't see a problem at that point, the next thing to do is to -type @kbd{C-M-q} at the beginning of the defun. A range of lines will -probably shift left; if so, the missing open parenthesis or spurious -close parenthesis is probably near the first of those lines. (However, -don't assume this is true; study the code to make sure.) Once you have -found the discrepancy, undo the @kbd{C-M-q} with @kbd{C-_}, since the -old indentation is probably appropriate to the intended parentheses. +type @kbd{C-M-q} (@code{indent-pp-sexp}) at the beginning of the defun. +A range of lines will probably shift left; if so, the missing open +parenthesis or spurious close parenthesis is probably near the first of +those lines. (However, don't assume this is true; study the code to +make sure.) Once you have found the discrepancy, undo the @kbd{C-M-q} +with @kbd{C-_} (@code{undo}), since the old indentation is probably +appropriate to the intended parentheses. After you think you have fixed the problem, use @kbd{C-M-q} again. If the old indentation actually fits the intended nesting of parentheses, commit faafd467a374c9398ee4668cdc173611d35693ed Author: Eli Zaretskii Date: Sat Aug 3 12:41:35 2019 +0300 Improve documentation of debugging Lisp syntax error * doc/lispref/debugging.texi (Syntax Errors, Excess Open) (Excess Close): Name the commands invoked by the key sequences. Add cross-references to appropriate sections of the Emacs manual. (Bug#21385) diff --git a/doc/lispref/debugging.texi b/doc/lispref/debugging.texi index 9e43343310..12caeaf128 100644 --- a/doc/lispref/debugging.texi +++ b/doc/lispref/debugging.texi @@ -849,9 +849,10 @@ parenthesis or missing open parenthesis, but does not say where the missing parenthesis belongs. How, then, to find what to change? If the problem is not simply an imbalance of parentheses, a useful -technique is to try @kbd{C-M-e} at the beginning of each defun, and see -if it goes to the place where that defun appears to end. If it does -not, there is a problem in that defun. +technique is to try @kbd{C-M-e} (@code{end-of-defun}, @pxref{Moving by +Defuns,,,emacs, The GNU Emacs Manual}) at the beginning of each defun, +and see if it goes to the place where that defun appears to end. If +it does not, there is a problem in that defun. @cindex unbalanced parentheses @cindex parenthesis mismatch, debugging @@ -871,29 +872,32 @@ find the mismatch.) The first step is to find the defun that is unbalanced. If there is an excess open parenthesis, the way to do this is to go to the end of -the file and type @kbd{C-u C-M-u}. This will move you to the -beginning of the first defun that is unbalanced. +the file and type @kbd{C-u C-M-u} (@code{backward-up-list}, +@pxref{Moving by Parens,,,emacs, The GNU Emacs Manual}). This will +move you to the beginning of the first defun that is unbalanced. The next step is to determine precisely what is wrong. There is no way to be sure of this except by studying the program, but often the existing indentation is a clue to where the parentheses should have been. The easiest way to use this clue is to reindent with @kbd{C-M-q} -and see what moves. @strong{But don't do this yet!} Keep reading, -first. +(@code{indent-pp-sexp}, @pxref{Multi-line Indent,,,emacs, The GNU +Emacs Manual}) and see what moves. @strong{But don't do this yet!} +Keep reading, first. Before you do this, make sure the defun has enough close parentheses. Otherwise, @kbd{C-M-q} will get an error, or will reindent all the rest of the file until the end. So move to the end of the defun and insert a -close parenthesis there. Don't use @kbd{C-M-e} to move there, since -that too will fail to work until the defun is balanced. +close parenthesis there. Don't use @kbd{C-M-e} (@code{end-of-defun}) to +move there, since that too will fail to work until the defun is balanced. Now you can go to the beginning of the defun and type @kbd{C-M-q}. Usually all the lines from a certain point to the end of the function will shift to the right. There is probably a missing close parenthesis, or a superfluous open parenthesis, near that point. (However, don't assume this is true; study the code to make sure.) Once you have found -the discrepancy, undo the @kbd{C-M-q} with @kbd{C-_}, since the old -indentation is probably appropriate to the intended parentheses. +the discrepancy, undo the @kbd{C-M-q} with @kbd{C-_} (@code{undo}), +since the old indentation is probably appropriate to the intended +parentheses. After you think you have fixed the problem, use @kbd{C-M-q} again. If the old indentation actually fit the intended nesting of parentheses, @@ -905,21 +909,24 @@ anything. @cindex excess close parentheses To deal with an excess close parenthesis, first go to the beginning -of the file, then type @kbd{C-u -1 C-M-u} to find the end of the first -unbalanced defun. +of the file, then type @kbd{C-u -1 C-M-u} (@code{backward-up-list} +with an argument of @minus{}1) to find the end of the first unbalanced +defun. Then find the actual matching close parenthesis by typing @kbd{C-M-f} +(@code{forward-sexp}, @pxref{Expressions,,,emacs, The GNU Emacs Manual}) at the beginning of that defun. This will leave you somewhere short of the place where the defun ought to end. It is possible that you will find a spurious close parenthesis in that vicinity. If you don't see a problem at that point, the next thing to do is to -type @kbd{C-M-q} at the beginning of the defun. A range of lines will -probably shift left; if so, the missing open parenthesis or spurious -close parenthesis is probably near the first of those lines. (However, -don't assume this is true; study the code to make sure.) Once you have -found the discrepancy, undo the @kbd{C-M-q} with @kbd{C-_}, since the -old indentation is probably appropriate to the intended parentheses. +type @kbd{C-M-q} (@code{indent-pp-sexp}) at the beginning of the defun. +A range of lines will probably shift left; if so, the missing open +parenthesis or spurious close parenthesis is probably near the first of +those lines. (However, don't assume this is true; study the code to +make sure.) Once you have found the discrepancy, undo the @kbd{C-M-q} +with @kbd{C-_} (@code{undo}), since the old indentation is probably +appropriate to the intended parentheses. After you think you have fixed the problem, use @kbd{C-M-q} again. If the old indentation actually fits the intended nesting of parentheses, commit 49a5b573b25b70b3efd288efab0e27af1191d8c7 Author: Eli Zaretskii Date: Sat Aug 3 12:15:03 2019 +0300 Improve documentation of 'display-buffer-*' functions * lisp/window.el (display-buffer-in-atom-window) (display-buffer-in-side-window, display-buffer-same-window) (display-buffer--maybe-same-window) (display-buffer-reuse-window) (display-buffer-reuse-mode-window) (display-buffer-pop-up-frame, display-buffer-pop-up-window) (display-buffer--maybe-pop-up-frame-or-window) (display-buffer--maybe-pop-up-frame) (display-buffer-in-child-frame, display-buffer-in-direction) (display-buffer-below-selected, display-buffer-at-bottom) (display-buffer-in-previous-window) (display-buffer-use-some-window, display-buffer-no-window): More details about the ALIST argument in the doc string. (Bug#19461) diff --git a/lisp/window.el b/lisp/window.el index 8b12c4381f..70e2bba749 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -666,8 +666,9 @@ new window to that atomic window. Operations like `split-window' or `delete-window', when applied to a constituent of an atomic window, are applied atomically to the root of that atomic window. -ALIST is an association list of symbols and values. The -following symbols can be used. +ALIST is an association list of action symbols and values. +See Info node `(elisp) Buffer Display Action Alists' for +details of such alists. The following symbols can be used: `window' specifies the existing window the new window shall be combined with. Use `window-atom-root' to make the new window a @@ -1000,8 +1001,10 @@ and may be called only if no window on SIDE exists yet." (defun display-buffer-in-side-window (buffer alist) "Display BUFFER in a side window of the selected frame. -ALIST is an association list of symbols and values. The -following special symbols can be used in ALIST. +ALIST is an association list of action symbols and values. +See Info node `(elisp) Buffer Display Action Alists' for +details of such alists. +The following special symbols can be used in ALIST: `side' denotes the side of the frame where the new window shall be located. Valid values are `bottom', `right', `top' and @@ -7285,6 +7288,10 @@ The default predicate is to use any frame other than the selected frame. If successful, return the window used; otherwise return nil. +ALIST is an association list of action symbols and values. +See Info node `(elisp) Buffer Display Action Alists' for +details of such alists. + If ALIST has a non-nil `inhibit-switch-frame' entry, avoid raising the frame. @@ -7314,10 +7321,15 @@ that allows the selected frame)." (defun display-buffer-same-window (buffer alist) "Display BUFFER in the selected window. -This fails if ALIST has an `inhibit-same-window' element whose -value is non-nil, or if the selected window is a minibuffer -window or is dedicated to another buffer; in that case, return nil. -Otherwise, return the selected window." + +ALIST is an association list of action symbols and values. +See Info node `(elisp) Buffer Display Action Alists' for +details of such alists. + +This function fails if ALIST has an `inhibit-same-window' +element whose value is non-nil, or if the selected window is a +minibuffer window or is dedicated to another buffer; in that case, +return nil. Otherwise, return the selected window." (unless (or (cdr (assq 'inhibit-same-window alist)) (window-minibuffer-p) (window-dedicated-p)) @@ -7325,6 +7337,11 @@ Otherwise, return the selected window." (defun display-buffer--maybe-same-window (buffer alist) "Conditionally display BUFFER in the selected window. + +ALIST is an association list of action symbols and values. +See Info node `(elisp) Buffer Display Action Alists' for +details of such alists. + If `same-window-p' returns non-nil for BUFFER's name, call `display-buffer-same-window' and return its value. Otherwise, return nil." @@ -7336,6 +7353,10 @@ return nil." Preferably use a window on the selected frame if such a window exists. Return nil if no usable window is found. +ALIST is an association list of action symbols and values. +See Info node `(elisp) Buffer Display Action Alists' for +details of such alists. + If ALIST has a non-nil 'inhibit-same-window' entry, the selected window is not eligible for reuse. @@ -7391,6 +7412,10 @@ that frame." Display BUFFER in the returned window. Return nil if no usable window is found. +ALIST is an association list of action symbols and values. +See Info node `(elisp) Buffer Display Action Alists' for +details of such alists. + If ALIST contains a `mode' entry, its value is a major mode (a symbol) or a list of modes. A window is a candidate if it displays a buffer that derives from one of the given modes. When @@ -7470,6 +7495,10 @@ See `display-buffer' for the format of display actions." This works by calling `pop-up-frame-function'. If successful, return the window used; otherwise return nil. +ALIST is an association list of action symbols and values. +See Info node `(elisp) Buffer Display Action Alists' for +details of such alists. + If ALIST has a non-nil `inhibit-switch-frame' entry, avoid raising the new frame. @@ -7496,6 +7525,10 @@ The new window is created on the selected frame, or in `last-nonminibuffer-frame' if no windows can be created there. If successful, return the new window; otherwise return nil. +ALIST is an association list of action symbols and values. +See Info node `(elisp) Buffer Display Action Alists' for +details of such alists. + If ALIST has a non-nil `inhibit-switch-frame' entry, then in the event that the new window is created on another frame, avoid raising the frame." @@ -7524,6 +7557,10 @@ raising the frame." If `pop-up-frames' is non-nil (and not `graphic-only' on a text-only terminal), try with `display-buffer-pop-up-frame'. +ALIST is an association list of action symbols and values. +See Info node `(elisp) Buffer Display Action Alists' for +details of such alists. + If that cannot be done, and `pop-up-windows' is non-nil, try again with `display-buffer-pop-up-window'." (or (display-buffer--maybe-pop-up-frame buffer alist) @@ -7532,7 +7569,11 @@ again with `display-buffer-pop-up-window'." (defun display-buffer--maybe-pop-up-frame (buffer alist) "Try displaying BUFFER based on `pop-up-frames'. If `pop-up-frames' is non-nil (and not `graphic-only' on a -text-only terminal), try with `display-buffer-pop-up-frame'." +text-only terminal), try with `display-buffer-pop-up-frame'. + +ALIST is an association list of action symbols and values. +See Info node `(elisp) Buffer Display Action Alists' for +details of such alists." (and (if (eq pop-up-frames 'graphic-only) (display-graphic-p) pop-up-frames) @@ -7550,6 +7591,10 @@ By default, this either reuses a child frame of the selected frame or makes a new child frame of the selected frame. If successful, return the window used; otherwise return nil. +ALIST is an association list of action symbols and values. +See Info node `(elisp) Buffer Display Action Alists' for +details of such alists. + If ALIST has a non-nil 'child-frame-parameters' entry, the corresponding value is an alist of frame parameters to give the new frame. A 'parent-frame' parameter specifying the selected @@ -7653,6 +7698,11 @@ ALIST is a buffer display alist." (defun display-buffer-in-direction (buffer alist) "Try to display BUFFER in a direction specified by ALIST. + +ALIST is an association list of action symbols and values. +See Info node `(elisp) Buffer Display Action Alists' for +details of such alists. + ALIST has to contain a 'direction' entry whose value should be one of 'left', 'above' (or 'up'), 'right', and 'below' (or 'down'). Other values are usually interpreted as 'below'. @@ -7741,6 +7791,10 @@ create a new window below the selected one and show BUFFER there. If that attempt fails as well and there is a non-dedicated window below the selected one, use that window. +ALIST is an association list of action symbols and values. +See Info node `(elisp) Buffer Display Action Alists' for +details of such alists. + If ALIST contains a 'window-min-height' entry, this function ensures that the window used is or can become at least as high as specified by that entry's value. Note that such an entry alone @@ -7795,7 +7849,11 @@ must also contain a 'window-height' entry with the same value." This either reuses such a window provided it shows BUFFER already, splits a window at the bottom of the frame or the frame's root window, or reuses some window at the bottom of the -selected frame." +selected frame. + +ALIST is an association list of action symbols and values. +See Info node `(elisp) Buffer Display Action Alists' for +details of such alists." (let (bottom-window bottom-window-shows-buffer window) (walk-window-tree (lambda (window) @@ -7819,6 +7877,11 @@ selected frame." (defun display-buffer-in-previous-window (buffer alist) "Display BUFFER in a window previously showing it. + +ALIST is an association list of action symbols and values. +See Info node `(elisp) Buffer Display Action Alists' for +details of such alists. + If ALIST has a non-nil `inhibit-same-window' entry, the selected window is not usable. A dedicated window is usable only if it already shows BUFFER. If ALIST contains a `previous-window' @@ -7890,6 +7953,10 @@ apply the following order of preference: Search for a usable window, set that window to the buffer, and return the window. If no suitable window is found, return nil. +ALIST is an association list of action symbols and values. +See Info node `(elisp) Buffer Display Action Alists' for +details of such alists. + If ALIST has a non-nil `inhibit-switch-frame' entry, then in the event that a window in another frame is chosen, avoid raising that frame." @@ -7930,6 +7997,11 @@ that frame." (defun display-buffer-no-window (_buffer alist) "Display BUFFER in no window. + +ALIST is an association list of action symbols and values. +See Info node `(elisp) Buffer Display Action Alists' for +details of such alists. + If ALIST has a non-nil `allow-no-window' entry, then don't display a window at all. This makes possible to override the default action and avoid displaying the buffer. It is assumed that when the caller commit e56e85d227b9c14b02e9c938efe994176a015db2 Author: Lars Ingebrigtsen Date: Fri Aug 2 23:11:28 2019 +0200 macroexp doc fixes * lisp/emacs-lisp/macroexp.el (macroexp-progn): Doc clarification (bug#19371). (macroexp-let*): Doc fix. diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index a04b3951c6..9b29d0058c 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -319,7 +319,8 @@ definitions to shadow the loaded ones for use in file byte-compilation." (cons (nreverse decls) body))) (defun macroexp-progn (exps) - "Return an expression equivalent to \\=`(progn ,@EXPS)." + "Return EXPS with `progn' prepended. +If EXPS is a single expression, `progn' is not prepended." (if (cdr exps) `(progn ,@exps) (car exps))) (defun macroexp-unprogn (exp) @@ -328,7 +329,7 @@ Never returns an empty list." (if (eq (car-safe exp) 'progn) (or (cdr exp) '(nil)) (list exp))) (defun macroexp-let* (bindings exp) - "Return an expression equivalent to \\=`(let* ,bindings ,exp)." + "Return an expression equivalent to \\=`(let* ,BINDINGS ,EXP)." (cond ((null bindings) exp) ((eq 'let* (car-safe exp)) `(let* (,@bindings ,@(cadr exp)) ,@(cddr exp))) commit 530a4af66cee9e028e767d5be471dfd9d4955f50 Author: Lars Ingebrigtsen Date: Fri Aug 2 23:03:47 2019 +0200 macroexp--cons doc fix * lisp/emacs-lisp/macroexp.el (macroexp--cons): Doc fix (bug#19371). diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 9af75320ec..a04b3951c6 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -33,7 +33,8 @@ (defvar macroexpand-all-environment nil) (defun macroexp--cons (car cdr original-cons) - "Return (CAR . CDR), using ORIGINAL-CONS if possible." + "Return ORIGINAL-CONS if the car/cdr of it is `eq' to CAR and CDR, respectively. +If not, return (CAR . CDR)." (if (and (eq car (car original-cons)) (eq cdr (cdr original-cons))) original-cons (cons car cdr))) commit 6f888d0711f0e1216dd5a6712b737d1fb2c2f102 Author: Lars Ingebrigtsen Date: Fri Aug 2 22:36:38 2019 +0200 Fix some minor inconsistencies in the Package examples * doc/lispref/package.texi (Simple Packages): Use one of the approved keywords (bug#19490). * doc/lispref/tips.texi (Library Headers): Use URL instead of Homepage to make things consistent with "Simple Packages". diff --git a/doc/lispref/package.texi b/doc/lispref/package.texi index a2f4f55be7..eb34b8e0af 100644 --- a/doc/lispref/package.texi +++ b/doc/lispref/package.texi @@ -158,7 +158,7 @@ the various headers, as illustrated by the following example: ;; Author: J. R. Hacker ;; Version: 1.3 ;; Package-Requires: ((flange "1.0")) -;; Keywords: multimedia, frobnicate +;; Keywords: multimedia, hypermedia ;; URL: http://example.com/jrhacker/superfrobnicate @dots{} diff --git a/doc/lispref/tips.texi b/doc/lispref/tips.texi index 01e9a3a851..855b284a15 100644 --- a/doc/lispref/tips.texi +++ b/doc/lispref/tips.texi @@ -958,7 +958,7 @@ explains these conventions, starting with an example: ;; Created: 14 Jul 2010 @group ;; Keywords: languages -;; Homepage: http://example.com/foo +;; URL: http://example.com/foo ;; This file is not part of GNU Emacs. commit acb8e331ca1e6914d8c158a6f387e84ce08c4f3b Author: Lars Ingebrigtsen Date: Fri Aug 2 22:04:38 2019 +0200 Don't but out on ~/.git files in ede * lisp/cedet/ede/detect.el (ede--detect-ldf-root-predicate): Make this work with ~/ as the dir (bug#19521). diff --git a/lisp/cedet/ede/detect.el b/lisp/cedet/ede/detect.el index 3dfb84803b..d65abce4b3 100644 --- a/lisp/cedet/ede/detect.el +++ b/lisp/cedet/ede/detect.el @@ -135,6 +135,8 @@ Return a cons cell: (defun ede--detect-ldf-root-predicate (dir) "Non-nil if DIR no longer match `ede--detect-nomatch-auto'." + ;; `dir' may be "~/". + (setq dir (expand-file-name dir)) (or (ede--detect-stop-scan-p dir) ;; To know if DIR is at the top, we need to look just above ;; to see if there is a match. commit 44d02d366b7809349d509e6814e67e48d05fef1e Author: Lars Ingebrigtsen Date: Fri Aug 2 21:45:19 2019 +0200 browse-url doc string fixup * lisp/net/browse-url.el (browse-url-browser-function) (browse-url-secondary-browser-function): Mention each other in the doc strings. diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 7962478701..135f11f03c 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -169,7 +169,9 @@ If the value is not a function it should be a list of pairs \(REGEXP . FUNCTION). In this case the function called will be the one associated with the first REGEXP which matches the current URL. The function is passed the URL and any other args of `browse-url'. The last -regexp should probably be \".\" to specify a default browser." +regexp should probably be \".\" to specify a default browser. + +Also see `browse-url-secondary-browser-function'." :type browse-url--browser-defcustom-type :version "24.1") @@ -178,7 +180,9 @@ regexp should probably be \".\" to specify a default browser." This is usually an external browser (that is, not eww or w3m), used as the secondary browser choice, typically when a prefix argument is given to a URL-opening command in those modes that -support this (for instance, eww/shr)." +support this (for instance, eww/shr). + +Also see `browse-url-browser-function'." :version "27.1" :type browse-url--browser-defcustom-type) commit 685a82298ef3686ad4663c5873203e222e864fad Author: Lars Ingebrigtsen Date: Fri Aug 2 21:25:29 2019 +0200 Make Info-find-file ensure that Info is initialised * lisp/info.el (Info-find-file): Ensure that Info is initialised, because libraries call that function (bug#19880). diff --git a/lisp/info.el b/lisp/info.el index cc18ea11f3..16909736f8 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -882,6 +882,7 @@ just return nil (no error). If NO-POP-TO-DIR, don't try to pop to the info buffer if we can't find a node." + (info-initialize) ;; Convert filename to lower case if not found as specified. ;; Expand it. (cond commit 1b82cc0105994e638766ba864654add6935fa508 Author: Lars Ingebrigtsen Date: Fri Aug 2 21:21:23 2019 +0200 Fix progression in hideshow.el * lisp/progmodes/hideshow.el (hs-hide-all): Ensure progression in a less brittle fashion (bug#19892). diff --git a/lisp/progmodes/hideshow.el b/lisp/progmodes/hideshow.el index 4cfcd3d09a..0fb5c55512 100644 --- a/lisp/progmodes/hideshow.el +++ b/lisp/progmodes/hideshow.el @@ -806,7 +806,8 @@ If `hs-hide-comments-when-hiding-all' is non-nil, also hide the comments." (hs-hide-block-at-point t)) ;; Go to end of matched data to prevent from getting stuck ;; with an endless loop. - (goto-char (match-end 0)))) + (when (looking-at hs-block-start-regexp) + (goto-char (match-end 0))))) ;; found a comment, probably (let ((c-reg (hs-inside-comment-p))) (when (and c-reg (car c-reg)) commit 0393cd2f721f8e44b4cef3b0864f1b4903ab9ba3 Author: Michael Heerdegen Date: Fri Aug 2 21:04:22 2019 +0200 Fix example code in hideshow.el * lisp/progmodes/hideshow.el: The original example would infloop (bug#19892). diff --git a/lisp/progmodes/hideshow.el b/lisp/progmodes/hideshow.el index 1d62bb5875..4cfcd3d09a 100644 --- a/lisp/progmodes/hideshow.el +++ b/lisp/progmodes/hideshow.el @@ -97,7 +97,8 @@ ;; nested level in addition to the top-level: ;; ;; (defun ttn-hs-hide-level-1 () -;; (hs-hide-level 1) +;; (when (hs-looking-at-block-start-p) +;; (hs-hide-level 1)) ;; (forward-sexp 1)) ;; (setq hs-hide-all-non-comment-function 'ttn-hs-hide-level-1) ;; commit 3e943ebc34d3583480546da24ecb65ca74119297 Author: Michael Albinus Date: Fri Aug 2 20:14:23 2019 +0200 Use default value of `parse-time-months' in tramp-smb.el * lisp/net/tramp-smb.el (tramp-smb-read-file-entry): Use default value of `parse-time-months'. diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 568c6cb43a..cb8d2df084 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -1814,10 +1814,12 @@ Result is the list (LOCALNAME MODE SIZE MTIME)." (if (and sec min hour day month year) (encode-time sec min hour day - ;; FIXME: Won't this fail if parse-time-months is configured - ;; by the user? See "The date/time prompt" in the Org manual. - ;; If the code is OK as-is, perhaps explain why in a comment. - (cdr (assoc (downcase month) parse-time-months)) + ;; `parse-time-months' could be customized by the + ;; user, so we take its default value. + (cdr + (assoc + (downcase month) + (default-toplevel-value 'parse-time-months))) year) tramp-time-dont-know)) (list localname mode size mtime)))) commit a6a0e857d4d23726a6f3a90d85e43fd6061e296e Author: Michael Albinus Date: Fri Aug 2 20:13:44 2019 +0200 ; Fix typo in filenotify-tests.el diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el index 3d2f6e6a73..2027299197 100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@ -1397,7 +1397,7 @@ the file watch." ;; active. We receive the `deleted' event from both the ;; directory and the file monitor. The `stopped' event is ;; from the file monitor. It's undecided in which order the - ;; the directory and the file monitor are triggered. + ;; directory and the file monitor are triggered. (file-notify--test-with-actions '(:random deleted deleted stopped) (delete-file file-notify--test-tmpfile1)) (should (file-notify-valid-p file-notify--test-desc1)) commit 10065010a64d4a9a109030773aa835a5c7e00429 Author: Tassilo Horn Date: Fri Aug 2 18:05:13 2019 +0200 Improve pretty-printing of multiple JSON snippets in a region * lisp/json.el (json-pretty-print): Improve pretty-printing of multiple JSON snippets in a region. Don't lose the region contents starting with the first non-JSON-parseable text. Also, don't swallow errors that occurred while parsing (bug#34160). diff --git a/lisp/json.el b/lisp/json.el index cdb1be0616..f20fbcd0f8 100644 --- a/lisp/json.el +++ b/lisp/json.el @@ -772,25 +772,60 @@ With prefix argument MINIMIZE, minimize it instead." (json-null :json-null) ;; Ensure that ordering is maintained (json-object-type 'alist) - (err (gensym)) - json) - (replace-region-contents - begin end - (lambda () - (let ((pretty "")) - (save-restriction - (narrow-to-region begin end) - (goto-char begin) - (while (not (eq (setq json (condition-case nil - (json-read) - (json-error err))) - err)) - (setq pretty (concat pretty (json-encode json))))) - pretty)) - json-pretty-print-max-secs - ;; FIXME: What's a good value here? Can we use something better, - ;; e.g., by deriving a value from the size of the region? - 64))) + (orig-buf (current-buffer)) + error) + ;; Strategy: Repeatedly `json-read' from the original buffer and + ;; write the pretty-printed snippet to a temporary buffer. As + ;; soon as we get an error from `json-read', simply append the + ;; remainder which we couldn't pretty-print to the temporary + ;; buffer as well (probably the region ends _inside_ a JSON + ;; object). + ;; + ;; Finally, use `replace-region-contents' to swap the original + ;; region with the contents of the temporary buffer so that point, + ;; marks, etc. are kept. + (with-temp-buffer + (let ((tmp-buf (current-buffer))) + (set-buffer orig-buf) + (replace-region-contents + begin end + (lambda () + (let ((pos (point)) + (keep-going t)) + (while keep-going + (condition-case err + ;; We want to format only the JSON snippets in the + ;; region without modifying the whitespace between + ;; them. + (let ((space (buffer-substring + (point) + (+ (point) + (skip-chars-forward + " \t\n" (point-max))))) + (json (json-read))) + (setq pos (point)) ; End of last good json-read. + (set-buffer tmp-buf) + (insert space (json-encode json)) + (set-buffer orig-buf)) + (t + (setq keep-going nil) + (set-buffer orig-buf) + ;; Rescue the remainder we couldn't pretty-print. + (append-to-buffer tmp-buf pos (point-max)) + ;; EOF is expected because we json-read until we hit + ;; the end of the narrow region. + (unless (eq (car err) 'json-end-of-file) + (setq error err))))) + tmp-buf)) + json-pretty-print-max-secs + ;; FIXME: What's a good value here? Can we use something better, + ;; e.g., by deriving a value from the size of the region? + 64))) + ;; If we got an error during JSON processing (possibly the region + ;; starts or ends inside a JSON object), signal it to the user. + ;; We did our best. + (when error + (signal (car error) (cdr error))))) (defun json-pretty-print-buffer-ordered (&optional minimize) "Pretty-print current buffer with object keys ordered. commit 695fbcf56db5a4336865e64b6d076008c62ce2ef Author: Basil L. Contovounesios Date: Fri Aug 2 16:39:53 2019 +0300 ; Docfixes for recent browse-url.el additions * lisp/net/browse-url.el (browse-url-secondary-browser-function) (browse-url-button-copy): Fix punctuation in and clarify docstrings. diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 6382e66f61..7962478701 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -175,10 +175,10 @@ regexp should probably be \".\" to specify a default browser." (defcustom browse-url-secondary-browser-function 'browse-url-default-browser "Function used to launch an alternative browser. -This should usually be an external browser (that is, not eww or -w3m), used as the secondary browser choice, and is typically used -when giving a prefix argument to the URL-opening command (in -those modes that support this (for instance, eww/shr)." +This is usually an external browser (that is, not eww or w3m), +used as the secondary browser choice, typically when a prefix +argument is given to a URL-opening command in those modes that +support this (for instance, eww/shr)." :version "27.1" :type browse-url--browser-defcustom-type) @@ -1700,7 +1700,7 @@ If `current-prefix-arg' is non-nil, use (browse-url url))) (defun browse-url-button-copy () - "Copy the URL under point" + "Copy the URL under point." (interactive) (let ((url (get-text-property (point) 'browse-url-data))) (unless url commit 558038ccb76614d60bf54cb62359027d25e00f72 Author: Alan Mackenzie Date: Fri Aug 2 13:38:13 2019 +0000 CC Mode: Fix error in macro cache. This fixes bug #36802 * lisp/progmodes/cc-engine.el (c-invalidate-macro-cache): Add in a cond arm to handle the change position being less than the recorded CPP contruct end. diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index 37d4591fc9..a095277989 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -269,6 +269,11 @@ ((and (cdr c-macro-cache) (< beg (cdr c-macro-cache))) (setcdr c-macro-cache nil) + (setq c-macro-cache-start-pos beg + c-macro-cache-syntactic nil + c-macro-cache-no-comment nil)) + ((and c-macro-cache-start-pos + (< beg c-macro-cache-start-pos)) (setq c-macro-cache-start-pos beg c-macro-cache-syntactic nil c-macro-cache-no-comment nil)))) commit eddf4664d786e16b34f6bd0af238a567feb5012c Author: Basil L. Contovounesios Date: Mon Jul 22 21:57:39 2019 +0100 Make gravatar.el more configurable For discussion, see the following thread: https://lists.gnu.org/archive/html/emacs-devel/2019-07/msg00528.html * etc/NEWS: Announce changes in gravatar.el user options. * lisp/image/gravatar.el (gravatar-cache-ttl): Change :type to number of seconds without changing the default value and while still accepting other timestamp formats. (gravatar-rating): Restrict :type to ratings recognized by Gravatar. (gravatar-size): Allow nil as a value, in which case Gravatar's default size is used. (gravatar-default-image, gravatar-force-default): New user options controlling the Gravatar query parameters 'default' and 'forcedefault', respectively. (gravatar-base-url): Use HTTPS. (gravatar--query-string): New helper function to facilitate testing. (gravatar-build-url): Use it. * test/lisp/image/gravatar-tests.el (gravatar-size) (gravatar-default-image, gravatar-force-default) (gravatar-build-url): New tests. diff --git a/etc/NEWS b/etc/NEWS index 9be10b4e79..e84c0d3ec5 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1788,6 +1788,22 @@ particular when the end of the buffer is visible in the window. Use 'mouse-wheel-mode' instead. Note that 'mouse-wheel-mode' is already enabled by default on most graphical displays. +** Gravatar + ++++ +*** 'gravatar-cache-ttl' is now a number of seconds. +The previously used timestamp format of a list of integers is still +supported, but is deprecated. The default value has not changed. + ++++ +*** 'gravatar-size' can now be nil. +This results in the use of Gravatar's default size of 80 pixels. + ++++ +*** The default fallback gravatar is now configurable. +This is possible using the new user options 'gravatar-default-image' +and 'gravatar-force-default'. + * New Modes and Packages in Emacs 27.1 diff --git a/lisp/image/gravatar.el b/lisp/image/gravatar.el index 52fd875d68..e235fdd76f 100644 --- a/lisp/image/gravatar.el +++ b/lisp/image/gravatar.el @@ -39,12 +39,13 @@ :type 'boolean :group 'gravatar) -;; FIXME a time value is not the nicest format for a custom variable. -(defcustom gravatar-cache-ttl (days-to-time 30) - "Time to live for gravatar cache entries. +(defcustom gravatar-cache-ttl 2592000 + "Time to live in seconds for gravatar cache entries. If a requested gravatar has been cached for longer than this, it -is retrieved anew." - :type '(repeat integer) +is retrieved anew. The default value is 30 days." + :type 'integer + ;; Restricted :type to number of seconds. + :version "27.1" :group 'gravatar) (defcustom gravatar-rating "g" @@ -64,17 +65,61 @@ of increasing explicitness, the following: Each level covers itself as well as all less explicit levels. For example, setting this variable to \"pg\" will allow gravatars rated either \"g\" or \"pg\"." - :type 'string + :type '(choice (const :tag "General Audience" "g") + (const :tag "Parental Guidance" "pg") + (const :tag "Restricted" "r") + (const :tag "Explicit" "x")) + ;; Restricted :type to ratings recognized by Gravatar. + :version "27.1" :group 'gravatar) (defcustom gravatar-size 32 "Gravatar size in pixels to request. -Valid sizes range from 1 to 2048 inclusive." - :type 'integer +Valid sizes range from 1 to 2048 inclusive. If nil, use the +Gravatar default (usually 80)." + :type '(choice (const :tag "Gravatar default" nil) + (integer :tag "Pixels")) + :version "27.1" + :group 'gravatar) + +(defcustom gravatar-default-image "404" + "Default gravatar to use when none match the request. +This happens when no gravatar satisfying `gravatar-rating' exists +for a given email address. The following options are supported: + +nil - Default placeholder. +\"404\" - No placeholder. +\"mp\" - Mystery Person: generic avatar outline. +\"identicon\" - Geometric pattern based on email address. +\"monsterid\" - Generated \"monster\" with different colors, faces, etc. +\"wavatar\" - Generated faces with different features and backgrounds. +\"retro\" - Generated 8-bit arcade-style pixelated faces. +\"robohash\" - Generated robot with different colors, faces, etc. +\"blank\" - Transparent PNG image. +URL - Custom image URL." + :type '(choice (const :tag "Default" nil) + (const :tag "None" "404") + (const :tag "Mystery person" "mp") + (const :tag "Geometric patterns" "identicon") + (const :tag "Monsters" "monsterid") + (const :tag "Faces" "wavatar") + (const :tag "Retro" "retro") + (const :tag "Robots" "robohash") + (const :tag "Blank" "blank") + (string :tag "Custom URL")) + :version "27.1" + :group 'gravatar) + +(defcustom gravatar-force-default nil + "Whether to force use of `gravatar-default-image'. +Non-nil means use `gravatar-default-image' even when there exists +a gravatar for a given email address." + :type 'boolean + :version "27.1" :group 'gravatar) (defconst gravatar-base-url - "http://www.gravatar.com/avatar" + "https://www.gravatar.com/avatar" "Base URL for getting gravatars.") (defun gravatar-hash (mail-address) @@ -82,13 +127,24 @@ Valid sizes range from 1 to 2048 inclusive." ;; https://gravatar.com/site/implement/hash/ (md5 (downcase (string-trim mail-address)))) +(defun gravatar--query-string () + "Return URI-encoded query string for Gravatar." + (url-build-query-string + `((r ,gravatar-rating) + ,@(and gravatar-default-image + `((d ,gravatar-default-image))) + ,@(and gravatar-force-default + '((f y))) + ,@(and gravatar-size + `((s ,gravatar-size)))))) + (defun gravatar-build-url (mail-address) - "Return a URL to retrieve MAIL-ADDRESS gravatar." - (format "%s/%s?d=404&r=%s&s=%d" + "Return the URL of a gravatar for MAIL-ADDRESS." + ;; https://gravatar.com/site/implement/images/ + (format "%s/%s?%s" gravatar-base-url (gravatar-hash mail-address) - gravatar-rating - gravatar-size)) + (gravatar--query-string))) (defun gravatar-get-data () "Return body of current URL buffer, or nil on failure." diff --git a/test/lisp/image/gravatar-tests.el b/test/lisp/image/gravatar-tests.el index e6239da008..bd61663f0e 100644 --- a/test/lisp/image/gravatar-tests.el +++ b/test/lisp/image/gravatar-tests.el @@ -31,4 +31,42 @@ (should (equal (gravatar-hash " foo") hash)) (should (equal (gravatar-hash " foo ") hash)))) +(ert-deftest gravatar-size () + "Test query strings for `gravatar-size'." + (let ((gravatar-default-image nil) + (gravatar-force-default nil)) + (let ((gravatar-size 2048)) + (should (equal (gravatar--query-string) "r=g&s=2048"))) + (let ((gravatar-size nil)) + (should (equal (gravatar--query-string) "r=g"))))) + +(ert-deftest gravatar-default-image () + "Test query strings for `gravatar-default-image'." + (let ((gravatar-force-default nil) + (gravatar-size nil)) + (let ((gravatar-default-image nil)) + (should (equal (gravatar--query-string) "r=g"))) + (let ((gravatar-default-image "404")) + (should (equal (gravatar--query-string) "r=g&d=404"))) + (let ((gravatar-default-image "https://foo/bar.png")) + (should (equal (gravatar--query-string) + "r=g&d=https%3A%2F%2Ffoo%2Fbar.png"))))) + +(ert-deftest gravatar-force-default () + "Test query strings for `gravatar-force-default'." + (let ((gravatar-default-image nil) + (gravatar-size nil)) + (let ((gravatar-force-default nil)) + (should (equal (gravatar--query-string) "r=g"))) + (let ((gravatar-force-default t)) + (should (equal (gravatar--query-string) "r=g&f=y"))))) + +(ert-deftest gravatar-build-url () + "Test `gravatar-build-url'." + (let ((gravatar-default-image nil) + (gravatar-force-default nil) + (gravatar-size nil)) + (should (equal (gravatar-build-url "foo") "\ +https://www.gravatar.com/avatar/acbd18db4cc2f85cedef654fccc4a4d8?r=g")))) + ;;; gravatar-tests.el ends here commit b4b1eda7fbf4c4f3fa6377bd18d1d1a22e6e4b42 Author: Basil L. Contovounesios Date: Mon Jul 22 21:48:45 2019 +0100 Fix some minor gravatar.el issues For discussion, see the following thread: https://lists.gnu.org/archive/html/emacs-devel/2019-07/msg00528.html * lisp/image/gravatar.el (gravatar-hash): Trim leading and trailing whitespace in given address, as per the Gravatar docs. (gravatar-retrieve-synchronously): Silence call to url-retrieve-synchronously for consistency with gravatar-retrieve. (gravatar-retrieved): Only cache buffer on successful retrieval. * test/lisp/image/gravatar-tests.el: New file. diff --git a/lisp/image/gravatar.el b/lisp/image/gravatar.el index fb539bcdbd..52fd875d68 100644 --- a/lisp/image/gravatar.el +++ b/lisp/image/gravatar.el @@ -26,6 +26,8 @@ (require 'url) (require 'url-cache) +(eval-when-compile + (require 'subr-x)) (defgroup gravatar nil "Gravatars." @@ -76,8 +78,9 @@ Valid sizes range from 1 to 2048 inclusive." "Base URL for getting gravatars.") (defun gravatar-hash (mail-address) - "Create a hash from MAIL-ADDRESS." - (md5 (downcase mail-address))) + "Return the Gravatar hash for MAIL-ADDRESS." + ;; https://gravatar.com/site/implement/hash/ + (md5 (downcase (string-trim mail-address)))) (defun gravatar-build-url (mail-address) "Return a URL to retrieve MAIL-ADDRESS gravatar." @@ -114,7 +117,7 @@ Value is either an image descriptor, or the symbol `error' if the retrieval failed." (let ((url (gravatar-build-url mail-address))) (with-current-buffer (if (url-cache-expired url gravatar-cache-ttl) - (url-retrieve-synchronously url) + (url-retrieve-synchronously url t) (url-fetch-from-cache url)) (gravatar-retrieved () #'identity)))) @@ -125,7 +128,8 @@ an image descriptor, or the symbol `error' on failure. This function is intended as a callback for `url-retrieve'." (let ((data (unless (plist-get status :error) (gravatar-get-data)))) - (and url-current-object ; Only cache if not already cached. + (and data ; Only cache on success. + url-current-object ; Only cache if not already cached. gravatar-automatic-caching (url-store-in-cache)) (prog1 (apply cb (if data (create-image data nil t) 'error) cbargs) diff --git a/test/lisp/image/gravatar-tests.el b/test/lisp/image/gravatar-tests.el new file mode 100644 index 0000000000..e6239da008 --- /dev/null +++ b/test/lisp/image/gravatar-tests.el @@ -0,0 +1,34 @@ +;;; gravatar-tests.el --- tests for gravatar.el -*- lexical-binding: t -*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'gravatar) + +(ert-deftest gravatar-hash () + "Test `gravatar-hash'." + (should (equal (gravatar-hash "") "d41d8cd98f00b204e9800998ecf8427e")) + (let ((hash "acbd18db4cc2f85cedef654fccc4a4d8")) + (should (equal (gravatar-hash "foo") hash)) + (should (equal (gravatar-hash "foo ") hash)) + (should (equal (gravatar-hash " foo") hash)) + (should (equal (gravatar-hash " foo ") hash)))) + +;;; gravatar-tests.el ends here commit cf569e520ee080b5a913d37d363a5ab5fc38d982 Author: Basil L. Contovounesios Date: Mon Jul 22 21:49:47 2019 +0100 DRY in gravatar.el For discussion, see the following thread: https://lists.gnu.org/archive/html/emacs-devel/2019-07/msg00528.html * lisp/image/gravatar.el (gravatar-data->image): Remove. (gravatar-retrieve, gravatar-retrieve-synchronously): Reuse url-fetch-from-cache and gravatar-retrieved to reduce duplication. (gravatar-retrieved): Only cache buffer if url-current-object is non-nil and return result of callback. This affords reusing this function in cached URL buffers. diff --git a/lisp/image/gravatar.el b/lisp/image/gravatar.el index ea746b71d7..fb539bcdbd 100644 --- a/lisp/image/gravatar.el +++ b/lisp/image/gravatar.el @@ -95,14 +95,6 @@ Valid sizes range from 1 to 2048 inclusive." (search-forward "\n\n" nil t) (buffer-substring (point) (point-max))))) -(defun gravatar-data->image () - "Get data of current buffer and return an image. -If no image available, return 'error." - (let ((data (gravatar-get-data))) - (if data - (create-image data nil t) - 'error))) - ;;;###autoload (defun gravatar-retrieve (mail-address callback &optional cbargs) "Asynchronously retrieve a gravatar for MAIL-ADDRESS. @@ -112,11 +104,8 @@ where GRAVATAR is either an image descriptor, or the symbol (let ((url (gravatar-build-url mail-address))) (if (url-cache-expired url gravatar-cache-ttl) (url-retrieve url #'gravatar-retrieved (list callback cbargs) t) - (apply callback - (with-temp-buffer - (url-cache-extract (url-cache-create-filename url)) - (gravatar-data->image)) - cbargs)))) + (with-current-buffer (url-fetch-from-cache url) + (gravatar-retrieved () callback cbargs))))) ;;;###autoload (defun gravatar-retrieve-synchronously (mail-address) @@ -124,26 +113,23 @@ where GRAVATAR is either an image descriptor, or the symbol Value is either an image descriptor, or the symbol `error' if the retrieval failed." (let ((url (gravatar-build-url mail-address))) - (if (url-cache-expired url gravatar-cache-ttl) - (with-current-buffer (url-retrieve-synchronously url) - (when gravatar-automatic-caching - (url-store-in-cache (current-buffer))) - (prog1 (gravatar-data->image) - (kill-buffer (current-buffer)))) - (with-temp-buffer - (url-cache-extract (url-cache-create-filename url)) - (gravatar-data->image))))) + (with-current-buffer (if (url-cache-expired url gravatar-cache-ttl) + (url-retrieve-synchronously url) + (url-fetch-from-cache url)) + (gravatar-retrieved () #'identity)))) (defun gravatar-retrieved (status cb &optional cbargs) - "Callback function used by `gravatar-retrieve'." - ;; Store gravatar? - (when gravatar-automatic-caching - (url-store-in-cache (current-buffer))) - (if (plist-get status :error) - ;; Error happened. - (apply cb 'error cbargs) - (apply cb (gravatar-data->image) cbargs)) - (kill-buffer (current-buffer))) + "Handle Gravatar response data in current buffer. +Return the result of (apply CB DATA CBARGS), where DATA is either +an image descriptor, or the symbol `error' on failure. +This function is intended as a callback for `url-retrieve'." + (let ((data (unless (plist-get status :error) + (gravatar-get-data)))) + (and url-current-object ; Only cache if not already cached. + gravatar-automatic-caching + (url-store-in-cache)) + (prog1 (apply cb (if data (create-image data nil t) 'error) cbargs) + (kill-buffer)))) (provide 'gravatar) commit 60eb0a4834305e1c2b31b1e817875f3d8d0be5f5 Author: Basil L. Contovounesios Date: Mon Jul 22 22:06:22 2019 +0100 Use lexical-binding for Gravatar support For discussion, see the following thread: https://lists.gnu.org/archive/html/emacs-devel/2019-07/msg00528.html * lisp/gnus/gnus-gravatar.el: Use lexical-binding. Link custom group 'gnus-gravatar' to 'gravatar'. (gnus-gravatar-size, gnus-gravatar-too-ugly): Doc fix. (gnus-gravatar-insert): Check liveness of article buffer sooner. (gnus-treat-from-gravatar, gnus-treat-mail-gravatar): Use interactive spec "p" instead of emulating it. * lisp/image/gravatar.el: Use lexical-binding. (gravatar-cache-expired): Remove. Change all callers to use url-cache-expired instead. (gravatar-get-data, gravatar-retrieve) (gravatar-retrieve-synchronously): Simplify. diff --git a/lisp/gnus/gnus-gravatar.el b/lisp/gnus/gnus-gravatar.el index 19cbf529c6..ec3f909161 100644 --- a/lisp/gnus/gnus-gravatar.el +++ b/lisp/gnus/gnus-gravatar.el @@ -1,9 +1,9 @@ -;;; gnus-gravatar.el --- Gnus Gravatar support +;;; gnus-gravatar.el --- Gnus Gravatar support -*- lexical-binding: t -*- ;; Copyright (C) 2010-2019 Free Software Foundation, Inc. ;; Author: Julien Danjou -;; Keywords: news +;; Keywords: multimedia, news ;; This file is part of GNU Emacs. @@ -29,13 +29,15 @@ (require 'mail-extr) ;; Because of binding `mail-extr-disable-voodoo'. (defgroup gnus-gravatar nil - "Gnus Gravatar." + "Gravatars in Gnus." + :link '(custom-group-link gravatar) :group 'gnus-visual) (defcustom gnus-gravatar-size nil - "How big should gravatars be displayed. + "Size in pixels at which gravatars should be displayed. If nil, default to `gravatar-size'." - :type '(choice (const nil) integer) + :type '(choice (const :tag "Default" nil) + (integer :tag "Pixels")) :version "24.1" :group 'gnus-gravatar) @@ -48,7 +50,7 @@ If nil, default to `gravatar-size'." (defcustom gnus-gravatar-too-ugly gnus-article-x-face-too-ugly "Regexp matching posters whose avatar shouldn't be shown automatically. If nil, show all avatars." - :type '(choice regexp (const nil)) + :type '(choice regexp (const :tag "Allow all" nil)) :version "24.1" :group 'gnus-gravatar) @@ -74,56 +76,57 @@ If nil, show all avatars." (ignore-errors (gravatar-retrieve (cadr address) - 'gnus-gravatar-insert + #'gnus-gravatar-insert (list header address category)))))))) (defun gnus-gravatar-insert (gravatar header address category) "Insert GRAVATAR for ADDRESS in HEADER in current article buffer. -Set image category to CATEGORY." +Set image category to CATEGORY. This function is intended as a +callback for `gravatar-retrieve'." (unless (eq gravatar 'error) (gnus-with-article-buffer - (let ((mark (point-marker)) - (inhibit-point-motion-hooks t) - (case-fold-search t)) - (save-restriction - (article-narrow-to-head) - ;; The buffer can be gone at this time - (when (buffer-live-p (current-buffer)) + ;; The buffer can be gone at this time. + (when (buffer-live-p (current-buffer)) + (let ((real-name (car address)) + (mail-address (cadr address)) + (mark (point-marker)) + (inhibit-point-motion-hooks t) + (case-fold-search t)) + (save-restriction + (article-narrow-to-head) (gnus-article-goto-header header) (mail-header-narrow-to-field) - (let ((real-name (car address)) - (mail-address (cadr address))) - (when (if real-name - (re-search-forward - (concat (replace-regexp-in-string - "[\t ]+" "[\t\n ]+" - (regexp-quote real-name)) - "\\|" - (regexp-quote mail-address)) - nil t) - (search-forward mail-address nil t)) - (goto-char (1- (match-beginning 0))) - ;; If we're on the " quoting the name, go backward - (when (looking-at "[\"<]") - (goto-char (1- (point)))) - ;; Do not do anything if there's already a gravatar. This can - ;; happens if the buffer has been regenerated in the mean time, for - ;; example we were fetching someaddress, and then we change to - ;; another mail with the same someaddress. - (unless (memq 'gnus-gravatar (text-properties-at (point))) - (let ((point (point))) - (setq gravatar (append gravatar gnus-gravatar-properties)) - (gnus-put-image gravatar (buffer-substring (point) (1+ point)) category) - (put-text-property point (point) 'gnus-gravatar address) - (gnus-add-wash-type category) - (gnus-add-image category gravatar))))))) - (goto-char (marker-position mark)))))) + (when (if real-name + (re-search-forward + (concat (replace-regexp-in-string + "[\t ]+" "[\t\n ]+" + (regexp-quote real-name)) + "\\|" + (regexp-quote mail-address)) + nil t) + (search-forward mail-address nil t)) + (goto-char (1- (match-beginning 0))) + ;; If we're on the " quoting the name, go backward. + (when (looking-at-p "[\"<]") + (goto-char (1- (point)))) + ;; Do not do anything if there's already a gravatar. This can + ;; happen if the buffer has been regenerated in the mean time, for + ;; example we were fetching someaddress, and then we change to + ;; another mail with the same someaddress. + (unless (get-text-property (point) 'gnus-gravatar) + (let ((pos (point))) + (setq gravatar (append gravatar gnus-gravatar-properties)) + (gnus-put-image gravatar (buffer-substring pos (1+ pos)) category) + (put-text-property pos (point) 'gnus-gravatar address) + (gnus-add-wash-type category) + (gnus-add-image category gravatar))))) + (goto-char mark)))))) ;;;###autoload (defun gnus-treat-from-gravatar (&optional force) "Display gravatar in the From header. If gravatar is already displayed, remove it." - (interactive (list t)) ;; When type `W D g' + (interactive "p") (gnus-with-article-buffer (if (memq 'from-gravatar gnus-article-wash-types) (gnus-delete-images 'from-gravatar) @@ -133,12 +136,12 @@ If gravatar is already displayed, remove it." (defun gnus-treat-mail-gravatar (&optional force) "Display gravatars in the Cc and To headers. If gravatars are already displayed, remove them." - (interactive (list t)) ;; When type `W D h' - (gnus-with-article-buffer - (if (memq 'mail-gravatar gnus-article-wash-types) - (gnus-delete-images 'mail-gravatar) - (gnus-gravatar-transform-address "cc" 'mail-gravatar force) - (gnus-gravatar-transform-address "to" 'mail-gravatar force)))) + (interactive "p") + (gnus-with-article-buffer + (if (memq 'mail-gravatar gnus-article-wash-types) + (gnus-delete-images 'mail-gravatar) + (gnus-gravatar-transform-address "cc" 'mail-gravatar force) + (gnus-gravatar-transform-address "to" 'mail-gravatar force)))) (provide 'gnus-gravatar) diff --git a/lisp/image/gravatar.el b/lisp/image/gravatar.el index 9a1ec3b556..ea746b71d7 100644 --- a/lisp/image/gravatar.el +++ b/lisp/image/gravatar.el @@ -1,9 +1,9 @@ -;;; gravatar.el --- Get Gravatars +;;; gravatar.el --- Get Gravatars -*- lexical-binding: t -*- ;; Copyright (C) 2010-2019 Free Software Foundation, Inc. ;; Author: Julien Danjou -;; Keywords: news +;; Keywords: comm, multimedia ;; This file is part of GNU Emacs. @@ -26,10 +26,9 @@ (require 'url) (require 'url-cache) -(require 'image) (defgroup gravatar nil - "Gravatar." + "Gravatars." :version "24.1" :group 'comm) @@ -88,22 +87,13 @@ Valid sizes range from 1 to 2048 inclusive." gravatar-rating gravatar-size)) -(defun gravatar-cache-expired (url) - "Check if URL is cached for more than `gravatar-cache-ttl'." - (cond (url-standalone-mode - (not (file-exists-p (url-cache-create-filename url)))) - (t (let ((cache-time (url-is-cached url))) - (if cache-time - (time-less-p (time-add cache-time gravatar-cache-ttl) nil) - t))))) - (defun gravatar-get-data () - "Get data from current buffer." + "Return body of current URL buffer, or nil on failure." (save-excursion (goto-char (point-min)) - (when (re-search-forward "^HTTP/.+ 200 OK$" nil (line-end-position)) - (when (search-forward "\n\n" nil t) - (buffer-substring (point) (point-max)))))) + (and (re-search-forward "^HTTP/.+ 200 OK$" nil (line-end-position)) + (search-forward "\n\n" nil t) + (buffer-substring (point) (point-max))))) (defun gravatar-data->image () "Get data of current buffer and return an image. @@ -113,29 +103,20 @@ If no image available, return 'error." (create-image data nil t) 'error))) -(autoload 'help-function-arglist "help-fns") - ;;;###autoload -(defun gravatar-retrieve (mail-address cb &optional cbargs) +(defun gravatar-retrieve (mail-address callback &optional cbargs) "Asynchronously retrieve a gravatar for MAIL-ADDRESS. -When finished, call CB as (apply CB GRAVATAR CBARGS), +When finished, call CALLBACK as (apply CALLBACK GRAVATAR CBARGS), where GRAVATAR is either an image descriptor, or the symbol `error' if the retrieval failed." (let ((url (gravatar-build-url mail-address))) - (if (gravatar-cache-expired url) - (let ((args (list url - 'gravatar-retrieved - (list cb (when cbargs cbargs))))) - (when (> (length (help-function-arglist 'url-retrieve)) - 4) - (setq args (nconc args (list t)))) - (apply #'url-retrieve args)) - (apply cb - (with-temp-buffer - (set-buffer-multibyte nil) - (url-cache-extract (url-cache-create-filename url)) - (gravatar-data->image)) - cbargs)))) + (if (url-cache-expired url gravatar-cache-ttl) + (url-retrieve url #'gravatar-retrieved (list callback cbargs) t) + (apply callback + (with-temp-buffer + (url-cache-extract (url-cache-create-filename url)) + (gravatar-data->image)) + cbargs)))) ;;;###autoload (defun gravatar-retrieve-synchronously (mail-address) @@ -143,19 +124,16 @@ where GRAVATAR is either an image descriptor, or the symbol Value is either an image descriptor, or the symbol `error' if the retrieval failed." (let ((url (gravatar-build-url mail-address))) - (if (gravatar-cache-expired url) + (if (url-cache-expired url gravatar-cache-ttl) (with-current-buffer (url-retrieve-synchronously url) (when gravatar-automatic-caching (url-store-in-cache (current-buffer))) - (let ((data (gravatar-data->image))) - (kill-buffer (current-buffer)) - data)) + (prog1 (gravatar-data->image) + (kill-buffer (current-buffer)))) (with-temp-buffer - (set-buffer-multibyte nil) (url-cache-extract (url-cache-create-filename url)) (gravatar-data->image))))) - (defun gravatar-retrieved (status cb &optional cbargs) "Callback function used by `gravatar-retrieve'." ;; Store gravatar? commit 87ec668e95084af45bec010de36493fb90a26461 Author: Alan Mackenzie Date: Fri Aug 2 12:57:40 2019 +0000 CC Mode: Fix spurious recognition of operators beginning with, e.g. "or" This fixes bug #36801. * lisp/progmodes/cc-langs.el (c-pre-lambda-tokens-re): Use c-make-keywords-re rather than regexp-opt to make an optimised regexp out of a list of tokens. diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el index f3dd0c6c4c..9d36f8f9e4 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el @@ -1542,7 +1542,7 @@ Currently (2016-08) only used in C++ mode." (c-lang-defconst c-pre-lambda-tokens-re ;; Regexp matching any token in the list `c-pre-lambda-tokens'. - t (regexp-opt (c-lang-const c-pre-lambda-tokens))) + t (c-make-keywords-re t (c-lang-const c-pre-lambda-tokens))) (c-lang-defvar c-pre-lambda-tokens-re (c-lang-const c-pre-lambda-tokens-re)) ;;; Syntactic whitespace. commit 3975eb46150a6c896319b350112c036c678cfc38 Author: Lars Ingebrigtsen Date: Fri Aug 2 14:46:48 2019 +0200 pdb doc clarification * lisp/progmodes/gud.el (pdb): Clarify what the parameters mean (bug#20106). diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index 6b152b7b90..b6a4ad3cd0 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -1681,9 +1681,15 @@ This should be an executable on your path, or an absolute file name." ;;;###autoload (defun pdb (command-line) - "Run pdb on program FILE in buffer `*gud-FILE*'. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger." + "Run COMMAND-LINE in the `*gud-FILE*' buffer. + +COMMAND-LINE should include the pdb executable +name (`gud-pdb-command-name') and the file to be debugged. + +If called interactively, the command line will be prompted for. + +The directory containing this file becomes the initial working +directory and source-file directory for your debugger." (interactive (list (gud-query-cmdline 'pdb))) commit 7197fbebfc9660d2f21a0907289388019a169031 Author: Lars Ingebrigtsen Date: Fri Aug 2 14:16:25 2019 +0200 Mention that some dired commands work on the current file, too * lisp/dired-aux.el (dired-do-search): Mention that it works on file under point (bug#20194). (dired-do-find-regexp-and-replace): Ditto. (dired-do-find-regexp): Ditto. diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 20656a8fcc..6c06d841e7 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -2872,7 +2872,10 @@ is part of a file name (i.e., has the text property `dired-filename')." ;;;###autoload (defun dired-do-search (regexp) "Search through all marked files for a match for REGEXP. +If no files are marked, search through the file under point. + Stops when a match is found. + To continue searching for next match, use command \\[fileloop-continue]." (interactive "sSearch marked files (regexp): ") (fileloop-initialize-search @@ -2909,6 +2912,9 @@ with the command \\[tags-loop-continue]." ;;;###autoload (defun dired-do-find-regexp (regexp) "Find all matches for REGEXP in all marked files. + +If no files are marked, use the file under point. + For any marked directory, all of its files are searched recursively. However, files matching `grep-find-ignored-files' and subdirectories matching `grep-find-ignored-directories' are skipped in the marked @@ -2941,6 +2947,9 @@ REGEXP should use constructs supported by your local `grep' command." ;;;###autoload (defun dired-do-find-regexp-and-replace (from to) "Replace matches of FROM with TO, in all marked files. + +If no files are marked, use the file under point. + For any marked directory, matches in all of its files are replaced, recursively. However, files matching `grep-find-ignored-files' and subdirectories matching `grep-find-ignored-directories' are skipped commit 2ca12bb3de7f76446c102bb1e133f6ac03f7d8be Author: Alan Mackenzie Date: Fri Aug 2 11:24:38 2019 +0000 CC Mode: Fix the timing of application and removal of string fence properties This fixes bug #36897. * lisp/progmodes/cc-mode.el (c-before-change-check-unbalanced-strings): Check string fence text properties are actually present on string delimiters before trying to remove them. (c-before-change): Amend the nesting of unwind-protect, widen, c-restore-string-fences, and c-clear-string-fences. Move invalidate-state-cache to outside of the widening. (c-after-change): Amend the nesting of unwind-protect, widen, c-restore-string-fences, and c-clear-string-fences. diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index 5e373b6e17..60a9de5ddb 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -1426,8 +1426,11 @@ Note that the style variables are always made local to the buffer." (and c-multiline-string-start-char (not (c-characterp c-multiline-string-start-char)))) (when (and (eq end-literal-type 'string) - (not (eq (char-before (cdr end-limits)) ?\())) - (c-remove-string-fences (1- (cdr end-limits))) + (not (eq (char-before (cdr end-limits)) ?\()) + (memq (char-after (car end-limits)) c-string-delims) + (equal (c-get-char-property (car end-limits) 'syntax-table) + '(15))) + (c-remove-string-fences (car end-limits)) (setq c-new-END (max c-new-END (cdr end-limits)))) (when (and (eq beg-literal-type 'string) @@ -1864,12 +1867,12 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ;; property changes. (when (fboundp 'syntax-ppss) (setq c-syntax-table-hwm most-positive-fixnum)) - (unwind-protect - (progn - (c-restore-string-fences (point-min) (point-max)) - (save-restriction - (save-match-data - (widen) + (save-restriction + (save-match-data + (widen) + (unwind-protect + (progn + (c-restore-string-fences (point-min) (point-max)) (save-excursion ;; Are we inserting/deleting stuff in the middle of an ;; identifier? @@ -1896,8 +1899,8 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") 'font-lock-comment-face) (previous-single-property-change end 'face)) end))) - (when (>= end1 beg) ; Don't hassle about changes - ; entirely in comments. + (when (>= end1 beg) ; Don't hassle about changes entirely in + ; comments. ;; Find a limit for the search for a `c-type' property (while (and (/= (skip-chars-backward "^;{}") 0) @@ -1924,12 +1927,11 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (buffer-substring-no-properties (point) type-pos))) (goto-char end1) - (skip-chars-forward "^;{}") ;FIXME!!! loop for - ;comment, maybe + (skip-chars-forward "^;{}") ; FIXME!!! loop for + ; comment, maybe (setq lim (point)) (setq term-pos - (or (c-next-single-property-change end 'c-type nil lim) - lim)) + (or (c-next-single-property-change end 'c-type nil lim) lim)) (setq c-maybe-stale-found-type (list type marked-id type-pos term-pos @@ -1940,14 +1942,13 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (if c-get-state-before-change-functions (mapc (lambda (fn) (funcall fn beg end)) - c-get-state-before-change-functions)) - ))) - ;; The following must be done here rather than in - ;; `c-after-change' because newly inserted parens would foul - ;; up the invalidation algorithm. - (c-invalidate-state-cache beg) - (c-truncate-lit-pos-cache beg)) - (c-clear-string-fences)))) + c-get-state-before-change-functions)))) + (c-clear-string-fences)))) + (c-truncate-lit-pos-cache beg) + ;; The following must be done here rather than in `c-after-change' + ;; because newly inserted parens would foul up the invalidation + ;; algorithm. + (c-invalidate-state-cache beg))) (defvar c-in-after-change-fontification nil) (make-variable-buffer-local 'c-in-after-change-fontification) @@ -1991,19 +1992,17 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ;; When `combine-after-change-calls' is used we might get calls ;; with regions outside the current narrowing. This has been ;; observed in Emacs 20.7. - (unwind-protect - (progn - (c-restore-string-fences (point-min) (point-max)) - (save-restriction - (save-match-data ; c-recognize-<>-arglists changes match-data - (widen) - + (save-restriction + (save-match-data ; c-recognize-<>-arglists changes match-data + (widen) + (unwind-protect + (progn + (c-restore-string-fences (point-min) (point-max)) (when (> end (point-max)) - ;; Some emacsen might return positions past the - ;; end. This has been observed in Emacs 20.7 when - ;; rereading a buffer changed on disk (haven't been - ;; able to minimize it, but Emacs 21.3 appears to - ;; work). + ;; Some emacsen might return positions past the end. This + ;; has been observed in Emacs 20.7 when rereading a buffer + ;; changed on disk (haven't been able to minimize it, but + ;; Emacs 21.3 appears to work). (setq end (point-max)) (when (> beg end) (setq beg end))) @@ -2034,8 +2033,8 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (save-excursion (mapc (lambda (fn) (funcall fn beg end old-len)) - c-before-font-lock-functions))))) - (c-clear-string-fences)))) + c-before-font-lock-functions))) + (c-clear-string-fences)))))) ;; A workaround for syntax-ppss's failure to notice syntax-table text ;; property changes. (when (fboundp 'syntax-ppss) commit ccc52f1d97ad71f2af3f237168018180fa4f873f Author: Lars Ingebrigtsen Date: Fri Aug 2 12:44:31 2019 +0200 Use "rebinding keys" in the "Rebinding" section of the manual * doc/emacs/custom.texi (Rebinding): Use the term "rebinding keys" instead of "redefining keys", because the former seems more logical (bug#21036). diff --git a/doc/emacs/custom.texi b/doc/emacs/custom.texi index dda10adbe4..8fbc6c1ca0 100644 --- a/doc/emacs/custom.texi +++ b/doc/emacs/custom.texi @@ -1698,7 +1698,7 @@ They do not bind @key{SPC}. @node Rebinding @subsection Changing Key Bindings Interactively @cindex key rebinding, this session -@cindex redefining keys, this session +@cindex rebinding keys, this session @cindex binding keys The way to redefine an Emacs key is to change its entry in a keymap. commit 408e75e819f70ed47000bc31b34435a4bad33c0c Author: Mattias Engdegård Date: Mon Jul 22 17:10:37 2019 +0200 Clean up file-size-function It is now called `byte-count-to-string-function', and used instead of calling `file-size-human-readable' directly where appropriate. * lisp/files.el (file-size-human-readable-iec): New. (file-size-function): Rename to byte-count-to-string-function. Better default value. Eliminate lambda. Better default for custom choice. Put in group `files'. More descriptive doc string. Move. (out-of-memory-warning-percentage, warn-maybe-out-of-memory) (get-free-disk-space): * lisp/dired.el (dired-number-of-marked-files): * lisp/url/url-http.el (url-http-simple-after-change-function) (url-http-content-length-after-change-function): Use byte-count-to-string-function. * test/lisp/files-test.el (files-test-file-size-human-readable): Test file-size-human-readable-iec. diff --git a/etc/NEWS b/etc/NEWS index 486e677539..9be10b4e79 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -405,7 +405,8 @@ mode they are described in the manual "(emacs) Display". ** New variable 'xref-file-name-display' controls the display of file names in xref buffers. -** New variable 'file-size-function' controls how file sizes are displayed. +** New customizable variable 'byte-count-to-string-function'. +It is used for displaying file sizes and disk space in some cases. +++ ** Emacs now interprets RGB triplets like HTML, SVG, and CSS do. diff --git a/lisp/dired.el b/lisp/dired.el index 331e95a6cc..c31176972f 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -3642,12 +3642,12 @@ object files--just `.o' will mark more than you might think." sum (file-attribute-size (file-attributes file))))) (if (zerop nmarked) (message "No marked files")) - (message "%d marked file%s (%sB total size)" + (message "%d marked file%s (%s total size)" nmarked (if (= nmarked 1) "" "s") - (file-size-human-readable size)))) + (funcall byte-count-to-string-function size)))) (defun dired-mark-files-containing-regexp (regexp &optional marker-char) "Mark all files with contents containing REGEXP for use in later commands. diff --git a/lisp/files.el b/lisp/files.el index 184421f54f..009f52a3c6 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -1426,6 +1426,21 @@ in all cases, since that is the standard symbol for byte." (if (string= prefixed-unit "") "" (or space "")) prefixed-unit)))) +(defun file-size-human-readable-iec (size) + "Human-readable string for SIZE bytes, using IEC prefixes." + (file-size-human-readable size 'iec " ")) + +(defcustom byte-count-to-string-function #'file-size-human-readable-iec + "Function that turns a number of bytes into a human-readable string. +It is for use when displaying file sizes and disk space where other +constraints do not force a specific format." + :type '(radio + (function-item file-size-human-readable-iec) + (function-item file-size-human-readable) + (function :tag "Custom function" :value number-to-string)) + :group 'files + :version "27.1") + (defcustom mounted-file-systems (if (memq system-type '(windows-nt cygwin)) "^//[^/]+/" @@ -2093,7 +2108,7 @@ think it does, because \"free\" is pretty hard to define in practice." (defun files--ask-user-about-large-file (size op-type filename offer-raw) (let ((prompt (format "File %s is large (%s), really %s?" (file-name-nondirectory filename) - (file-size-human-readable size 'iec " ") op-type))) + (funcall byte-count-to-string-function size) op-type))) (if (not offer-raw) (if (y-or-n-p prompt) nil 'abort) (let* ((use-dialog (and (display-popup-menus-p) @@ -2145,10 +2160,10 @@ returns nil or exits non-locally." exceeds the %S%% of currently available free memory (%s). If that fails, try to open it with `find-file-literally' \(but note that some characters might be displayed incorrectly)." - (file-size-human-readable size 'iec " ") + (funcall byte-count-to-string-function size) out-of-memory-warning-percentage - (file-size-human-readable (* total-free-memory 1024) - 'iec " ")))))))) + (funcall byte-count-to-string-function + (* total-free-memory 1024))))))))) (defun files--message (format &rest args) "Like `message', except sometimes don't print to minibuffer. @@ -6705,22 +6720,13 @@ This variable is obsolete; Emacs no longer uses it." "ignored, as Emacs uses `file-system-info' instead" "27.1") -(defcustom file-size-function #'file-size-human-readable - "Function that transforms the number of bytes into a human-readable string." - :type `(radio - (function-item :tag "Default" file-size-human-readable) - (function-item :tag "IEC" - ,(lambda (size) (file-size-human-readable size 'iec " "))) - (function :tag "Custom function")) - :version "27.1") - (defun get-free-disk-space (dir) "String describing the amount of free space on DIR's file system. If DIR's free space cannot be obtained, this function returns nil." (save-match-data (let ((avail (nth 2 (file-system-info dir)))) (if avail - (funcall file-size-function avail))))) + (funcall byte-count-to-string-function avail))))) ;; The following expression replaces `dired-move-to-filename-regexp'. (defvar directory-listing-before-filename-regexp diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 838f0a30c1..9b690778fc 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -1025,7 +1025,7 @@ should be shown to the user." ;; Function used when we do NOT know how long the document is going to be ;; Just _very_ simple 'downloaded %d' type of info. (url-lazy-message "Reading %s..." - (file-size-human-readable (buffer-size) 'iec " "))) + (funcall byte-count-to-string-function (buffer-size)))) (defun url-http-content-length-after-change-function (_st nd _length) "Function used when we DO know how long the document is going to be. @@ -1038,16 +1038,16 @@ the callback to be triggered." (url-percentage (- nd url-http-end-of-headers) url-http-content-length) url-http-content-type - (file-size-human-readable (- nd url-http-end-of-headers) 'iec " ") - (file-size-human-readable url-http-content-length 'iec " ") + (funcall byte-count-to-string-function (- nd url-http-end-of-headers)) + (funcall byte-count-to-string-function url-http-content-length) (url-percentage (- nd url-http-end-of-headers) url-http-content-length)) (url-display-percentage "Reading... %s of %s (%d%%)" (url-percentage (- nd url-http-end-of-headers) url-http-content-length) - (file-size-human-readable (- nd url-http-end-of-headers) 'iec " ") - (file-size-human-readable url-http-content-length 'iec " ") + (funcall byte-count-to-string-function (- nd url-http-end-of-headers)) + (funcall byte-count-to-string-function url-http-content-length) (url-percentage (- nd url-http-end-of-headers) url-http-content-length))) diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index df2c3f47ae..ed23f7675c 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -1280,7 +1280,12 @@ renaming only, rather than modified in-place." (should (equal (file-size-human-readable 4294967296 'iec " ") "4 GiB")) (should (equal (file-size-human-readable 10000 nil " " "bit") "9.8 kbit")) (should (equal (file-size-human-readable 10000 'si " " "bit") "10 kbit")) - (should (equal (file-size-human-readable 10000 'iec " " "bit") "9.8 Kibit"))) + (should (equal (file-size-human-readable 10000 'iec " " "bit") "9.8 Kibit")) + + (should (equal (file-size-human-readable-iec 0) "0 B")) + (should (equal (file-size-human-readable-iec 1) "1 B")) + (should (equal (file-size-human-readable-iec 9621) "9.4 KiB")) + (should (equal (file-size-human-readable-iec 72528034765) "67.5 GiB"))) (ert-deftest files-test-magic-mode-alist-re-baseline () "Test magic-mode-alist with RE, expected behaviour for match." commit b49d987a8cf5f5dd7ba864e20995e21765eaefcf Author: Eli Zaretskii Date: Fri Aug 2 12:24:53 2019 +0300 Mention font-backend related crashes in PROBLEMS * etc/PROBLEMS: Mention the crash in the Cairo build when .emacs.desktop messes with font-backend. (Bug#36835) diff --git a/etc/PROBLEMS b/etc/PROBLEMS index 785e6e18af..2d56cc761a 100644 --- a/etc/PROBLEMS +++ b/etc/PROBLEMS @@ -45,6 +45,13 @@ following command may do the trick. See xrdb(1) for more information. $ xrdb -merge ~/.Xresources +** Emacs compiled with Cairo crashes when restoring session from desktop file. + +This can happen if the '.emacs.desktop' file contains setting for +'font-backend' frame parameter. A workaround is to delete the +offending '.emacs.desktop' file, or edit it to remove the setting of +'font-backend'. + ** Emacs aborts while starting up, only when run without X. This problem often results from compiling Emacs with GCC when GCC was commit fbd2ea1f73f3262636efacfe77ad33dc8a4d826f Author: Paul Eggert Date: Thu Aug 1 15:34:35 2019 -0700 Fix two parse-time-months invalid assumptions * lisp/gnus/nnimap.el: Do not require parse-time. * lisp/gnus/nnimap.el (nnimap-find-expired-articles): * lisp/net/pop3.el (pop3-make-date): Just use system-time-locale and format-time-string; no need to refer to parse-time-months. * lisp/net/pop3.el (parse-time-months): Remove defvar. * lisp/net/tramp-smb.el (tramp-smb-read-file-entry): Add FIXME comment about this. diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index c6eaa54c69..0c5aaf32d4 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -36,7 +36,6 @@ (require 'nnoo) (require 'netrc) (require 'utf7) -(require 'parse-time) (require 'nnmail) (autoload 'auth-source-forget+ "auth-source") @@ -1097,12 +1096,8 @@ textual parts.") (let ((result (nnimap-command "UID SEARCH SENTBEFORE %s" - (format-time-string - (format "%%d-%s-%%Y" - (upcase - (car (rassoc (decoded-time-month (decode-time cutoff)) - parse-time-months)))) - cutoff)))) + (let ((system-time-locale "C")) + (upcase (format-time-string "%d-%b-%Y" cutoff)))))) (and (car result) (delete 0 (mapcar #'string-to-number (cdr (assoc "SEARCH" (cdr result))))))))))) diff --git a/lisp/net/pop3.el b/lisp/net/pop3.el index ddb4139610..4bf50c0d22 100644 --- a/lisp/net/pop3.el +++ b/lisp/net/pop3.el @@ -35,7 +35,6 @@ (eval-when-compile (require 'cl-lib)) (require 'mail-utils) -(defvar parse-time-months) (defgroup pop3 nil "Post Office Protocol." @@ -609,18 +608,9 @@ Return the response string if optional second argument is non-nil." (defun pop3-make-date (&optional now) "Make a valid date header. If NOW, use that time instead." - (require 'parse-time) - (let* ((now (or now (current-time))) - (zone (decoded-time-zone (decode-time now)))) - (when (< zone 0) - (setq zone (- zone))) - (concat - (format-time-string "%d" now) - ;; The month name of the %b spec is locale-specific. Pfff. - (format " %s " - (capitalize (car (rassoc (decoded-time-month (decode-time now)) - parse-time-months)))) - (format-time-string "%Y %H:%M:%S %z" now)))) + ;; The month name of the %b spec is locale-specific. Pfff. + (let ((system-time-locale "C")) + (format-time-string "%d %b %Y %T %z" now))) (defun pop3-munge-message-separator (start end) "Check to see if a message separator exists. If not, generate one." diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 9b87ed40cb..568c6cb43a 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -1814,6 +1814,9 @@ Result is the list (LOCALNAME MODE SIZE MTIME)." (if (and sec min hour day month year) (encode-time sec min hour day + ;; FIXME: Won't this fail if parse-time-months is configured + ;; by the user? See "The date/time prompt" in the Org manual. + ;; If the code is OK as-is, perhaps explain why in a comment. (cdr (assoc (downcase month) parse-time-months)) year) tramp-time-dont-know)) commit 24b60b75ea544f0c2df740d40592c6665c123523 Author: Paul Eggert Date: Thu Aug 1 15:31:07 2019 -0700 Port standard-test-interval to Los Angeles * test/lisp/calendar/iso8601-tests.el (standard-test-interval): Use UTC to avoid DST glitches in the test. diff --git a/test/lisp/calendar/iso8601-tests.el b/test/lisp/calendar/iso8601-tests.el index 2959f54b81..35c319ed03 100644 --- a/test/lisp/calendar/iso8601-tests.el +++ b/test/lisp/calendar/iso8601-tests.el @@ -228,14 +228,14 @@ ;; A time interval starting at 20 minutes and 50 seconds past 23 ;; hours on 12 April 1985 and ending at 30 minutes past 10 hours on ;; 25 June 1985. - (should (equal (iso8601-parse-interval "19850412T232050/19850625T103000") - '((50 20 23 12 4 1985 nil nil nil) - (0 30 10 25 6 1985 nil nil nil) + (should (equal (iso8601-parse-interval "19850412T232050Z/19850625T103000Z") + '((50 20 23 12 4 1985 nil nil 0) + (0 30 10 25 6 1985 nil nil 0) (10 9 11 15 3 1970 0 nil 0)))) (should (equal (iso8601-parse-interval - "1985-04-12T23:20:50/1985-06-25T10:30:00") - '((50 20 23 12 4 1985 nil nil nil) - (0 30 10 25 6 1985 nil nil nil) + "1985-04-12T23:20:50Z/1985-06-25T10:30:00Z") + '((50 20 23 12 4 1985 nil nil 0) + (0 30 10 25 6 1985 nil nil 0) (10 9 11 15 3 1970 0 nil 0)))) ;; A time interval starting at 12 April 1985 and ending on 25 June commit 10dba8a1b8cb647d6adc1e4894ccc65f46435ee3 Author: Lars Ingebrigtsen Date: Fri Aug 2 00:15:13 2019 +0200 Document that --eval makes emacsclient ignore -n * doc/man/emacsclient.1: Mention that -n is ignored if --eval is given (bug#20524). diff --git a/doc/man/emacsclient.1 b/doc/man/emacsclient.1 index 24ca1c9a46..3bdaafbfc5 100644 --- a/doc/man/emacsclient.1 +++ b/doc/man/emacsclient.1 @@ -88,6 +88,7 @@ This can also be specified via the EMACS_SERVER_FILE environment variable. .B \-n, \-\-no-wait returns immediately without waiting for you to "finish" the buffer in Emacs. +If combined with --eval, this option is ignored. .TP .B \-nw, \-t, \-\-tty open a new Emacs frame on the current terminal commit 51cf2eb5c981b7e05a3329564753bcb61e4d5b07 Author: Lars Ingebrigtsen Date: Thu Aug 1 23:16:24 2019 +0200 Document batch-byte-compile directory behavior * lisp/emacs-lisp/bytecomp.el (batch-byte-compile): Document the behaviour with directories (bug#20867). diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 6dcd4c6846..40b4e2f467 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -5091,8 +5091,15 @@ it won't work in an interactive Emacs." "Run `byte-compile-file' on the files remaining on the command line. Use this from the command line, with `-batch'; it won't work in an interactive Emacs. -Each file is processed even if an error occurred previously. + +Each file is processed even if an error occurred previously. If +a file name denotes a directory, all Emacs Lisp source files in +that directory (that have previously been compiled) will be +recompiled if newer than the compiled files. In this case, +NOFORCE is ignored. + For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\". + If NOFORCE is non-nil, don't recompile a file that seems to be already up-to-date." ;; command-line-args-left is what is left of the command line, from commit 0a7e131ce46eec2b0e799d39cc0dc3d743897e60 Author: Stefan Monnier Date: Thu Aug 1 16:55:03 2019 -0400 * lisp/gnus/message.el (message-sendmail-f-is-evil): Update :version diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 30c5f7cbda..4900686b85 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -843,6 +843,7 @@ symbol `never', the posting is not allowed. If it is the symbol Doing so would be even more evil than leaving it out." :group 'message-sending :link '(custom-manual "(message)Mail Variables") + :version "27.1" :type 'boolean) (defcustom message-sendmail-envelope-from commit 688fec11430ded60e80cc689817e46db82e1b0eb Author: Lars Ingebrigtsen Date: Thu Aug 1 21:52:46 2019 +0200 Update URL in comment in gomoku.el * lisp/play/gomoku.el: Update the URL in the comments (bug#21300). diff --git a/lisp/play/gomoku.el b/lisp/play/gomoku.el index 6d5553b320..88c4ed96fa 100644 --- a/lisp/play/gomoku.el +++ b/lisp/play/gomoku.el @@ -36,7 +36,7 @@ ;; about the squares where one may play, or else there is a known forced win ;; for the first player. This program has no such restriction, but it does not ;; know about the forced win, nor do I. -;; See http://renju.nu/r1rulhis.htm for more information. +;; See http://renju.se/rif/r1rulhis.htm for more information. ;; There are two main places where you may want to customize the program: key commit fe939b36f901645e976bf016d8766c3a1300e45c Author: Lars Ingebrigtsen Date: Thu Aug 1 21:21:59 2019 +0200 Fix reference to `tags-loop-continue' in doc string * lisp/dired-aux.el (dired-do-search): Refer to `fileloop-continue' instead of the obsolete `tags-loop-continue' (bug#21475). diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 30a941c7bb..20656a8fcc 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -2873,7 +2873,7 @@ is part of a file name (i.e., has the text property `dired-filename')." (defun dired-do-search (regexp) "Search through all marked files for a match for REGEXP. Stops when a match is found. -To continue searching for next match, use command \\[tags-loop-continue]." +To continue searching for next match, use command \\[fileloop-continue]." (interactive "sSearch marked files (regexp): ") (fileloop-initialize-search regexp commit 10ffdabc372612fd60725cf092739cc1a6d4bdac Author: Lars Ingebrigtsen Date: Thu Aug 1 20:54:17 2019 +0200 Mention `C-h b' in the Keymaps node * doc/emacs/custom.texi (Keymaps): Mention `C-h b' here (bug#21653). diff --git a/doc/emacs/custom.texi b/doc/emacs/custom.texi index adea9351ea..dda10adbe4 100644 --- a/doc/emacs/custom.texi +++ b/doc/emacs/custom.texi @@ -1563,7 +1563,8 @@ self-inserting because the global keymap binds it to the command such as @kbd{C-a} also get their standard meanings from the global keymap. Commands to rebind keys, such as @kbd{M-x global-set-key}, work by storing the new binding in the proper place in the global map -(@pxref{Rebinding}). +(@pxref{Rebinding}). To view the current key bindings, use the +@kbd{C-h b} command. @cindex function key Most modern keyboards have function keys as well as character keys. commit afeb1e45b265d340cd856518da9a1b0a44fbe063 Author: Daniel Barrett Date: Thu Aug 1 19:47:43 2019 +0200 Add PDF to the DocBook notation class * etc/schema/dbnotn.rnc: PDF is among the document types accepted (bug#21882). Copyright-paperwork-exempt: yes diff --git a/etc/schema/dbnotn.rnc b/etc/schema/dbnotn.rnc index 2a6185f27f..10ecc53b18 100644 --- a/etc/schema/dbnotn.rnc +++ b/etc/schema/dbnotn.rnc @@ -65,6 +65,7 @@ notation.class = | "JPEG" | "IGES" | "PCX" + | "PDF" | "PIC" | "PNG" | "PS" commit 5b3b7da1684ac556f659c9187bab0d9f803b9097 Author: Lars Ingebrigtsen Date: Thu Aug 1 19:27:19 2019 +0200 Say that while returns nil * src/eval.c (Fwhile): Say that while always returns nil (bug#22006). diff --git a/src/eval.c b/src/eval.c index 2e5074360d..cb9eb37b56 100644 --- a/src/eval.c +++ b/src/eval.c @@ -991,6 +991,9 @@ DEFUN ("while", Fwhile, Swhile, 1, UNEVALLED, 0, doc: /* If TEST yields non-nil, eval BODY... and repeat. The order of execution is thus TEST, BODY, TEST, BODY and so on until TEST returns nil. + +The value of a `while' form is always nil. + usage: (while TEST BODY...) */) (Lisp_Object args) { commit e7c1fa96ba804d5b9462c626ddc26ccfef30a976 Author: Glenn Morris Date: Thu Aug 1 08:40:28 2019 -0700 * doc/lispref/display.texi (SVG Images): Add menu for subsection. Again. This is needed for makeinfo-4.13. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 7c0a56dcad..cd7eddcb01 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -5776,6 +5776,9 @@ circle: (insert-image (svg-image svg))) @end lisp +@menu +* SVG Path Commands:: +@end menu @subsubheading SVG Path Commands commit 3134137bdd2e73647ae19b92cc18d0743d2dbc1b Author: Eli Zaretskii Date: Thu Aug 1 17:21:22 2019 +0300 Fix the ELisp manual part of a recent commit * doc/lispref/display.texi (SVG Images): Fix markup of "SVG Path Commands". It is no longer a @node, but a @subheading. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 216d033242..7c0a56dcad 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -5777,8 +5777,13 @@ circle: @end lisp -@node SVG Path Commands -@subsubsection SVG Path Commands +@subsubheading SVG Path Commands + +@cindex svg path commands +@anchor{SVG Path Commands} +@dfn{SVG paths} allow creation of complex images by combining lines, +curves, arcs, and other basic shapes. The functions described below +allow invoking SVG path commands from a Lisp program. @deffn Command moveto points Move the pen to the first point in @var{points}. Additional points commit 1aa31b5f8911cc422644916c7652a90add7d5fd5 Author: Basil L. Contovounesios Date: Thu Aug 1 16:30:15 2019 +0300 Fix property stripping in image-file-yank-handler Fix proposed by Martin Rudalics in: https://lists.gnu.org/archive/html/emacs-devel/2008-12/msg00945.html * lisp/image-file.el (image-file-yank-handler): Handle case when yank-excluded-properties is t. diff --git a/lisp/image-file.el b/lisp/image-file.el index 26f16d1ed2..c1d44a7d6d 100644 --- a/lisp/image-file.el +++ b/lisp/image-file.el @@ -140,7 +140,9 @@ absolute file name and number of characters inserted." "Yank handler for inserting an image into a buffer." (let ((len (length string)) (image (get-text-property 0 'display string))) - (remove-list-of-text-properties 0 len yank-excluded-properties string) + (if (eq yank-excluded-properties t) + (set-text-properties 0 len () string) + (remove-list-of-text-properties 0 len yank-excluded-properties string)) (if (consp image) (add-text-properties 0 (or (next-single-property-change 0 'image-counter string) commit 2267110b6f00bbb0ad87f4621e6ecd9dc1bd8581 Author: Basil L. Contovounesios Date: Thu Aug 1 15:59:46 2019 +0300 Fix usage of remove-text-properties * lisp/allout-widgets.el (allout-decorate-item-icon): * lisp/emacs-lisp/chart.el (chart-goto-xy): * lisp/forms.el (forms--make-format) (forms--make-format-elt-using-text-properties): * lisp/htmlfontify.el (hfy-unmark-trailing-whitespace): * lisp/net/newst-plainview.el (newsticker-hide-entry) (newsticker-show-entry): * lisp/nxml/nxml-mode.el (nxml-cleanup): * lisp/obsolete/longlines.el (longlines-unshow-hard-newlines) (longlines-encode-region): * lisp/org/ob-exp.el (org-babel-exp-process-buffer): * lisp/org/org-agenda.el (org-agenda-show-new-time): * lisp/progmodes/cc-defs.el (c-clear-char-property-with-value-function) (c-clear-char-property-with-value-on-char-function): * lisp/progmodes/ebrowse.el (ebrowse--hide): * lisp/progmodes/gdb-mi.el (gdb-send): * lisp/progmodes/idlw-shell.el (idlwave-retrieve-expression-from-level): * lisp/progmodes/make-mode.el (makefile-fill-paragraph): * lisp/progmodes/prog-mode.el (prettify-symbols--post-command-hook): * lisp/progmodes/ruby-mode.el (ruby-syntax-propertize): * lisp/tmm.el (tmm-remove-inactive-mouse-face): Always pass an explicit plist to remove-text-properties. * lisp/dired.el (dired--unhide): * lisp/facemenu.el (facemenu-add-face): * lisp/htmlfontify.el (hfy-fontify-buffer): * lisp/iimage.el (iimage-mode-buffer): * lisp/image-file.el (image-file-yank-handler): * lisp/progmodes/prog-mode.el (prettify-symbols--compose-symbol): * lisp/textmodes/tex-mode.el (latex-env-before-change): * test/src/undo-tests.el (undo-test0): Use remove-list-of-text-properties in place of remove-text-properties where appropriate. diff --git a/lisp/allout-widgets.el b/lisp/allout-widgets.el index e7da08d44e..e4a8db8a62 100644 --- a/lisp/allout-widgets.el +++ b/lisp/allout-widgets.el @@ -1966,7 +1966,7 @@ reapplying this method will rectify the glyphs." ;; XXX we strip the prior properties without even checking if ;; the prior bullet was distinctive, because the widget ;; provisions to convey that info is disappearing, sigh. - (remove-text-properties icon-end (1+ icon-end) '(display)) + (remove-text-properties icon-end (1+ icon-end) '(display nil)) (setq distinctive-start icon-end distinctive-end icon-end) (widget-put item-widget :distinctive-start distinctive-start) (widget-put item-widget :distinctive-end distinctive-end)) diff --git a/lisp/dired.el b/lisp/dired.el index d47393b134..331e95a6cc 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -2560,7 +2560,7 @@ See options: `dired-hide-details-hide-symlink-targets' and ;; approximate ("anywhere on the line is fine"). ;; FIXME: This also removes other invisible properties! (save-excursion - (remove-text-properties + (remove-list-of-text-properties (progn (goto-char start) (line-end-position)) (progn (goto-char end) (line-end-position)) '(invisible)))) diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index 354830d911..124ede17fd 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -518,7 +518,7 @@ cons cells of the form (NAME . NUM). See `sort' for more details." (or (= (move-to-column x) x) (let ((p (point))) (indent-to x) - (remove-text-properties p (point) '(face)))))) + (remove-text-properties p (point) '(face nil)))))) (defun chart-zap-chars (n) "Zap up to N chars without deleting EOLs." diff --git a/lisp/facemenu.el b/lisp/facemenu.el index 44b3941b24..c582fc8b28 100644 --- a/lisp/facemenu.el +++ b/lisp/facemenu.el @@ -732,7 +732,7 @@ effect. See `facemenu-remove-face-function'." (if facemenu-remove-face-function (funcall facemenu-remove-face-function start end) (if (and start (< start end)) - (remove-text-properties start end '(face default)) + (remove-list-of-text-properties start end '(face)) (facemenu-set-self-insert-face 'default)))) (facemenu-add-face-function (save-excursion diff --git a/lisp/forms.el b/lisp/forms.el index a85ee94c1a..149b967573 100644 --- a/lisp/forms.el +++ b/lisp/forms.el @@ -933,7 +933,7 @@ Commands: Equivalent keys in read-only mode: '(front-sticky (read-only cursor-intangible))))) ;; Prevent insertion after the last text. (remove-text-properties (1- (point)) (point) - '(rear-nonsticky))) + '(rear-nonsticky nil))) (setq forms--iif-start nil)) `(lambda (arg) ,@(apply 'append @@ -998,7 +998,7 @@ Commands: Equivalent keys in read-only mode: ;; '(front-sticky (read-only)))))) ;; ;; Prevent insertion after the last text. ;; (remove-text-properties (1- (point)) (point) - ;; '(rear-nonsticky))) + ;; '(rear-nonsticky nil))) ;; ;; ;; wrap up ;; (setq forms--iif-start nil) diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el index dfba025742..b8442be1e8 100644 --- a/lisp/htmlfontify.el +++ b/lisp/htmlfontify.el @@ -1589,7 +1589,7 @@ Do not record undo information during evaluation of BODY." (when show-trailing-whitespace (hfy-save-buffer-state nil (remove-text-properties (point-min) (point-max) - '(hfy-show-trailing-whitespace))))) + '(hfy-show-trailing-whitespace nil))))) (defun hfy-begin-span (style text-block text-id text-begins-block-p) "Default handler to begin a span of text. @@ -1677,7 +1677,8 @@ FILE, if set, is the file name." (copy-to-buffer html-buffer (point-min) (point-max)) (set-buffer html-buffer) ;; rip out props that could interfere with our htmlization of the buffer: - (remove-text-properties (point-min) (point-max) hfy-ignored-properties) + (remove-list-of-text-properties (point-min) (point-max) + hfy-ignored-properties) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; at this point, html-buffer retains the fontification of the parent: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/lisp/iimage.el b/lisp/iimage.el index 3b5006491a..b2ee3da783 100644 --- a/lisp/iimage.el +++ b/lisp/iimage.el @@ -138,8 +138,9 @@ Examples of image filename patterns to match: keymap ,image-map modification-hooks (iimage-modification-hook))) - (remove-text-properties (match-beginning 0) (match-end 0) - '(display modification-hooks)))))))))) + (remove-list-of-text-properties + (match-beginning 0) (match-end 0) + '(display modification-hooks)))))))))) ;;;###autoload (define-minor-mode iimage-mode nil diff --git a/lisp/image-file.el b/lisp/image-file.el index 6cadc42110..26f16d1ed2 100644 --- a/lisp/image-file.el +++ b/lisp/image-file.el @@ -140,7 +140,7 @@ absolute file name and number of characters inserted." "Yank handler for inserting an image into a buffer." (let ((len (length string)) (image (get-text-property 0 'display string))) - (remove-text-properties 0 len yank-excluded-properties string) + (remove-list-of-text-properties 0 len yank-excluded-properties string) (if (consp image) (add-text-properties 0 (or (next-single-property-change 0 'image-counter string) diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el index 4f5c729dd0..58bca31aba 100644 --- a/lisp/net/newst-plainview.el +++ b/lisp/net/newst-plainview.el @@ -1002,7 +1002,7 @@ not get changed." ;; toggle (add-text-properties pos1 pos2 (list 'invisible org-inv-prop)) - (remove-text-properties pos1 pos2 '(org-invisible)))))) + (remove-text-properties pos1 pos2 '(org-invisible nil)))))) (newsticker--buffer-redraw)) (defun newsticker-show-entry () @@ -1028,7 +1028,7 @@ not get changed." ;; toggle (add-text-properties pos1 pos2 (list 'invisible org-inv-prop)) - (remove-text-properties pos1 pos2 '(org-invisible)))))) + (remove-text-properties pos1 pos2 '(org-invisible nil)))))) (newsticker--buffer-redraw)) (defun newsticker-toggle-auto-narrow-to-feed () diff --git a/lisp/nxml/nxml-mode.el b/lisp/nxml/nxml-mode.el index 623a666662..7d770e6163 100644 --- a/lisp/nxml/nxml-mode.el +++ b/lisp/nxml/nxml-mode.el @@ -561,7 +561,7 @@ Many aspects this mode can be customized using (widen) (with-silent-modifications (nxml-with-invisible-motion - (remove-text-properties (point-min) (point-max) '(face))))) + (remove-text-properties (point-min) (point-max) '(face nil))))) (remove-hook 'change-major-mode-hook #'nxml-cleanup t)) (defun nxml-degrade (context err) diff --git a/lisp/obsolete/longlines.el b/lisp/obsolete/longlines.el index 30c6f35e7b..5ad7f66899 100644 --- a/lisp/obsolete/longlines.el +++ b/lisp/obsolete/longlines.el @@ -248,7 +248,7 @@ With optional argument ARG, make the hard newlines invisible again." (inhibit-modification-hooks t) buffer-file-name buffer-file-truename) (while pos - (remove-text-properties pos (1+ pos) '(display)) + (remove-text-properties pos (1+ pos) '(display nil)) (setq pos (text-property-not-all (1+ pos) (point-max) 'hard nil))) (restore-buffer-modified-p mod))) @@ -387,7 +387,7 @@ compatibility with `format-alist', and is ignored." (goto-char (1+ pos)) (insert-and-inherit " ") (delete-region pos (1+ pos)) - (remove-text-properties pos (1+ pos) 'hard)))) + (remove-text-properties pos (1+ pos) '(hard nil))))) (set-buffer-modified-p mod) end))) diff --git a/lisp/org/ob-exp.el b/lisp/org/ob-exp.el index bf5796405f..4a5bff82ae 100644 --- a/lisp/org/ob-exp.el +++ b/lisp/org/ob-exp.el @@ -282,7 +282,8 @@ this template." (set-marker begin nil) (set-marker end nil))))) (kill-buffer org-babel-exp-reference-buffer) - (remove-text-properties (point-min) (point-max) '(org-reference))))))) + (remove-text-properties (point-min) (point-max) + '(org-reference nil))))))) (defun org-babel-exp-do-export (info type &optional hash) "Return a string with the exported content of a code block. diff --git a/lisp/org/org-agenda.el b/lisp/org/org-agenda.el index 23ee8d71e6..a6195cfb2a 100644 --- a/lisp/org/org-agenda.el +++ b/lisp/org/org-agenda.el @@ -9230,7 +9230,7 @@ Called with a universal prefix arg, show the priority instead of setting it." (goto-char (point-max)) (while (not (bobp)) (when (equal marker (org-get-at-bol 'org-marker)) - (remove-text-properties (point-at-bol) (point-at-eol) '(display)) + (remove-text-properties (point-at-bol) (point-at-eol) '(display nil)) (org-move-to-column (- (window-width) (length stamp)) t) (add-text-properties (1- (point)) (point-at-eol) diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el index ab3e25b226..34f47debb1 100644 --- a/lisp/progmodes/cc-defs.el +++ b/lisp/progmodes/cc-defs.el @@ -1291,7 +1291,7 @@ been put there by c-put-char-property. POINT remains unchanged." (when (and (fboundp 'syntax-ppss) (eq property 'syntax-table)) (setq c-syntax-table-hwm (min c-syntax-table-hwm place))) (setq end-place (c-next-single-property-change place property nil to)) - (remove-text-properties place end-place (cons property nil)) + (remove-text-properties place end-place (list property nil)) ;; Do we have to do anything with stickiness here? (setq place end-place)))) @@ -1375,7 +1375,7 @@ property, or nil." (setq place (c-next-single-property-change place property nil to))) (< place to)) (when (eq (char-after place) char) - (remove-text-properties place (1+ place) (cons property nil)) + (remove-text-properties place (1+ place) (list property nil)) (or first (progn (setq first place) (when (eq property 'syntax-table) diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el index 3faec4959b..733e373582 100644 --- a/lisp/progmodes/ebrowse.el +++ b/lisp/progmodes/ebrowse.el @@ -1383,7 +1383,7 @@ Pop to member buffer if no prefix ARG, to tree buffer otherwise." (defun ebrowse--unhide (start end) ;; FIXME: This also removes other invisible properties! - (remove-text-properties start end '(invisible))) + (remove-text-properties start end '(invisible nil))) ;;; Misc tree buffer commands diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index 15d47575c7..439e0dfc62 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -1794,7 +1794,7 @@ commands to be prefixed by \"-interpreter-exec console\".") "A comint send filter for gdb." (with-current-buffer gud-comint-buffer (let ((inhibit-read-only t)) - (remove-text-properties (point-min) (point-max) '(face)))) + (remove-text-properties (point-min) (point-max) '(face nil)))) ;; mimic key to repeat previous command in GDB (when (= gdb-control-level 0) (if (not (string= "" string)) diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el index 3bd99620d0..188ec012cf 100644 --- a/lisp/progmodes/idlw-shell.el +++ b/lisp/progmodes/idlw-shell.el @@ -3120,7 +3120,7 @@ versions of IDL." fetch-start start) (setq fetch-end (next-single-property-change fetch-start 'fetch expr))) (unless fetch-end (setq fetch-end (length expr))) - (remove-text-properties fetch-start fetch-end '(fetch) expr) + (remove-text-properties fetch-start fetch-end '(fetch nil) expr) (setq expr (concat (substring expr 0 fetch-start) (format "(routine_names('%s',fetch=%d))" (substring expr fetch-start fetch-end) diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el index cffb749c3e..54292b5d39 100644 --- a/lisp/progmodes/make-mode.el +++ b/lisp/progmodes/make-mode.el @@ -1313,7 +1313,7 @@ Fill comments, backslashed lines, and variable definitions specially." ;; which back-to-indentation (called via fill-newline -> ;; fill-indent-to-left-margin -> indent-line-to) thinks are real code ;; (bug#13179). - (remove-text-properties (point-min) (point-max) '(syntax-table)) + (remove-text-properties (point-min) (point-max) '(syntax-table nil)) (let ((fill-paragraph-function nil) ;; Adjust fill-column to allow space for the backslash. (fill-column (- fill-column 1))) diff --git a/lisp/progmodes/prog-mode.el b/lisp/progmodes/prog-mode.el index 79fe56aebb..cb39e62265 100644 --- a/lisp/progmodes/prog-mode.el +++ b/lisp/progmodes/prog-mode.el @@ -138,9 +138,10 @@ Regexp match data 0 specifies the characters to be composed." ;; No composition for you. Let's actually remove any ;; composition we may have added earlier and which is now ;; incorrect. - (remove-text-properties start end '(composition - prettify-symbols-start - prettify-symbols-end)))) + (remove-list-of-text-properties start end + '(composition + prettify-symbols-start + prettify-symbols-end)))) ;; Return nil because we're not adding any face property. nil) @@ -191,7 +192,7 @@ on the symbol." (e (apply #'max e))) (with-silent-modifications (setq prettify-symbols--current-symbol-bounds (list s e)) - (remove-text-properties s e '(composition)))))) + (remove-text-properties s e '(composition nil)))))) ;;;###autoload (define-minor-mode prettify-symbols-mode diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el index 340c689f02..69acc7a394 100644 --- a/lisp/progmodes/ruby-mode.el +++ b/lisp/progmodes/ruby-mode.el @@ -1858,7 +1858,7 @@ It will be properly highlighted even when the call omits parens.") "Syntactic keywords for Ruby mode. See `syntax-propertize-function'." (let (case-fold-search) (goto-char start) - (remove-text-properties start end '(ruby-expansion-match-data)) + (remove-text-properties start end '(ruby-expansion-match-data nil)) (ruby-syntax-propertize-heredoc end) (ruby-syntax-enclosing-percent-literal end) (funcall diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index 91c580adec..f277defecf 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -729,7 +729,7 @@ automatically inserts its partner." (condition-case err (with-silent-modifications ;; Remove properties even if don't find a pair. - (remove-text-properties + (remove-list-of-text-properties (previous-single-property-change (1+ start) 'latex-env-pair) (next-single-property-change start 'latex-env-pair) '(latex-env-pair)) diff --git a/lisp/tmm.el b/lisp/tmm.el index 44f04eab87..bf76652f40 100644 --- a/lisp/tmm.el +++ b/lisp/tmm.el @@ -378,7 +378,7 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'." (while (not (eobp)) (setq next (next-single-char-property-change (point) 'mouse-face)) (when (looking-at inactive-string) - (remove-text-properties (point) next '(mouse-face)) + (remove-text-properties (point) next '(mouse-face nil)) (add-text-properties (point) next '(face tmm-inactive))) (goto-char next))) (set-buffer-modified-p nil))) diff --git a/test/src/undo-tests.el b/test/src/undo-tests.el index b84f5a5847..8395ba9909 100644 --- a/test/src/undo-tests.el +++ b/test/src/undo-tests.el @@ -72,7 +72,7 @@ (undo-boundary) (put-text-property (point-min) (point-max) 'face 'bold) (undo-boundary) - (remove-text-properties (point-min) (point-max) '(face default)) + (remove-list-of-text-properties (point-min) (point-max) '(face)) (undo-boundary) (set-buffer-multibyte (not enable-multibyte-characters)) (undo-boundary) commit 6a77aa4a2c34e6edee06c9831687927543c75391 Author: Glenn Morris Date: Thu Aug 1 06:26:06 2019 -0700 ; Auto-commit of loaddefs files. diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index ab235f6c7b..e925adbb11 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -61,6 +61,7 @@ should return a grid vector array that is the new solution. ;;;### (autoloads nil "ada-mode" "progmodes/ada-mode.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/ada-mode.el +(push (purecopy '(ada-mode 4 0)) package--builtin-versions) (autoload 'ada-add-extensions "ada-mode" "\ Define SPEC and BODY as being valid extensions for Ada files. @@ -1498,7 +1499,7 @@ Features a private abbrev table and the following bindings: \\[asm-colon] outdent a preceding label, tab to next tab stop. \\[tab-to-tab-stop] tab to next tab stop. -\\[asm-newline] newline, then tab to next tab stop. +\\[newline-and-indent] newline, then tab to next tab stop. \\[asm-comment] smart placement of assembler comments. The character used for making comments is set by the variable @@ -4455,6 +4456,12 @@ Any character in STRING that has an entry in `char-fold-table' is replaced with that entry (which is a regexp) and other characters are `regexp-quote'd. +When LAX is non-nil, then the final character also matches ligatures +partially, for instance, the search string \"f\" will match \"fi\", +so when typing the search string in isearch while the cursor is on +a ligature, the search won't try to immediately advance to the next +complete match, but will stay on the partially matched ligature. + If the resulting regexp would be too long for Emacs to handle, just return the result of calling `regexp-quote' on STRING. @@ -5098,13 +5105,18 @@ Returns the (possibly newly created) process buffer. \(fn NAME PROGRAM &optional STARTFILE &rest SWITCHES)" nil nil) (autoload 'comint-run "comint" "\ -Run PROGRAM in a Comint buffer and switch to it. +Run PROGRAM in a Comint buffer and switch to that buffer. + +If SWITCHES are supplied, they are passed to PROGRAM. With prefix argument +\\[universal-argument] prompt for SWITCHES as well as PROGRAM. + The buffer name is made by surrounding the file name of PROGRAM with `*'s. The file name is used to make a symbol name, such as `comint-sh-hook', and any hooks on this symbol are run in the buffer. + See `make-comint' and `comint-exec'. -\(fn PROGRAM)" t nil) +\(fn PROGRAM &optional SWITCHES)" t nil) (function-put 'comint-run 'interactive-only 'make-comint) @@ -5238,8 +5250,9 @@ Otherwise, it saves all modified buffers without asking.") (defvar compilation-search-path '(nil) "\ List of directories to search for source files named in error messages. -Elements should be directory names, not file names of directories. -The value nil as an element means to try the default directory.") +Elements should be directory names, not file names of +directories. The value nil as an element means the error +message buffer `default-directory'.") (custom-autoload 'compilation-search-path "compile" t) @@ -6811,11 +6824,31 @@ Prettify all columns in a text region. START and END delimit the text region. +If you have, for example, the following columns: + + a b c d + aaaa bb ccc ddddd + +Depending on your settings (see below), you then obtain the +following result: + + [ a , b , c , d ] + [ aaaa, bb , ccc , ddddd ] + +See the `delimit-columns-str-before', +`delimit-columns-str-after', `delimit-columns-str-separator', +`delimit-columns-before', `delimit-columns-after', +`delimit-columns-separator', `delimit-columns-format' and +`delimit-columns-extra' variables for customization of the +look. + \(fn START END)" t nil) (autoload 'delimit-columns-rectangle "delim-col" "\ Prettify all columns in a text rectangle. +See `delimit-columns-region' for what this entails. + START and END delimit the corners of the text rectangle. \(fn START END)" t nil) @@ -6864,9 +6897,9 @@ information on adapting behavior of commands in Delete Selection mode. ;;; Generated autoloads from emacs-lisp/derived.el (autoload 'define-derived-mode "derived" "\ -Create a new mode as a variant of an existing mode. +Create a new mode CHILD which is a variant of an existing mode PARENT. -The arguments to this command are as follow: +The arguments are as follows: CHILD: the name of the command for the derived mode. PARENT: the name of the command for the parent mode (e.g. `text-mode') @@ -6874,24 +6907,28 @@ PARENT: the name of the command for the parent mode (e.g. `text-mode') NAME: a string which will appear in the status line (e.g. \"Hypertext\") DOCSTRING: an optional documentation string--if you do not supply one, the function will attempt to invent something useful. +KEYWORD-ARGS: + optional arguments in the form of pairs of keyword and value. + The following keyword arguments are currently supported: + + :group GROUP + Declare the customization group that corresponds + to this mode. The command `customize-mode' uses this. + :syntax-table TABLE + Use TABLE instead of the default (CHILD-syntax-table). + A nil value means to simply use the same syntax-table + as the parent. + :abbrev-table TABLE + Use TABLE instead of the default (CHILD-abbrev-table). + A nil value means to simply use the same abbrev-table + as the parent. + :after-hook FORM + A single lisp form which is evaluated after the mode + hooks have been run. It should not be quoted. + BODY: forms to execute just before running the hooks for the new mode. Do not use `interactive' here. -BODY can start with a bunch of keyword arguments. The following keyword - arguments are currently understood: -:group GROUP - Declare the customization group that corresponds to this mode. - The command `customize-mode' uses this. -:syntax-table TABLE - Use TABLE instead of the default (CHILD-syntax-table). - A nil value means to simply use the same syntax-table as the parent. -:abbrev-table TABLE - Use TABLE instead of the default (CHILD-abbrev-table). - A nil value means to simply use the same abbrev-table as the parent. -:after-hook FORM - A single lisp form which is evaluated after the mode hooks have been - run. It should not be quoted. - Here is how you could define LaTeX-Thesis mode as a variant of LaTeX mode: (define-derived-mode LaTeX-thesis-mode LaTeX-mode \"LaTeX-Thesis\") @@ -6900,7 +6937,7 @@ You could then make new key bindings for `LaTeX-thesis-mode-map' without changing regular LaTeX mode. In this example, BODY is empty, and DOCSTRING is generated by default. -On a more complicated level, the following command uses `sgml-mode' as +As a more complex example, the following command uses `sgml-mode' as the parent, and then sets the variable `case-fold-search' to nil: (define-derived-mode article-mode sgml-mode \"Article\" @@ -6915,7 +6952,7 @@ The new mode runs the hook constructed by the function See Info node `(elisp)Derived Modes' for more details. -\(fn CHILD PARENT NAME &optional DOCSTRING &rest BODY)" nil t) +\(fn CHILD PARENT NAME [DOCSTRING] [KEYWORD-ARGS...] &rest BODY)" nil t) (function-put 'define-derived-mode 'doc-string-elt '4) @@ -12279,14 +12316,11 @@ DELIMITED if non-nil means replace only word-delimited matches. ;;; Generated autoloads from filenotify.el (autoload 'file-notify-handle-event "filenotify" "\ -Handle file system monitoring event. -If EVENT is a filewatch event, call its callback. It has the format - - (file-notify (DESCRIPTOR ACTIONS FILE [FILE1-OR-COOKIE]) CALLBACK) - +Handle a file system monitoring event, coming from backends. +If OBJECT is a filewatch event, call its callback. Otherwise, signal a `file-notify-error'. -\(fn EVENT)" t nil) +\(fn OBJECT)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "filenotify" '("file-notify-"))) @@ -12831,7 +12865,7 @@ to get the effect of a C-q. ;;;### (autoloads nil "flymake" "progmodes/flymake.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/flymake.el -(push (purecopy '(flymake 1 0 6)) package--builtin-versions) +(push (purecopy '(flymake 1 0 8)) package--builtin-versions) (autoload 'flymake-log "flymake" "\ Log, at level LEVEL, the message MSG formatted with ARGS. @@ -14242,6 +14276,13 @@ Pop up a frame and enter GROUP. \(fn GROUP)" t nil) +(autoload 'gnus-read-ephemeral-emacs-bug-group "gnus-group" "\ +Browse Emacs bug reports with IDS in an ephemeral group. +The arguments have the same meaning as those of +`gnus-read-ephemeral-bug-group', which see. + +\(fn IDS &optional WINDOW-CONF)" t nil) + (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus-group" '("gnus-"))) ;;;*** @@ -14349,7 +14390,7 @@ group parameters. If AUTO-UPDATE is non-nil (prefix argument accepted, if called interactively), it makes sure nnmail-split-fancy is re-computed before getting new mail, by adding `gnus-group-split-update' to -`nnmail-pre-get-new-mail-hook'. +`gnus-get-top-new-news-hook'. A non-nil CATCH-ALL replaces the current value of `gnus-group-split-default-catch-all-group'. This variable is only used @@ -14821,13 +14862,17 @@ if ARG is `toggle'; disable the mode otherwise. ;;; Generated autoloads from image/gravatar.el (autoload 'gravatar-retrieve "gravatar" "\ -Retrieve MAIL-ADDRESS gravatar and call CB on retrieval. -You can provide a list of argument to pass to CB in CBARGS. +Asynchronously retrieve a gravatar for MAIL-ADDRESS. +When finished, call CB as (apply CB GRAVATAR CBARGS), +where GRAVATAR is either an image descriptor, or the symbol +`error' if the retrieval failed. \(fn MAIL-ADDRESS CB &optional CBARGS)" nil nil) (autoload 'gravatar-retrieve-synchronously "gravatar" "\ -Retrieve MAIL-ADDRESS gravatar and returns it. +Synchronously retrieve a gravatar for MAIL-ADDRESS. +Value is either an image descriptor, or the symbol `error' if the +retrieval failed. \(fn MAIL-ADDRESS)" nil nil) @@ -15862,7 +15907,11 @@ See `hi-lock-mode' for more information on Hi-Lock mode. (defalias 'highlight-lines-matching-regexp 'hi-lock-line-face-buffer) (autoload 'hi-lock-line-face-buffer "hi-lock" "\ -Set face of all lines containing a match of REGEXP to FACE. +Highlight all lines that match REGEXP using FACE. +The lines that match REGEXP will be displayed by merging +the attributes of FACE with any other face attributes +of text in those lines. + Interactively, prompt for REGEXP using `read-regexp', then FACE. Use the global history list for FACE. @@ -18401,6 +18450,13 @@ Add submenus to the File menu, to convert to and from various formats." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "iso-transl" '("iso-transl-"))) +;;;*** + +;;;### (autoloads nil "iso8601" "calendar/iso8601.el" (0 0 0 0)) +;;; Generated autoloads from calendar/iso8601.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "iso8601" '("iso8601-"))) + ;;;*** ;;;### (autoloads nil "ispell" "textmodes/ispell.el" (0 0 0 0)) @@ -19196,7 +19252,7 @@ Special commands: ;;;### (autoloads nil "let-alist" "emacs-lisp/let-alist.el" (0 0 ;;;;;; 0 0)) ;;; Generated autoloads from emacs-lisp/let-alist.el -(push (purecopy '(let-alist 1 0 5)) package--builtin-versions) +(push (purecopy '(let-alist 1 0 6)) package--builtin-versions) (autoload 'let-alist "let-alist" "\ Let-bind dotted symbols to their cdrs in ALIST and execute BODY. @@ -19801,10 +19857,12 @@ Return the value of the header field whose type is FIELD-NAME. If second arg LAST is non-nil, use the last field of type FIELD-NAME. If third arg ALL is non-nil, concatenate all such fields with commas between. If 4th arg LIST is non-nil, return a list of all such fields. +If 5th arg DELETE is non-nil, delete all header lines that are +included in the result. The buffer should be narrowed to just the header, else false matches may be returned from the message body. -\(fn FIELD-NAME &optional LAST ALL LIST)" nil nil) +\(fn FIELD-NAME &optional LAST ALL LIST DELETE)" nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "mail-utils" '("mail-"))) @@ -21652,15 +21710,6 @@ language environment LANG-ENV. \(fn FROM TO LANG-ENV)" nil nil) -(autoload 'char-displayable-p "mule-util" "\ -Return non-nil if we should be able to display CHAR. -On a multi-font display, the test is only whether there is an -appropriate font from the selected frame's fontset to display -CHAR's charset in general. Since fonts may be specified on a -per-character basis, this may not be accurate. - -\(fn CHAR)" nil nil) - (autoload 'filepos-to-bufferpos "mule-util" "\ Try to return the buffer position corresponding to a particular file position. The file position is given as a (0-based) BYTE count. @@ -22866,7 +22915,7 @@ startup file, `~/.emacs-octave'. ;;;### (autoloads nil "opascal" "progmodes/opascal.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/opascal.el -(define-obsolete-function-alias 'delphi-mode 'opascal-mode "24.4") +(define-obsolete-function-alias 'delphi-mode #'opascal-mode "24.4") (autoload 'opascal-mode "opascal" "\ Major mode for editing OPascal code.\\ @@ -24156,6 +24205,21 @@ The return value is a string (or nil in case we can't find it)." nil nil) ;;;;;; 0 0)) ;;; Generated autoloads from emacs-lisp/package-x.el +(autoload 'package-upload-file "package-x" "\ +Upload the Emacs Lisp package FILE to the package archive. +Interactively, prompt for FILE. The package is considered a +single-file package if FILE ends in \".el\", and a multi-file +package if FILE ends in \".tar\". +Automatically extract package attributes and update the archive's +contents list with this information. +If `package-archive-upload-base' does not specify a valid upload +destination, prompt for one. If the directory does not exist, it +is created. The directory need not have any initial contents +\(i.e., you can use this command to populate an initially empty +archive). + +\(fn FILE)" t nil) + (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "package-x" '("package-"))) ;;;*** @@ -27914,327 +27978,102 @@ becomes just a more verbose version of STRING. (autoload 'rx "rx" "\ Translate regular expressions REGEXPS in sexp form to a regexp string. -REGEXPS is a non-empty sequence of forms of the sort listed below. - -Note that `rx' is a Lisp macro; when used in a Lisp program being -compiled, the translation is performed by the compiler. The -`literal' and `regexp' forms accept subforms that will evaluate -to strings, in addition to constant strings. If REGEXPS include -such forms, then the result is an expression which returns a -regexp string, rather than a regexp string directly. See -`rx-to-string' for performing translation completely at run time. - -The following are valid subforms of regular expressions in sexp -notation. - -STRING - matches string STRING literally. - -CHAR - matches character CHAR literally. - -`not-newline', `nonl' - matches any character except a newline. - -`anything' - matches any character - -`(any SET ...)' -`(in SET ...)' -`(char SET ...)' - matches any character in SET .... SET may be a character or string. - Ranges of characters can be specified as `A-Z' in strings. - Ranges may also be specified as conses like `(?A . ?Z)'. - Reversed ranges like `Z-A' and `(?Z . ?A)' are not permitted. - - SET may also be the name of a character class: `digit', - `control', `hex-digit', `blank', `graph', `print', `alnum', - `alpha', `ascii', `nonascii', `lower', `punct', `space', `upper', - `word', or one of their synonyms. - -`(not (any SET ...))' - matches any character not in SET ... - -`line-start', `bol' - matches the empty string, but only at the beginning of a line - in the text being matched - -`line-end', `eol' - is similar to `line-start' but matches only at the end of a line - -`string-start', `bos', `bot' - matches the empty string, but only at the beginning of the - string being matched against. - -`string-end', `eos', `eot' - matches the empty string, but only at the end of the - string being matched against. - -`buffer-start' - matches the empty string, but only at the beginning of the - buffer being matched against. Actually equivalent to `string-start'. - -`buffer-end' - matches the empty string, but only at the end of the - buffer being matched against. Actually equivalent to `string-end'. - -`point' - matches the empty string, but only at point. - -`word-start', `bow' - matches the empty string, but only at the beginning of a word. - -`word-end', `eow' - matches the empty string, but only at the end of a word. - -`word-boundary' - matches the empty string, but only at the beginning or end of a - word. - -`(not word-boundary)' -`not-word-boundary' - matches the empty string, but not at the beginning or end of a - word. - -`symbol-start' - matches the empty string, but only at the beginning of a symbol. - -`symbol-end' - matches the empty string, but only at the end of a symbol. - -`digit', `numeric', `num' - matches 0 through 9. - -`control', `cntrl' - matches any character whose code is in the range 0-31. - -`hex-digit', `hex', `xdigit' - matches 0 through 9, a through f and A through F. - -`blank' - matches horizontal whitespace, as defined by Annex C of the - Unicode Technical Standard #18. In particular, it matches - spaces, tabs, and other characters whose Unicode - `general-category' property indicates they are spacing - separators. - -`graphic', `graph' - matches graphic characters--everything except whitespace, ASCII - and non-ASCII control characters, surrogates, and codepoints - unassigned by Unicode. - -`printing', `print' - matches whitespace and graphic characters. - -`alphanumeric', `alnum' - matches alphabetic characters and digits. For multibyte characters, - it matches characters whose Unicode `general-category' property - indicates they are alphabetic or decimal number characters. - -`letter', `alphabetic', `alpha' - matches alphabetic characters. For multibyte characters, - it matches characters whose Unicode `general-category' property - indicates they are alphabetic characters. - -`ascii' - matches ASCII (unibyte) characters. - -`nonascii' - matches non-ASCII (multibyte) characters. - -`lower', `lower-case' - matches anything lower-case, as determined by the current case - table. If `case-fold-search' is non-nil, this also matches any - upper-case letter. - -`upper', `upper-case' - matches anything upper-case, as determined by the current case - table. If `case-fold-search' is non-nil, this also matches any - lower-case letter. - -`punctuation', `punct' - matches punctuation. (But at present, for multibyte characters, - it matches anything that has non-word syntax.) - -`space', `whitespace', `white' - matches anything that has whitespace syntax. - -`word', `wordchar' - matches anything that has word syntax. - -`not-wordchar' - matches anything that has non-word syntax. - -`(syntax SYNTAX)' - matches a character with syntax SYNTAX. SYNTAX must be one - of the following symbols, or a symbol corresponding to the syntax - character, e.g. `\\.' for `\\s.'. - - `whitespace' (\\s- in string notation) - `punctuation' (\\s.) - `word' (\\sw) - `symbol' (\\s_) - `open-parenthesis' (\\s() - `close-parenthesis' (\\s)) - `expression-prefix' (\\s') - `string-quote' (\\s\") - `paired-delimiter' (\\s$) - `escape' (\\s\\) - `character-quote' (\\s/) - `comment-start' (\\s<) - `comment-end' (\\s>) - `string-delimiter' (\\s|) - `comment-delimiter' (\\s!) - -`(not (syntax SYNTAX))' - matches a character that doesn't have syntax SYNTAX. - -`(category CATEGORY)' - matches a character with category CATEGORY. CATEGORY must be - either a character to use for C, or one of the following symbols. - - `space-for-indent' (\\c\\s in string notation) - `base' (\\c.) - `consonant' (\\c0) - `base-vowel' (\\c1) - `upper-diacritical-mark' (\\c2) - `lower-diacritical-mark' (\\c3) - `tone-mark' (\\c4) - `symbol' (\\c5) - `digit' (\\c6) - `vowel-modifying-diacritical-mark' (\\c7) - `vowel-sign' (\\c8) - `semivowel-lower' (\\c9) - `not-at-end-of-line' (\\c<) - `not-at-beginning-of-line' (\\c>) - `alpha-numeric-two-byte' (\\cA) - `chinese-two-byte' (\\cC) - `greek-two-byte' (\\cG) - `japanese-hiragana-two-byte' (\\cH) - `indian-two-byte' (\\cI) - `japanese-katakana-two-byte' (\\cK) - `strong-left-to-right' (\\cL) - `korean-hangul-two-byte' (\\cN) - `strong-right-to-left' (\\cR) - `cyrillic-two-byte' (\\cY) - `combining-diacritic' (\\c^) - `ascii' (\\ca) - `arabic' (\\cb) - `chinese' (\\cc) - `ethiopic' (\\ce) - `greek' (\\cg) - `korean' (\\ch) - `indian' (\\ci) - `japanese' (\\cj) - `japanese-katakana' (\\ck) - `latin' (\\cl) - `lao' (\\co) - `tibetan' (\\cq) - `japanese-roman' (\\cr) - `thai' (\\ct) - `vietnamese' (\\cv) - `hebrew' (\\cw) - `cyrillic' (\\cy) - `can-break' (\\c|) - -`(not (category CATEGORY))' - matches a character that doesn't have category CATEGORY. - -`(and SEXP1 SEXP2 ...)' -`(: SEXP1 SEXP2 ...)' -`(seq SEXP1 SEXP2 ...)' -`(sequence SEXP1 SEXP2 ...)' - matches what SEXP1 matches, followed by what SEXP2 matches, etc. - Without arguments, matches the empty string. - -`(submatch SEXP1 SEXP2 ...)' -`(group SEXP1 SEXP2 ...)' - like `and', but makes the match accessible with `match-end', - `match-beginning', and `match-string'. - -`(submatch-n N SEXP1 SEXP2 ...)' -`(group-n N SEXP1 SEXP2 ...)' - like `group', but make it an explicitly-numbered group with - group number N. - -`(or SEXP1 SEXP2 ...)' -`(| SEXP1 SEXP2 ...)' - matches anything that matches SEXP1 or SEXP2, etc. If all - args are strings, use `regexp-opt' to optimize the resulting - regular expression. Without arguments, never matches anything. - -`(minimal-match SEXP)' - produce a non-greedy regexp for SEXP. Normally, regexps matching - zero or more occurrences of something are \"greedy\" in that they - match as much as they can, as long as the overall regexp can - still match. A non-greedy regexp matches as little as possible. - -`(maximal-match SEXP)' - produce a greedy regexp for SEXP. This is the default. - -Below, `SEXP ...' represents a sequence of regexp forms, treated as if -enclosed in `(and ...)'. - -`(zero-or-more SEXP ...)' -`(0+ SEXP ...)' - matches zero or more occurrences of what SEXP ... matches. - -`(* SEXP ...)' - like `zero-or-more', but always produces a greedy regexp, independent - of `rx-greedy-flag'. - -`(*? SEXP ...)' - like `zero-or-more', but always produces a non-greedy regexp, - independent of `rx-greedy-flag'. - -`(one-or-more SEXP ...)' -`(1+ SEXP ...)' - matches one or more occurrences of SEXP ... - -`(+ SEXP ...)' - like `one-or-more', but always produces a greedy regexp. - -`(+? SEXP ...)' - like `one-or-more', but always produces a non-greedy regexp. - -`(zero-or-one SEXP ...)' -`(optional SEXP ...)' -`(opt SEXP ...)' - matches zero or one occurrences of A. - -`(? SEXP ...)' - like `zero-or-one', but always produces a greedy regexp. - -`(?? SEXP ...)' - like `zero-or-one', but always produces a non-greedy regexp. - -`(repeat N SEXP)' -`(= N SEXP ...)' - matches N occurrences. - -`(>= N SEXP ...)' - matches N or more occurrences. - -`(repeat N M SEXP)' -`(** N M SEXP ...)' - matches N to M occurrences. - -`(backref N)' - matches what was matched previously by submatch N. - -`(literal STRING-EXPR)' - matches STRING-EXPR literally, where STRING-EXPR is any lisp - expression that evaluates to a string. - -`(regexp REGEXP-EXPR)' - include REGEXP-EXPR in string notation in the result, where - REGEXP-EXPR is any lisp expression that evaluates to a - string containing a valid regexp. - -`(eval FORM)' - evaluate FORM and insert result. If result is a string, - `regexp-quote' it. Note that FORM is evaluated during - macroexpansion. +Each argument is one of the forms below; RX is a subform, and RX... stands +for one or more RXs. For details, see Info node `(elisp) Rx Notation'. +See `rx-to-string' for the corresponding function. + +STRING Match a literal string. +CHAR Match a literal character. + +\(seq RX...) Match the RXs in sequence. Alias: :, sequence, and. +\(or RX...) Match one of the RXs. Alias: |. + +\(zero-or-more RX...) Match RXs zero or more times. Alias: 0+. +\(one-or-more RX...) Match RXs one or more times. Alias: 1+. +\(zero-or-one RX...) Match RXs or the empty string. Alias: opt, optional. +\(* RX...) Match RXs zero or more times; greedy. +\(+ RX...) Match RXs one or more times; greedy. +\(? RX...) Match RXs or the empty string; greedy. +\(*? RX...) Match RXs zero or more times; non-greedy. +\(+? RX...) Match RXs one or more times; non-greedy. +\(?? RX...) Match RXs or the empty string; non-greedy. +\(= N RX...) Match RXs exactly N times. +\(>= N RX...) Match RXs N or more times. +\(** N M RX...) Match RXs N to M times. Alias: repeat. +\(minimal-match RX) Match RX, with zero-or-more, one-or-more, zero-or-one + and aliases using non-greedy matching. +\(maximal-match RX) Match RX, with zero-or-more, one-or-more, zero-or-one + and aliases using greedy matching, which is the default. + +\(any SET...) Match a character from one of the SETs. Each SET is a + character, a string, a range as string \"A-Z\" or cons + (?A . ?Z), or a character class (see below). Alias: in, char. +\(not CHARSPEC) Match one character not matched by CHARSPEC. CHARSPEC + can be (any ...), (syntax ...), (category ...), + or a character class. +not-newline Match any character except a newline. Alias: nonl. +anything Match any character. + +CHARCLASS Match a character from a character class. One of: + alpha, alphabetic, letter Alphabetic characters (defined by Unicode). + alnum, alphanumeric Alphabetic or decimal digit chars (Unicode). + digit numeric, num 0-9. + xdigit, hex-digit, hex 0-9, A-F, a-f. + cntrl, control ASCII codes 0-31. + blank Horizontal whitespace (Unicode). + space, whitespace, white Chars with whitespace syntax. + lower, lower-case Lower-case chars, from current case table. + upper, upper-case Upper-case chars, from current case table. + graph, graphic Graphic characters (Unicode). + print, printing Whitespace or graphic (Unicode). + punct, punctuation Not control, space, letter or digit (ASCII); + not word syntax (non-ASCII). + word, wordchar Characters with word syntax. + ascii ASCII characters (codes 0-127). + nonascii Non-ASCII characters (but not raw bytes). + +\(syntax SYNTAX) Match a character with syntax SYNTAX, being one of: + whitespace, punctuation, word, symbol, open-parenthesis, + close-parenthesis, expression-prefix, string-quote, + paired-delimiter, escape, character-quote, comment-start, + comment-end, string-delimiter, comment-delimiter + +\(category CAT) Match a character in category CAT, being one of: + space-for-indent, base, consonant, base-vowel, + upper-diacritical-mark, lower-diacritical-mark, tone-mark, symbol, + digit, vowel-modifying-diacritical-mark, vowel-sign, + semivowel-lower, not-at-end-of-line, not-at-beginning-of-line, + alpha-numeric-two-byte, chinese-two-byte, greek-two-byte, + japanese-hiragana-two-byte, indian-two-byte, + japanese-katakana-two-byte, strong-left-to-right, + korean-hangul-two-byte, strong-right-to-left, cyrillic-two-byte, + combining-diacritic, ascii, arabic, chinese, ethiopic, greek, + korean, indian, japanese, japanese-katakana, latin, lao, + tibetan, japanese-roman, thai, vietnamese, hebrew, cyrillic, + can-break + +Zero-width assertions: these all match the empty string in specific places. + line-start At the beginning of a line. Alias: bol. + line-end At the end of a line. Alias: eol. + string-start At the start of the string or buffer. + Alias: buffer-start, bos, bot. + string-end At the end of the string or buffer. + Alias: buffer-end, eos, eot. + point At point. + word-start At the beginning of a word. + word-end At the end of a word. + word-boundary At the beginning or end of a word. + not-word-boundary Not at the beginning or end of a word. + symbol-start At the beginning of a symbol. + symbol-end At the end of a symbol. + +\(group RX...) Match RXs and define a capture group. Alias: submatch. +\(group-n N RX...) Match RXs and define capture group N. Alias: submatch-n. +\(backref N) Match the text that capture group N matched. + +\(literal EXPR) Match the literal string from evaluating EXPR at run time. +\(regexp EXPR) Match the string regexp from evaluating EXPR at run time. +\(eval EXPR) Match the rx sexp from evaluating EXPR at compile time. \(fn &rest REGEXPS)" nil t) @@ -29218,7 +29057,7 @@ Otherwise, let mailer send back a message to report errors.") (custom-autoload 'mail-interactive "sendmail" t) -(defvar send-mail-function (if (and (boundp 'smtpmail-smtp-server) smtpmail-smtp-server) 'smtpmail-send-it 'sendmail-query-once) "\ +(defvar send-mail-function (if (and (boundp 'smtpmail-smtp-server) smtpmail-smtp-server) #'smtpmail-send-it #'sendmail-query-once) "\ Function to call to send the current buffer as mail. The headers should be delimited by a line which is not a valid RFC 822 (or later) header or continuation line, @@ -29338,7 +29177,7 @@ before you edit the message, so you can edit or delete the lines.") Query for `send-mail-function' and send mail with it. This also saves the value of `send-mail-function' via Customize." nil nil) -(define-mail-user-agent 'sendmail-user-agent 'sendmail-user-agent-compose 'mail-send-and-exit) +(define-mail-user-agent 'sendmail-user-agent #'sendmail-user-agent-compose #'mail-send-and-exit) (autoload 'sendmail-user-agent-compose "sendmail" "\ @@ -30245,6 +30084,116 @@ then `snmpv2-mode-hook'." t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "snmp-mode" '("snmp"))) +;;;*** + +;;;### (autoloads nil "so-long" "so-long.el" (0 0 0 0)) +;;; Generated autoloads from so-long.el +(push (purecopy '(so-long 1 0)) package--builtin-versions) + +(autoload 'so-long-commentary "so-long" "\ +View the so-long documentation in `outline-mode'." t nil) + +(autoload 'so-long-customize "so-long" "\ +Open the so-long `customize' group." t nil) + +(autoload 'so-long-minor-mode "so-long" "\ +This is the minor mode equivalent of `so-long-mode'. + +If called interactively, enable So-Long minor mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + +Any active minor modes listed in `so-long-minor-modes' are disabled for the +current buffer, and buffer-local values are assigned to variables in accordance +with `so-long-variable-overrides'. + +This minor mode is a standard `so-long-action' option. + +\(fn &optional ARG)" t nil) + +(autoload 'so-long-mode "so-long" "\ +This major mode is the default `so-long-action' option. + +The normal reason for this mode being active is that `global-so-long-mode' is +enabled, and `so-long-predicate' has detected that the file contains long lines. + +Many Emacs modes struggle with buffers which contain excessively long lines, +and may consequently cause unacceptable performance issues. + +This is commonly on account of 'minified' code (i.e. code has been compacted +into the smallest file size possible, which often entails removing newlines +should they not be strictly necessary). These kinds of files are typically +not intended to be edited, so not providing the usual editing mode in these +cases will rarely be an issue. + +This major mode disables any active minor modes listed in `so-long-minor-modes' +for the current buffer, and buffer-local values are assigned to variables in +accordance with `so-long-variable-overrides'. + +To restore the original major mode (along with the minor modes and variable +values), despite potential performance issues, type \\[so-long-revert]. + +Use \\[so-long-commentary] for more information. + +Use \\[so-long-customize] to configure the behaviour. + +\(fn)" t nil) + +(autoload 'so-long "so-long" "\ +Invoke `so-long-action' and run `so-long-hook'. + +This command is called automatically when long lines are detected, when +`global-so-long-mode' is enabled. + +The effects of the action can be undone by calling `so-long-revert'. + +If ACTION is provided, it is used instead of `so-long-action'. With a prefix +argument, select the action to use interactively. + +\(fn &optional ACTION)" t nil) + +(autoload 'so-long-enable "so-long" "\ +Enable the so-long library's functionality. + +Equivalent to calling (global-so-long-mode 1)" t nil) + +(defvar global-so-long-mode nil "\ +Non-nil if Global So-Long mode is enabled. +See the `global-so-long-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `global-so-long-mode'.") + +(custom-autoload 'global-so-long-mode "so-long" nil) + +(autoload 'global-so-long-mode "so-long" "\ +Toggle automated performance mitigations for files with long lines. + +If called interactively, enable Global So-Long mode if ARG is positive, and +disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it +if ARG is `toggle'; disable the mode otherwise. + +Many Emacs modes struggle with buffers which contain excessively long lines, +and may consequently cause unacceptable performance issues. + +This is commonly on account of 'minified' code (i.e. code that has been +compacted into the smallest file size possible, which often entails removing +newlines should they not be strictly necessary). + +When such files are detected by `so-long-predicate', we invoke the selected +`so-long-action' to mitigate potential performance problems in the buffer. + +Use \\[so-long-commentary] for more information. + +Use \\[so-long-customize] to configure the behaviour. + +\(fn &optional ARG)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "so-long" '("so-long-" "turn-o"))) + ;;;*** ;;;### (autoloads nil "soap-client" "net/soap-client.el" (0 0 0 0)) @@ -32433,14 +32382,21 @@ Start a terminal-emulator for a serial port in a new buffer. PORT is the path or name of the serial port. For example, this could be \"/dev/ttyS0\" on Unix. On Windows, this could be \"COM1\" or \"\\\\.\\COM10\". + SPEED is the speed of the serial port in bits per second. 9600 is a common value. SPEED can be nil, see `serial-process-configure' for details. + +Usually `term-char-mode' is used, but if LINE-MODE (the prefix +when used interactively) is non-nil, `term-line-mode' is used +instead. + The buffer is in Term mode; see `term-mode' for the commands to use in that buffer. + \\Type \\[switch-to-buffer] to switch to another buffer. -\(fn PORT SPEED)" t nil) +\(fn PORT SPEED &optional LINE-MODE)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "term" '("ansi-term-color-vector" "explicit-shell-file-name" "serial-" "term-"))) @@ -33381,7 +33337,7 @@ Convert the time interval in seconds to a short string. \(fn DELAY)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "time-date" '("encode-time-value" "seconds-to-string" "time-" "with-decoded-time-value"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "time-date" '("date-" "decoded-time-" "encode-time-value" "seconds-to-string" "time-" "with-decoded-time-value"))) ;;;*** @@ -33837,7 +33793,7 @@ the output buffer or changing the window configuration. ;;;### (autoloads nil "tramp" "net/tramp.el" (0 0 0 0)) ;;; Generated autoloads from net/tramp.el -(push (purecopy '(tramp 2 4 2)) package--builtin-versions) +(push (purecopy '(tramp 2 4 3 -1)) package--builtin-versions) (defvar tramp-mode t "\ Whether Tramp is enabled. @@ -35512,6 +35468,19 @@ When called interactively with a prefix argument, prompt for REMOTE-LOCATION. \(fn &optional REMOTE-LOCATION)" t nil) +(autoload 'vc-log-search "vc" "\ +Search the log of changes for PATTERN. + +PATTERN is usually interpreted as a regular expression. However, its +exact semantics is up to the backend's log search command; some can +only match fixed strings. + +Display all entries that match log messages in long format. +With a prefix argument, ask for a command to run that will output +log entries. + +\(fn PATTERN)" t nil) + (autoload 'vc-log-mergebase "vc" "\ Show a log of changes between the merge base of REV1 and REV2 revisions. The merge base is a common ancestor between REV1 and REV2 revisions. @@ -35943,6 +35912,7 @@ Key bindings: ;;;### (autoloads nil "verilog-mode" "progmodes/verilog-mode.el" ;;;;;; (0 0 0 0)) ;;; Generated autoloads from progmodes/verilog-mode.el +(push (purecopy '(verilog-mode 2019 6 21 103209889)) package--builtin-versions) (autoload 'verilog-mode "verilog-mode" "\ Major mode for editing Verilog code. @@ -36824,8 +36794,8 @@ also enable the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'; disable the mode otherwise. When View mode is enabled, commands that do not change the buffer -contents are available as usual. Kill commands insert text in -kill buffers but do not delete. Most other commands beep and +contents are available as usual. Kill commands save text but +do not delete it from the buffer. Most other commands beep and tell the user that the buffer is read-only. \\ commit 0148fc73538e2dccb586abe80ba48fdaf2041ca7 Author: Glenn Morris Date: Thu Aug 1 06:08:11 2019 -0700 ; Auto-commit of loaddefs files. diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index bb9991873d..99c4f86e6f 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -69,6 +69,7 @@ should return a grid vector array that is the new solution. ;;;### (autoloads nil "ada-mode" "progmodes/ada-mode.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/ada-mode.el +(push (purecopy '(ada-mode 4 0)) package--builtin-versions) (autoload 'ada-add-extensions "ada-mode" "\ Define SPEC and BODY as being valid extensions for Ada files. @@ -15194,13 +15195,17 @@ Like `goto-address-mode', but only for comments and strings. ;;; Generated autoloads from image/gravatar.el (autoload 'gravatar-retrieve "gravatar" "\ -Retrieve MAIL-ADDRESS gravatar and call CB on retrieval. -You can provide a list of argument to pass to CB in CBARGS. +Asynchronously retrieve a gravatar for MAIL-ADDRESS. +When finished, call CB as (apply CB GRAVATAR CBARGS), +where GRAVATAR is either an image descriptor, or the symbol +`error' if the retrieval failed. \(fn MAIL-ADDRESS CB &optional CBARGS)" nil nil) (autoload 'gravatar-retrieve-synchronously "gravatar" "\ -Retrieve MAIL-ADDRESS gravatar and returns it. +Synchronously retrieve a gravatar for MAIL-ADDRESS. +Value is either an image descriptor, or the symbol `error' if the +retrieval failed. \(fn MAIL-ADDRESS)" nil nil) @@ -16256,7 +16261,11 @@ See `hi-lock-mode' for more information on Hi-Lock mode. (defalias 'highlight-lines-matching-regexp 'hi-lock-line-face-buffer) (autoload 'hi-lock-line-face-buffer "hi-lock" "\ -Set face of all lines containing a match of REGEXP to FACE. +Highlight all lines that match REGEXP using FACE. +The lines that match REGEXP will be displayed by merging +the attributes of FACE with any other face attributes +of text in those lines. + Interactively, prompt for REGEXP using `read-regexp', then FACE. Use the global history list for FACE. @@ -32308,6 +32317,7 @@ and `sc-post-hook' is run after the guts of this function. ;;;### (autoloads nil "svg" "svg.el" (0 0 0 0)) ;;; Generated autoloads from svg.el +(push (purecopy '(svg 0 5)) package--builtin-versions) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "svg" '("svg-"))) @@ -36595,6 +36605,7 @@ Key bindings: ;;;### (autoloads nil "verilog-mode" "progmodes/verilog-mode.el" ;;;;;; (0 0 0 0)) ;;; Generated autoloads from progmodes/verilog-mode.el +(push (purecopy '(verilog-mode 2017 8 7 201875024)) package--builtin-versions) (autoload 'verilog-mode "verilog-mode" "\ Major mode for editing Verilog code. @@ -37478,8 +37489,8 @@ and disable it otherwise. If called from Lisp, enable View mode if ARG is omitted or nil. When View mode is enabled, commands that do not change the buffer -contents are available as usual. Kill commands insert text in -kill buffers but do not delete. Most other commands beep and +contents are available as usual. Kill commands save text but +do not delete it from the buffer. Most other commands beep and tell the user that the buffer is read-only. \\ commit 716f8cb1f93473189ace3c5165936bd836792af0 Author: Lars Ingebrigtsen Date: Thu Aug 1 14:48:09 2019 +0200 Doc string clarification for defcustom * lisp/custom.el (defcustom): Mention `custom-declare-variable' in the doc string(bug#22703). diff --git a/lisp/custom.el b/lisp/custom.el index 736460fec7..9bd9712b65 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -336,6 +336,11 @@ to load a file defining variables with this form, or with _outside_ any bindings for these variables. (`defvar' and `defconst' behave similarly in this respect.) +This macro calls `custom-declare-variable'. If you want to +programmatically alter a customizable variable (for instance, to +write a package that extends the syntax of a variable), you can +call that functcion directly. + See Info node `(elisp) Customization' in the Emacs Lisp manual for more information." (declare (doc-string 3) (debug (name body))) commit 75690d7fac331744eda76a4b23c36a74ff9bcb07 Author: Lars Ingebrigtsen Date: Thu Aug 1 13:59:01 2019 +0200 Make `C-u RET' in erc use the secondary browser * lisp/erc/erc-button.el (erc-button-alist): Use the version of `browse-url' that interprets `C-u RET' as using the secondary browser. diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index c2702081da..726d9674d4 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -133,8 +133,8 @@ longer than `erc-fill-column'." ;; bytecompiling lambdas in this alist. On the other hand, it makes ;; things hard to maintain. '(('nicknames 0 erc-button-buttonize-nicks erc-nick-popup 0) - (erc-button-url-regexp 0 t browse-url 0) - (" ]+\\) *>" 0 t browse-url 1) + (erc-button-url-regexp 0 t browse-url-button-open-url 0) + (" ]+\\) *>" 0 t browse-url-button-open-url 1) ;;; ("(\\(\\([^~\n \t@][^\n \t@]*\\)@\\([a-zA-Z0-9.:-]+\\)\\)" 1 t finger 2 3) ;; emacs internal ("[`]\\([a-zA-Z][-a-zA-Z_0-9]+\\)[']" 1 t erc-button-describe-symbol 1) commit 70a2f2b09a902e0408aa0b640d0c2e1e5dcc6216 Author: Lars Ingebrigtsen Date: Thu Aug 1 13:48:08 2019 +0200 Use decoded-time accessors in vc-cvs * lisp/vc/vc-cvs.el (vc-cvs-parse-entry): Use decoded-time accessors for results from `parse-time-string'. diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el index 6fb5fa09c7..b33a106f3a 100644 --- a/lisp/vc/vc-cvs.el +++ b/lisp/vc/vc-cvs.el @@ -1180,7 +1180,7 @@ is non-nil." (parsed-time (progn (require 'parse-time) (parse-time-string (concat time " +0000"))))) (cond ((and (not (string-match "\\+" time)) - (car parsed-time) + (decoded-time-second parsed-time) ;; Compare just the seconds part of the file time, ;; since CVS file time stamp resolution is just 1 second. (= (encode-time mtime 'integer) commit 3001c6eaa878db9e384bfcb499fe483a0dad7430 Author: Lars Ingebrigtsen Date: Thu Aug 1 13:47:04 2019 +0200 Use decoded-time accessors in gnus-demon * lisp/gnus/gnus-demon.el (gnus-demon-time-to-step): Use decoded-time accessors for results from `parse-time-string'. diff --git a/lisp/gnus/gnus-demon.el b/lisp/gnus/gnus-demon.el index b26aaa1529..6007e18f55 100644 --- a/lisp/gnus/gnus-demon.el +++ b/lisp/gnus/gnus-demon.el @@ -173,8 +173,8 @@ marked with SPECIAL." (nowParts (decode-time now)) ;; obtain THEN as discrete components (thenParts (parse-time-string time)) - (thenHour (elt thenParts 2)) - (thenMin (elt thenParts 1)) + (thenHour (decoded-time-hour thenParts)) + (thenMin (decoded-time-minute thenParts)) ;; convert time as elements into number of seconds since EPOCH. (then (encode-time 0 commit 9b49afd287f4220d8a3e3ecbf83f3f0dc3745a0a Author: Lars Ingebrigtsen Date: Thu Aug 1 13:46:28 2019 +0200 Use decoded-time accessors in esh-util * lisp/eshell/esh-util.el (eshell-parse-ange-ls): Use decoded-time accessors for results from `parse-time-string'. diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index 082403130d..353b9400f2 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -647,12 +647,12 @@ If NOSORT is non-nil, the list is not sorted--its order is unpredictable. (name (ange-ftp-parse-filename)) (mtime (let ((moment (parse-time-string (match-string 6)))) - (if (nth 0 moment) - (setcar (nthcdr 5 moment) - (decoded-time-year (decode-time))) - (setcar (nthcdr 0 moment) 0) - (setcar (nthcdr 1 moment) 0) - (setcar (nthcdr 2 moment) 0)) + (if (decoded-time-second moment) + (setf (decoded-time-year moment) + (decoded-time-year (decode-time))) + (setf (decoded-time-second moment) 0) + (setf (decoded-time-minute moment) 0) + (setf (decoded-time-hour moment) 0)) (encode-time moment))) symlink) (if (string-match "\\(.+\\) -> \\(.+\\)" name) commit 5bccff7b5ba3529de29e12de151eb4bfb5859e08 Author: Lars Ingebrigtsen Date: Thu Aug 1 13:38:41 2019 +0200 Remove some compat code in esh-util * lisp/eshell/esh-util.el (eshell-parse-ange-ls): Remove older-Emacs compat code. diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index 4835e63baa..082403130d 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -600,10 +600,7 @@ If NOSORT is non-nil, the list is not sorted--its order is unpredictable. (setq host-users (cdr host-users)) (cdr (assoc user host-users)))))) -;; Add an autoload for parse-time-string -(if (and (not (fboundp 'parse-time-string)) - (locate-library "parse-time")) - (autoload 'parse-time-string "parse-time")) +(autoload 'parse-time-string "parse-time") (eval-when-compile (require 'ange-ftp nil t)) ; ange-ftp-parse-filename @@ -649,17 +646,14 @@ If NOSORT is non-nil, the list is not sorted--its order is unpredictable. (size (string-to-number (match-string 5))) (name (ange-ftp-parse-filename)) (mtime - (if (fboundp 'parse-time-string) - (let ((moment (parse-time-string - (match-string 6)))) - (if (nth 0 moment) - (setcar (nthcdr 5 moment) - (decoded-time-year (decode-time))) - (setcar (nthcdr 0 moment) 0) - (setcar (nthcdr 1 moment) 0) - (setcar (nthcdr 2 moment) 0)) - (encode-time moment)) - (ange-ftp-file-modtime (expand-file-name name dir)))) + (let ((moment (parse-time-string (match-string 6)))) + (if (nth 0 moment) + (setcar (nthcdr 5 moment) + (decoded-time-year (decode-time))) + (setcar (nthcdr 0 moment) 0) + (setcar (nthcdr 1 moment) 0) + (setcar (nthcdr 2 moment) 0)) + (encode-time moment))) symlink) (if (string-match "\\(.+\\) -> \\(.+\\)" name) (setq symlink (match-string 2 name) commit 3c31775527acbd3c4fdf47d01b8db28e7d78ecd3 Author: Basil L. Contovounesios Date: Thu Aug 1 14:07:18 2019 +0300 ; Use more decoded time accessors in time-date.el These were overlooked in a recent change. * lisp/calendar/time-date.el (time-date--day-in-year): Use decoded time accessors. diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index 32ba128689..5b82b8ab0f 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -216,9 +216,9 @@ DATE1 and DATE2 should be date-time strings." (defun time-date--day-in-year (tim) "Return the day number within the year corresponding to the decoded time TIM." - (let* ((month (nth 4 tim)) - (day (nth 3 tim)) - (year (nth 5 tim)) + (let* ((month (decoded-time-month tim)) + (day (decoded-time-day tim)) + (year (decoded-time-year tim)) (day-of-year (+ day (* 31 (1- month))))) (when (> month 2) (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10))) commit b22b59c77bf15edd4b4fa1969ce0e20402de1104 Author: Martin Rudalics Date: Thu Aug 1 09:56:44 2019 +0200 Add example for removing scroll bars/fringes from mini windows (Bug#8868) * doc/lispref/display.texi (Fringe Size/Pos): Mention example for how to permenantly remove fringes from minibuffer windows. (Scroll Bars): Add example for how to permanently remove scroll bars and fringes from minibuffer windows. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 7c27b3897b..216d033242 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -3983,7 +3983,9 @@ with its @var{keep-margins} argument @code{nil} or omitted. However, if the optional fifth argument @var{persistent} is non-@code{nil} and the other arguments are processed successfully, the values specified here unconditionally survive subsequent invocations of -@code{set-window-buffer}. +@code{set-window-buffer}. This can be used to permanently turn off +fringes in the minibuffer window, consult the description of +@code{set-window-scroll-bars} for an example (@pxref{Scroll Bars}). @end defun @defun window-fringes &optional window @@ -4418,6 +4420,23 @@ here unconditionally survive subsequent invocations of @code{set-window-buffer}. @end defun +Using the @var{persistent} argument of @code{set-window-scroll-bars} +and @code{set-window-fringes} (@pxref{Fringe Size/Pos}) you can +reliably and permanently turn off scroll bars and/or fringes in any +minibuffer window by adding the following snippet to your early init +file (@pxref{Init File}). + +@smallexample +@group +(add-hook 'after-make-frame-functions + (lambda (frame) + (set-window-scroll-bars + (minibuffer-window frame) 0 nil 0 nil t) + (set-window-fringes + (minibuffer-window frame) 0 0 nil t))) +@end group +@end smallexample + The following four functions take as argument a live window which defaults to the selected one. commit f8f1c8c33a0a8fa117bf06e3b34865dea48eb6a1 Author: Paul Eggert Date: Wed Jul 31 19:21:50 2019 -0700 format-time-string subsumes time-zone-format * lisp/calendar/time-date.el (time-zone-format): * test/lisp/calendar/time-date-tests.el (test-time-zone-format): Remove. * lisp/gnus/nnrss.el (nnrss-normalize-date): Use format-time-string instead of time-zone-format. diff --git a/etc/NEWS b/etc/NEWS index e1ac4eb933..486e677539 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2110,10 +2110,6 @@ doing computations on a decoded time structure), 'make-decoded-time' filled out), and 'encoded-time-set-defaults' (which fills in nil elements as if it's midnight January 1st, 1970) have been added. -*** The new function `time-zone-format' has been added to format -Emacs time zones (which are in seconds) according to many standards -(i.e., "+01:00"). - ** 'define-minor-mode' automatically documents the meaning of ARG. +++ diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index b94bf52760..32ba128689 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -352,20 +352,6 @@ is output until the first non-zero unit is encountered." (<= (car here) delay))) (concat (format "%.2f" (/ delay (car (cddr here)))) (cadr here)))))) -(defun time-zone-format (seconds &optional short) - "Format SECONDS as a valid time zone string. -For instance, 3600 is \"+01:00\". -If SHORT, the colon isn't included." - (format "%s%02d%s%02d" - (if (< seconds 0) - "-" - "+") - (/ (abs seconds) 3600) - (if short - "" - ":") - (mod (abs seconds) 3600))) - (defun date-days-in-month (year month) "The number of days in MONTH in YEAR." (if (= month 2) diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index f2c86ee44e..82d3f57424 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -487,7 +487,7 @@ which RSS 2.0 allows." (format "%s, %02d %s %04d %s%s" (substring cts 0 3) day (substring cts 4 7) year time (if zone - (concat " " (time-zone-format zone t)) + (concat " " (format-time-string "%z" nil zone)) ""))) (message-make-date given)))) diff --git a/test/lisp/calendar/time-date-tests.el b/test/lisp/calendar/time-date-tests.el index 51250ce5e7..b46a247cd3 100644 --- a/test/lisp/calendar/time-date-tests.el +++ b/test/lisp/calendar/time-date-tests.el @@ -104,12 +104,6 @@ (should (equal (decoded-time-add time (mdec :zone -7200)) '(12 15 14 8 7 2019 1 t 7200))))) -(ert-deftest test-time-zone-format () - (should (equal (time-zone-format 3600) - "+01:00")) - (should (equal (time-zone-format -7200) - "-02:00"))) - (require 'ert) ;;; time-date-tests.el ends here commit 5f78e81af0c2648391f26602189c565627e08218 Author: Lars Ingebrigtsen Date: Wed Jul 31 22:29:29 2019 +0200 Revert "Revert "Add support for paths to svg.el"" This reverts commit 0a2461be9edb218bf9ca56156d8966a2421f13a7. Copyright paperwork is now in place, so the patch mistakenly applied can now be re-applied. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 42f838bcdb..7c27b3897b 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -5608,6 +5608,9 @@ The identified of the shape. @item :gradient If given, this should be the identifier of a previously defined gradient object. + +@item :clip-path +Identifier of a clip path. @end table @defun svg-rectangle svg x y width height &rest args @@ -5655,6 +5658,29 @@ that describe the outer circumference of the polygon. @end lisp @end defun +@defun svg-path svg commands &rest args +Add the outline of a shape to @var{svg} according to @var{commands}, +see @ref{SVG Path Commands}. + +Coordinates by default are absolute. To use coordinates relative to +the last position, or -- initially -- to the origin, set the attribute +@var{:relative} to @code{t}. This attribute can be specified for the +function or for individual commands. If specified for the function, +then all commands use relative coordinates by default. To make an +individual command use absolute coordinates, set @var{:relative} to +@code{nil}. + +@lisp +(svg-path svg + '((moveto ((100 . 100))) + (lineto ((200 . 0) (0 . 200) (-200 . 0))) + (lineto ((100 . 100)) :relative nil)) + :stroke-color "blue" + :fill-color "lightblue" + :relative t) +@end lisp +@end defun + @defun svg-text svg text &rest args Add the specified @var{text} to @var{svg}. @@ -5686,6 +5712,30 @@ string containing the image data as raw bytes. @var{image-type} should be a @end lisp @end defun +@defun svg-clip-path svg &rest args +Add a clipping path to @var{svg}. If applied to a shape via the +@var{:clip-path} property, parts of that shape which lie outside of +the clipping path are not drawn. + +@lisp +(let ((clip-path (svg-clip-path svg :id "foo"))) + (svg-circle clip-path 200 200 175)) +(svg-rectangle svg 50 50 300 300 + :fill-color "red" + :clip-path "url(#foo)") +@end lisp +@end defun + +@defun svg-node svg tag &rest args +Add the custom node @var{tag} to @var{svg}. + +@lisp +(svg-node svg + 'rect + :width 300 :height 200 :x 50 :y 100 :fill-color "green") +@end lisp +@end defun + @defun svg-remove svg id Remove the element with identifier @code{id} from the @code{svg}. @end defun @@ -5708,6 +5758,193 @@ circle: @end lisp +@node SVG Path Commands +@subsubsection SVG Path Commands + +@deffn Command moveto points +Move the pen to the first point in @var{points}. Additional points +are connected with lines. @var{points} is a list of X/Y coordinate +pairs. Subsequent @command{moveto} commands represent the start of a +new @dfn{subpath}. + +@lisp +(svg-path svg '((moveto ((200 . 100) (100 . 200) (0 . 100)))) + :fill "white" :stroke "black") +@end lisp +@end deffn + +@deffn Command closepath +End the current subpath by connecting it back to its initial point. A +line is drawn along the connection. + +@lisp +(svg-path svg '((moveto ((200 . 100) (100 . 200) (0 . 100))) + (closepath) + (moveto ((75 . 125) (100 . 150) (125 . 125))) + (closepath)) + :fill "red" :stroke "black") +@end lisp +@end deffn + +@deffn Command lineto points +Draw a line from the current point to the first element in +@var{points}, a list of X/Y position pairs. If more than one point is +specified, draw a polyline. +@lisp +(svg-path svg '((moveto ((200 . 100))) + (lineto ((100 . 200) (0 . 100)))) + :fill "yellow" :stroke "red") +@end lisp +@end deffn + +@deffn Command horizontal-lineto x-coordinates +Draw a horizontal line from the current point to the first element in +@var{x-coordinates}. Specifying multiple coordinates is possible, +although usually this doesn’t make sense. + +@lisp +(svg-path svg '((moveto ((100 . 200))) + (horizontal-lineto (300))) + :stroke "green") +@end lisp +@end deffn + +@deffn Command vertical-lineto y-coordinates +Draw vertical lines. + +@lisp +(svg-path svg '((moveto ((200 . 100))) + (vertical-lineto (300))) + :stroke "green") +@end lisp +@end deffn + +@deffn Command curveto coordinate-sets +Using the first element in @var{coordinate-sets}, draw a cubic Bézier +curve from the current point. If there are multiple coordinate sets, +draw a polybézier. Each coordinate set is a list of the form +@code{(@var{x1} @var{y1} @var{x2} @var{y2} @var{x} @var{y})}, where +@w{(@var{x}, @var{y})} is the curve’s end point. @w{(@var{x1}, +@var{y1})} and @w{(@var{x2}, @var{y2})} are control points at the +beginning and at the end, respectively. + +@lisp +(svg-path svg '((moveto ((100 . 100))) + (curveto ((200 100 100 200 200 200) + (300 200 0 100 100 100)))) + :fill "transparent" :stroke "red") +@end lisp +@end deffn + +@deffn Command smooth-curveto coordinate-sets +Using the first element in @var{coordinate-sets}, draw a cubic Bézier +curve from the current point. If there are multiple coordinate sets, +draw a polybézier. Each coordinate set is a list of the form +@code{(@var{x2} @var{y2} @var{x} @var{y})}, where @w{(@var{x}, +@var{y})} is the curve’s end point and @w{(@var{x2}, @var{y2})} is the +corresponding control point. The first control point is the +reflection of the second control point of the previous command +relative to the current point, if that command was @command{curveto} +or @command{smooth-curveto}. Otherwise the first control point +coincides with the current point. + +@lisp +(svg-path svg '((moveto ((100 . 100))) + (curveto ((200 100 100 200 200 200))) + (smooth-curveto ((0 100 100 100)))) + :fill "transparent" :stroke "blue") +@end lisp +@end deffn + +@deffn Command quadratic-bezier-curveto coordinate-sets +Using the first element in @var{coordinate-sets}, draw a quadratic +Bézier curve from the current point. If there are multiple coordinate +sets, draw a polybézier. Each coordinate set is a list of the form +@code{(@var{x1} @var{y1} @var{x} @var{y})}, where @w{(@var{x}, +@var{y})} is the curve’s end point and @w{(@var{x1}, @var{y1})} is the +control point. + +@lisp +(svg-path svg '((moveto ((200 . 100))) + (quadratic-bezier-curveto ((300 100 300 200))) + (quadratic-bezier-curveto ((300 300 200 300))) + (quadratic-bezier-curveto ((100 300 100 200))) + (quadratic-bezier-curveto ((100 100 200 100)))) + :fill "transparent" :stroke "pink") +@end lisp +@end deffn + +@deffn Command smooth-quadratic-bezier-curveto coordinate-sets +Using the first element in @var{coordinate-sets}, draw a quadratic +Bézier curve from the current point. If there are multiple coordinate +sets, draw a polybézier. Each coordinate set is a list of the form +@code{(@var{x} @var{y})}, where @w{(@var{x}, @var{y})} is the curve’s +end point. The control point is the reflection of the control point +of the previous command relative to the current point, if that command +was @command{quadratic-bezier-curveto} or +@command{smooth-quadratic-bezier-curveto}. Otherwise the control +point coincides with the current point. + +@lisp +(svg-path svg '((moveto ((200 . 100))) + (quadratic-bezier-curveto ((300 100 300 200))) + (smooth-quadratic-bezier-curveto ((200 300))) + (smooth-quadratic-bezier-curveto ((100 200))) + (smooth-quadratic-bezier-curveto ((200 100)))) + :fill "transparent" :stroke "lightblue") +@end lisp +@end deffn + +@deffn Command elliptical-arc coordinate-sets +Using the first element in @var{coordinate-sets}, draw an elliptical +arc from the current point. If there are multiple coordinate sets, +draw a sequence of elliptical arcs. Each coordinate set is a list of +the form @code{(@var{rx} @var{ry} @var{x} @var{y})}, where +@w{(@var{x}, @var{y})} is the end point of the ellipse, and +@w{(@var{rx}, @var{ry})} are its radii. Attributes may be appended to +the list: + +@table @code +@item :x-axis-rotation +The angle in degrees by which the x-axis of the ellipse is rotated +relative to the x-axis of the current coordinate system. + +@item :large-arc +If set to @code{t}, draw an arc sweep greater than or equal to 180 +degrees. Otherwise, draw an arc sweep smaller than or equal to 180 +degrees. + +@item :sweep +If set to @code{t}, draw an arc in @dfn{positive angle direction}. +Otherwise, draw it in @dfn{negative angle direction}. +@end table + +@lisp +(svg-path svg '((moveto ((200 . 250))) + (elliptical-arc ((75 75 200 350)))) + :fill "transparent" :stroke "red") +(svg-path svg '((moveto ((200 . 250))) + (elliptical-arc ((75 75 200 350 :large-arc t)))) + :fill "transparent" :stroke "green") +(svg-path svg '((moveto ((200 . 250))) + (elliptical-arc ((75 75 200 350 :sweep t)))) + :fill "transparent" :stroke "blue") +(svg-path svg '((moveto ((200 . 250))) + (elliptical-arc ((75 75 200 350 :large-arc t + :sweep t)))) + :fill "transparent" :stroke "gray") +(svg-path svg '((moveto ((160 . 100))) + (elliptical-arc ((40 100 80 0))) + (elliptical-arc ((40 100 -40 -70 + :x-axis-rotation -120))) + (elliptical-arc ((40 100 -40 70 + :x-axis-rotation -240)))) + :stroke "pink" :fill "lightblue" + :relative t) +@end lisp +@end deffn + + @node Other Image Types @subsection Other Image Types @cindex PBM diff --git a/lisp/svg.el b/lisp/svg.el index 86b56a03d5..2ab56d3960 100644 --- a/lisp/svg.el +++ b/lisp/svg.el @@ -3,6 +3,7 @@ ;; Copyright (C) 2014-2019 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen +;; Felix E. Klee ;; Keywords: image ;; Version: 1.0 ;; Package-Requires: ((emacs "25")) @@ -324,6 +325,153 @@ If the SVG is later changed, the image will also be updated." "\\'"))))) (when node (dom-remove-node svg node)))) +;; Function body copied from `org-plist-delete' in Emacs 26.1. +(defun svg--plist-delete (plist property) + "Delete PROPERTY from PLIST. +This is in contrast to merely setting it to 0." + (let (p) + (while plist + (if (not (eq property (car plist))) + (setq p (plist-put p (car plist) (nth 1 plist)))) + (setq plist (cddr plist))) + p)) + +(defun svg--path-command-symbol (command-symbol command-args) + (let ((char (symbol-name command-symbol)) + (relative (if (plist-member command-args :relative) + (plist-get command-args :relative) + (plist-get command-args :default-relative)))) + (intern (if relative (downcase char) (upcase char))))) + +(defun svg--elliptical-arc-coordinates + (rx ry x y &rest args) + (list + rx ry + (or (plist-get args :x-axis-rotation) 0) + (if (plist-get args :large-arc) 1 0) + (if (plist-get args :sweep) 1 0) + x y)) + +(defun svg--elliptical-arc-command (coordinates-list &rest args) + (cons + (svg--path-command-symbol 'a args) + (apply 'append + (mapcar + (lambda (coordinates) + (apply 'svg--elliptical-arc-coordinates + coordinates)) + coordinates-list)))) + +(defun svg--moveto-command (coordinates-list &rest args) + (cons + (svg--path-command-symbol 'm args) + (apply 'append + (mapcar + (lambda (coordinates) + (list (car coordinates) (cdr coordinates))) + coordinates-list)))) + +(defun svg--closepath-command (&rest args) + (list (svg--path-command-symbol 'z args))) + +(defun svg--lineto-command (coordinates-list &rest args) + (cons + (svg--path-command-symbol 'l args) + (apply 'append + (mapcar + (lambda (coordinates) + (list (car coordinates) (cdr coordinates))) + coordinates-list)))) + +(defun svg--horizontal-lineto-command (coordinate-list &rest args) + (cons + (svg--path-command-symbol 'h args) + coordinate-list)) + +(defun svg--vertical-lineto-command (coordinate-list &rest args) + (cons + (svg--path-command-symbol 'v args) + coordinate-list)) + +(defun svg--curveto-command (coordinates-list &rest args) + (cons + (svg--path-command-symbol 'c args) + (apply 'append coordinates-list))) + +(defun svg--smooth-curveto-command (coordinates-list &rest args) + (cons + (svg--path-command-symbol 's args) + (apply 'append coordinates-list))) + +(defun svg--quadratic-bezier-curveto-command (coordinates-list + &rest args) + (cons + (svg--path-command-symbol 'q args) + (apply 'append coordinates-list))) + +(defun svg--smooth-quadratic-bezier-curveto-command (coordinates-list + &rest args) + (cons + (svg--path-command-symbol 't args) + (apply 'append coordinates-list))) + +(defun svg--eval-path-command (command default-relative) + (cl-letf + (((symbol-function 'moveto) #'svg--moveto-command) + ((symbol-function 'closepath) #'svg--closepath-command) + ((symbol-function 'lineto) #'svg--lineto-command) + ((symbol-function 'horizontal-lineto) + #'svg--horizontal-lineto-command) + ((symbol-function 'vertical-lineto) + #'svg--vertical-lineto-command) + ((symbol-function 'curveto) #'svg--curveto-command) + ((symbol-function 'smooth-curveto) + #'svg--smooth-curveto-command) + ((symbol-function 'quadratic-bezier-curveto) + #'svg--quadratic-bezier-curveto-command) + ((symbol-function 'smooth-quadratic-bezier-curveto) + #'svg--smooth-quadratic-bezier-curveto-command) + ((symbol-function 'elliptical-arc) + #'svg--elliptical-arc-command) + (extended-command (append command (list :default-relative + default-relative)))) + (mapconcat 'prin1-to-string (apply extended-command) " "))) + +(defun svg-path (svg commands &rest args) + "Add the outline of a shape to SVG according to COMMANDS. +Coordinates by default are absolute. ARGS is a plist of +modifiers. If :relative is t, then coordinates are relative to +the last position, or -- initially -- to the origin." + (let* ((default-relative (plist-get args :relative)) + (stripped-args (svg--plist-delete args :relative)) + (d (mapconcat 'identity + (mapcar + (lambda (command) + (svg--eval-path-command command + default-relative)) + commands) " "))) + (svg--append + svg + (dom-node 'path + `((d . ,d) + ,@(svg--arguments svg stripped-args)))))) + +(defun svg-clip-path (svg &rest args) + "Add a clipping path to SVG, where ARGS is a plist of modifiers. +If applied to a shape via the :clip-path property, parts of that +shape which lie outside of the clipping path are not drawn." + (let ((new-dom-node (dom-node 'clipPath + `(,@(svg--arguments svg args))))) + (svg--append svg new-dom-node) + new-dom-node)) + +(defun svg-node (svg tag &rest args) + "Add the custom node TAG to SVG." + (let ((new-dom-node (dom-node tag + `(,@(svg--arguments svg args))))) + (svg--append svg new-dom-node) + new-dom-node)) + (provide 'svg) ;;; svg.el ends here commit ee7baca4fa96d4e1ad6bd9ad055d92f435b7eaa6 Author: Lars Ingebrigtsen Date: Wed Jul 31 22:18:57 2019 +0200 Restore `replace-region-contents' in json-pretty-print * lisp/json.el (json-pretty-print): Switch back to using `replace-region-contents' to preserve markers and fonts which went missing when fixing the bug (bug#34160). (json-pretty-print-max-secs): Restore, too. diff --git a/lisp/json.el b/lisp/json.el index d664dae05e..cdb1be0616 100644 --- a/lisp/json.el +++ b/lisp/json.el @@ -49,6 +49,8 @@ ;; 2008-02-21 - Installed in GNU Emacs. ;; 2011-10-17 - Patch `json-alist-p' and `json-plist-p' to avoid recursion -tzz ;; 2012-10-25 - Added pretty-printed reformatting -Ryan Crum (ryan@ryancrum.org) +;; 2019-02-02 - Pretty-printing now uses replace-region-contents and support for +;; minimization -tsdh ;;; Code: @@ -755,6 +757,12 @@ With prefix argument MINIMIZE, minimize it instead." (interactive "P") (json-pretty-print (point-min) (point-max) minimize)) +(defvar json-pretty-print-max-secs 2.0 + "Maximum time for `json-pretty-print's comparison. +The function `json-pretty-print' uses `replace-region-contents' +(which see) passing the value of this variable as argument +MAX-SECS.") + (defun json-pretty-print (begin end &optional minimize) "Pretty-print selected region. With prefix argument MINIMIZE, minimize it instead." @@ -766,16 +774,23 @@ With prefix argument MINIMIZE, minimize it instead." (json-object-type 'alist) (err (gensym)) json) - (save-restriction - (narrow-to-region begin end) - (goto-char begin) - (while (not (eq (setq json (condition-case _ - (json-read) - (json-error err))) - err)) - (delete-region begin (point)) - (insert (json-encode json)) - (setq begin (point)))))) + (replace-region-contents + begin end + (lambda () + (let ((pretty "")) + (save-restriction + (narrow-to-region begin end) + (goto-char begin) + (while (not (eq (setq json (condition-case nil + (json-read) + (json-error err))) + err)) + (setq pretty (concat pretty (json-encode json))))) + pretty)) + json-pretty-print-max-secs + ;; FIXME: What's a good value here? Can we use something better, + ;; e.g., by deriving a value from the size of the region? + 64))) (defun json-pretty-print-buffer-ordered (&optional minimize) "Pretty-print current buffer with object keys ordered. commit a79e96f0f9133b0577e709f805179ab59b09fe33 Author: Lars Ingebrigtsen Date: Wed Jul 31 21:04:50 2019 +0200 Add more icalendar tests (for the isodatetime parser) * test/lisp/calendar/icalendar-tests.el (icalendar-tests--decode-isodatetime): Test `icalendar--decode-isodatetime'. diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el index af617e677f..baea480404 100644 --- a/test/lisp/calendar/icalendar-tests.el +++ b/test/lisp/calendar/icalendar-tests.el @@ -2325,5 +2325,31 @@ END:VCALENDAR ) ) +(defun icalendar-test--format (string &optional day zone) + (let ((time (icalendar--decode-isodatetime string day zone))) + (format-time-string "%FT%T%z" (encode-time time) 0))) + +(defun icalendar-tests--decode-isodatetime (ical-string) + (should (equal (icalendar-test--format "20040917T050910-0200") + "2004-09-17T03:09:10+0000")) + (should (equal (icalendar-test--format "20040917T050910") + "2004-09-17T03:09:10+0000")) + (should (equal (icalendar-test--format "20040917T050910Z") + "2004-09-17T05:09:10+0000")) + (should (equal (icalendar-test--format "20040917T0509") + "2004-09-17T03:09:00+0000")) + (should (equal (icalendar-test--format "20040917") + "2004-09-16T22:00:00+0000")) + (should (equal (icalendar-test--format "20040917T050910" 1) + "2004-09-18T03:09:10+0000")) + (should (equal (icalendar-test--format "20040917T050910" 30) + "2004-10-17T03:09:10+0000")) + (should (equal (icalendar-test--format "20040917T050910" -1) + "2004-09-16T03:09:10+0000")) + + (should (equal (icalendar-test--format "20040917T050910" nil -3600) + "2004-09-17T06:09:10+0000"))) + + (provide 'icalendar-tests) ;;; icalendar-tests.el ends here commit c8f1e17e6be1545557f10c3e8039e655ace6ab1c Author: Lars Ingebrigtsen Date: Wed Jul 31 15:25:46 2019 +0200 Rewrite `url-dav-process-date-property' to use parse-time * lisp/url/url-dav.el (url-dav-iso8601-regexp): Remove. (url-dav-process-date-property): Rewrite to use `parse-iso8601-time-string'. diff --git a/lisp/url/url-dav.el b/lisp/url/url-dav.el index a4cf0f0ec0..3159b695c1 100644 --- a/lisp/url/url-dav.el +++ b/lisp/url/url-dav.el @@ -33,6 +33,7 @@ (require 'url-util) (require 'url-handlers) (require 'url-http) +(require 'parse-time) (defvar url-dav-supported-protocols '(1 2) "List of supported DAV versions.") @@ -83,72 +84,14 @@ Returns nil if WebDAV is not supported." (defun url-dav-process-number-property (node) (string-to-number (url-dav-node-text node))) -(defconst url-dav-iso8601-regexp - (let* ((dash "-?") - (colon ":?") - (4digit "\\([0-9][0-9][0-9][0-9]\\)") - (2digit "\\([0-9][0-9]\\)") - (date-fullyear 4digit) - (date-month 2digit) - (date-mday 2digit) - (time-hour 2digit) - (time-minute 2digit) - (time-second 2digit) - (time-secfrac "\\(\\.[0-9]+\\)?") - (time-numoffset (concat "[-+]\\(" time-hour "\\):" time-minute)) - (time-offset (concat "Z" time-numoffset)) - (partial-time (concat time-hour colon time-minute colon time-second - time-secfrac)) - (full-date (concat date-fullyear dash date-month dash date-mday)) - (full-time (concat partial-time time-offset)) - (date-time (concat full-date "T" full-time))) - (list (concat "^" full-date) - (concat "T" partial-time) - (concat "Z" time-numoffset))) - "List of regular expressions matching ISO 8601 dates. -1st regular expression matches the date. -2nd regular expression matches the time. -3rd regular expression matches the (optional) timezone specification.") - (defun url-dav-process-date-property (node) - (require 'parse-time) - (let* ((date-re (nth 0 url-dav-iso8601-regexp)) - (time-re (nth 1 url-dav-iso8601-regexp)) - (tz-re (nth 2 url-dav-iso8601-regexp)) - (date-string (url-dav-node-text node)) - re-start - time seconds minute hour fractional-seconds - day month year day-of-week dst tz) - ;; We need to populate 'time' with - ;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ) - - ;; Nobody else handles iso8601 correctly, let's do it ourselves. - (when (string-match date-re date-string re-start) - (setq year (string-to-number (match-string 1 date-string)) - month (string-to-number (match-string 2 date-string)) - day (string-to-number (match-string 3 date-string)) - re-start (match-end 0)) - (when (string-match time-re date-string re-start) - (setq hour (string-to-number (match-string 1 date-string)) - minute (string-to-number (match-string 2 date-string)) - seconds (string-to-number (match-string 3 date-string)) - fractional-seconds (string-to-number (or - (match-string 4 date-string) - "0")) - re-start (match-end 0)) - (when (string-match tz-re date-string re-start) - (setq tz (match-string 1 date-string))) - (url-debug 'dav "Parsed iso8601%s date" (if tz "tz" "")) - (setq time (list seconds minute hour day month year day-of-week dst tz)))) - - ;; Fall back to having Gnus do fancy things for us. - (when (not time) - (setq time (parse-time-string date-string))) - + (let* ((date-string (url-dav-node-text node)) + (time (parse-iso8601-time-string date-string))) (if time (setq time (encode-time time)) (url-debug 'dav "Unable to decode date (%S) (%s)" - (xml-node-name node) date-string)) + (xml-node-name node) + date-string)) time)) (defun url-dav-process-boolean-property (node) commit 1ab6445bb3ed7e0ebe771692cbeda557a82b9381 Author: Lars Ingebrigtsen Date: Wed Jul 31 15:18:03 2019 +0200 Fix time zone in previous rewrite of newsticker--decode-iso8601-date * lisp/net/newst-backend.el (newsticker--decode-iso8601-date): According to the tests, this function should default to the Z time zone. diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index 5064610e39..1fb7fe005e 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -1597,10 +1597,11 @@ This function calls `message' with arguments STRING and ARGS, if (defun newsticker--decode-iso8601-date (string) "Return ISO8601-STRING in format like `encode-time'. -Converts from ISO-8601 to Emacs representation." +Converts from ISO-8601 to Emacs representation. If no time zone +is present, this fuction defaults to universal time." (if string (condition-case nil - (encode-time (iso8601-parse string)) + (encode-time (decoded-time-set-defaults (iso8601-parse string) 0)) (wrong-type-argument (message "Cannot decode \"%s\"" string) nil)) commit 296002ba5aefa60f8a1f97c4d28808683247ce8b Author: Lars Ingebrigtsen Date: Wed Jul 31 15:17:04 2019 +0200 Rewrite `parse-iso8601-time-string' to use `iso8601-parse' * lisp/calendar/parse-time.el (parse-iso8601-time-string): Use `iso8601-parse'. (parse-time-iso8601-regexp): Remove. diff --git a/lisp/calendar/parse-time.el b/lisp/calendar/parse-time.el index 68d6ce05d6..e28df97918 100644 --- a/lisp/calendar/parse-time.el +++ b/lisp/calendar/parse-time.el @@ -36,6 +36,8 @@ ;;; Code: (require 'cl-lib) +(require 'iso8601) +(eval-when-compile (require 'subr-x)) ;; Byte-compiler warnings (defvar parse-time-elt) @@ -193,75 +195,17 @@ unknown DST value is returned as -1." (setf (nth (pop slots) time) new-val)))))))) time)) -(defconst parse-time-iso8601-regexp - (let* ((dash "-?") - (colon ":?") - (4digit "\\([0-9][0-9][0-9][0-9]\\)") - (2digit "\\([0-9][0-9]\\)") - (date-fullyear 4digit) - (date-month 2digit) - (date-mday 2digit) - (time-hour 2digit) - (time-minute 2digit) - (time-second 2digit) - (time-secfrac "\\(\\.[0-9]+\\)?") - (time-numoffset (concat "\\([-+]\\)" time-hour ":?" time-minute "?")) - (partial-time (concat time-hour colon time-minute colon time-second - time-secfrac)) - (full-date (concat date-fullyear dash date-month dash date-mday))) - (list (concat "^" full-date) - (concat "T" partial-time) - (concat "\\(Z\\|" time-numoffset "\\)"))) - "List of regular expressions matching ISO 8601 dates. -1st regular expression matches the date. -2nd regular expression matches the time. -3rd regular expression matches the (optional) timezone specification.") - (defun parse-iso8601-time-string (date-string) "Parse an ISO 8601 time string, such as 2016-12-01T23:35:06-05:00. If DATE-STRING cannot be parsed, it falls back to `parse-time-string'." - (let* ((date-re (nth 0 parse-time-iso8601-regexp)) - (time-re (nth 1 parse-time-iso8601-regexp)) - (tz-re (nth 2 parse-time-iso8601-regexp)) - re-start - time seconds minute hour - day month year day-of-week (dst -1) tz) - ;; We need to populate 'time' with - ;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ) - - ;; Nobody else handles iso8601 correctly, let's do it ourselves. - (when (string-match date-re date-string re-start) - (setq year (string-to-number (match-string 1 date-string)) - month (string-to-number (match-string 2 date-string)) - day (string-to-number (match-string 3 date-string)) - re-start (match-end 0)) - (when (string-match time-re date-string re-start) - (setq hour (string-to-number (match-string 1 date-string)) - minute (string-to-number (match-string 2 date-string)) - seconds (string-to-number (match-string 3 date-string)) - re-start (match-end 0)) - (when (string-match tz-re date-string re-start) - (setq dst nil) - (setq tz (if (string= "Z" (match-string 1 date-string)) - 0 ;; UTC timezone indicated by Z - (let ((tz (+ - (* 3600 - (string-to-number - (match-string 3 date-string))) - (* 60 - (string-to-number - (or (match-string 4 date-string) "0")))))) - (if (string= "-" (match-string 2 date-string)) - (- tz) tz))))) - (setq time (list seconds minute hour day month year day-of-week dst tz)))) - - ;; Fall back to having `parse-time-string' do fancy things for us. - (when (not time) - (setq time (parse-time-string date-string))) - - (and time - (encode-time time)))) + (when-let ((time + (if (iso8601-valid-p date-string) + (decoded-time-set-defaults (iso8601-parse date-string)) + ;; Fall back to having `parse-time-string' do fancy + ;; things for us. + (parse-time-string date-string)))) + (encode-time time))) (provide 'parse-time) commit fa648a59c9818ae284209ac7ae4f3700aebd92c9 Author: Lars Ingebrigtsen Date: Wed Jul 31 15:15:47 2019 +0200 Allow timezone defaults in decoded-time-set-defaults * lisp/calendar/time-date.el (decoded-time-set-defaults): Allow passing in a default time zone, as this seems to be something callers seem to do. diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index dfe8dce68b..b94bf52760 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -512,7 +512,7 @@ changes in daylight saving time are not taken into account." "Return a `decoded-time' structure with only the keywords given filled out." (list second minute hour day month year nil dst zone)) -(defun decoded-time-set-defaults (time) +(defun decoded-time-set-defaults (time &optional default-zone) "Set any nil values in `decoded-time' TIME to default values. The default value is based on January 1st, 1970 at midnight. @@ -536,6 +536,10 @@ TIME is modified and returned." (when (and (not (decoded-time-zone time)) (not (decoded-time-dst time))) (setf (decoded-time-dst time) -1)) + + (when (and (not (decoded-time-zone time)) + default-zone) + (setf (decoded-time-zone time) 0)) time) (provide 'time-date) commit 4dcb692de0cf0107149abe501663a1477571bfc0 Author: Lars Ingebrigtsen Date: Wed Jul 31 15:10:38 2019 +0200 Default DST to "undecided" in decoded-time-set-defaults * lisp/calendar/time-date.el (decoded-time-set-defaults): When we don't have a zone or a DST, set DST to "undecided". diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index 6f85171247..dfe8dce68b 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -530,6 +530,12 @@ TIME is modified and returned." (setf (decoded-time-month time) 1)) (unless (decoded-time-year time) (setf (decoded-time-year time) 0)) + + ;; When we don't have a time zone and we don't have a DST, then mark + ;; it as unknown. + (when (and (not (decoded-time-zone time)) + (not (decoded-time-dst time))) + (setf (decoded-time-dst time) -1)) time) (provide 'time-date) commit e82ae1db3c63449641f65cf249efa5b475da22a2 Author: Lars Ingebrigtsen Date: Tue Jul 30 17:22:08 2019 +0200 decoded-time-dst doc fix * lisp/simple.el (decoded-time): Doc fix for dst (note -1 value). diff --git a/lisp/simple.el b/lisp/simple.el index 0bc39f08c0..08021ce0e0 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -9081,7 +9081,9 @@ This is an integer between 1 and 12 (inclusive). January is 1.") (weekday nil :documentation "\ This is a number between 0 and 6, and 0 is Sunday.") (dst nil :documentation "\ -This is t if daylight saving time is in effect, and nil if not.") +This is t if daylight saving time is in effect, nil if it is not +in effect, and -1 if daylight saving information is not +available.") (zone nil :documentation "\ This is an integer indicating the UTC offset in seconds, i.e., the number of seconds east of Greenwich.") commit 6a87416d61794af1bdde80f696a0595f215e7baa Author: Lars Ingebrigtsen Date: Tue Jul 30 17:01:35 2019 +0200 Use iso8601-parse in nnrss * lisp/gnus/nnrss.el (nnrss-normalize-date): Use iso8601-parse instead of hand-rolled parser. * test/lisp/gnus/nnrss-tests.el: New file. diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index 0bfecb28e0..f2c86ee44e 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -36,6 +36,7 @@ (require 'rfc2231) (require 'mm-url) (require 'rfc2047) +(require 'iso8601) (require 'mml) (require 'xml) @@ -468,49 +469,25 @@ which RSS 2.0 allows." (not (string-match "\\`[A-Z+-]" zone))) (setq zone nil)))) ;; ISO 8601 - ((string-match - (eval-when-compile - (concat - ;; 1. year - "\\(199[0-9]\\|20[0-9][0-9]\\)" - "\\(?:-" - ;; 2. month - "\\([01][0-9]\\)" - "\\(?:-" - ;; 3. day - "\\([0-3][0-9]\\)" - "\\)?\\)?\\(?:T" - ;; 4. hh:mm - "\\([012][0-9]:[0-5][0-9]\\)" - "\\(?:" - ;; 5. :ss - "\\(:[0-5][0-9]\\)" - "\\(?:\\.[0-9]+\\)?\\)?\\)?" - ;; 6+7,8,9. zone - "\\(?:\\(?:\\([+-][012][0-9]\\):\\([0-5][0-9]\\)\\)" - "\\|\\([+-][012][0-9][0-5][0-9]\\)" - "\\|\\(Z\\)\\)?")) - date) - (setq year (string-to-number (match-string 1 date)) - month (string-to-number (or (match-string 2 date) "1")) - day (string-to-number (or (match-string 3 date) "1")) - time (if (match-beginning 5) - (substring date (match-beginning 4) (match-end 5)) - (concat (or (match-string 4 date) "00:00") ":00")) - zone (cond ((match-beginning 6) - (concat (match-string 6 date) - (match-string 7 date))) - ((match-beginning 9) ;; Z - "+0000") - (t ;; nil if zone is not provided. - (match-string 8 date)))))) + ((iso8601-valid-p date) + (let ((decoded (decoded-time-set-defaults (iso8601-parse date)))) + (setq year (decoded-time-year decoded) + month (decoded-time-month decoded) + day (decoded-time-day decoded) + time (format "%02d:%02d:%02d" + (decoded-time-hour decoded) + (decoded-time-minute decoded) + (decoded-time-second decoded)) + zone (if (equal (decoded-time-zone decoded) "Z") + 0 + (decoded-time-zone decoded)))))) (if month (progn (setq cts (current-time-string (encode-time 0 0 0 day month year))) (format "%s, %02d %s %04d %s%s" (substring cts 0 3) day (substring cts 4 7) year time (if zone - (concat " " zone) + (concat " " (time-zone-format zone t)) ""))) (message-make-date given)))) diff --git a/test/lisp/gnus/nnrss-tests.el b/test/lisp/gnus/nnrss-tests.el new file mode 100644 index 0000000000..184c592ea2 --- /dev/null +++ b/test/lisp/gnus/nnrss-tests.el @@ -0,0 +1,29 @@ +;;; nnrss-tests.el --- tests for gnus/nnrss.el -*- lexical-binding:t -*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'nnrss) + +(ert-deftest test-nnrss-normalize () + (should (equal (nnrss-normalize-date "2004-09-17T05:09:49.001+00:00") + "Fri, 17 Sep 2004 05:09:49 +0000"))) + +;;; nnrss-tests.el ends here commit 14c0a63e79ebb5c7445b3a4d2fe6e98e4a707765 Author: Lars Ingebrigtsen Date: Tue Jul 30 16:59:31 2019 +0200 Make time-zone-format take a SHORT parameter * lisp/calendar/time-date.el (time-zone-format): Accept an optional SHORT parameter. diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index efc9ae4e3b..6f85171247 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -352,14 +352,18 @@ is output until the first non-zero unit is encountered." (<= (car here) delay))) (concat (format "%.2f" (/ delay (car (cddr here)))) (cadr here)))))) -(defun time-zone-format (seconds) +(defun time-zone-format (seconds &optional short) "Format SECONDS as a valid time zone string. -For instance, 3600 is \"+01:00\"." - (format "%s%02d:%02d" +For instance, 3600 is \"+01:00\". +If SHORT, the colon isn't included." + (format "%s%02d%s%02d" (if (< seconds 0) "-" "+") (/ (abs seconds) 3600) + (if short + "" + ":") (mod (abs seconds) 3600))) (defun date-days-in-month (year month) commit 46df7bbe12cce4c9af7ce4357aa9f8d36c1d8933 Author: Lars Ingebrigtsen Date: Tue Jul 30 16:56:12 2019 +0200 Add new function time-zone-format * lisp/calendar/time-date.el (time-zone-format): New function. diff --git a/etc/NEWS b/etc/NEWS index 486e677539..e1ac4eb933 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2110,6 +2110,10 @@ doing computations on a decoded time structure), 'make-decoded-time' filled out), and 'encoded-time-set-defaults' (which fills in nil elements as if it's midnight January 1st, 1970) have been added. +*** The new function `time-zone-format' has been added to format +Emacs time zones (which are in seconds) according to many standards +(i.e., "+01:00"). + ** 'define-minor-mode' automatically documents the meaning of ARG. +++ diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index f14478e67c..efc9ae4e3b 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -352,6 +352,16 @@ is output until the first non-zero unit is encountered." (<= (car here) delay))) (concat (format "%.2f" (/ delay (car (cddr here)))) (cadr here)))))) +(defun time-zone-format (seconds) + "Format SECONDS as a valid time zone string. +For instance, 3600 is \"+01:00\"." + (format "%s%02d:%02d" + (if (< seconds 0) + "-" + "+") + (/ (abs seconds) 3600) + (mod (abs seconds) 3600))) + (defun date-days-in-month (year month) "The number of days in MONTH in YEAR." (if (= month 2) diff --git a/test/lisp/calendar/time-date-tests.el b/test/lisp/calendar/time-date-tests.el index b46a247cd3..51250ce5e7 100644 --- a/test/lisp/calendar/time-date-tests.el +++ b/test/lisp/calendar/time-date-tests.el @@ -104,6 +104,12 @@ (should (equal (decoded-time-add time (mdec :zone -7200)) '(12 15 14 8 7 2019 1 t 7200))))) +(ert-deftest test-time-zone-format () + (should (equal (time-zone-format 3600) + "+01:00")) + (should (equal (time-zone-format -7200) + "-02:00"))) + (require 'ert) ;;; time-date-tests.el ends here commit 07ce3be6aa15fdf2092bdf3c60a132d5f4b9c980 Author: Lars Ingebrigtsen Date: Tue Jul 30 16:46:10 2019 +0200 `decoded-time-set-defaults' refactored out from iso8601 code * lisp/calendar/iso8601.el (iso8601--encode-time): * lisp/calendar/time-date.el (decoded-time-set-defaults): Refactor out from `iso8601--encode-time', because it's helpful in other contexts. diff --git a/etc/NEWS b/etc/NEWS index 7dfb08256f..486e677539 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2102,13 +2102,13 @@ with POSIX.1-2017. 'decoded-time-weekday', 'decoded-time-dst' and 'decoded-time-zone' accessors can be used. -+++ *** The new functions 'date-days-in-month' (which will say how many days there are in a month in a specific year), 'date-ordinal-to-time' (that computes the date of an ordinal day), 'decoded-time-add' for -doing computations on a decoded time structure), and -'make-decoded-time' (for making a decoded time structure with only the -given keywords filled out) have been added. +doing computations on a decoded time structure), 'make-decoded-time' +(for making a decoded time structure with only the given keywords +filled out), and 'encoded-time-set-defaults' (which fills in nil +elements as if it's midnight January 1st, 1970) have been added. ** 'define-minor-mode' automatically documents the meaning of ARG. diff --git a/lisp/calendar/iso8601.el b/lisp/calendar/iso8601.el index ab0077ac58..c69156cbeb 100644 --- a/lisp/calendar/iso8601.el +++ b/lisp/calendar/iso8601.el @@ -349,21 +349,7 @@ Return the number of minutes." (defun iso8601--encode-time (time) "Like `encode-time', but fill in nil values in TIME." - (setq time (copy-sequence time)) - (unless (decoded-time-second time) - (setf (decoded-time-second time) 0)) - (unless (decoded-time-minute time) - (setf (decoded-time-minute time) 0)) - (unless (decoded-time-hour time) - (setf (decoded-time-hour time) 0)) - - (unless (decoded-time-day time) - (setf (decoded-time-day time) 1)) - (unless (decoded-time-month time) - (setf (decoded-time-month time) 1)) - (unless (decoded-time-year time) - (setf (decoded-time-year time) 0)) - (encode-time time)) + (encode-time (decoded-time-set-defaults (copy-sequence time)))) (provide 'iso8601) diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index e195f71c58..f14478e67c 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -498,6 +498,26 @@ changes in daylight saving time are not taken into account." "Return a `decoded-time' structure with only the keywords given filled out." (list second minute hour day month year nil dst zone)) +(defun decoded-time-set-defaults (time) + "Set any nil values in `decoded-time' TIME to default values. +The default value is based on January 1st, 1970 at midnight. + +TIME is modified and returned." + (unless (decoded-time-second time) + (setf (decoded-time-second time) 0)) + (unless (decoded-time-minute time) + (setf (decoded-time-minute time) 0)) + (unless (decoded-time-hour time) + (setf (decoded-time-hour time) 0)) + + (unless (decoded-time-day time) + (setf (decoded-time-day time) 1)) + (unless (decoded-time-month time) + (setf (decoded-time-month time) 1)) + (unless (decoded-time-year time) + (setf (decoded-time-year time) 0)) + time) + (provide 'time-date) ;;; time-date.el ends here commit 8c04e65622cbff1417727162d9b0c455cb87ed73 Author: Lars Ingebrigtsen Date: Tue Jul 30 16:20:40 2019 +0200 Have newsticker use iso8601 to parse dates * lisp/net/newst-backend.el (newsticker--decode-iso8601-date): Use iso8601 to parse. diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index e356a0ece5..5064610e39 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -37,6 +37,7 @@ (require 'derived) (require 'xml) (require 'url-parse) +(require 'iso8601) ;; Silence warnings (defvar w3-mode-map) @@ -1594,61 +1595,15 @@ This function calls `message' with arguments STRING and ARGS, if ;;(not (current-message)) (apply 'message string args))) -(defun newsticker--decode-iso8601-date (iso8601-string) - "Return ISO8601-STRING in format like `decode-time'. -Converts from ISO-8601 to Emacs representation. -Examples: -2004-09-17T05:09:49.001+00:00 -2004-09-17T05:09:49+00:00 -2004-09-17T05:09+00:00 -2004-09-17T05:09:49 -2004-09-17T05:09 -2004-09-17 -2004-09 -2004" - (if iso8601-string - (when (string-match - (concat - "^ *\\([0-9]\\{4\\}\\)" ;year - "\\(-\\([0-9]\\{2\\}\\)" ;month - "\\(-\\([0-9]\\{2\\}\\)" ;day - "\\(T" - "\\([0-9]\\{2\\}\\):\\([0-9]\\{2\\}\\)" ;hour:minute - "\\(:\\([0-9]\\{2\\}\\)\\(\\.[0-9]+\\)?\\)?" ;second - ;timezone - "\\(\\([-+Z]\\)\\(\\([0-9]\\{2\\}\\):\\([0-9]\\{2\\}\\)\\)?\\)?" - "\\)?\\)?\\)? *$") - iso8601-string) - (let ((year (read (match-string 1 iso8601-string))) - (month (read (or (match-string 3 iso8601-string) - "1"))) - (day (read (or (match-string 5 iso8601-string) - "1"))) - (hour (read (or (match-string 7 iso8601-string) - "0"))) - (minute (read (or (match-string 8 iso8601-string) - "0"))) - (second (read (or (match-string 10 iso8601-string) - "0"))) - (sign (match-string 13 iso8601-string)) - (offset-hour (read (or (match-string 15 iso8601-string) - "0"))) - (offset-minute (read (or (match-string 16 iso8601-string) - "0")))) - (cond ((string= sign "+") - (setq hour (- hour offset-hour)) - (setq minute (- minute offset-minute))) - ((string= sign "-") - (setq hour (+ hour offset-hour)) - (setq minute (+ minute offset-minute)))) - ;; if UTC subtract current-time-zone offset - ;;(setq second (+ (car (current-time-zone)) second))) - - (condition-case nil - (encode-time second minute hour day month year t) - (error - (message "Cannot decode \"%s\"" iso8601-string) - nil)))) +(defun newsticker--decode-iso8601-date (string) + "Return ISO8601-STRING in format like `encode-time'. +Converts from ISO-8601 to Emacs representation." + (if string + (condition-case nil + (encode-time (iso8601-parse string)) + (wrong-type-argument + (message "Cannot decode \"%s\"" string) + nil)) nil)) (defun newsticker--decode-rfc822-date (rfc822-string) commit 794f8f25b505ab32c7e79d1d484fce22e85c0010 Author: Michael Albinus Date: Wed Jul 31 21:22:48 2019 +0200 Call file notification actions properly in filenotify-tests.el * test/lisp/filenotify-tests.el (file-notify--test-wait-for-events): Rename from `file-notify--wait-for-events'. Adapt all callees. (file-notify--test-cleanup): Reset also `file-notify--test-event' and `file-notify--test-file nil'. (file-notify--test-event-desc, file-notify--test-event-action): New accessor functions. (file-notify-test02-rm-watch, file-notify--test-event-test) (file-notify--test-with-actions-check) (file-notify--test-with-actions-explainer): Use them. (file-notify--test-with-actions-check) (file-notify--test-with-actions-explainer) (file-notify--test-with-actions): Rename them from *-events-*. Rename also internal variables accordingly. Adapt all callees. diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el index 7c8c1953c4..3d2f6e6a73 100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@ -123,7 +123,7 @@ There are different timeouts for local and remote file notification libraries." ((eq system-type 'cygwin) 6) (t 3))) -(defmacro file-notify--wait-for-events (timeout until) +(defmacro file-notify--test-wait-for-events (timeout until) "Wait for and return file notification events until form UNTIL is true. TIMEOUT is the maximum time to wait for, in seconds." `(with-timeout (,timeout (ignore)) @@ -134,7 +134,7 @@ TIMEOUT is the maximum time to wait for, in seconds." "Check that `file-notify-descriptors' is an empty hash table. Return nil when any other file notification watch is still active." ;; Give read events a last chance. - (file-notify--wait-for-events + (file-notify--test-wait-for-events (file-notify--test-timeout) (zerop (hash-table-count file-notify-descriptors))) ;; Now check. @@ -193,6 +193,8 @@ Return nil when any other file notification watch is still active." file-notify--test-desc1 nil file-notify--test-desc2 nil file-notify--test-results nil + file-notify--test-event nil + file-notify--test-file nil file-notify--test-events nil file-notify--test-monitors nil)) @@ -459,9 +461,11 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (unless (eq system-type 'cygwin) (let (results) (cl-flet ((first-callback (event) - (when (eq (nth 1 event) 'deleted) (push 1 results))) + (when (eq (file-notify--test-event-action event) 'deleted) + (push 1 results))) (second-callback (event) - (when (eq (nth 1 event) 'deleted) (push 2 results)))) + (when (eq (file-notify--test-event-action event) 'deleted) + (push 2 results)))) (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) @@ -480,7 +484,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Only the second callback shall run. (file-notify--test-read-event) (delete-file file-notify--test-tmpfile) - (file-notify--wait-for-events + (file-notify--test-wait-for-events (file-notify--test-timeout) results) (should (equal results (list 2))) @@ -494,6 +498,8 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." "Check `file-notify-rm-watch' for remote files.") ;; Accessors for the callback argument. +(defun file-notify--test-event-desc (event) (car event)) +(defun file-notify--test-event-action (event) (nth 1 event)) (defun file-notify--test-event-file (event) (nth 2 event)) (defun file-notify--test-event-file1 (event) (nth 3 event)) @@ -502,14 +508,15 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." We cannot pass arguments, so we assume that `file-notify--test-event' and `file-notify--test-file' are bound somewhere." ;; Check the descriptor. - (should (equal (car file-notify--test-event) file-notify--test-desc)) + (should (equal (file-notify--test-event-desc file-notify--test-event) + file-notify--test-desc)) ;; Check the file name. (should (string-prefix-p file-notify--test-file (file-notify--test-event-file file-notify--test-event))) ;; Check the second file name if exists. - (when (eq (nth 1 file-notify--test-event) 'renamed) + (when (eq (file-notify--test-event-action file-notify--test-event) 'renamed) (should (string-prefix-p file-notify--test-file @@ -535,68 +542,72 @@ and the event to `file-notify--test-events'." file-notify--test-results (append file-notify--test-results `(,result)))))) -(defun file-notify--test-with-events-check (events) - "Check whether received events match one of the EVENTS alternatives." +(defun file-notify--test-with-actions-check (actions) + "Check whether received actions match one of the ACTIONS alternatives." (let (result) - (dolist (elt events result) + (dolist (elt actions result) (setq result (or result (if (eq (car elt) :random) (equal (sort (cdr elt) 'string-lessp) - (sort (mapcar #'cadr file-notify--test-events) + (sort (mapcar #'file-notify--test-event-action + file-notify--test-events) 'string-lessp)) - (equal elt (mapcar #'cadr file-notify--test-events)))))))) - -(defun file-notify--test-with-events-explainer (events) - "Explain why `file-notify--test-with-events-check' fails." - (if (null (cdr events)) - (format "Received events do not match expected events\n%s\n%s" - (mapcar #'cadr file-notify--test-events) (car events)) + (equal elt (mapcar #'file-notify--test-event-action + file-notify--test-events)))))))) + +(defun file-notify--test-with-actions-explainer (actions) + "Explain why `file-notify--test-with-actions-check' fails." + (if (null (cdr actions)) + (format "Received actions do not match expected actions\n%s\n%s" + (mapcar #'file-notify--test-event-action file-notify--test-events) + (car actions)) (format - "Received events do not match any sequence of expected events\n%s\n%s" - (mapcar #'cadr file-notify--test-events) events))) + "Received actions do not match any sequence of expected actions\n%s\n%s" + (mapcar #'file-notify--test-event-action file-notify--test-events) + actions))) -(put 'file-notify--test-with-events-check 'ert-explainer - 'file-notify--test-with-events-explainer) +(put 'file-notify--test-with-actions-check 'ert-explainer + 'file-notify--test-with-actions-explainer) -(defmacro file-notify--test-with-events (events &rest body) - "Run BODY collecting events and then compare with EVENTS. -EVENTS is either a simple list of events, or a list of lists of -events, which represent different possible results. The first +(defmacro file-notify--test-with-actions (actions &rest body) + "Run BODY collecting actions and then compare with ACTIONS. +ACTIONS is either a simple list of actions, or a list of lists of +actions, which represent different possible results. The first event of a list could be the pseudo event `:random', which is just an indicator for comparison. -Don't wait longer than timeout seconds for the events to be +Don't wait longer than timeout seconds for the actions to be delivered." - (declare (indent 1)) - `(let* ((events (if (consp (car ,events)) ,events (list ,events))) + (declare (indent 1) (debug (form body))) + `(let* ((actions (if (consp (car ,actions)) ,actions (list ,actions))) (max-length (apply 'max (mapcar (lambda (x) (length (if (eq (car x) :random) (cdr x) x))) - events))) + actions))) create-lockfiles) - ;; Flush pending events. + ;; Flush pending actions. (file-notify--test-read-event) - (file-notify--wait-for-events + (file-notify--test-wait-for-events (file-notify--test-timeout) (not (input-pending-p))) (setq file-notify--test-events nil file-notify--test-results nil) ,@body - (file-notify--wait-for-events - ;; More events need more time. Use some fudge factor. + (file-notify--test-wait-for-events + ;; More actions need more time. Use some fudge factor. (* (ceiling max-length 100) (file-notify--test-timeout)) (= max-length (length file-notify--test-events))) - ;; Check the result sequence just to make sure that all events + ;; Check the result sequence just to make sure that all actions ;; are as expected. (dolist (result file-notify--test-results) (when (ert-test-failed-p result) (ert-fail (cadr (ert-test-result-with-condition-condition result))))) ;; One of the possible event sequences shall match. - (should (file-notify--test-with-events-check events)))) + (should (file-notify--test-with-actions-check actions)))) (ert-deftest file-notify-test03-events () "Check file creation/change/removal notifications." @@ -613,7 +624,7 @@ delivered." (file-notify--test-add-watch file-notify--test-tmpfile '(change) #'file-notify--test-event-handler))) - (file-notify--test-with-events + (file-notify--test-with-actions (cond ;; gvfs-monitor-dir on cygwin does not detect the ;; `created' event reliably. @@ -647,7 +658,7 @@ delivered." (file-notify--test-add-watch file-notify--test-tmpfile '(change) #'file-notify--test-event-handler))) - (file-notify--test-with-events + (file-notify--test-with-actions (cond ;; gvfs-monitor-dir on cygwin does not detect the ;; `changed' event reliably. @@ -681,7 +692,7 @@ delivered." (file-notify--test-add-watch file-notify--test-tmpdir '(change) #'file-notify--test-event-handler))) - (file-notify--test-with-events + (file-notify--test-with-actions (cond ;; w32notify does not raise `deleted' and `stopped' ;; events for the watched directory. @@ -728,7 +739,7 @@ delivered." (file-notify--test-add-watch file-notify--test-tmpdir '(change) #'file-notify--test-event-handler))) - (file-notify--test-with-events + (file-notify--test-with-actions (cond ;; w32notify does not distinguish between `changed' and ;; `attribute-changed'. It does not raise `deleted' and @@ -785,7 +796,7 @@ delivered." (file-notify--test-add-watch file-notify--test-tmpdir '(change) #'file-notify--test-event-handler))) - (file-notify--test-with-events + (file-notify--test-with-actions (cond ;; w32notify does not raise `deleted' and `stopped' ;; events for the watched directory. @@ -836,7 +847,7 @@ delivered." (file-notify--test-add-watch file-notify--test-tmpfile '(attribute-change) #'file-notify--test-event-handler))) - (file-notify--test-with-events + (file-notify--test-with-actions (cond ;; w32notify does not distinguish between `changed' and ;; `attribute-changed'. Under MS Windows 7, we get four @@ -923,7 +934,7 @@ delivered." "another text" nil file-notify--test-tmpfile nil 'no-message) ;; Check, that the buffer has been reverted. - (file-notify--wait-for-events + (file-notify--test-wait-for-events timeout (string-match (format-message "Reverting buffer `%s'." (buffer-name buf)) @@ -932,7 +943,7 @@ delivered." ;; Stop file notification. Autorevert shall still work via polling. (file-notify-rm-watch auto-revert-notify-watch-descriptor) - (file-notify--wait-for-events + (file-notify--test-wait-for-events timeout (null auto-revert-notify-watch-descriptor)) (should auto-revert-use-notify) (should-not auto-revert-notify-watch-descriptor) @@ -946,7 +957,7 @@ delivered." "foo bla" nil file-notify--test-tmpfile nil 'no-message) ;; Check, that the buffer has been reverted. - (file-notify--wait-for-events + (file-notify--test-wait-for-events timeout (string-match (format-message "Reverting buffer `%s'." (buffer-name buf)) @@ -1002,7 +1013,7 @@ delivered." file-notify--test-tmpfile '(change) #'file-notify--test-event-handler))) (should (file-notify-valid-p file-notify--test-desc)) - (file-notify--test-with-events + (file-notify--test-with-actions (cond ;; gvfs-monitor-dir on cygwin does not detect the ;; `changed' event reliably. @@ -1039,7 +1050,7 @@ delivered." file-notify--test-tmpdir '(change) #'file-notify--test-event-handler))) (should (file-notify-valid-p file-notify--test-desc)) - (file-notify--test-with-events + (file-notify--test-with-actions (cond ;; w32notify does not raise `deleted' and `stopped' ;; events for the watched directory. @@ -1100,7 +1111,7 @@ delivered." ;; After removing the watch, the descriptor must not be valid ;; anymore. (file-notify-rm-watch file-notify--test-desc) - (file-notify--wait-for-events + (file-notify--test-wait-for-events (file-notify--test-timeout) (not (file-notify-valid-p file-notify--test-desc))) (should-not (file-notify-valid-p file-notify--test-desc)) @@ -1127,7 +1138,7 @@ delivered." ;; After deleting the directory, the descriptor must not be ;; valid anymore. (delete-directory file-notify--test-tmpfile 'recursive) - (file-notify--wait-for-events + (file-notify--test-wait-for-events (file-notify--test-timeout) (not (file-notify-valid-p file-notify--test-desc))) (should-not (file-notify-valid-p file-notify--test-desc)) @@ -1170,7 +1181,7 @@ delivered." (push (expand-file-name (format "y%d" i)) target-file-list)) (push (expand-file-name (format "y%d" i)) source-file-list) (push (expand-file-name (format "x%d" i)) target-file-list))) - (file-notify--test-with-events (make-list (+ n n) 'created) + (file-notify--test-with-actions (make-list (+ n n) 'created) (let ((source-file-list source-file-list) (target-file-list target-file-list)) (while (and source-file-list target-file-list) @@ -1178,7 +1189,7 @@ delivered." (write-region "" nil (pop source-file-list) nil 'no-message) (file-notify--test-read-event) (write-region "" nil (pop target-file-list) nil 'no-message)))) - (file-notify--test-with-events + (file-notify--test-with-actions (cond ;; w32notify fires both `deleted' and `renamed' events. ((string-equal (file-notify--test-library) "w32notify") @@ -1199,7 +1210,7 @@ delivered." (while (and source-file-list target-file-list) (file-notify--test-read-event) (rename-file (pop source-file-list) (pop target-file-list) t)))) - (file-notify--test-with-events (make-list n 'deleted) + (file-notify--test-with-actions (make-list n 'deleted) (dolist (file target-file-list) (file-notify--test-read-event) (delete-file file))) @@ -1233,7 +1244,7 @@ delivered." file-notify--test-tmpfile '(change) #'file-notify--test-event-handler))) (should (file-notify-valid-p file-notify--test-desc)) - (file-notify--test-with-events + (file-notify--test-with-actions ;; There could be one or two `changed' events. '((changed) (changed changed)) @@ -1269,7 +1280,7 @@ delivered." file-notify--test-tmpfile '(change) #'file-notify--test-event-handler))) (should (file-notify-valid-p file-notify--test-desc)) - (file-notify--test-with-events + (file-notify--test-with-actions (cond ;; On cygwin we only get the `changed' event. ((eq system-type 'cygwin) @@ -1345,7 +1356,7 @@ the file watch." (should-not (equal file-notify--test-desc1 file-notify--test-desc2)) (let ((n 100)) ;; Run the test. - (file-notify--test-with-events + (file-notify--test-with-actions ;; There could be one or two `changed' events. (list ;; cygwin. @@ -1387,13 +1398,13 @@ the file watch." ;; directory and the file monitor. The `stopped' event is ;; from the file monitor. It's undecided in which order the ;; the directory and the file monitor are triggered. - (file-notify--test-with-events '(:random deleted deleted stopped) + (file-notify--test-with-actions '(:random deleted deleted stopped) (delete-file file-notify--test-tmpfile1)) (should (file-notify-valid-p file-notify--test-desc1)) (should-not (file-notify-valid-p file-notify--test-desc2)) ;; Now we delete the directory. - (file-notify--test-with-events + (file-notify--test-with-actions (cond ;; In kqueue and for cygwin, just one `deleted' event for ;; the directory is received. commit 6da19c52446e5526fb2c82ac9c57a579f3170795 Author: Michael Albinus Date: Wed Jul 31 21:22:05 2019 +0200 Distinguish different file notification events * lisp/filenotify.el (file-notify--watch): Add docstring. (file-notify-descriptors, file-notify--rm-descriptor) (file-notify--pending-rename): Adapt docstring. (file-notify): New defstruct. (file-notify-handle-event): Rename argument to OBJECT. Use accessor functions of the defstruct. diff --git a/lisp/filenotify.el b/lisp/filenotify.el index e5dc353186..89bcf6baac 100644 --- a/lisp/filenotify.el +++ b/lisp/filenotify.el @@ -48,6 +48,8 @@ could use another implementation.") (:constructor nil) (:constructor file-notify--watch-make (directory filename callback))) + "The internal struct for bookkeeping watched files or directories. +Used in `file-notify-descriptors'." ;; Watched directory. directory ;; Watched relative filename, nil if watching the directory. @@ -67,13 +69,13 @@ could use another implementation.") "Hash table for registered file notification descriptors. A key in this hash table is the descriptor as returned from `inotify', `kqueue', `gfilenotify', `w32notify' or a file name -handler. The value in the hash table is `file-notify--watch' +handler. The value in the hash table is a `file-notify--watch' struct.") (defun file-notify--rm-descriptor (descriptor) "Remove DESCRIPTOR from `file-notify-descriptors'. DESCRIPTOR should be an object returned by `file-notify-add-watch'. -If it is registered in `file-notify-descriptors', a stopped event is sent." +If it is registered in `file-notify-descriptors', a `stopped' event is sent." (when-let* ((watch (gethash descriptor file-notify-descriptors))) (let ((callback (file-notify--watch-callback watch))) ;; Make sure this is the last time the callback is invoked. @@ -85,25 +87,26 @@ If it is registered in `file-notify-descriptors', a stopped event is sent." `(,descriptor stopped ,(file-notify--watch-absolute-filename watch))) (remhash descriptor file-notify-descriptors))))) -;; This function is used by `inotify', `kqueue', `gfilenotify' and -;; `w32notify' events. -;;;###autoload -(defun file-notify-handle-event (event) - "Handle file system monitoring event. -If EVENT is a filewatch event, call its callback. It has the format - - (file-notify (DESCRIPTOR ACTIONS FILE [FILE1-OR-COOKIE]) CALLBACK) +(cl-defstruct (file-notify (:type list) :named) + "A file system monitoring event, coming from the backends." + -event -callback) +;; This function is used by `inotify', `kqueue', `gfilenotify', +;; `w32notify' and remote file system handlers. Usually, we call the +;; argument `event' for such handlers. But in the following, `event' +;; means a part of the argument only, so we call the argument `object'. +;;;###autoload +(defun file-notify-handle-event (object) + "Handle a file system monitoring event, coming from backends. +If OBJECT is a filewatch event, call its callback. Otherwise, signal a `file-notify-error'." (interactive "e") (when file-notify-debug - (message "file-notify-handle-event %S" event)) - (if (and (consp event) - (eq (car event) 'file-notify) - (>= (length event) 3)) - (funcall (nth 2 event) (nth 1 event)) + (message "file-notify-handle-event %S" object)) + (if (file-notify-p object) + (funcall (file-notify--callback object) (file-notify--event object)) (signal 'file-notify-error - (cons "Not a valid file-notify event" event)))) + (cons "Not a valid file-notify-event" object)))) (cl-defstruct (file-notify--rename (:constructor nil) @@ -113,7 +116,7 @@ Otherwise, signal a `file-notify-error'." (defvar file-notify--pending-rename nil "A pending rename event awaiting the destination file name. -It is nil or a `file-notify--rename' where the cookie can be nil.") +It is nil or a `file-notify--rename' defstruct where the cookie can be nil.") (defun file-notify--expand-file-name (watch file) "Full file name of FILE reported for WATCH." @@ -284,13 +287,13 @@ DESC is the back-end descriptor. ACTIONS is a list of: (setq action 'deleted))) ((eq action 'stopped) (file-notify-rm-watch desc) - (setq actions nil) - (setq action nil)) + (setq actions nil + action nil)) ;; Make the event pending. ((eq action 'renamed-from) (setq file-notify--pending-rename - (file-notify--rename-make watch desc file file1-or-cookie)) - (setq action nil)) + (file-notify--rename-make watch desc file file1-or-cookie) + action nil)) ;; Look for pending event. ((eq action 'renamed-to) (if file-notify--pending-rename @@ -301,16 +304,16 @@ DESC is the back-end descriptor. ACTIONS is a list of: file-notify--pending-rename)) (from-file (file-notify--rename-from-file file-notify--pending-rename))) - (setq file1 file) - (setq file from-file) + (setq file1 file + file from-file) ;; If the source is handled by another watch, we ;; must fire the rename event there as well. (when (and (not (equal desc pending-desc)) callback) (funcall callback (list pending-desc 'renamed file file1))) - (setq file-notify--pending-rename nil) - (setq action 'renamed)) + (setq file-notify--pending-rename nil + action 'renamed)) (setq action 'created)))) (when action commit 82f13f83760b047a72a199ea262265b3f4d2ec04 Author: Paul Eggert Date: Wed Jul 31 10:40:44 2019 -0700 Avoid intern calls for builtin syms * src/casefiddle.c (Fdowncase_region): * src/eval.c (Fdefvaralias): Use builtin symbol rather than calling intern. diff --git a/src/casefiddle.c b/src/casefiddle.c index 3f407eaded..ee292dda9b 100644 --- a/src/casefiddle.c +++ b/src/casefiddle.c @@ -529,7 +529,7 @@ See also `capitalize-region'. */) if (!NILP (region_noncontiguous_p)) { - bounds = call1 (Fsymbol_value (intern ("region-extract-function")), + bounds = call1 (Fsymbol_value (Qregion_extract_function), intern ("bounds")); while (CONSP (bounds)) diff --git a/src/eval.c b/src/eval.c index b890aa6f7f..2e5074360d 100644 --- a/src/eval.c +++ b/src/eval.c @@ -625,7 +625,7 @@ The return value is BASE-VARIABLE. */) && !EQ (find_symbol_value (new_alias), find_symbol_value (base_variable))) call2 (intern ("display-warning"), - list3 (intern ("defvaralias"), intern ("losing-value"), new_alias), + list3 (Qdefvaralias, intern ("losing-value"), new_alias), CALLN (Fformat_message, build_string ("Overwriting value of `%s' by aliasing to `%s'"), commit 3018f6d832907e0321e90ba27397200e56fe5957 Author: Paul Eggert Date: Wed Jul 31 10:38:34 2019 -0700 Fix Fload infile problem * src/lread.c (Fload): Close window of vulnerability where the wrong stream could have been closed. diff --git a/src/lread.c b/src/lread.c index 2c0c18dd79..eec88760d4 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1083,7 +1083,7 @@ static void close_infile_unwind (void *arg) { struct infile *prev_infile = arg; - eassert (infile); + eassert (infile && infile != prev_infile); fclose (infile->stream); infile = prev_infile; } @@ -1403,6 +1403,10 @@ Return t if the file exists and loads successfully. */) #endif } + /* Declare here rather than inside the else-part because the storage + might be accessed by the unbind_to call below. */ + struct infile input; + if (is_module) { /* `module-load' uses the file name, so we can close the stream @@ -1418,6 +1422,9 @@ Return t if the file exists and loads successfully. */) if (! stream) report_file_error ("Opening stdio stream", file); set_unwind_protect_ptr (fd_index, close_infile_unwind, infile); + input.stream = stream; + input.lookahead = 0; + infile = &input; } if (! NILP (Vpurify_flag)) @@ -1443,10 +1450,6 @@ Return t if the file exists and loads successfully. */) specbind (Qinhibit_file_name_operation, Qnil); specbind (Qload_in_progress, Qt); - /* Declare here rather than inside the else-part because the storage - might be accessed by the unbind_to call below. */ - struct infile input; - if (is_module) { #ifdef HAVE_MODULES @@ -1461,10 +1464,6 @@ Return t if the file exists and loads successfully. */) } else { - input.stream = stream; - input.lookahead = 0; - infile = &input; - if (lisp_file_lexically_bound_p (Qget_file_char)) Fset (Qlexical_binding, Qt); commit 06726f6653fd2be9e33552209fceddd352a62793 Author: Stefan Monnier Date: Wed Jul 31 11:48:43 2019 -0400 * src/lread.c (close_infile_unwind): Remove leftover debug code diff --git a/src/lread.c b/src/lread.c index 23e4616b6f..2c0c18dd79 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1083,7 +1083,6 @@ static void close_infile_unwind (void *arg) { struct infile *prev_infile = arg; - fprintf (stderr, "Closing infile: back to %x!\n", prev_infile); eassert (infile); fclose (infile->stream); infile = prev_infile; commit bedcc2d87bde06482ccdc31ac7f428cbde34ced5 Author: Stefan Monnier Date: Wed Jul 31 11:19:39 2019 -0400 * src/lread.c (infile): Set/reset it like a dynamically scoped variable I've seen segfaults where `infile` is nil when we get to readbyte_from_file, presumably because Fload set it to NULL (via close_infile_unwind) just before returning to its caller which was probably itself within another read/load and for some reason readevalloop didn't get to re-set `infile` like it used to do at every iteration. I was not able to really track down the bug, but the way `infile` was set/reset seemed fragile and managing it like a standard dynamically-scoped var seems both safer (and more efficient since we don't need readevalloop to constantly re-set it). (readchar): Assert that `infile` is set if using a function the depends on it. (readbyte_from_file): Assert that `infile` is set. (close_infile_unwind): Reset `infile` to its previous value rather than to NULL. (Fload): Remember the previous value of `infile` before chaning it. (readevalloop): Don't set `infile` any more. diff --git a/src/lread.c b/src/lread.c index eecb5e141d..23e4616b6f 100644 --- a/src/lread.c +++ b/src/lread.c @@ -287,6 +287,7 @@ readchar (Lisp_Object readcharfun, bool *multibyte) if (EQ (readcharfun, Qget_file_char)) { + eassert (infile); readbyte = readbyte_from_file; goto read_multibyte; } @@ -320,6 +321,7 @@ readchar (Lisp_Object readcharfun, bool *multibyte) string, and the cdr part is a value of readcharfun given to read_vector. */ readbyte = readbyte_from_string; + eassert (infile); if (EQ (XCDR (readcharfun), Qget_emacs_mule_file_char)) emacs_mule_encoding = 1; goto read_multibyte; @@ -328,6 +330,7 @@ readchar (Lisp_Object readcharfun, bool *multibyte) if (EQ (readcharfun, Qget_emacs_mule_file_char)) { readbyte = readbyte_from_file; + eassert (infile); emacs_mule_encoding = 1; goto read_multibyte; } @@ -506,6 +509,7 @@ readbyte_from_stdio (void) static int readbyte_from_file (int c, Lisp_Object readcharfun) { + eassert (infile); if (c >= 0) { eassert (infile->lookahead < sizeof infile->buf); @@ -1078,10 +1082,11 @@ suffix_p (Lisp_Object string, const char *suffix) static void close_infile_unwind (void *arg) { - FILE *stream = arg; - eassert (infile == NULL || infile->stream == stream); - infile = NULL; - fclose (stream); + struct infile *prev_infile = arg; + fprintf (stderr, "Closing infile: back to %x!\n", prev_infile); + eassert (infile); + fclose (infile->stream); + infile = prev_infile; } DEFUN ("load", Fload, Sload, 1, 5, 0, @@ -1413,7 +1418,7 @@ Return t if the file exists and loads successfully. */) { if (! stream) report_file_error ("Opening stdio stream", file); - set_unwind_protect_ptr (fd_index, close_infile_unwind, stream); + set_unwind_protect_ptr (fd_index, close_infile_unwind, infile); } if (! NILP (Vpurify_flag)) @@ -2019,7 +2024,7 @@ readevalloop (Lisp_Object readcharfun, if (b && first_sexp) whole_buffer = (BUF_PT (b) == BUF_BEG (b) && BUF_ZV (b) == BUF_Z (b)); - infile = infile0; + eassert (!infile0 || infile == infile0); read_next: c = READCHAR; if (c == ';') commit 495d0667fcf4df9f10c261684162c64f08aadd71 Author: Paul Eggert Date: Wed Jul 31 06:56:14 2019 -0700 Clarify (lognot bignum) * doc/lispref/numbers.texi (Bitwise Operations): Say that (= (lognot n) (- -1 n)). diff --git a/doc/lispref/numbers.texi b/doc/lispref/numbers.texi index cae8babcb4..0c71387a8a 100644 --- a/doc/lispref/numbers.texi +++ b/doc/lispref/numbers.texi @@ -1072,7 +1072,8 @@ result is 0, which is an identity element for this operation. If @defun lognot integer This function returns the bitwise complement of its argument: the @var{n}th bit is one in the result if, and only if, the @var{n}th bit is zero in -@var{integer}, and vice-versa. +@var{integer}, and vice-versa. The result equals @minus{}1 @minus{} +@var{integer}. @example (lognot 5) commit c306848c0fe830127ee8d4fd936f17f341ad179b Author: Michael Albinus Date: Wed Jul 31 14:54:08 2019 +0200 Fix an error in tramp-sh-inotifywait-process-filter * lisp/net/tramp-sh.el (tramp-sh-inotifywait-process-filter): Add default FILE to returned event, if inotifywait doesn't tell us. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 6a82fef4f7..3399b961b2 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -3785,7 +3785,8 @@ file-notify events." (intern-soft (replace-regexp-in-string "_" "-" (downcase x)))) (split-string (match-string 1 line) "," 'omit)) - (match-string 3 line)))) + (or (match-string 3 line) + (file-name-nondirectory (process-get proc 'watch-name)))))) ;; Usually, we would add an Emacs event now. Unfortunately, ;; `unread-command-events' does not accept several events at ;; once. Therefore, we apply the handler directly. commit 0aa4bfaab8f7452ad1c972e60e3e0745fa16f9b6 Author: Noam Postavsky Date: Wed Jul 31 08:33:28 2019 -0400 Remove no-longer relevant xref * doc/lispref/positions.texi (List Motion): Remove xref, the text it references was removed in 2018-02-15 "Document open-paren-in-column-0-is-defun-start being of less importance". diff --git a/doc/lispref/positions.texi b/doc/lispref/positions.texi index cd9587ba4b..7e5155782c 100644 --- a/doc/lispref/positions.texi +++ b/doc/lispref/positions.texi @@ -801,8 +801,7 @@ column 0 is considered to be the start of a defun. If it is @code{nil}, an open parenthesis in column 0 has no special meaning. The default is @code{t}. If a string literal happens to have a parenthesis in column 0, escape it with a backslash to avoid a false -positive. @xref{Left Margin Paren,, Left Margin Convention, emacs, -The GNU Emacs Manual}. +positive. @end defopt @defvar beginning-of-defun-function commit 1ac0cfa2642ac026e09a7555f000e895b49289d5 Merge: 77fb84e6db 8fbe46252f Author: Glenn Morris Date: Tue Jul 30 21:42:34 2019 -0700 Merge from origin/emacs-26 8fbe462 (origin/emacs-26) ; * doc/lispref/positions.texi (List Motion... 1d9efc0 Add index for "\( in strings" (Bug#25195) 304e96f Fix doc-string of 'fit-window-to-buffer' (Bug#36848) d4c4987 Update view-mode docstring d6ca1fc ; * lisp/term.el: Add missing / to esc seq commentary. b3e2073 Fix subproc listening when setting filter to non-t (Bug#36591) f671950 * etc/NEWS.25: Belatedly announce rcirc-reconnect-delay. 7f42277 Mention term.el's \032 dir tracking in commentary (Bug#19524) 16a529e Remove upload functionality of package-x from the elisp manual 78e6c2a * etc/AUTHORS: Update. 086a56e Clarify Gravatar docs 0592467 * doc/lispref/display.texi (Defining Faces): Say a face can't... # Conflicts: # doc/emacs/programs.texi # etc/AUTHORS # lisp/term.el commit 77fb84e6db96cbaa70e230f4881e4ede6e028f15 Author: Noam Postavsky Date: Tue Jul 30 21:13:04 2019 -0400 * lisp/emacs-lisp/let-alist.el: Bump version to 1.0.6 (Bug#23244). diff --git a/lisp/emacs-lisp/let-alist.el b/lisp/emacs-lisp/let-alist.el index a9bb31113b..8831965baf 100644 --- a/lisp/emacs-lisp/let-alist.el +++ b/lisp/emacs-lisp/let-alist.el @@ -4,7 +4,7 @@ ;; Author: Artur Malabarba ;; Package-Requires: ((emacs "24.1")) -;; Version: 1.0.5 +;; Version: 1.0.6 ;; Keywords: extensions lisp ;; Prefix: let-alist ;; Separator: - commit 3a59cc84069376802ba8fd731b524d78db58262c Author: Stefan Monnier Date: Tue Jul 30 16:37:01 2019 -0400 * lisp/gnus/message.el: Reduce redundancy with send-mail-function (message-send-mail-function) : Remove `local-library` tests for libs distributed with Emacs. (message-use-send-mail-function): New function. (message-default-send-mail-function): Default to it, and remove cases already handled by it. (message--default-send-mail-function): New function. (message-send-mail-function) : Use it as new default. (message-sendmail-f-is-evil): Obey mail-specify-envelope-from if available. (message-check, message-with-reply-buffer): Use `declare`. (message-smtpmail-send-it): smtpmail accepts mail-header-separator, so simplify and declare obsolete. (message-send-mail-with-mailclient): Declare obsolete. (message-check-news-body-syntax): Don't presume that the checksum is a fixnum. diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index ea7a282b8b..30c5f7cbda 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -666,30 +666,29 @@ variable should be a regexp or a list of regexps." (defun message-send-mail-function () "Return suitable value for the variable `message-send-mail-function'." - (cond ((and (require 'sendmail) - (boundp 'sendmail-program) - sendmail-program - (executable-find sendmail-program)) - 'message-send-mail-with-sendmail) - ((and (locate-library "smtpmail") - (boundp 'smtpmail-default-smtp-server) - smtpmail-default-smtp-server) - 'message-smtpmail-send-it) - ((locate-library "mailclient") - 'message-send-mail-with-mailclient) + (declare (obsolete nil "27.1")) + (require 'sendmail) + (defvar sendmail-program) + (cond ((executable-find sendmail-program) + #'message-send-mail-with-sendmail) + ((bound-and-true-p 'smtpmail-default-smtp-server) + #'message-smtpmail-send-it) (t - (error "Don't know how to send mail. Please customize `message-send-mail-function'")))) + #'message-send-mail-with-mailclient))) (defun message-default-send-mail-function () - (cond ((eq send-mail-function 'smtpmail-send-it) 'message-smtpmail-send-it) - ((eq send-mail-function 'feedmail-send-it) 'feedmail-send-it) - ((eq send-mail-function 'sendmail-query-once) 'sendmail-query-once) - ((eq send-mail-function 'mailclient-send-it) - 'message-send-mail-with-mailclient) - (t (message-send-mail-function)))) + (cond ((eq send-mail-function #'feedmail-send-it) #'feedmail-send-it) + ((eq send-mail-function #'sendmail-query-once) #'sendmail-query-once) + ((eq send-mail-function #'sendmail-send-it) + #'message-send-mail-with-sendmail) + (t #'message-use-send-mail-function))) + +(defun message--default-send-mail-function () + "Use the setting of `send-mail-function' if applicable." + (funcall (message-default-send-mail-function))) ;; Useful to set in site-init.el -(defcustom message-send-mail-function (message-default-send-mail-function) +(defcustom message-send-mail-function #'message--default-send-mail-function "Function to call to send the current buffer as mail. The headers should be delimited by a line whose contents match the variable `mail-header-separator'. @@ -702,7 +701,9 @@ default is system dependent and determined by the function `message-send-mail-function'. See also `send-mail-function'." - :type '(radio (function-item message-send-mail-with-sendmail) + :type '(radio (function-item message--default-send-mail-function + :tag "Use send-mail-function") + (function-item message-send-mail-with-sendmail) (function-item message-send-mail-with-mh) (function-item message-send-mail-with-qmail) (function-item message-smtpmail-send-it) @@ -712,8 +713,8 @@ See also `send-mail-function'." :tag "Use Mailclient package") (function :tag "Other")) :group 'message-sending - :version "23.2" - :initialize 'custom-initialize-default + :version "27.1" + :initialize #'custom-initialize-default :link '(custom-manual "(message)Mail Variables") :group 'message-mail) @@ -834,7 +835,10 @@ symbol `never', the posting is not allowed. If it is the symbol (const never) (const ask))) -(defcustom message-sendmail-f-is-evil nil +(defcustom message-sendmail-f-is-evil + (if (boundp 'mail-specify-envelope-from) + (not mail-specify-envelope-from) + nil) "Non-nil means don't add \"-f username\" to the sendmail command line. Doing so would be even more evil than leaving it out." :group 'message-sending @@ -1920,10 +1924,10 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." "Ask QUESTION, displaying remaining args in a temporary buffer if SHOW." `(message-talkative-question 'y-or-n-p ,question ,show ,@text)) -(defmacro message-delete-line (&optional n) +(defsubst message-delete-line (&optional n) "Delete the current line (and the next N lines)." - `(delete-region (progn (beginning-of-line) (point)) - (progn (forward-line ,(or n 1)) (point)))) + (delete-region (progn (beginning-of-line) (point)) + (progn (forward-line (or n 1)) (point)))) (defun message-mark-active-p () "Non-nil means the mark and region are currently active in this buffer." @@ -2039,13 +2043,11 @@ see `message-narrow-to-headers-or-head'." (defmacro message-with-reply-buffer (&rest forms) "Evaluate FORMS in the reply buffer, if it exists." + (declare (indent 0) (debug t)) `(when (buffer-live-p message-reply-buffer) (with-current-buffer message-reply-buffer ,@forms))) -(put 'message-with-reply-buffer 'lisp-indent-function 0) -(put 'message-with-reply-buffer 'edebug-form-spec '(body)) - (defun message-fetch-reply-field (header) "Fetch field HEADER from the message we're replying to." (message-with-reply-buffer @@ -4174,13 +4176,11 @@ It should typically alter the sending method in some way or other." (defmacro message-check (type &rest forms) "Eval FORMS if TYPE is to be checked." + (declare (indent 1) (debug t)) `(or (message-check-element ,type) (save-excursion ,@forms))) -(put 'message-check 'lisp-indent-function 1) -(put 'message-check 'edebug-form-spec '(form body)) - (defun message-text-with-property (prop &optional start end reverse) "Return a list of start and end positions where the text has PROP. START and END bound the search, they default to `point-min' and @@ -4818,24 +4818,25 @@ to find out how to use this." ;; Pass it on to mh. (mh-send-letter))) +(defun message-use-send-mail-function () + (run-hooks 'message-send-mail-hook) + (funcall send-mail-function)) + (defun message-smtpmail-send-it () "Send the prepared message buffer with `smtpmail-send-it'. The only difference from `smtpmail-send-it' is that this command evaluates `message-send-mail-hook' just before sending a message. It is useful if your ISP requires the POP-before-SMTP authentication. See the Gnus manual for details." + (declare (obsolete message-use-send-mail-function "27.1")) (run-hooks 'message-send-mail-hook) - ;; Change header-delimiter to be what smtpmail expects. - (goto-char (point-min)) - (when (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (replace-match "\n")) (smtpmail-send-it)) (defun message-send-mail-with-mailclient () "Send the prepared message buffer with `mailclient-send-it'. The only difference from `mailclient-send-it' is that this command evaluates `message-send-mail-hook' just before sending a message." + (declare (obsolete message-use-send-mail-function "27.1")) (run-hooks 'message-send-mail-hook) (mailclient-send-it)) @@ -5325,7 +5326,7 @@ Otherwise, generate and save a value for `canlock-password' first." (message-check 'new-text (or (not message-checksum) - (not (eq (message-checksum) message-checksum)) + (not (equal (message-checksum) message-checksum)) (if (message-gnksa-enable-p 'quoted-text-only) (y-or-n-p "It looks like no new text has been added. Really post? ") @@ -7815,8 +7816,8 @@ Pre-defined symbols include `message-tool-bar-gnome' and (repeat :tag "User defined list" gmm-tool-bar-item) (symbol)) :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'message-tool-bar-update + :initialize #'custom-initialize-default + :set #'message-tool-bar-update :group 'message) (defcustom message-tool-bar-gnome @@ -7840,8 +7841,8 @@ Pre-defined symbols include `message-tool-bar-gnome' and See `gmm-tool-bar-from-list' for details on the format of the list." :type '(repeat gmm-tool-bar-item) :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'message-tool-bar-update + :initialize #'custom-initialize-default + :set #'message-tool-bar-update :group 'message) (defcustom message-tool-bar-retro @@ -7860,8 +7861,8 @@ See `gmm-tool-bar-from-list' for details on the format of the list." See `gmm-tool-bar-from-list' for details on the format of the list." :type '(repeat gmm-tool-bar-item) :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'message-tool-bar-update + :initialize #'custom-initialize-default + :set #'message-tool-bar-update :group 'message) (defcustom message-tool-bar-zap-list @@ -7873,8 +7874,8 @@ These items are not displayed on the message mode tool bar. See `gmm-tool-bar-from-list' for the format of the list." :type 'gmm-tool-bar-zap-list :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'message-tool-bar-update + :initialize #'custom-initialize-default + :set #'message-tool-bar-update :group 'message) (defvar image-load-path) commit add146f09f0f73f4af4760cc6205b287076c08d8 Author: Juri Linkov Date: Tue Jul 30 23:35:42 2019 +0300 * lisp/bindings.el (mode-line-defining-kbd-macro): New defvar. (minor-mode-alist): Use it for `defining-kbd-macro'. (Bug#36564) diff --git a/lisp/bindings.el b/lisp/bindings.el index 64842c4e1f..0be1458798 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -644,6 +644,11 @@ Switch to the most recently selected buffer other than the current one." (let ((indicator (car (nth 4 (car (cdr event)))))) (describe-minor-mode-from-indicator indicator))) +(defvar mode-line-defining-kbd-macro (propertize " Def" 'face 'font-lock-warning-face) + "String displayed in the mode line in keyboard macro recording mode.") +;;;###autoload +(put 'mode-line-defining-kbd-macro 'risky-local-variable t) + (defvar minor-mode-alist nil "\ Alist saying how to show minor modes in the mode line. Each element looks like (VARIABLE STRING); @@ -653,13 +658,14 @@ Actually, STRING need not be a string; any mode-line construct is okay. See `mode-line-format'.") ;;;###autoload (put 'minor-mode-alist 'risky-local-variable t) -;; Don't use purecopy here--some people want to change these strings. +;; Don't use purecopy here--some people want to change these strings, +;; also string properties are lost when put into pure space. (setq minor-mode-alist - `((abbrev-mode " Abbrev") + '((abbrev-mode " Abbrev") (overwrite-mode overwrite-mode) (auto-fill-function " Fill") ;; not really a minor mode... - (defining-kbd-macro ,(propertize " Def" 'face 'error)))) + (defining-kbd-macro mode-line-defining-kbd-macro))) ;; These variables are used by autoloadable packages. ;; They are defined here so that they do not get overridden commit f7cf9199abf53ed17a751e995e519488bb0b591b Author: Stefan Monnier Date: Tue Jul 30 16:14:10 2019 -0400 * lisp/mail/sendmail.el (sendmail-send-it): Add FIXMEs. Remove redundant :groups in the file, as well. diff --git a/lisp/mail/sendmail.el b/lisp/mail/sendmail.el index 291efab961..1da33a43eb 100644 --- a/lisp/mail/sendmail.el +++ b/lisp/mail/sendmail.el @@ -39,7 +39,6 @@ (defcustom mail-setup-with-from t "Non-nil means insert `From:' field when setting up the message." :type 'boolean - :group 'sendmail :version "22.1") (defcustom sendmail-program @@ -51,7 +50,6 @@ (t "sendmail"))) "Program used to send messages." :version "24.1" ; add executable-find, remove fakemail - :group 'mail :type 'file) ;;;###autoload @@ -72,8 +70,7 @@ Otherwise, most addresses look like `angles', but they look like (const parens) (const angles) (const default)) - :version "27.1" - :group 'sendmail) + :version "27.1") (make-obsolete-variable 'mail-from-style "only the `angles' value is valid according to RFC2822." "27.1" 'set) @@ -89,8 +86,7 @@ privileged operation. This variable affects sendmail and smtpmail -- if you use feedmail to send mail, see instead the variable `feedmail-deduce-envelope-from'." :version "21.1" - :type 'boolean - :group 'sendmail) + :type 'boolean) (defcustom mail-envelope-from nil "If non-nil, designate the envelope-from address when sending mail. @@ -102,16 +98,14 @@ being sent is used), or nil (in which case the value of :version "21.1" :type '(choice (string :tag "From-name") (const :tag "Use From: header from message" header) - (const :tag "Use `user-mail-address'" nil)) - :group 'sendmail) + (const :tag "Use `user-mail-address'" nil))) ;;;###autoload (defcustom mail-self-blind nil "Non-nil means insert Bcc to self in messages to be sent. This is done when the message is initialized, so you can remove or alter the Bcc field to override the default." - :type 'boolean - :group 'sendmail) + :type 'boolean) ;;;###autoload (defcustom mail-interactive t @@ -122,8 +116,7 @@ so you can remove or alter the Bcc field to override the default." "Non-nil means when sending a message wait for and display errors. Otherwise, let mailer send back a message to report errors." :type 'boolean - :version "23.1" ; changed from nil to t - :group 'sendmail) + :version "23.1") ; changed from nil to t (defcustom mail-yank-ignored-headers (concat "^" @@ -138,7 +131,6 @@ Otherwise, let mailer send back a message to report errors." ":") "Delete these headers from old message when it's inserted in a reply." :type 'regexp - :group 'sendmail :version "23.1") ;; Useful to set in site-init.el @@ -147,7 +139,7 @@ Otherwise, let mailer send back a message to report errors." ;; Assume smtpmail is the preferred choice if it's already configured. (if (and (boundp 'smtpmail-smtp-server) smtpmail-smtp-server) - 'smtpmail-send-it 'sendmail-query-once) + #'smtpmail-send-it #'sendmail-query-once) "Function to call to send the current buffer as mail. The headers should be delimited by a line which is not a valid RFC 822 (or later) header or continuation line, @@ -160,14 +152,12 @@ This is used by the default mail-sending commands. See also (function-item feedmail-send-it :tag "Use Feedmail package") (function-item mailclient-send-it :tag "Use Mailclient package") function) - :version "24.1" - :group 'sendmail) + :version "24.1") ;;;###autoload (defcustom mail-header-separator (purecopy "--text follows this line--") "Line used to separate headers from text in messages being composed." - :type 'string - :group 'sendmail) + :type 'string) ;; Set up mail-header-separator for use as a category text property. (put 'mail-header-separator 'rear-nonsticky '(category)) @@ -183,16 +173,14 @@ This is used by the default mail-sending commands. See also "Name of file to write all outgoing messages in, or nil for none. This is normally an mbox file, but for backwards compatibility may also be a Babyl file." - :type '(choice file (const nil)) - :group 'sendmail) + :type '(choice file (const nil))) ;;;###autoload (defcustom mail-default-reply-to nil "Address to insert as default Reply-To field of outgoing messages. If nil, it will be initialized from the REPLYTO environment variable when you first send mail." - :type '(choice (const nil) string) - :group 'sendmail) + :type '(choice (const nil) string)) (defcustom mail-alias-file nil "If non-nil, the name of a file to use instead of the sendmail default. @@ -201,8 +189,7 @@ feature from that of defining aliases in `.mailrc' to be expanded in Emacs. This variable has no effect unless your system uses sendmail as its mailer. The default file is defined in sendmail's configuration file, e.g. `/etc/aliases'." - :type '(choice (const :tag "Sendmail default" nil) file) - :group 'sendmail) + :type '(choice (const :tag "Sendmail default" nil) file)) ;;;###autoload (defcustom mail-personal-alias-file (purecopy "~/.mailrc") @@ -210,15 +197,13 @@ The default file is defined in sendmail's configuration file, e.g. This file typically should be in same format as the `.mailrc' file used by the `Mail' or `mailx' program. This file need not actually exist." - :type '(choice (const nil) file) - :group 'sendmail) + :type '(choice (const nil) file)) ;;;###autoload (defcustom mail-setup-hook nil "Normal hook, run each time a new outgoing message is initialized." :type 'hook - :options '(fortune-to-signature spook mail-abbrevs-setup) - :group 'sendmail) + :options '(fortune-to-signature spook mail-abbrevs-setup)) ;;;###autoload (defvar mail-aliases t @@ -236,15 +221,13 @@ The alias definitions in the file have this form: (defcustom mail-yank-prefix "> " "Prefix insert on lines of yanked message being replied to. If this is nil, use indentation, as specified by `mail-indentation-spaces'." - :type '(choice (const nil) string) - :group 'sendmail) + :type '(choice (const nil) string)) ;;;###autoload (defcustom mail-indentation-spaces 3 "Number of spaces to insert at the beginning of each cited line. Used by `mail-yank-original' via `mail-indent-citation'." - :type 'integer - :group 'sendmail) + :type 'integer) ;;;###autoload (defcustom mail-citation-hook nil @@ -257,8 +240,7 @@ in the cited portion of the message. If this hook is entirely empty (nil), a default action is taken instead of no action." - :type 'hook - :group 'sendmail) + :type 'hook) (defvar mail-citation-header nil "While running `mail-citation-hook', this variable holds the message header. @@ -273,7 +255,6 @@ It should match whatever sort of citation prefixes you want to handle, with whitespace before and after; it should also match just whitespace. The default value matches citations like `foo-bar>' plus whitespace." :type 'regexp - :group 'sendmail :version "24.1") (defvar mail-abbrevs-loaded nil) @@ -380,15 +361,13 @@ and should insert whatever you want to insert." :type '(choice (const :tag "None" nil) (const :tag "Use `.signature' file" t) (string :tag "String to insert") - (sexp :tag "Expression to evaluate")) - :group 'sendmail) + (sexp :tag "Expression to evaluate"))) (put 'mail-signature 'risky-local-variable t) ;;;###autoload (defcustom mail-signature-file (purecopy "~/.signature") "File containing the text inserted at end of mail buffer." - :type 'file - :group 'sendmail) + :type 'file) ;;;###autoload (defcustom mail-default-directory (purecopy "~/") @@ -398,7 +377,6 @@ This directory is used for auto-save files of Mail mode buffers. Note that Message mode does not use this variable; it auto-saves in `message-auto-save-directory'." :type '(directory :tag "Directory") - :group 'sendmail :version "22.1") (defvar mail-reply-action nil) @@ -411,16 +389,14 @@ in `message-auto-save-directory'." "A string containing header lines, to be inserted in outgoing messages. It can contain newlines, and should end in one. It is inserted before you edit the message, so you can edit or delete the lines." - :type '(choice (const nil) string) - :group 'sendmail) + :type '(choice (const nil) string)) (defcustom mail-bury-selects-summary t "If non-nil, try to show Rmail summary buffer after returning from mail. The functions \\[mail-send-on-exit] or \\[mail-dont-send] select the Rmail summary buffer before returning, if it exists and this variable is non-nil." - :type 'boolean - :group 'sendmail) + :type 'boolean) (defcustom mail-send-nonascii 'mime "Specify whether to allow sending non-ASCII characters in mail. @@ -430,14 +406,12 @@ If t, that means do allow it. nil means don't allow it. The default is `mime'. Including non-ASCII characters in a mail message can be problematical for the recipient, who may not know how to decode them properly." - :type '(choice (const t) (const nil) (const query) (const mime)) - :group 'sendmail) + :type '(choice (const t) (const nil) (const query) (const mime))) (defcustom mail-use-dsn nil "Ask MTA for notification of failed, delayed or successful delivery. Note that only some MTAs (currently only recent versions of Sendmail) support Delivery Status Notification." - :group 'sendmail :type '(repeat (radio (const :tag "Failure" failure) (const :tag "Delay" delay) (const :tag "Success" success))) @@ -506,7 +480,7 @@ This also saves the value of `send-mail-function' via Customize." ;; If send-mail-function is already setup, we're incorrectly called ;; a second time, probably because someone's using an old value ;; of send-mail-function. - (if (not (eq send-mail-function 'sendmail-query-once)) + (if (not (eq send-mail-function #'sendmail-query-once)) (funcall send-mail-function) (let ((function (sendmail-query-user-about-smtp))) (funcall function) @@ -571,8 +545,8 @@ This also saves the value of `send-mail-function' via Customize." ;;;###autoload (define-mail-user-agent 'sendmail-user-agent - 'sendmail-user-agent-compose - 'mail-send-and-exit) + #'sendmail-user-agent-compose + #'mail-send-and-exit) ;;;###autoload (defun sendmail-user-agent-compose (&optional to subject other-headers @@ -687,7 +661,6 @@ This also saves the value of `send-mail-function' via Customize." "Hook run by Mail mode. When composing a mail, this runs immediately after creating, or switching to, the `*mail*' buffer. See also `mail-setup-hook'." - :group 'sendmail :type 'hook :options '(footnote-mode)) @@ -724,10 +697,8 @@ Turning on Mail mode runs the normal hooks `text-mode-hook' and (make-local-variable 'font-lock-defaults) (setq font-lock-defaults '(mail-font-lock-keywords t t)) (make-local-variable 'paragraph-separate) - (make-local-variable 'normal-auto-fill-function) - (setq normal-auto-fill-function 'mail-mode-auto-fill) - (make-local-variable 'fill-paragraph-function) - (setq fill-paragraph-function 'mail-mode-fill-paragraph) + (setq-local normal-auto-fill-function #'mail-mode-auto-fill) + (setq-local fill-paragraph-function #'mail-mode-fill-paragraph) ;; Allow using comment commands to add/remove quoting (this only does ;; anything if mail-yank-prefix is set to a non-nil value). (set (make-local-variable 'comment-start) mail-yank-prefix) @@ -880,16 +851,14 @@ Prefix arg means don't delete this window." (defcustom mail-send-hook nil "Hook run just before sending a message." :type 'hook - :options '(flyspell-mode-off) - :group 'sendmail) + :options '(flyspell-mode-off)) ;;;###autoload (defcustom mail-mailing-lists nil "List of mailing list addresses the user is subscribed to. The variable is used to trigger insertion of the \"Mail-Followup-To\" header when sending a message to a mailing list." - :type '(repeat string) - :group 'sendmail) + :type '(repeat string)) (declare-function mml-to-mime "mml" ()) @@ -938,7 +907,7 @@ the user from the mailer." (push e l))) (split-string new-header-values ",[[:space:]]+" t)) - (mapconcat 'identity l ", ")) + (mapconcat #'identity l ", ")) "\n")) ;; Add Mail-Reply-To if none yet (unless (mail-fetch-field "mail-reply-to") @@ -1185,6 +1154,9 @@ Return non-nil if and only if some part of the header is encoded." This is a suitable value for `send-mail-function'. It sends using the external program defined by `sendmail-program'." (require 'mail-utils) + ;; FIXME: A lot of the work done here seems out-of-place (e.g. it should + ;; happen regardless of the method used to send, whether via SMTP of + ;; /usr/bin/sendmail or anything else). (let ((errbuf (if mail-interactive (generate-new-buffer " sendmail errors") 0)) @@ -1222,6 +1194,8 @@ external program defined by `sendmail-program'." (expand-mail-aliases (point-min) delimline)) (goto-char (point-min)) ;; Ignore any blank lines in the header + ;; FIXME: mail-header-end should have stopped at an empty line, + ;; so the regexp below should never match before delimline! (while (and (re-search-forward "\n\n\n*" delimline t) (< (point) delimline)) (replace-match "\n")) @@ -1346,11 +1320,11 @@ external program defined by `sendmail-program'." '("-t") ) (if mail-use-dsn - (list "-N" (mapconcat 'symbol-name + (list "-N" (mapconcat #'symbol-name mail-use-dsn ","))) ) ) - (exit-value (apply 'call-process-region args))) + (exit-value (apply #'call-process-region args))) (cond ((or (null exit-value) (eq 0 exit-value))) ((numberp exit-value) (setq error t) @@ -1818,7 +1792,7 @@ If the current line has `mail-yank-prefix', insert it on the new line." (or (bolp) (newline)) (goto-char start)))) -(define-obsolete-function-alias 'mail-attach-file 'mail-insert-file "24.1") +(define-obsolete-function-alias 'mail-attach-file #'mail-insert-file "24.1") (declare-function mml-attach-file "mml" (file &optional type description disposition)) commit 01739625704aaaea6831cef459a4a53171689513 Merge: 056cbcb7a9 9b480db673 Author: Stephen Leake Date: Tue Jul 30 11:03:15 2019 -0700 Merge commit '9b480db6732c6d2e886838f112d9bd46fc8989bf' commit 056cbcb7a959463290bc91c19b909cbf3eb47d0a Author: Stephen Leake Date: Tue Jul 30 11:02:03 2019 -0700 Improve doc strings for some -search-path variables * lisp/emacs-lisp/bytecomp.el (emacs-lisp-compilation-search-path): Improve doc string. * lisp/progmodes/compile.el (compilation-search-path): Improve doc string. * lisp/progmodes/grep.el (grep-search-path): Improve doc string. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 431525431a..125344b779 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1037,9 +1037,10 @@ If STR is something like \"Buffer foo.el\", return # we go into emacs-lisp-compilation-mode.") (defcustom emacs-lisp-compilation-search-path '(nil) - "Search path for byte-compile error messages. -Elements should be directory names, not file names of directories. -The value nil as an element means to try the default directory." + "Directories to search for files named in byte-compile error messages. +Value should be a list of directory names, not file names of +directories. The value nil as an element means the byte-compile +message buffer `default-directory'." :version "27.1" :type '(repeat (choice (const :tag "Default" nil) (string :tag "Directory")))) diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 4b2fc516c3..7537525a06 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -677,8 +677,9 @@ of `my-compilation-root' here." ;;;###autoload (defcustom compilation-search-path '(nil) "List of directories to search for source files named in error messages. -Elements should be directory names, not file names of directories. -The value nil as an element means to try the default directory." +Elements should be directory names, not file names of +directories. The value nil as an element means the error +message buffer `default-directory'." :type '(repeat (choice (const :tag "Default" nil) (string :tag "Directory")))) diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index 67222f7862..306ae8fd50 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -442,9 +442,10 @@ abbreviated part can also be toggled with :group 'grep) (defcustom grep-search-path '(nil) - "Search path for grep results. -Elements should be directory names, not file names of directories. -The value nil as an element means to try the default directory." + "List of directories to search for files named in grep messages. +Elements should be directory names, not file names of +directories. The value nil as an element means the grep messages +buffer `default-directory'." :group 'grep :version "27.1" :type '(repeat (choice (const :tag "Default" nil) commit 8fbe46252f5f241d274b59c6b1aaecd3ee58cc6a Author: Eli Zaretskii Date: Tue Jul 30 17:50:32 2019 +0300 ; * doc/lispref/positions.texi (List Motion): Fix last change. diff --git a/doc/lispref/positions.texi b/doc/lispref/positions.texi index a5a51f0a0b..cd9587ba4b 100644 --- a/doc/lispref/positions.texi +++ b/doc/lispref/positions.texi @@ -800,9 +800,9 @@ If this variable's value is non-@code{nil}, an open parenthesis in column 0 is considered to be the start of a defun. If it is @code{nil}, an open parenthesis in column 0 has no special meaning. The default is @code{t}. If a string literal happens to have a -parenthesis in column 0, escape it with backslash to avoid a false -positive, @xref{Left Margin Paren,, Left Margin Convention, emacs, The -GNU Emacs Manual}. +parenthesis in column 0, escape it with a backslash to avoid a false +positive. @xref{Left Margin Paren,, Left Margin Convention, emacs, +The GNU Emacs Manual}. @end defopt @defvar beginning-of-defun-function commit 9b480db6732c6d2e886838f112d9bd46fc8989bf Author: Lars Ingebrigtsen Date: Tue Jul 30 16:07:38 2019 +0200 Make `C-u RET' on URLs in Gnus buffers use the secondary browser * lisp/gnus/gnus-art.el (gnus-button-alist): Make `C-u RET' on URLs use the secondary browse-url browser. diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 6d297d4c1d..8f5a313c61 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -7739,7 +7739,7 @@ positives are possible." 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) ;; Raw URLs. (gnus-button-url-regexp - 0 (>= gnus-button-browse-level 0) browse-url 0) + 0 (>= gnus-button-browse-level 0) browse-url-button-open-url 0) ;; man pages ("\\b\\([a-z][a-z]+([1-9])\\)\\W" 0 (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3)) commit 08953259b9e6e8f41b68a47cdec99e56e5cc9f6f Author: Lars Ingebrigtsen Date: Tue Jul 30 16:06:51 2019 +0200 Tweak `browse-url-add-buttons' for better button.el comp * lisp/net/browse-url.el (browse-url-add-buttons): Make browse-url buttons be understood by `forward-button' and the like. diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index c5bd415fe7..6382e66f61 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -1675,6 +1675,7 @@ clickable and will use `browse-url' to open the URLs in question." keymap ,browse-url-button-map face browse-url-button button t + category browse-url browse-url-data ,(match-string 0))))))) (defun browse-url-button-open (&optional external mouse-event) commit 8bd6245e56f04181286620d8497e68e8b1c4f684 Author: Lars Ingebrigtsen Date: Tue Jul 30 16:06:00 2019 +0200 Add a new conveniency function to browse-url * lisp/net/browse-url.el (browse-url-button-open-url): Add a new conveniency function. diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 37995a4660..c5bd415fe7 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -1690,6 +1690,14 @@ external browser instead of the default one." (funcall browse-url-secondary-browser-function url) (browse-url url)))) +(defun browse-url-button-open-url (url) + "Open URL using `browse-url'. +If `current-prefix-arg' is non-nil, use +`browse-url-secondary-browser-function' instead." + (if current-prefix-arg + (funcall browse-url-secondary-browser-function url) + (browse-url url))) + (defun browse-url-button-copy () "Copy the URL under point" (interactive) commit 0b79445f55274f7c0c4f9d4d63931321a4c82a97 Author: Dmitry Gutov Date: Tue Jul 30 16:59:32 2019 +0300 Support filename matches in etags xref backend * lisp/progmodes/etags.el (etags--xref-find-definitions): Support filename matches (bug#32510). diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index 7bf575340e..a052ad2ce5 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -2070,14 +2070,15 @@ for \\[find-tag] (which see)." (beginning-of-line) (pcase-let* ((tag-info (etags-snarf-tag)) (`(,hint ,line . _) tag-info)) - (unless (eq hint t) ; hint==t if we are in a filename line - (let* ((file (file-of-tag)) - (mark-key (cons file line))) - (unless (gethash mark-key marks) - (let ((loc (xref-make-etags-location - tag-info (expand-file-name file)))) - (push (xref-make hint loc) xrefs) - (puthash mark-key t marks))))))))))) + (let* ((file (file-of-tag)) + (mark-key (cons file line))) + (unless (gethash mark-key marks) + (let ((loc (xref-make-etags-location + tag-info (expand-file-name file)))) + (push (xref-make (if (eq hint t) "(filename match)" hint) + loc) + xrefs) + (puthash mark-key t marks)))))))))) (nreverse xrefs))) (defclass xref-etags-location (xref-location) commit 4fe88791df32f083ae329a0f4415fc29b599e9c5 Author: Dmitry Gutov Date: Tue Jul 30 16:56:43 2019 +0300 ; Re-enable all Flymake tests on Hydra To see if the recent improvements fixed something diff --git a/test/lisp/progmodes/flymake-tests.el b/test/lisp/progmodes/flymake-tests.el index 224c57e78a..f1d8b3a423 100644 --- a/test/lisp/progmodes/flymake-tests.el +++ b/test/lisp/progmodes/flymake-tests.el @@ -111,7 +111,6 @@ SEVERITY-PREDICATE is used to setup (ert-deftest perl-backend () "Test the perl backend" (skip-unless (executable-find "perl")) - (skip-unless (not (getenv "EMACS_HYDRA_CI"))) (flymake-tests--with-flymake ("test.pl") (flymake-goto-next-error) (should (eq 'flymake-warning (face-at-point))) @@ -123,7 +122,6 @@ SEVERITY-PREDICATE is used to setup (ert-deftest ruby-backend () "Test the ruby backend" (skip-unless (executable-find "ruby")) - (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ;; Some versions of ruby fail if HOME doesn't exist (bug#29187). (let* ((tempdir (make-temp-file "flymake-tests-ruby" t)) (process-environment (cons (format "HOME=%s" tempdir) @@ -169,7 +167,6 @@ SEVERITY-PREDICATE is used to setup (ert-deftest included-c-header-files () "Test inclusion of .h header files." (skip-unless (and (executable-find "gcc") (executable-find "make"))) - (skip-unless (not (getenv "EMACS_HYDRA_CI"))) (let ((flymake-wrap-around nil)) (flymake-tests--with-flymake ("some-problems.h") @@ -295,7 +292,6 @@ SEVERITY-PREDICATE is used to setup (ert-deftest recurrent-backend () "Test a backend that calls REPORT-FN multiple times" - (skip-unless (not (getenv "EMACS_HYDRA_CI"))) (with-temp-buffer (let (tick) (cl-letf commit 56db1e84a09b887539adf2b24479d58ddaad5843 Author: Dmitry Gutov Date: Tue Jul 30 16:55:33 2019 +0300 Guard against flymake-no-changes-timeout being nil * test/lisp/progmodes/flymake-tests.el (flymake-tests--wait-for-backends): Guard against flymake-no-changes-timeout being nil (in personal configurations) to help when running tests interactively. diff --git a/test/lisp/progmodes/flymake-tests.el b/test/lisp/progmodes/flymake-tests.el index af9729028c..224c57e78a 100644 --- a/test/lisp/progmodes/flymake-tests.el +++ b/test/lisp/progmodes/flymake-tests.el @@ -52,7 +52,7 @@ (flymake-reporting-backends)) while notdone unless noninteractive do (read-event "" nil 0.1) - do (sleep-for (+ 0.5 flymake-no-changes-timeout)) + do (sleep-for (+ 0.5 (or flymake-no-changes-timeout 0))) finally (when notdone (ert-skip (format "Some backends not reporting yet %s" notdone))))) commit 075a3e0570f1e962ffe30f533f45a5af20e515ba Author: Lars Ingebrigtsen Date: Tue Jul 30 15:36:03 2019 +0200 Call out the Gnus widget->button makeover in NEWS diff --git a/etc/NEWS b/etc/NEWS index 5414958ad1..7dfb08256f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1009,6 +1009,14 @@ offers them to the user to open with 'browse-url'. This option controls whether and how to use Gnus search groups as 'path:' search terms to 'notmuch'. +--- ++++ The buttons in the Gnus article buffer were formerly widgets +(i.e., buttons from widget.el). This has now changed, and they are +now buttons (from button.el), and commands like 'TAB' now search for +buttons instead of widgets. There should be no user-visible changes, +but out-of-tree code that relied on widgets being present might now +fail. + ** erc --- commit f90ef53aa05e407dbae1b497f74b002ff8341f33 Author: Lars Ingebrigtsen Date: Tue Jul 30 15:24:55 2019 +0200 Convert Emacs article buffers from widget.el to button.el * lisp/gnus/gnus-art.el (gnus-mime-button-map) (gnus-url-button-commands, gnus-insert-mime-button) (gnus-mime-display-alternative) (gnus-article-extend-url-button, gnus-article-add-button) (gnus-insert-prev-page-button, gnus-insert-next-page-button) (gnus-mime-security-button-map) (gnus-insert-mime-security-button): Ditto. * lisp/gnus/gnus-html.el (gnus-html-displayed-image-map) (gnus-html-wash-images, gnus-html-put-image): Ditto. * lisp/gnus/gnus-icalendar.el (gnus-icalendar-insert-button): Ditto. * lisp/gnus/gnus-sum.el (gnus-summary-widget-forward) (gnus-summary-button-forward, gnus-summary-widget-backward) (gnus-summary-button-backward, gnus-collect-urls-primary-text) (gnus-collect-urls, gnus-summary-browse-url): Stop using widgets and star using button.el buttons instead. * lisp/gnus/mm-decode.el (mm-shr, mm-handle-filename): Don't convert shr buttons into widgets. diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index a38300ef66..6d297d4c1d 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -4381,7 +4381,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is ;;; Gnus article mode ;;; -(set-keymap-parent gnus-article-mode-map widget-keymap) +(set-keymap-parent gnus-article-mode-map button-buffer-map) (gnus-define-keys gnus-article-mode-map " " gnus-article-goto-next-page @@ -4874,6 +4874,7 @@ General format specifiers can also be used. See Info node (defvar gnus-mime-button-map (let ((map (make-sparse-keymap))) + (define-key map "\r" 'gnus-article-push-button) (define-key map [mouse-2] 'gnus-article-push-button) (define-key map [down-mouse-3] 'gnus-mime-button-menu) (dolist (c gnus-mime-button-commands) @@ -4888,7 +4889,9 @@ General format specifiers can also be used. See Info node gnus-mime-button-commands))) (defvar gnus-url-button-commands - '((gnus-article-copy-string "u" "Copy URL to kill ring"))) + '((gnus-article-copy-string "u" "Copy URL to kill ring") + (push-button "\r" "Push the button") + (push-button [mouse-2] "Push the button"))) (defvar gnus-url-button-map (let ((map (make-sparse-keymap))) @@ -5849,26 +5852,12 @@ all parts." ;; Exclude a newline. (1- (point)) (point))) - (when gnus-article-button-face - (overlay-put (make-overlay b e nil t) - 'face gnus-article-button-face)) - (widget-convert-button - 'link b e - :mime-handle handle - :action 'gnus-widget-press-button - :button-keymap gnus-mime-button-map - :help-echo - (lambda (widget) - (format - "%S: %s the MIME part; %S: more options" - 'mouse-2 - (if (mm-handle-displayed-p (widget-get widget :mime-handle)) - "hide" "show") - 'down-mouse-3))))) - -(defun gnus-widget-press-button (elems _el) - (goto-char (widget-get elems :from)) - (gnus-article-press-button)) + (make-text-button + b e + 'keymap gnus-mime-button-map + 'face gnus-article-button-face + 'help-echo + "mouse-2: toggle the MIME part; down-mouse-3: more options"))) (defvar gnus-displaying-mime nil) @@ -6151,10 +6140,9 @@ If nil, don't show those extra buttons." mouse-face ,gnus-article-mouse-face face ,gnus-article-button-face gnus-part ,id + button t article-type multipart rear-nonsticky t)) - (widget-convert-button 'link from (point) - :action 'gnus-widget-press-button) ;; Do the handles (while (setq handle (pop handles)) (add-text-properties @@ -6175,10 +6163,9 @@ If nil, don't show those extra buttons." mouse-face ,gnus-article-mouse-face face ,gnus-article-button-face gnus-part ,id + button t gnus-data ,handle rear-nonsticky t)) - (widget-convert-button 'link from (point) - :action 'gnus-widget-press-button) (insert " ")) (insert "\n\n")) (when preferred @@ -8025,7 +8012,7 @@ url is put as the `gnus-button-url' overlay property on the button." (match-beginning 1)) points))))) (match-beginning 2))) - (let (gnus-article-mouse-face widget-mouse-face) + (let (gnus-article-mouse-face) (while points (gnus-article-add-button (pop points) (pop points) 'gnus-button-push @@ -8074,18 +8061,19 @@ url is put as the `gnus-button-url' overlay property on the button." (defun gnus-article-add-button (from to fun &optional data text) "Create a button between FROM and TO with callback FUN and data DATA." - (when gnus-article-button-face - (overlay-put (make-overlay from to nil t) - 'face gnus-article-button-face)) (add-text-properties from to (nconc (and gnus-article-mouse-face (list 'mouse-face gnus-article-mouse-face)) - (list 'gnus-callback fun) + (list 'gnus-callback fun + 'button-data data + 'action fun + 'keymap gnus-url-button-map + 'category t + 'button t) (and data (list 'gnus-data data)))) - (widget-convert-button 'link from to :action 'gnus-widget-press-button - :help-echo (or text "Follow the link") - :keymap gnus-url-button-map)) + (when gnus-article-button-face + (add-face-text-property from to gnus-article-button-face t))) (defun gnus-article-copy-string () "Copy the string in the button to the kill ring." @@ -8413,13 +8401,8 @@ url is put as the `gnus-button-url' overlay property on the button." ;; Exclude a newline. (1- (point)) (point))) - (when gnus-article-button-face - (overlay-put (make-overlay b e nil t) - 'face gnus-article-button-face)) - (widget-convert-button - 'link b e - :action 'gnus-button-prev-page - :button-keymap gnus-prev-page-map))) + (make-text-button b e 'keymap gnus-prev-page-map + 'face gnus-article-button-face))) (defun gnus-button-next-page (&optional _args _more-args) "Go to the next page." @@ -8449,13 +8432,8 @@ url is put as the `gnus-button-url' overlay property on the button." ;; Exclude a newline. (1- (point)) (point))) - (when gnus-article-button-face - (overlay-put (make-overlay b e nil t) - 'face gnus-article-button-face)) - (widget-convert-button - 'link b e - :action 'gnus-button-next-page - :button-keymap gnus-next-page-map))) + (make-text-button b e 'keymap gnus-next-page-map + 'face gnus-article-button-face))) (defun gnus-article-button-next-page (_arg) "Go to the next page." @@ -8708,6 +8686,7 @@ For example: (defvar gnus-mime-security-button-map (let ((map (make-sparse-keymap))) + (define-key map "\r" 'gnus-article-push-button) (define-key map [mouse-2] 'gnus-article-push-button) (define-key map [down-mouse-3] 'gnus-mime-security-button-menu) (dolist (c gnus-mime-security-button-commands) @@ -8843,20 +8822,8 @@ For example: ;; Exclude a newline. (1- (point)) (point))) - (when gnus-article-button-face - (overlay-put (make-overlay b e nil t) - 'face gnus-article-button-face)) - (widget-convert-button - 'link b e - :mime-handle handle - :action 'gnus-widget-press-button - :button-keymap gnus-mime-security-button-map - :help-echo - (lambda (_widget) - (format - "%S: show detail; %S: more options" - 'mouse-2 - 'down-mouse-3))))) + (make-text-button b e 'keymap gnus-mime-security-button-map + 'face gnus-article-button-face))) (defun gnus-mime-display-security (handle) (save-restriction diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el index f36c389787..92d760f4bf 100644 --- a/lisp/gnus/gnus-html.el +++ b/lisp/gnus/gnus-html.el @@ -84,7 +84,7 @@ fit these criteria." (define-key map "i" 'gnus-html-browse-image) (define-key map "\r" 'gnus-html-browse-url) (define-key map "u" 'gnus-article-copy-string) - (define-key map [tab] 'widget-forward) + (define-key map [tab] 'button-forward) map)) (defun gnus-html-encode-url (url) @@ -180,12 +180,10 @@ fit these criteria." 'image-displayer `(lambda (url start end) (gnus-html-display-image url start end ,alt-text)) + 'help-echo alt-text + 'button t + 'keymap gnus-html-image-map 'gnus-image (list url start end alt-text))) - (widget-convert-button - 'url-link start (point) - :help-echo alt-text - :keymap gnus-html-image-map - url) (if (string-match "\\`cid:" url) ;; URLs with cid: have their content stashed in other ;; parts of the MIME structure, so just insert them @@ -207,21 +205,15 @@ fit these criteria." (delete-region start end)) "*") 'cid)) - (widget-convert-button - 'link start end - :action 'gnus-html-insert-image - :help-echo url - :keymap gnus-html-image-map - :button-keymap gnus-html-image-map))) + (make-text-button start end + 'help-echo url + 'keymap gnus-html-image-map))) ;; Normal, external URL. (if (or inhibit-images (gnus-html-image-url-blocked-p url blocked-images)) - (widget-convert-button - 'link start end - :action 'gnus-html-insert-image - :help-echo url - :keymap gnus-html-image-map - :button-keymap gnus-html-image-map) + (make-text-button start end + 'help-echo url + 'keymap gnus-html-image-map) ;; Non-blocked url (let ((width (when (string-match "width=\"?\\([0-9]+\\)" parameters) @@ -444,11 +436,9 @@ Return a string with image data." (let ((image (gnus-rescale-image image (gnus-html-maximum-image-size)))) (delete-region start end) (gnus-put-image image alt-text 'external) - (widget-convert-button - 'url-link start (point) - :help-echo alt-text - :keymap gnus-html-displayed-image-map - url) + (make-text-button start (point) + 'help-echo alt-text + 'keymap gnus-html-displayed-image-map) (put-text-property start (point) 'gnus-alt-text alt-text) (when url (add-text-properties diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index 402e233d7f..529cafe23e 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -777,9 +777,8 @@ These will be used to retrieve the RSVP information from ical events." ,callback keymap ,gnus-mime-button-map face ,gnus-article-button-face - gnus-data ,data)) - (widget-convert-button 'link start (point) - :action 'gnus-widget-press-button))) + button t + gnus-data ,data)))) (defun gnus-icalendar-send-buffer-by-mail (buffer-name subject) (let ((message-signature nil)) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 320130f49b..73f0eb3918 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -9410,7 +9410,9 @@ Obeys the standard process/prefix convention." (t (error "Couldn't select virtual nndoc group"))))) -(defun gnus-summary-widget-forward (arg) +(define-obsolete-function-alias 'gnus-summary-widget-forward + #'gnus-summary-button-forward "27.1") +(defun gnus-summary-button-forward (arg) "Move point to the next field or button in the article. With optional ARG, move across that many fields." (interactive "p") @@ -9420,9 +9422,11 @@ With optional ARG, move across that many fields." (error "No article window found")))) (select-window win) (select-frame-set-input-focus (window-frame win)) - (widget-forward arg))) + (forward-button arg))) -(defun gnus-summary-widget-backward (arg) +(define-obsolete-function-alias 'gnus-summary-widget-backward + #'gnus-summary-button-backward "27.1") +(defun gnus-summary-button-backward (arg) "Move point to the previous field or button in the article. With optional ARG, move across that many fields." (interactive "p") @@ -9432,30 +9436,28 @@ With optional ARG, move across that many fields." (error "No article window found")))) (select-window win) (select-frame-set-input-focus (window-frame win)) - (unless (widget-at (point)) + (unless (button-at (point)) (goto-char (point-max))) - (widget-backward arg))) + (backward-button arg))) (defcustom gnus-collect-urls-primary-text "Link" - "The widget text for the default link in `gnus-summary-browse-url'." + "The button text for the default link in `gnus-summary-browse-url'." :version "27.1" :type 'string :group 'gnus-article-various) (defun gnus-collect-urls () "Return the list of URLs in the buffer after (point). -The 1st element is the widget named by `gnus-collect-urls-primary-text'." +The 1st element is the button named by `gnus-collect-urls-primary-text'." (let ((pt (point)) urls primary) - (while (progn (widget-move 1 t) ; no echo - ;; `widget-move' wraps around to top of buffer. - (> (point) pt)) + (while (forward-button 1 nil nil t) (setq pt (point)) - (when-let ((w (widget-at pt)) - (u (or (widget-value w) + (when-let ((w (button-at pt)) + (u (or (button-get w 'shr-url) (get-text-property pt 'gnus-string)))) (when (string-match-p "\\`[[:alpha:]]+://" u) (if (and gnus-collect-urls-primary-text (null primary) - (string= gnus-collect-urls-primary-text (widget-text w))) + (string= gnus-collect-urls-primary-text (button-label w))) (setq primary u) (push u urls))))) (setq urls (nreverse urls)) @@ -9489,7 +9491,7 @@ default." (gnus-summary-select-article) (gnus-with-article-buffer (article-goto-body) - ;; Back up a char, in case body starts with a widget. + ;; Back up a char, in case body starts with a button. (backward-char) (setq urls (gnus-collect-urls)) (setq target diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index c73bec0f19..cba9633b53 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -1829,7 +1829,6 @@ text/html;\\s-*charset=\\([^\t\n\r \"'>]+\\)[^>]*>" nil t) (shr-insert-document document) (unless (bobp) (insert "\n")) - (mm-convert-shr-links) (mm-handle-set-undisplayer handle (let ((min (point-min-marker)) @@ -1838,40 +1837,6 @@ text/html;\\s-*charset=\\([^\t\n\r \"'>]+\\)[^>]*>" nil t) (let ((inhibit-read-only t)) (delete-region min max)))))))) -(defvar shr-image-map) -(defvar shr-map) -(autoload 'widget-convert-button "wid-edit") -(defvar widget-keymap) - -(defun mm-convert-shr-links () - (let ((start (point-min)) - end keymap) - (while (and start - (< start (point-max))) - (when (setq start (text-property-not-all start (point-max) 'shr-url nil)) - (setq end (next-single-property-change start 'shr-url nil (point-max))) - (widget-convert-button - 'url-link start end - :help-echo (get-text-property start 'help-echo) - :keymap (setq keymap (copy-keymap - (if (mm-images-in-region-p start end) - shr-image-map - shr-map))) - (get-text-property start 'shr-url)) - ;; Mask keys that launch `widget-button-click'. - ;; Those bindings are provided by `widget-keymap' - ;; that is a parent of `gnus-article-mode-map'. - (dolist (key (where-is-internal 'widget-button-click widget-keymap)) - (unless (lookup-key keymap key) - (define-key keymap key #'ignore))) - ;; Avoid `shr-next-link' and `shr-previous-link' in `keymap' so - ;; TAB and M-TAB run `widget-forward' and `widget-backward' instead. - (substitute-key-definition 'shr-next-link nil keymap) - (substitute-key-definition 'shr-previous-link nil keymap) - (dolist (overlay (overlays-at start)) - (overlay-put overlay 'face nil)) - (setq start end))))) - (defun mm-handle-filename (handle) "Return filename of HANDLE if any." (or (mail-content-type-get (mm-handle-type handle) commit e619a6b33838488a35a39200fc180811a31ab444 Author: Lars Ingebrigtsen Date: Tue Jul 30 15:23:22 2019 +0200 Mark shr buttons as button.el buffers * lisp/net/shr.el (shr-urlify): Mark buttons as button.el buffers for easier reuse in buttonified buffers. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 7555d6c6ae..fbd1a9b766 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -1207,6 +1207,8 @@ START, and END. Note that START and END should be markers." (add-text-properties start (point) (list 'shr-url url + 'button t + 'category 'shr ; For button.el button buffers. 'help-echo (let ((parsed (url-generic-parse-url (or (ignore-errors (decode-coding-string commit 4121b2ee5506538a5fac2c7d91431b87aa2a3139 Author: Lars Ingebrigtsen Date: Tue Jul 30 15:22:01 2019 +0200 Convert ` to ' in two recent NEWS entries diff --git a/etc/NEWS b/etc/NEWS index cdf4bb2904..5414958ad1 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -536,7 +536,7 @@ be functions. its functions. +++ -*** `cl-defstruct' slots accept a ':documentation' property +*** 'cl-defstruct' slots accept a ':documentation' property --- *** 'cl-values-list' will now signal an error if its argument isn't a list. @@ -2095,11 +2095,11 @@ with POSIX.1-2017. accessors can be used. +++ -*** The new functions `date-days-in-month' (which will say how many -days there are in a month in a specific year), `date-ordinal-to-time' -(that computes the date of an ordinal day), `decoded-time-add' for +*** The new functions 'date-days-in-month' (which will say how many +days there are in a month in a specific year), 'date-ordinal-to-time' +(that computes the date of an ordinal day), 'decoded-time-add' for doing computations on a decoded time structure), and -`make-decoded-time' (for making a decoded time structure with only the +'make-decoded-time' (for making a decoded time structure with only the given keywords filled out) have been added. ** 'define-minor-mode' automatically documents the meaning of ARG. commit b75fb81e362b8afbf37da0d2480676269430694c Author: Lars Ingebrigtsen Date: Tue Jul 30 15:21:29 2019 +0200 Extend button.el to take callback data * doc/lispref/display.texi (Button Buffer Commands) (Button Buffer Commands): Document this. * lisp/button.el (backward-button, forward-button): Accept a NO-ERROR parameter. (button-activate): Make it possible to have specific data in the callback action. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 3c91092906..cf0008df86 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -6473,7 +6473,9 @@ that is the value of that property, passing it the single argument @var{button}). If @var{use-mouse-action} is non-@code{nil}, try to invoke the button's @code{mouse-action} property instead of @code{action}; if the button has no @code{mouse-action} property, use -@code{action} as normal. +@code{action} as normal. If the @code{button-data} property is +present in @var{button}, use that as the argument for the +@code{action} function instead of @var{button}. @end defun @defun button-label button @@ -6541,14 +6543,16 @@ event's position is used. If there's no button at @var{pos}, do nothing and return @code{nil}, otherwise return @code{t}. @end deffn -@deffn Command forward-button n &optional wrap display-message +@deffn Command forward-button n &optional wrap display-message no-error Move to the @var{n}th next button, or @var{n}th previous button if @var{n} is negative. If @var{n} is zero, move to the start of any button at point. If @var{wrap} is non-@code{nil}, moving past either end of the buffer continues from the other end. If @var{display-message} is non-@code{nil}, the button's help-echo string is displayed. Any button with a non-@code{nil} @code{skip} property -is skipped over. Returns the button found. +is skipped over. Returns the button found, and signals an error if no +buttons can be found. If @var{no-error} in non-@code{nil}, return nil +instead of signalling the error. @end deffn @deffn Command backward-button n &optional wrap display-message @@ -6558,7 +6562,9 @@ button at point. If @var{wrap} is non-@code{nil}, moving past either end of the buffer continues from the other end. If @var{display-message} is non-@code{nil}, the button's help-echo string is displayed. Any button with a non-@code{nil} @code{skip} property -is skipped over. Returns the button found. +is skipped over. Returns the button found, and signals an error if no +buttons can be found. If @var{no-error} in non-@code{nil}, return nil +instead of signalling the error. @end deffn @defun next-button pos &optional count-current diff --git a/etc/NEWS b/etc/NEWS index 1587eab1e2..cdf4bb2904 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1968,6 +1968,12 @@ valid event type. * Lisp Changes in Emacs 27.1 ++++ +** Buttons (created with 'make-button' and related functions) can +now use the 'button-data' property. If present, the data in this +property will be passed on to the 'action' function instead of the +button itself in 'button-activate'. + ** 'defcustom' now takes a ':local' keyword that can be either t or 'permanent', which mean that the variable should be automatically buffer-local. 'permanent' also sets the variable's 'permanent-local' diff --git a/lisp/button.el b/lisp/button.el index 921e84dfa6..ca6f0d3b6e 100644 --- a/lisp/button.el +++ b/lisp/button.el @@ -235,15 +235,19 @@ The action can either be a marker or a function. If it's a marker then goto it. Otherwise if it is a function then it is called with BUTTON as only argument. BUTTON is either an overlay, a buffer position, or (for buttons in the mode-line or -header-line) a string." +header-line) a string. + +If BUTTON has a `button-data' value, call the function with this +value instad of BUTTON." (let ((action (or (and use-mouse-action (button-get button 'mouse-action)) - (button-get button 'action)))) + (button-get button 'action))) + (data (button-get button 'button-data))) (if (markerp action) (save-selected-window (select-window (display-buffer (marker-buffer action))) (goto-char action) (recenter 0)) - (funcall action button)))) + (funcall action (or data button))))) (defun button-label (button) "Return BUTTON's text label." @@ -324,6 +328,10 @@ using `make-text-button'. Note, however, that if there is an existing face property at the site of the button, the button face may not be visible. You may want to use `make-button' in that case. +If the property `button-data' is present, it will later be used +as the argument for the `action' callback function instead of the +default argument, which is the button itself. + BEG can also be a string, in which case it is made into a button. Also see `insert-text-button'." @@ -462,13 +470,17 @@ return t." (button-activate button use-mouse-action) t)))) -(defun forward-button (n &optional wrap display-message) +(defun forward-button (n &optional wrap display-message no-error) "Move to the Nth next button, or Nth previous button if N is negative. If N is 0, move to the start of any button at point. If WRAP is non-nil, moving past either end of the buffer continues from the other end. If DISPLAY-MESSAGE is non-nil, the button's help-echo string is displayed. Any button with a non-nil `skip' property is skipped over. + +If NO-ERROR, return nil if no further buttons could be found +instead of erroring out. + Returns the button found." (interactive "p\nd\nd") (let (button) @@ -497,22 +509,28 @@ Returns the button found." (unless (button-get button 'skip) (setq n (1- n))))))) (if (null button) - (user-error (if wrap "No buttons!" "No more buttons")) + (if no-error + nil + (user-error (if wrap "No buttons!" "No more buttons"))) (let ((msg (and display-message (button-get button 'help-echo)))) (when msg (message "%s" msg))) button))) -(defun backward-button (n &optional wrap display-message) +(defun backward-button (n &optional wrap display-message no-error) "Move to the Nth previous button, or Nth next button if N is negative. If N is 0, move to the start of any button at point. If WRAP is non-nil, moving past either end of the buffer continues from the other end. If DISPLAY-MESSAGE is non-nil, the button's help-echo string is displayed. Any button with a non-nil `skip' property is skipped over. + +If NO-ERROR, return nil if no further buttons could be found +instead of erroring out. + Returns the button found." (interactive "p\nd\nd") - (forward-button (- n) wrap display-message)) + (forward-button (- n) wrap display-message no-error)) (provide 'button) commit 1d9efc0b3a60fda86885001b229b6528ffb931df Author: Noam Postavsky Date: Sun Jul 28 12:15:33 2019 -0400 Add index for "\( in strings" (Bug#25195) * doc/emacs/programs.texi (Left Margin Paren): Add index for "\( in strings". * doc/lispref/positions.texi (List Motion): Add index, and cross reference. diff --git a/doc/emacs/programs.texi b/doc/emacs/programs.texi index 1d6f3e0459..4c42b1078d 100644 --- a/doc/emacs/programs.texi +++ b/doc/emacs/programs.texi @@ -173,6 +173,7 @@ features that use them will also give you trouble. This includes the indentation commands (@pxref{Program Indent}) and Font Lock mode (@pxref{Font Lock}). +@cindex \( in strings The most likely problem case is when you want an opening delimiter at the start of a line inside a string. To avoid trouble, put an escape character (@samp{\}, in C and Emacs Lisp, @samp{/} in some diff --git a/doc/lispref/positions.texi b/doc/lispref/positions.texi index 7707793467..a5a51f0a0b 100644 --- a/doc/lispref/positions.texi +++ b/doc/lispref/positions.texi @@ -794,11 +794,15 @@ on a line that starts with a match for this regular expression, followed by a character with open-parenthesis syntax. @end defopt +@cindex \( in strings @defopt open-paren-in-column-0-is-defun-start If this variable's value is non-@code{nil}, an open parenthesis in column 0 is considered to be the start of a defun. If it is @code{nil}, an open parenthesis in column 0 has no special meaning. -The default is @code{t}. +The default is @code{t}. If a string literal happens to have a +parenthesis in column 0, escape it with backslash to avoid a false +positive, @xref{Left Margin Paren,, Left Margin Convention, emacs, The +GNU Emacs Manual}. @end defopt @defvar beginning-of-defun-function commit 99156a03bfee8304cf2644470dceb668e6262c98 Author: Lars Ingebrigtsen Date: Tue Jul 30 13:34:53 2019 +0200 Re-fix dired-pop-to-buffer obsoletion reference * lisp/dired.el (dired-pop-to-buffer): Re-fix obsoletion reference (bug#26243). diff --git a/lisp/dired.el b/lisp/dired.el index 738d5fc111..d47393b134 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -3326,7 +3326,7 @@ or \"* [3 files]\"." (defun dired-pop-to-buffer (buf) "Pop up buffer BUF in a way suitable for Dired." - (declare (obsolete nil "24.3")) + (declare (obsolete pop-to-buffer "24.3")) (let ((split-window-preferred-function (lambda (window) (or (and (let ((split-height-threshold 0)) commit 25cf501c1f86b98ff880b23a48dea66c1a913111 Author: Lars Ingebrigtsen Date: Tue Jul 30 13:18:36 2019 +0200 Revert "Make `ispell-change-dictionary' only list installed dictionaries" This reverts commit 848712b481e16f5c96fed6344c2f7d71a8d52ed1. There could be dictionaries available (set via command-line options for the speller, for instance) that would not be returned. diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el index 0c7fb3899e..9dfa9f3c44 100644 --- a/lisp/textmodes/ispell.el +++ b/lisp/textmodes/ispell.el @@ -851,13 +851,11 @@ Internal use.") ;; Ensure aspell's alias dictionary will override standard ;; definitions. (setq found (ispell-aspell-add-aliases found)) - ;; Merge into FOUND any elements from the standard - ;; ispell-dictionary-base-alist which have no element in FOUND at - ;; all. - (unless found - (dolist (dict ispell-dictionary-base-alist) - (unless (assoc (car dict) found) - (setq found (nconc found (list dict)))))) + ;; Merge into FOUND any elements from the standard ispell-dictionary-base-alist + ;; which have no element in FOUND at all. + (dolist (dict ispell-dictionary-base-alist) + (unless (assoc (car dict) found) + (setq found (nconc found (list dict))))) (setq ispell-aspell-dictionary-alist found) ;; Add a default entry (let ((default-dict @@ -1297,7 +1295,8 @@ aspell is used along with Emacs).") ;; Substitute ispell-dictionary-alist with the list of ;; dictionaries corresponding to the given spellchecker. ;; With programs that support it, use the list of really - ;; installed dictionaries. Allow distro info. + ;; installed dictionaries and add to it elements of the original + ;; list that are not present there. Allow distro info. (let ((found-dicts-alist (if ispell-encoding8-command (if ispell-really-aspell @@ -1364,9 +1363,7 @@ aspell is used along with Emacs).") ;; Add dicts to `ispell-dictionary-alist' unless already present. (dolist (dict (append found-dicts-alist ispell-base-dicts-override-alist - (if found-dicts-alist - nil - ispell-dictionary-base-alist))) + ispell-dictionary-base-alist)) (unless (assoc (car dict) all-dicts-alist) (push dict all-dicts-alist))) (setq ispell-dictionary-alist all-dicts-alist)) commit 74c5d688bb29c34c7392267840102f006465dd02 Author: Lars Ingebrigtsen Date: Tue Jul 30 13:11:38 2019 +0200 Use decoded time accessors in ediff-mult * lisp/vc/ediff-mult.el (ediff-format-date): Use decoded time accessors. diff --git a/lisp/vc/ediff-mult.el b/lisp/vc/ediff-mult.el index b666900335..1bdaca268e 100644 --- a/lisp/vc/ediff-mult.el +++ b/lisp/vc/ediff-mult.el @@ -1205,13 +1205,12 @@ behavior." ;; TIME is like the output of decode-time (defun ediff-format-date (time) (format "%s %2d %4d %s:%s:%s" - (cdr (assoc (nth 4 time) ediff-months)) ; month - (nth 3 time) ; day - (nth 5 time) ; year - (ediff-fill-leading-zero (nth 2 time)) ; hour - (ediff-fill-leading-zero (nth 1 time)) ; min - (ediff-fill-leading-zero (nth 0 time)) ; sec - )) + (cdr (assoc (decoded-time-month time) ediff-months)) + (decoded-time-day time) + (decoded-time-year time) + (ediff-fill-leading-zero (decoded-time-hour time)) + (ediff-fill-leading-zero (decoded-time-minute time)) + (ediff-fill-leading-zero (decoded-time-second time)))) ;; Draw the directories (defun ediff-insert-dirs-in-meta-buffer (meta-list) commit 4134e6f87c955d89d6baff07fa15f25b19db99cf Author: Lars Ingebrigtsen Date: Tue Jul 30 13:11:14 2019 +0200 Use decoded time accessors in pop3 * lisp/net/pop3.el (pop3-make-date): Use decoded time accessors. diff --git a/lisp/net/pop3.el b/lisp/net/pop3.el index 599e2305f7..ddb4139610 100644 --- a/lisp/net/pop3.el +++ b/lisp/net/pop3.el @@ -611,14 +611,14 @@ Return the response string if optional second argument is non-nil." If NOW, use that time instead." (require 'parse-time) (let* ((now (or now (current-time))) - (zone (nth 8 (decode-time now)))) + (zone (decoded-time-zone (decode-time now)))) (when (< zone 0) (setq zone (- zone))) (concat (format-time-string "%d" now) ;; The month name of the %b spec is locale-specific. Pfff. (format " %s " - (capitalize (car (rassoc (nth 4 (decode-time now)) + (capitalize (car (rassoc (decoded-time-month (decode-time now)) parse-time-months)))) (format-time-string "%Y %H:%M:%S %z" now)))) commit 2b5fe44faad82afd393b0470ff05577520d766e9 Author: Lars Ingebrigtsen Date: Tue Jul 30 13:10:42 2019 +0200 Use decoded time accessors in esh-util * lisp/eshell/esh-util.el (eshell-parse-ange-ls): Use decoded time accessors. diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index fe8eb35d36..4835e63baa 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -654,7 +654,7 @@ If NOSORT is non-nil, the list is not sorted--its order is unpredictable. (match-string 6)))) (if (nth 0 moment) (setcar (nthcdr 5 moment) - (nth 5 (decode-time))) + (decoded-time-year (decode-time))) (setcar (nthcdr 0 moment) 0) (setcar (nthcdr 1 moment) 0) (setcar (nthcdr 2 moment) 0)) commit bddd4d382a0e91c73326f1e278924ce9e5624cd7 Author: Lars Ingebrigtsen Date: Tue Jul 30 13:10:03 2019 +0200 Use decoded time accessors in in em-ls * lisp/eshell/em-ls.el (eshell-ls-file): Use decoded time accessors. diff --git a/lisp/eshell/em-ls.el b/lisp/eshell/em-ls.el index 89969d3258..b1aab79538 100644 --- a/lisp/eshell/em-ls.el +++ b/lisp/eshell/em-ls.el @@ -525,12 +525,14 @@ whose cdr is the list of file attributes." " " (format-time-string (concat eshell-ls-date-format " " - (if (= (nth 5 (decode-time)) - (nth 5 (decode-time - (nth (cond - ((eq sort-method 'by-atime) 4) - ((eq sort-method 'by-ctime) 6) - (t 5)) attrs)))) + (if (= (decoded-time-year (decode-time)) + (decoded-time-year + (decode-time + (nth (cond + ((eq sort-method 'by-atime) 4) + ((eq sort-method 'by-ctime) 6) + (t 5)) + attrs)))) "%H:%M" " %Y")) (nth (cond ((eq sort-method 'by-atime) 4) commit 66a74f841541a9bfa32d34cad9098cee27c58026 Author: Lars Ingebrigtsen Date: Tue Jul 30 13:08:49 2019 +0200 Use decoded time accessors in timer * lisp/emacs-lisp/timer.el (run-at-time): Use decoded time accessors. diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 22ccc35103..400f00a85b 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -375,8 +375,11 @@ This function returns a timer object which you can use in (now (decode-time))) (if (>= hhmm 0) (setq time - (encode-time 0 (% hhmm 100) (/ hhmm 100) (nth 3 now) - (nth 4 now) (nth 5 now) (nth 8 now))))))) + (encode-time 0 (% hhmm 100) (/ hhmm 100) + (decoded-time-day now) + (decoded-time-month now) + (decoded-time-year now) + (decoded-time-zone now))))))) (or (consp time) (error "Invalid time format")) commit c859bc07c96484e5f8f31c24a0057a0fcf02a441 Author: Lars Ingebrigtsen Date: Tue Jul 30 13:08:21 2019 +0200 Use decoded time accessors in timeclock * lisp/calendar/timeclock.el (timeclock-day-base): Use decoded time accessors. diff --git a/lisp/calendar/timeclock.el b/lisp/calendar/timeclock.el index 3735115a93..60586e7ace 100644 --- a/lisp/calendar/timeclock.el +++ b/lisp/calendar/timeclock.el @@ -1139,9 +1139,9 @@ discrepancy, today's discrepancy, and the time worked today." "Given a time within a day, return 0:0:0 within that day. If optional argument TIME is non-nil, use that instead of the current time." (let ((decoded (decode-time time))) - (setcar (nthcdr 0 decoded) 0) - (setcar (nthcdr 1 decoded) 0) - (setcar (nthcdr 2 decoded) 0) + (setf (decoded-time-second decoded) 0) + (setf (decoded-time-minute decoded) 0) + (setf (decoded-time-hour decoded) 0) (encode-time decoded))) (defun timeclock-mean (l) commit e9e1b0af354aa1672429729ff1e0f48370ce362f Author: Lars Ingebrigtsen Date: Tue Jul 30 13:07:49 2019 +0200 Use decoded time accessors in time-date * lisp/calendar/time-date.el (time-to-days): Use decoded time accessors. diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index d299dc5e7d..e195f71c58 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -237,7 +237,7 @@ DATE1 and DATE2 should be date-time strings." TIME should be a time value. The Gregorian date Sunday, December 31, 1bce is imaginary." (let* ((tim (decode-time time)) - (year (nth 5 tim))) + (year (decoded-time-year tim))) (+ (time-date--day-in-year tim) ; Days this year (* 365 (1- year)) ; + Days in prior years (/ (1- year) 4) ; + Julian leap years commit e3bbd665a9ab8208fdc9c20aee8ac0b4cee682d8 Author: Lars Ingebrigtsen Date: Tue Jul 30 13:07:17 2019 +0200 Use decoded time accessors in appt * lisp/calendar/appt.el (appt-check, appt-make-list): Use decoded time accessors. diff --git a/lisp/calendar/appt.el b/lisp/calendar/appt.el index b7aa2123a4..944054eee3 100644 --- a/lisp/calendar/appt.el +++ b/lisp/calendar/appt.el @@ -325,7 +325,7 @@ displayed in a window: (prev-appt-display-count appt-display-count) ;; Convert current time to minutes after midnight (12.01am = 1). (now (decode-time)) - (now-mins (+ (* 60 (nth 2 now)) (nth 1 now))) + (now-mins (+ (* 60 (decoded-time-hour now)) (decoded-time-minute now))) appt-mins appt-warn-time min-to-app min-list string-list) (save-excursion ; FIXME ? ;; At first check in any day, update appointments to today's list. @@ -647,7 +647,8 @@ Any appointments made with `appt-add' are not affected by this function." ;; Convert current time to minutes after midnight (12:01am = 1), ;; and remove elements in the list that are in the past. (let* ((now (decode-time)) - (now-mins (+ (* 60 (nth 2 now)) (nth 1 now)))) + (now-mins (+ (* 60 (decoded-time-hour now)) + (decoded-time-minute now)))) (while (and appt-time-msg-list (< (caar (car appt-time-msg-list)) now-mins)) (setq appt-time-msg-list (cdr appt-time-msg-list))))))) commit bd3bc1c924d4b65f0413a7df9b74f6facd0d2a1a Author: Lars Ingebrigtsen Date: Tue Jul 30 13:06:35 2019 +0200 Fix syntax error in previus calc-forms change * lisp/calc/calc-forms.el (calc-time): Fix previous decoded time change. diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el index d867ac1d47..bdfc0e44dd 100644 --- a/lisp/calc/calc-forms.el +++ b/lisp/calc/calc-forms.el @@ -43,7 +43,7 @@ (list 'hms (decoded-time-hour time) (decoded-time-minute time) - (decoded-time-second 0 time)) + (decoded-time-second time)) (list 'hms 24 0 0)))))) (defun calc-to-hms (arg) commit 9f14c9ad342e60d2ef4965253a57f297342e5cf9 Author: Lars Ingebrigtsen Date: Tue Jul 30 13:06:06 2019 +0200 Use decoded time accessors in calendar * lisp/calendar/icalendar.el (icalendar--add-decoded-times) (icalendar--convert-sexp-to-ical): * lisp/calendar/calendar.el (calendar-current-date): * lisp/calendar/cal-dst.el (calendar-dst-find-data) (calendar-dst-find-startend): Use decoded time accessors. diff --git a/lisp/calendar/cal-dst.el b/lisp/calendar/cal-dst.el index e0126a6560..510cd6808e 100644 --- a/lisp/calendar/cal-dst.el +++ b/lisp/calendar/cal-dst.el @@ -259,7 +259,7 @@ for `calendar-current-time-zone'." (car t2-date-sec) t1-utc-diff)) (t1-time (/ (cdr t1-date-sec) 60)) (t2-time (/ (cdr t2-date-sec) 60))) - (if (nth 7 (decode-time t1)) + (if (decoded-time-dst (decode-time t1)) (list (/ t0-utc-diff 60) (/ (- t1-utc-diff t0-utc-diff) 60) t0-name t1-name t1-rules t2-rules t1-time t2-time) (list (/ t1-utc-diff 60) (/ (- t0-utc-diff t1-utc-diff) 60) @@ -291,7 +291,8 @@ the current year." (condition-case nil (encode-time 1 0 0 1 1 year) (error - (encode-time 1 0 0 1 1 (nth 5 (decode-time)))))) + (encode-time 1 0 0 1 1 + (decoded-time-year (decode-time)))))) f (nth 4 e) e (list year f (nth 5 e)) calendar-dst-transition-cache diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index 1e988c2712..14604a673d 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -1871,7 +1871,9 @@ the STRINGS are just concatenated and the result truncated." "Return the current date in a list (month day year). Optional integer OFFSET is a number of days from the current date." (let* ((now (decode-time)) - (now (list (nth 4 now) (nth 3 now) (nth 5 now)))) + (now (list (decoded-time-month now) + (decoded-time-day now) + (decoded-time-year now)))) (if (zerop (or offset 0)) now (calendar-gregorian-from-absolute diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index 17316ddbbd..cf3315b45d 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -721,12 +721,12 @@ Both times must be given in decoded form. One of these times must be valid (year > 1900 or something)." ;; FIXME: does this function exist already? (decode-time (encode-time - (+ (nth 0 time1) (nth 0 time2)) - (+ (nth 1 time1) (nth 1 time2)) - (+ (nth 2 time1) (nth 2 time2)) - (+ (nth 3 time1) (nth 3 time2)) - (+ (nth 4 time1) (nth 4 time2)) - (+ (nth 5 time1) (nth 5 time2)) + (+ (decoded-time-second time1) (decoded-time-second time2)) + (+ (decoded-time-minute time1) (decoded-time-minute time2)) + (+ (decoded-time-hour time1) (decoded-time-hour time2)) + (+ (decoded-time-day time1) (decoded-time-day time2)) + (+ (decoded-time-month time1) (decoded-time-month time2)) + (+ (decoded-time-year time1) (decoded-time-year time2)) nil nil ;;(or (nth 6 time1) (nth 6 time2)) ;; FIXME? @@ -1623,9 +1623,9 @@ enumeration, given as a Lisp time value -- used for test purposes." (lambda (offset) (let* ((day (decode-time (time-add now (* 60 60 24 offset)))) - (d (nth 3 day)) - (m (nth 4 day)) - (y (nth 5 day)) + (d (decoded-time-day day)) + (m (decoded-time-month day)) + (y (decoded-time-year day)) (se (diary-sexp-entry p1 p2 (list m d y))) (see (cond ((stringp se) se) ((consp se) (cdr se)) commit bd26eff54779bfd5739c1d663bcabd19246682d8 Author: Lars Ingebrigtsen Date: Tue Jul 30 13:05:17 2019 +0200 Use decoded time accessors in Gnus * lisp/gnus/nnimap.el (nnimap-find-expired-articles): * lisp/gnus/nndiary.el (nndiary-compute-reminders) (nndiary-last-occurrence, nndiary-next-occurrence): * lisp/gnus/message.el (message-make-expires-date): * lisp/gnus/gnus-util.el (gnus-seconds-today) (gnus-seconds-month, gnus-seconds-year): * lisp/gnus/gnus-demon.el (gnus-demon-time-to-step): * lisp/gnus/gnus-art.el (article-make-date-line): Use decoded time accessors. diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 89f57712c5..a38300ef66 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -3598,22 +3598,22 @@ possible values." (let ((dtime (decode-time time))) (concat "Date: the " - (number-to-string (nth 3 dtime)) - (let ((digit (% (nth 3 dtime) 10))) + (number-to-string (decoded-time-day dtime)) + (let ((digit (% (decoded-time-day dtime) 10))) (cond - ((memq (nth 3 dtime) '(11 12 13)) "th") + ((memq (decoded-time-day dtime) '(11 12 13)) "th") ((= digit 1) "st") ((= digit 2) "nd") ((= digit 3) "rd") (t "th"))) " of " - (nth (1- (nth 4 dtime)) gnus-english-month-names) + (nth (1- (decoded-time-month dtime)) gnus-english-month-names) " " - (number-to-string (nth 5 dtime)) + (number-to-string (decoded-time-year dtime)) " at " - (format "%02d" (nth 2 dtime)) + (format "%02d" (decoded-time-hour dtime)) ":" - (format "%02d" (nth 1 dtime))))))) + (format "%02d" (decoded-time-minute dtime))))))) (foo (format "Date: %s (from Gnus)" date)))) diff --git a/lisp/gnus/gnus-demon.el b/lisp/gnus/gnus-demon.el index cb70d9525c..b26aaa1529 100644 --- a/lisp/gnus/gnus-demon.el +++ b/lisp/gnus/gnus-demon.el @@ -176,22 +176,25 @@ marked with SPECIAL." (thenHour (elt thenParts 2)) (thenMin (elt thenParts 1)) ;; convert time as elements into number of seconds since EPOCH. - (then (encode-time 0 - thenMin - thenHour - ;; If THEN is earlier than NOW, make it - ;; same time tomorrow. Doc for encode-time - ;; says that this is OK. - (+ (elt nowParts 3) - (if (or (< thenHour (elt nowParts 2)) - (and (= thenHour (elt nowParts 2)) - (<= thenMin (elt nowParts 1)))) - 1 0)) - (elt nowParts 4) - (elt nowParts 5) - (elt nowParts 6) - (elt nowParts 7) - (elt nowParts 8))) + (then (encode-time + 0 + thenMin + thenHour + ;; If THEN is earlier than NOW, make it + ;; same time tomorrow. Doc for encode-time + ;; says that this is OK. + (+ (decoded-time-day nowParts) + (if (or (< thenHour (decoded-time-hour nowParts)) + (and (= thenHour + (decoded-time-hour nowParts)) + (<= thenMin + (decoded-time-minute nowParts)))) + 1 0)) + (decoded-time-month nowParts) + (decoded-time-year nowParts) + (decoded-time-weekday nowParts) + (decoded-time-dst nowParts) + (decoded-time-zone nowParts))) (diff (float-time (time-subtract then now)))) ;; Return number of timesteps in the number of seconds. (round diff gnus-demon-timestep))) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 31421cc755..9ccdb83865 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -359,20 +359,26 @@ Symbols are also allowed; their print names are used instead." (defun gnus-seconds-today () "Return the number of seconds passed today." (let ((now (decode-time))) - (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)))) + (+ (decoded-time-second now) + (* (decoded-time-minute now) 60) + (* (decoded-time-hour now) 3600)))) (defun gnus-seconds-month () "Return the number of seconds passed this month." (let ((now (decode-time))) - (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600) - (* (- (car (nthcdr 3 now)) 1) 3600 24)))) + (+ (decoded-time-second now) + (* (decoded-time-minute now) 60) + (* (decoded-time-hour now) 3600) + (* (- (decoded-time-day now) 1) 3600 24)))) (defun gnus-seconds-year () "Return the number of seconds passed this year." (let* ((current (current-time)) (now (decode-time current)) (days (format-time-string "%j" current))) - (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600) + (+ (decoded-time-second now) + (* (decoded-time-minute now) 60) + (* (decoded-time-hour now) 3600) (* (- (string-to-number days) 1) 3600 24)))) (defmacro gnus-date-get-time (date) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 3f190ed651..ea7a282b8b 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -5509,8 +5509,8 @@ If NOW, use that time instead." In posting styles use `(\"Expires\" (make-expires-date 30))'." (let* ((cur (decode-time)) - (nday (+ days (nth 3 cur)))) - (setf (nth 3 cur) nday) + (nday (+ days (decoded-time-day cur)))) + (setf (decoded-time-day cur) nday) (message-make-date (encode-time cur)))) (defun message-make-message-id () diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index f8ec222616..2ad0634e6a 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -1264,12 +1264,12 @@ all. This may very well take some time.") (date-elts (decode-time date)) ;; ### NOTE: out-of-range values are accepted by encode-time. This ;; makes our life easier. - (monday (- (nth 3 date-elts) + (monday (- (decoded-time-day date-elts) (if nndiary-week-starts-on-monday - (if (zerop (nth 6 date-elts)) + (if (zerop (decoded-time-weekday date-elts)) 6 - (- (nth 6 date-elts) 1)) - (nth 6 date-elts)))) + (- (decoded-time-weekday date-elts) 1)) + (decoded-time-weekday date-elts)))) reminder res) ;; remove the DOW and DST entries (setcdr (nthcdr 5 date-elts) (nthcdr 8 date-elts)) @@ -1343,9 +1343,10 @@ all. This may very well take some time.") ;; have to know which day is the 1st one for this month. ;; Maybe there's simpler, but decode-time(encode-time) will ;; give us the answer. - (let ((first (nth 6 (decode-time - (encode-time 0 0 0 1 month year - time-zone)))) + (let ((first (decoded-time-weekday + (decode-time + (encode-time 0 0 0 1 month year + time-zone)))) (max (cond ((= month 2) (if (date-leap-year-p year) 29 28)) ((<= month 7) @@ -1390,11 +1391,11 @@ all. This may very well take some time.") ;; If there's no next occurrence, returns the last one (if any) which is then ;; in the past. (let* ((today (decode-time now)) - (this-minute (nth 1 today)) - (this-hour (nth 2 today)) - (this-day (nth 3 today)) - (this-month (nth 4 today)) - (this-year (nth 5 today)) + (this-minute (decoded-time-minute today)) + (this-hour (decoded-time-hour today)) + (this-day (decoded-time-day today)) + (this-month (decoded-time-month today)) + (this-year (decoded-time-year today)) (minute-list (sort (nndiary-flatten (nth 0 sched) 0 59) '<)) (hour-list (sort (nndiary-flatten (nth 1 sched) 0 23) '<)) (dom-list (nth 2 sched)) @@ -1445,9 +1446,10 @@ all. This may very well take some time.") ;; have to know which day is the 1st one for this month. ;; Maybe there's simpler, but decode-time(encode-time) will ;; give us the answer. - (let ((first (nth 6 (decode-time - (encode-time 0 0 0 1 month year - time-zone)))) + (let ((first (decoded-time-weekday + (decode-time + (encode-time 0 0 0 1 month year + time-zone)))) (max (cond ((= month 2) (if (date-leap-year-p year) 29 28)) ((<= month 7) diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index 99a610487f..c6eaa54c69 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -1100,7 +1100,7 @@ textual parts.") (format-time-string (format "%%d-%s-%%Y" (upcase - (car (rassoc (nth 4 (decode-time cutoff)) + (car (rassoc (decoded-time-month (decode-time cutoff)) parse-time-months)))) cutoff)))) (and (car result) commit 608832acc35420fc7140f73cd8e18f1a00f93ec6 Author: Lars Ingebrigtsen Date: Tue Jul 30 13:03:22 2019 +0200 Use decoded time accessors in calc * lisp/calc/calc-forms.el (calc-time, math-this-year) (calcFunc-now): Use decoded time accessors. diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el index eb1a8248cd..d867ac1d47 100644 --- a/lisp/calc/calc-forms.el +++ b/lisp/calc/calc-forms.el @@ -41,7 +41,9 @@ (calc-enter-result 0 "time" (list 'mod (list 'hms - (nth 2 time) (nth 1 time) (nth 0 time)) + (decoded-time-hour time) + (decoded-time-minute time) + (decoded-time-second 0 time)) (list 'hms 24 0 0)))))) (defun calc-to-hms (arg) @@ -523,7 +525,7 @@ in the Gregorian calendar and the remaining part determines the time." (defun math-this-year () - (nth 5 (decode-time))) + (decoded-time-year (decode-time))) (defun math-leap-year-p (year &optional julian) "Non-nil if YEAR is a leap year. @@ -1341,8 +1343,12 @@ as measured in the integer number of days before December 31, 1 BC (Gregorian)." (defun calcFunc-now (&optional zone) (let ((date (let ((now (decode-time))) (list 'date (math-dt-to-date - (list (nth 5 now) (nth 4 now) (nth 3 now) - (nth 2 now) (nth 1 now) (nth 0 now))))))) + (list (decoded-time-year now) + (decoded-time-month now) + (decoded-time-day now) + (decoded-time-hour now) + (decoded-time-minute now) + (decoded-time-second now))))))) (if zone (math-add date (math-div (math-sub (calcFunc-tzone nil date) (calcFunc-tzone zone date)) commit 3c4eb0d190ec5d28d5798b346fcde701fd919d1b Author: Lars Ingebrigtsen Date: Tue Jul 30 13:02:41 2019 +0200 Use decoded time accessors in proced * lisp/proced.el (proced-format-start): Use decoded time accessors. diff --git a/lisp/proced.el b/lisp/proced.el index b05046bfbd..5f35fa34a0 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -1367,12 +1367,12 @@ Prefix ARG controls sort order, see `proced-sort-interactive'." The return string is always 6 characters wide." (let ((d-start (decode-time start)) (d-current (decode-time))) - (cond ( ;; process started in previous years - (< (nth 5 d-start) (nth 5 d-current)) + (cond (;; process started in previous years + (< (decoded-time-year d-start) (decoded-time-year d-current)) (format-time-string " %Y" start)) ;; process started today - ((and (= (nth 3 d-start) (nth 3 d-current)) - (= (nth 4 d-start) (nth 4 d-current))) + ((and (= (decoded-time-day d-start) (decoded-time-day d-current)) + (= (decoded-time-month d-start) (decoded-time-month d-current))) (format-time-string " %H:%M" start)) (t ;; process started this year (format-time-string "%b %e" start))))) commit 8a30f0414ec4145ca3684639c6ce1edeeb3f3331 Author: Lars Ingebrigtsen Date: Tue Jul 30 12:09:12 2019 +0200 Make description of text properties on the form `(string ...)' work * lisp/descr-text.el (describe-property-list): Don't special-case for symbols that have widget properties here (bug#22957). It's not documented that this function should do that, and looking at the code, it doesn't seem like this function is actually used for doing that, either. This makes describing some text properties that are on the form `(string ...)' work. diff --git a/lisp/descr-text.el b/lisp/descr-text.el index 8be2b94458..ba53aeb385 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -88,8 +88,6 @@ into help buttons that call `describe-text-category' or (insert-text-button (format "%S" value) 'type 'help-face 'help-args (list value))) - ((widgetp value) - (describe-text-widget value)) (t (describe-text-sexp value)))) (insert "\n"))) commit 26381d56e2e39700c60e17ca22c418028a3bfbd9 Author: Lars Ingebrigtsen Date: Tue Jul 30 12:04:21 2019 +0200 Use the elisp xref backend in profiler buffers * lisp/profiler.el (profiler--xref-backend): New function (bug#23455). (profiler-report-mode): Use it to use the elisp xref handler when hitting `M-.' in profiler buffers. diff --git a/lisp/profiler.el b/lisp/profiler.el index ee11ff68c5..92495e2de8 100644 --- a/lisp/profiler.el +++ b/lisp/profiler.el @@ -615,9 +615,12 @@ return it." (profiler-report-render-calltree)) buffer)) +(defun profiler--xref-backend () 'elisp) + (define-derived-mode profiler-report-mode special-mode "Profiler-Report" "Profiler Report Mode." (add-to-invisibility-spec '(profiler . t)) + (add-hook 'xref-backend-functions #'profiler--xref-backend nil t) (setq buffer-read-only t buffer-undo-list t truncate-lines t)) commit e18a4a08e40c83623c7c5c7159de1b772d22303a Author: Lars Ingebrigtsen Date: Tue Jul 30 11:56:03 2019 +0200 Adjust time-date tests to tweaked format diff --git a/test/lisp/calendar/time-date-tests.el b/test/lisp/calendar/time-date-tests.el index d6cf742bc5..b46a247cd3 100644 --- a/test/lisp/calendar/time-date-tests.el +++ b/test/lisp/calendar/time-date-tests.el @@ -35,13 +35,13 @@ (ert-deftest test-ordinal () (should (equal (date-ordinal-to-time 2008 271) - '(0 0 0 27 9 2008 nil nil nil))) + '(nil nil nil 27 9 2008 nil nil nil))) (should (equal (date-ordinal-to-time 2008 1) - '(0 0 0 1 1 2008 nil nil nil))) + '(nil nil nil 1 1 2008 nil nil nil))) (should (equal (date-ordinal-to-time 2008 32) - '(0 0 0 1 2 2008 nil nil nil))) + '(nil nil nil 1 2 2008 nil nil nil))) (should (equal (date-ordinal-to-time 1981 095) - '(0 0 0 5 4 1981 nil nil nil)))) + '(nil nil nil 5 4 1981 nil nil nil)))) (cl-defmethod mdec (&key second minute hour day month year commit 304e96f50d49e142edd8ec1b1c7d9fb1ce9a7385 Author: Martin Rudalics Date: Tue Jul 30 09:23:22 2019 +0200 Fix doc-string of 'fit-window-to-buffer' (Bug#36848) * lisp/window.el (fit-window-to-buffer): Fix doc-string. Suggested by Drew Adams diff --git a/lisp/window.el b/lisp/window.el index de110111b5..a86c2f96bd 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -8285,7 +8285,7 @@ and defaults to `window-min-width'. Both MAX-WIDTH and MIN-WIDTH are specified in columns and include fringes, margins, a scrollbar and a vertical divider, if any. -If the optional argument `preserve-size' is non-nil, preserve the +Optional argument PRESERVE-SIZE non-nil means to preserve the size of WINDOW (see `window-preserve-size'). Fit pixelwise if the option `window-resize-pixelwise' is non-nil. commit 28d1023bbeea7c5c6b0791a48852a12f14785067 Author: Juri Linkov Date: Tue Jul 30 01:46:15 2019 +0300 Highlight keyboard macro recording mode with read color in the mode-line * lisp/bindings.el (minor-mode-alist): Propertize " Def" with 'error' face for defining-kbd-macro. (Bug#36564) diff --git a/lisp/bindings.el b/lisp/bindings.el index 5205d497ef..64842c4e1f 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -655,11 +655,11 @@ okay. See `mode-line-format'.") (put 'minor-mode-alist 'risky-local-variable t) ;; Don't use purecopy here--some people want to change these strings. (setq minor-mode-alist - '((abbrev-mode " Abbrev") + `((abbrev-mode " Abbrev") (overwrite-mode overwrite-mode) (auto-fill-function " Fill") ;; not really a minor mode... - (defining-kbd-macro " Def"))) + (defining-kbd-macro ,(propertize " Def" 'face 'error)))) ;; These variables are used by autoloadable packages. ;; They are defined here so that they do not get overridden commit 77acef90cc86ae4a69ea3abba7259f48801f64bf Author: Stefan Monnier Date: Mon Jul 29 14:59:26 2019 -0400 * lisp/progmodes/vhdl-mode.el: Use cl-lib when available (vhdl--pushnew): New macro. Use it instead of `pushnew`. (emacs-major-version): Don't bother checking (featurep 'xemacs) since that is always (< emacs-major-version 25) as well. diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index 13d0cfa67e..9eedbf9cbc 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -126,13 +126,15 @@ ;;; Code: -(eval-when-compile (require 'cl)) -(eval-and-compile - ;; Before Emacs-24.4, `pushnew' expands to runtime calls to `cl-adjoin' - ;; even for relatively simple cases such as used here. We only test <25 - ;; because it's easier and sufficient. - (when (or (featurep 'xemacs) (< emacs-major-version 25)) - (require 'cl))) +(eval-when-compile + (condition-case nil (require 'cl-lib) (file-missing (require 'cl))) + (defalias 'vhdl--pushnew (if (fboundp 'cl-pushnew) 'cl-pushnew 'pushnew))) + +;; Before Emacs-24.4, `pushnew' expands to runtime calls to `cl-adjoin' +;; even for relatively simple cases such as used here. We only test <25 +;; because it's easier and sufficient. +(when (< emacs-major-version 25) + (condition-case nil (require 'cl-lib) (file-missing (require 'cl)))) ;; Emacs 21+ handling (defconst vhdl-emacs-21 (and (<= 21 emacs-major-version) (not (featurep 'xemacs))) @@ -14315,7 +14317,7 @@ of PROJECT." (vhdl-scan-directory-contents dir-name project nil (format "(%s/%s) " act-dir num-dir) (cdr dir-list)) - (pushnew (file-name-directory dir-name) dir-list-tmp :test #'equal) + (vhdl--pushnew (file-name-directory dir-name) dir-list-tmp :test #'equal) (setq dir-list (cdr dir-list) act-dir (1+ act-dir))) (vhdl-aput 'vhdl-directory-alist project (list (nreverse dir-list-tmp))) @@ -16407,8 +16409,8 @@ component instantiation." (if (or (member constant-name single-list) (member constant-name multi-list)) (progn (setq single-list (delete constant-name single-list)) - (pushnew constant-name multi-list :test #'equal)) - (pushnew constant-name single-list :test #'equal)) + (vhdl--pushnew constant-name multi-list :test #'equal)) + (vhdl--pushnew constant-name single-list :test #'equal)) (unless (match-string 1) (setq generic-alist (cdr generic-alist))) (vhdl-forward-syntactic-ws)) @@ -16434,12 +16436,12 @@ component instantiation." (member signal-name multi-out-list)) (setq single-out-list (delete signal-name single-out-list)) (setq multi-out-list (delete signal-name multi-out-list)) - (pushnew signal-name local-list :test #'equal)) + (vhdl--pushnew signal-name local-list :test #'equal)) ((member signal-name single-in-list) (setq single-in-list (delete signal-name single-in-list)) - (pushnew signal-name multi-in-list :test #'equal)) + (vhdl--pushnew signal-name multi-in-list :test #'equal)) ((not (member signal-name multi-in-list)) - (pushnew signal-name single-in-list :test #'equal))) + (vhdl--pushnew signal-name single-in-list :test #'equal))) ;; output signal (cond ((member signal-name local-list) @@ -16448,12 +16450,12 @@ component instantiation." (member signal-name multi-in-list)) (setq single-in-list (delete signal-name single-in-list)) (setq multi-in-list (delete signal-name multi-in-list)) - (pushnew signal-name local-list :test #'equal)) + (vhdl--pushnew signal-name local-list :test #'equal)) ((member signal-name single-out-list) (setq single-out-list (delete signal-name single-out-list)) - (pushnew signal-name multi-out-list :test #'equal)) + (vhdl--pushnew signal-name multi-out-list :test #'equal)) ((not (member signal-name multi-out-list)) - (pushnew signal-name single-out-list :test #'equal)))) + (vhdl--pushnew signal-name single-out-list :test #'equal)))) (unless (match-string 1) (setq port-alist (cdr port-alist))) (vhdl-forward-syntactic-ws)) @@ -16536,14 +16538,14 @@ component instantiation." generic-end-pos (vhdl-compose-insert-generic constant-entry))) (setq generic-pos (point-marker)) - (pushnew constant-name written-list :test #'equal)) + (vhdl--pushnew constant-name written-list :test #'equal)) (t (vhdl-goto-marker (vhdl-max-marker generic-inst-pos generic-pos)) (setq generic-end-pos (vhdl-compose-insert-generic constant-entry)) (setq generic-inst-pos (point-marker)) - (pushnew constant-name written-list :test #'equal)))) + (vhdl--pushnew constant-name written-list :test #'equal)))) (setq constant-alist (cdr constant-alist))) (when (/= constant-temp-pos generic-inst-pos) (vhdl-goto-marker (vhdl-max-marker constant-temp-pos generic-pos)) @@ -16562,14 +16564,14 @@ component instantiation." (vhdl-max-marker port-end-pos (vhdl-compose-insert-port signal-entry))) (setq port-in-pos (point-marker)) - (pushnew signal-name written-list :test #'equal)) + (vhdl--pushnew signal-name written-list :test #'equal)) ((member signal-name multi-out-list) (vhdl-goto-marker (vhdl-max-marker port-out-pos port-in-pos)) (setq port-end-pos (vhdl-max-marker port-end-pos (vhdl-compose-insert-port signal-entry))) (setq port-out-pos (point-marker)) - (pushnew signal-name written-list :test #'equal)) + (vhdl--pushnew signal-name written-list :test #'equal)) ((or (member signal-name single-in-list) (member signal-name single-out-list)) (vhdl-goto-marker @@ -16578,12 +16580,12 @@ component instantiation." (vhdl-max-marker port-out-pos port-in-pos))) (setq port-end-pos (vhdl-compose-insert-port signal-entry)) (setq port-inst-pos (point-marker)) - (pushnew signal-name written-list :test #'equal)) + (vhdl--pushnew signal-name written-list :test #'equal)) ((equal (upcase (nth 2 signal-entry)) "OUT") (vhdl-goto-marker signal-pos) (vhdl-compose-insert-signal signal-entry) (setq signal-pos (point-marker)) - (pushnew signal-name written-list :test #'equal))) + (vhdl--pushnew signal-name written-list :test #'equal))) (setq signal-alist (cdr signal-alist))) (when (/= port-temp-pos port-inst-pos) (vhdl-goto-marker @@ -16934,7 +16936,7 @@ no project is defined." "Remove duplicate elements from IN-LIST." (let (out-list) (while in-list - (pushnew (car in-list) out-list :test #'equal) + (vhdl--pushnew (car in-list) out-list :test #'equal) (setq in-list (cdr in-list))) out-list)) commit 199a1b5cd4845f432ee7231e0f7cdd2b6ebddf37 Author: Juri Linkov Date: Mon Jul 29 21:18:34 2019 +0300 * lisp/info.el (Info-toc-insert): Suppress same section names as node names. Add indentation to section lines. (Bug#23142) diff --git a/lisp/info.el b/lisp/info.el index 3203c5f171..cc18ea11f3 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -2452,11 +2452,12 @@ Table of contents is created from the tree structure of menus." "Insert table of contents with references to nodes." (let ((section "Top")) (while nodes - (let ((node (assoc (car nodes) node-list))) - (unless (member (nth 2 node) (list nil section)) - (insert (setq section (nth 2 node)) "\n")) - (insert (make-string level ?\t)) - (insert "*Note " (car nodes) ":: \n") + (let ((node (assoc (car nodes) node-list)) + (indentation (make-string level ?\t))) + (when (and (not (member (nth 2 node) (list nil section))) + (not (equal (nth 1 node) (nth 2 node)))) + (insert indentation (setq section (nth 2 node)) "\n")) + (insert indentation "*Note " (car nodes) ":: \n") (Info-toc-insert (nth 3 node) node-list (1+ level) curr-file) (setq nodes (cdr nodes)))))) commit 5483e44730d39284ca8fdfa360b92646bf23ba3c Author: Stefan Monnier Date: Mon Jul 29 11:57:49 2019 -0400 * lisp/simple.el (decoded-time): Use `cl-defstruct` diff --git a/lisp/simple.el b/lisp/simple.el index 8855045123..0bc39f08c0 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -9065,79 +9065,27 @@ to capitalize ARG words." ;;; Accessors for `decode-time' values. -(defsubst decoded-time-second (time) - "The seconds in TIME, which is a value returned by `decode-time'. +(cl-defstruct (decoded-time + (:constructor nil) + (:copier nil) + (:type list)) + (second nil :documentation "\ This is an integer between 0 and 60 (inclusive). (60 is a leap -second, which only some operating systems support.)" - (nth 0 time)) - -(defsubst decoded-time-minute (time) - "The minutes in TIME, which is a value returned by `decode-time'. -This is an integer between 0 and 59 (inclusive)." - (nth 1 time)) - -(defsubst decoded-time-hour (time) - "The hours in TIME, which is a value returned by `decode-time'. -This is an integer between 0 and 23 (inclusive)." - (nth 2 time)) - -(defsubst decoded-time-day (time) - "The day-of-the-month in TIME, which is a value returned by `decode-time'. -This is an integer between 1 and 31 (inclusive)." - (nth 3 time)) - -(defsubst decoded-time-month (time) - "The month in TIME, which is a value returned by `decode-time'. -This is an integer between 1 and 12 (inclusive). January is 1." - (nth 4 time)) - -(defsubst decoded-time-year (time) - "The year in TIME, which is a value returned by `decode-time'. -This is a four digit integer." - (nth 5 time)) - -(defsubst decoded-time-weekday (time) - "The day-of-the-week in TIME, which is a value returned by `decode-time'. -This is a number between 0 and 6, and 0 is Sunday." - (nth 6 time)) - -(defsubst decoded-time-dst (time) - "The daylight saving time in TIME, which is a value returned by `decode-time'. -This is t if daylight saving time is in effect, and nil if not." - (nth 7 time)) - -(defsubst decoded-time-zone (time) - "The time zone in TIME, which is a value returned by `decode-time'. +second, which only some operating systems support.)") + (minute nil :documentation "This is an integer between 0 and 59 (inclusive).") + (hour nil :documentation "This is an integer between 0 and 23 (inclusive).") + (day nil :documentation "This is an integer between 1 and 31 (inclusive).") + (month nil :documentation "\ +This is an integer between 1 and 12 (inclusive). January is 1.") + (year nil :documentation "This is a four digit integer.") + (weekday nil :documentation "\ +This is a number between 0 and 6, and 0 is Sunday.") + (dst nil :documentation "\ +This is t if daylight saving time is in effect, and nil if not.") + (zone nil :documentation "\ This is an integer indicating the UTC offset in seconds, i.e., -the number of seconds east of Greenwich." - (nth 8 time)) - -(gv-define-setter decoded-time-second (second time) - `(setf (nth 0 ,time) ,second)) - -(gv-define-setter decoded-time-minute (minute time) - `(setf (nth 1 ,time) ,minute)) - -(gv-define-setter decoded-time-hour (hour time) - `(setf (nth 2 ,time) ,hour)) - -(gv-define-setter decoded-time-day (day time) - `(setf (nth 3 ,time) ,day)) - -(gv-define-setter decoded-time-month (month time) - `(setf (nth 4 ,time) ,month)) - -(gv-define-setter decoded-time-year (year time) - `(setf (nth 5 ,time) ,year)) - -;; No setter for weekday, which is the 6th element. - -(gv-define-setter decoded-time-dst (dst time) - `(setf (nth 7 ,time) ,dst)) - -(gv-define-setter decoded-time-zone (zone time) - `(setf (nth 8 ,time) ,zone)) - +the number of seconds east of Greenwich.") + ) commit 75361be63fcd42497dd1eb93cab3255833334475 Author: Stefan Monnier Date: Mon Jul 29 11:56:11 2019 -0400 * lisp/emacs-lisp/cl-macs.el (cl-defstruct): Add slot option :documentation Use it to improve the docstring of the accessor functions. * doc/misc/cl.texi: Rename menu entry to "CL-Lib". (Structures): Add ':documentation' and mention ':type' as well, which we don't completely ignore any more. diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi index a919760263..afe8f01f59 100644 --- a/doc/misc/cl.texi +++ b/doc/misc/cl.texi @@ -24,7 +24,7 @@ modify this GNU manual.'' @dircategory Emacs lisp libraries @direntry -* CL: (cl). Partial Common Lisp support for Emacs Lisp. +* CL-Lib: (cl). Partial Common Lisp support for Emacs Lisp. @end direntry @finalout @@ -4036,12 +4036,6 @@ is either a slot symbol or a list of the form @samp{(@var{slot-name} is a Lisp form that is evaluated any time an instance of the structure type is created without specifying that slot's value. -Common Lisp defines several slot options, but the only one -implemented in this package is @code{:read-only}. A non-@code{nil} -value for this option means the slot should not be @code{setf}-able; -the slot's value is determined when the object is created and does -not change afterward. - @example (cl-defstruct person (name nil :read-only t) @@ -4049,7 +4043,23 @@ not change afterward. (sex 'unknown)) @end example -Any slot options other than @code{:read-only} are ignored. +@var{slot-options} is a list of keyword-value pairs, where the +following keywords can be used: + +@table @code +@item :read-only +A non-nil value means the slot should not be @code{setf}-able; +the slot's value is determined when the object is created and does +not change afterward. + +@item :type +The expected type of the values held in this slot. + +@item :documentation +A documentation string describing the slot. +@end table + +Other slot options are currently ignored. For obscure historical reasons, structure options take a different form than slot options. A structure option is either a keyword diff --git a/etc/NEWS b/etc/NEWS index 7c21cc7930..1587eab1e2 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -535,6 +535,9 @@ be functions. *** 'cl-defstruct' has a new ':noinline' argument to prevent inlining its functions. ++++ +*** `cl-defstruct' slots accept a ':documentation' property + --- *** 'cl-values-list' will now signal an error if its argument isn't a list. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 8b9224bd1b..1ae7266624 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2722,8 +2722,10 @@ node `(cl)Structures' for the description of the options. Each SLOT may instead take the form (SNAME SDEFAULT SOPTIONS...), where SDEFAULT is the default value of that slot and SOPTIONS are keyword-value pairs for that slot. -Currently, only one keyword is supported, `:read-only'. If this has a -non-nil value, that slot cannot be set via `setf'. +Supported keywords for slots are: +- `:read-only': If this has a non-nil value, that slot cannot be set via `setf'. +- `:documentation': this is a docstring describing the slot. +- `:type': the type of the field; currently unused. \(fn NAME &optional DOCSTRING &rest SLOTS)" (declare (doc-string 2) (indent 1) @@ -2902,14 +2904,17 @@ non-nil value, that slot cannot be set via `setf'. defaults)) (if (assq slot descp) (error "Duplicate slots named %s in %s" slot name)) - (let ((accessor (intern (format "%s%s" conc-name slot)))) + (let ((accessor (intern (format "%s%s" conc-name slot))) + (default-value (pop desc)) + (doc (plist-get desc :documentation))) (push slot slots) - (push (pop desc) defaults) + (push default-value defaults) ;; The arg "cl-x" is referenced by name in eg pred-form ;; and pred-check, so changing it is not straightforward. (push `(,defsym ,accessor (cl-x) - ,(format "Access slot \"%s\" of `%s' struct CL-X." - slot name) + ,(format "Access slot \"%s\" of `%s' struct CL-X.%s" + slot name + (if doc (concat "\n" doc) "")) (declare (side-effect-free t)) ,@(and pred-check (list `(or ,pred-check commit b47ca8125b39b871328da114637449a86050baa5 Author: Lars Ingebrigtsen Date: Mon Jul 29 15:45:48 2019 +0200 Tweak how mm-display-external handles windows * lisp/gnus/mm-decode.el (mm-display-external): Don't delete other buffers when displaying parts (bug#22861) because that should be up to the user, probably. diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index 85aa6944dd..c73bec0f19 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -896,11 +896,11 @@ external if displayed external." (buffer-live-p gnus-summary-buffer)) (when attachment-filename (with-current-buffer mm - (rename-buffer (format "*mm* %s" attachment-filename) t))) + (rename-buffer + (format "*mm* %s" attachment-filename) t))) ;; So that we pop back to the right place, sort of. (switch-to-buffer gnus-summary-buffer) (switch-to-buffer mm)) - (delete-other-windows) (funcall method)) (mm-save-part handle)) (when (and (not non-viewer) commit a9593253e90aa58134833078ae1fc5505ae9f58c Author: Lars Ingebrigtsen Date: Mon Jul 29 14:46:37 2019 +0200 Add further documentation about semicolon use * doc/lispref/tips.texi (Comment Tips): Document the sub-heading convention (bug#23060) as explained by Stefan on StackExchange. diff --git a/doc/lispref/tips.texi b/doc/lispref/tips.texi index 30f2c983ad..01e9a3a851 100644 --- a/doc/lispref/tips.texi +++ b/doc/lispref/tips.texi @@ -916,13 +916,16 @@ is discouraged. When commenting out entire functions, use two semicolons. @item ;;;; -Comments that start with four semicolons, @samp{;;;;}, should be aligned -to the left margin and are used for headings of major sections of a -program. For example: +Comments that start with four (or more) semicolons, @samp{;;;;}, +should be aligned to the left margin and are used for headings of +major sections of a program. For example: @smallexample ;;;; The kill ring @end smallexample + +If you wish to have sub-headings under these heading, use more +semicolons to nest these sub-headings. @end table @noindent commit fa04c8b87e50a2e2b0d021958f637be8f475d8bc Author: Lars Ingebrigtsen Date: Mon Jul 29 14:22:31 2019 +0200 Add an ISO 8601 parsing library * doc/lispref/os.texi (Time Parsing): Document it. * lisp/calendar/iso8601.el: New file. * test/lisp/calendar/iso8601-tests.el: Test ISO8601 parsing functions. diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index d397a12573..b3444838d3 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -1622,6 +1622,19 @@ ISO 8601 string, like ``Fri, 25 Mar 2016 16:24:56 +0100'' or less well-formed time strings as well. @end defun +@vindex ISO 8601 date/time strings +@defun iso8601-parse string +For a more strict function (that will error out upon invalid input), +this function can be used instead. It's able to parse all variants of +the ISO 8601 standard, so in addition to the formats mentioned above, +it also parses things like ``1998W45-3'' (week number) and +``1998-245'' (ordinal day number). To parse durations, there's +@code{iso8601-parse-duration}, and to parse intervals, there's +@code{iso8601-parse-interval}. All these functions return decoded +time structures, except the final one, which returns three of them +(the start, the end, and the duration). +@end defun + @defun format-time-string format-string &optional time zone This function converts @var{time} (or the current time, if diff --git a/etc/NEWS b/etc/NEWS index 2bdbfcb8d0..7c21cc7930 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2055,6 +2055,15 @@ of various forms, including a new timestamp form '(TICKS . HZ)', where TICKS is an integer and HZ is a positive integer denoting a clock frequency. The old 'encode-time' API is still supported. ++++ +*** A new package to parse ISO 8601 time, date, durations and +intervals has been added. The main function to use is +'iso8601-parse', but there's also 'iso8601-parse-date', +'iso8601-parse-time', 'iso8601-parse-duration' and +'iso8601-parse-interval'. All these functions return decoded time +structures, except the final one, which returns three of them (start, +end and duration). + +++ *** 'time-add', 'time-subtract', and 'time-less-p' now accept infinities and NaNs too, and propagate them or return nil like diff --git a/lisp/calendar/iso8601.el b/lisp/calendar/iso8601.el new file mode 100644 index 0000000000..ab0077ac58 --- /dev/null +++ b/lisp/calendar/iso8601.el @@ -0,0 +1,370 @@ +;;; iso8601.el --- parse ISO 8601 date/time strings -*- lexical-binding:t -*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; Keywords: dates + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; ISO8601 times basically look like 1985-04-01T15:23:49... Or so +;; you'd think. This is what everybody means when they say "ISO8601", +;; but it's in reality a quite large collection of syntaxes, including +;; week numbers, ordinal dates, durations and intervals. This package +;; has functions for parsing them all. +;; +;; The interface functions are `iso8601-parse', `iso8601-parse-date', +;; `iso8601-parse-time', `iso8601-parse-zone', +;; `iso8601-parse-duration' and `iso8601-parse-interval'. They all +;; return decoded time objects, except the last one, which returns a +;; list of three of them. +;; +;; (iso8601-parse-interval "P1Y2M10DT2H30M/2008W32T153000-01") +;; '((0 0 13 24 5 2007 nil nil -3600) +;; (0 30 15 3 8 2008 nil nil -3600) +;; (0 30 2 10 2 1 nil nil nil)) +;; +;; +;; The standard can be found at: +;; +;; http://www.loc.gov/standards/datetime/iso-tc154-wg5_n0038_iso_wd_8601-1_2016-02-16.pdf +;; +;; The Wikipedia page on the standard is also informative: +;; +;; https://en.wikipedia.org/wiki/ISO_8601 +;; +;; RFC3339 defines the subset that everybody thinks of as "ISO8601". + +;;; Code: + +(require 'time-date) +(require 'cl-lib) + +(defun iso8601--concat-regexps (regexps) + (mapconcat (lambda (regexp) + (concat "\\(?:" + (replace-regexp-in-string "(" "(?:" regexp) + "\\)")) + regexps "\\|")) + +(defconst iso8601--year-match + "\\([-+]\\)?\\([0-9][0-9][0-9][0-9]\\)") +(defconst iso8601--full-date-match + "\\([-+]\\)?\\([0-9][0-9][0-9][0-9]\\)-?\\([0-9][0-9]\\)-?\\([0-9][0-9]\\)") +(defconst iso8601--without-day-match + "\\([-+]\\)?\\([0-9][0-9][0-9][0-9]\\)-\\([0-9][0-9]\\)") +(defconst iso8601--outdated-date-match + "--\\([0-9][0-9]\\)-?\\([0-9][0-9]\\)") +(defconst iso8601--week-date-match + "\\([-+]\\)?\\([0-9][0-9][0-9][0-9]\\)-?W\\([0-9][0-9]\\)-?\\([0-9]\\)?") +(defconst iso8601--ordinal-date-match + "\\([-+]\\)?\\([0-9][0-9][0-9][0-9]\\)-?\\([0-9][0-9][0-9]\\)") +(defconst iso8601--date-match + (iso8601--concat-regexps + (list iso8601--year-match + iso8601--full-date-match + iso8601--without-day-match + iso8601--outdated-date-match + iso8601--week-date-match + iso8601--ordinal-date-match))) + +(defconst iso8601--time-match + "\\([0-9][0-9]\\):?\\([0-9][0-9]\\)?:?\\([0-9][0-9]\\)?\\.?\\([0-9][0-9][0-9]\\)?") + +(defconst iso8601--zone-match + "\\(Z\\|\\([-+]\\)\\([0-9][0-9]\\):?\\([0-9][0-9]\\)?\\)") + +(defconst iso8601--full-time-match + (concat "\\(" (replace-regexp-in-string "(" "(?:" iso8601--time-match) "\\)" + "\\(" iso8601--zone-match "\\)?")) + +(defconst iso8601--combined-match + (concat "\\(" iso8601--date-match "\\)" + "\\(?:T\\(" + (replace-regexp-in-string "(" "(?:" iso8601--time-match) + "\\)" + "\\(" iso8601--zone-match "\\)?\\)?")) + +(defconst iso8601--duration-full-match + "P\\([0-9]+Y\\)?\\([0-9]+M\\)?\\([0-9]+D\\)?\\(T\\([0-9]+H\\)?\\([0-9]+M\\)?\\([0-9]+S\\)?\\)?") +(defconst iso8601--duration-week-match + "P\\([0-9]+\\)W") +(defconst iso8601--duration-combined-match + (concat "P" iso8601--combined-match)) +(defconst iso8601--duration-match + (iso8601--concat-regexps + (list iso8601--duration-full-match + iso8601--duration-week-match + iso8601--duration-combined-match))) + +(defun iso8601-parse (string) + "Parse an ISO 8601 date/time string and return a `decoded-time' structure. + +The ISO 8601 date/time strings look like \"2008-03-02T13:47:30\", +but shorter, incomplete strings like \"2008-03-02\" are valid, as +well as variants like \"2008W32\" (week number) and +\"2008-234\" (ordinal day number)." + (if (not (iso8601-valid-p string)) + (signal 'wrong-type-argument string) + (let* ((date-string (match-string 1 string)) + (time-string (match-string 2 string)) + (zone-string (match-string 3 string)) + (date (iso8601-parse-date date-string))) + ;; The time portion is optional. + (when time-string + (let ((time (iso8601-parse-time time-string))) + (setf (decoded-time-hour date) (decoded-time-hour time)) + (setf (decoded-time-minute date) (decoded-time-minute time)) + (setf (decoded-time-second date) (decoded-time-second time)))) + ;; The time zone is optional. + (when zone-string + (setf (decoded-time-zone date) + ;; The time zone in decoded times are in seconds. + (* (iso8601-parse-zone zone-string) 60))) + date))) + +(defun iso8601-parse-date (string) + "Parse STRING (which should be on ISO 8601 format) and return a time value." + (cond + ;; Just a year: [-+]YYYY. + ((iso8601--match iso8601--year-match string) + (iso8601--decoded-time + :year (iso8601--adjust-year (match-string 1 string) + (match-string 2 string)))) + ;; Calendar dates: YYYY-MM-DD and variants. + ((iso8601--match iso8601--full-date-match string) + (iso8601--decoded-time + :year (iso8601--adjust-year (match-string 1 string) + (match-string 2 string)) + :month (match-string 3 string) + :day (match-string 4 string))) + ;; Calendar date without day: YYYY-MM. + ((iso8601--match iso8601--without-day-match string) + (iso8601--decoded-time + :year (iso8601--adjust-year (match-string 1 string) + (match-string 2 string)) + :month (match-string 3 string))) + ;; Outdated date without year: --MM-DD + ((iso8601--match iso8601--outdated-date-match string) + (iso8601--decoded-time + :month (match-string 1 string) + :day (match-string 2 string))) + ;; Week dates: YYYY-Www-D + ((iso8601--match iso8601--week-date-match string) + (let* ((year (iso8601--adjust-year (match-string 1 string) + (match-string 2 string))) + (week (string-to-number (match-string 3 string))) + (day-of-week (and (match-string 4 string) + (string-to-number (match-string 4 string)))) + (jan-start (decoded-time-weekday + (decode-time + (iso8601--encode-time + (iso8601--decoded-time :year year + :month 1 + :day 4))))) + (correction (+ (if (zerop jan-start) 7 jan-start) + 3)) + (ordinal (+ (* week 7) (or day-of-week 0) (- correction)))) + (cond + ;; Monday 29 December 2008 is written "2009-W01-1". + ((< ordinal 1) + (setq year (1- year) + ordinal (+ ordinal (if (date-leap-year-p year) + 366 365)))) + ;; Sunday 3 January 2010 is written "2009-W53-7". + ((> ordinal (if (date-leap-year-p year) + 366 365)) + (setq ordinal (- ordinal (if (date-leap-year-p year) + 366 365)) + year (1+ year)))) + (let ((month-day (date-ordinal-to-time year ordinal))) + (iso8601--decoded-time :year year + :month (decoded-time-month month-day) + :day (decoded-time-day month-day))))) + ;; Ordinal dates: YYYY-DDD + ((iso8601--match iso8601--ordinal-date-match string) + (let* ((year (iso8601--adjust-year (match-string 1 string) + (match-string 2 string))) + (ordinal (string-to-number (match-string 3 string))) + (month-day (date-ordinal-to-time year ordinal))) + (iso8601--decoded-time :year year + :month (decoded-time-month month-day) + :day (decoded-time-day month-day)))) + (t + (signal 'wrong-type-argument string)))) + +(defun iso8601--adjust-year (sign year) + (save-match-data + (let ((year (if (stringp year) + (string-to-number year) + year))) + (if (string= sign "-") + ;; -0001 is 2 BCE. + (1- (- year)) + year)))) + +(defun iso8601-parse-time (string) + "Parse STRING, which should be an ISO 8601 time string, and return a time value." + (if (not (iso8601--match iso8601--full-time-match string)) + (signal 'wrong-type-argument string) + (let ((time (match-string 1 string)) + (zone (match-string 2 string))) + (if (not (iso8601--match iso8601--time-match time)) + (signal 'wrong-type-argument string) + (let ((hour (string-to-number (match-string 1 time))) + (minute (and (match-string 2 time) + (string-to-number (match-string 2 time)))) + (second (and (match-string 3 time) + (string-to-number (match-string 3 time)))) + ;; Hm... + (_millisecond (and (match-string 4 time) + (string-to-number (match-string 4 time))))) + (iso8601--decoded-time :hour hour + :minute (or minute 0) + :second (or second 0) + :zone (and zone + (* 60 (iso8601-parse-zone + zone))))))))) + +(defun iso8601-parse-zone (string) + "Parse STRING, which should be an ISO 8601 time zone. +Return the number of minutes." + (if (not (iso8601--match iso8601--zone-match string)) + (signal 'wrong-type-argument string) + (if (match-string 2 string) + ;; HH:MM-ish. + (let ((hour (string-to-number (match-string 3 string))) + (minute (and (match-string 4 string) + (string-to-number (match-string 4 string))))) + (* (if (equal (match-string 2 string) "-") + -1 + 1) + (+ (* hour 60) + (or minute 0)))) + ;; "Z". + 0))) + +(defun iso8601-valid-p (string) + "Say whether STRING is a valid ISO 8601 representation." + (iso8601--match iso8601--combined-match string)) + +(defun iso8601-parse-duration (string) + "Parse ISO 8601 durations on the form P3Y6M4DT12H30M5S." + (cond + ((and (iso8601--match iso8601--duration-full-match string) + ;; Just a "P" isn't valid; there has to be at least one + ;; element, like P1M. + (> (length (match-string 0 string)) 2)) + (iso8601--decoded-time :year (or (match-string 1 string) 0) + :month (or (match-string 2 string) 0) + :day (or (match-string 3 string) 0) + :hour (or (match-string 5 string) 0) + :minute (or (match-string 6 string) 0) + :second (or (match-string 7 string) 0))) + ;; PnW: Weeks. + ((iso8601--match iso8601--duration-week-match string) + (let ((weeks (string-to-number (match-string 1 string)))) + ;; Does this make sense? Hm... + (iso8601--decoded-time :day (* weeks 7)))) + ;; PT