commit 9d791c60b94dbf88da945911878aeabd07735ac8 (HEAD, refs/remotes/origin/master) Author: Glenn Morris Date: Sun Jan 28 18:10:50 2018 -0800 * configure.ac: Improve recent libtof version test. diff --git a/configure.ac b/configure.ac index a09ae6a592..f2a8332d71 100644 --- a/configure.ac +++ b/configure.ac @@ -3309,8 +3309,7 @@ if test "${HAVE_X11}" = "yes"; then AC_DEFINE(HAVE_OTF_GET_VARIATION_GLYPHS, 1, [Define to 1 if libotf has OTF_get_variation_glyphs.]) fi - EMACS_CHECK_MODULES([OTFOK], [libotf >= 0.9.16]) - if test "$HAVE_OTFOK" != "yes"; then + if ! $PKG_CONFIG --atleast-version=0.9.16 libotf; then AC_DEFINE(HAVE_OTF_KANNADA_BUG, 1, [Define to 1 if libotf is affected by https://debbugs.gnu.org/28110.]) fi commit 17bf85938c2835f371dd44b4d9f6c9f741c2b054 Author: Glenn Morris Date: Sun Jan 28 18:07:03 2018 -0800 ; * test/lisp/emacs-lisp/cl-preloaded-tests.el: Fix copyright notice. diff --git a/test/lisp/emacs-lisp/cl-preloaded-tests.el b/test/lisp/emacs-lisp/cl-preloaded-tests.el index 008a6e629f..9d5feee396 100644 --- a/test/lisp/emacs-lisp/cl-preloaded-tests.el +++ b/test/lisp/emacs-lisp/cl-preloaded-tests.el @@ -1,16 +1,16 @@ ;;; cl-preloaded-tests.el --- unit tests for cl-preloaded.el -*- lexical-binding: t; -*- -;; Copyright (C) 2017 Free Software Foundation, Inc. +;; Copyright (C) 2017-2018 Free Software Foundation, Inc. ;; Author: Philipp Stephani ;; This file is part of GNU Emacs. -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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. commit 61b9721c1c1a6315a4ec1a695a75e99eb4848e4b Author: Juri Linkov Date: Sun Jan 28 23:59:02 2018 +0200 * lisp/simple.el: Move definitions shell-command-saved-pos and shell-command-dont-erase-buffer closer to their usage. diff --git a/lisp/simple.el b/lisp/simple.el index 5a3a6e1f24..375ee31e9c 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -37,28 +37,6 @@ (defvar compilation-current-error) (defvar compilation-context-lines) -(defcustom shell-command-dont-erase-buffer nil - "If non-nil, output buffer is not erased between shell commands. -Also, a non-nil value sets the point in the output buffer -once the command completes. -The value `beg-last-out' sets point at the beginning of the output, -`end-last-out' sets point at the end of the buffer, `save-point' -restores the buffer position before the command." - :type '(choice - (const :tag "Erase buffer" nil) - (const :tag "Set point to beginning of last output" beg-last-out) - (const :tag "Set point to end of last output" end-last-out) - (const :tag "Save point" save-point)) - :group 'shell - :version "26.1") - -(defvar shell-command-saved-pos nil - "Record of point positions in output buffers after command completion. -The value is an alist whose elements are of the form (BUFFER . POS), -where BUFFER is the output buffer, and POS is the point position -in BUFFER once the command finishes. -This variable is used when `shell-command-dont-erase-buffer' is non-nil.") - (defcustom idle-update-delay 0.5 "Idle time delay before updating various things on the screen. Various Emacs features that update auxiliary information when point moves @@ -3300,6 +3278,28 @@ is output." :group 'shell :version "26.1") +(defcustom shell-command-dont-erase-buffer nil + "If non-nil, output buffer is not erased between shell commands. +Also, a non-nil value sets the point in the output buffer +once the command completes. +The value `beg-last-out' sets point at the beginning of the output, +`end-last-out' sets point at the end of the buffer, `save-point' +restores the buffer position before the command." + :type '(choice + (const :tag "Erase buffer" nil) + (const :tag "Set point to beginning of last output" beg-last-out) + (const :tag "Set point to end of last output" end-last-out) + (const :tag "Save point" save-point)) + :group 'shell + :version "26.1") + +(defvar shell-command-saved-pos nil + "Record of point positions in output buffers after command completion. +The value is an alist whose elements are of the form (BUFFER . POS), +where BUFFER is the output buffer, and POS is the point position +in BUFFER once the command finishes. +This variable is used when `shell-command-dont-erase-buffer' is non-nil.") + (defun shell-command--save-pos-or-erase () "Store a buffer position or erase the buffer. See `shell-command-dont-erase-buffer'." commit 2a9e5517d71d890a45f7fedb53102c4a039db787 Author: Juri Linkov Date: Sun Jan 28 23:48:11 2018 +0200 * lisp/simple.el (upcase-dwim, downcase-dwim): Add region-noncontiguous-p to the calls of region functions to support rectangular regions. diff --git a/lisp/simple.el b/lisp/simple.el index 44f738f07e..5a3a6e1f24 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -8963,7 +8963,7 @@ Otherwise, it calls `upcase-word', with prefix argument passed to it to upcase ARG words." (interactive "*p") (if (use-region-p) - (upcase-region (region-beginning) (region-end)) + (upcase-region (region-beginning) (region-end) (region-noncontiguous-p)) (upcase-word arg))) (defun downcase-dwim (arg) @@ -8973,7 +8973,7 @@ Otherwise, it calls `downcase-word', with prefix argument passed to it to downcase ARG words." (interactive "*p") (if (use-region-p) - (downcase-region (region-beginning) (region-end)) + (downcase-region (region-beginning) (region-end) (region-noncontiguous-p)) (downcase-word arg))) (defun capitalize-dwim (arg) commit 3c46315d21c090797920628a886234c5d8dc8215 Author: Juri Linkov Date: Sun Jan 28 23:27:32 2018 +0200 * lisp/tar-mode.el (tar-summarize-buffer): Let-bind `create-lockfiles' to nil instead of `buffer-file-truename'. (Bug#30215) * lisp/image-mode.el (image-toggle-display-image): Idem. diff --git a/lisp/image-mode.el b/lisp/image-mode.el index 1052ed9761..70d2ca87cc 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -780,7 +780,7 @@ was inserted." rear-nonsticky (display) ;; intangible read-only t front-sticky (read-only))) - (let ((buffer-file-truename nil)) ; avoid changing dir mtime by lock_file + (let ((create-lockfiles nil)) ; avoid changing dir mtime by lock_file (add-text-properties (point-min) (point-max) props) (restore-buffer-modified-p modified)) ;; Inhibit the cursor when the buffer contains only an image, diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el index 2beeb7484a..f7b14fab51 100644 --- a/lisp/tar-mode.el +++ b/lisp/tar-mode.el @@ -595,7 +595,7 @@ MODE should be an integer which is a file mode value." (progress-reporter-done progress-reporter) (message "Warning: premature EOF parsing tar file")) (goto-char (point-min)) - (let ((buffer-file-truename nil) ; avoid changing dir mtime by lock_file + (let ((create-lockfiles nil) ; avoid changing dir mtime by lock_file (inhibit-read-only t) (total-summaries (mapconcat 'tar-header-block-summarize tar-parse-info "\n"))) commit 614e9b322ec08cf6549cd4db34e1dc75149e6b31 Author: Philipp Stephani Date: Sun Jan 28 20:39:58 2018 +0100 Add missing module types to cl--typeof-types. * lisp/emacs-lisp/cl-preloaded.el (cl--typeof-types): Add module types. * test/src/emacs-module-tests.el (emacs-module-tests--generic): New helper function. (module-function-object, mod-test-userptr-fun-test): Test that type dispatching works with module types. diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 364de03133..2a70f9b924 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -60,12 +60,14 @@ (marker number-or-marker atom) (overlay atom) (float number atom) (window-configuration atom) (process atom) (window atom) (subr atom) (compiled-function function atom) + (module-function function atom) (buffer atom) (char-table array sequence atom) (bool-vector array sequence atom) (frame atom) (hash-table atom) (terminal atom) (thread atom) (mutex atom) (condvar atom) (font-spec atom) (font-entity atom) (font-object atom) (vector array sequence atom) + (user-ptr atom) ;; Plus, really hand made: (null symbol list sequence atom)) "Alist of supertypes. diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el index 162af21bbe..a6407524ad 100644 --- a/test/src/emacs-module-tests.el +++ b/test/src/emacs-module-tests.el @@ -30,6 +30,14 @@ (require 'mod-test mod-test-file) +(cl-defgeneric emacs-module-tests--generic (_)) + +(cl-defmethod emacs-module-tests--generic ((_ module-function)) + 'module-function) + +(cl-defmethod emacs-module-tests--generic ((_ user-ptr)) + 'user-ptr) + ;; ;; Basic tests. ;; @@ -74,6 +82,7 @@ changes." (should (module-function-p func)) (should (functionp func)) (should (equal (type-of func) 'module-function)) + (should (eq (emacs-module-tests--generic func) 'module-function)) (should (string-match-p (rx bos "# Date: Sun Jan 28 20:20:07 2018 +0100 Test that module functions are functions. * test/src/emacs-module-tests.el (module-function-object): Verify that a module function is treated as a function. diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el index 85d6305386..162af21bbe 100644 --- a/test/src/emacs-module-tests.el +++ b/test/src/emacs-module-tests.el @@ -72,6 +72,7 @@ This test needs to be changed whenever the implementation changes." (let ((func (symbol-function #'mod-test-sum))) (should (module-function-p func)) + (should (functionp func)) (should (equal (type-of func) 'module-function)) (should (string-match-p (rx bos "# Date: Sun Jan 28 19:25:48 2018 +0100 * src/lisp.h: Tell developers to add new types to cl--typeof-types. diff --git a/src/lisp.h b/src/lisp.h index 616aea0780..d547c0c443 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -583,7 +583,10 @@ enum Lisp_Fwd_Type resources allocated for it that are not Lisp objects. You can even make a pointer to the function that frees the resources a slot in your object -- this way, the same object could be used to represent - several disparate C structures. */ + several disparate C structures. + + You also need to add the new type to the constant + `cl--typeof-types' in lisp/emacs-lisp/cl-preloaded.el. */ /* A Lisp_Object is a tagged pointer or integer. Ordinarily it is a commit 9a747b3554515135d5acadfcb5c2b1b8240d8f84 Author: Philipp Stephani Date: Thu Dec 21 18:25:49 2017 +0100 Prevent name clashes between CL structures and builtin types * lisp/emacs-lisp/cl-preloaded.el (cl-struct-define): Don't allow structures with the same names as builtin types. (cl--typeof-types, cl--all-builtin-types): Move from cl-generic.el and rename. (cl--struct-name-p): New helper function. * lisp/emacs-lisp/cl-macs.el (cl-defstruct): Don't allow structures with the same names as builtin types. * lisp/emacs-lisp/cl-generic.el (cl--generic-typeof-generalizer) (cl-generic-generalizers): Adapt to name change. * test/lisp/emacs-lisp/cl-macs-tests.el (cl-defstruct/builtin-type): * test/lisp/emacs-lisp/cl-preloaded-tests.el (cl-struct-define/builtin-type): New unit tests. * etc/NEWS: Document changed behavior. diff --git a/etc/NEWS b/etc/NEWS index 80ddf10488..b28f284116 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -220,6 +220,10 @@ calling 'eldoc-message' directly. generating warnings for a decade. To interpret old-style backquotes as new-style, bind the new variable 'force-new-style-backquotes' to t. +** Defining a Common Lisp structure using 'cl-defstruct' or +'cl-struct-define' whose name clashes with a builtin type (e.g., +'integer' or 'hash-table') now signals an error. + * Lisp Changes in Emacs 27.1 diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index caad62c84f..173173305b 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -1160,45 +1160,19 @@ These match if the argument is `eql' to VAL." ;;; Dispatch on "system types". -(defconst cl--generic-typeof-types - ;; Hand made from the source code of `type-of'. - '((integer number number-or-marker atom) - (symbol atom) (string array sequence atom) - (cons list sequence) - ;; Markers aren't `numberp', yet they are accepted wherever integers are - ;; accepted, pretty much. - (marker number-or-marker atom) - (overlay atom) (float number atom) (window-configuration atom) - (process atom) (window atom) (subr atom) (compiled-function function atom) - (buffer atom) (char-table array sequence atom) - (bool-vector array sequence atom) - (frame atom) (hash-table atom) (terminal atom) - (thread atom) (mutex atom) (condvar atom) - (font-spec atom) (font-entity atom) (font-object atom) - (vector array sequence atom) - ;; Plus, really hand made: - (null symbol list sequence atom)) - "Alist of supertypes. -Each element has the form (TYPE . SUPERTYPES) where TYPE is one of -the symbols returned by `type-of', and SUPERTYPES is the list of its -supertypes from the most specific to least specific.") - -(defconst cl--generic-all-builtin-types - (delete-dups (copy-sequence (apply #'append cl--generic-typeof-types)))) - (cl-generic-define-generalizer cl--generic-typeof-generalizer ;; FIXME: We could also change `type-of' to return `null' for nil. 10 (lambda (name &rest _) `(if ,name (type-of ,name) 'null)) (lambda (tag &rest _) - (and (symbolp tag) (assq tag cl--generic-typeof-types)))) + (and (symbolp tag) (assq tag cl--typeof-types)))) (cl-defmethod cl-generic-generalizers :extra "typeof" (type) "Support for dispatch on builtin types. -See the full list and their hierarchy in `cl--generic-typeof-types'." +See the full list and their hierarchy in `cl--typeof-types'." ;; FIXME: Add support for other types accepted by `cl-typep' such ;; as `character', `face', `function', ... (or - (and (memq type cl--generic-all-builtin-types) + (and (memq type cl--all-builtin-types) (progn ;; FIXME: While this wrinkle in the semantics can be occasionally ;; problematic, this warning is more often annoying than helpful. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 43eb426116..4aed1f2662 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2687,6 +2687,9 @@ non-nil value, that slot cannot be set via `setf'. (forms nil) (docstring (if (stringp (car descs)) (pop descs))) pred-form pred-check) + ;; Can't use `cl-check-type' yet. + (unless (cl--struct-name-p name) + (signal 'wrong-type-argument (list 'cl-struct-name-p name 'name))) (setq descs (cons '(cl-tag-slot) (mapcar (function (lambda (x) (if (consp x) x (list x)))) descs))) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 92d29996f9..364de03133 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -50,6 +50,37 @@ (apply #'error string (append sargs args)) (signal 'cl-assertion-failed `(,form ,@sargs))))) +(defconst cl--typeof-types + ;; Hand made from the source code of `type-of'. + '((integer number number-or-marker atom) + (symbol atom) (string array sequence atom) + (cons list sequence) + ;; Markers aren't `numberp', yet they are accepted wherever integers are + ;; accepted, pretty much. + (marker number-or-marker atom) + (overlay atom) (float number atom) (window-configuration atom) + (process atom) (window atom) (subr atom) (compiled-function function atom) + (buffer atom) (char-table array sequence atom) + (bool-vector array sequence atom) + (frame atom) (hash-table atom) (terminal atom) + (thread atom) (mutex atom) (condvar atom) + (font-spec atom) (font-entity atom) (font-object atom) + (vector array sequence atom) + ;; Plus, really hand made: + (null symbol list sequence atom)) + "Alist of supertypes. +Each element has the form (TYPE . SUPERTYPES) where TYPE is one of +the symbols returned by `type-of', and SUPERTYPES is the list of its +supertypes from the most specific to least specific.") + +(defconst cl--all-builtin-types + (delete-dups (copy-sequence (apply #'append cl--typeof-types)))) + +(defun cl--struct-name-p (name) + "Return t if NAME is a valid structure name for `cl-defstruct'." + (and name (symbolp name) (not (keywordp name)) + (not (memq name cl--all-builtin-types)))) + ;; When we load this (compiled) file during pre-loading, the cl--struct-class ;; code below will need to access the `cl-struct' info, since it's considered ;; already as its parent (because `cl-struct' was defined while the file was @@ -110,6 +141,7 @@ ;;;###autoload (defun cl-struct-define (name docstring parent type named slots children-sym tag print) + (cl-check-type name cl--struct-name) (unless type ;; Legacy defstruct, using tagged vectors. Enable backward compatibility. (cl-old-struct-compat-mode 1)) diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index edb1530cad..6e9fb44b4b 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -497,7 +497,6 @@ collection clause." vconcat (vector (1+ x))) [2 3 4 5 6]))) - (ert-deftest cl-macs-loop-for-as-equals-and () "Test for https://debbugs.gnu.org/29799 ." (let ((arr (make-vector 3 0))) @@ -505,4 +504,13 @@ collection clause." (cl-loop for k below 3 for x = k and z = (elt arr k) collect (list k x)))))) + +(ert-deftest cl-defstruct/builtin-type () + (should-error + (macroexpand '(cl-defstruct hash-table)) + :type 'wrong-type-argument) + (should-error + (macroexpand '(cl-defstruct (hash-table (:predicate hash-table-p)))) + :type 'wrong-type-argument)) + ;;; cl-macs-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-preloaded-tests.el b/test/lisp/emacs-lisp/cl-preloaded-tests.el new file mode 100644 index 0000000000..008a6e629f --- /dev/null +++ b/test/lisp/emacs-lisp/cl-preloaded-tests.el @@ -0,0 +1,33 @@ +;;; cl-preloaded-tests.el --- unit tests for cl-preloaded.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 Free Software Foundation, Inc. +;; Author: Philipp Stephani + +;; This file is part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Unit tests for lisp/emacs-lisp/cl-preloaded.el. + +;;; Code: + +(ert-deftest cl-struct-define/builtin-type () + (should-error + (cl-struct-define 'hash-table nil nil 'record nil nil + 'cl-preloaded-tests-tag 'cl-preloaded-tests nil) + :type 'wrong-type-argument)) + +;;; cl-preloaded-tests.el ends here commit a718e1593ae7332fafe734f880181e2d8ecc34df Author: Alan Mackenzie Date: Sun Jan 28 17:53:07 2018 +0000 Fix some errors in c-display-defun-name when the type is "struct {..}", etc. Also fix some errors with c-display-defun-name when there are nested classes. * lisp/progmodes/cc-cmds.el (c-in-function-trailer-p): Deal with a struct {..} being merely the type of a function. (c-where-wrt-brace-construct): Deal with a struct {..} being merely the type of a function. Rearrange the order of some Lisp forms. Insert a check for c-protection-key ("private", etc.) alongside the checking for a label. (c-defun-name-1): New function extracted form c-defun-name, which works within the existing restriction. Don't regard 'at-function-end as being within the defun any more. Recognize "struct", etc., with the new c-defun-type-name-decl-key rather than c-type-prefix-key. Make the recognition of a normal function more accurate. (c-defun-name): Part left after extracting the above function. It now just widens and calls c-defun-name-1. (c-declaration-limits-1): New function extracted from c-declaration-limits, which works within the existing restriction. Move LIM back one block to account for the possibility of struct {..} as a function type. Check we're not inside a declaration without braces. (c-declaration-limits): Part left after extracting the above function. It now just narrows to an enclosing decl block and calls c-declaration-limits-1. (c-defun-name-and-limits): New function which identifies the name and limits of the most nested enclosing declaration or macro. (c-display-defun-name): Use c-defun-name-and-limits rather than two separate functions (which didn't always agree on which function). * lisp/progmodes/cc-engine.el (c-beginning-of-statement-1): If we have struct {..} as the type of a function, go back over this, too. * lisp/progmodes/cc-langs.el (c-defun-type-name-decl-kwds) (c-defun-type-name-decl-key): New lang const/var. diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el index 0c4829e103..31cf0b1159 100644 --- a/lisp/progmodes/cc-cmds.el +++ b/lisp/progmodes/cc-cmds.el @@ -1397,6 +1397,16 @@ No indentation or other \"electric\" behavior is performed." (not (eq (char-before) ?_)) (c-syntactic-re-search-forward "[;=([{]" eo-block t t t) (eq (char-before) ?\{) + ;; Exclude the entire "struct {...}" being the type of a + ;; function being declared. + (not + (and + (c-go-up-list-forward) + (eq (char-before) ?}) + (progn (c-forward-syntactic-ws) + (c-syntactic-re-search-forward + "[;=([{]" nil t t t)) + (eq (char-before) ?\())) bod))))) (defun c-where-wrt-brace-construct () @@ -1434,7 +1444,11 @@ No indentation or other \"electric\" behavior is performed." ((and (not least-enclosing) (consp paren-state) (consp (car paren-state)) - (eq start (cdar paren-state))) + (eq start (cdar paren-state)) + (not + (progn + (c-forward-syntactic-ws) + (looking-at c-symbol-start)))) 'at-function-end) (t ;; Find the start of the current declaration. NOTE: If we're in the @@ -1450,6 +1464,18 @@ No indentation or other \"electric\" behavior is performed." "\\([;#]\\|\\'\\|\\s(\\|\\s)\\|\\s\"\\|\\s\\\\|\\s$\\|\\s<\\|\\s>\\|\\s!\\)"))) (forward-char)) (setq kluge-start (point)) + ;; First approximation as to whether the current "header" we're in is + ;; one followed by braces. + (setq brace-decl-p + (save-excursion + (and (c-syntactic-re-search-forward "[;{]" nil t t) + (or (eq (char-before) ?\{) + (and c-recognize-knr-p + ;; Might have stopped on the + ;; ';' in a K&R argdecl. In + ;; that case the declaration + ;; should contain a block. + (c-in-knr-argdecl)))))) (setq decl-result (car (c-beginning-of-decl-1 ;; NOTE: If we're in a K&R region, this might be the start @@ -1460,17 +1486,9 @@ No indentation or other \"electric\" behavior is performed." (c-safe-position least-enclosing paren-state))))) ;; Has the declaration we've gone back to got braces? - (or (eq decl-result 'label) - (setq brace-decl-p - (save-excursion - (and (c-syntactic-re-search-forward "[;{]" nil t t) - (or (eq (char-before) ?\{) - (and c-recognize-knr-p - ;; Might have stopped on the - ;; ';' in a K&R argdecl. In - ;; that case the declaration - ;; should contain a block. - (c-in-knr-argdecl))))))) + (if (or (eq decl-result 'label) + (looking-at c-protection-key)) + (setq brace-decl-p nil)) (cond ((or (eq decl-result 'label) ; e.g. "private:" or invalid syntax. @@ -1817,251 +1835,298 @@ the open-parenthesis that starts a defun; see `beginning-of-defun'." (c-keep-region-active) (= arg 0)))) -(defun c-defun-name () - "Return the name of the current defun, or NIL if there isn't one. -\"Defun\" here means a function, or other top level construct -with a brace block." +(defun c-defun-name-1 () + "Return the name of the current defun, at the current narrowing, +or NIL if there isn't one. \"Defun\" here means a function, or +other top level construct with a brace block." (c-save-buffer-state (beginning-of-defun-function end-of-defun-function - where pos name-end case-fold-search) + where pos decl name-start name-end case-fold-search) + + (save-excursion + ;; Move back out of any macro/comment/string we happen to be in. + (c-beginning-of-macro) + (setq pos (c-literal-start)) + (if pos (goto-char pos)) + + (setq where (c-where-wrt-brace-construct)) + + ;; Move to the beginning of the current defun, if any, if we're not + ;; already there. + (if (memq where '(outwith-function at-function-end)) + nil + (unless (eq where 'at-header) + (c-backward-to-nth-BOF-{ 1 where) + (c-beginning-of-decl-1)) + (when (looking-at c-typedef-key) + (goto-char (match-end 0)) + (c-forward-syntactic-ws)) + + ;; Pick out the defun name, according to the type of defun. + (cond + ;; struct, union, enum, or similar: + ((save-excursion + (and + (looking-at c-defun-type-name-decl-key) + (consp (c-forward-decl-or-cast-1 (c-point 'bosws) 'top nil)) + (or (not (or (eq (char-after) ?{) + (and c-recognize-knr-p + (c-in-knr-argdecl)))) + (progn (c-backward-syntactic-ws) + (not (eq (char-before) ?\))))))) + (let ((key-pos (point))) + (c-forward-over-token-and-ws) ; over "struct ". + (cond + ((looking-at c-symbol-key) ; "struct foo { ..." + (buffer-substring-no-properties key-pos (match-end 0))) + ((eq (char-after) ?{) ; "struct { ... } foo" + (when (c-go-list-forward) + (c-forward-syntactic-ws) + (when (looking-at c-symbol-key) ; a bit bogus - there might + ; be several identifiers. + (match-string-no-properties 0))))))) + + ((looking-at "DEFUN\\s-*(") ;"DEFUN\\_>") think of XEmacs! + ;; DEFUN ("file-name-directory", Ffile_name_directory, Sfile_name_directory, ...) ==> Ffile_name_directory + ;; DEFUN(POSIX::STREAM-LOCK, stream lockp &key BLOCK SHARED START LENGTH) ==> POSIX::STREAM-LOCK + (down-list 1) + (c-forward-syntactic-ws) + (when (eq (char-after) ?\") + (forward-sexp 1) + (c-forward-token-2)) ; over the comma and following WS. + (buffer-substring-no-properties + (point) + (progn + (c-forward-token-2) + (c-backward-syntactic-ws) + (point)))) + + (t + ;; Normal function or initializer. + (when + (and + (consp + (setq decl + (c-forward-decl-or-cast-1 (c-point 'bosws) 'top nil))) + (setq name-start (car decl)) + (progn (if (and (looking-at c-after-suffixed-type-decl-key) + (match-beginning 1)) + (c-forward-keyword-clause 1)) + t) + (or (eq (char-after) ?{) + (and c-recognize-knr-p + (c-in-knr-argdecl))) + (goto-char name-start) + (c-forward-name) + (eq (char-after) ?\()) + (c-backward-syntactic-ws) + (when (eq (char-before) ?\=) ; struct foo bar = {0, 0} ; + (c-backward-token-2) + (c-backward-syntactic-ws)) + (setq name-end (point)) + (c-back-over-compound-identifier) + (and (looking-at c-symbol-start) + (buffer-substring-no-properties (point) name-end))))))))) +(defun c-defun-name () + "Return the name of the current defun, or NIL if there isn't one. +\"Defun\" here means a function, or other top level construct +with a brace block, at the outermost level of nesting." + (c-save-buffer-state () (save-restriction (widen) - (save-excursion - ;; Move back out of any macro/comment/string we happen to be in. - (c-beginning-of-macro) - (setq pos (c-literal-start)) - (if pos (goto-char pos)) - - (setq where (c-where-wrt-brace-construct)) - - ;; Move to the beginning of the current defun, if any, if we're not - ;; already there. - (if (eq where 'outwith-function) - nil - (unless (eq where 'at-header) - (c-backward-to-nth-BOF-{ 1 where) - (c-beginning-of-decl-1)) - (when (looking-at c-typedef-key) - (goto-char (match-end 0)) - (c-forward-syntactic-ws)) - - ;; Pick out the defun name, according to the type of defun. - (cond - ;; struct, union, enum, or similar: - ((save-excursion - (and - (looking-at c-type-prefix-key) - (consp (c-forward-decl-or-cast-1 (c-point 'bosws) 'top nil)) - (or (not (or (eq (char-after) ?{) - (and c-recognize-knr-p - (c-in-knr-argdecl)))) - (progn (c-backward-syntactic-ws) - (not (eq (char-before) ?\))))))) - (let ((key-pos (point))) - (c-forward-over-token-and-ws) ; over "struct ". - (cond - ((looking-at c-symbol-key) ; "struct foo { ..." - (buffer-substring-no-properties key-pos (match-end 0))) - ((eq (char-after) ?{) ; "struct { ... } foo" - (when (c-go-list-forward) - (c-forward-syntactic-ws) - (when (looking-at c-symbol-key) ; a bit bogus - there might - ; be several identifiers. - (match-string-no-properties 0))))))) - - ((looking-at "DEFUN\\s-*(") ;"DEFUN\\_>") think of XEmacs! - ;; DEFUN ("file-name-directory", Ffile_name_directory, Sfile_name_directory, ...) ==> Ffile_name_directory - ;; DEFUN(POSIX::STREAM-LOCK, stream lockp &key BLOCK SHARED START LENGTH) ==> POSIX::STREAM-LOCK - (down-list 1) - (c-forward-syntactic-ws) - (when (eq (char-after) ?\") - (forward-sexp 1) - (c-forward-token-2)) ; over the comma and following WS. - (buffer-substring-no-properties - (point) - (progn - (c-forward-token-2) - (when (looking-at ":") ; CLISP: DEFUN(PACKAGE:LISP-SYMBOL,...) - (skip-chars-forward "^,")) - (c-backward-syntactic-ws) - (point)))) - - ((looking-at "DEF[a-zA-Z0-9_]* *( *\\([^, ]*\\) *,") - ;; DEFCHECKER(sysconf_arg,prefix=_SC,default=, ...) ==> sysconf_arg - ;; DEFFLAGSET(syslog_opt_flags,LOG_PID ...) ==> syslog_opt_flags - (match-string-no-properties 1)) - - ;; Objc selectors. - ((assq 'objc-method-intro (c-guess-basic-syntax)) - (let ((bound (save-excursion (c-end-of-statement) (point))) - (kw-re (concat "\\(?:" c-symbol-key "\\)?:")) - (stretches)) - (when (c-syntactic-re-search-forward c-symbol-key bound t t t) - (push (match-string-no-properties 0) stretches) - (while (c-syntactic-re-search-forward kw-re bound t t t) - (push (match-string-no-properties 0) stretches))) - (apply 'concat (nreverse stretches)))) - - (t - ;; Normal function or initializer. - (when - (and - (consp (c-forward-decl-or-cast-1 (c-point 'bosws) 'top nil)) - (or (eq (char-after) ?{) - (and c-recognize-knr-p - (c-in-knr-argdecl))) - (progn - (c-backward-syntactic-ws) - (eq (char-before) ?\))) - (c-go-list-backward)) - (c-backward-syntactic-ws) - (when (eq (char-before) ?\=) ; struct foo bar = {0, 0} ; - (c-backward-token-2) - (c-backward-syntactic-ws)) - (setq name-end (point)) - (c-back-over-compound-identifier) - (and (looking-at c-symbol-start) - (buffer-substring-no-properties (point) name-end)))))))))) + (c-defun-name-1)))) -(defun c-declaration-limits (near) - ;; Return a cons of the beginning and end positions of the current - ;; top level declaration or macro. If point is not inside any then - ;; nil is returned, unless NEAR is non-nil in which case the closest - ;; following one is chosen instead (if there is any). The end +(defun c-declaration-limits-1 (near) + ;; Return a cons of the beginning and end position of the current + ;; declaration or macro in the current narrowing. If there is no current + ;; declaration or macro, return nil, unless NEAR is non-nil, in which case + ;; the closest following one is chosen instead (if there is any). The end ;; position is at the next line, providing there is one before the ;; declaration. ;; ;; This function might do hidden buffer changes. (save-excursion - (save-restriction - (let ((start (point)) - (paren-state (c-parse-state)) - lim pos end-pos where) - ;; Narrow enclosing brace blocks out, as required by the values of - ;; `c-defun-tactic', `near', and the position of point. - (when (eq c-defun-tactic 'go-outward) - (let ((bounds - (save-restriction - (if (and (not (save-excursion (c-beginning-of-macro))) - (save-restriction - (c-narrow-to-most-enclosing-decl-block) - (memq (c-where-wrt-brace-construct) - '(at-function-end outwith-function))) - (not near)) - (c-narrow-to-most-enclosing-decl-block nil 2) - (c-narrow-to-most-enclosing-decl-block)) - (cons (point-min) (point-max))))) - (narrow-to-region (car bounds) (cdr bounds)))) - (setq paren-state (c-parse-state)) - - (or - ;; Note: Some code duplication in `c-beginning-of-defun' and - ;; `c-end-of-defun'. - (catch 'exit - (unless (c-safe - (goto-char (c-least-enclosing-brace paren-state)) - ;; If we moved to the outermost enclosing paren - ;; then we can use c-safe-position to set the - ;; limit. Can't do that otherwise since the - ;; earlier paren pair on paren-state might very - ;; well be part of the declaration we should go - ;; to. - (setq lim (c-safe-position (point) paren-state)) - t) - ;; At top level. Make sure we aren't inside a literal. - (setq pos (c-literal-start - (c-safe-position (point) paren-state))) - (if pos (goto-char pos))) - - (when (c-beginning-of-macro) + (let ((start (point)) + (paren-state (c-parse-state)) + lim pos end-pos where) + (or + ;; Note: Some code duplication in `c-beginning-of-defun' and + ;; `c-end-of-defun'. + (catch 'exit + (unless (c-safe + (goto-char (c-least-enclosing-brace paren-state)) + ;; If we moved to the outermost enclosing paren + ;; then we can use c-safe-position to set the + ;; limit. Can't do that otherwise since the + ;; earlier paren pair on paren-state might very + ;; well be part of the declaration we should go + ;; to. + (setq lim (c-safe-position (point) paren-state)) + ;; We might have a struct foo {...} as the type of the + ;; function, so set LIM back one further block. + (if (eq (char-before lim) ?}) + (setq lim + (or + (save-excursion + (and + (c-go-list-backward lim) + (let ((paren-state-1 (c-parse-state))) + (c-safe-position + (point) paren-state-1)))) + (point-min)))) + t) + ;; At top level. Make sure we aren't inside a literal. + (setq pos (c-literal-start + (c-safe-position (point) paren-state))) + (if pos (goto-char pos))) + + (when (c-beginning-of-macro) + (throw 'exit + (cons (point) + (save-excursion + (c-end-of-macro) + (forward-line 1) + (point))))) + + (setq pos (point)) + (setq where (and (not (save-excursion (c-beginning-of-macro))) + (c-where-wrt-brace-construct))) + (when (and (not (eq where 'at-header)) + (or (and near + (memq where + '(at-function-end outwith-function)) + ;; Check we're not inside a declaration without + ;; braces. + (save-excursion + (memq (car (c-beginning-of-decl-1 lim)) + '(previous label)))) + (eq (car (c-beginning-of-decl-1 lim)) 'previous) + (= pos (point)))) + ;; We moved back over the previous defun. Skip to the next + ;; one. Not using c-forward-syntactic-ws here since we + ;; should not skip a macro. We can also be directly after + ;; the block in a `c-opt-block-decls-with-vars-key' + ;; declaration, but then we won't move significantly far + ;; here. + (goto-char pos) + (c-forward-comments) + + (when (and near (c-beginning-of-macro)) (throw 'exit (cons (point) (save-excursion (c-end-of-macro) (forward-line 1) - (point))))) + (point)))))) - (setq pos (point)) - (setq where (and (not (save-excursion (c-beginning-of-macro))) - (c-where-wrt-brace-construct))) - (when (and (not (eq where 'at-header)) - (or (and near - (memq where - '(at-function-end outwith-function))) - (eq (car (c-beginning-of-decl-1 lim)) 'previous) - (= pos (point)))) - ;; We moved back over the previous defun. Skip to the next - ;; one. Not using c-forward-syntactic-ws here since we - ;; should not skip a macro. We can also be directly after - ;; the block in a `c-opt-block-decls-with-vars-key' - ;; declaration, but then we won't move significantly far - ;; here. - (goto-char pos) - (c-forward-comments) - - (when (and near (c-beginning-of-macro)) - (throw 'exit - (cons (point) - (save-excursion - (c-end-of-macro) - (forward-line 1) - (point)))))) + (if (eobp) (throw 'exit nil)) - (if (eobp) (throw 'exit nil)) + ;; Check if `c-beginning-of-decl-1' put us after the block in a + ;; declaration that doesn't end there. We're searching back and + ;; forth over the block here, which can be expensive. + (setq pos (point)) + (if (and c-opt-block-decls-with-vars-key + (progn + (c-backward-syntactic-ws) + (eq (char-before) ?})) + (eq (car (c-beginning-of-decl-1)) + 'previous) + (save-excursion + (c-end-of-decl-1) + (and (> (point) pos) + (setq end-pos (point))))) + nil + (goto-char pos)) + + (if (or (and (not near) (> (point) start)) + (not (eq (c-where-wrt-brace-construct) 'at-header))) + nil + + ;; Try to be line oriented; position the limits at the + ;; closest preceding boi, and after the next newline, that + ;; isn't inside a comment, but if we hit a neighboring + ;; declaration then we instead use the exact declaration + ;; limit in that direction. + (cons (progn + (setq pos (point)) + (while (and (/= (point) (c-point 'boi)) + (c-backward-single-comment))) + (if (/= (point) (c-point 'boi)) + pos + (point))) + (progn + (if end-pos + (goto-char end-pos) + (c-end-of-decl-1)) + (setq pos (point)) + (while (and (not (bolp)) + (not (looking-at "\\s *$")) + (c-forward-single-comment))) + (cond ((bolp) + (point)) + ((looking-at "\\s *$") + (forward-line 1) + (point)) + (t + pos)))))) + (and (not near) + (goto-char (point-min)) + (c-forward-decl-or-cast-1 -1 nil nil) + (eq (char-after) ?\{) + (cons (point-min) (point-max))))))) - ;; Check if `c-beginning-of-decl-1' put us after the block in a - ;; declaration that doesn't end there. We're searching back and - ;; forth over the block here, which can be expensive. - (setq pos (point)) - (if (and c-opt-block-decls-with-vars-key - (progn - (c-backward-syntactic-ws) - (eq (char-before) ?})) - (eq (car (c-beginning-of-decl-1)) - 'previous) - (save-excursion - (c-end-of-decl-1) - (and (> (point) pos) - (setq end-pos (point))))) - nil - (goto-char pos)) - - (if (and (not near) (> (point) start)) - nil - - ;; Try to be line oriented; position the limits at the - ;; closest preceding boi, and after the next newline, that - ;; isn't inside a comment, but if we hit a neighboring - ;; declaration then we instead use the exact declaration - ;; limit in that direction. - (cons (progn - (setq pos (point)) - (while (and (/= (point) (c-point 'boi)) - (c-backward-single-comment))) - (if (/= (point) (c-point 'boi)) - pos - (point))) - (progn - (if end-pos - (goto-char end-pos) - (c-end-of-decl-1)) - (setq pos (point)) - (while (and (not (bolp)) - (not (looking-at "\\s *$")) - (c-forward-single-comment))) - (cond ((bolp) - (point)) - ((looking-at "\\s *$") - (forward-line 1) - (point)) - (t - pos)))))) - (and (not near) - (goto-char (point-min)) - (c-forward-decl-or-cast-1 -1 nil nil) - (eq (char-after) ?\{) - (cons (point-min) (point-max)))))))) +(defun c-declaration-limits (near) + ;; Return a cons of the beginning and end positions of the current + ;; top level declaration or macro. If point is not inside any then + ;; nil is returned, unless NEAR is non-nil in which case the closest + ;; following one is chosen instead (if there is any). The end + ;; position is at the next line, providing there is one before the + ;; declaration. + ;; + ;; This function might do hidden buffer changes. + (save-restriction + ;; Narrow enclosing brace blocks out, as required by the values of + ;; `c-defun-tactic', `near', and the position of point. + (when (eq c-defun-tactic 'go-outward) + (let ((bounds + (save-restriction + (if (and (not (save-excursion (c-beginning-of-macro))) + (save-restriction + (c-narrow-to-most-enclosing-decl-block) + (memq (c-where-wrt-brace-construct) + '(at-function-end outwith-function))) + (not near)) + (c-narrow-to-most-enclosing-decl-block nil 2) + (c-narrow-to-most-enclosing-decl-block)) + (cons (point-min) (point-max))))) + (narrow-to-region (car bounds) (cdr bounds)))) + (c-declaration-limits-1 near))) + +(defun c-defun-name-and-limits (near) + ;; Return a cons of the name and limits (itself a cons) of the current + ;; top-level declaration or macro, or nil of there is none. + ;; + ;; If `c-defun-tactic' is 'go-outward, we return the name and limits of the + ;; most tightly enclosing declaration or macro. Otherwise, we return that + ;; at the file level. + (save-restriction + (widen) + (if (eq c-defun-tactic 'go-outward) + (c-save-buffer-state ((paren-state (c-parse-state)) + (orig-point-min (point-min)) + (orig-point-max (point-max)) + lim name where limits fdoc) + (setq lim (c-widen-to-enclosing-decl-scope + paren-state orig-point-min orig-point-max)) + (and lim (setq lim (1- lim))) + (c-while-widening-to-decl-block (not (setq name (c-defun-name-1)))) + (when name + (setq limits (c-declaration-limits-1 near)) + (cons name limits))) + (c-save-buffer-state ((name (c-defun-name)) + (limits (c-declaration-limits near))) + (and name limits (cons name limits)))))) (defun c-display-defun-name (&optional arg) "Display the name of the current CC mode defun and the position in it. @@ -2069,12 +2134,13 @@ With a prefix arg, push the name onto the kill ring too." (interactive "P") (save-restriction (widen) - (c-save-buffer-state ((name (c-defun-name)) - (limits (c-declaration-limits t)) + (c-save-buffer-state ((name-and-limits (c-defun-name-and-limits nil)) + (name (car name-and-limits)) + (limits (cdr name-and-limits)) (point-bol (c-point 'bol))) (when name (message "%s. Line %s/%s." name - (1+ (count-lines (car limits) point-bol)) + (1+ (count-lines (car limits) (max point-bol (car limits)))) (count-lines (car limits) (cdr limits))) (if arg (kill-new name)) (sit-for 3 t))))) diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index b78e85a670..ceeee6b357 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -1124,7 +1124,16 @@ comment at the start of cc-engine.el for more info." (not (c-looking-at-inexpr-block lim nil t)) (save-excursion (c-backward-token-2 1 t nil) - (not (looking-at "=\\([^=]\\|$\\)")))) + (not (looking-at "=\\([^=]\\|$\\)"))) + (or + (not c-opt-block-decls-with-vars-key) + (save-excursion + (c-backward-token-2 1 t nil) + (if (and (looking-at c-symbol-start) + (not (looking-at c-keywords-regexp))) + (c-backward-token-2 1 t nil)) + (not (looking-at + c-opt-block-decls-with-vars-key))))) (save-excursion (c-forward-sexp) (point))) ;; Just gone back over some paren block? diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el index c06dd2164d..f1ef89a76a 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el @@ -2107,6 +2107,18 @@ will be handled." "Alist associating keywords in c-other-decl-block-decl-kwds with their matching \"in\" syntactic symbols.") +(c-lang-defconst c-defun-type-name-decl-kwds + "Keywords introducing a named block, where the name is a \"defun\" + name." + t (append (c-lang-const c-class-decl-kwds) + (c-lang-const c-brace-list-decl-kwds))) + +(c-lang-defconst c-defun-type-name-decl-key + ;; Regexp matching a keyword in `c-defun-name-decl-kwds'. + t (c-make-keywords-re t (c-lang-const c-defun-type-name-decl-kwds))) +(c-lang-defvar c-defun-type-name-decl-key + (c-lang-const c-defun-type-name-decl-key)) + (c-lang-defconst c-typedef-decl-kwds "Keywords introducing declarations where the identifier(s) being declared are types. commit 36c8128e740ce91af10769bef46a21a72dafc56c Author: Noam Postavsky Date: Tue Jan 23 18:50:23 2018 -0500 Fix round tripping of read->print for symbols with strange quotes Since 2017-07-22 "Signal error for symbol names with strange quotes (Bug#2967)", symbol names beginning with certain quote characters require an escaping backslash. However, the corresponding change for printing missed, so that (eq (read (prin1-to-string SYM)) SYM) does not give `t' for such symbols. * src/character.c (confusable_symbol_character_p): New function, extracted from test `read1'. * src/lread.c (read1): Use it. * src/print.c (print_object): Use it to print a backslash for symbols starting with characters that `read1' requires to be escaped. * test/src/print-tests.el (print-read-roundtrip): New test. * etc/NEWS.26: * etc/NEWS: Clarify the announcement for the earlier reader change (Bug#30217). diff --git a/etc/NEWS b/etc/NEWS index 2888acd4dc..80ddf10488 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -229,6 +229,15 @@ as new-style, bind the new variable 'force-new-style-backquotes' to t. ** 'print-quoted' now defaults to t, so if you want to see (quote x) instead of 'x you will have to bind it to nil where applicable. +** To avoid confusion caused by "smart quotes", the reader signals an +error when reading Lisp symbols which begin with one of the following +quotation characters: ‘’‛“”‟〞＂＇. A symbol beginning with such a +character can be written by escaping the quotation character with a +backslash. For example: + + (read "‘smart") => (invalid-read-syntax "strange quote" "‘") + (read "\\‘smart") == (intern "‘smart") + ** Internal parsing commands now use syntax-ppss and disregard open-paren-in-column-0-is-defun-start. This affects mostly things like forward-comment, scan-sexps, and forward-sexp when parsing backward. diff --git a/etc/NEWS.26 b/etc/NEWS.26 index 46762d65e1..76e6316ca2 100644 --- a/etc/NEWS.26 +++ b/etc/NEWS.26 @@ -1377,11 +1377,6 @@ second argument instead of its first. renamed to 'lread--old-style-backquotes'. No user code should use this variable. ---- -** To avoid confusion caused by "smart quotes", the reader no longer -accepts Lisp symbols which begin with the following quotation -characters: ‘’‛“”‟〞＂＇, unless they are escaped with backslash. - +++ ** 'default-file-name-coding-system' now defaults to a coding system that does not process CRLF. For example, it defaults to 'utf-8-unix' diff --git a/src/character.c b/src/character.c index fa817a5031..4a934c7801 100644 --- a/src/character.c +++ b/src/character.c @@ -1050,6 +1050,32 @@ blankp (int c) return XINT (category) == UNICODE_CATEGORY_Zs; /* separator, space */ } + +/* Return true for characters that would read as symbol characters, + but graphically may be confused with some kind of punctuation. We + require an escaping backslash, when such characters begin a + symbol. */ +bool +confusable_symbol_character_p (int ch) +{ + switch (ch) + { + case 0x2018: /* LEFT SINGLE QUOTATION MARK */ + case 0x2019: /* RIGHT SINGLE QUOTATION MARK */ + case 0x201B: /* SINGLE HIGH-REVERSED-9 QUOTATION MARK */ + case 0x201C: /* LEFT DOUBLE QUOTATION MARK */ + case 0x201D: /* RIGHT DOUBLE QUOTATION MARK */ + case 0x201F: /* DOUBLE HIGH-REVERSED-9 QUOTATION MARK */ + case 0x301E: /* DOUBLE PRIME QUOTATION MARK */ + case 0xFF02: /* FULLWIDTH QUOTATION MARK */ + case 0xFF07: /* FULLWIDTH APOSTROPHE */ + return true; + + default: + return false; + } +} + signed char HEXDIGIT_CONST hexdigit[UCHAR_MAX + 1] = { #if HEXDIGIT_IS_CONST diff --git a/src/character.h b/src/character.h index c716885d46..d9e2d7bfc6 100644 --- a/src/character.h +++ b/src/character.h @@ -682,6 +682,8 @@ extern bool graphicp (int); extern bool printablep (int); extern bool blankp (int); +extern bool confusable_symbol_character_p (int ch); + /* Return a translation table of id number ID. */ #define GET_TRANSLATION_TABLE(id) \ (XCDR (XVECTOR (Vtranslation_table_vector)->contents[(id)])) diff --git a/src/lread.c b/src/lread.c index 28d4bf9a4f..3b0a17c90b 100644 --- a/src/lread.c +++ b/src/lread.c @@ -3473,20 +3473,9 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (!quoted && multibyte) { int ch = STRING_CHAR ((unsigned char *) read_buffer); - switch (ch) - { - case 0x2018: /* LEFT SINGLE QUOTATION MARK */ - case 0x2019: /* RIGHT SINGLE QUOTATION MARK */ - case 0x201B: /* SINGLE HIGH-REVERSED-9 QUOTATION MARK */ - case 0x201C: /* LEFT DOUBLE QUOTATION MARK */ - case 0x201D: /* RIGHT DOUBLE QUOTATION MARK */ - case 0x201F: /* DOUBLE HIGH-REVERSED-9 QUOTATION MARK */ - case 0x301E: /* DOUBLE PRIME QUOTATION MARK */ - case 0xFF02: /* FULLWIDTH QUOTATION MARK */ - case 0xFF07: /* FULLWIDTH APOSTROPHE */ - xsignal2 (Qinvalid_read_syntax, build_string ("strange quote"), - CALLN (Fstring, make_number (ch))); - } + if (confusable_symbol_character_p (ch)) + xsignal2 (Qinvalid_read_syntax, build_string ("strange quote"), + CALLN (Fstring, make_number (ch))); } { Lisp_Object result; diff --git a/src/print.c b/src/print.c index 0e1980d84b..7157967324 100644 --- a/src/print.c +++ b/src/print.c @@ -1971,7 +1971,8 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) || c == ';' || c == '#' || c == '(' || c == ')' || c == ',' || c == '.' || c == '`' || c == '[' || c == ']' || c == '?' || c <= 040 - || confusing) + || confusing + || (i == 1 && confusable_symbol_character_p (c))) { printchar ('\\', printcharfun); confusing = false; diff --git a/test/src/print-tests.el b/test/src/print-tests.el index 46368c69ad..01e65028bc 100644 --- a/test/src/print-tests.el +++ b/test/src/print-tests.el @@ -58,5 +58,9 @@ (buffer-string)) "--------\n")))) +(ert-deftest print-read-roundtrip () + (let ((sym '\’bar)) + (should (eq (read (prin1-to-string sym)) sym)))) + (provide 'print-tests) ;;; print-tests.el ends here commit 69a30e8b87fac5888daa26c63663351570e3d533 Author: Simen Heggestøyl Date: Sun Jan 28 15:35:46 2018 +0100 Shorten CSS hex colors when possible * lisp/textmodes/css-mode.el (css--format-hex): New function for shortening CSS hex colors when possible. (css--named-color-to-hex, css--rgb-to-named-color-or-hex): Use it. * test/lisp/textmodes/css-mode-tests.el (css-test-format-hex): New tests for 'css--format-hex'. (css-test-named-color-to-hex, css-test-cycle-color-format): Adjust for the changes to 'css--named-color-to-hex' and 'css--rgb-to-named-color-or-hex'. diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index 135c0d5f92..55c21f8acb 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -1413,6 +1413,15 @@ should not be mixed with those in color.el." (apply-partially #'make-list (if six-digits 2 4)) (seq-partition (seq-drop hex 1) (if six-digits 2 1))))))) +(defun css--format-hex (hex) + "Format a CSS hex color by shortening it if possible." + (let ((parts (seq-partition (seq-drop hex 1) 2))) + (if (and (>= (length hex) 6) + (seq-every-p (lambda (p) (eq (elt p 0) (elt p 1))) parts)) + (apply #'string + (cons ?# (mapcar (lambda (p) (elt p 0)) parts))) + hex))) + (defun css--named-color-to-hex () "Convert named CSS color at point to hex format. Return non-nil if a conversion was made. @@ -1426,7 +1435,7 @@ should not be mixed with those in color.el." (when (member (word-at-point) (mapcar #'car css--color-map)) (looking-at css--colors-regexp) (let ((color (css--compute-color (point) (match-string 0)))) - (replace-match color)) + (replace-match (css--format-hex color))) t))) (defun css--format-rgba-alpha (alpha) @@ -1490,7 +1499,9 @@ should not be mixed with those in color.el." (kill-sexp) (let ((named-color (seq-find (lambda (x) (equal (cdr x) color)) css--color-map))) - (insert (if named-color (car named-color) color))) + (insert (if named-color + (car named-color) + (css--format-hex color)))) t))))) (defun css-cycle-color-format () diff --git a/test/lisp/textmodes/css-mode-tests.el b/test/lisp/textmodes/css-mode-tests.el index 4883123843..a8ce994416 100644 --- a/test/lisp/textmodes/css-mode-tests.el +++ b/test/lisp/textmodes/css-mode-tests.el @@ -254,9 +254,18 @@ (should (equal (css--color-to-4-dpc "#fafbfc") "#fafafbfbfcfc"))) +(ert-deftest css-test-format-hex () + (should (equal (css--format-hex "#fff") "#fff")) + (should (equal (css--format-hex "#ffffff") "#fff")) + (should (equal (css--format-hex "#aabbcc") "#abc")) + (should (equal (css--format-hex "#12ff34") "#12ff34")) + (should (equal (css--format-hex "#aabbccdd") "#abcd")) + (should (equal (css--format-hex "#aabbccde") "#aabbccde")) + (should (equal (css--format-hex "#abcdef") "#abcdef"))) + (ert-deftest css-test-named-color-to-hex () - (dolist (item '(("black" "#000000") - ("white" "#ffffff") + (dolist (item '(("black" "#000") + ("white" "#fff") ("salmon" "#fa8072"))) (with-temp-buffer (css-mode) @@ -309,7 +318,7 @@ (css-mode) (insert "black") (css-cycle-color-format) - (should (equal (buffer-string) "#000000")) + (should (equal (buffer-string) "#000")) (css-cycle-color-format) (should (equal (buffer-string) "rgb(0, 0, 0)")) (css-cycle-color-format) commit 97defdfc36d9a83a3081c5f76e249f908645f7ec Author: Simen Heggestøyl Date: Sun Jan 28 13:03:05 2018 +0100 Fix off-by-one error in 'css--hex-to-rgb' * lisp/textmodes/css-mode.el (css--hex-to-rgb): Fix off-by-one error. * test/lisp/textmodes/css-mode-tests.el (css-test-hex-to-rgb): Add regression tests for the above fix. diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index 6bd08f5919..135c0d5f92 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -1458,7 +1458,7 @@ should not be mixed with those in color.el." (if-let* ((alpha (css--hex-alpha hex)) (a (css--format-rgba-alpha (/ (string-to-number alpha 16) - (float (expt 16 (length alpha))))))) + (float (- (expt 16 (length alpha)) 1)))))) (format "rgba(%d, %d, %d, %s)" r g b a) (format "rgb(%d, %d, %d)" r g b)) t)) diff --git a/test/lisp/textmodes/css-mode-tests.el b/test/lisp/textmodes/css-mode-tests.el index 272d281217..4883123843 100644 --- a/test/lisp/textmodes/css-mode-tests.el +++ b/test/lisp/textmodes/css-mode-tests.el @@ -281,7 +281,9 @@ ("#fff" "rgb(255, 255, 255)") ("#ffffff" "rgb(255, 255, 255)") ("#ffffff80" "rgba(255, 255, 255, 0.5)") - ("#fff8" "rgba(255, 255, 255, 0.5)"))) + ("#fff0" "rgba(255, 255, 255, 0)") + ("#fff8" "rgba(255, 255, 255, 0.53)") + ("#ffff" "rgba(255, 255, 255, 1)"))) (with-temp-buffer (css-mode) (insert (nth 0 item))