commit 5ee56c4613e9380dbbe4bbaa97b29dd377e2134c (HEAD, refs/remotes/origin/master) Author: Eli Zaretskii Date: Sat Sep 24 18:10:42 2016 +0300 Fix 'dired-mark-extension' with prefix argument * lisp/dired-x.el (dired-mark-extension): Allow to specify MARKER-CHAR interactively as a string, not as a character's codepoint. (Bug#24518) * doc/misc/dired-x.texi (Advanced Mark Commands): Document the behavior when invoked with a prefix arg. diff --git a/doc/misc/dired-x.texi b/doc/misc/dired-x.texi index 474dd0a..2391852 100644 --- a/doc/misc/dired-x.texi +++ b/doc/misc/dired-x.texi @@ -710,7 +710,8 @@ variable @code{window-min-height}. @findex dired-mark-extension Mark all files with a certain extension for use in later commands. A @samp{.} is not automatically prepended to the string entered, you must type it -explicitly. +explicitly. If invoked with a prefix argument, this command asks for +a character to use as the marker. When called from Lisp, @var{extension} may also be a list of extensions and an optional argument @var{marker-char} specifies the marker used. diff --git a/lisp/dired-x.el b/lisp/dired-x.el index 41c2256..7d73c42 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -333,8 +333,18 @@ See also the functions: "Mark all files with a certain EXTENSION for use in later commands. A `.' is *not* automatically prepended to the string entered. EXTENSION may also be a list of extensions instead of a single one. -Optional MARKER-CHAR is marker to use." - (interactive "sMarking extension: \nP") +Optional MARKER-CHAR is marker to use. +Interactively, ask for EXTENSION, and if invoked with a prefix +argument, for MARKER-CHAR as well." + (interactive + (list (read-string "Marking extension: ") + (and current-prefix-arg + (let* ((dflt (char-to-string dired-marker-char)) + (input (read-string + (format + "Marker character to use (default %s): " dflt) + nil nil dflt))) + (aref input 0))))) (or (listp extension) (setq extension (list extension))) (dired-mark-files-regexp commit 6ddcb0f10fb2b3c6c6a31733b28f7fbb30637ac2 Author: Simen Heggestøyl Date: Sat Sep 24 13:55:36 2016 +0200 Support completion of classes and IDs in CSS mode * lisp/textmodes/css-mode.el (css-class-list-function): New variable holding the function to call for retrieving completions of class names. (css-id-list-function): New variable holding the function to call for retrieving completions of IDs. (css--foreign-completions): New function for retrieving completions from other buffers. (css--complete-selector): Support completing HTML class names and IDs from other buffers in addition to completing HTML tags. * lisp/textmodes/sgml-mode.el (html--buffer-classes-cache): New variable holding a cache for `html-current-buffer-classes'. (html--buffer-ids-cache): New variable holding a cache for `html-current-buffer-ids'. (html-current-buffer-classes): New function returning a list of class names used in the current buffer. (html-current-buffer-ids): New function returning a list of IDs used in the current buffer. (html-mode): Set `css-class-list-function' and `css-id-list-function' to `html-current-buffer-classes' and `html-current-buffer-ids' respectively. diff --git a/etc/NEWS b/etc/NEWS index 3149d91..c3f4cf0 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -392,8 +392,10 @@ enables reading of shell initialization files. ** CSS mode --- -*** Support for completing attribute values, at-rules, bang-rules, and -HTML tags using the 'completion-at-point' command. +*** Support for completing attribute values, at-rules, bang-rules, +HTML tags, classes and IDs using the 'completion-at-point' command. +Completion candidates for HTML classes and IDs are retrieved from open +HTML mode buffers. +++ ** Emacs now supports character name escape sequences in character and diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index 4d8170e..53b3fa5 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -30,7 +30,6 @@ ;; - electric ; and } ;; - filling code with auto-fill-mode ;; - fix font-lock errors with multi-line selectors -;; - support completion of user-defined classes names and IDs ;;; Code: @@ -864,16 +863,46 @@ Used to provide completion of HTML tags in selectors.") "Non-nil if nested selectors are allowed in the current mode.") (make-variable-buffer-local 'css--nested-selectors-allowed) -;; TODO: Currently only supports completion of HTML tags. By looking -;; at open HTML mode buffers we should be able to provide completion -;; of user-defined classes and IDs too. +(defvar css-class-list-function #'ignore + "Called to provide completions of class names. +This can be bound by buffers that are able to suggest class name +completions, such as HTML mode buffers.") + +(defvar css-id-list-function #'ignore + "Called to provide completions of IDs. +This can be bound by buffers that are able to suggest ID +completions, such as HTML mode buffers.") + +(defun css--foreign-completions (extractor) + "Return a list of completions provided by other buffers. +EXTRACTOR should be the name of a function that may be defined in +one or more buffers. In each of the buffers where EXTRACTOR is +defined, EXTRACTOR is called and the results are accumulated into +a list of completions." + (delete-dups + (seq-mapcat + (lambda (buf) + (with-current-buffer buf + (funcall (symbol-value extractor)))) + (buffer-list)))) + (defun css--complete-selector () "Complete part of a CSS selector at point." (when (or (= (nth 0 (syntax-ppss)) 0) css--nested-selectors-allowed) - (save-excursion - (let ((end (point))) + (let ((end (point))) + (save-excursion (skip-chars-backward "-[:alnum:]") - (list (point) end css--html-tags))))) + (let ((start-char (char-before))) + (list + (point) end + (completion-table-dynamic + (lambda (_) + (cond + ((eq start-char ?.) + (css--foreign-completions 'css-class-list-function)) + ((eq start-char ?#) + (css--foreign-completions 'css-id-list-function)) + (t css--html-tags)))))))))) (defun css-completion-at-point () "Complete current symbol at point. diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el index 990c09b..43effef 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -32,6 +32,9 @@ ;;; Code: +(require 'dom) +(require 'seq) +(require 'subr-x) (eval-when-compile (require 'skeleton) (require 'cl-lib)) @@ -2168,6 +2171,55 @@ This takes effect when first loading the library.") nil t) (match-string-no-properties 1)))) +(defvar html--buffer-classes-cache nil + "Cache for `html-current-buffer-classes'. +When set, this should be a cons cell where the CAR is the +buffer's tick counter (as produced by `buffer-modified-tick'), +and the CDR is the list of class names found in the buffer.") +(make-variable-buffer-local 'html--buffer-classes-cache) + +(defvar html--buffer-ids-cache nil + "Cache for `html-current-buffer-ids'. +When set, this should be a cons cell where the CAR is the +buffer's tick counter (as produced by `buffer-modified-tick'), +and the CDR is the list of class names found in the buffer.") +(make-variable-buffer-local 'html--buffer-ids-cache) + +(defun html-current-buffer-classes () + "Return a list of class names used in the current buffer. +The result is cached in `html--buffer-classes-cache'." + (let ((tick (buffer-modified-tick))) + (if (eq (car html--buffer-classes-cache) tick) + (cdr html--buffer-classes-cache) + (let* ((dom (libxml-parse-html-region (point-min) (point-max))) + (classes + (seq-mapcat + (lambda (el) + (when-let (class-list + (cdr (assq 'class (dom-attributes el)))) + (split-string class-list))) + (dom-by-class dom "")))) + (setq-local html--buffer-classes-cache (cons tick classes)) + classes)))) + +(defun html-current-buffer-ids () + "Return a list of IDs used in the current buffer. +The result is cached in `html--buffer-ids-cache'." + (let ((tick (buffer-modified-tick))) + (if (eq (car html--buffer-ids-cache) tick) + (cdr html--buffer-ids-cache) + (let* ((dom + (libxml-parse-html-region (point-min) (point-max))) + (ids + (seq-mapcat + (lambda (el) + (when-let (id-list + (cdr (assq 'id (dom-attributes el)))) + (split-string id-list))) + (dom-by-id dom "")))) + (setq-local html--buffer-ids-cache (cons tick ids)) + ids)))) + ;;;###autoload (define-derived-mode html-mode sgml-mode '(sgml-xml-mode "XHTML" "HTML") @@ -2218,6 +2270,12 @@ To work around that, do: (setq-local add-log-current-defun-function #'html-current-defun-name) (setq-local sentence-end-base "[.?!][]\"'”)}]*\\(<[^>]*>\\)*") + (when (fboundp 'libxml-parse-html-region) + (defvar css-class-list-function) + (setq-local css-class-list-function #'html-current-buffer-classes) + (defvar css-id-list-function) + (setq-local css-id-list-function #'html-current-buffer-ids)) + (setq imenu-create-index-function 'html-imenu-index) (setq-local sgml-empty-tags commit 05ed68a25d3c81cc20314c42a43aeb23d6c2d8f1 Author: Eli Zaretskii Date: Sat Sep 24 13:32:44 2016 +0300 Update test suite files due to removal of test/lisp/legacy * test/README: Reference file-organization.org. * test/file-organization.org: Remove the description of files in the lisp/legacy/ directory. diff --git a/test/README b/test/README index 2994fca..fec84a8 100644 --- a/test/README +++ b/test/README @@ -4,6 +4,9 @@ See the end of the file for license conditions. This directory contains files intended to test various aspects of Emacs's functionality. Please help add tests! +See the file file-organization.org for the details of the directory +structure and file-naming conventions. + Emacs uses ERT, Emacs Lisp Regression Testing, for testing. See (info "(ert)") or https://www.gnu.org/software/emacs/manual/html_node/ert/ for more information on writing and running tests. diff --git a/test/file-organization.org b/test/file-organization.org index 226e12d..dba5f4f 100644 --- a/test/file-organization.org +++ b/test/file-organization.org @@ -36,9 +36,6 @@ appended, such as ~/test/lisp/emacs-lisp/eieio-tests~ Where features of the C source are tested using Emacs-Lisp test files, these should reside in ~/test/src~ and be named after the C file. -A few test suites which predate this scheme and do not fit cleanly -into it are placed in ~/test/lisp/legacy~. - There are also some test materials that cannot be run automatically (i.e. via ert). These should be placed in ~/test/manual~ commit 05c98ddec73ef5800ea6e29995960100a3fb4eb6 Author: Eli Zaretskii Date: Sat Sep 24 13:27:57 2016 +0300 ; * test/src/undo-tests.el: Moved from test/lisp/legacy/. diff --git a/test/lisp/legacy/undo-tests.el b/test/src/undo-tests.el similarity index 100% rename from test/lisp/legacy/undo-tests.el rename to test/src/undo-tests.el commit fac0426fb3dee125e80cf849713990d966f02a97 Author: Eli Zaretskii Date: Sat Sep 24 13:25:04 2016 +0300 ; * test/src/textprop-tests.el: Minor copyedits. diff --git a/test/src/textprop-tests.el b/test/src/textprop-tests.el index 397ef28..ceb48d1 100644 --- a/test/src/textprop-tests.el +++ b/test/src/textprop-tests.el @@ -67,3 +67,6 @@ ;; (message "%S" (car stack)) (should (and (equal-including-properties (pop stack) string) (null stack))))) + +(provide 'textprop-tests) +;; textprop-tests.el ends here. commit 0123d567384fd69c137fcecc181dbb5a65e043b4 Author: Eli Zaretskii Date: Sat Sep 24 13:23:20 2016 +0300 ; * Move test/lisp/legacy/textprop-tests.el to test/src/. diff --git a/test/lisp/legacy/textprop-tests.el b/test/src/textprop-tests.el similarity index 100% rename from test/lisp/legacy/textprop-tests.el rename to test/src/textprop-tests.el commit 7f287b7f780849ca32cddaf69dac83a435f92300 Author: Eli Zaretskii Date: Sat Sep 24 13:20:19 2016 +0300 Incorporate syntax-tests in lisp-tests. * test/lisp/emacs-lisp/lisp-tests.el: Add tests from test/lisp/legacy/syntax-tests.el. * test/lisp/legacy/syntax-tests.el: File deleted. diff --git a/test/lisp/emacs-lisp/lisp-tests.el b/test/lisp/emacs-lisp/lisp-tests.el index d83f4a0..2dadae9 100644 --- a/test/lisp/emacs-lisp/lisp-tests.el +++ b/test/lisp/emacs-lisp/lisp-tests.el @@ -4,6 +4,7 @@ ;; Author: Aaron S. Hawley ;; Author: Stefan Monnier +;; Author: Daniel Colascione ;; Keywords: internal ;; GNU Emacs is free software: you can redistribute it and/or modify @@ -27,6 +28,7 @@ (require 'ert) (require 'python) +(require 'cl-lib) (ert-deftest lisp-forward-sexp-1-empty-parens () "Test basics of \\[forward-sexp]." @@ -233,8 +235,73 @@ (ert-deftest core-elisp-tests-3-backquote () (should (eq 3 (eval ``,,'(+ 1 2))))) -(provide 'core-elisp-tests) -;;; core-elisp-tests.el ends here +;; Test up-list and backward-up-list. +(defun lisp-run-up-list-test (fn data start instructions) + (cl-labels ((posof (thing) + (and (symbolp thing) + (= (length (symbol-name thing)) 1) + (- (aref (symbol-name thing) 0) ?a -1)))) + (with-temp-buffer + (set-syntax-table (make-syntax-table)) + ;; Use a syntax table in which single quote is a string + ;; character so that we can embed the test data in a lisp string + ;; literal. + (modify-syntax-entry ?\' "\"") + (insert data) + (goto-char (posof start)) + (dolist (instruction instructions) + (cond ((posof instruction) + (funcall fn) + (should (eql (point) (posof instruction)))) + ((symbolp instruction) + (should-error (funcall fn) + :type instruction)) + (t (cl-assert nil nil "unknown ins"))))))) + +(defmacro define-lisp-up-list-test (name fn data start &rest expected) + `(ert-deftest ,name () + (lisp-run-up-list-test ,fn ,data ',start ',expected))) + +(define-lisp-up-list-test up-list-basic + (lambda () (up-list)) + (or "(1 1 (1 1) 1 (1 1) 1)") + ;; abcdefghijklmnopqrstuv + i k v scan-error) + +(define-lisp-up-list-test up-list-with-forward-sexp-function + (lambda () + (let ((forward-sexp-function + (lambda (&optional arg) + (let ((forward-sexp-function nil)) + (forward-sexp arg))))) + (up-list))) + (or "(1 1 (1 1) 1 (1 1) 1)") + ;; abcdefghijklmnopqrstuv + i k v scan-error) + +(define-lisp-up-list-test up-list-out-of-string + (lambda () (up-list 1 t)) + (or "1 (1 '2 2 (2 2 2' 1) 1") + ;; abcdefghijklmnopqrstuvwxy + o r u scan-error) + +(define-lisp-up-list-test up-list-cross-string + (lambda () (up-list 1 t)) + (or "(1 '2 ( 2' 1 '2 ) 2' 1)") + ;; abcdefghijklmnopqrstuvwxy + i r u x scan-error) + +(define-lisp-up-list-test up-list-no-cross-string + (lambda () (up-list 1 t t)) + (or "(1 '2 ( 2' 1 '2 ) 2' 1)") + ;; abcdefghijklmnopqrstuvwxy + i k x scan-error) + +(define-lisp-up-list-test backward-up-list-basic + (lambda () (backward-up-list)) + (or "(1 1 (1 1) 1 (1 1) 1)") + ;; abcdefghijklmnopqrstuv + i f a scan-error) (provide 'lisp-tests) ;;; lisp-tests.el ends here diff --git a/test/lisp/legacy/syntax-tests.el b/test/lisp/legacy/syntax-tests.el deleted file mode 100644 index d4af80e..0000000 --- a/test/lisp/legacy/syntax-tests.el +++ /dev/null @@ -1,97 +0,0 @@ -;;; syntax-tests.el --- Testing syntax rules and basic movement -*- lexical-binding: t -*- - -;; Copyright (C) 2014-2016 Free Software Foundation, Inc. - -;; Author: Daniel Colascione -;; Keywords: - -;; 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: - -;; - -;;; Code: -(require 'ert) -(require 'cl-lib) - -(defun run-up-list-test (fn data start instructions) - (cl-labels ((posof (thing) - (and (symbolp thing) - (= (length (symbol-name thing)) 1) - (- (aref (symbol-name thing) 0) ?a -1)))) - (with-temp-buffer - (set-syntax-table (make-syntax-table)) - ;; Use a syntax table in which single quote is a string - ;; character so that we can embed the test data in a lisp string - ;; literal. - (modify-syntax-entry ?\' "\"") - (insert data) - (goto-char (posof start)) - (dolist (instruction instructions) - (cond ((posof instruction) - (funcall fn) - (should (eql (point) (posof instruction)))) - ((symbolp instruction) - (should-error (funcall fn) - :type instruction)) - (t (cl-assert nil nil "unknown ins"))))))) - -(defmacro define-up-list-test (name fn data start &rest expected) - `(ert-deftest ,name () - (run-up-list-test ,fn ,data ',start ',expected))) - -(define-up-list-test up-list-basic - (lambda () (up-list)) - (or "(1 1 (1 1) 1 (1 1) 1)") - ;; abcdefghijklmnopqrstuv - i k v scan-error) - -(define-up-list-test up-list-with-forward-sexp-function - (lambda () - (let ((forward-sexp-function - (lambda (&optional arg) - (let ((forward-sexp-function nil)) - (forward-sexp arg))))) - (up-list))) - (or "(1 1 (1 1) 1 (1 1) 1)") - ;; abcdefghijklmnopqrstuv - i k v scan-error) - -(define-up-list-test up-list-out-of-string - (lambda () (up-list 1 t)) - (or "1 (1 '2 2 (2 2 2' 1) 1") - ;; abcdefghijklmnopqrstuvwxy - o r u scan-error) - -(define-up-list-test up-list-cross-string - (lambda () (up-list 1 t)) - (or "(1 '2 ( 2' 1 '2 ) 2' 1)") - ;; abcdefghijklmnopqrstuvwxy - i r u x scan-error) - -(define-up-list-test up-list-no-cross-string - (lambda () (up-list 1 t t)) - (or "(1 '2 ( 2' 1 '2 ) 2' 1)") - ;; abcdefghijklmnopqrstuvwxy - i k x scan-error) - -(define-up-list-test backward-up-list-basic - (lambda () (backward-up-list)) - (or "(1 1 (1 1) 1 (1 1) 1)") - ;; abcdefghijklmnopqrstuv - i f a scan-error) - -(provide 'syntax-tests) -;;; syntax-tests.el ends here commit 25d66a430e45b4df1d8bb8c8e559f86dcdbcb4c3 Author: Eli Zaretskii Date: Sat Sep 24 13:12:43 2016 +0300 ; * test/src/process-tests.el: Renamed from test/lisp/legacy/process-tests.el. diff --git a/test/lisp/legacy/process-tests.el b/test/src/process-tests.el similarity index 99% rename from test/lisp/legacy/process-tests.el rename to test/src/process-tests.el index 8554a28..8cc59bf 100644 --- a/test/lisp/legacy/process-tests.el +++ b/test/src/process-tests.el @@ -163,3 +163,4 @@ (should (equal path samepath)))) (provide 'process-tests) +;; process-tests.el ends here. commit ef5c799c661dae1d1eb52c45d7a82e93f92b47c0 Author: Eli Zaretskii Date: Sat Sep 24 13:00:40 2016 +0300 Incorporate occur-tests in replace-tests * test/lisp/replace-tests.el: Add tests from test/lisp/legacy/occur-tests.el. * test/lisp/legacy/occur-tests.el: File deleted. diff --git a/test/lisp/legacy/occur-tests.el b/test/lisp/legacy/occur-tests.el deleted file mode 100644 index da45d5f..0000000 --- a/test/lisp/legacy/occur-tests.el +++ /dev/null @@ -1,352 +0,0 @@ -;;; occur-tests.el --- Test suite for occur. - -;; Copyright (C) 2010-2016 Free Software Foundation, Inc. - -;; Author: Juri Linkov -;; Keywords: matching, internal - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Code: - -(require 'ert) - -(defconst occur-tests - '( - ;; * Test one-line matches (at bob, eob, bol, eol). - ("x" 0 "\ -xa -b -cx -xd -xex -fx -" "\ -6 matches in 5 lines for \"x\" in buffer: *test-occur* - 1:xa - 3:cx - 4:xd - 5:xex - 6:fx -") - ;; * Test multi-line matches, this is the first test from - ;; http://lists.gnu.org/archive/html/emacs-devel/2005-06/msg01008.html - ;; where numbers are replaced with letters. - ("a\na" 0 "\ -a -a -a -a -a -" "\ -2 matches for \"a\na\" in buffer: *test-occur* - 1:a - :a - 3:a - :a -") - ;; * Test multi-line matches, this is the second test from - ;; http://lists.gnu.org/archive/html/emacs-devel/2005-06/msg01008.html - ;; where numbers are replaced with letters. - ("a\nb" 0 "\ -a -b -c -a -b -" "\ -2 matches for \"a\nb\" in buffer: *test-occur* - 1:a - :b - 4:a - :b -") - ;; * Test line numbers for multi-line matches with empty last match line. - ("a\n" 0 "\ -a - -c -a - -" "\ -2 matches for \"a\n\" in buffer: *test-occur* - 1:a - : - 4:a - : -") - ;; * Test multi-line matches with 3 match lines. - ("x\n.x\n" 0 "\ -ax -bx -c -d -ex -fx -" "\ -2 matches for \"x\n.x\n\" in buffer: *test-occur* - 1:ax - :bx - :c - 5:ex - :fx - : -") - ;; * Test non-overlapping context lines with matches at bob/eob. - ("x" 1 "\ -ax -b -c -d -ex -f -g -hx -" "\ -3 matches for \"x\" in buffer: *test-occur* - 1:ax - :b -------- - :d - 5:ex - :f -------- - :g - 8:hx -") - ;; * Test non-overlapping context lines with matches not at bob/eob. - ("x" 1 "\ -a -bx -c -d -ex -f -" "\ -2 matches for \"x\" in buffer: *test-occur* - :a - 2:bx - :c -------- - :d - 5:ex - :f -") - ;; * Test overlapping context lines with matches at bob/eob. - ("x" 2 "\ -ax -bx -c -dx -e -f -gx -h -i -j -kx -" "\ -5 matches for \"x\" in buffer: *test-occur* - 1:ax - 2:bx - :c - 4:dx - :e - :f - 7:gx - :h - :i - :j - 11:kx -") - ;; * Test overlapping context lines with matches not at bob/eob. - ("x" 2 "\ -a -b -cx -d -e -f -gx -h -i -" "\ -2 matches for \"x\" in buffer: *test-occur* - :a - :b - 3:cx - :d - :e - :f - 7:gx - :h - :i -") - ;; * Test overlapping context lines with empty first and last line.. - ("x" 2 "\ - -b -cx -d -e -f -gx -h - -" "\ -2 matches for \"x\" in buffer: *test-occur* - : - :b - 3:cx - :d - :e - :f - 7:gx - :h - : -") - ;; * Test multi-line overlapping context lines. - ("x\n.x" 2 "\ -ax -bx -c -d -ex -fx -g -h -i -jx -kx -" "\ -3 matches for \"x\n.x\" in buffer: *test-occur* - 1:ax - :bx - :c - :d - 5:ex - :fx - :g - :h - :i - 10:jx - :kx -") - ;; * Test multi-line non-overlapping context lines. - ("x\n.x" 2 "\ -ax -bx -c -d -e -f -gx -hx -" "\ -2 matches for \"x\n.x\" in buffer: *test-occur* - 1:ax - :bx - :c - :d -------- - :e - :f - 7:gx - :hx -") - ;; * Test non-overlapping negative (before-context) lines. - ("x" -2 "\ -a -bx -c -d -e -fx -g -h -ix -" "\ -3 matches for \"x\" in buffer: *test-occur* - :a - 2:bx -------- - :d - :e - 6:fx -------- - :g - :h - 9:ix -") - ;; * Test overlapping negative (before-context) lines. - ("x" -3 "\ -a -bx -c -dx -e -f -gx -h -" "\ -3 matches for \"x\" in buffer: *test-occur* - :a - 2:bx - :c - 4:dx - :e - :f - 7:gx -") - -) - "List of tests for `occur'. -Each element has the format: -\(REGEXP NLINES INPUT-BUFFER-STRING OUTPUT-BUFFER-STRING).") - -(defun occur-test-case (test) - (let ((regexp (nth 0 test)) - (nlines (nth 1 test)) - (input-buffer-string (nth 2 test)) - (temp-buffer (get-buffer-create " *test-occur*"))) - (unwind-protect - (save-window-excursion - (with-current-buffer temp-buffer - (erase-buffer) - (insert input-buffer-string) - (occur regexp nlines) - (with-current-buffer "*Occur*" - (buffer-substring-no-properties (point-min) (point-max))))) - (and (buffer-name temp-buffer) - (kill-buffer temp-buffer))))) - -(defun occur-test-create (n) - "Create a test for element N of the `occur-tests' constant." - (let ((testname (intern (format "occur-test-%.2d" n))) - (testdoc (format "Test element %d of `occur-tests'." n))) - (eval - `(ert-deftest ,testname () - ,testdoc - (let (occur-hook) - (should (equal (occur-test-case (nth ,n occur-tests)) - (nth 3 (nth ,n occur-tests))))))))) - -(dotimes (i (length occur-tests)) - (occur-test-create i)) - -(provide 'occur-tests) - -;;; occur-tests.el ends here diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el index bfaab6c..2b71348 100644 --- a/test/lisp/replace-tests.el +++ b/test/lisp/replace-tests.el @@ -1,6 +1,9 @@ ;;; replace-tests.el --- tests for replace.el. -;; Copyright (C) 2015-2016 Free Software Foundation, Inc. +;; Copyright (C) 2010-2016 Free Software Foundation, Inc. + +;; Author: Nicolas Richard +;; Author: Juri Linkov ;; This file is part of GNU Emacs. @@ -32,4 +35,327 @@ (query-replace--split-string (concat before "\0" after)) (concat before "\0" after))))))) +(defconst replace-occur-tests + '( + ;; * Test one-line matches (at bob, eob, bol, eol). + ("x" 0 "\ +xa +b +cx +xd +xex +fx +" "\ +6 matches in 5 lines for \"x\" in buffer: *test-occur* + 1:xa + 3:cx + 4:xd + 5:xex + 6:fx +") + ;; * Test multi-line matches, this is the first test from + ;; http://lists.gnu.org/archive/html/emacs-devel/2005-06/msg01008.html + ;; where numbers are replaced with letters. + ("a\na" 0 "\ +a +a +a +a +a +" "\ +2 matches for \"a\na\" in buffer: *test-occur* + 1:a + :a + 3:a + :a +") + ;; * Test multi-line matches, this is the second test from + ;; http://lists.gnu.org/archive/html/emacs-devel/2005-06/msg01008.html + ;; where numbers are replaced with letters. + ("a\nb" 0 "\ +a +b +c +a +b +" "\ +2 matches for \"a\nb\" in buffer: *test-occur* + 1:a + :b + 4:a + :b +") + ;; * Test line numbers for multi-line matches with empty last match line. + ("a\n" 0 "\ +a + +c +a + +" "\ +2 matches for \"a\n\" in buffer: *test-occur* + 1:a + : + 4:a + : +") + ;; * Test multi-line matches with 3 match lines. + ("x\n.x\n" 0 "\ +ax +bx +c +d +ex +fx +" "\ +2 matches for \"x\n.x\n\" in buffer: *test-occur* + 1:ax + :bx + :c + 5:ex + :fx + : +") + ;; * Test non-overlapping context lines with matches at bob/eob. + ("x" 1 "\ +ax +b +c +d +ex +f +g +hx +" "\ +3 matches for \"x\" in buffer: *test-occur* + 1:ax + :b +------- + :d + 5:ex + :f +------- + :g + 8:hx +") + ;; * Test non-overlapping context lines with matches not at bob/eob. + ("x" 1 "\ +a +bx +c +d +ex +f +" "\ +2 matches for \"x\" in buffer: *test-occur* + :a + 2:bx + :c +------- + :d + 5:ex + :f +") + ;; * Test overlapping context lines with matches at bob/eob. + ("x" 2 "\ +ax +bx +c +dx +e +f +gx +h +i +j +kx +" "\ +5 matches for \"x\" in buffer: *test-occur* + 1:ax + 2:bx + :c + 4:dx + :e + :f + 7:gx + :h + :i + :j + 11:kx +") + ;; * Test overlapping context lines with matches not at bob/eob. + ("x" 2 "\ +a +b +cx +d +e +f +gx +h +i +" "\ +2 matches for \"x\" in buffer: *test-occur* + :a + :b + 3:cx + :d + :e + :f + 7:gx + :h + :i +") + ;; * Test overlapping context lines with empty first and last line.. + ("x" 2 "\ + +b +cx +d +e +f +gx +h + +" "\ +2 matches for \"x\" in buffer: *test-occur* + : + :b + 3:cx + :d + :e + :f + 7:gx + :h + : +") + ;; * Test multi-line overlapping context lines. + ("x\n.x" 2 "\ +ax +bx +c +d +ex +fx +g +h +i +jx +kx +" "\ +3 matches for \"x\n.x\" in buffer: *test-occur* + 1:ax + :bx + :c + :d + 5:ex + :fx + :g + :h + :i + 10:jx + :kx +") + ;; * Test multi-line non-overlapping context lines. + ("x\n.x" 2 "\ +ax +bx +c +d +e +f +gx +hx +" "\ +2 matches for \"x\n.x\" in buffer: *test-occur* + 1:ax + :bx + :c + :d +------- + :e + :f + 7:gx + :hx +") + ;; * Test non-overlapping negative (before-context) lines. + ("x" -2 "\ +a +bx +c +d +e +fx +g +h +ix +" "\ +3 matches for \"x\" in buffer: *test-occur* + :a + 2:bx +------- + :d + :e + 6:fx +------- + :g + :h + 9:ix +") + ;; * Test overlapping negative (before-context) lines. + ("x" -3 "\ +a +bx +c +dx +e +f +gx +h +" "\ +3 matches for \"x\" in buffer: *test-occur* + :a + 2:bx + :c + 4:dx + :e + :f + 7:gx +") + +) + "List of tests for `occur'. +Each element has the format: +\(REGEXP NLINES INPUT-BUFFER-STRING OUTPUT-BUFFER-STRING).") + +(defun replace-occur-test-case (test) + (let ((regexp (nth 0 test)) + (nlines (nth 1 test)) + (input-buffer-string (nth 2 test)) + (temp-buffer (get-buffer-create " *test-occur*"))) + (unwind-protect + (save-window-excursion + (with-current-buffer temp-buffer + (erase-buffer) + (insert input-buffer-string) + (occur regexp nlines) + (with-current-buffer "*Occur*" + (buffer-substring-no-properties (point-min) (point-max))))) + (and (buffer-name temp-buffer) + (kill-buffer temp-buffer))))) + +(defun replace-occur-test-create (n) + "Create a test for element N of the `replace-occur-tests' constant." + (let ((testname (intern (format "occur-test-%.2d" n))) + (testdoc (format "Test element %d of `replace-occur-tests'." n))) + (eval + `(ert-deftest ,testname () + ,testdoc + (let (replace-occur-hook) + (should (equal (replace-occur-test-case (nth ,n replace-occur-tests)) + (nth 3 (nth ,n replace-occur-tests))))))))) + +(dotimes (i (length replace-occur-tests)) + (replace-occur-test-create i)) + ;;; replace-tests.el ends here commit 4e71b5b343c92fc587c666b98440cd8d9b36980c Author: Eli Zaretskii Date: Sat Sep 24 12:53:46 2016 +0300 Incorporate lexbind-tests.el in bytecomp-test.el * test/lisp/emacs-lisp/bytecomp-tests.el: Added tests from test/lisp/legacy/lexbind-tests.el. * test/lisp/legacy/lexbind-tests.el: File deleted. diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 8847c1b5..91d438e 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -2,7 +2,8 @@ ;; Copyright (C) 2008-2016 Free Software Foundation, Inc. -;; Author: Shigeru Fukaya +;; Author: Shigeru Fukaya +;; Author: Stefan Monnier ;; Created: November 2008 ;; Keywords: internal ;; Human-Keywords: internal @@ -420,6 +421,46 @@ Subtests signal errors if something goes wrong." (defun def () (m)))) (should (equal (funcall 'def) 4))) +(defconst bytecomp-lexbind-tests + `( + (let ((f #'car)) + (let ((f (lambda (x) (cons (funcall f x) (cdr x))))) + (funcall f '(1 . 2)))) + ) + "List of expression for test. +Each element will be executed by interpreter and with +bytecompiled code, and their results compared.") + +(defun bytecomp-lexbind-check-1 (pat) + "Return non-nil if PAT is the same whether directly evalled or compiled." + (let ((warning-minimum-log-level :emergency) + (byte-compile-warnings nil) + (v0 (condition-case nil + (eval pat t) + (error nil))) + (v1 (condition-case nil + (funcall (let ((lexical-binding t)) + (byte-compile `(lambda nil ,pat)))) + (error nil)))) + (equal v0 v1))) + +(put 'bytecomp-lexbind-check-1 'ert-explainer 'bytecomp-lexbind-explain-1) + +(defun bytecomp-lexbind-explain-1 (pat) + (let ((v0 (condition-case nil + (eval pat t) + (error nil))) + (v1 (condition-case nil + (funcall (let ((lexical-binding t)) + (byte-compile (list 'lambda nil pat)))) + (error nil)))) + (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled." + pat v0 v1))) + +(ert-deftest bytecomp-lexbind-tests () + "Test the Emacs byte compiler lexbind handling." + (dolist (pat bytecomp-lexbind-tests) + (should (bytecomp-lexbind-check-1 pat)))) ;; Local Variables: ;; no-byte-compile: t diff --git a/test/lisp/legacy/lexbind-tests.el b/test/lisp/legacy/lexbind-tests.el deleted file mode 100644 index 3bf8c13..0000000 --- a/test/lisp/legacy/lexbind-tests.el +++ /dev/null @@ -1,75 +0,0 @@ -;;; lexbind-tests.el --- Testing the lexbind byte-compiler - -;; Copyright (C) 2011-2016 Free Software Foundation, Inc. - -;; Author: Stefan Monnier -;; Keywords: - -;; 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: - -;; - -;;; Code: - -(require 'ert) - -(defconst lexbind-tests - `( - (let ((f #'car)) - (let ((f (lambda (x) (cons (funcall f x) (cdr x))))) - (funcall f '(1 . 2)))) - ) - "List of expression for test. -Each element will be executed by interpreter and with -bytecompiled code, and their results compared.") - - - -(defun lexbind-check-1 (pat) - "Return non-nil if PAT is the same whether directly evalled or compiled." - (let ((warning-minimum-log-level :emergency) - (byte-compile-warnings nil) - (v0 (condition-case nil - (eval pat t) - (error nil))) - (v1 (condition-case nil - (funcall (let ((lexical-binding t)) - (byte-compile `(lambda nil ,pat)))) - (error nil)))) - (equal v0 v1))) - -(put 'lexbind-check-1 'ert-explainer 'lexbind-explain-1) - -(defun lexbind-explain-1 (pat) - (let ((v0 (condition-case nil - (eval pat t) - (error nil))) - (v1 (condition-case nil - (funcall (let ((lexical-binding t)) - (byte-compile (list 'lambda nil pat)))) - (error nil)))) - (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled." - pat v0 v1))) - -(ert-deftest lexbind-tests () - "Test the Emacs byte compiler lexbind handling." - (dolist (pat lexbind-tests) - (should (lexbind-check-1 pat)))) - - - -(provide 'lexbind-tests) -;;; lexbind-tests.el ends here commit 524a991f884b0c922e5263817d39856dac58c99b Author: Eli Zaretskii Date: Sat Sep 24 12:43:40 2016 +0300 ; * test/src/font-tests.el: Minor copyedits. diff --git a/test/src/font-tests.el b/test/src/font-tests.el index 9f730d3..f0f0d31 100644 --- a/test/src/font-tests.el +++ b/test/src/font-tests.el @@ -1,4 +1,4 @@ -;;; font-parse-tests.el --- Test suite for font parsing. +;;; font-tests.el --- Test suite for font-related functions. ;; Copyright (C) 2011-2016 Free Software Foundation, Inc. @@ -163,4 +163,5 @@ expected font properties from parsing NAME.") ;; no-byte-compile: t ;; End: -;;; font-parse-tests.el ends here. +(provide 'font-tests) +;;; font-tests.el ends here. commit e8ae0bc7070c4498f0f69e150c2c1dfead8b2e05 Author: Eli Zaretskii Date: Sat Sep 24 12:40:10 2016 +0300 ; * test/src/font-tests.el: Moved from test/lisp/legacy/font-parse-tests.el. diff --git a/test/lisp/legacy/font-parse-tests.el b/test/src/font-tests.el similarity index 100% rename from test/lisp/legacy/font-parse-tests.el rename to test/src/font-tests.el commit 4822b56598f91489e050fcbf305d99b5e57b6791 Merge: 23efc43 b3e1b38 Author: Eli Zaretskii Date: Sat Sep 24 12:36:43 2016 +0300 Merge branch 'master' of git.savannah.gnu.org:/srv/git/emacs commit 23efc43d01462ff0e952dd149d26e90cbe8792f0 Author: Eli Zaretskii Date: Sat Sep 24 12:35:54 2016 +0300 ; * test/lisp/files-tests.el: Minor copyedits. diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index 56150c1..479848a 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -1,4 +1,4 @@ -;;; files.el --- tests for file handling. +;;; files-tests.el --- tests for files.el. ;; Copyright (C) 2012-2016 Free Software Foundation, Inc. @@ -197,4 +197,5 @@ form.") (setenv "FOO" foo-env) (setenv "BAR" bar-env)))) -;;; files.el ends here +(provide 'files-tests) +;;; files-tests.el ends here commit b3e1b382456b0f7d108c57d6f902bbddfdd97b2a Author: Paul Eggert Date: Sat Sep 24 02:35:13 2016 -0700 Improve integer overflow handling a bit * src/charset.c (read_hex): Use INT_LEFT_SHIFT_OVERFLOW for clarity. The machine code is the same on my platform. * src/doprnt.c (doprnt): * src/emacs-module.c (module_funcall): * src/font.c (font_intern_prop): * src/keyboard.c (Frecursion_depth): * src/lread.c (read1): Use WRAPV macros instead of checking overflow by hand. * src/editfns.c (hi_time, time_arith, decode_time_components): * src/emacs-module.c (Fmodule_load): Simplify by using FIXNUM_OVERFLOW_P. * src/emacs-module.c: Include intprops.h. * src/xdisp.c (percent99): New function. (decode_mode_spec): Use it to simplify overflow avoidance and formatting of %p and %P. diff --git a/src/charset.c b/src/charset.c index 0c831f1..cdbfe11 100644 --- a/src/charset.c +++ b/src/charset.c @@ -435,7 +435,7 @@ read_hex (FILE *fp, bool *eof, bool *overflow) n = 0; while (c_isxdigit (c = getc (fp))) { - if (UINT_MAX >> 4 < n) + if (INT_LEFT_SHIFT_OVERFLOW (n, 4)) *overflow = 1; n = ((n << 4) | (c - ('0' <= c && c <= '9' ? '0' diff --git a/src/doprnt.c b/src/doprnt.c index 9d8b783..de2b89e 100644 --- a/src/doprnt.c +++ b/src/doprnt.c @@ -133,8 +133,11 @@ doprnt (char *buffer, ptrdiff_t bufsize, const char *format, const char *fmt = format; /* Pointer into format string. */ char *bufptr = buffer; /* Pointer into output buffer. */ + /* Enough to handle floating point formats with large numbers. */ + enum { SIZE_BOUND_EXTRA = DBL_MAX_10_EXP + 50 }; + /* Use this for sprintf unless we need something really big. */ - char tembuf[DBL_MAX_10_EXP + 100]; + char tembuf[SIZE_BOUND_EXTRA + 50]; /* Size of sprintf_buffer. */ ptrdiff_t size_allocated = sizeof (tembuf); @@ -196,21 +199,19 @@ doprnt (char *buffer, ptrdiff_t bufsize, const char *format, This might be a field width or a precision; e.g. %1.1000f and %1000.1f both might need 1000+ bytes. Parse the width or precision, checking for overflow. */ - ptrdiff_t n = *fmt - '0'; + int n = *fmt - '0'; + bool overflow = false; while (fmt + 1 < format_end && '0' <= fmt[1] && fmt[1] <= '9') { - /* Avoid ptrdiff_t, size_t, and int overflow, as - many sprintfs mishandle widths greater than INT_MAX. - This test is simple but slightly conservative: e.g., - (INT_MAX - INT_MAX % 10) is reported as an overflow - even when it's not. */ - if (n >= min (INT_MAX, min (PTRDIFF_MAX, SIZE_MAX)) / 10) - error ("Format width or precision too large"); - n = n * 10 + fmt[1] - '0'; + overflow |= INT_MULTIPLY_WRAPV (n, 10, &n); + overflow |= INT_ADD_WRAPV (n, fmt[1] - '0', &n); *string++ = *++fmt; } + if (overflow + || min (PTRDIFF_MAX, SIZE_MAX) - SIZE_BOUND_EXTRA < n) + error ("Format width or precision too large"); if (size_bound < n) size_bound = n; } @@ -244,9 +245,7 @@ doprnt (char *buffer, ptrdiff_t bufsize, const char *format, /* Make the size bound large enough to handle floating point formats with large numbers. */ - if (size_bound > min (PTRDIFF_MAX, SIZE_MAX) - DBL_MAX_10_EXP - 50) - error ("Format width or precision too large"); - size_bound += DBL_MAX_10_EXP + 50; + size_bound += SIZE_BOUND_EXTRA; /* Make sure we have that much. */ if (size_bound > size_allocated) diff --git a/src/editfns.c b/src/editfns.c index 835e432..c5b177e 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -1523,17 +1523,8 @@ static EMACS_INT hi_time (time_t t) { time_t hi = t >> LO_TIME_BITS; - - /* Check for overflow, helping the compiler for common cases where - no runtime check is needed, and taking care not to convert - negative numbers to unsigned before comparing them. */ - if (! ((! TYPE_SIGNED (time_t) - || MOST_NEGATIVE_FIXNUM <= TIME_T_MIN >> LO_TIME_BITS - || MOST_NEGATIVE_FIXNUM <= hi) - && (TIME_T_MAX >> LO_TIME_BITS <= MOST_POSITIVE_FIXNUM - || hi <= MOST_POSITIVE_FIXNUM))) + if (FIXNUM_OVERFLOW_P (hi)) time_overflow (); - return hi; } @@ -1595,7 +1586,7 @@ time_arith (Lisp_Object a, Lisp_Object b, struct lisp_time ta = lisp_time_struct (a, &alen); struct lisp_time tb = lisp_time_struct (b, &blen); struct lisp_time t = op (ta, tb); - if (! (MOST_NEGATIVE_FIXNUM <= t.hi && t.hi <= MOST_POSITIVE_FIXNUM)) + if (FIXNUM_OVERFLOW_P (t.hi)) time_overflow (); Lisp_Object val = Qnil; @@ -1853,7 +1844,7 @@ decode_time_components (Lisp_Object high, Lisp_Object low, Lisp_Object usec, if (result) { - if (! (MOST_NEGATIVE_FIXNUM <= hi && hi <= MOST_POSITIVE_FIXNUM)) + if (FIXNUM_OVERFLOW_P (hi)) return -1; result->hi = hi; result->lo = lo; diff --git a/src/emacs-module.c b/src/emacs-module.c index 724d24a..0e755ef 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -30,7 +30,9 @@ along with GNU Emacs. If not, see . */ #include "lisp.h" #include "dynlib.h" #include "coding.h" -#include "verify.h" + +#include +#include /* Feature tests. */ @@ -424,13 +426,14 @@ module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs, first arg, because that's what Ffuncall takes. */ Lisp_Object *newargs; USE_SAFE_ALLOCA; - if (nargs == PTRDIFF_MAX) + ptrdiff_t nargs1; + if (INT_ADD_WRAPV (nargs, 1, &nargs1)) xsignal0 (Qoverflow_error); - SAFE_ALLOCA_LISP (newargs, nargs + 1); + SAFE_ALLOCA_LISP (newargs, nargs1); newargs[0] = value_to_lisp (fun); for (ptrdiff_t i = 0; i < nargs; i++) newargs[1 + i] = value_to_lisp (args[i]); - emacs_value result = lisp_to_value (Ffuncall (nargs + 1, newargs)); + emacs_value result = lisp_to_value (Ffuncall (nargs1, newargs)); SAFE_FREE (); return result; } @@ -665,7 +668,7 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, if (r != 0) { - if (! (MOST_NEGATIVE_FIXNUM <= r && r <= MOST_POSITIVE_FIXNUM)) + if (FIXNUM_OVERFLOW_P (r)) xsignal0 (Qoverflow_error); xsignal2 (Qmodule_load_failed, file, make_number (r)); } diff --git a/src/font.c b/src/font.c index 144ba07..f280063 100644 --- a/src/font.c +++ b/src/font.c @@ -264,14 +264,13 @@ font_intern_prop (const char *str, ptrdiff_t len, bool force_symbol) break; if (i == len) { - EMACS_INT n; - i = 0; - for (n = 0; (n += str[i++] - '0') <= MOST_POSITIVE_FIXNUM; n *= 10) + for (EMACS_INT n = 0; + (n += str[i++] - '0') <= MOST_POSITIVE_FIXNUM; ) { if (i == len) return make_number (n); - if (MOST_POSITIVE_FIXNUM / 10 < n) + if (INT_MULTIPLY_WRAPV (n, 10, &n)) break; } diff --git a/src/keyboard.c b/src/keyboard.c index b8bc361..ca40c6e 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -10058,11 +10058,9 @@ DEFUN ("recursion-depth", Frecursion_depth, Srecursion_depth, 0, 0, 0, doc: /* Return the current depth in recursive edits. */) (void) { - Lisp_Object temp; - /* Wrap around reliably on integer overflow. */ - EMACS_INT sum = (command_loop_level & INTMASK) + (minibuf_level & INTMASK); - XSETINT (temp, sum); - return temp; + EMACS_INT sum; + INT_ADD_WRAPV (command_loop_level, minibuf_level, &sum); + return make_number (sum); } DEFUN ("open-dribble-file", Fopen_dribble_file, Sopen_dribble_file, 1, 1, diff --git a/src/lread.c b/src/lread.c index dc7c00b..d3413d1 100644 --- a/src/lread.c +++ b/src/lread.c @@ -2894,19 +2894,17 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) { EMACS_INT n = 0; Lisp_Object tem; + bool overflow = false; /* Read a non-negative integer. */ while (c >= '0' && c <= '9') { - if (MOST_POSITIVE_FIXNUM / 10 < n - || MOST_POSITIVE_FIXNUM < n * 10 + c - '0') - n = MOST_POSITIVE_FIXNUM + 1; - else - n = n * 10 + c - '0'; + overflow |= INT_MULTIPLY_WRAPV (n, 10, &n); + overflow |= INT_ADD_WRAPV (n, c - '0', &n); c = READCHAR; } - if (n <= MOST_POSITIVE_FIXNUM) + if (!overflow && n <= MOST_POSITIVE_FIXNUM) { if (c == 'r' || c == 'R') return read_integer (readcharfun, n); diff --git a/src/xdisp.c b/src/xdisp.c index 4bf1470..13af87f 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -23448,6 +23448,16 @@ decode_mode_spec_coding (Lisp_Object coding_system, char *buf, bool eol_flag) return buf; } +/* Return the approximate percentage N is of D (rounding upward), or 99, + whichever is less. Assume 0 < D and 0 <= N <= D * INT_MAX / 100. */ + +static int +percent99 (ptrdiff_t n, ptrdiff_t d) +{ + int percent = (d - 1 + 100.0 * n) / d; + return min (percent, 99); +} + /* Return a string for the output of a mode line %-spec for window W, generated by character C. FIELD_WIDTH > 0 means pad the string returned with spaces to that value. Return a Lisp string in @@ -23735,29 +23745,17 @@ decode_mode_spec (struct window *w, register int c, int field_width, case 'p': { ptrdiff_t pos = marker_position (w->start); - ptrdiff_t total = BUF_ZV (b) - BUF_BEGV (b); + ptrdiff_t begv = BUF_BEGV (b); + ptrdiff_t zv = BUF_ZV (b); - if (w->window_end_pos <= BUF_Z (b) - BUF_ZV (b)) - { - if (pos <= BUF_BEGV (b)) - return "All"; - else - return "Bottom"; - } - else if (pos <= BUF_BEGV (b)) + if (w->window_end_pos <= BUF_Z (b) - zv) + return pos <= begv ? "All" : "Bottom"; + else if (pos <= begv) return "Top"; else { - if (total > 1000000) - /* Do it differently for a large value, to avoid overflow. */ - total = ((pos - BUF_BEGV (b)) + (total / 100) - 1) / (total / 100); - else - total = ((pos - BUF_BEGV (b)) * 100 + total - 1) / total; - /* We can't normally display a 3-digit number, - so get us a 2-digit number that is close. */ - if (total == 100) - total = 99; - sprintf (decode_mode_spec_buf, "%2"pD"d%%", total); + sprintf (decode_mode_spec_buf, "%2d%%", + percent99 (pos - begv, zv - begv)); return decode_mode_spec_buf; } } @@ -23767,30 +23765,16 @@ decode_mode_spec (struct window *w, register int c, int field_width, { ptrdiff_t toppos = marker_position (w->start); ptrdiff_t botpos = BUF_Z (b) - w->window_end_pos; - ptrdiff_t total = BUF_ZV (b) - BUF_BEGV (b); + ptrdiff_t begv = BUF_BEGV (b); + ptrdiff_t zv = BUF_ZV (b); - if (botpos >= BUF_ZV (b)) - { - if (toppos <= BUF_BEGV (b)) - return "All"; - else - return "Bottom"; - } + if (zv <= botpos) + return toppos <= begv ? "All" : "Bottom"; else { - if (total > 1000000) - /* Do it differently for a large value, to avoid overflow. */ - total = ((botpos - BUF_BEGV (b)) + (total / 100) - 1) / (total / 100); - else - total = ((botpos - BUF_BEGV (b)) * 100 + total - 1) / total; - /* We can't normally display a 3-digit number, - so get us a 2-digit number that is close. */ - if (total == 100) - total = 99; - if (toppos <= BUF_BEGV (b)) - sprintf (decode_mode_spec_buf, "Top%2"pD"d%%", total); - else - sprintf (decode_mode_spec_buf, "%2"pD"d%%", total); + sprintf (decode_mode_spec_buf, + &"Top%2d%%"[begv < toppos ? sizeof "Top" - 1 : 0], + percent99 (botpos - begv, zv - begv)); return decode_mode_spec_buf; } } commit 4f05e930ca9ca4fa87aa2bc83187590432d792bd Author: Eli Zaretskii Date: Sat Sep 24 12:34:15 2016 +0300 ; * test/lisp/files-tests.el: Moved from test/lisp/legacy/. diff --git a/test/lisp/legacy/files-tests.el b/test/lisp/files-tests.el similarity index 100% rename from test/lisp/legacy/files-tests.el rename to test/lisp/files-tests.el commit 0cba34447768b7aa5c8bd05128b17541a43e980d Author: Eli Zaretskii Date: Sat Sep 24 12:30:22 2016 +0300 Incorporate core-elisp-tests in lisp-tests * test/lisp/emacs-lisp/lisp-tests.el: Added tests from test/lisp/legacy/core-elisp-tests.el. * test/lisp/legacy/core-elisp-tests.el: File removed. diff --git a/test/lisp/emacs-lisp/lisp-tests.el b/test/lisp/emacs-lisp/lisp-tests.el index 4fe20f0..d83f4a0 100644 --- a/test/lisp/emacs-lisp/lisp-tests.el +++ b/test/lisp/emacs-lisp/lisp-tests.el @@ -3,6 +3,7 @@ ;; Copyright (C) 2013-2016 Free Software Foundation, Inc. ;; Author: Aaron S. Hawley +;; Author: Stefan Monnier ;; Keywords: internal ;; GNU Emacs is free software: you can redistribute it and/or modify @@ -207,5 +208,33 @@ (goto-char (point-min)) (should-error (forward-sexp)))) ;; FIXME: Shouldn't be an error. +;; Test some core Elisp rules. +(ert-deftest core-elisp-tests-1-defvar-in-let () + "Test some core Elisp rules." + (with-temp-buffer + ;; Check that when defvar is run within a let-binding, the toplevel default + ;; is properly initialized. + (should (equal (list (let ((c-e-x 1)) (defvar c-e-x 2) c-e-x) c-e-x) + '(1 2))) + (should (equal (list (let ((c-e-x 1)) + (defcustom c-e-x 2 "doc" :group 'blah :type 'integer) c-e-x) + c-e-x) + '(1 2))))) + +(ert-deftest core-elisp-tests-2-window-configurations () + "Test properties of window-configurations." + (let ((wc (current-window-configuration))) + (with-current-buffer (window-buffer (frame-selected-window)) + (push-mark) + (activate-mark)) + (set-window-configuration wc) + (should (or (not mark-active) (mark))))) + +(ert-deftest core-elisp-tests-3-backquote () + (should (eq 3 (eval ``,,'(+ 1 2))))) + +(provide 'core-elisp-tests) +;;; core-elisp-tests.el ends here + (provide 'lisp-tests) ;;; lisp-tests.el ends here diff --git a/test/lisp/legacy/core-elisp-tests.el b/test/lisp/legacy/core-elisp-tests.el deleted file mode 100644 index b44bb37..0000000 --- a/test/lisp/legacy/core-elisp-tests.el +++ /dev/null @@ -1,52 +0,0 @@ -;;; core-elisp-tests.el --- Testing some core Elisp rules - -;; Copyright (C) 2013-2016 Free Software Foundation, Inc. - -;; Author: Stefan Monnier -;; Keywords: - -;; 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: - -;; - -;;; Code: - -(ert-deftest core-elisp-tests-1-defvar-in-let () - "Test some core Elisp rules." - (with-temp-buffer - ;; Check that when defvar is run within a let-binding, the toplevel default - ;; is properly initialized. - (should (equal (list (let ((c-e-x 1)) (defvar c-e-x 2) c-e-x) c-e-x) - '(1 2))) - (should (equal (list (let ((c-e-x 1)) - (defcustom c-e-x 2 "doc" :group 'blah :type 'integer) c-e-x) - c-e-x) - '(1 2))))) - -(ert-deftest core-elisp-tests-2-window-configurations () - "Test properties of window-configurations." - (let ((wc (current-window-configuration))) - (with-current-buffer (window-buffer (frame-selected-window)) - (push-mark) - (activate-mark)) - (set-window-configuration wc) - (should (or (not mark-active) (mark))))) - -(ert-deftest core-elisp-tests-3-backquote () - (should (eq 3 (eval ``,,'(+ 1 2))))) - -(provide 'core-elisp-tests) -;;; core-elisp-tests.el ends here commit 2f4776bf321bcd9c92a0f979f5a0544b76f3cba5 Author: Eli Zaretskii Date: Sat Sep 24 12:18:54 2016 +0300 Move coding-tests.el and decoder-test.el to their places * test/src/coding-tests.el: Added all the tests from test/lisp/legacy/decoder-tests.el. * test/lisp/legacy/decoder-tests.el: File deleted. diff --git a/test/lisp/legacy/decoder-tests.el b/test/lisp/legacy/decoder-tests.el deleted file mode 100644 index 5699fec..0000000 --- a/test/lisp/legacy/decoder-tests.el +++ /dev/null @@ -1,349 +0,0 @@ -;;; decoder-tests.el --- test for text decoder - -;; Copyright (C) 2013-2016 Free Software Foundation, Inc. - -;; Author: Kenichi Handa - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; Code: - -(require 'ert) - -;; Directory to hold test data files. -(defvar decoder-tests-workdir - (expand-file-name "decoder-tests" temporary-file-directory)) - -;; Remove all generated test files. -(defun decoder-tests-remove-files () - (delete-directory decoder-tests-workdir t)) - -;; Return the contents (specified by CONTENT-TYPE; ascii, latin, or -;; binary) of a test file. -(defun decoder-tests-file-contents (content-type) - (let* ((ascii "ABCDEFGHIJKLMNOPQRSTUVWXYZ\n") - (latin (concat ascii "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏ\n")) - (binary (string-to-multibyte - (concat (string-as-unibyte latin) - (unibyte-string #xC0 #xC1 ?\n))))) - (cond ((eq content-type 'ascii) ascii) - ((eq content-type 'latin) latin) - ((eq content-type 'binary) binary) - (t - (error "Invalid file content type: %s" content-type))))) - -;; Generate FILE with CONTENTS encoded by CODING-SYSTEM. -;; whose encoding specified by CODING-SYSTEM. -(defun decoder-tests-gen-file (file contents coding-system) - (or (file-directory-p decoder-tests-workdir) - (mkdir decoder-tests-workdir t)) - (setq file (expand-file-name file decoder-tests-workdir)) - (with-temp-file file - (set-buffer-file-coding-system coding-system) - (insert contents)) - file) - -;;; The following three functions are filters for contents of a test -;;; file. - -;; Convert all LFs to CR LF sequences in the string STR. -(defun decoder-tests-lf-to-crlf (str) - (with-temp-buffer - (insert str) - (goto-char (point-min)) - (while (search-forward "\n" nil t) - (delete-char -1) - (insert "\r\n")) - (buffer-string))) - -;; Convert all LFs to CRs in the string STR. -(defun decoder-tests-lf-to-cr (str) - (with-temp-buffer - (insert str) - (subst-char-in-region (point-min) (point-max) ?\n ?\r) - (buffer-string))) - -;; Convert all LFs to LF LF sequences in the string STR. -(defun decoder-tests-lf-to-lflf (str) - (with-temp-buffer - (insert str) - (goto-char (point-min)) - (while (search-forward "\n" nil t) - (insert "\n")) - (buffer-string))) - -;; Prepend the UTF-8 BOM to STR. -(defun decoder-tests-add-bom (str) - (concat "\xfeff" str)) - -;; Return the name of test file whose contents specified by -;; CONTENT-TYPE and whose encoding specified by CODING-SYSTEM. -(defun decoder-tests-filename (content-type coding-system &optional ext) - (if ext - (expand-file-name (format "%s-%s.%s" content-type coding-system ext) - decoder-tests-workdir) - (expand-file-name (format "%s-%s" content-type coding-system) - decoder-tests-workdir))) - - -;;; Check ASCII optimizing decoder - -;; Generate a test file whose contents specified by CONTENT-TYPE and -;; whose encoding specified by CODING-SYSTEM. -(defun decoder-tests-ao-gen-file (content-type coding-system) - (let ((file (decoder-tests-filename content-type coding-system))) - (decoder-tests-gen-file file - (decoder-tests-file-contents content-type) - coding-system))) - -;; Test the decoding of a file whose contents and encoding are -;; specified by CONTENT-TYPE and WRITE-CODING. The test passes if the -;; file is read by READ-CODING and detected as DETECTED-CODING and the -;; contents is correctly decoded. -;; Optional 5th arg TRANSLATOR is a function to translate the original -;; file contents to match with the expected result of decoding. For -;; instance, when a file of dos eol-type is read by unix eol-type, -;; `decode-test-lf-to-crlf' must be specified. - -(defun decoder-tests (content-type write-coding read-coding detected-coding - &optional translator) - (prefer-coding-system 'utf-8-auto) - (let ((filename (decoder-tests-filename content-type write-coding))) - (with-temp-buffer - (let ((coding-system-for-read read-coding) - (contents (decoder-tests-file-contents content-type)) - (disable-ascii-optimization nil)) - (if translator - (setq contents (funcall translator contents))) - (insert-file-contents filename) - (if (and (coding-system-equal buffer-file-coding-system detected-coding) - (string= (buffer-string) contents)) - nil - (list buffer-file-coding-system - (string-to-list (buffer-string)) - (string-to-list contents))))))) - -(ert-deftest ert-test-decoder-ascii () - (unwind-protect - (progn - (dolist (eol-type '(unix dos mac)) - (decoder-tests-ao-gen-file 'ascii eol-type)) - (should-not (decoder-tests 'ascii 'unix 'undecided 'unix)) - (should-not (decoder-tests 'ascii 'dos 'undecided 'dos)) - (should-not (decoder-tests 'ascii 'dos 'dos 'dos)) - (should-not (decoder-tests 'ascii 'mac 'undecided 'mac)) - (should-not (decoder-tests 'ascii 'mac 'mac 'mac)) - (should-not (decoder-tests 'ascii 'dos 'utf-8 'utf-8-dos)) - (should-not (decoder-tests 'ascii 'dos 'unix 'unix - 'decoder-tests-lf-to-crlf)) - (should-not (decoder-tests 'ascii 'mac 'dos 'dos - 'decoder-tests-lf-to-cr)) - (should-not (decoder-tests 'ascii 'dos 'mac 'mac - 'decoder-tests-lf-to-lflf))) - (decoder-tests-remove-files))) - -(ert-deftest ert-test-decoder-latin () - (unwind-protect - (progn - (dolist (coding '("utf-8" "utf-8-with-signature")) - (dolist (eol-type '("unix" "dos" "mac")) - (decoder-tests-ao-gen-file 'latin - (intern (concat coding "-" eol-type))))) - (should-not (decoder-tests 'latin 'utf-8-unix 'undecided 'utf-8-unix)) - (should-not (decoder-tests 'latin 'utf-8-unix 'utf-8-unix 'utf-8-unix)) - (should-not (decoder-tests 'latin 'utf-8-dos 'undecided 'utf-8-dos)) - (should-not (decoder-tests 'latin 'utf-8-dos 'utf-8-dos 'utf-8-dos)) - (should-not (decoder-tests 'latin 'utf-8-mac 'undecided 'utf-8-mac)) - (should-not (decoder-tests 'latin 'utf-8-mac 'utf-8-mac 'utf-8-mac)) - (should-not (decoder-tests 'latin 'utf-8-dos 'unix 'utf-8-unix - 'decoder-tests-lf-to-crlf)) - (should-not (decoder-tests 'latin 'utf-8-mac 'dos 'utf-8-dos - 'decoder-tests-lf-to-cr)) - (should-not (decoder-tests 'latin 'utf-8-dos 'mac 'utf-8-mac - 'decoder-tests-lf-to-lflf)) - (should-not (decoder-tests 'latin 'utf-8-with-signature-unix 'undecided - 'utf-8-with-signature-unix)) - (should-not (decoder-tests 'latin 'utf-8-with-signature-unix 'utf-8-auto - 'utf-8-with-signature-unix)) - (should-not (decoder-tests 'latin 'utf-8-with-signature-dos 'undecided - 'utf-8-with-signature-dos)) - (should-not (decoder-tests 'latin 'utf-8-with-signature-unix 'utf-8 - 'utf-8-unix 'decoder-tests-add-bom)) - (should-not (decoder-tests 'latin 'utf-8-with-signature-unix 'utf-8 - 'utf-8-unix 'decoder-tests-add-bom))) - (decoder-tests-remove-files))) - -(ert-deftest ert-test-decoder-binary () - (unwind-protect - (progn - (dolist (eol-type '("unix" "dos" "mac")) - (decoder-tests-ao-gen-file 'binary - (intern (concat "raw-text" "-" eol-type)))) - (should-not (decoder-tests 'binary 'raw-text-unix 'undecided - 'raw-text-unix)) - (should-not (decoder-tests 'binary 'raw-text-dos 'undecided - 'raw-text-dos)) - (should-not (decoder-tests 'binary 'raw-text-mac 'undecided - 'raw-text-mac)) - (should-not (decoder-tests 'binary 'raw-text-dos 'unix - 'raw-text-unix 'decoder-tests-lf-to-crlf)) - (should-not (decoder-tests 'binary 'raw-text-mac 'dos - 'raw-text-dos 'decoder-tests-lf-to-cr)) - (should-not (decoder-tests 'binary 'raw-text-dos 'mac - 'raw-text-mac 'decoder-tests-lf-to-lflf))) - (decoder-tests-remove-files))) - - -;;; Check the coding system `prefer-utf-8'. - -;; Read FILE. Check if the encoding was detected as DETECT. If -;; PREFER is non-nil, prefer that coding system before reading. - -(defun decoder-tests-prefer-utf-8-read (file detect prefer) - (with-temp-buffer - (with-coding-priority (if prefer (list prefer)) - (insert-file-contents file)) - (if (eq buffer-file-coding-system detect) - nil - (format "Invalid detection: %s" buffer-file-coding-system)))) - -;; Read FILE, modify it, and write it. Check if the coding system -;; used for writing was CODING. If CODING-TAG is non-nil, insert -;; coding tag with it before writing. If STR is non-nil, insert it -;; before writing. - -(defun decoder-tests-prefer-utf-8-write (file coding-tag coding - &optional str) - (with-temp-buffer - (insert-file-contents file) - (goto-char (point-min)) - (if coding-tag - (insert (format ";; -*- coding: %s; -*-\n" coding-tag)) - (insert ";;\n")) - (if str - (insert str)) - (write-file (decoder-tests-filename 'test 'test "el")) - (if (coding-system-equal buffer-file-coding-system coding) - nil - (format "Incorrect encoding: %s" last-coding-system-used)))) - -(ert-deftest ert-test-decoder-prefer-utf-8 () - (unwind-protect - (let ((ascii (decoder-tests-gen-file "ascii.el" - (decoder-tests-file-contents 'ascii) - 'unix)) - (latin (decoder-tests-gen-file "utf-8.el" - (decoder-tests-file-contents 'latin) - 'utf-8-unix))) - (should-not (decoder-tests-prefer-utf-8-read - ascii 'prefer-utf-8-unix nil)) - (should-not (decoder-tests-prefer-utf-8-read - latin 'utf-8-unix nil)) - (should-not (decoder-tests-prefer-utf-8-read - latin 'utf-8-unix 'iso-8859-1)) - (should-not (decoder-tests-prefer-utf-8-read - latin 'utf-8-unix 'sjis)) - (should-not (decoder-tests-prefer-utf-8-write - ascii nil 'prefer-utf-8-unix)) - (should-not (decoder-tests-prefer-utf-8-write - ascii 'iso-8859-1 'iso-8859-1-unix)) - (should-not (decoder-tests-prefer-utf-8-write - ascii nil 'utf-8-unix "À"))) - (decoder-tests-remove-files))) - - -;;; The following is for benchmark testing of the new optimized -;;; decoder, not for regression testing. - -(defun generate-ascii-file () - (dotimes (i 100000) - (insert-char ?a 80) - (insert "\n"))) - -(defun generate-rarely-nonascii-file () - (dotimes (i 100000) - (if (/= i 50000) - (insert-char ?a 80) - (insert ?À) - (insert-char ?a 79)) - (insert "\n"))) - -(defun generate-mostly-nonascii-file () - (dotimes (i 30000) - (insert-char ?a 80) - (insert "\n")) - (dotimes (i 20000) - (insert-char ?À 80) - (insert "\n")) - (dotimes (i 10000) - (insert-char ?あ 80) - (insert "\n"))) - - -(defvar test-file-list - '((generate-ascii-file - ("~/ascii-tag-utf-8-unix.unix" ";; -*- coding: utf-8-unix; -*-" unix) - ("~/ascii-tag-utf-8.unix" ";; -*- coding: utf-8; -*-" unix) - ("~/ascii-tag-none.unix" "" unix) - ("~/ascii-tag-utf-8-dos.dos" ";; -*- coding: utf-8-dos; -*-" dos) - ("~/ascii-tag-utf-8.dos" ";; -*- coding: utf-8; -*-" dos) - ("~/ascii-tag-none.dos" "" dos)) - (generate-rarely-nonascii-file - ("~/utf-8-r-tag-utf-8-unix.unix" ";; -*- coding: utf-8-unix; -*-" utf-8-unix) - ("~/utf-8-r-tag-utf-8.unix" ";; -*- coding: utf-8; -*-" utf-8-unix) - ("~/utf-8-r-tag-none.unix" "" utf-8-unix) - ("~/utf-8-r-tag-utf-8-dos.dos" ";; -*- coding: utf-8-dos; -*-" utf-8-dos) - ("~/utf-8-r-tag-utf-8.dos" ";; -*- coding: utf-8; -*-" utf-8-dos) - ("~/utf-8-r-tag-none.dos" "" utf-8-dos)) - (generate-mostly-nonascii-file - ("~/utf-8-m-tag-utf-8-unix.unix" ";; -*- coding: utf-8-unix; -*-" utf-8-unix) - ("~/utf-8-m-tag-utf-8.unix" ";; -*- coding: utf-8; -*-" utf-8-unix) - ("~/utf-8-m-tag-none.unix" "" utf-8-unix) - ("~/utf-8-m-tag-utf-8-dos.dos" ";; -*- coding: utf-8-dos; -*-" utf-8-dos) - ("~/utf-8-m-tag-utf-8.dos" ";; -*- coding: utf-8; -*-" utf-8-dos) - ("~/utf-8-m-tag-none.dos" "" utf-8-dos)))) - -(defun generate-benchmark-test-file () - (interactive) - (with-temp-buffer - (message "Generating data...") - (dolist (files test-file-list) - (delete-region (point-min) (point-max)) - (funcall (car files)) - (dolist (file (cdr files)) - (message "Writing %s..." (car file)) - (goto-char (point-min)) - (insert (nth 1 file) "\n") - (let ((coding-system-for-write (nth 2 file))) - (write-region (point-min) (point-max) (car file))) - (delete-region (point-min) (point)))))) - -(defun benchmark-decoder () - (let ((gc-cons-threshold 4000000)) - (insert "Without optimization:\n") - (dolist (files test-file-list) - (dolist (file (cdr files)) - (let* ((disable-ascii-optimization t) - (result (benchmark-run 10 - (with-temp-buffer (insert-file-contents (car file)))))) - (insert (format "%s: %s\n" (car file) result))))) - (insert "With optimization:\n") - (dolist (files test-file-list) - (dolist (file (cdr files)) - (let* ((disable-ascii-optimization nil) - (result (benchmark-run 10 - (with-temp-buffer (insert-file-contents (car file)))))) - (insert (format "%s: %s\n" (car file) result))))))) diff --git a/test/src/coding-tests.el b/test/src/coding-tests.el index 772c873..bd494bc 100644 --- a/test/src/coding-tests.el +++ b/test/src/coding-tests.el @@ -1,8 +1,9 @@ ;;; coding-tests.el --- tests for text encoding and decoding -;; Copyright (C) 2015-2016 Free Software Foundation, Inc. +;; Copyright (C) 2013-2016 Free Software Foundation, Inc. ;; Author: Eli Zaretskii +;; Author: Kenichi Handa ;; This file is part of GNU Emacs. @@ -56,3 +57,327 @@ (insert (encode-coding-string "あ" 'euc-jp) "\xd" "\n") (decode-coding-region (point-min) (point-max) 'euc-jp-dos) (should-not (string-match-p "\^M" (buffer-string))))) + +;; Return the contents (specified by CONTENT-TYPE; ascii, latin, or +;; binary) of a test file. +(defun coding-tests-file-contents (content-type) + (let* ((ascii "ABCDEFGHIJKLMNOPQRSTUVWXYZ\n") + (latin (concat ascii "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏ\n")) + (binary (string-to-multibyte + (concat (string-as-unibyte latin) + (unibyte-string #xC0 #xC1 ?\n))))) + (cond ((eq content-type 'ascii) ascii) + ((eq content-type 'latin) latin) + ((eq content-type 'binary) binary) + (t + (error "Invalid file content type: %s" content-type))))) + +;; Generate FILE with CONTENTS encoded by CODING-SYSTEM. +;; whose encoding specified by CODING-SYSTEM. +(defun coding-tests-gen-file (file contents coding-system) + (or (file-directory-p coding-tests-workdir) + (mkdir coding-tests-workdir t)) + (setq file (expand-file-name file coding-tests-workdir)) + (with-temp-file file + (set-buffer-file-coding-system coding-system) + (insert contents)) + file) + +;;; The following three functions are filters for contents of a test +;;; file. + +;; Convert all LFs to CR LF sequences in the string STR. +(defun coding-tests-lf-to-crlf (str) + (with-temp-buffer + (insert str) + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (delete-char -1) + (insert "\r\n")) + (buffer-string))) + +;; Convert all LFs to CRs in the string STR. +(defun coding-tests-lf-to-cr (str) + (with-temp-buffer + (insert str) + (subst-char-in-region (point-min) (point-max) ?\n ?\r) + (buffer-string))) + +;; Convert all LFs to LF LF sequences in the string STR. +(defun coding-tests-lf-to-lflf (str) + (with-temp-buffer + (insert str) + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (insert "\n")) + (buffer-string))) + +;; Prepend the UTF-8 BOM to STR. +(defun coding-tests-add-bom (str) + (concat "\xfeff" str)) + +;; Return the name of test file whose contents specified by +;; CONTENT-TYPE and whose encoding specified by CODING-SYSTEM. +(defun coding-tests-filename (content-type coding-system &optional ext) + (if ext + (expand-file-name (format "%s-%s.%s" content-type coding-system ext) + coding-tests-workdir) + (expand-file-name (format "%s-%s" content-type coding-system) + coding-tests-workdir))) + + +;;; Check ASCII optimizing decoder + +;; Generate a test file whose contents specified by CONTENT-TYPE and +;; whose encoding specified by CODING-SYSTEM. +(defun coding-tests-ao-gen-file (content-type coding-system) + (let ((file (coding-tests-filename content-type coding-system))) + (coding-tests-gen-file file + (coding-tests-file-contents content-type) + coding-system))) + +;; Test the decoding of a file whose contents and encoding are +;; specified by CONTENT-TYPE and WRITE-CODING. The test passes if the +;; file is read by READ-CODING and detected as DETECTED-CODING and the +;; contents is correctly decoded. +;; Optional 5th arg TRANSLATOR is a function to translate the original +;; file contents to match with the expected result of decoding. For +;; instance, when a file of dos eol-type is read by unix eol-type, +;; `decode-test-lf-to-crlf' must be specified. + +(defun coding-tests (content-type write-coding read-coding detected-coding + &optional translator) + (prefer-coding-system 'utf-8-auto) + (let ((filename (coding-tests-filename content-type write-coding))) + (with-temp-buffer + (let ((coding-system-for-read read-coding) + (contents (coding-tests-file-contents content-type)) + (disable-ascii-optimization nil)) + (if translator + (setq contents (funcall translator contents))) + (insert-file-contents filename) + (if (and (coding-system-equal buffer-file-coding-system detected-coding) + (string= (buffer-string) contents)) + nil + (list buffer-file-coding-system + (string-to-list (buffer-string)) + (string-to-list contents))))))) + +(ert-deftest ert-test-coding-ascii () + (unwind-protect + (progn + (dolist (eol-type '(unix dos mac)) + (coding-tests-ao-gen-file 'ascii eol-type)) + (should-not (coding-tests 'ascii 'unix 'undecided 'unix)) + (should-not (coding-tests 'ascii 'dos 'undecided 'dos)) + (should-not (coding-tests 'ascii 'dos 'dos 'dos)) + (should-not (coding-tests 'ascii 'mac 'undecided 'mac)) + (should-not (coding-tests 'ascii 'mac 'mac 'mac)) + (should-not (coding-tests 'ascii 'dos 'utf-8 'utf-8-dos)) + (should-not (coding-tests 'ascii 'dos 'unix 'unix + 'coding-tests-lf-to-crlf)) + (should-not (coding-tests 'ascii 'mac 'dos 'dos + 'coding-tests-lf-to-cr)) + (should-not (coding-tests 'ascii 'dos 'mac 'mac + 'coding-tests-lf-to-lflf))) + (coding-tests-remove-files))) + +(ert-deftest ert-test-coding-latin () + (unwind-protect + (progn + (dolist (coding '("utf-8" "utf-8-with-signature")) + (dolist (eol-type '("unix" "dos" "mac")) + (coding-tests-ao-gen-file 'latin + (intern (concat coding "-" eol-type))))) + (should-not (coding-tests 'latin 'utf-8-unix 'undecided 'utf-8-unix)) + (should-not (coding-tests 'latin 'utf-8-unix 'utf-8-unix 'utf-8-unix)) + (should-not (coding-tests 'latin 'utf-8-dos 'undecided 'utf-8-dos)) + (should-not (coding-tests 'latin 'utf-8-dos 'utf-8-dos 'utf-8-dos)) + (should-not (coding-tests 'latin 'utf-8-mac 'undecided 'utf-8-mac)) + (should-not (coding-tests 'latin 'utf-8-mac 'utf-8-mac 'utf-8-mac)) + (should-not (coding-tests 'latin 'utf-8-dos 'unix 'utf-8-unix + 'coding-tests-lf-to-crlf)) + (should-not (coding-tests 'latin 'utf-8-mac 'dos 'utf-8-dos + 'coding-tests-lf-to-cr)) + (should-not (coding-tests 'latin 'utf-8-dos 'mac 'utf-8-mac + 'coding-tests-lf-to-lflf)) + (should-not (coding-tests 'latin 'utf-8-with-signature-unix 'undecided + 'utf-8-with-signature-unix)) + (should-not (coding-tests 'latin 'utf-8-with-signature-unix 'utf-8-auto + 'utf-8-with-signature-unix)) + (should-not (coding-tests 'latin 'utf-8-with-signature-dos 'undecided + 'utf-8-with-signature-dos)) + (should-not (coding-tests 'latin 'utf-8-with-signature-unix 'utf-8 + 'utf-8-unix 'coding-tests-add-bom)) + (should-not (coding-tests 'latin 'utf-8-with-signature-unix 'utf-8 + 'utf-8-unix 'coding-tests-add-bom))) + (coding-tests-remove-files))) + +(ert-deftest ert-test-coding-binary () + (unwind-protect + (progn + (dolist (eol-type '("unix" "dos" "mac")) + (coding-tests-ao-gen-file 'binary + (intern (concat "raw-text" "-" eol-type)))) + (should-not (coding-tests 'binary 'raw-text-unix 'undecided + 'raw-text-unix)) + (should-not (coding-tests 'binary 'raw-text-dos 'undecided + 'raw-text-dos)) + (should-not (coding-tests 'binary 'raw-text-mac 'undecided + 'raw-text-mac)) + (should-not (coding-tests 'binary 'raw-text-dos 'unix + 'raw-text-unix 'coding-tests-lf-to-crlf)) + (should-not (coding-tests 'binary 'raw-text-mac 'dos + 'raw-text-dos 'coding-tests-lf-to-cr)) + (should-not (coding-tests 'binary 'raw-text-dos 'mac + 'raw-text-mac 'coding-tests-lf-to-lflf))) + (coding-tests-remove-files))) + + +;;; Check the coding system `prefer-utf-8'. + +;; Read FILE. Check if the encoding was detected as DETECT. If +;; PREFER is non-nil, prefer that coding system before reading. + +(defun coding-tests-prefer-utf-8-read (file detect prefer) + (with-temp-buffer + (with-coding-priority (if prefer (list prefer)) + (insert-file-contents file)) + (if (eq buffer-file-coding-system detect) + nil + (format "Invalid detection: %s" buffer-file-coding-system)))) + +;; Read FILE, modify it, and write it. Check if the coding system +;; used for writing was CODING. If CODING-TAG is non-nil, insert +;; coding tag with it before writing. If STR is non-nil, insert it +;; before writing. + +(defun coding-tests-prefer-utf-8-write (file coding-tag coding + &optional str) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (if coding-tag + (insert (format ";; -*- coding: %s; -*-\n" coding-tag)) + (insert ";;\n")) + (if str + (insert str)) + (write-file (coding-tests-filename 'test 'test "el")) + (if (coding-system-equal buffer-file-coding-system coding) + nil + (format "Incorrect encoding: %s" last-coding-system-used)))) + +(ert-deftest ert-test-coding-prefer-utf-8 () + (unwind-protect + (let ((ascii (coding-tests-gen-file "ascii.el" + (coding-tests-file-contents 'ascii) + 'unix)) + (latin (coding-tests-gen-file "utf-8.el" + (coding-tests-file-contents 'latin) + 'utf-8-unix))) + (should-not (coding-tests-prefer-utf-8-read + ascii 'prefer-utf-8-unix nil)) + (should-not (coding-tests-prefer-utf-8-read + latin 'utf-8-unix nil)) + (should-not (coding-tests-prefer-utf-8-read + latin 'utf-8-unix 'iso-8859-1)) + (should-not (coding-tests-prefer-utf-8-read + latin 'utf-8-unix 'sjis)) + (should-not (coding-tests-prefer-utf-8-write + ascii nil 'prefer-utf-8-unix)) + (should-not (coding-tests-prefer-utf-8-write + ascii 'iso-8859-1 'iso-8859-1-unix)) + (should-not (coding-tests-prefer-utf-8-write + ascii nil 'utf-8-unix "À"))) + (coding-tests-remove-files))) + + +;;; The following is for benchmark testing of the new optimized +;;; decoder, not for regression testing. + +(defun generate-ascii-file () + (dotimes (i 100000) + (insert-char ?a 80) + (insert "\n"))) + +(defun generate-rarely-nonascii-file () + (dotimes (i 100000) + (if (/= i 50000) + (insert-char ?a 80) + (insert ?À) + (insert-char ?a 79)) + (insert "\n"))) + +(defun generate-mostly-nonascii-file () + (dotimes (i 30000) + (insert-char ?a 80) + (insert "\n")) + (dotimes (i 20000) + (insert-char ?À 80) + (insert "\n")) + (dotimes (i 10000) + (insert-char ?あ 80) + (insert "\n"))) + + +(defvar test-file-list + '((generate-ascii-file + ("~/ascii-tag-utf-8-unix.unix" ";; -*- coding: utf-8-unix; -*-" unix) + ("~/ascii-tag-utf-8.unix" ";; -*- coding: utf-8; -*-" unix) + ("~/ascii-tag-none.unix" "" unix) + ("~/ascii-tag-utf-8-dos.dos" ";; -*- coding: utf-8-dos; -*-" dos) + ("~/ascii-tag-utf-8.dos" ";; -*- coding: utf-8; -*-" dos) + ("~/ascii-tag-none.dos" "" dos)) + (generate-rarely-nonascii-file + ("~/utf-8-r-tag-utf-8-unix.unix" ";; -*- coding: utf-8-unix; -*-" utf-8-unix) + ("~/utf-8-r-tag-utf-8.unix" ";; -*- coding: utf-8; -*-" utf-8-unix) + ("~/utf-8-r-tag-none.unix" "" utf-8-unix) + ("~/utf-8-r-tag-utf-8-dos.dos" ";; -*- coding: utf-8-dos; -*-" utf-8-dos) + ("~/utf-8-r-tag-utf-8.dos" ";; -*- coding: utf-8; -*-" utf-8-dos) + ("~/utf-8-r-tag-none.dos" "" utf-8-dos)) + (generate-mostly-nonascii-file + ("~/utf-8-m-tag-utf-8-unix.unix" ";; -*- coding: utf-8-unix; -*-" utf-8-unix) + ("~/utf-8-m-tag-utf-8.unix" ";; -*- coding: utf-8; -*-" utf-8-unix) + ("~/utf-8-m-tag-none.unix" "" utf-8-unix) + ("~/utf-8-m-tag-utf-8-dos.dos" ";; -*- coding: utf-8-dos; -*-" utf-8-dos) + ("~/utf-8-m-tag-utf-8.dos" ";; -*- coding: utf-8; -*-" utf-8-dos) + ("~/utf-8-m-tag-none.dos" "" utf-8-dos)))) + +(defun generate-benchmark-test-file () + (interactive) + (with-temp-buffer + (message "Generating data...") + (dolist (files test-file-list) + (delete-region (point-min) (point-max)) + (funcall (car files)) + (dolist (file (cdr files)) + (message "Writing %s..." (car file)) + (goto-char (point-min)) + (insert (nth 1 file) "\n") + (let ((coding-system-for-write (nth 2 file))) + (write-region (point-min) (point-max) (car file))) + (delete-region (point-min) (point)))))) + +(defun benchmark-decoder () + (let ((gc-cons-threshold 4000000)) + (insert "Without optimization:\n") + (dolist (files test-file-list) + (dolist (file (cdr files)) + (let* ((disable-ascii-optimization t) + (result (benchmark-run 10 + (with-temp-buffer (insert-file-contents (car file)))))) + (insert (format "%s: %s\n" (car file) result))))) + (insert "With optimization:\n") + (dolist (files test-file-list) + (dolist (file (cdr files)) + (let* ((disable-ascii-optimization nil) + (result (benchmark-run 10 + (with-temp-buffer (insert-file-contents (car file)))))) + (insert (format "%s: %s\n" (car file) result))))))) + +;; Local Variables: +;; byte-compile-warnings: (not obsolete) +;; End: + +(provide 'coding-tests) +;; coding-tests.el ends here commit 3facefd162c7fdd20cbac97d2f6d34e74216eb35 Author: Eli Zaretskii Date: Sat Sep 24 12:04:55 2016 +0300 ; * test/src/coding-tests.el: Moved from test/lisp/legacy/. diff --git a/test/lisp/legacy/coding-tests.el b/test/src/coding-tests.el similarity index 100% rename from test/lisp/legacy/coding-tests.el rename to test/src/coding-tests.el commit c5e71d574a22ab644801240badcfc63cdd9473e5 Author: Eli Zaretskii Date: Sat Sep 24 12:01:44 2016 +0300 ; * test/lisp/emacs-lisp/bytecomp-tests.el: Fix header and 'provide'. diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 1e076a7..8847c1b5 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -1,4 +1,4 @@ -;;; bytecomp-testsuite.el +;;; bytecomp-tests.el ;; Copyright (C) 2008-2016 Free Software Foundation, Inc. @@ -425,4 +425,5 @@ Subtests signal errors if something goes wrong." ;; no-byte-compile: t ;; End: -(provide 'byte-opt-testsuite) +(provide 'bytecomp-tests) +;; bytecomp-tests.el ends here. commit 57b07f7a8aee17f1162a04ba5d9772bdf97c889f Author: Eli Zaretskii Date: Sat Sep 24 11:59:42 2016 +0300 ; * test/lisp/emacs-lisp/bytecomp-tests.el: Moved from test/lisp/. diff --git a/test/lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el similarity index 100% rename from test/lisp/bytecomp-tests.el rename to test/lisp/emacs-lisp/bytecomp-tests.el commit 90351d98b6ebc079e81c7a788c0e7fe66c888f2b Author: Eli Zaretskii Date: Sat Sep 24 11:55:03 2016 +0300 ; * test/lisp/bytecomp-tests.el: Moved from test/lisp/legacy/. diff --git a/test/lisp/legacy/bytecomp-tests.el b/test/lisp/bytecomp-tests.el similarity index 99% rename from test/lisp/legacy/bytecomp-tests.el rename to test/lisp/bytecomp-tests.el index 48211f0..1e076a7 100644 --- a/test/lisp/legacy/bytecomp-tests.el +++ b/test/lisp/bytecomp-tests.el @@ -426,4 +426,3 @@ Subtests signal errors if something goes wrong." ;; End: (provide 'byte-opt-testsuite) -