commit 3ce07b18f9a65f961ce959b5af32d05714f5a802 (HEAD, refs/remotes/origin/master) Author: Eli Zaretskii Date: Sat Feb 18 11:32:45 2017 +0200 Avoid infloop in rect.el * lisp/rect.el (rectangle--*-char): Avoid inflooping when called with argument N whose absolute value is greater than 1. (Bug#25773) diff --git a/lisp/rect.el b/lisp/rect.el index a4fa282791..a85101fddf 100644 --- a/lisp/rect.el +++ b/lisp/rect.el @@ -639,7 +639,8 @@ Activates the region if needed. Only lasts until the region is deactivated." ;; rectangles" and not "visual rectangles", so in the presence of ;; bidirectional text things won't work well anyway. (if (< n 0) (rectangle--*-char other-cmd (- n)) - (let ((col (rectangle--point-col (point)))) + (let ((col (rectangle--point-col (point))) + (step 1)) (while (> n 0) (let* ((bol (line-beginning-position)) (eol (line-end-position)) @@ -647,7 +648,7 @@ Activates the region if needed. Only lasts until the region is deactivated." (nextcol (condition-case nil (save-excursion - (funcall cmd 1) + (funcall cmd step) (cond ((> bol (point)) (- curcol 1)) ((< eol (point)) (+ col (1+ n))) @@ -666,7 +667,8 @@ Activates the region if needed. Only lasts until the region is deactivated." (t ;; (> nextcol curcol) (if (<= diff n) (progn (cl-decf n diff) (setq col nextcol)) - (setq col (if (< col nextcol) (+ col n) (- col n)) n 0)))))) + (setq col (if (< col nextcol) (+ col n) (- col n)) n 0)))) + (setq step (1+ step)))) ;; FIXME: This rectangle--col-pos's move-to-column is wasted! (rectangle--col-pos col 'point)))) commit 73ea77c856ded90cfb1a03a9d87827b5ecb93a7c Author: Eli Zaretskii Date: Sat Feb 18 11:28:42 2017 +0200 Remove annoying warnings about let-binding * src/data.c (Fmake_variable_buffer_local, Fmake_local_variable): Remove warnings about making symbols local while let-bound. (Bug#25561) diff --git a/src/data.c b/src/data.c index 12dc2df0ba..ba5bdc5df3 100644 --- a/src/data.c +++ b/src/data.c @@ -1834,15 +1834,6 @@ The function `default-value' gets the default value and `set-default' sets it. blv = make_blv (sym, forwarded, valcontents); sym->redirect = SYMBOL_LOCALIZED; SET_SYMBOL_BLV (sym, blv); - { - Lisp_Object symbol; - XSETSYMBOL (symbol, sym); /* In case `variable' is aliased. */ - if (let_shadows_global_binding_p (symbol)) - { - AUTO_STRING (format, "Making %s buffer-local while let-bound!"); - CALLN (Fmessage, format, SYMBOL_NAME (variable)); - } - } } blv->local_if_set = 1; @@ -1916,16 +1907,6 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */) blv = make_blv (sym, forwarded, valcontents); sym->redirect = SYMBOL_LOCALIZED; SET_SYMBOL_BLV (sym, blv); - { - Lisp_Object symbol; - XSETSYMBOL (symbol, sym); /* In case `variable' is aliased. */ - if (let_shadows_global_binding_p (symbol)) - { - AUTO_STRING (format, "Making %s local to %s while let-bound!"); - CALLN (Fmessage, format, SYMBOL_NAME (variable), - BVAR (current_buffer, name)); - } - } } /* Make sure this buffer has its own value of symbol. */ commit a83b66923cfb71bb477d7a1f426f7426f91917da Author: Hong Xu Date: Thu Feb 16 13:28:56 2017 -0800 Avoid errors when flyspell-generic-check-word-predicate is a lambda. * flyspell.el (flyspell-auto-correct-word, flyspell-word): Apply functionp instead of fboundp on flyspell-generic-check-word-predicate (Bug#25765). diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index 3a32b75534..0edf9b1a47 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -1111,8 +1111,8 @@ misspelling and skips redundant spell-checking step." (flyspell-word (flyspell-get-word following)) start end poss word ispell-filter) (if (or (eq flyspell-word nil) - (and (fboundp flyspell-generic-check-word-predicate) - (not (funcall flyspell-generic-check-word-predicate)))) + (and (functionp flyspell-generic-check-word-predicate) + (not (funcall flyspell-generic-check-word-predicate)))) t (progn ;; destructure return flyspell-word info list. @@ -1918,7 +1918,7 @@ This command proposes various successive corrections for the current word." ;; invoke the original binding of M-TAB, if that was recorded. (if (and (local-variable-p 'flyspell--prev-meta-tab-binding) (commandp flyspell--prev-meta-tab-binding t) - (fboundp flyspell-generic-check-word-predicate) + (functionp flyspell-generic-check-word-predicate) (not (funcall flyspell-generic-check-word-predicate)) (equal (where-is-internal 'flyspell-auto-correct-word nil t) [?\M-\t])) commit 22b2207471807bda86534b4faf1a29b3a6447536 Author: Glenn Morris Date: Fri Feb 17 20:15:21 2017 -0500 Remove the build number from emacs-version variable It's a largely internal detail that can confuse users. (Bug#25590) * lisp/version.el (emacs-build-number): New constant. (emacs-version): Use emacs-build-number. * lisp/loadup.el (top-level): When dumping, increment emacs-build-number rather than emacs-version. * src/emacs.c (emacs-version): Doc fix. * doc/lispref/intro.texi (Version Info): Update emacs-version details. Mention emacs-build-number. * lisp/gnus/gnus-util.el (gnus-emacs-version): * lisp/mail/emacsbug.el (report-emacs-bug): * admin/admin.el (set-version): Update for emacs-version change. ; * etc/NEWS: Mention this. diff --git a/admin/admin.el b/admin/admin.el index 4892045a69..a6ef19c9ab 100644 --- a/admin/admin.el +++ b/admin/admin.el @@ -93,9 +93,7 @@ Optional argument DATE is the release date, default today." Root must be the root of an Emacs source tree." (interactive (list (read-directory-name "Emacs root directory: " source-directory) - (read-string "Version number: " - (replace-regexp-in-string "\\.[0-9]+\\'" "" - emacs-version)))) + (read-string "Version number: " emacs-version))) (unless (file-exists-p (expand-file-name "src/emacs.c" root)) (user-error "%s doesn't seem to be the root of an Emacs source tree" root)) (message "Setting version numbers...") diff --git a/doc/lispref/intro.texi b/doc/lispref/intro.texi index d871d3a87b..61ef3082a0 100644 --- a/doc/lispref/intro.texi +++ b/doc/lispref/intro.texi @@ -480,8 +480,8 @@ running. It is useful to include this string in bug reports. @smallexample @group (emacs-version) - @result{} "GNU Emacs 24.5.1 (x86_64-unknown-linux-gnu, GTK+ Version 3.16) - of 2015-06-01" + @result{} "GNU Emacs 26.1 (build 1, x86_64-unknown-linux-gnu, + GTK+ Version 3.16) of 2017-06-01" @end group @end smallexample @@ -507,11 +507,11 @@ emacs-build-time @defvar emacs-version The value of this variable is the version of Emacs being run. It is a -string such as @code{"23.1.1"}. The last number in this string is not -really part of the Emacs release version number; it is incremented -each time Emacs is built in any given directory. A value with four -numeric components, such as @code{"22.0.91.1"}, indicates an -unreleased test version. +string such as @code{"26.1"}. A value with three numeric components, +such as @code{"26.0.91"}, indicates an unreleased test version. +(Prior to Emacs 26.1, the string includes an extra final component +with the integer that is now stored in @code{emacs-build-number}; +e.g., @code{"25.1.1"}.) @end defvar @defvar emacs-major-version @@ -524,6 +524,12 @@ The minor version number of Emacs, as an integer. For Emacs version 23.1, the value is 1. @end defvar +@defvar emacs-build-number +An integer that increments each time Emacs is built in the same +directory (without cleaning). This is only of relevance when +developing Emacs. +@end defvar + @node Acknowledgments @section Acknowledgments diff --git a/etc/NEWS b/etc/NEWS index 0ceb878a8e..73085f626b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -80,6 +80,9 @@ for '--daemon'. * Changes in Emacs 26.1 +** The variable 'emacs-version' no longer includes the build number. +This is now stored separately in a new variable, 'emacs-build-number'. + +++ ** The new function 'mapbacktrace' applies a function to all frames of the current stack trace. diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index ff5c295091..20eceb58ed 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -1618,7 +1618,7 @@ sequence, this is like `mapcar'. With several, it is like the Common Lisp ((not (memq 'emacs lst)) nil) ((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version) - (concat "Emacs/" (match-string 1 emacs-version) + (concat "Emacs/" emacs-version (if system-v (concat " (" system-v ")") ""))) diff --git a/lisp/loadup.el b/lisp/loadup.el index ecb72840c4..5b19b05a82 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -350,7 +350,7 @@ lost after dumping"))) (multibyte-string-p default-directory)) (error "default-directory must be unibyte when dumping Emacs!")) -;; Determine which last version number to use +;; Determine which build number to use ;; based on the executables that now exist. (if (and (equal (last command-line-args) '("dump")) (not (eq system-type 'ms-dos))) @@ -364,10 +364,9 @@ lost after dumping"))) files))) (setq emacs-repository-version (condition-case nil (emacs-repository-get-version) (error nil))) - ;; `emacs-version' is a constant, so we shouldn't change it with `setq'. - (defconst emacs-version - (format "%s.%d" - emacs-version (if versions (1+ (apply 'max versions)) 1))))) + ;; A constant, so we shouldn't change it with `setq'. + (defconst emacs-build-number + (if versions (1+ (apply 'max versions)) 1)))) (message "Finding pointers to doc strings...") @@ -463,7 +462,7 @@ lost after dumping"))) ;; Don't bother adding another name if we're just ;; building bootstrap-emacs. (equal (last command-line-args) '("bootstrap")))) - (let ((name (concat "emacs-" emacs-version)) + (let ((name (format "emacs-%s.%d" emacs-version emacs-build-number)) (exe (if (eq system-type 'windows-nt) ".exe" ""))) (while (string-match "[^-+_.a-zA-Z0-9]+" name) (setq name (concat (downcase (substring name 0 (match-beginning 0))) diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el index c8214c3510..ecb7db60ae 100644 --- a/lisp/mail/emacsbug.el +++ b/lisp/mail/emacsbug.el @@ -151,10 +151,7 @@ Prompts for bug subject. Leaves you in a mail buffer." (interactive "sBug Subject: ") ;; The syntax `version;' is preferred to `[version]' because the ;; latter could be mistakenly stripped by mailing software. - (if (eq system-type 'ms-dos) - (setq topic (concat emacs-version "; " topic)) - (when (string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version) - (setq topic (concat (match-string 1 emacs-version) "; " topic)))) + (setq topic (concat emacs-version "; " topic)) (let ((from-buffer (current-buffer)) (can-insert-mail (or (report-emacs-bug-can-use-xdg-email) (report-emacs-bug-can-use-osx-open))) diff --git a/lisp/version.el b/lisp/version.el index 99ab3519a7..ea6f1b4694 100644 --- a/lisp/version.el +++ b/lisp/version.el @@ -44,6 +44,12 @@ This variable first existed in version 19.23.") (defconst emacs-build-time (if emacs-build-system (current-time)) "Time at which Emacs was dumped out, or nil if not available.") +(defconst emacs-build-number 1 ; loadup.el may increment this + "The build number of this version of Emacs. +This is an integer that increments each time Emacs is built in a given +directory (without cleaning). This is likely to only be relevant when +developing Emacs.") + (defvar motif-version-string) (defvar gtk-version-string) (defvar ns-version-string) @@ -56,8 +62,9 @@ Don't use this function in programs to choose actions according to the system configuration; look at `system-configuration' instead." (interactive "P") (let ((version-string - (format "GNU Emacs %s (%s%s%s%s)%s" + (format "GNU Emacs %s (build %s, %s%s%s%s)%s" emacs-version + emacs-build-number system-configuration (cond ((featurep 'motif) (concat ", " (substring motif-version-string 4))) diff --git a/src/emacs.c b/src/emacs.c index 3083d0df30..e5305e2741 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -2607,7 +2607,12 @@ This is nil during initialization. */); Vemacs_copyright = build_string (emacs_copyright); DEFVAR_LISP ("emacs-version", Vemacs_version, - doc: /* Version numbers of this version of Emacs. */); + doc: /* Version numbers of this version of Emacs. +This has the form: MAJOR.MINOR[.MICRO], where MAJOR/MINOR/MICRO are integers. +MICRO is only present in unreleased development versions, +and is not especially meaningful. Prior to Emacs 26.1, an extra final +component .BUILD is present. This is now stored separately in +`emacs-build-number'. */); Vemacs_version = build_string (emacs_version); DEFVAR_LISP ("report-emacs-bug-address", Vreport_emacs_bug_address, commit 8675f9c8b8a002530d0c4e0263bb3d4cf3a649fa Author: Glenn Morris Date: Fri Feb 17 19:06:15 2017 -0500 Ensure that user-mail-address always has a value * lisp/startup.el (user-mail-address): Initialize in the normal way. (command-line): Reset user-mail-address if needed using standard custom machinery. * lisp/mail/feedmail.el (feedmail-fiddle-from): * lisp/mail/rmail.el (rmail-unknown-mail-followup-to): * lisp/mail/rmailsum.el (rmail-header-summary): Simplify now that user-mail-address is always set. ; * doc/lispref/os.texi (System Environment): Remove fixme comment. diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index c0a9c81fda..9b6752c5e1 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -941,8 +941,6 @@ If this variable is non-@code{nil}, it is used instead of @code{system-name} for purposes of generating email addresses. For example, it is used when constructing the default value of @code{user-mail-address}. @xref{User Identification}. -@c FIXME sounds like should probably give this a :set-after and some -@c custom-initialize-delay voodoo. @end defopt @deffn Command getenv var &optional frame diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el index 53791565bb..e0bd4590b1 100644 --- a/lisp/mail/feedmail.el +++ b/lisp/mail/feedmail.el @@ -2759,24 +2759,17 @@ return that value." (cond ;; nil means do nothing ((eq nil feedmail-from-line) nil) - ;; t is the same a using the default computation, so compute it and recurse + ;; t is the same as using the default computation, so compute it and recurse ;; user-full-name suggested by kpc@ptolemy.arc.nasa.gov (=Kimball Collins) ;; improvement using user-mail-address suggested by ;; gray@austin.apc.slb.com (Douglas Gray Stephens) - ;; improvement using mail-host-address suggested by "Jason Eisner" - ;; ((this situation really is hopeless, though) ((eq t feedmail-from-line) (let ((feedmail-from-line - (let ((at-stuff - (if (> (length user-mail-address) 0) - user-mail-address - (concat (user-login-name) "@" - (or mail-host-address (system-name)))))) - (cond - ((eq mail-from-style nil) at-stuff) - ((eq mail-from-style 'parens) (concat at-stuff " (" (user-full-name) ")")) - ((eq mail-from-style 'angles) (concat "\"" (user-full-name) "\" <" at-stuff ">")) - )))) + (cond + ((eq mail-from-style nil) user-mail-address) + ((eq mail-from-style 'parens) (concat user-mail-address " (" (user-full-name) ")")) + ((eq mail-from-style 'angles) (concat "\"" (user-full-name) "\" <" user-mail-address ">")) + ))) (feedmail-fiddle-from))) ;; if it's a string, simply make a fiddle-plex out of it and recurse diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index 695638fa06..4b72b3562d 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -2665,12 +2665,7 @@ Ask the user whether to add that list name to `mail-mailing-lists'." (concat "^\\(" (regexp-quote (user-login-name)) "\\($\\|@\\)\\|" - (regexp-quote - (if (> (length user-mail-address) 0) - user-mail-address - (concat (user-login-name) "@" - (or mail-host-address - (system-name))))) + (regexp-quote user-mail-address) "\\>\\)")) addr)) (y-or-n-p diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el index 729538173a..37ac46c6af 100644 --- a/lisp/mail/rmailsum.el +++ b/lisp/mail/rmailsum.el @@ -753,15 +753,7 @@ the message being processed." (concat "^\\(" (regexp-quote (user-login-name)) "\\($\\|@\\)\\|" - (regexp-quote - ;; Don't lose if run from init file - ;; where user-mail-address is not - ;; set yet. - (if (> (length user-mail-address) 0) - user-mail-address - (concat (user-login-name) "@" - (or mail-host-address - (system-name))))) + (regexp-quote user-mail-address) "\\>\\)")) from)) ;; No From field, or it's this user. diff --git a/lisp/startup.el b/lisp/startup.el index 4272708ce9..2d48bd5df1 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -381,17 +381,14 @@ If this is nil, Emacs uses `system-name'." :type '(choice (const nil) string) :group 'mail) -(defcustom user-mail-address (if command-line-processed - (or (getenv "EMAIL") - (concat (user-login-name) "@" - (or mail-host-address - (system-name)))) - ;; Empty string means "not set yet". - "") - "Full mailing address of this user. -This is initialized with environment variable `EMAIL' or, as a -fallback, using `mail-host-address'. This is done after your -init file is read, in case it sets `mail-host-address'." +(defcustom user-mail-address + (or (getenv "EMAIL") + (concat (user-login-name) "@" (or mail-host-address (system-name)))) + "The email address of the current user. +This defaults to either: the value of EMAIL environment variable; or +user@host, using `user-login-name' and `mail-host-address' (or `system-name')." + :initialize 'custom-initialize-delay + :set-after '(mail-host-address) :type 'string :group 'mail) @@ -1296,11 +1293,17 @@ the `--debug-init' option to view a complete error backtrace." (set-language-environment current-language-environment))) ;; Do this here in case the init file sets mail-host-address. - (if (equal user-mail-address "") - (setq user-mail-address (or (getenv "EMAIL") - (concat (user-login-name) "@" - (or mail-host-address - (system-name)))))) + (and mail-host-address + ;; Check that user-mail-address has not been set by hand. + ;; Yes, this is ugly, but slightly less so than leaving + ;; user-mail-address uninitialized during init file processing. + ;; Perhaps we should make :set-after do something like this? + ;; Ie, extend it to also mean (re)initialize-after. + (equal user-mail-address + (let (mail-host-address) + (ignore-errors + (eval (car (get 'user-mail-address 'standard-value)))))) + (custom-reevaluate-setting 'user-mail-address)) ;; If parameter have been changed in the init file which influence ;; face realization, clear the face cache so that new faces will commit f3eaab0a3749822592ddf36e591dcafd31451177 Author: Mark Oteiza Date: Fri Feb 17 19:01:11 2017 -0500 Turn on lexical-binding in ruby-mode * lisp/progmodes/ruby-mode.el: Turn on lexical-binding. (ruby-font-lock-syntax-table): Use make-syntax-table. (ruby-mode): 'define-derived-mode' writes the keys for us. diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el index 036d071f10..6f431ecd30 100644 --- a/lisp/progmodes/ruby-mode.el +++ b/lisp/progmodes/ruby-mode.el @@ -1,4 +1,4 @@ -;;; ruby-mode.el --- Major mode for editing Ruby files +;;; ruby-mode.el --- Major mode for editing Ruby files -*- lexical-binding: t -*- ;; Copyright (C) 1994-2017 Free Software Foundation, Inc. @@ -2035,7 +2035,7 @@ It will be properly highlighted even when the call omits parens.") t))) (defvar ruby-font-lock-syntax-table - (let ((tbl (copy-syntax-table ruby-mode-syntax-table))) + (let ((tbl (make-syntax-table ruby-mode-syntax-table))) (modify-syntax-entry ?_ "w" tbl) tbl) "The syntax table to use for fontifying Ruby mode buffers. @@ -2255,9 +2255,7 @@ See `font-lock-syntax-table'.") ;;;###autoload (define-derived-mode ruby-mode prog-mode "Ruby" - "Major mode for editing Ruby code. - -\\{ruby-mode-map}" + "Major mode for editing Ruby code." (ruby-mode-variables) (setq-local imenu-create-index-function 'ruby-imenu-create-index) @@ -2286,7 +2284,8 @@ See `font-lock-syntax-table'.") "\\(?:Gem\\|Rake\\|Cap\\|Thor" "\\|Puppet\\|Berks" "\\|Vagrant\\|Guard\\|Pod\\)file" - "\\)\\'")) 'ruby-mode)) + "\\)\\'")) + 'ruby-mode)) ;;;###autoload (dolist (name (list "ruby" "rbx" "jruby" "ruby1.9" "ruby1.8")) commit edadd31bf4b5516acf3d041f79cf7164c584e052 Author: Mark Oteiza Date: Fri Feb 17 18:52:12 2017 -0500 Turn on lexical-binding in elint.el * lisp/emacs-lisp/elint.el: Quote entry point commands in commentary. (elint-running, elint-current-pos): Move these dynamic vars to toward the top of the file. (elint-check-quote-form): Ignore unused argument. (elint-check-conditional-form): Remove unused binding. diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index f5e10a24d3..a14bd0d764 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -1,4 +1,4 @@ -;;; elint.el --- Lint Emacs Lisp +;;; elint.el --- Lint Emacs Lisp -*- lexical-binding: t -*- ;; Copyright (C) 1997, 2001-2017 Free Software Foundation, Inc. @@ -27,7 +27,7 @@ ;; misspellings and undefined variables, although it can also catch ;; function calls with the wrong number of arguments. -;; To use, call elint-current-buffer or elint-defun to lint a buffer +;; To use, call `elint-current-buffer' or `elint-defun' to lint a buffer ;; or defun. The first call runs `elint-initialize' to set up some ;; argument data, which may take a while. @@ -154,6 +154,9 @@ Set by `elint-initialize', if `elint-scan-preloaded' is non-nil.") "Regexp matching elements of `preloaded-file-list' to ignore. We ignore them because they contain no definitions of use to Elint.") +(defvar elint-running) +(defvar elint-current-pos) ; dynamically bound in elint-top-form + ;;; ;;; ADT: top-form ;;; @@ -862,7 +865,7 @@ CODE can be a lambda expression, a macro, or byte-compiled code." (t (elint-error "Not a function object: %s" form) env)))) -(defun elint-check-quote-form (form env) +(defun elint-check-quote-form (_form env) "Lint the quote FORM in ENV." env) @@ -903,8 +906,7 @@ CODE can be a lambda expression, a macro, or byte-compiled code." "Check the when/unless/and/or FORM in ENV. Does basic handling of `featurep' tests." (let ((func (car form)) - (test (cadr form)) - sym) + (test (cadr form))) ;; Misses things like (and t (featurep 'xemacs)) ;; Check byte-compile-maybe-guarded. (cond ((and (memq func '(when and)) @@ -967,8 +969,6 @@ Does basic handling of `featurep' tests." ;;; Message functions ;;; -(defvar elint-current-pos) ; dynamically bound in elint-top-form - (defun elint-log (type string args) (elint-log-message (format "%s:%d:%s: %s" (let ((f (buffer-file-name))) @@ -1038,8 +1038,6 @@ Insert HEADER followed by a blank line if non-nil." (display-buffer (elint-get-log-buffer)) (sit-for 0))) -(defvar elint-running) - (defun elint-set-mode-line (&optional on) "Set the mode-line-process of the Elint log buffer." (with-current-buffer (elint-get-log-buffer) commit 5401820672c650f47bf055ebbf3cc590f90cb05a Author: Gemini Lasswell Date: Sat Feb 4 16:16:11 2017 -0800 * lisp/emacs-lisp/subr-x.el (if-let*): Fix Edebug spec (Bug#24748) diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index f7a846927c..1d729f9409 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -126,7 +126,8 @@ In the special case you only want to bind a single value, VARLIST can just be a plain tuple. \n(fn VARLIST THEN ELSE...)" (declare (indent 2) - (debug ([&or (&rest (symbolp form)) (symbolp form)] form body))) + (debug ([&or (&rest [&or symbolp (symbolp form)]) (symbolp form)] + form body))) (when (and (<= (length bindings) 2) (not (listp (car bindings)))) ;; Adjust the single binding case commit 071680b734f54733614e355ce4b89bd2300a632b Author: Mark Oteiza Date: Fri Feb 17 18:38:09 2017 -0500 Enable erc-accidental-paste-threshold-seconds by default * lisp/erc/erc.el (erc-accidental-paste-threshold-seconds): Set default to 0.2 (Bug#25709). diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 751bcde700..488404d734 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -5331,7 +5331,7 @@ Specifically, return the position of `erc-insert-marker'." "Time of last call to `erc-send-current-line'. If that function has never been called, the value is 0.") -(defcustom erc-accidental-paste-threshold-seconds nil +(defcustom erc-accidental-paste-threshold-seconds 0.2 "Minimum time, in seconds, before sending new lines via IRC. If the value is a number, `erc-send-current-line' signals an error if its previous invocation was fewer than this many seconds ago. @@ -5341,7 +5341,7 @@ into the ERC buffer, that text is not sent to the IRC server. If the value is nil, `erc-send-current-line' always considers any submitted line to be intentional." :group 'erc - :version "24.4" + :version "26.1" :type '(choice number (other :tag "disabled" nil))) (defun erc-send-current-line () commit 9f9863e50298a3506165cc1f056ab3238f37cb9f Author: Michal Nazarewicz Date: Fri Feb 17 16:36:44 2017 +0100 Fix build failure caused by ‘Generate upcase and downcase tables from Unicode’ The [5ec3a584: Generate upcase and downcase tables from Unicode data] commit broke bootstrap from a truly clean tree (e.g. a fresh clone or one created with ‘make extraclean’), see . The failure was caused by characters.el trying to read Unicode property tables which aren’t available so early in the build process. Wrap the part that requires Unicode property tables in a condition checking if those are available. If they aren’t they case and syntax tables won’t be fully set but later on, the characters.el file will be evaluated again and this time with Unicode properties available so final Emacs ends up with the exact same case and syntax tables. diff --git a/lisp/international/characters.el b/lisp/international/characters.el index 9e993e7060..3eb287fd96 100644 --- a/lisp/international/characters.el +++ b/lisp/international/characters.el @@ -665,70 +665,74 @@ with L, LRE, or LRO Unicode bidi character type.") ;; Combining marks (modify-category-entry '(#x20d0 . #x20ff) ?^) - ;; Set all Letter, uppercase; Letter, lowercase and Letter, titlecase syntax - ;; to word. - (let ((syn-tab (standard-syntax-table))) - (map-char-table - (lambda (ch cat) - (when (memq cat '(Lu Ll Lt)) - (modify-syntax-entry ch "w " syn-tab))) - (unicode-property-table-internal 'general-category)) - - ;; Ⅰ through Ⅻ had word syntax in the past so set it here as well. - ;; The general category of those characters is Number, Letter. - (modify-syntax-entry '(#x2160 . #x216b) "w " syn-tab) - - ;; ⓐ through ⓩ are symbols, other according to Unicode but Emacs set - ;; their syntax to word in the past so keep backwards compatibility. - (modify-syntax-entry '(#x24D0 . #x24E9) "w " syn-tab)) - - ;; Set downcase and upcase from Unicode properties - - ;; In some languages, such as Turkish, U+0049 LATIN CAPITAL LETTER I and - ;; U+0131 LATIN SMALL LETTER DOTLESS I make a case pair, and so do U+0130 - ;; LATIN CAPITAL LETTER I WITH DOT ABOVE and U+0069 LATIN SMALL LETTER I. - - ;; We used to set up half of those correspondence unconditionally, but that - ;; makes searches slow. So now we don't set up either half of these - ;; correspondences by default. - - ;; (set-downcase-syntax ?İ ?i tbl) - ;; (set-upcase-syntax ?I ?ı tbl) - - (let ((map-unicode-property - (lambda (property func) - (map-char-table - (lambda (ch cased) - ;; ASCII characters skipped due to reasons outlined above. As of - ;; Unicode 9.0, this exception affects the following: - ;; lc(U+0130 İ) = i - ;; uc(U+0131 ı) = I - ;; uc(U+017F ſ) = S - ;; uc(U+212A K) = k - (when (> cased 127) - (let ((end (if (consp ch) (cdr ch) ch))) - (setq ch (max 128 (if (consp ch) (car ch) ch))) - (while (<= ch end) - (funcall func ch cased) - (setq ch (1+ ch)))))) - (unicode-property-table-internal property)))) - (down tbl) - (up (case-table-get-table tbl 'up))) - - ;; This works on an assumption that if toUpper(x) != x then toLower(x) == - ;; x (and the opposite for toLower/toUpper). This doesn’t hold for title - ;; case characters but those incorrect mappings will be overwritten later. - (funcall map-unicode-property 'uppercase - (lambda (lc uc) (aset down lc lc) (aset up uc uc))) - (funcall map-unicode-property 'lowercase - (lambda (uc lc) (aset down lc lc) (aset up uc uc))) - - ;; Now deal with the actual mapping. This will correctly assign casing for - ;; title-case characters. - (funcall map-unicode-property 'uppercase - (lambda (lc uc) (aset up lc uc) (aset up uc uc))) - (funcall map-unicode-property 'lowercase - (lambda (uc lc) (aset down uc lc) (aset down lc lc)))) + (let ((gc (unicode-property-table-internal 'general-category)) + (syn-table (standard-syntax-table))) + ;; In early bootstrapping Unicode tables are not available so we need to + ;; skip this step in those cases. + (when gc + ;; Set all Letter, uppercase; Letter, lowercase and Letter, + ;; titlecase syntax to word. + (map-char-table + (lambda (ch cat) + (when (memq cat '(Lu Ll Lt)) + (modify-syntax-entry ch "w " syn-table))) + gc) + ;; Ⅰ through Ⅻ had word syntax in the past so set it here as well. + ;; The general category of those characters is Number, Letter. + (modify-syntax-entry '(#x2160 . #x216b) "w " syn-table) + + ;; ⓐ through ⓩ are symbols, other according to Unicode but Emacs set + ;; their syntax to word in the past so keep backwards compatibility. + (modify-syntax-entry '(#x24D0 . #x24E9) "w " syn-table) + + ;; Set downcase and upcase from Unicode properties + + ;; In some languages, such as Turkish, U+0049 LATIN CAPITAL LETTER I and + ;; U+0131 LATIN SMALL LETTER DOTLESS I make a case pair, and so do U+0130 + ;; LATIN CAPITAL LETTER I WITH DOT ABOVE and U+0069 LATIN SMALL LETTER I. + + ;; We used to set up half of those correspondence unconditionally, but + ;; that makes searches slow. So now we don't set up either half of these + ;; correspondences by default. + + ;; (set-downcase-syntax ?İ ?i tbl) + ;; (set-upcase-syntax ?I ?ı tbl) + + (let ((map-unicode-property + (lambda (property func) + (map-char-table + (lambda (ch cased) + ;; ASCII characters skipped due to reasons outlined above. As + ;; of Unicode 9.0, this exception affects the following: + ;; lc(U+0130 İ) = i + ;; uc(U+0131 ı) = I + ;; uc(U+017F ſ) = S + ;; uc(U+212A K) = k + (when (> cased 127) + (let ((end (if (consp ch) (cdr ch) ch))) + (setq ch (max 128 (if (consp ch) (car ch) ch))) + (while (<= ch end) + (funcall func ch cased) + (setq ch (1+ ch)))))) + (unicode-property-table-internal property)))) + (down tbl) + (up (case-table-get-table tbl 'up))) + + ;; This works on an assumption that if toUpper(x) != x then toLower(x) + ;; == x (and the opposite for toLower/toUpper). This doesn’t hold for + ;; title case characters but those incorrect mappings will be + ;; overwritten later. + (funcall map-unicode-property 'uppercase + (lambda (lc uc) (aset down lc lc) (aset up uc uc))) + (funcall map-unicode-property 'lowercase + (lambda (uc lc) (aset down lc lc) (aset up uc uc))) + + ;; Now deal with the actual mapping. This will correctly assign casing + ;; for title-case characters. + (funcall map-unicode-property 'uppercase + (lambda (lc uc) (aset up lc uc) (aset up uc uc))) + (funcall map-unicode-property 'lowercase + (lambda (uc lc) (aset down uc lc) (aset down lc lc)))))) ;; Clear out the extra slots so that they will be recomputed from the main ;; (downcase) table and upcase table. Since we’re side-stepping the usual commit 630e2d2e6aeba60f178c6ef2b283622070b873b3 Author: Katsumi Yamaoka Date: Fri Feb 17 10:05:56 2017 +0000 mm-add-meta-html-tag: Improve regexp * lisp/gnus/mm-decode.el (mm-add-meta-html-tag): Improve regexp to search html meta tag. diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index 6b53939959..6683d68a31 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -1413,8 +1413,8 @@ Return t if meta tag is added or replaced." (let ((case-fold-search t)) (goto-char (point-min)) (if (re-search-forward "\ -]+\\)\\)?[^>]*>" nil t) +]+\\)\\)?[^>]*>" nil t) (if (and (not force-charset) (match-beginning 2) (string-match "\\`html\\'" (match-string 1))) commit 79f017d5c3019f8bc2a5014beda28bb3b829a8e3 Author: Katsumi Yamaoka Date: Fri Feb 17 09:52:09 2017 +0000 mm-shr: Prefer charset specified in html meta tag * lisp/gnus/mm-decode.el (mm-shr): Prefer charset specified in html meta tag than mail-parse-charset in the case there is no charset spec in MIME header. diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index 989d4b8ea1..6b53939959 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -1793,40 +1793,44 @@ If RECURSIVE, search recursively." (buffer-string)))))) (shr-inhibit-images mm-html-inhibit-images) (shr-blocked-images mm-html-blocked-images) - charset coding char) - (unless handle - (setq handle (mm-dissect-buffer t))) - (and (setq charset - (or (mail-content-type-get (mm-handle-type handle) 'charset) - mail-parse-charset)) - (setq coding (mm-charset-to-coding-system charset nil t)) - (eq coding 'ascii) - (setq coding nil)) + charset coding char document) + (mm-with-part (or handle (setq handle (mm-dissect-buffer t))) + (setq case-fold-search t) + (setq charset + (or (mail-content-type-get (mm-handle-type handle) 'charset) + (progn + (goto-char (point-min)) + (and (re-search-forward "\ +]+\\)\\)?[^>]*>" nil t) + (setq coding + (mm-charset-to-coding-system (match-string 2) + nil t)) + (string-match "\\`html\\'" (match-string 1)))) + mail-parse-charset)) + (when (or coding + (setq coding (mm-charset-to-coding-system charset nil t))) + (insert (prog1 + (decode-coding-string (buffer-string) coding) + (erase-buffer) + (set-buffer-multibyte t)))) + (goto-char (point-min)) + (while (re-search-forward + "&#\\(?:x\\([89][0-9a-f]\\)\\|\\(1[2-5][0-9]\\)\\);" nil t) + (when (setq char + (cdr (assq (if (match-beginning 1) + (string-to-number (match-string 1) 16) + (string-to-number (match-string 2))) + mm-extra-numeric-entities))) + (replace-match (char-to-string char)))) + ;; Remove "soft hyphens". + (goto-char (point-min)) + (while (search-forward "­" nil t) + (replace-match "" t t)) + (setq document (libxml-parse-html-region (point-min) (point-max)))) (save-restriction (narrow-to-region (point) (point)) - (shr-insert-document - (mm-with-part handle - (insert (prog1 - (if coding - (decode-coding-string (buffer-string) coding) - (buffer-string)) - (erase-buffer) - (mm-enable-multibyte))) - (goto-char (point-min)) - (setq case-fold-search t) - (while (re-search-forward - "&#\\(?:x\\([89][0-9a-f]\\)\\|\\(1[2-5][0-9]\\)\\);" nil t) - (when (setq char - (cdr (assq (if (match-beginning 1) - (string-to-number (match-string 1) 16) - (string-to-number (match-string 2))) - mm-extra-numeric-entities))) - (replace-match (char-to-string char)))) - ;; Remove "soft hyphens". - (goto-char (point-min)) - (while (search-forward "­" nil t) - (replace-match "" t t)) - (libxml-parse-html-region (point-min) (point-max)))) + (shr-insert-document document) (unless (bobp) (insert "\n")) (mm-convert-shr-links) commit 78f869687e86d4a9f91003dbbbbacde2e2741487 Author: Glenn Morris Date: Thu Feb 16 21:43:23 2017 -0800 Stop duplicating some custom-types in message.el * lisp/gnus/message.el (user-mail-address, user-full-name): No need to re-specify custom-type. diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 2819269122..079ed52ba5 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -64,9 +64,6 @@ :group 'mail :group 'news) -(put 'user-mail-address 'custom-type 'string) -(put 'user-full-name 'custom-type 'string) - (defgroup message-various nil "Various Message Variables." :link '(custom-manual "(message)Various Message Variables") commit 3ea055c90ed0b6c486518265300fa7219f8e5a29 Author: Glenn Morris Date: Thu Feb 16 20:33:24 2017 -0800 Whitespace trivia in dunnet.el * lisp/play/dunnet.el (dun-special-object, dun-put-objs) (dun-rlogin-endgame): Whitespace trivia. diff --git a/lisp/play/dunnet.el b/lisp/play/dunnet.el index ed5b4c6506..8ddb680f25 100644 --- a/lisp/play/dunnet.el +++ b/lisp/play/dunnet.el @@ -152,7 +152,7 @@ your objects, to give off an eerie glow.")) (progn (if (not dun-inbus) (progn - (dun-mprincl"You fall into a hole in the ground.") + (dun-mprincl "You fall into a hole in the ground.") (setq dun-current-room vermont-station) (dun-describe-room vermont-station)) (progn @@ -555,7 +555,7 @@ with a bang. The key seems to have vanished!") (dun-mprincl "I don't know how to combine those objects. Perhaps you should just try dropping it.") - (dun-mprincl"You can't put that there."))))))))))) + (dun-mprincl "You can't put that there."))))))))))) (defun dun-type (_args) (if (not (= dun-current-room computer-room)) @@ -2990,7 +2990,7 @@ drwxr-xr-x 3 root staff 2048 Jan 1 1970 ..") (if (not (= (dun-score nil) 90)) (dun-mprincl "You have not achieved enough points to connect to endgame.") - (dun-mprincl"\nWelcome to the endgame. You are a truly noble adventurer.") + (dun-mprincl "\nWelcome to the endgame. You are a truly noble adventurer.") (setq dun-current-room treasure-room) (setq dun-endgame t) (dun-replace dun-room-objects endgame-treasure-room (list obj-bill)) commit b91bfa10413182654a76d0ba337198f39a4d0e8e Author: Glenn Morris Date: Thu Feb 16 20:24:37 2017 -0800 Explicit error on changing case of negative integers * src/casefiddle.c (casify_object): Reject negative integers: Emacs characters are positive integers. (Bug#25684) diff --git a/src/casefiddle.c b/src/casefiddle.c index b2b87e7a85..11d5944491 100644 --- a/src/casefiddle.c +++ b/src/casefiddle.c @@ -41,7 +41,7 @@ casify_object (enum case_action flag, Lisp_Object obj) if (NILP (XCHAR_TABLE (BVAR (current_buffer, downcase_table))->extras[1])) Fset_case_table (BVAR (current_buffer, downcase_table)); - if (INTEGERP (obj)) + if (NATNUMP (obj)) { int flagbits = (CHAR_ALT | CHAR_SUPER | CHAR_HYPER | CHAR_SHIFT | CHAR_CTL | CHAR_META); commit 7cc95d4d86e5a9f2df248d2aa7c8cc423c8f06e3 Author: Dmitry Gutov Date: Fri Feb 17 03:00:46 2017 +0200 Fix buffers update in vc-retrieve-tag * lisp/vc/vc.el (vc-retrieve-tag): When the granularity is `repository', use the repository root and pass it to vc-resynch-buffer (bug#25714). diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index c66a0921e4..c3088560c1 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -2157,7 +2157,7 @@ checked out in that new branch." NAME can name a branch, in which case this command will switch to the named branch in the directory DIR. Interactively, prompt for DIR only for VCS that works at file level; -otherwise use the default directory of the current buffer. +otherwise use the repository root of the current buffer. If NAME is empty, it refers to the latest revisions of the current branch. If locking is used for the files in DIR, then there must not be any locked files at or below DIR (but if NAME is empty, locked files are @@ -2170,7 +2170,9 @@ allowed and simply skipped)." (if (eq granularity 'repository) ;; For VC's that do not work at file level, it's pointless ;; to ask for a directory, branches are created at repository level. - default-directory + ;; XXX: Either we call expand-file-name here, or use + ;; file-in-directory-p inside vc-resynch-buffers-in-directory. + (expand-file-name (vc-root-dir)) (read-directory-name "Directory: " default-directory default-directory t)) (read-string "Tag name to retrieve (default latest revisions): ")))) (let ((update (yes-or-no-p "Update any affected buffers? ")) commit cb70725584a754a491ddad82c42278f17c714a2f Author: Paul Eggert Date: Thu Feb 16 09:17:45 2017 -0800 ; Spelling, punctuation and minor wording fixes diff --git a/ChangeLog.3 b/ChangeLog.3 index 835ee08ba0..1c2f5b1d2f 100644 --- a/ChangeLog.3 +++ b/ChangeLog.3 @@ -5090,7 +5090,7 @@ (image-dired-cmd-rotate-thumbnail-program) (image-dired-cmd-write-exif-data-program) (image-dired-cmd-read-exif-data-program): - Use executable-find to set the defaut value of this option. + Use executable-find to set the default value of this option. (image-dired-cmd-rotate-original-program): Idem. Search for program 'convert' if 'jpegtran' is not available. (image-dired-cmd-rotate-original-options): diff --git a/etc/NEWS b/etc/NEWS index a54c655c36..0ceb878a8e 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -340,9 +340,10 @@ the file's actual content before prompting the user. ** Title case characters are properly converted to upper case. 'upcase', 'upcase-region' et al. convert title case characters (such -as Dz) into their upper case form (such as DZ). As a downside, -'capitalize' and 'upcase-initials' produce awkward words where first -two letters are upper case, e.g. DŽungla (instead of Džungla). +as the single character "Dz") into their upper case form (such as "DZ"). +As a downside, 'capitalize' and 'upcase-initials' produce awkward +words where first character is upper rather than title case, e.g., +"DŽungla" instead of "Džungla". * Changes in Specialized Modes and Packages in Emacs 26.1 @@ -375,24 +376,24 @@ method is an NNTP select method. +++ *** A new command for sorting articles by readedness marks has been -added: `C-c C-s C-m C-m'. +added: 'C-c C-s C-m C-m'. ** Ibuffer --- -*** New filter commands `ibuffer-filter-by-basename', -`ibuffer-filter-by-file-extension', `ibuffer-filter-by-directory', -`ibuffer-filter-by-starred-name', `ibuffer-filter-by-modified' -and `ibuffer-filter-by-visiting-file'; bound respectively +*** New filter commands 'ibuffer-filter-by-basename', +'ibuffer-filter-by-file-extension', 'ibuffer-filter-by-directory', +'ibuffer-filter-by-starred-name', 'ibuffer-filter-by-modified' +and 'ibuffer-filter-by-visiting-file'; bound respectively to '/b', '/.', '//', '/*', '/i' and '/v'. --- *** Two new commands 'ibuffer-filter-chosen-by-completion' -and `ibuffer-and-filter', the second bound to '/&'. +and 'ibuffer-and-filter', the second bound to '/&'. --- -*** The commands `ibuffer-pop-filter', `ibuffer-pop-filter-group', -`ibuffer-or-filter' and `ibuffer-filter-disable' have the alternative +*** The commands 'ibuffer-pop-filter', 'ibuffer-pop-filter-group', +'ibuffer-or-filter' and 'ibuffer-filter-disable' have the alternative bindings '/', '/S-', '/|' and '/DEL', respectively. --- @@ -894,9 +895,9 @@ consistency with the new functions. For compatibility, 'sxhash' remains as an alias to 'sxhash-equal'. +++ -** New function `add-variable-watcher' can be used to call a function +** New function 'add-variable-watcher' can be used to call a function when a symbol's value is changed. This is used to implement the new -debugger command `debug-on-variable-change'. +debugger command 'debug-on-variable-change'. +++ ** Time conversion functions that accept a time zone rule argument now diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index f3cc3d5992..004f2e2865 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1421,7 +1421,7 @@ when (and (listp el) ;; make sure we're at the correct op (eq (nth 1 el) 'byte-constant) (eq (nth 2 el) orig-table)) - ;; jump tables are never resused, so we do this exactly + ;; Jump tables are never reused, so do this exactly ;; once. do (setf (nth 2 el) last-constant) and return nil)))) ;; lap = ( [ (pc . (op . arg)) ]* ) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index e96ba0b6ed..25513bd024 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -912,7 +912,7 @@ CONST2 may be evaluated multiple times." (dolist (bytes-tail patchlist) (setq pc (caar bytes-tail)) ; Pick PC from goto's tag. ;; Splits PC's value into 2 bytes. The jump address is - ;; "reconstructued" by the `FETCH2' macro in `bytecode.c'. + ;; "reconstructed" by the `FETCH2' macro in `bytecode.c'. (setcar (cdr bytes-tail) (logand pc 255)) (setcar bytes-tail (lsh pc -8)) ;; FIXME: Replace this by some workaround. @@ -4085,7 +4085,7 @@ Return a list of the form ((TEST . VAR) ((VALUE BODY) ...))" ;; varref var ;; constant #s(hash-table purecopy t data (val1 (TAG1) val2 (TAG2))) ;; switch - ;; goto DEFAUT-TAG + ;; goto DEFAULT-TAG ;; TAG1 ;; ;; goto DONETAG @@ -4103,7 +4103,7 @@ Return a list of the form ((TEST . VAR) ((VALUE BODY) ...))" ;; When the opcode argument is `byte-goto', `byte-compile-goto' sets ;; `byte-compile-depth' to `nil'. However, we need `byte-compile-depth' ;; to be non-nil for generating tags for all cases. Since - ;; `byte-compile-depth' will increase by atmost 1 after compiling + ;; `byte-compile-depth' will increase by at most 1 after compiling ;; all of the clause (which is further enforced by cl-assert below) ;; it should be safe to preserve it's value. (let ((byte-compile-depth byte-compile-depth)) diff --git a/lisp/international/characters.el b/lisp/international/characters.el index b2c0e39741..9e993e7060 100644 --- a/lisp/international/characters.el +++ b/lisp/international/characters.el @@ -675,10 +675,10 @@ with L, LRE, or LRO Unicode bidi character type.") (unicode-property-table-internal 'general-category)) ;; Ⅰ through Ⅻ had word syntax in the past so set it here as well. - ;; General category of those characers is Number, Letter. + ;; The general category of those characters is Number, Letter. (modify-syntax-entry '(#x2160 . #x216b) "w " syn-tab) - ;; ⓐ thourgh ⓩ are symbols, other according to Unicode but Emacs set + ;; ⓐ through ⓩ are symbols, other according to Unicode but Emacs set ;; their syntax to word in the past so keep backwards compatibility. (modify-syntax-entry '(#x24D0 . #x24E9) "w " syn-tab)) diff --git a/src/ChangeLog.11 b/src/ChangeLog.11 index c9ebce9926..365fc277a9 100644 --- a/src/ChangeLog.11 +++ b/src/ChangeLog.11 @@ -10673,7 +10673,7 @@ Try font from Ffont_get_system_font. Do not get font from x_default_parameter if we got one from Ffont_get_system_font. - (Fx_select_font): Get the defaut font name from :name of FRAME_FONT(f). + (Fx_select_font): Get the default font name from :name of FRAME_FONT(f). * w32font.c (w32font_driver): Initialize all members. diff --git a/src/lisp.h b/src/lisp.h index f1e2685702..080bcf74ce 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4615,7 +4615,7 @@ struct for_each_tail_internal This macro uses maybe_quit because of an excess of caution. The call to maybe_quit should not be needed in practice, as a very long list, whether circular or not, will cause Emacs to be so slow in - other noninterruptible areas (e.g., garbage collection) that there + other uninterruptible areas (e.g., garbage collection) that there is little point to calling maybe_quit here. */ #define FOR_EACH_TAIL_INTERNAL(tail, cycle, check_quit) \ commit 0b544b676473dedf34c6cb6a3315bec1f42d7162 Author: Paul Eggert Date: Thu Feb 16 07:55:28 2017 -0800 * src/buffer.h: Fix indenting. diff --git a/src/buffer.h b/src/buffer.h index f53212e312..a2bdc4e729 100644 --- a/src/buffer.h +++ b/src/buffer.h @@ -1375,7 +1375,8 @@ upcase (int c) } /* True if C is upper case. */ -INLINE bool uppercasep (int c) +INLINE bool +uppercasep (int c) { return downcase (c) != c; } commit 8929746489bb257d1e29c3bab629b3b67e3117d2 Author: Paul Eggert Date: Thu Feb 16 07:52:57 2017 -0800 Add sanity checks for Bswitch hash tables * src/bytecode.c (exec_byte_code) [BYTE_CODE_SAFE]: Check that operand is a hash table and hashes to ints. diff --git a/src/bytecode.c b/src/bytecode.c index af94d03b17..4414b077bb 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -1415,13 +1415,15 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Bswitch): { - /*TODO: Perhaps introduce another byte-code for switch when the - number of cases is less, which uses a simple vector for linear - search as the jump table. */ + /* TODO: Perhaps introduce another byte-code for switch when the + number of cases is less, which uses a simple vector for linear + search as the jump table. */ Lisp_Object jmp_table = POP; + if (BYTE_CODE_SAFE && !HASH_TABLE_P (jmp_table)) + emacs_abort (); Lisp_Object v1 = POP; ptrdiff_t i; - struct Lisp_Hash_Table *h = XHASH_TABLE(jmp_table); + struct Lisp_Hash_Table *h = XHASH_TABLE (jmp_table); /* h->count is a faster approximation for HASH_TABLE_SIZE (h) here. */ @@ -1429,9 +1431,9 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, { /* Do a linear search if there are not many cases FIXME: 5 is arbitrarily chosen. */ Lisp_Object hash_code = h->test.cmpfn - ? make_number(h->test.hashfn (&h->test, v1)) : Qnil; + ? make_number (h->test.hashfn (&h->test, v1)) : Qnil; - for (i = h->count; 0 <= --i;) + for (i = h->count; 0 <= --i; ) if (EQ (v1, HASH_KEY (h, i)) || (h->test.cmpfn && EQ (hash_code, HASH_HASH (h, i)) @@ -1440,13 +1442,16 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, } else - i = hash_lookup(h, v1, NULL); + i = hash_lookup (h, v1, NULL); - if (i >= 0) - { - op = XINT (HASH_VALUE (h, i)); - goto op_branch; - } + if (i >= 0) + { + Lisp_Object val = HASH_VALUE (h, i); + if (BYTE_CODE_SAFE && !INTEGERP (val)) + emacs_abort (); + op = XINT (val); + goto op_branch; + } } NEXT; commit 064541af6a71bf45d530fe34b7e00c8123ee93d8 Author: Paul Eggert Date: Thu Feb 16 07:49:03 2017 -0800 * src/keyboard.c (read_key_sequence): Fix integer-overflow glitch. diff --git a/src/keyboard.c b/src/keyboard.c index 0fad633581..d2f4b504ab 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -5421,26 +5421,26 @@ make_lispy_event (struct input_event *event) not. And Control+Shift+s should produce C-S-s whether caps-lock is on or not. */ if (event->modifiers & ~shift_modifier) - { + { /* This is a key chord: some non-shift modifier is depressed. */ if (uppercasep (c) && !(event->modifiers & shift_modifier)) - { + { /* Got a capital letter without a shift. The caps lock is on. Un-capitalize the letter. */ c = downcase (c); - } + } else if (lowercasep (c) && (event->modifiers & shift_modifier)) - { + { /* Got a lower-case letter even though shift is depressed. The caps lock is on. Capitalize the letter. */ c = upcase (c); - } - } + } + } if (event->kind == ASCII_KEYSTROKE_EVENT) { @@ -9645,13 +9645,13 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, && INTEGERP (key)) { Lisp_Object new_key; - int k = XINT (key); + EMACS_INT k = XINT (key); if (k & shift_modifier) XSETINT (new_key, k & ~shift_modifier); else if (CHARACTERP (make_number (k & ~CHAR_MODIFIER_MASK))) { - int dc = downcase(k & ~CHAR_MODIFIER_MASK); + int dc = downcase (k & ~CHAR_MODIFIER_MASK); if (dc == (k & ~CHAR_MODIFIER_MASK)) goto not_upcase; XSETINT (new_key, dc | (k & CHAR_MODIFIER_MASK)); commit 501ad546263ed2a902be1c9d8c1bb3af5794066b Author: Vibhav Pant Date: Thu Feb 16 20:18:55 2017 +0530 bytecomp.el: Avoid unnecessary calculation for jump table addresses. * lisp/emacs-lisp/bytecomp.el (byte-compile-lapcode): Don't do redundant operations while calculating the correct jump addresses from TAGs in jump tables. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 75e6b904aa..e96ba0b6ed 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -911,16 +911,21 @@ CONST2 may be evaluated multiple times." ;; Patch tag PCs into absolute jumps. (dolist (bytes-tail patchlist) (setq pc (caar bytes-tail)) ; Pick PC from goto's tag. + ;; Splits PC's value into 2 bytes. The jump address is + ;; "reconstructued" by the `FETCH2' macro in `bytecode.c'. (setcar (cdr bytes-tail) (logand pc 255)) (setcar bytes-tail (lsh pc -8)) ;; FIXME: Replace this by some workaround. (if (> (car bytes-tail) 255) (error "Bytecode overflow"))) + ;; Similarly, replace TAGs in all jump tables with the correct PC index. (dolist (hash-table byte-compile-jump-tables) (maphash #'(lambda (value tag) (setq pc (cadr tag)) - (puthash value (+ (logand pc 255) (lsh (lsh pc -8) 8)) - hash-table)) + ;; We don't need to split PC here, as it is stored as a lisp + ;; object in the hash table (whereas other goto-* ops store + ;; it within 2 bytes in the byte string). + (puthash value pc hash-table)) hash-table)) (apply 'unibyte-string (nreverse bytes)))) commit 236648fe2623a10c8ca02637b79cd0ceffd0b6b9 Author: Mark Oteiza Date: Wed Feb 15 20:43:55 2017 -0500 Minor changes in json.el * lisp/json.el (json-advance): Simpler docstring. (json-read-escaped-char): Use xdigit subform in rx expression. (json-read-string): Just use = for char comparison. diff --git a/lisp/json.el b/lisp/json.el index b2ac356641..59942dbed8 100644 --- a/lisp/json.el +++ b/lisp/json.el @@ -188,7 +188,7 @@ Unlike `reverse', this keeps the property-value pairs intact." ;; Reader utilities (defsubst json-advance (&optional n) - "Skip past the following N characters." + "Advance N characters forward." (forward-char n)) (defsubst json-peek () @@ -381,13 +381,13 @@ representation will be parsed correctly." ;; this clause overlaps with the next one and therefore has to ;; come first. ((looking-at - (rx (group (any "Dd") (any "89ABab") (= 2 (any "0-9A-Fa-f"))) - "\\u" (group (any "Dd") (any "C-Fc-f") (= 2 (any "0-9A-Fa-f"))))) + (rx (group (any "Dd") (any "89ABab") (= 2 (any xdigit))) + "\\u" (group (any "Dd") (any "C-Fc-f") (= 2 (any xdigit))))) (json-advance 10) (json--decode-utf-16-surrogates (string-to-number (match-string 1) 16) (string-to-number (match-string 2) 16))) - ((looking-at "[0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f]") + ((looking-at (rx (= 4 xdigit))) (let ((hex (match-string 0))) (json-advance 4) (string-to-number hex 16))) @@ -396,14 +396,14 @@ representation will be parsed correctly." (defun json-read-string () "Read the JSON string at point." - (unless (char-equal (json-peek) ?\") + (unless (= (json-peek) ?\") (signal 'json-string-format (list "doesn't start with `\"'!"))) ;; Skip over the '"' (json-advance) (let ((characters '()) (char (json-peek))) - (while (not (char-equal char ?\")) - (push (if (char-equal char ?\\) + (while (not (= char ?\")) + (push (if (= char ?\\) (json-read-escaped-char) (json-pop)) characters) commit 1b4442bee921d6698fc8ecac1c95c39f7ca2efe4 Author: Mark Oteiza Date: Wed Feb 15 20:40:46 2017 -0500 Don't expand body inside a let-binding when there are no bindings * lisp/emacs-lisp/pcase.el (pcase-codegen): Only let-bind if VARS is non-nil. diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 46a5eedd15..289265abf2 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -437,8 +437,10 @@ to this macro." ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy ;; codegen from later metamorphosing this let into a funcall. - `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars) - ,@code)) + (if vars + `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars) + ,@code) + `(progn ,@code))) (defun pcase--small-branch-p (code) (and (= 1 (length code)) commit 8ed8ef307d9a28f6c3336a448c7fbdfe8a733d83 Author: Glenn Morris Date: Wed Feb 15 20:23:07 2017 -0500 Handle user-mail-address being the empty string * lisp/mail/feedmail.el (feedmail-fiddle-from): * lisp/mail/rmail.el (rmail-unknown-mail-followup-to): * lisp/mail/rmailsum.el (rmail-header-summary): Belated update for 2002-09-29 startup.el change, 680ebfa, where the value of user-mail-address during initialization was changed from nil to the empty string. diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el index 1402db4095..53791565bb 100644 --- a/lisp/mail/feedmail.el +++ b/lisp/mail/feedmail.el @@ -2768,7 +2768,8 @@ return that value." ((eq t feedmail-from-line) (let ((feedmail-from-line (let ((at-stuff - (if user-mail-address user-mail-address + (if (> (length user-mail-address) 0) + user-mail-address (concat (user-login-name) "@" (or mail-host-address (system-name)))))) (cond diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index aeaba5862f..695638fa06 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -2666,10 +2666,11 @@ Ask the user whether to add that list name to `mail-mailing-lists'." (regexp-quote (user-login-name)) "\\($\\|@\\)\\|" (regexp-quote - (or user-mail-address - (concat (user-login-name) "@" - (or mail-host-address - (system-name))))) + (if (> (length user-mail-address) 0) + user-mail-address + (concat (user-login-name) "@" + (or mail-host-address + (system-name))))) "\\>\\)")) addr)) (y-or-n-p diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el index 7c7c9f48e7..729538173a 100644 --- a/lisp/mail/rmailsum.el +++ b/lisp/mail/rmailsum.el @@ -757,10 +757,11 @@ the message being processed." ;; Don't lose if run from init file ;; where user-mail-address is not ;; set yet. - (or user-mail-address - (concat (user-login-name) "@" - (or mail-host-address - (system-name))))) + (if (> (length user-mail-address) 0) + user-mail-address + (concat (user-login-name) "@" + (or mail-host-address + (system-name))))) "\\>\\)")) from)) ;; No From field, or it's this user. commit adfb6f1dc26a927cf4bab24bdfae54b51e3ae0ec Author: Michael Albinus Date: Wed Feb 15 19:42:34 2017 +0100 Continue to fix bug#25607 * lisp/ido.el (ido-complete): Let-bind `non-essential' to nil. (ido-file-name-all-completions-1): Do not bind `non-essential'. * lisp/net/tramp.el: (tramp-completion-file-name-handler): Improve autoloaded version. (tramp-completion-file-name-handler): Remove old compat code. Check only for `tramp-completion-mode-p'. (tramp-completion-mode-p): Autoload. Do not check any longer for `last-input-event'. (tramp-completion-handle-expand-file-name): Simplify. (Bug#25607) diff --git a/lisp/ido.el b/lisp/ido.el index e18464d1d6..561d6e7f08 100644 --- a/lisp/ido.el +++ b/lisp/ido.el @@ -2541,7 +2541,7 @@ If cursor is not at the end of the user input, move to end of input." (defun ido-complete () "Try and complete the current pattern amongst the file names." (interactive) - (let (res) + (let (non-essential res) (cond (ido-incomplete-regexp ;; Do nothing @@ -3556,7 +3556,6 @@ it is put to the start of the list." ;; Strip method:user@host: part of tramp completions. ;; Tramp completions do not include leading slash. (let* ((len (1- (length dir))) - (non-essential t) (compl (or ;; We do not want to be disturbed by "File does not ;; exist" errors. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 4b5bd47263..c0f6fdcfad 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2137,7 +2137,7 @@ preventing reentrant calls of Tramp.") ;; non-nil, we must load tramp.el, in order to get the real definition ;; of `tramp-completion-file-name-handler'. ;;;###autoload(defun tramp-completion-file-name-handler (operation &rest args) -;;;###autoload (if (and (boundp 'non-essential) (symbol-value 'non-essential)) +;;;###autoload (if (tramp-completion-mode-p) ;;;###autoload (apply 'tramp-autoload-file-name-handler operation args) ;;;###autoload (tramp-completion-run-real-handler operation args))) @@ -2145,23 +2145,7 @@ preventing reentrant calls of Tramp.") "Invoke Tramp file name completion handler. Falls back to normal file name handler if no Tramp file name handler exists." (let ((fn (assoc operation tramp-completion-file-name-handler-alist))) - (if (and - ;; When `tramp-mode' is not enabled, we don't do anything. - fn tramp-mode (tramp-completion-mode-p) - ;; For other syntaxes than `sep', the regexp matches many common - ;; situations where the user doesn't actually want to use Tramp. - ;; So to avoid autoloading Tramp after typing just "/s", we - ;; disable this part of the completion, unless the user implicitly - ;; indicated his interest in using a fancier completion system. - (or (eq tramp-syntax 'sep) - (featurep 'tramp) ;; If it's loaded, we may as well use it. - ;; `partial-completion-mode' is obsoleted with Emacs 24.1. - (and (boundp 'partial-completion-mode) - (symbol-value 'partial-completion-mode)) - ;; FIXME: These may have been loaded even if the user never - ;; intended to use them. - (featurep 'ido) - (featurep 'icicles))) + (if (and fn tramp-mode (tramp-completion-mode-p)) (save-match-data (apply (cdr fn) args)) (tramp-completion-run-real-handler operation args)))) @@ -2281,20 +2265,13 @@ should never be set globally, the intention is to let-bind it.") ;; Tramp file name syntax. Maybe another variable should be introduced ;; overwriting this check in such cases. Or we change Tramp file name ;; syntax in order to avoid ambiguities. -(defun tramp-completion-mode-p () +;;;###autoload +(progn (defun tramp-completion-mode-p () "Check, whether method / user name / host name completion is active." (or ;; Signal from outside. `non-essential' has been introduced in Emacs 24. (and (boundp 'non-essential) (symbol-value 'non-essential)) - tramp-completion-mode - (equal last-input-event 'tab) - (and (natnump last-input-event) - (or - ;; ?\t has event-modifier 'control. - (equal last-input-event ?\t) - (and (not (event-modifiers last-input-event)) - (or (equal last-input-event ?\?) - (equal last-input-event ?\ ))))))) + tramp-completion-mode))) (defun tramp-connectable-p (filename) "Check, whether it is possible to connect the remote host w/o side-effects. @@ -2309,17 +2286,12 @@ not in completion mode." (defun tramp-completion-handle-expand-file-name (name &optional dir) "Like `expand-file-name' for Tramp files." - (if (tramp-completion-mode-p) - (progn - ;; If DIR is not given, use `default-directory' or "/". - (setq dir (or dir default-directory "/")) - (cond - ((file-name-absolute-p name) name) - ((zerop (length name)) dir) - (t (concat (file-name-as-directory dir) name)))) - - (tramp-completion-run-real-handler - 'expand-file-name (list name dir)))) + ;; If DIR is not given, use `default-directory' or "/". + (setq dir (or dir default-directory "/")) + (cond + ((file-name-absolute-p name) name) + ((zerop (length name)) dir) + (t (concat (file-name-as-directory dir) name)))) ;; Method, host name and user name completion. ;; `tramp-completion-dissect-file-name' returns a list of @@ -2406,11 +2378,11 @@ not in completion mode." (tramp-connectable-p (expand-file-name filename directory))) (lambda (x) (funcall predicate (expand-file-name (car x) directory)))))) -;; I misuse a little bit the tramp-file-name structure in order to handle -;; completion possibilities for partial methods / user names / host names. -;; Return value is a list of tramp-file-name structures according to possible -;; completions. If "localname" is non-nil it means there -;; shouldn't be a completion anymore. +;; I misuse a little bit the tramp-file-name structure in order to +;; handle completion possibilities for partial methods / user names / +;; host names. Return value is a list of tramp-file-name structures +;; according to possible completions. If "localname" is non-nil it +;; means there shouldn't be a completion anymore. ;; Expected results: commit 6220faeb4e9be16b9dec728e72ea8dff2cfe35ba Author: Michal Nazarewicz Date: Wed Sep 7 21:00:57 2016 +0200 casing: don’t assume letters are *either* upper- or lower-case (bug#24603) A compatibility digraph characters, such as Dž, are neither upper- nor lower-case. At the moment however, those are reported as upper-case¹ despite the fact that they change when upper-cased. Stop checking if a character is upper-case before trying to up-case it so that title-case characters are handled correctly. This fixes one of the issues mentioned in bug#24603. ¹ Because they change when converted to lower-case. Notice an asymmetry in that for a character to be considered lower-case it must not be upper-case (plus the usual condition of changing when upper-cased). * src/buffer.h (upcase1): Delete. (upcase): Change to upcase character unconditionally just like downcase does it. This is what upcase1 was. * src/casefiddle.c (casify_object, casify_region): Use upcase instead of upcase1 and don’t check !uppercasep(x) before calling upcase. * src/keyboard.c (read_key_sequence): Don’t check if uppercase(x), just downcase(x) and see if it changed. * test/src/casefiddle-tests.el (casefiddle-tests--characters, casefiddle-tests-casing): Update test cases which are now passing. diff --git a/etc/NEWS b/etc/NEWS index 421e5daa3e..a54c655c36 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -338,6 +338,12 @@ same as in modes where the character is not whitespace. Instead of only checking the modification time, Emacs now also checks the file's actual content before prompting the user. +** Title case characters are properly converted to upper case. +'upcase', 'upcase-region' et al. convert title case characters (such +as Dz) into their upper case form (such as DZ). As a downside, +'capitalize' and 'upcase-initials' produce awkward words where first +two letters are upper case, e.g. DŽungla (instead of Džungla). + * Changes in Specialized Modes and Packages in Emacs 26.1 @@ -1028,7 +1034,7 @@ along with GNU Emacs. If not, see . Local variables: -coding: us-ascii +coding: utf-8 mode: outline paragraph-separate: "[ ]*$" end: diff --git a/src/buffer.h b/src/buffer.h index 4a23e4fdd2..f53212e312 100644 --- a/src/buffer.h +++ b/src/buffer.h @@ -1365,28 +1365,28 @@ downcase (int c) return NATNUMP (down) ? XFASTINT (down) : c; } -/* True if C is upper case. */ -INLINE bool uppercasep (int c) { return downcase (c) != c; } - -/* Upcase a character C known to be not upper case. */ +/* Upcase a character C, or make no change if that cannot be done. */ INLINE int -upcase1 (int c) +upcase (int c) { Lisp_Object upcase_table = BVAR (current_buffer, upcase_table); Lisp_Object up = CHAR_TABLE_REF (upcase_table, c); return NATNUMP (up) ? XFASTINT (up) : c; } +/* True if C is upper case. */ +INLINE bool uppercasep (int c) +{ + return downcase (c) != c; +} + /* True if C is lower case. */ INLINE bool lowercasep (int c) { - return !uppercasep (c) && upcase1 (c) != c; + return !uppercasep (c) && upcase (c) != c; } -/* Upcase a character C, or make no change if that cannot be done. */ -INLINE int upcase (int c) { return uppercasep (c) ? c : upcase1 (c); } - INLINE_HEADER_END #endif /* EMACS_BUFFER_H */ diff --git a/src/casefiddle.c b/src/casefiddle.c index 28ffcb298f..b2b87e7a85 100644 --- a/src/casefiddle.c +++ b/src/casefiddle.c @@ -64,13 +64,9 @@ casify_object (enum case_action flag, Lisp_Object obj) multibyte = 1; if (! multibyte) MAKE_CHAR_MULTIBYTE (c1); - c = downcase (c1); - if (inword) - XSETFASTINT (obj, c | flags); - else if (c == (XFASTINT (obj) & ~flagbits)) + c = flag == CASE_DOWN ? downcase (c1) : upcase (c1); + if (c != c1) { - if (! inword) - c = upcase1 (c1); if (! multibyte) MAKE_CHAR_UNIBYTE (c); XSETFASTINT (obj, c | flags); @@ -95,7 +91,7 @@ casify_object (enum case_action flag, Lisp_Object obj) c = downcase (c); else if (!uppercasep (c) && (!inword || flag != CASE_CAPITALIZE_UP)) - c = upcase1 (c1); + c = upcase (c1); if ((int) flag >= (int) CASE_CAPITALIZE) inword = (SYNTAX (c) == Sword); if (c != c1) @@ -127,9 +123,8 @@ casify_object (enum case_action flag, Lisp_Object obj) c = STRING_CHAR_AND_LENGTH (SDATA (obj) + i_byte, len); if (inword && flag != CASE_CAPITALIZE_UP) c = downcase (c); - else if (!uppercasep (c) - && (!inword || flag != CASE_CAPITALIZE_UP)) - c = upcase1 (c); + else if (!inword || flag != CASE_CAPITALIZE_UP) + c = upcase (c); if ((int) flag >= (int) CASE_CAPITALIZE) inword = (SYNTAX (c) == Sword); o += CHAR_STRING (c, o); @@ -236,9 +231,8 @@ casify_region (enum case_action flag, Lisp_Object b, Lisp_Object e) c2 = c; if (inword && flag != CASE_CAPITALIZE_UP) c = downcase (c); - else if (!uppercasep (c) - && (!inword || flag != CASE_CAPITALIZE_UP)) - c = upcase1 (c); + else if (!inword || flag != CASE_CAPITALIZE_UP) + c = upcase (c); if ((int) flag >= (int) CASE_CAPITALIZE) inword = ((SYNTAX (c) == Sword) && (inword || !syntax_prefix_flag_p (c))); diff --git a/src/keyboard.c b/src/keyboard.c index ed8e71fd0a..0fad633581 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -9642,22 +9642,26 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, use the corresponding lower-case letter instead. */ if (NILP (current_binding) && /* indec.start >= t && fkey.start >= t && */ keytran.start >= t - && INTEGERP (key) - && ((CHARACTERP (make_number (XINT (key) & ~CHAR_MODIFIER_MASK)) - && uppercasep (XINT (key) & ~CHAR_MODIFIER_MASK)) - || (XINT (key) & shift_modifier))) + && INTEGERP (key)) { Lisp_Object new_key; + int k = XINT (key); + + if (k & shift_modifier) + XSETINT (new_key, k & ~shift_modifier); + else if (CHARACTERP (make_number (k & ~CHAR_MODIFIER_MASK))) + { + int dc = downcase(k & ~CHAR_MODIFIER_MASK); + if (dc == (k & ~CHAR_MODIFIER_MASK)) + goto not_upcase; + XSETINT (new_key, dc | (k & CHAR_MODIFIER_MASK)); + } + else + goto not_upcase; original_uppercase = key; original_uppercase_position = t - 1; - if (XINT (key) & shift_modifier) - XSETINT (new_key, XINT (key) & ~shift_modifier); - else - XSETINT (new_key, (downcase (XINT (key) & ~CHAR_MODIFIER_MASK) - | (XINT (key) & CHAR_MODIFIER_MASK))); - /* We have to do this unconditionally, regardless of whether the lower-case char is defined in the keymaps, because they might get translated through function-key-map. */ @@ -9668,6 +9672,7 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, goto replay_sequence; } + not_upcase: if (NILP (current_binding) && help_char_p (EVENT_HEAD (key)) && t > 1) { diff --git a/test/src/casefiddle-tests.el b/test/src/casefiddle-tests.el index c752bb0917..152d85de00 100644 --- a/test/src/casefiddle-tests.el +++ b/test/src/casefiddle-tests.el @@ -63,13 +63,13 @@ (?Ł ?Ł ?ł ?Ł) (?ł ?Ł ?ł ?Ł) - ;; FIXME(bug#24603): We should have: + ;; FIXME(bug#24603): Commented ones are what we want. ;;(?DŽ ?DŽ ?dž ?Dž) - ;; but instead we have: (?DŽ ?DŽ ?dž ?DŽ) - ;; FIXME(bug#24603): Those two are broken at the moment: ;;(?Dž ?DŽ ?dž ?Dž) + (?Dž ?DŽ ?dž ?DŽ) ;;(?dž ?DŽ ?dž ?Dž) + (?dž ?DŽ ?dž ?DŽ) (?Σ ?Σ ?σ ?Σ) (?σ ?Σ ?σ ?Σ) @@ -197,7 +197,7 @@ ;;("ΌΣΟΣ" "ΌΣΟΣ" "όσος" "Όσος" "Όσος") ;; And here’s what is actually happening: ("DŽUNGLA" "DŽUNGLA" "džungla" "DŽungla" "DŽUNGLA") - ("Džungla" "DžUNGLA" "džungla" "Džungla" "Džungla") + ("Džungla" "DŽUNGLA" "džungla" "DŽungla" "DŽungla") ("džungla" "DŽUNGLA" "džungla" "DŽungla" "DŽungla") ("define" "DEfiNE" "define" "Define" "Define") ("fish" "fiSH" "fish" "fish" "fish") commit 5ec3a58462e99533ea5200de356302181d634d0b Author: Michal Nazarewicz Date: Mon Sep 19 00:23:40 2016 +0200 Generate upcase and downcase tables from Unicode data (bug#24603) Use Unicode data to generate case tables instead of mostly repeating them in lisp code. Do that in a way which maps ‘Dz’ (and similar) digraph to ‘dz’ when down- and ‘DZ’ when upcasing. https://debbugs.gnu.org/cgi/bugreport.cgi?msg=89;bug=24603 lists all changes to syntax table and case tables introduced by this commit. * lisp/international/characters.el: Remove case-pairs defined with explicit Lisp code and instead use Unicode character properties. * test/src/casefiddle-tests.el (casefiddle-tests--characters, casefiddle-tests-casing): Update test cases which are now working as they should. diff --git a/lisp/international/characters.el b/lisp/international/characters.el index 2b9711aec6..b2c0e39741 100644 --- a/lisp/international/characters.el +++ b/lisp/international/characters.el @@ -543,10 +543,6 @@ with L, LRE, or LRO Unicode bidi character type.") (set-case-syntax ?½ "_" tbl) (set-case-syntax ?¾ "_" tbl) (set-case-syntax ?¿ "." tbl) - (let ((c 192)) - (while (<= c 222) - (set-case-syntax-pair c (+ c 32) tbl) - (setq c (1+ c)))) (set-case-syntax ?× "_" tbl) (set-case-syntax ?ß "w" tbl) (set-case-syntax ?÷ "_" tbl) @@ -558,101 +554,8 @@ with L, LRE, or LRO Unicode bidi character type.") (modify-category-entry c ?l) (setq c (1+ c))) - (let ((pair-ranges '((#x0100 . #x012F) - (#x0132 . #x0137) - (#x0139 . #x0148) - (#x014a . #x0177) - (#x0179 . #x017E) - (#x0182 . #x0185) - (#x0187 . #x0188) - (#x018B . #x018C) - (#x0191 . #x0192) - (#x0198 . #x0199) - (#x01A0 . #x01A5) - (#x01A7 . #x01A8) - (#x01AC . #x01AD) - (#x01AF . #x01B0) - (#x01B3 . #x01B6) - (#x01B8 . #x01B9) - (#x01BC . #x01BD) - (#x01CD . #x01DC) - (#x01DE . #x01EF) - (#x01F4 . #x01F5) - (#x01F8 . #x021F) - (#x0222 . #x0233) - (#x023B . #x023C) - (#x0241 . #x0242) - (#x0246 . #x024F)))) - (dolist (elt pair-ranges) - (let ((from (car elt)) (to (cdr elt))) - (while (< from to) - (set-case-syntax-pair from (1+ from) tbl) - (setq from (+ from 2)))))) - - (set-case-syntax-pair ?Ÿ ?ÿ tbl) - - ;; In some languages, such as Turkish, U+0049 LATIN CAPITAL LETTER I - ;; and U+0131 LATIN SMALL LETTER DOTLESS I make a case pair, and so - ;; do U+0130 LATIN CAPITAL LETTER I WITH DOT ABOVE and U+0069 LATIN - ;; SMALL LETTER I. - - ;; We used to set up half of those correspondence unconditionally, - ;; but that makes searches slow. So now we don't set up either half - ;; of these correspondences by default. - - ;; (set-downcase-syntax ?İ ?i tbl) - ;; (set-upcase-syntax ?I ?ı tbl) - - (set-case-syntax-pair ?Ɓ ?ɓ tbl) - (set-case-syntax-pair ?Ɔ ?ɔ tbl) - (set-case-syntax-pair ?Ɖ ?ɖ tbl) - (set-case-syntax-pair ?Ɗ ?ɗ tbl) - (set-case-syntax-pair ?Ǝ ?ǝ tbl) - (set-case-syntax-pair ?Ə ?ə tbl) - (set-case-syntax-pair ?Ɛ ?ɛ tbl) - (set-case-syntax-pair ?Ɠ ?ɠ tbl) - (set-case-syntax-pair ?Ɣ ?ɣ tbl) - (set-case-syntax-pair ?Ɩ ?ɩ tbl) - (set-case-syntax-pair ?Ɨ ?ɨ tbl) - (set-case-syntax-pair ?Ɯ ?ɯ tbl) - (set-case-syntax-pair ?Ɲ ?ɲ tbl) - (set-case-syntax-pair ?Ɵ ?ɵ tbl) - (set-case-syntax-pair ?Ʀ ?ʀ tbl) - (set-case-syntax-pair ?Ʃ ?ʃ tbl) - (set-case-syntax-pair ?Ʈ ?ʈ tbl) - (set-case-syntax-pair ?Ʊ ?ʊ tbl) - (set-case-syntax-pair ?Ʋ ?ʋ tbl) - (set-case-syntax-pair ?Ʒ ?ʒ tbl) - ;; We use set-downcase-syntax below, since we want upcase of dž - ;; return DŽ, not Dž, and the same for the rest. - (set-case-syntax-pair ?DŽ ?dž tbl) - (set-downcase-syntax ?Dž ?dž tbl) - (set-case-syntax-pair ?LJ ?lj tbl) - (set-downcase-syntax ?Lj ?lj tbl) - (set-case-syntax-pair ?NJ ?nj tbl) - (set-downcase-syntax ?Nj ?nj tbl) - - ;; 01F0; F; 006A 030C; # LATIN SMALL LETTER J WITH CARON - - (set-case-syntax-pair ?DZ ?dz tbl) - (set-downcase-syntax ?Dz ?dz tbl) - (set-case-syntax-pair ?Ƕ ?ƕ tbl) - (set-case-syntax-pair ?Ƿ ?ƿ tbl) - (set-case-syntax-pair ?Ⱥ ?ⱥ tbl) - (set-case-syntax-pair ?Ƚ ?ƚ tbl) - (set-case-syntax-pair ?Ⱦ ?ⱦ tbl) - (set-case-syntax-pair ?Ƀ ?ƀ tbl) - (set-case-syntax-pair ?Ʉ ?ʉ tbl) - (set-case-syntax-pair ?Ʌ ?ʌ tbl) - ;; Latin Extended Additional (modify-category-entry '(#x1e00 . #x1ef9) ?l) - (setq c #x1e00) - (while (<= c #x1ef9) - (and (zerop (% c 2)) - (or (<= c #x1e94) (>= c #x1ea0)) - (set-case-syntax-pair c (1+ c) tbl)) - (setq c (1+ c))) ;; Latin Extended-C (setq c #x2C60) @@ -660,57 +563,12 @@ with L, LRE, or LRO Unicode bidi character type.") (modify-category-entry c ?l) (setq c (1+ c))) - (let ((pair-ranges '((#x2C60 . #x2C61) - (#x2C67 . #x2C6C) - (#x2C72 . #x2C73) - (#x2C75 . #x2C76)))) - (dolist (elt pair-ranges) - (let ((from (car elt)) (to (cdr elt))) - (while (< from to) - (set-case-syntax-pair from (1+ from) tbl) - (setq from (+ from 2)))))) - - (set-case-syntax-pair ?Ɫ ?ɫ tbl) - (set-case-syntax-pair ?Ᵽ ?ᵽ tbl) - (set-case-syntax-pair ?Ɽ ?ɽ tbl) - (set-case-syntax-pair ?Ɑ ?ɑ tbl) - (set-case-syntax-pair ?Ɱ ?ɱ tbl) - (set-case-syntax-pair ?Ɐ ?ɐ tbl) - (set-case-syntax-pair ?Ɒ ?ɒ tbl) - (set-case-syntax-pair ?Ȿ ?ȿ tbl) - (set-case-syntax-pair ?Ɀ ?ɀ tbl) - ;; Latin Extended-D (setq c #xA720) (while (<= c #xA7FF) (modify-category-entry c ?l) (setq c (1+ c))) - (let ((pair-ranges '((#xA722 . #xA72F) - (#xA732 . #xA76F) - (#xA779 . #xA77C) - (#xA77E . #xA787) - (#xA78B . #xA78E) - (#xA790 . #xA793) - (#xA796 . #xA7A9) - (#xA7B4 . #xA7B7)))) - (dolist (elt pair-ranges) - (let ((from (car elt)) (to (cdr elt))) - (while (< from to) - (set-case-syntax-pair from (1+ from) tbl) - (setq from (+ from 2)))))) - - (set-case-syntax-pair ?Ᵹ ?ᵹ tbl) - (set-case-syntax-pair ?Ɦ ?ɦ tbl) - (set-case-syntax-pair ?Ɜ ?ɜ tbl) - (set-case-syntax-pair ?Ɡ ?ɡ tbl) - (set-case-syntax-pair ?Ɬ ?ɬ tbl) - (set-case-syntax-pair ?Ɪ ?ɪ tbl) - (set-case-syntax-pair ?Ʞ ?ʞ tbl) - (set-case-syntax-pair ?Ʇ ?ʇ tbl) - (set-case-syntax-pair ?Ʝ ?ʝ tbl) - (set-case-syntax-pair ?Ꭓ ?ꭓ tbl) - ;; Latin Extended-E (setq c #xAB30) (while (<= c #xAB64) @@ -719,102 +577,19 @@ with L, LRE, or LRO Unicode bidi character type.") ;; Greek (modify-category-entry '(#x0370 . #x03ff) ?g) - (setq c #x0370) - (while (<= c #x03ff) - (if (or (and (>= c #x0391) (<= c #x03a1)) - (and (>= c #x03a3) (<= c #x03ab))) - (set-case-syntax-pair c (+ c 32) tbl)) - (and (>= c #x03da) - (<= c #x03ee) - (zerop (% c 2)) - (set-case-syntax-pair c (1+ c) tbl)) - (setq c (1+ c))) - (set-case-syntax-pair ?Ά ?ά tbl) - (set-case-syntax-pair ?Έ ?έ tbl) - (set-case-syntax-pair ?Ή ?ή tbl) - (set-case-syntax-pair ?Ί ?ί tbl) - (set-case-syntax-pair ?Ό ?ό tbl) - (set-case-syntax-pair ?Ύ ?ύ tbl) - (set-case-syntax-pair ?Ώ ?ώ tbl) ;; Armenian (setq c #x531) - (while (<= c #x556) - (set-case-syntax-pair c (+ c #x30) tbl) - (setq c (1+ c))) ;; Greek Extended (modify-category-entry '(#x1f00 . #x1fff) ?g) - (setq c #x1f00) - (while (<= c #x1fff) - (and (<= (logand c #x000f) 7) - (<= c #x1fa7) - (not (memq c '(#x1f16 #x1f17 #x1f56 #x1f57 - #x1f50 #x1f52 #x1f54 #x1f56))) - (/= (logand c #x00f0) #x70) - (set-case-syntax-pair (+ c 8) c tbl)) - (setq c (1+ c))) - (set-case-syntax-pair ?Ᾰ ?ᾰ tbl) - (set-case-syntax-pair ?Ᾱ ?ᾱ tbl) - (set-case-syntax-pair ?Ὰ ?ὰ tbl) - (set-case-syntax-pair ?Ά ?ά tbl) - (set-case-syntax-pair ?ᾼ ?ᾳ tbl) - (set-case-syntax-pair ?Ὲ ?ὲ tbl) - (set-case-syntax-pair ?Έ ?έ tbl) - (set-case-syntax-pair ?Ὴ ?ὴ tbl) - (set-case-syntax-pair ?Ή ?ή tbl) - (set-case-syntax-pair ?ῌ ?ῃ tbl) - (set-case-syntax-pair ?Ῐ ?ῐ tbl) - (set-case-syntax-pair ?Ῑ ?ῑ tbl) - (set-case-syntax-pair ?Ὶ ?ὶ tbl) - (set-case-syntax-pair ?Ί ?ί tbl) - (set-case-syntax-pair ?Ῠ ?ῠ tbl) - (set-case-syntax-pair ?Ῡ ?ῡ tbl) - (set-case-syntax-pair ?Ὺ ?ὺ tbl) - (set-case-syntax-pair ?Ύ ?ύ tbl) - (set-case-syntax-pair ?Ῥ ?ῥ tbl) - (set-case-syntax-pair ?Ὸ ?ὸ tbl) - (set-case-syntax-pair ?Ό ?ό tbl) - (set-case-syntax-pair ?Ὼ ?ὼ tbl) - (set-case-syntax-pair ?Ώ ?ώ tbl) - (set-case-syntax-pair ?ῼ ?ῳ tbl) ;; cyrillic (modify-category-entry '(#x0400 . #x04FF) ?y) - (setq c #x0400) - (while (<= c #x04ff) - (and (>= c #x0400) - (<= c #x040f) - (set-case-syntax-pair c (+ c 80) tbl)) - (and (>= c #x0410) - (<= c #x042f) - (set-case-syntax-pair c (+ c 32) tbl)) - (and (zerop (% c 2)) - (or (and (>= c #x0460) (<= c #x0480)) - (and (>= c #x048c) (<= c #x04be)) - (and (>= c #x04d0) (<= c #x052e))) - (set-case-syntax-pair c (1+ c) tbl)) - (setq c (1+ c))) - (set-case-syntax-pair ?Ӂ ?ӂ tbl) - (set-case-syntax-pair ?Ӄ ?ӄ tbl) - (set-case-syntax-pair ?Ӈ ?ӈ tbl) - (set-case-syntax-pair ?Ӌ ?ӌ tbl) - (modify-category-entry '(#xA640 . #xA69F) ?y) - (setq c #xA640) - (while (<= c #xA66C) - (set-case-syntax-pair c (+ c 1) tbl) - (setq c (+ c 2))) - (setq c #xA680) - (while (<= c #xA69A) - (set-case-syntax-pair c (+ c 1) tbl) - (setq c (+ c 2))) ;; Georgian (setq c #x10A0) - (while (<= c #x10CD) - (set-case-syntax-pair c (+ c #x1C60) tbl) - (setq c (1+ c))) ;; Cyrillic Extended-C (modify-category-entry '(#x1C80 . #x1C8F) ?y) @@ -844,12 +619,6 @@ with L, LRE, or LRO Unicode bidi character type.") (set-case-syntax c "." tbl) (setq c (1+ c))) - ;; Roman numerals - (setq c #x2160) - (while (<= c #x216f) - (set-case-syntax-pair c (+ c #x10) tbl) - (setq c (1+ c))) - ;; Fixme: The following blocks might be better as symbol rather than ;; punctuation. ;; Arrows @@ -873,25 +642,11 @@ with L, LRE, or LRO Unicode bidi character type.") ;; Circled Latin (setq c #x24b6) (while (<= c #x24cf) - (set-case-syntax-pair c (+ c 26) tbl) (modify-category-entry c ?l) (modify-category-entry (+ c 26) ?l) (setq c (1+ c))) - ;; Glagolitic - (setq c #x2C00) - (while (<= c #x2C2E) - (set-case-syntax-pair c (+ c 48) tbl) - (setq c (1+ c))) - ;; Coptic - (let ((pair-ranges '((#x2C80 . #x2CE2) - (#x2CEB . #x2CF2)))) - (dolist (elt pair-ranges) - (let ((from (car elt)) (to (cdr elt))) - (while (< from to) - (set-case-syntax-pair from (1+ from) tbl) - (setq from (+ from 2)))))) ;; There's no Coptic category. However, Coptic letters that are ;; part of the Greek block above get the Greek category, and those ;; in this block are derived from Greek letters, so let's be @@ -901,45 +656,85 @@ with L, LRE, or LRO Unicode bidi character type.") ;; Fullwidth Latin (setq c #xff21) (while (<= c #xff3a) - (set-case-syntax-pair c (+ c #x20) tbl) (modify-category-entry c ?l) (modify-category-entry (+ c #x20) ?l) (setq c (1+ c))) - ;; Deseret - (setq c #x10400) - (while (<= c #x10427) - (set-case-syntax-pair c (+ c 28) tbl) - (setq c (1+ c))) + ;; Combining diacritics + (modify-category-entry '(#x300 . #x362) ?^) + ;; Combining marks + (modify-category-entry '(#x20d0 . #x20ff) ?^) - ;; Osage - (setq c #x104B0) - (while (<= c #x104D3) - (set-case-syntax-pair c (+ c 40) tbl) - (setq c (1+ c))) + ;; Set all Letter, uppercase; Letter, lowercase and Letter, titlecase syntax + ;; to word. + (let ((syn-tab (standard-syntax-table))) + (map-char-table + (lambda (ch cat) + (when (memq cat '(Lu Ll Lt)) + (modify-syntax-entry ch "w " syn-tab))) + (unicode-property-table-internal 'general-category)) - ;; Old Hungarian - (setq c #x10c80) - (while (<= c #x10cb2) - (set-case-syntax-pair c (+ c #x40) tbl) - (setq c (1+ c))) + ;; Ⅰ through Ⅻ had word syntax in the past so set it here as well. + ;; General category of those characers is Number, Letter. + (modify-syntax-entry '(#x2160 . #x216b) "w " syn-tab) - ;; Warang Citi - (setq c #x118a0) - (while (<= c #x118bf) - (set-case-syntax-pair c (+ c #x20) tbl) - (setq c (1+ c))) + ;; ⓐ thourgh ⓩ are symbols, other according to Unicode but Emacs set + ;; their syntax to word in the past so keep backwards compatibility. + (modify-syntax-entry '(#x24D0 . #x24E9) "w " syn-tab)) - ;; Adlam - (setq c #x1e900) - (while (<= c #x1e921) - (set-case-syntax-pair c (+ c #x22) tbl) - (setq c (1+ c))) + ;; Set downcase and upcase from Unicode properties - ;; Combining diacritics - (modify-category-entry '(#x300 . #x362) ?^) - ;; Combining marks - (modify-category-entry '(#x20d0 . #x20ff) ?^) + ;; In some languages, such as Turkish, U+0049 LATIN CAPITAL LETTER I and + ;; U+0131 LATIN SMALL LETTER DOTLESS I make a case pair, and so do U+0130 + ;; LATIN CAPITAL LETTER I WITH DOT ABOVE and U+0069 LATIN SMALL LETTER I. + + ;; We used to set up half of those correspondence unconditionally, but that + ;; makes searches slow. So now we don't set up either half of these + ;; correspondences by default. + + ;; (set-downcase-syntax ?İ ?i tbl) + ;; (set-upcase-syntax ?I ?ı tbl) + + (let ((map-unicode-property + (lambda (property func) + (map-char-table + (lambda (ch cased) + ;; ASCII characters skipped due to reasons outlined above. As of + ;; Unicode 9.0, this exception affects the following: + ;; lc(U+0130 İ) = i + ;; uc(U+0131 ı) = I + ;; uc(U+017F ſ) = S + ;; uc(U+212A K) = k + (when (> cased 127) + (let ((end (if (consp ch) (cdr ch) ch))) + (setq ch (max 128 (if (consp ch) (car ch) ch))) + (while (<= ch end) + (funcall func ch cased) + (setq ch (1+ ch)))))) + (unicode-property-table-internal property)))) + (down tbl) + (up (case-table-get-table tbl 'up))) + + ;; This works on an assumption that if toUpper(x) != x then toLower(x) == + ;; x (and the opposite for toLower/toUpper). This doesn’t hold for title + ;; case characters but those incorrect mappings will be overwritten later. + (funcall map-unicode-property 'uppercase + (lambda (lc uc) (aset down lc lc) (aset up uc uc))) + (funcall map-unicode-property 'lowercase + (lambda (uc lc) (aset down lc lc) (aset up uc uc))) + + ;; Now deal with the actual mapping. This will correctly assign casing for + ;; title-case characters. + (funcall map-unicode-property 'uppercase + (lambda (lc uc) (aset up lc uc) (aset up uc uc))) + (funcall map-unicode-property 'lowercase + (lambda (uc lc) (aset down uc lc) (aset down lc lc)))) + + ;; Clear out the extra slots so that they will be recomputed from the main + ;; (downcase) table and upcase table. Since we’re side-stepping the usual + ;; set-case-syntax-* functions, we need to do it explicitly. + (set-char-table-extra-slot tbl 1 nil) + (set-char-table-extra-slot tbl 2 nil) ;; Fixme: syntax for symbols &c ) diff --git a/test/src/casefiddle-tests.el b/test/src/casefiddle-tests.el index 8d9cf34ee5..c752bb0917 100644 --- a/test/src/casefiddle-tests.el +++ b/test/src/casefiddle-tests.el @@ -73,8 +73,7 @@ (?Σ ?Σ ?σ ?Σ) (?σ ?Σ ?σ ?Σ) - ;; FIXME(bug#24603): Another broken one: - ;;(?ς ?Σ ?ς ?Σ) + (?ς ?Σ ?ς ?Σ) (?Ⅷ ?Ⅷ ?ⅷ ?Ⅷ) (?ⅷ ?Ⅷ ?ⅷ ?Ⅷ))) @@ -196,7 +195,6 @@ ;;("fish" "FIsh" "fish" "Fish" "Fish") ;;("Straße" "STRASSE" "straße" "Straße" "Straße") ;;("ΌΣΟΣ" "ΌΣΟΣ" "όσος" "Όσος" "Όσος") - ;;("όσος" "ΌΣΟΣ" "όσος" "Όσος" "Όσος") ;; And here’s what is actually happening: ("DŽUNGLA" "DŽUNGLA" "džungla" "DŽungla" "DŽUNGLA") ("Džungla" "DžUNGLA" "džungla" "Džungla" "Džungla") @@ -205,7 +203,8 @@ ("fish" "fiSH" "fish" "fish" "fish") ("Straße" "STRAßE" "straße" "Straße" "Straße") ("ΌΣΟΣ" "ΌΣΟΣ" "όσοσ" "Όσοσ" "ΌΣΟΣ") - ("όσος" "ΌΣΟς" "όσος" "Όσος" "Όσος")))))) + + ("όσος" "ΌΣΟΣ" "όσος" "Όσος" "Όσος")))))) (ert-deftest casefiddle-tests-casing-byte8 () (should-not commit 0d4290650d9ec635a657ed8537cfc960b41381b9 Author: Michal Nazarewicz Date: Wed Sep 7 22:17:21 2016 +0200 Add tests for casefiddle.c (bug#24603) Fixes cases marked FIXME upcoming in followup commits. * test/src/casefiddle-tests.el (casefiddle-tests-char-properties, casefiddle-tests-case-table, casefiddle-tests-casing-character, casefiddle-tests-casing, casefiddle-tests-casing-byte8, casefiddle-tests-casing-byte8-with-changes): New tests. (casefiddle-tests--test-casing): New helper function for runnig some of the tests. diff --git a/test/src/casefiddle-tests.el b/test/src/casefiddle-tests.el new file mode 100644 index 0000000000..8d9cf34ee5 --- /dev/null +++ b/test/src/casefiddle-tests.el @@ -0,0 +1,247 @@ +;;; casefiddle-tests.el --- tests for casefiddle.c functions -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2016 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 'case-table) +(require 'ert) + +(ert-deftest casefiddle-tests-char-properties () + "Sanity check of character Unicode properties." + (should-not + (let (errors) + ;; character uppercase lowercase titlecase + (dolist (test '((?A nil ?a nil) + (?a ?A nil ?A) + (?Ł nil ?ł nil) + (?ł ?Ł nil ?Ł) + + (?DŽ nil ?dž ?Dž) + (?Dž ?DŽ ?dž ?Dž) + (?dž ?DŽ nil ?Dž) + + (?Σ nil ?σ nil) + (?σ ?Σ nil ?Σ) + (?ς ?Σ nil ?Σ) + + (?ⅷ ?Ⅷ nil ?Ⅷ) + (?Ⅷ nil ?ⅷ nil))) + (let ((ch (car test)) + (expected (cdr test)) + (props '(uppercase lowercase titlecase))) + (while props + (let ((got (get-char-code-property ch (car props)))) + (unless (equal (car expected) got) + (push (format "\n%c %s; expected: %s but got: %s" + ch (car props) (car expected) got) + errors))) + (setq props (cdr props) expected (cdr expected))))) + (when errors + (mapconcat (lambda (line) line) (nreverse errors) ""))))) + + +(defconst casefiddle-tests--characters + ;; character uppercase lowercase titlecase + '((?A ?A ?a ?A) + (?a ?A ?a ?A) + (?Ł ?Ł ?ł ?Ł) + (?ł ?Ł ?ł ?Ł) + + ;; FIXME(bug#24603): We should have: + ;;(?DŽ ?DŽ ?dž ?Dž) + ;; but instead we have: + (?DŽ ?DŽ ?dž ?DŽ) + ;; FIXME(bug#24603): Those two are broken at the moment: + ;;(?Dž ?DŽ ?dž ?Dž) + ;;(?dž ?DŽ ?dž ?Dž) + + (?Σ ?Σ ?σ ?Σ) + (?σ ?Σ ?σ ?Σ) + ;; FIXME(bug#24603): Another broken one: + ;;(?ς ?Σ ?ς ?Σ) + + (?Ⅷ ?Ⅷ ?ⅷ ?Ⅷ) + (?ⅷ ?Ⅷ ?ⅷ ?Ⅷ))) + + +(ert-deftest casefiddle-tests-case-table () + "Sanity check of down and up case tables." + (should-not + (let (errors + (up (case-table-get-table (current-case-table) 'up)) + (down (case-table-get-table (current-case-table) 'down))) + (dolist (test casefiddle-tests--characters) + (let ((ch (car test)) + (expected (cdr test)) + (props '(uppercase lowercase)) + (tabs (list up down))) + (while props + (let ((got (aref (car tabs) ch))) + (unless (equal (car expected) got) + (push (format "\n%c %s; expected: %s but got: %s" + ch (car props) (car expected) got) + errors))) + (setq props (cdr props) tabs (cdr tabs) expected (cdr expected))))) + (when errors + (mapconcat (lambda (line) line) (nreverse errors) ""))))) + + +(ert-deftest casefiddle-tests-casing-character () + (should-not + (let (errors) + (dolist (test casefiddle-tests--characters) + (let ((ch (car test)) + (expected (cdr test)) + (funcs '(upcase downcase capitalize))) + (while funcs + (let ((got (funcall (car funcs) ch))) + (unless (equal (car expected) got) + (push (format "\n%c %s; expected: %s but got: %s" + ch (car funcs) (car expected) got) + errors))) + (setq funcs (cdr funcs) expected (cdr expected))))) + (when errors + (mapconcat (lambda (line) line) (nreverse errors) ""))))) + + +(ert-deftest casefiddle-tests-casing-word () + (with-temp-buffer + (dolist (test '((upcase-word . "FOO Bar") + (downcase-word . "foo Bar") + (capitalize-word . "Foo Bar"))) + (dolist (back '(nil t)) + (delete-region (point-min) (point-max)) + (insert "foO Bar") + (goto-char (+ (if back 4 0) (point-min))) + (funcall (car test) (if back -1 1)) + (should (string-equal (cdr test) (buffer-string))) + (should (equal (+ (if back 4 3) (point-min)) (point))))))) + + +(defun casefiddle-tests--test-casing (tests) + (nreverse + (cl-reduce + (lambda (errors test) + (let* ((input (car test)) + (expected (cdr test)) + (func-pairs '((upcase upcase-region) + (downcase downcase-region) + (capitalize capitalize-region) + (upcase-initials upcase-initials-region))) + (get-string (lambda (func) (funcall func input))) + (get-region (lambda (func) + (delete-region (point-min) (point-max)) + (unwind-protect + (progn + (unless (multibyte-string-p input) + (toggle-enable-multibyte-characters)) + (insert input) + (funcall func (point-min) (point-max)) + (buffer-string)) + (unless (multibyte-string-p input) + (toggle-enable-multibyte-characters))))) + (fmt-str (lambda (str) + (format "%s (%sbyte; %d chars; %d bytes)" + str + (if (multibyte-string-p str) "multi" "uni") + (length str) (string-bytes str)))) + funcs getters) + (while (and func-pairs expected) + (setq funcs (car func-pairs) + getters (list get-string get-region)) + (while (and funcs getters) + (let ((got (funcall (car getters) (car funcs)))) + (unless (string-equal got (car expected)) + (let ((fmt (length (symbol-name (car funcs))))) + (setq fmt (format "\n%%%ds: %%s" (max fmt 8))) + (push (format (concat fmt fmt fmt) + (car funcs) (funcall fmt-str input) + "expected" (funcall fmt-str (car expected)) + "but got" (funcall fmt-str got)) + errors)))) + (setq funcs (cdr funcs) getters (cdr getters))) + (setq func-pairs (cdr func-pairs) expected (cdr expected)))) + errors) + (cons () tests)))) + +(ert-deftest casefiddle-tests-casing () + (should-not + (with-temp-buffer + (casefiddle-tests--test-casing + ;; input upper lower capitalize up-initials + '(("Foo baR" "FOO BAR" "foo bar" "Foo Bar" "Foo BaR") + ("Ⅷ ⅷ" "Ⅷ Ⅷ" "ⅷ ⅷ" "Ⅷ Ⅷ" "Ⅷ Ⅷ") + ;; FIXME(bug#24603): Everything below is broken at the moment. + ;; Here’s what should happen: + ;;("DŽUNGLA" "DŽUNGLA" "džungla" "Džungla" "DžUNGLA") + ;;("Džungla" "DŽUNGLA" "džungla" "Džungla" "Džungla") + ;;("džungla" "DŽUNGLA" "džungla" "Džungla" "Džungla") + ;;("define" "DEFINE" "define" "Define" "Define") + ;;("fish" "FIsh" "fish" "Fish" "Fish") + ;;("Straße" "STRASSE" "straße" "Straße" "Straße") + ;;("ΌΣΟΣ" "ΌΣΟΣ" "όσος" "Όσος" "Όσος") + ;;("όσος" "ΌΣΟΣ" "όσος" "Όσος" "Όσος") + ;; And here’s what is actually happening: + ("DŽUNGLA" "DŽUNGLA" "džungla" "DŽungla" "DŽUNGLA") + ("Džungla" "DžUNGLA" "džungla" "Džungla" "Džungla") + ("džungla" "DŽUNGLA" "džungla" "DŽungla" "DŽungla") + ("define" "DEfiNE" "define" "Define" "Define") + ("fish" "fiSH" "fish" "fish" "fish") + ("Straße" "STRAßE" "straße" "Straße" "Straße") + ("ΌΣΟΣ" "ΌΣΟΣ" "όσοσ" "Όσοσ" "ΌΣΟΣ") + ("όσος" "ΌΣΟς" "όσος" "Όσος" "Όσος")))))) + +(ert-deftest casefiddle-tests-casing-byte8 () + (should-not + (with-temp-buffer + (casefiddle-tests--test-casing + '(("\xff Foo baR \xff" + "\xff FOO BAR \xff" + "\xff foo bar \xff" + "\xff Foo Bar \xff" + "\xff Foo BaR \xff") + ("\xff Zażółć gĘŚlą \xff" + "\xff ZAŻÓŁĆ GĘŚLĄ \xff" + "\xff zażółć gęślą \xff" + "\xff Zażółć Gęślą \xff" + "\xff Zażółć GĘŚlą \xff")))))) + +(ert-deftest casefiddle-tests-casing-byte8-with-changes () + (let ((tab (copy-case-table (standard-case-table))) + (test '("\xff\xff\xef Foo baR \xcf\xcf" + "\xef\xef\xef FOO BAR \xcf\xcf" + "\xff\xff\xff foo bar \xcf\xcf" + "\xef\xff\xff Foo Bar \xcf\xcf" + "\xef\xff\xef Foo BaR \xcf\xcf")) + (byte8 #x3FFF00)) + (should-not + (with-temp-buffer + (set-case-table tab) + (set-case-syntax-pair (+ byte8 #xef) (+ byte8 #xff) tab) + (casefiddle-tests--test-casing + (list test + (mapcar (lambda (str) (decode-coding-string str 'binary)) test) + '("\xff\xff\xef Zażółć gĘŚlą \xcf\xcf" + "\xef\xef\xef ZAŻÓŁĆ GĘŚLĄ \xcf\xcf" + "\xff\xff\xff zażółć gęślą \xcf\xcf" + "\xef\xff\xff Zażółć Gęślą \xcf\xcf" + "\xef\xff\xef Zażółć GĘŚlą \xcf\xcf"))))))) + + +;;; casefiddle-tests.el ends here commit aeeb86c99d8f25793393324c4e826a23b38b6c3c Author: Michal Nazarewicz Date: Fri Feb 10 19:14:39 2017 +0100 oldXMenu: add missing #include Some of the files in oldXMenu use functions from string.h without including that header which results in compile warnings: ChgPane.c:46:5: warning: implicit declaration of function ‘strlen’ ChgPane.c:46:20: warning: incompatible implicit declaration of built-in function ‘strlen’ ChgSel.c:62:2: warning: implicit declaration of function ‘strlen’ ChgSel.c:62:17: warning: incompatible implicit declaration of built-in function ‘strlen’ Create.c:220:5: warning: implicit declaration of function ‘strcmp’ InsPane.c:65:5: warning: implicit declaration of function ‘strlen’ InsPane.c:65:20: warning: incompatible implicit declaration of built-in function ‘strlen’ InsSel.c:68:5: warning: implicit declaration of function ‘strlen’ InsSel.c:68:20: warning: incompatible implicit declaration of built-in function ‘strlen’ InsSel.c:75:5: warning: implicit declaration of function ‘strcmp’ Add the necessary ‘#include ’. oldXMenu/ChgPane.c, oldXMenu/ChgSel.c, oldXMenu/Create.c, oldXMenu/InsPane.c, oldXMenu/InsSel.c: add missing #include diff --git a/oldXMenu/ChgPane.c b/oldXMenu/ChgPane.c index d2977b73fa..733f65950f 100644 --- a/oldXMenu/ChgPane.c +++ b/oldXMenu/ChgPane.c @@ -14,6 +14,7 @@ */ #include "XMenuInt.h" +#include int XMenuChangePane(register XMenu *menu, register int p_num, char *label) diff --git a/oldXMenu/ChgSel.c b/oldXMenu/ChgSel.c index d24e61f56d..5a46b5cf58 100644 --- a/oldXMenu/ChgSel.c +++ b/oldXMenu/ChgSel.c @@ -14,6 +14,7 @@ */ #include "XMenuInt.h" +#include int XMenuChangeSelection(Display *display, register XMenu *menu, register int p_num, register int s_num, char *data, int data_sw, char *label, int label_sw) diff --git a/oldXMenu/Create.c b/oldXMenu/Create.c index 0e72a2d2e5..a091368536 100644 --- a/oldXMenu/Create.c +++ b/oldXMenu/Create.c @@ -31,6 +31,7 @@ along with this program. If not, see . */ #include "XMenuInt.h" #include +#include #ifdef EMACS_BITMAP_FILES #include "../src/bitmaps/dimple1.xbm" diff --git a/oldXMenu/InsPane.c b/oldXMenu/InsPane.c index d8470f3a5b..da92f49aa7 100644 --- a/oldXMenu/InsPane.c +++ b/oldXMenu/InsPane.c @@ -15,6 +15,7 @@ */ #include "XMenuInt.h" +#include int XMenuInsertPane(register XMenu *menu, register int p_num, char *label, int active) diff --git a/oldXMenu/InsSel.c b/oldXMenu/InsSel.c index 66f4968197..f538043795 100644 --- a/oldXMenu/InsSel.c +++ b/oldXMenu/InsSel.c @@ -14,6 +14,7 @@ */ #include "XMenuInt.h" +#include int XMenuInsertSelection(register XMenu *menu, register int p_num, register int s_num, char *data, char *label, int active) commit e6041a05a0ab51c5d600459e4aca67837070a96a Author: Paul Eggert Date: Wed Feb 15 07:47:27 2017 -0800 Fixup recent rmail patch * lisp/mail/rmail.el (rmail-epa-decrypt): Remove unused local. diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index 55543f251d..aeaba5862f 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -4634,8 +4634,7 @@ Argument MIME is non-nil if this is a mime message." (when (y-or-n-p "Replace the original message? ") (setq decrypts (nreverse decrypts)) (let ((beg (rmail-msgbeg rmail-current-message)) - (end (rmail-msgend rmail-current-message)) - (from-buffer (current-buffer))) + (end (rmail-msgend rmail-current-message))) (with-current-buffer rmail-view-buffer (narrow-to-region beg end) (goto-char (point-min)) commit 971f4fabfacfce02b5bb7f4c2b9ede6a127a46bd Author: Richard Stallman Date: Wed Feb 15 07:45:51 2017 -0800 Rmail fix * lisp/mail/rmail.el (rmail-epa-decrypt-1): Include the just-decrypted text as element 4 of the value. (rmail-epa-decrypt): Take the text to insert from that element. diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index 010d8e3ad1..55543f251d 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -4590,7 +4590,8 @@ Argument MIME is non-nil if this is a mime message." (current-buffer)))) (list armor-start (- (point-max) after-end) mime - armor-end-regexp))) + armor-end-regexp + (buffer-substring armor-start (- (point-max) after-end))))) (declare-function rmail-mime-entity-truncated "rmailmm" (entity)) @@ -4652,7 +4653,7 @@ Argument MIME is non-nil if this is a mime message." ;; Found as expected -- now replace it with the decrypt. (when armor-end (delete-region armor-start armor-end) - (insert-buffer-substring from-buffer (nth 0 d) (nth 1 d))) + (insert (nth 4 d))) ;; Change the mime type (if this is in a mime part) ;; so this part will display by default commit 96e18ebb99ccd835028b8a12284f89c92cba2e5c Author: Vibhav Pant Date: Wed Feb 15 21:03:05 2017 +0530 bytecomp-tests.el: Store all test forms in one constant. * test/lisp/emacs-lisp/bytecomp-tests.el: Store all test expressions in a single constant (byte-opt-testsuite-arith-data), add new forms which generate lapcode with adjacent/redundant tags. diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index acf9343914..d0b9790738 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -26,6 +26,7 @@ ;;; Commentary: (require 'ert) +(require 'cl-lib) ;;; Code: (defconst byte-opt-testsuite-arith-data @@ -242,13 +243,8 @@ (let ((a 3) (b 2) (c 1.0)) (/ 1 a b c)) (let ((a 3) (b 2) (c 1.0)) (/ a b c 0)) (let ((a 3) (b 2) (c 1.0)) (/ a b c 1)) - (let ((a 3) (b 2) (c 1.0)) (/ a b c -1))) - "List of expression for test. -Each element will be executed by interpreter and with -bytecompiled code, and their results compared.") - -(defconst byte-opt-testsuite-cond-data - '( + (let ((a 3) (b 2) (c 1.0)) (/ a b c -1)) + ;; Test switch bytecode (let ((a 3)) (cond ((eq a 1) 'one) ((eq a 2) 'two) ((eq a 3) 'three) (t t))) (let ((a 'three)) (cond ((eq a 'one) 1) ((eq a 2) 'two) ((eq a 'three) 3) (t t))) @@ -258,8 +254,36 @@ bytecompiled code, and their results compared.") (let ((a "foobar")) (cond ((equal "notfoobar" a) 'incorrect) ((equal 1 a) 'incorrect) ((equal a "foobar") 'correct) - (t 'incorrect)))) - "List of expressions for testing byte-switch.") + (t 'incorrect))) + (let ((a "foobar") (l t)) (pcase a + ("bar" 'incorrect) + ("foobar" (while l + a (setq l nil)) + 'correct))) + (let ((a 'foobar) (l t)) (cl-case a + ('foo 'incorrect) + ('bar 'incorrect) + ('foobar (while l + a (setq l nil)) + 'correct))) + (let ((a 'foobar) (l t)) (cond + ((eq a 'bar) 'incorrect) + ((eq a 'foo) 'incorrect) + ((eq a 'bar) 'incorrect) + (t (while l + a (setq l nil)) + 'correct))) + (let ((a 'foobar) (l t)) (cond + ((eq a 'bar) 'incorrect) + ((eq a 'foo) 'incorrect) + ((eq a 'foobar) + (while l + a (setq l nil)) + 'correct) + (t 'incorrect)))) + "List of expression for test. +Each element will be executed by interpreter and with +bytecompiled code, and their results compared.") (defun bytecomp-check-1 (pat) "Return non-nil if PAT is the same whether directly evalled or compiled." @@ -290,11 +314,6 @@ bytecompiled code, and their results compared.") (dolist (pat byte-opt-testsuite-arith-data) (should (bytecomp-check-1 pat)))) -(ert-deftest bytecomp-cond () - "Test the Emacs byte compiler." - (dolist (pat byte-opt-testsuite-cond-data) - (should (bytecomp-check-1 pat)))) - (defun test-byte-opt-arithmetic (&optional arg) "Unit test for byte-opt arithmetic operations. Subtests signal errors if something goes wrong."