diff options
| author | Stefan Monnier <monnier@iro.umontreal.ca> | 2022-09-25 16:15:16 -0400 |
|---|---|---|
| committer | Stefan Monnier <monnier@iro.umontreal.ca> | 2022-09-25 16:15:16 -0400 |
| commit | 650c20f1ca4e07591a727e1cfcc74b3363d15985 (patch) | |
| tree | 85d11f6437cde22f410c25e0e5f71a3131ebd07d /test/lisp/emacs-lisp | |
| parent | 8869332684c2302b5ba1ead4568bbc7ba1c0183e (diff) | |
| parent | 4b85ae6a24380fb67a3315eaec9233f17a872473 (diff) | |
| download | emacs-650c20f1ca4e07591a727e1cfcc74b3363d15985.tar.gz emacs-650c20f1ca4e07591a727e1cfcc74b3363d15985.tar.bz2 emacs-650c20f1ca4e07591a727e1cfcc74b3363d15985.zip | |
Merge 'master' into noverlay
Diffstat (limited to 'test/lisp/emacs-lisp')
152 files changed, 11462 insertions, 1654 deletions
diff --git a/test/lisp/emacs-lisp/backquote-tests.el b/test/lisp/emacs-lisp/backquote-tests.el new file mode 100644 index 00000000000..2ba61726f09 --- /dev/null +++ b/test/lisp/emacs-lisp/backquote-tests.el @@ -0,0 +1,47 @@ +;;; backquote-tests.el --- Tests for backquote.el -*- lexical-binding: t -*- + +;; Copyright (C) 2019-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) + +(ert-deftest backquote-test-basic () + (let ((lst '(ba bb bc)) + (vec [ba bb bc])) + (should (equal 3 `,(eval '(+ x y) '((x . 1) (y . 2))))) + (should (equal vec `[,@lst])) + (should (equal `(a lst c) '(a lst c))) + (should (equal `(a ,lst c) '(a (ba bb bc) c))) + (should (equal `(a ,@lst c) '(a ba bb bc c))) + ;; Vectors work just like lists. + (should (equal `(a vec c) '(a vec c))) + (should (equal `(a ,vec c) '(a [ba bb bc] c))) + (should (equal `(a ,@vec c) '(a ba bb bc c))))) + +(ert-deftest backquote-test-nested () + "Test nested backquotes." + (let ((lst '(ba bb bc)) + (vec [ba bb bc])) + (should (equal `(a ,`(,@lst) c) `(a ,lst c))) + (should (equal `(a ,`[,@lst] c) `(a ,vec c))) + (should (equal `(a ,@`[,@lst] c) `(a ,@lst c))))) + +;;; backquote-tests.el ends here diff --git a/test/lisp/emacs-lisp/backtrace-tests.el b/test/lisp/emacs-lisp/backtrace-tests.el new file mode 100644 index 00000000000..b42de06776b --- /dev/null +++ b/test/lisp/emacs-lisp/backtrace-tests.el @@ -0,0 +1,485 @@ +;;; backtrace-tests.el --- Tests for backtraces -*- lexical-binding: t; -*- + +;; Copyright (C) 2018-2022 Free Software Foundation, Inc. + +;; Author: Gemini Lasswell + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'backtrace) +(require 'ert) +(require 'ert-x) +(require 'seq) + +;; Delay evaluation of the backtrace-creating functions until +;; load so that the backtraces are the same whether this file +;; is compiled or not. + +(eval-and-compile + (defconst backtrace-tests--uncompiled-functions + '(progn + (defun backtrace-tests--make-backtrace (arg) + (backtrace-tests--setup-buffer)) + + (defun backtrace-tests--setup-buffer () + "Set up the current buffer in backtrace mode." + (backtrace-mode) + (setq backtrace-frames (backtrace-get-frames)) + (let ((this-index)) + ;; Discard all past `backtrace-tests--make-backtrace'. + (dotimes (index (length backtrace-frames)) + (when (eq (backtrace-frame-fun (nth index backtrace-frames)) + 'backtrace-tests--make-backtrace) + (setq this-index index))) + (setq backtrace-frames (seq-subseq backtrace-frames 0 (1+ this-index)))) + (backtrace-print)))) + + (eval backtrace-tests--uncompiled-functions t)) + +(defun backtrace-tests--backtrace-lines () + (if debugger-stack-frame-as-list + '(" (backtrace-get-frames)\n" + " (setq backtrace-frames (backtrace-get-frames))\n" + " (backtrace-tests--setup-buffer)\n" + " (backtrace-tests--make-backtrace %s)\n") + '(" backtrace-get-frames()\n" + " (setq backtrace-frames (backtrace-get-frames))\n" + " backtrace-tests--setup-buffer()\n" + " backtrace-tests--make-backtrace(%s)\n"))) + +(defconst backtrace-tests--line-count (length (backtrace-tests--backtrace-lines))) + +(defun backtrace-tests--backtrace-lines-with-locals () + (let ((lines (backtrace-tests--backtrace-lines)) + (locals '(" [no locals]\n" + " [no locals]\n" + " [no locals]\n" + " arg = %s\n"))) + (apply #'append (cl-mapcar #'list lines locals)))) + +(defun backtrace-tests--result (value) + (format (apply #'concat (backtrace-tests--backtrace-lines)) + (cl-prin1-to-string value))) + +(defun backtrace-tests--result-with-locals (value) + (let ((str (cl-prin1-to-string value))) + (format (apply #'concat (backtrace-tests--backtrace-lines-with-locals)) + str str))) + +;; TODO check that debugger-batch-max-lines still works + +(defconst backtrace-tests--header "Test header\n") +(defun backtrace-tests--insert-header () + (insert backtrace-tests--header)) + +;;; Tests + +(ert-deftest backtrace-tests--variables () + "Backtrace buffers can show and hide local variables." + (ert-with-test-buffer (:name "variables") + (let ((results (concat backtrace-tests--header + (backtrace-tests--result 'value))) + (last-frame (format (nth (1- backtrace-tests--line-count) + (backtrace-tests--backtrace-lines)) 'value)) + (last-frame-with-locals + (format (apply #'concat (nthcdr (* 2 (1- backtrace-tests--line-count)) + (backtrace-tests--backtrace-lines-with-locals))) + 'value 'value))) + (backtrace-tests--make-backtrace 'value) + (setq backtrace-insert-header-function #'backtrace-tests--insert-header) + (backtrace-print) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results)) + ;; Go to the last frame. + (goto-char (point-max)) + (forward-line -1) + ;; Turn on locals for that frame. + (backtrace-toggle-locals) + (should (string= (backtrace-tests--get-substring (point) (point-max)) + last-frame-with-locals)) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + (concat results + (format (car (last (backtrace-tests--backtrace-lines-with-locals))) + 'value)))) + ;; Turn off locals for that frame. + (backtrace-toggle-locals) + (should (string= (backtrace-tests--get-substring (point) (point-max)) + last-frame)) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results)) + ;; Turn all locals on. + (backtrace-toggle-locals '(4)) + (should (string= (backtrace-tests--get-substring (point) (point-max)) + last-frame-with-locals)) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + (concat backtrace-tests--header + (backtrace-tests--result-with-locals 'value)))) + ;; Turn all locals off. + (backtrace-toggle-locals '(4)) + (should (string= (backtrace-tests--get-substring + (point) (+ (point) (length last-frame))) + last-frame)) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results))))) + +(ert-deftest backtrace-tests--backward-frame () + "`backtrace-backward-frame' moves backward to the start of a frame." + (ert-with-test-buffer (:name "backward") + (let ((results (concat backtrace-tests--header + (backtrace-tests--result nil)))) + (backtrace-tests--make-backtrace nil) + (setq backtrace-insert-header-function #'backtrace-tests--insert-header) + (backtrace-print) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results)) + + ;; Try to move backward from header. + (goto-char (+ (point-min) (/ (length backtrace-tests--header) 2))) + (let ((pos (point))) + (should-error (backtrace-backward-frame)) + (should (= pos (point)))) + + ;; Try to move backward from start of first line. + (forward-line) + (let ((pos (point))) + (should-error (backtrace-backward-frame)) + (should (= pos (point)))) + + ;; Move backward from middle of line. + (let ((start (point))) + (forward-char (/ (length (nth 0 (backtrace-tests--backtrace-lines))) 2)) + (backtrace-backward-frame) + (should (= start (point)))) + + ;; Move backward from end of buffer. + (goto-char (point-max)) + (backtrace-backward-frame) + (let* ((last (format (car (last (backtrace-tests--backtrace-lines))) nil)) + (len (length last))) + (should (string= (buffer-substring-no-properties (point) (+ (point) len)) + last))) + + ;; Move backward from start of line. + (backtrace-backward-frame) + (let* ((line (car (last (backtrace-tests--backtrace-lines) 2))) + (len (length line))) + (should (string= (buffer-substring-no-properties (point) (+ (point) len)) + line)))))) + +(ert-deftest backtrace-tests--forward-frame () + "`backtrace-forward-frame' moves forward to the start of a frame." + (ert-with-test-buffer (:name "forward") + (let* ((arg '(1 2 3)) + (results (concat backtrace-tests--header + (backtrace-tests--result arg))) + (first-line (nth 0 (backtrace-tests--backtrace-lines)))) + (backtrace-tests--make-backtrace arg) + (setq backtrace-insert-header-function #'backtrace-tests--insert-header) + (backtrace-print) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results)) + ;; Move forward from header. + (goto-char (+ (point-min) (/ (length backtrace-tests--header) 2))) + (backtrace-forward-frame) + (should (string= (backtrace-tests--get-substring + (point) (+ (point) (length first-line))) + first-line)) + + (let ((start (point)) + (offset (/ (length first-line) 2)) + (second-line (nth 1 (backtrace-tests--backtrace-lines)))) + ;; Move forward from start of first frame. + (backtrace-forward-frame) + (should (string= (backtrace-tests--get-substring + (point) (+ (point) (length second-line))) + second-line)) + ;; Move forward from middle of first frame. + (goto-char (+ start offset)) + (backtrace-forward-frame) + (should (string= (backtrace-tests--get-substring + (point) (+ (point) (length second-line))) + second-line))) + ;; Try to move forward from middle of last frame. + (goto-char (- (point-max) + (/ 2 (length (car (last (backtrace-tests--backtrace-lines))))))) + (should-error (backtrace-forward-frame)) + ;; Try to move forward from end of buffer. + (goto-char (point-max)) + (should-error (backtrace-forward-frame))))) + +(ert-deftest backtrace-tests--single-and-multi-line () + "Forms in backtrace frames can be on a single line or on multiple lines." + (ert-with-test-buffer (:name "single-multi-line") + (let* ((arg '(lambda (x) ; Quote this so it isn't made into a closure. + (let ((number (1+ x))) + (+ x number)))) + (header-string "Test header: ") + (header (format "%s%s\n" header-string arg)) + (insert-header-function (lambda () + (insert header-string) + (insert (backtrace-print-to-string arg)) + (insert "\n"))) + (results (concat header (backtrace-tests--result arg))) + (last-line (format (nth (1- backtrace-tests--line-count) + (backtrace-tests--backtrace-lines)) + arg)) + (last-line-locals (format (nth (1- (* 2 backtrace-tests--line-count)) + (backtrace-tests--backtrace-lines-with-locals)) + arg))) + + (backtrace-tests--make-backtrace arg) + (setq backtrace-insert-header-function insert-header-function) + (backtrace-print) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results)) + ;; Check pp and collapse for the form in the header. + (goto-char (point-min)) + (backtrace-tests--verify-single-and-multi-line header) + ;; Check pp and collapse for the last frame. + (goto-char (point-max)) + (backtrace-backward-frame) + (backtrace-tests--verify-single-and-multi-line last-line) + ;; Check pp and collapse for local variables in the last line. + (goto-char (point-max)) + (backtrace-backward-frame) + (backtrace-toggle-locals) + (forward-line) + (backtrace-tests--verify-single-and-multi-line last-line-locals)))) + +(defun backtrace-tests--verify-single-and-multi-line (line) + "Verify that `backtrace-single-line' and `backtrace-multi-line' work at point. +Point should be at the beginning of a line, and LINE should be a +string containing the text of the line at point. Assume that the +line contains the strings \"lambda\" and \"number\"." + (let ((pos (point))) + (backtrace-multi-line) + ;; Verify point is still at the start of the line. + (should (= pos (point)))) + + ;; Verify the form now spans multiple lines. + (let ((pos (point))) + (search-forward "number") + (should-not (= pos (pos-bol)))) + ;; Collapse the form. + (backtrace-single-line) + ;; Verify that the form is now back on one line, + ;; and that point is at the same place. + (should (string= (backtrace-tests--get-substring + (- (point) 6) (point)) "number")) + (should-not (= (point) (pos-bol))) + (should (string= (backtrace-tests--get-substring + (pos-bol) (1+ (pos-eol))) + line))) + +(ert-deftest backtrace-tests--print-circle () + "Backtrace buffers can toggle `print-circle' syntax." + (ert-with-test-buffer (:name "print-circle") + (let* ((print-circle nil) + (arg (let ((val (make-list 5 'a))) (nconc val val) val)) + (results (backtrace-tests--make-regexp + (backtrace-tests--result arg))) + (results-circle (regexp-quote (let ((print-circle t)) + (backtrace-tests--result arg)))) + (last-frame (backtrace-tests--make-regexp + (format (nth (1- backtrace-tests--line-count) + (backtrace-tests--backtrace-lines)) + arg))) + (last-frame-circle (regexp-quote + (let ((print-circle t)) + (format (nth (1- backtrace-tests--line-count) + (backtrace-tests--backtrace-lines)) + arg))))) + (backtrace-tests--make-backtrace arg) + (backtrace-print) + (should (string-match-p results + (backtrace-tests--get-substring (point-min) (point-max)))) + ;; Go to the last frame. + (goto-char (point-max)) + (forward-line -1) + ;; Turn on print-circle for that frame. + (backtrace-toggle-print-circle) + (should (string-match-p last-frame-circle + (backtrace-tests--get-substring (point) (point-max)))) + ;; Turn off print-circle for the frame. + (backtrace-toggle-print-circle) + (should (string-match-p last-frame + (backtrace-tests--get-substring (point) (point-max)))) + (should (string-match-p results + (backtrace-tests--get-substring (point-min) (point-max)))) + ;; Turn print-circle on for the buffer. + (backtrace-toggle-print-circle '(4)) + (should (string-match-p last-frame-circle + (backtrace-tests--get-substring (point) (point-max)))) + (should (string-match-p results-circle + (backtrace-tests--get-substring (point-min) (point-max)))) + ;; Turn print-circle off. + (backtrace-toggle-print-circle '(4)) + (should (string-match-p last-frame + (backtrace-tests--get-substring + (point) (+ (point) (length last-frame))))) + (should (string-match-p results + (backtrace-tests--get-substring (point-min) (point-max))))))) + +(ert-deftest backtrace-tests--print-gensym () + "Backtrace buffers can toggle `print-gensym' syntax." + (ert-with-test-buffer (:name "print-gensym") + (let* ((print-gensym nil) + (arg (list (gensym "first") (gensym) (gensym "last"))) + (results (backtrace-tests--make-regexp + (backtrace-tests--result arg))) + (results-gensym (regexp-quote (let ((print-gensym t)) + (backtrace-tests--result arg)))) + (last-frame (backtrace-tests--make-regexp + (format (nth (1- backtrace-tests--line-count) + (backtrace-tests--backtrace-lines)) + arg))) + (last-frame-gensym (regexp-quote + (let ((print-gensym t)) + (format (nth (1- backtrace-tests--line-count) + (backtrace-tests--backtrace-lines)) + arg))))) + (backtrace-tests--make-backtrace arg) + (backtrace-print) + (should (string-match-p results + (backtrace-tests--get-substring (point-min) (point-max)))) + ;; Go to the last frame. + (goto-char (point-max)) + (forward-line -1) + ;; Turn on print-gensym for that frame. + (backtrace-toggle-print-gensym) + (should (string-match-p last-frame-gensym + (backtrace-tests--get-substring (point) (point-max)))) + ;; Turn off print-gensym for the frame. + (backtrace-toggle-print-gensym) + (should (string-match-p last-frame + (backtrace-tests--get-substring (point) (point-max)))) + (should (string-match-p results + (backtrace-tests--get-substring (point-min) (point-max)))) + ;; Turn print-gensym on for the buffer. + (backtrace-toggle-print-gensym '(4)) + (should (string-match-p last-frame-gensym + (backtrace-tests--get-substring (point) (point-max)))) + (should (string-match-p results-gensym + (backtrace-tests--get-substring (point-min) (point-max)))) + ;; Turn print-gensym off. + (backtrace-toggle-print-gensym '(4)) + (should (string-match-p last-frame + (backtrace-tests--get-substring + (point) (+ (point) (length last-frame))))) + (should (string-match-p results + (backtrace-tests--get-substring (point-min) (point-max))))))) + +(defun backtrace-tests--make-regexp (str) + "Make regexp from STR for `backtrace-tests--print-circle'. +Used for results of printing circular objects without +`print-circle' on. Look for #n in string STR where n is any +digit and replace with #[0-9]." + (let ((regexp (regexp-quote str))) + (with-temp-buffer + (insert regexp) + (goto-char (point-min)) + (while (re-search-forward "#[0-9]" nil t) + (replace-match "#[0-9]"))) + (buffer-string))) + +(ert-deftest backtrace-tests--expand-ellipsis () + "Backtrace buffers ellipsify large forms as buttons which expand the ellipses." + ;; make a backtrace with an ellipsis + ;; expand the ellipsis + (ert-with-test-buffer (:name "variables") + (let* ((print-level nil) + (print-length nil) + (backtrace-line-length 300) + (arg (make-list 40 (make-string 10 ?a))) + (results (backtrace-tests--result arg))) + (backtrace-tests--make-backtrace arg) + (backtrace-print) + + ;; There should be an ellipsis. Find and expand it. + (goto-char (point-min)) + (search-forward "...") + (backward-char) + (push-button) + + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results))))) + +(ert-deftest backtrace-tests--expand-ellipses () + "Backtrace buffers ellipsify large forms and can expand the ellipses." + (ert-with-test-buffer (:name "variables") + (let* ((print-level nil) + (print-length nil) + (backtrace-line-length 300) + (arg (let ((outer (make-list 40 (make-string 10 ?a))) + (nested (make-list 40 (make-string 10 ?b)))) + (setf (nth 39 nested) (make-list 40 (make-string 10 ?c))) + (setf (nth 39 outer) nested) + outer)) + (results (backtrace-tests--result-with-locals arg))) + + ;; Make a backtrace with local variables visible. + (backtrace-tests--make-backtrace arg) + (backtrace-print) + (backtrace-toggle-locals '(4)) + + ;; There should be two ellipses. + (goto-char (point-min)) + (should (search-forward "...")) + (should (search-forward "...")) + (should-error (search-forward "...")) + + ;; Expanding the last frame without argument should expand both + ;; ellipses, but the expansions will contain one ellipsis each. + (let ((buffer-len (- (point-max) (point-min)))) + (goto-char (point-max)) + (backtrace-backward-frame) + (backtrace-expand-ellipses) + (should (> (- (point-max) (point-min)) buffer-len)) + (goto-char (point-min)) + (should (search-forward "...")) + (should (search-forward "...")) + (should-error (search-forward "..."))) + + ;; Expanding with argument should remove all ellipses. + (goto-char (point-max)) + (backtrace-backward-frame) + (backtrace-expand-ellipses '(4)) + (goto-char (point-min)) + + (should-error (search-forward "...")) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results))))) + + +(ert-deftest backtrace-tests--to-string () + "Backtraces can be produced as strings." + (let ((frames (ert-with-test-buffer (:name nil) + (backtrace-tests--make-backtrace "string") + backtrace-frames))) + (should (string= (backtrace-to-string frames) + (backtrace-tests--result "string"))))) + +(defun backtrace-tests--get-substring (beg end) + "Return the visible text between BEG and END. +Strip the string properties because it makes failed test results +easier to read." + (substring-no-properties (filter-buffer-substring beg end))) + +(provide 'backtrace-tests) + +;;; backtrace-tests.el ends here diff --git a/test/lisp/emacs-lisp/benchmark-tests.el b/test/lisp/emacs-lisp/benchmark-tests.el index e1b67f1ed17..b3c4949acc7 100644 --- a/test/lisp/emacs-lisp/benchmark-tests.el +++ b/test/lisp/emacs-lisp/benchmark-tests.el @@ -1,6 +1,6 @@ ;;; benchmark-tests.el --- Test suite for benchmark. -*- lexical-binding: t -*- -;; Copyright (C) 2017 Free Software Foundation, Inc. +;; Copyright (C) 2017-2022 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -23,29 +23,37 @@ (require 'ert) (ert-deftest benchmark-tests () - (let (str t-long t-short) - (should (consp (benchmark-run nil (1+ 0)))) - (should (consp (benchmark-run 1 (1+ 0)))) + (let (str t-long t-short m) + (should (consp (benchmark-run nil (setq m (1+ 0))))) + (should (consp (benchmark-run 1 (setq m (1+ 0))))) (should (stringp (benchmark nil (1+ 0)))) (should (stringp (benchmark 1 (1+ 0)))) - (should (consp (benchmark-run-compiled nil (1+ 0)))) + (should (consp (benchmark-run-compiled (1+ 0)))) (should (consp (benchmark-run-compiled 1 (1+ 0)))) ;; First test is heavier, must need longer time. - (should (> (car (benchmark-run nil + (let ((count1 0) + (count2 0) + (repeat 2)) + (ignore (benchmark-run (setq count1 (1+ count1)))) + (ignore (benchmark-run repeat (setq count2 (1+ count2)))) + (should (> count2 count1))) + (should (> (car (benchmark-run (let ((n 100000)) (while (> n 1) (setq n (1- n)))))) - (car (benchmark-run nil (1+ 0))))) - (should (> (car (benchmark-run nil + (car (benchmark-run (setq m (1+ 0)))))) + (should (> (car (benchmark-run (let ((n 100000)) (while (> n 1) (setq n (1- n)))))) - (car (benchmark-run nil (1+ 0))))) - (should (> (car (benchmark-run-compiled nil + (car (benchmark-run (setq m (1+ 0)))))) + (should (> (car (benchmark-run-compiled (let ((n 100000)) (while (> n 1) (setq n (1- n)))))) - (car (benchmark-run-compiled nil (1+ 0))))) + (car (benchmark-run-compiled (1+ 0))))) (setq str (benchmark nil '(let ((n 100000)) (while (> n 1) (setq n (1- n)))))) (string-match "Elapsed time: \\([0-9.]+\\)" str) (setq t-long (string-to-number (match-string 1 str))) (setq str (benchmark nil '(1+ 0))) (string-match "Elapsed time: \\([0-9.]+\\)" str) (setq t-short (string-to-number (match-string 1 str))) - (should (> t-long t-short)))) + (should (> t-long t-short)) + ;; Silence compiler. + m)) ;;; benchmark-tests.el ends here. diff --git a/test/lisp/emacs-lisp/bindat-tests.el b/test/lisp/emacs-lisp/bindat-tests.el new file mode 100644 index 00000000000..0c03c51e2ef --- /dev/null +++ b/test/lisp/emacs-lisp/bindat-tests.el @@ -0,0 +1,285 @@ +;;; bindat-tests.el --- tests for bindat.el -*- lexical-binding: t -*- + +;; Copyright (C) 2019-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'bindat) +(require 'cl-lib) + +(bindat-defmacro ip () "An IPv4 address" '(vec 4 byte)) + +(defconst header-bindat-spec + (bindat-type + (dest-ip ip) + (src-ip ip) + (dest-port uint 16) + (src-port uint 16))) + +(defconst data-bindat-spec + (bindat-type + (type u8) + (opcode u8) + (length uint 16 'le) ;; little endian order + (id strz 8) + (data vec length) + (_ align 4))) + + +(defconst packet-bindat-spec + (bindat-type + (header type header-bindat-spec) + (items u8) + (_ fill 3) + (item repeat items + (_ type data-bindat-spec)))) + +(defconst struct-bindat + '((header + (dest-ip . [192 168 1 100]) + (src-ip . [192 168 1 101]) + (dest-port . 284) + (src-port . 5408)) + (items . 2) + (item ((type . 2) + (opcode . 3) + (length . 5) + (id . "ABCDEF") + (data . [1 2 3 4 5])) + ((type . 1) + (opcode . 4) + (length . 7) + (id . "BCDEFG") + (data . [6 7 8 9 10 11 12]))))) + +(ert-deftest bindat-test-pack () + (should (equal + (cl-map 'vector #'identity + (bindat-pack packet-bindat-spec struct-bindat)) + [ 192 168 1 100 192 168 1 101 01 28 21 32 2 0 0 0 + 2 3 5 0 ?A ?B ?C ?D ?E ?F 0 0 1 2 3 4 5 0 0 0 + 1 4 7 0 ?B ?C ?D ?E ?F ?G 0 0 6 7 8 9 10 11 12 0 ]))) + +(ert-deftest bindat-test-unpack () + (should (equal + (bindat-unpack packet-bindat-spec + (bindat-pack packet-bindat-spec struct-bindat)) + struct-bindat))) + +(ert-deftest bindat-test-pack/multibyte-string-fails () + (should-error (bindat-pack nil nil "ö"))) + +(ert-deftest bindat-test-unpack/multibyte-string-fails () + (should-error (bindat-unpack nil "ö"))) + +(ert-deftest bindat-test-format-vector () + (should (equal (bindat-format-vector [1 2 3] "%d" "x" 2) "1x2")) + (should (equal (bindat-format-vector [1 2 3] "%d" "x") "1x2x3"))) + +(ert-deftest bindat-test-vector-to-dec () + (should (equal (bindat-vector-to-dec [1 2 3]) "1.2.3")) + (should (equal (bindat-vector-to-dec [2048 1024 512] ".") "2048.1024.512"))) + +(ert-deftest bindat-test-vector-to-hex () + (should (equal (bindat-vector-to-hex [1 2 3]) "01:02:03")) + (should (equal (bindat-vector-to-hex [2048 1024 512] ".") "800.400.200"))) + +(ert-deftest bindat-test-ip-to-string () + (should (equal (bindat-ip-to-string [192 168 0 1]) "192.168.0.1")) + (should (equal (bindat-ip-to-string "\300\250\0\1") "192.168.0.1"))) + +(defconst bindat-test--int-websocket-type + (bindat-type + :pack-var value + (n1 u8 + :pack-val (if (< value 126) value (if (< value 65536) 126 127))) + (n2 uint (pcase n1 (127 64) (126 16) (_ 0)) + :pack-val value) + :unpack-val (if (< n1 126) n1 n2))) + +(ert-deftest bindat-test--pack-val () + ;; This is intended to test the :(un)pack-val feature that offers + ;; control over the unpacked representation of the data. + (dolist (n '(0 42 125 126 127 128 150 255 5000 65535 65536 8769786876)) + (should + (equal (bindat-unpack bindat-test--int-websocket-type + (bindat-pack bindat-test--int-websocket-type n)) + n)))) + +(ert-deftest bindat-test--sint () + (dotimes (kind 32) + (let ((bitlen (* 8 (/ kind 2))) + (r (zerop (% kind 2)))) + (dotimes (_ 100) + (let* ((n (random (ash 1 bitlen))) + (i (- n (ash 1 (1- bitlen)))) + (stype (bindat-type sint bitlen r)) + (utype (bindat-type if r (uintr bitlen) (uint bitlen)))) + (should (equal (bindat-unpack + stype + (bindat-pack stype i)) + i)) + (when (>= i 0) + (should (equal (bindat-pack utype i) + (bindat-pack stype i))) + (should (equal (bindat-unpack utype (bindat-pack stype i)) + i)))))))) + +(defconst bindat-test--LEB128 + (bindat-type + letrec ((loop + (struct :pack-var n + (head u8 + :pack-val (+ (logand n 127) (if (> n 127) 128 0))) + (tail if (< head 128) (unit 0) loop + :pack-val (ash n -7)) + :unpack-val (+ (logand head 127) (ash tail 7))))) + loop)) + +(ert-deftest bindat-test--recursive () + (dotimes (n 10) + (let ((max (ash 1 (* n 10)))) + (dotimes (_ 10) + (let ((n (random max))) + (should (equal (bindat-unpack bindat-test--LEB128 + (bindat-pack bindat-test--LEB128 n)) + n))))))) + +(ert-deftest bindat-test--str-strz-prealloc () + (dolist (tc `(((,(bindat-type str 1) "") . "xx") + ((,(bindat-type str 2) "") . "xx") + ((,(bindat-type str 2) "a") . "ax") + ((,(bindat-type str 2) "ab") . "ab") + ((,(bindat-type str 2) "abc") . "ab") + ((((x str 1)) ((x . ""))) . "xx") + ((((x str 2)) ((x . ""))) . "xx") + ((((x str 2)) ((x . "a"))) . "ax") + ((((x str 2)) ((x . "ab"))) . "ab") + ((((x str 2)) ((x . "abc"))) . "ab") + ((,(bindat-type strz 1) "") . "\0x") + ((,(bindat-type strz 2) "") . "\0x") + ((,(bindat-type strz 2) "a") . "a\0") + ((,(bindat-type strz 2) "ab") . "ab") + ((,(bindat-type strz 2) "abc") . "ab") + ((((x strz 1)) ((x . ""))) . "\0x") + ((((x strz 2)) ((x . ""))) . "\0x") + ((((x strz 2)) ((x . "a"))) . "a\0") + ((((x strz 2)) ((x . "ab"))) . "ab") + ((((x strz 2)) ((x . "abc"))) . "ab") + ((,(bindat-type strz) "") . "\0x") + ((,(bindat-type strz) "a") . "a\0"))) + (let ((prealloc (make-string 2 ?x))) + (apply #'bindat-pack (append (car tc) (list prealloc))) + (should (equal prealloc (cdr tc)))))) + +(ert-deftest bindat-test--str-strz-multibyte () + (dolist (spec (list (bindat-type str 2) + (bindat-type strz 2) + (bindat-type strz))) + (should (equal (bindat-pack spec (string-to-multibyte "x")) "x\0")) + (should (equal (bindat-pack spec (string-to-multibyte "\xff")) "\xff\0")) + (should-error (bindat-pack spec "💩")) + (should-error (bindat-pack spec "\N{U+ff}"))) + (dolist (spec (list '((x str 2)) '((x strz 2)))) + (should (equal (bindat-pack spec `((x . ,(string-to-multibyte "x")))) + "x\0")) + (should (equal (bindat-pack spec `((x . ,(string-to-multibyte "\xff")))) + "\xff\0")) + (should-error (bindat-pack spec '((x . "💩")))) + (should-error (bindat-pack spec '((x . "\N{U+ff}")))))) + +(let ((spec (bindat-type strz 2))) + (ert-deftest bindat-test--strz-fixedlen-len () + (should (equal (bindat-length spec "") 2)) + (should (equal (bindat-length spec "a") 2))) + + (ert-deftest bindat-test--strz-fixedlen-len-overflow () + (should (equal (bindat-length spec "ab") 2)) + (should (equal (bindat-length spec "abc") 2))) + + (ert-deftest bindat-test--strz-fixedlen-pack () + (should (equal (bindat-pack spec "") "\0\0")) + (should (equal (bindat-pack spec "a") "a\0"))) + + (ert-deftest bindat-test--strz-fixedlen-pack-overflow () + ;; This is not the only valid semantic, but it's the one we've + ;; offered historically. + (should (equal (bindat-pack spec "ab") "ab")) + (should (equal (bindat-pack spec "abc") "ab"))) + + (ert-deftest bindat-test--strz-fixedlen-unpack () + (should (equal (bindat-unpack spec "\0\0") "")) + (should (equal (bindat-unpack spec "\0X") "")) + (should (equal (bindat-unpack spec "a\0") "a")) + ;; Same comment as for b-t-s-f-pack-overflow. + (should (equal (bindat-unpack spec "ab") "ab")) + ;; Missing null terminator. + (should-error (bindat-unpack spec "")) + (should-error (bindat-unpack spec "a")))) + +(let ((spec (bindat-type strz))) + (ert-deftest bindat-test--strz-varlen-len () + (should (equal (bindat-length spec "") 1)) + (should (equal (bindat-length spec "abc") 4))) + + (ert-deftest bindat-test--strz-varlen-pack () + (should (equal (bindat-pack spec "") "\0")) + (should (equal (bindat-pack spec "abc") "abc\0")) + ;; Null bytes in the input string break unpacking. + (should-error (bindat-pack spec "\0")) + (should-error (bindat-pack spec "\0x")) + (should-error (bindat-pack spec "x\0")) + (should-error (bindat-pack spec "x\0y"))) + + (ert-deftest bindat-test--strz-varlen-unpack () + (should (equal (bindat-unpack spec "\0") "")) + (should (equal (bindat-unpack spec "abc\0") "abc")) + ;; Missing null terminator. + (should-error (bindat-unpack spec "")) + (should-error (bindat-unpack spec "a")))) + +(let ((spec '((x strz 2)))) + (ert-deftest bindat-test--strz-legacy-fixedlen-len () + (should (equal (bindat-length spec '((x . ""))) 2)) + (should (equal (bindat-length spec '((x . "a"))) 2))) + + (ert-deftest bindat-test--strz-legacy-fixedlen-len-overflow () + (should (equal (bindat-length spec '((x . "ab"))) 2)) + (should (equal (bindat-length spec '((x . "abc"))) 2))) + + (ert-deftest bindat-test--strz-legacy-fixedlen-pack () + (should (equal (bindat-pack spec '((x . ""))) "\0\0")) + (should (equal (bindat-pack spec '((x . "a"))) "a\0"))) + + (ert-deftest bindat-test--strz-legacy-fixedlen-pack-overflow () + ;; Same comment as for b-t-s-f-pack-overflow. + (should (equal (bindat-pack spec '((x . "ab"))) "ab")) + (should (equal (bindat-pack spec '((x . "abc"))) "ab"))) + + (ert-deftest bindat-test--strz-legacy-fixedlen-unpack () + (should (equal (bindat-unpack spec "\0\0") '((x . "")))) + (should (equal (bindat-unpack spec "\0X") '((x . "")))) + (should (equal (bindat-unpack spec "a\0") '((x . "a")))) + ;; Same comment as for b-t-s-f-pack-overflow. + (should (equal (bindat-unpack spec "ab") '((x . "ab")))) + ;; Missing null terminator. + (should-error (bindat-unpack spec "")) + (should-error (bindat-unpack spec "a")))) + +;;; bindat-tests.el ends here diff --git a/test/lisp/emacs-lisp/bytecomp-resources/bc-test-alpha.el b/test/lisp/emacs-lisp/bytecomp-resources/bc-test-alpha.el new file mode 100644 index 00000000000..6997d91b26a --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/bc-test-alpha.el @@ -0,0 +1,9 @@ +;;; -*- lexical-binding: t -*- + +(require 'bc-test-beta) + +(defun bc-test-alpha-f (x) + (let ((y nil)) + (list y (bc-test-beta-f x)))) + +(provide 'bc-test-alpha) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/bc-test-beta.el b/test/lisp/emacs-lisp/bytecomp-resources/bc-test-beta.el new file mode 100644 index 00000000000..9205a13d7d5 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/bc-test-beta.el @@ -0,0 +1,6 @@ +;;; -*- lexical-binding: t -*- + +(defsubst bc-test-beta-f (y) + y) + +(provide 'bc-test-beta) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-add-hook.el b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-add-hook.el new file mode 100644 index 00000000000..5f390898e6a --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-add-hook.el @@ -0,0 +1,4 @@ +;;; -*- lexical-binding: t; -*- +(let ((foo nil)) + (add-hook 'foo #'next-line) + foo) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-remove-hook.el b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-remove-hook.el new file mode 100644 index 00000000000..eaa625eba1c --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-remove-hook.el @@ -0,0 +1,4 @@ +;;; -*- lexical-binding: t; -*- +(let ((foo nil)) + (remove-hook 'foo #'next-line) + foo) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-run-hook-with-args-until-failure.el b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-run-hook-with-args-until-failure.el new file mode 100644 index 00000000000..7a116ad464b --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-run-hook-with-args-until-failure.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t; -*- +(let ((foo nil)) + (run-hook-with-args-until-failure 'foo)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-run-hook-with-args-until-success.el b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-run-hook-with-args-until-success.el new file mode 100644 index 00000000000..96d10a343df --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-run-hook-with-args-until-success.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t; -*- +(let ((foo nil)) + (run-hook-with-args-until-success 'foo #'next-line)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-run-hook-with-args.el b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-run-hook-with-args.el new file mode 100644 index 00000000000..bb9101bd070 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-run-hook-with-args.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t; -*- +(let ((foo nil)) + (run-hook-with-args 'foo)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-symbol-value.el b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-symbol-value.el new file mode 100644 index 00000000000..5f390898e6a --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-symbol-value.el @@ -0,0 +1,4 @@ +;;; -*- lexical-binding: t; -*- +(let ((foo nil)) + (add-hook 'foo #'next-line) + foo) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el b/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el new file mode 100644 index 00000000000..47481574ea8 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el @@ -0,0 +1,6 @@ +;; -*- lexical-binding: t; -*- + +(defsubst foo-inlineable (foo-var) + (+ foo-var 2)) + +(provide 'foo-inlinable) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/fun-attr-warn.el b/test/lisp/emacs-lisp/bytecomp-resources/fun-attr-warn.el new file mode 100644 index 00000000000..be907b32f47 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/fun-attr-warn.el @@ -0,0 +1,266 @@ +;;; -*- lexical-binding: t -*- + +;; Correct + +(defun faw-str-decl-code (x) + "something" + (declare (pure t)) + (print x)) + +(defun faw-doc-decl-code (x) + (:documentation "something") + (declare (pure t)) + (print x)) + +(defun faw-str-int-code (x) + "something" + (interactive "P") + (print x)) + +(defun faw-doc-int-code (x) + (:documentation "something") + (interactive "P") + (print x)) + +(defun faw-decl-int-code (x) + (declare (pure t)) + (interactive "P") + (print x)) + +(defun faw-str-decl-int-code (x) + "something" + (declare (pure t)) + (interactive "P") + (print x)) + +(defun faw-doc-decl-int-code (x) + (:documentation "something") + (declare (pure t)) + (interactive "P") + (print x)) + + +;; Correct (last string is return value) + +(defun faw-str () + "something") + +(defun faw-decl-str () + (declare (pure t)) + "something") + +(defun faw-decl-int-str () + (declare (pure t)) + (interactive) + "something") + +(defun faw-str-str () + "something" + "something else") + +(defun faw-doc-str () + (:documentation "something") + "something else") + + +;; Incorrect (bad order) + +(defun faw-int-decl-code (x) + (interactive "P") + (declare (pure t)) + (print x)) + +(defun faw-int-str-code (x) + (interactive "P") + "something" + (print x)) + +(defun faw-int-doc-code (x) + (interactive "P") + (:documentation "something") + (print x)) + +(defun faw-decl-str-code (x) + (declare (pure t)) + "something" + (print x)) + +(defun faw-decl-doc-code (x) + (declare (pure t)) + (:documentation "something") + (print x)) + +(defun faw-str-int-decl-code (x) + "something" + (interactive "P") + (declare (pure t)) + (print x)) + +(defun faw-doc-int-decl-code (x) + (:documentation "something") + (interactive "P") + (declare (pure t)) + (print x)) + +(defun faw-int-str-decl-code (x) + (interactive "P") + "something" + (declare (pure t)) + (print x)) + +(defun faw-int-doc-decl-code (x) + (interactive "P") + (:documentation "something") + (declare (pure t)) + (print x)) + +(defun faw-int-decl-str-code (x) + (interactive "P") + (declare (pure t)) + "something" + (print x)) + +(defun faw-int-decl-doc-code (x) + (interactive "P") + (declare (pure t)) + (:documentation "something") + (print x)) + +(defun faw-decl-int-str-code (x) + (declare (pure t)) + (interactive "P") + "something" + (print x)) + +(defun faw-decl-int-doc-code (x) + (declare (pure t)) + (interactive "P") + (:documentation "something") + (print x)) + +(defun faw-decl-str-int-code (x) + (declare (pure t)) + "something" + (interactive "P") + (print x)) + +(defun faw-decl-doc-int-code (x) + (declare (pure t)) + (:documentation "something") + (interactive "P") + (print x)) + + +;; Incorrect (duplication) + +(defun faw-str-str-decl-int-code (x) + "something" + "something else" + (declare (pure t)) + (interactive "P") + (print x)) + +(defun faw-str-doc-decl-int-code (x) + "something" + (:documentation "something else") + (declare (pure t)) + (interactive "P") + (print x)) + +(defun faw-doc-str-decl-int-code (x) + (:documentation "something") + "something else" + (declare (pure t)) + (interactive "P") + (print x)) + +(defun faw-doc-doc-decl-int-code (x) + (:documentation "something") + (:documentation "something else") + (declare (pure t)) + (interactive "P") + (print x)) + +(defun faw-str-decl-str-int-code (x) + "something" + (declare (pure t)) + "something else" + (interactive "P") + (print x)) + +(defun faw-doc-decl-str-int-code (x) + (:documentation "something") + (declare (pure t)) + "something else" + (interactive "P") + (print x)) + +(defun faw-str-decl-doc-int-code (x) + "something" + (declare (pure t)) + (:documentation "something else") + (interactive "P") + (print x)) + +(defun faw-doc-decl-doc-int-code (x) + (:documentation "something") + (declare (pure t)) + (:documentation "something else") + (interactive "P") + (print x)) + +(defun faw-str-decl-decl-int-code (x) + "something" + (declare (pure t)) + (declare (indent 1)) + (interactive "P") + (print x)) + +(defun faw-doc-decl-decl-int-code (x) + (:documentation "something") + (declare (pure t)) + (declare (indent 1)) + (interactive "P") + (print x)) + +(defun faw-str-decl-int-decl-code (x) + "something" + (declare (pure t)) + (interactive "P") + (declare (indent 1)) + (print x)) + +(defun faw-doc-decl-int-decl-code (x) + (:documentation "something") + (declare (pure t)) + (interactive "P") + (declare (indent 1)) + (print x)) + +(defun faw-str-decl-int-int-code (x) + "something" + (declare (pure t)) + (interactive "P") + (interactive "p") + (print x)) + +(defun faw-doc-decl-int-int-code (x) + (:documentation "something") + (declare (pure t)) + (interactive "P") + (interactive "p") + (print x)) + +(defun faw-str-int-decl-int-code (x) + "something" + (interactive "P") + (declare (pure t)) + (interactive "p") + (print x)) + +(defun faw-doc-int-decl-int-code (x) + (:documentation "something") + (interactive "P") + (declare (pure t)) + (interactive "p") + (print x)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/no-byte-compile.el b/test/lisp/emacs-lisp/bytecomp-resources/no-byte-compile.el new file mode 100644 index 00000000000..00ad1947507 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/no-byte-compile.el @@ -0,0 +1 @@ +;; -*- no-byte-compile: t; -*- diff --git a/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el b/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el new file mode 100644 index 00000000000..5582b2ab0ea --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el @@ -0,0 +1,17 @@ +;; -*- lexical-binding: t; -*- + +;; In this test, we try and make sure that inlined functions's code isn't +;; mistakenly re-interpreted in the caller's context: we import an +;; inlinable function from another file where `foo-var' is a normal +;; lexical variable, and then call(inline) it in a function where +;; `foo-var' is a dynamically-scoped variable. + +(require 'foo-inlinable + (expand-file-name "foo-inlinable.el" + (file-name-directory + (or byte-compile-current-file load-file-name)))) + +(defvar foo-var) + +(defun foo-fun () + (+ (foo-inlineable 5) 1)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-autoload-not-on-top-level.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-autoload-not-on-top-level.el new file mode 100644 index 00000000000..f193130c6ca --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-autoload-not-on-top-level.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (autoload 'bar "baz" nil nil 'macro)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-callargs-defsubst.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-callargs-defsubst.el new file mode 100644 index 00000000000..3a29128cf3a --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-callargs-defsubst.el @@ -0,0 +1,5 @@ +;;; -*- lexical-binding: t -*- +(defsubst warn-callargs-defsubst-f1 (_x) + nil) +(defun warn-callargs-defsubst-f2 () + (warn-callargs-defsubst-f1 1 2)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-callargs.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-callargs.el new file mode 100644 index 00000000000..687add380b9 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-callargs.el @@ -0,0 +1,5 @@ +;;; -*- lexical-binding: t -*- +(defun foo (_x) + nil) +(defun bar () + (foo 1 2)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-defcustom-nogroup.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-defcustom-nogroup.el new file mode 100644 index 00000000000..a67d4f041f3 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-defcustom-nogroup.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defcustom foo nil + :type 'boolean) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-defcustom-notype.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-defcustom-notype.el new file mode 100644 index 00000000000..c15ab9b192a --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-defcustom-notype.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defcustom foo nil + :group 'emacs) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-defvar-lacks-prefix.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-defvar-lacks-prefix.el new file mode 100644 index 00000000000..9f3cbb98900 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-defvar-lacks-prefix.el @@ -0,0 +1,2 @@ +;;; -*- lexical-binding: t -*- +(defvar foo nil) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-format.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-format.el new file mode 100644 index 00000000000..a1902bc03b0 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-format.el @@ -0,0 +1,2 @@ +;;; -*- lexical-binding: t -*- +(message "%s" 1 2) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-free-setq.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-free-setq.el new file mode 100644 index 00000000000..6e187129c9b --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-free-setq.el @@ -0,0 +1,2 @@ +;;; -*- lexical-binding: t -*- +(setq foo 'bar) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-free-variable-reference.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-free-variable-reference.el new file mode 100644 index 00000000000..50a95272874 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-free-variable-reference.el @@ -0,0 +1,4 @@ +;;; -*- lexical-binding: t -*- +(defvar xxx-test) +(defun foo () + (setq xxx-test bar)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-interactive-only.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-interactive-only.el new file mode 100644 index 00000000000..9e0c99bd30b --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-interactive-only.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (next-line)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-lambda-malformed-interactive-spec.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-lambda-malformed-interactive-spec.el new file mode 100644 index 00000000000..6bd902705ed --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-lambda-malformed-interactive-spec.el @@ -0,0 +1,4 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (interactive "foo" "bar") + nil) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-make-variable-buffer-local.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-variable-buffer-local.el new file mode 100644 index 00000000000..aa1e6c0463b --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-variable-buffer-local.el @@ -0,0 +1,4 @@ +;;; -*- lexical-binding: t -*- +(defvar foobar) +(defun foo () + (make-variable-buffer-local 'foobar)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-defun.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-defun.el new file mode 100644 index 00000000000..2a7af617ac9 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-defun.el @@ -0,0 +1,8 @@ +;;; -*- lexical-binding: t -*- + +(defun foo-obsolete () + (declare (obsolete nil "99.99")) + nil) + +(defun foo () + (foo-obsolete)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-hook.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-hook.el new file mode 100644 index 00000000000..078e6e4a3a9 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-hook.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (add-hook 'bytecomp--tests-obsolete-var #'next-line)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-variable-bound.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-variable-bound.el new file mode 100644 index 00000000000..e65a541e6e3 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-variable-bound.el @@ -0,0 +1,7 @@ +;;; -*- lexical-binding: t -*- + +(make-obsolete-variable 'bytecomp--tests-obsolete-var-2 nil "99.99") + +(defun foo () + (let ((bytecomp--tests-obsolete-var-2 2)) + bytecomp--tests-obsolete-var-2)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-variable-same-file.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-variable-same-file.el new file mode 100644 index 00000000000..31deb6155ba --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-variable-same-file.el @@ -0,0 +1,13 @@ +;;; -*- lexical-binding: t -*- + +(defvar foo-obsolete nil) +(make-obsolete-variable 'foo-obsolete nil "99.99") + +;; From bytecomp.el: +;; If foo.el declares `toto' as obsolete, it is likely that foo.el will +;; actually use `toto' in order for this obsolete variable to still work +;; correctly, so paradoxically, while byte-compiling foo.el, the presence +;; of a make-obsolete-variable call for `toto' is an indication that `toto' +;; should not trigger obsolete-warnings in foo.el. +(defun foo () + foo-obsolete) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-variable.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-variable.el new file mode 100644 index 00000000000..9a517cc6767 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-variable.el @@ -0,0 +1,4 @@ +;;; -*- lexical-binding: t -*- + +(defun foo () + bytecomp--tests-obsolete-var) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-redefine-defun-as-macro.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-redefine-defun-as-macro.el new file mode 100644 index 00000000000..6bd239b6598 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-redefine-defun-as-macro.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () nil) +(defmacro foo () t) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-redefine-defun.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-redefine-defun.el new file mode 100644 index 00000000000..53e4c0ac8de --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-redefine-defun.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () nil) +(defun foo () t) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-redefine-macro-as-defun.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-redefine-macro-as-defun.el new file mode 100644 index 00000000000..f71ae445615 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-redefine-macro-as-defun.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defmacro foo () t) +(defun foo () nil) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-save-excursion.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-save-excursion.el new file mode 100644 index 00000000000..38185457192 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-save-excursion.el @@ -0,0 +1,5 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (save-excursion + (set-buffer (current-buffer)) + nil)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-let-bind-constant.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-let-bind-constant.el new file mode 100644 index 00000000000..cc1fb572577 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-let-bind-constant.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (let ((t 1)) t)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-let-bind-nonvariable.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-let-bind-nonvariable.el new file mode 100644 index 00000000000..dde2dcee6e7 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-let-bind-nonvariable.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (let (('t 1)) t)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-set-constant.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-set-constant.el new file mode 100644 index 00000000000..2fc0680cfab --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-set-constant.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (setq t nil)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-setq-nonvariable.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-setq-nonvariable.el new file mode 100644 index 00000000000..5a56913cd9b --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-setq-nonvariable.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (setq (a) nil)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-setq-odd.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-setq-odd.el new file mode 100644 index 00000000000..9ce80de08cd --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-setq-odd.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo (a b) + (setq a 1 b)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-autoload.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-autoload.el new file mode 100644 index 00000000000..96deb1bbb0a --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-autoload.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(autoload 'foox "foo" + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-custom-declare-variable.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-custom-declare-variable.el new file mode 100644 index 00000000000..2a4700bfda5 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-custom-declare-variable.el @@ -0,0 +1,4 @@ +;;; -*- lexical-binding: t -*- +(custom-declare-variable + 'foo t + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defalias.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defalias.el new file mode 100644 index 00000000000..a4235d22bd3 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defalias.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defalias 'foo #'ignore + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defconst.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defconst.el new file mode 100644 index 00000000000..946f01989a0 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defconst.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defconst foo-bar nil + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-define-abbrev-table.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-define-abbrev-table.el new file mode 100644 index 00000000000..3da9ccd48c6 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-define-abbrev-table.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(define-abbrev-table 'foo () + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-define-obsolete-function-alias.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-define-obsolete-function-alias.el new file mode 100644 index 00000000000..fea841b12ec --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-define-obsolete-function-alias.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(define-obsolete-function-alias 'foo #'ignore "99.1" + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-define-obsolete-variable-alias.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-define-obsolete-variable-alias.el new file mode 100644 index 00000000000..2d5f201cb65 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-define-obsolete-variable-alias.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(define-obsolete-variable-alias 'foo 'ignore "99.1" + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defun.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defun.el new file mode 100644 index 00000000000..94b0e80c979 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defun.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defvar.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defvar.el new file mode 100644 index 00000000000..99aacd09cbd --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defvar.el @@ -0,0 +1,6 @@ +;;; -*- lexical-binding: t -*- +(defvar foo-bar nil + "multiline +foo +xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +bar") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defvaralias.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defvaralias.el new file mode 100644 index 00000000000..52fdc17f5bf --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defvaralias.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defvaralias 'foo-bar #'ignore + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-fill-column.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-fill-column.el new file mode 100644 index 00000000000..1ff554f3704 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-fill-column.el @@ -0,0 +1,7 @@ +;;; -*- lexical-binding: t -*- +(defvar foo-bar nil + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") + +;; Local Variables: +;; fill-column: 100 +;; End: diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-function-signature.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-function-signature.el new file mode 100644 index 00000000000..e83f516e58c --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-function-signature.el @@ -0,0 +1,4 @@ +;;; -*- lexical-binding: t -*- +(defun foo-bar () + "This should not warn: +(fn COMMAND &rest ARGS &key (MARGIN (rx bol (+ \" \"))) (ARGUMENT (rx \"-\" (+ (any \"-\" alnum)) (32 \"=\"))) (METAVAR (rx (32 \" \") (or (+ (any alnum \"_-\")) (seq \"[\" (+? nonl) \"]\") (seq \"<\" (+? nonl) \">\") (seq \"{\" (+? nonl) \"}\")))) (SEPARATOR (rx \", \" symbol-start)) (DESCRIPTION (rx (* nonl) (* \"\\=\\n\" (>= 9 \" \") (* nonl)))) NARROW-START NARROW-END)") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-override.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-override.el new file mode 100644 index 00000000000..0bcf7b1d63b --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-override.el @@ -0,0 +1,8 @@ +;;; -*- lexical-binding: t -*- +(defvar foo-bar nil + "123456789012345") + +;; Local Variables: +;; byte-compile-docstring-max-column: 10 +;; fill-column: 20 +;; End: diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-substitutions.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-substitutions.el new file mode 100644 index 00000000000..37cfe463bfe --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-substitutions.el @@ -0,0 +1,17 @@ +;;; -*- lexical-binding: t -*- +(defalias 'foo #'ignore + "None of this should be considered too wide. + +; this should be treated as 60 characters - no warning +\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window] + +; 64 * 'x' does not warn +\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x' + +; keymaps are just ignored +\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map> + +\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map} + +bar baz foo bar baz foo bar baz foo bar baz foo bar baz foo bar +") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore.el new file mode 100644 index 00000000000..c80ddd180d9 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore.el @@ -0,0 +1,7 @@ +;;; -*- lexical-binding: t -*- +(defvar foo-bar nil + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") + +;; Local Variables: +;; byte-compile-docstring-max-column: 100 +;; End: diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-multiline-first.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-multiline-first.el new file mode 100644 index 00000000000..2563dbbb3b9 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-multiline-first.el @@ -0,0 +1,5 @@ +;;; -*- lexical-binding: t -*- +(defvar foo-bar nil + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +This is a multiline docstring where the first line is long. +foobar") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-multiline.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-multiline.el new file mode 100644 index 00000000000..9ae7bc9b9f0 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-multiline.el @@ -0,0 +1,6 @@ +;;; -*- lexical-binding: t -*- +(defvar foo-bar nil + "This is a multiline docstring. +But it's not the first line that is long. +xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +foobar") diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 30d2a4753cf..e7c308213e4 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -1,6 +1,6 @@ -;;; bytecomp-tests.el +;;; bytecomp-tests.el --- Tests for bytecomp.el -*- lexical-binding:t -*- -;; Copyright (C) 2008-2017 Free Software Foundation, Inc. +;; Copyright (C) 2008-2022 Free Software Foundation, Inc. ;; Author: Shigeru Fukaya <shigeru.fukaya@gmail.com> ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> @@ -26,10 +26,42 @@ ;;; Commentary: (require 'ert) +(require 'ert-x) (require 'cl-lib) +(require 'subr-x) +(require 'bytecomp) ;;; Code: -(defconst byte-opt-testsuite-arith-data +(defvar bytecomp-test-var nil) + +(defun bytecomp-test-get-var () + bytecomp-test-var) + +(defun bytecomp-test-identity (x) + "Identity, but hidden from some optimizations." + x) + +(defmacro bytecomp-test-loop (outer1 outer2 inner1 inner2) + "Exercise constant propagation inside `while' loops. +OUTER1, OUTER2, INNER1 and INNER2 are forms placed in the outer and +inner loops respectively." + `(let ((x 1) (i 3) (res nil)) + (while (> i 0) + (let ((y 2) (j 2)) + (setq res (cons (list 'outer x y) res)) + (while (> j 0) + (setq res (cons (list 'inner x y) res)) + ,inner1 + ,inner2 + (setq j (1- j))) + ,outer1 + ,outer2) + (setq i (1- i))) + res)) + +(defvar bytecomp-tests--xx nil) + +(defconst bytecomp-tests--test-cases '( ;; some functional tests (let ((a most-positive-fixnum) (b 1) (c 1.0)) (+ a b c)) @@ -38,14 +70,18 @@ (let ((a 3) (b 2) (c 1.0)) (/ a b c)) (let ((a (+ 1 (expt 2 -64))) (b (expt 2 -65))) (+ a -1 b)) (let ((a (+ 1 (expt 2 -64))) (b (expt 2 -65))) (- a 1 (- b))) - ;; This fails. Should it be a bug? - ;; (let ((a (expt 2 -1074)) (b 0.125)) (* a 8 b)) + (let ((a (expt 2 -1074)) (b 0.125)) (* a 8 b)) (let ((a 1.0)) (* a 0)) (let ((a 1.0)) (* a 2.0 0)) (let ((a 1.0)) (/ 0 a)) (let ((a 1.0)) (/ 3 a 2)) (let ((a most-positive-fixnum) (b 2.0)) (* a 2 b)) (let ((a 3) (b 2)) (/ a b 1.0)) + (let ((a -0.0)) (+ a)) + (let ((a -0.0)) (- a)) + (let ((a -0.0)) (* a)) + (let ((a -0.0)) (min a)) + (let ((a -0.0)) (max a)) (/ 3 -1) (+ 4 3 2 1) (+ 4 3 2.0 1) @@ -244,6 +280,9 @@ (let ((a 3) (b 2) (c 1.0)) (/ a b c 0)) (let ((a 3) (b 2) (c 1.0)) (/ a b c 1)) (let ((a 3) (b 2) (c 1.0)) (/ a b c -1)) + + (let ((a t)) (logand 0 a)) + ;; Test switch bytecode (let ((a 3)) (cond ((eq a 1) 'one) ((eq a 2) 'two) ((eq a 3) 'three) (t t))) (let ((a 'three)) (cond ((eq a 'one) 1) ((eq a 2) 'two) ((eq a 'three) 3) @@ -286,90 +325,449 @@ (t))) (let ((a)) (cond ((eq a 'foo) 'incorrect) - ('correct)))) - "List of expression for test. -Each element will be executed by interpreter and with -bytecompiled code, and their results compared.") + ('correct))) + ;; Bug#31734 + (let ((variable 0)) + (cond + ((eq variable 'default) + (message "equal")) + (t + (message "not equal")))) + ;; Bug#35770 + (let ((x 'a)) (cond ((eq x 'a) 'correct) + ((eq x 'b) 'incorrect) + ((eq x 'a) 'incorrect) + ((eq x 'c) 'incorrect))) + (let ((x #x10000000000000000)) + (cond ((eql x #x10000000000000000) 'correct) + ((eql x #x10000000000000001) 'incorrect) + ((eql x #x10000000000000000) 'incorrect) + ((eql x #x10000000000000002) 'incorrect))) + (let ((x "a")) (cond ((equal x "a") 'correct) + ((equal x "b") 'incorrect) + ((equal x "a") 'incorrect) + ((equal x "c") 'incorrect))) + ;; Multi-value clauses + (mapcar (lambda (x) (cond ((eq x 'a) 11) + ((memq x '(b a c d)) 22) + ((eq x 'c) 33) + ((eq x 'e) 44) + ((memq x '(d f g)) 55) + (t 99))) + '(a b c d e f g h)) + (mapcar (lambda (x) (cond ((eql x 1) 11) + ((memq x '(a b c)) 22) + ((memql x '(2 1 4 1e-3)) 33) + ((eq x 'd) 44) + ((eql x #x10000000000000000)))) + '(1 2 4 1e-3 a b c d 1.0 #x10000000000000000)) + (mapcar (lambda (x) (cond ((eq x 'a) 11) + ((memq x '(b d)) 22) + ((equal x '(a . b)) 33) + ((member x '(b c 1.5 2.5 "X" (d))) 44) + ((eql x 3.14) 55) + ((memql x '(9 0.5 1.5 q)) 66) + (t 99))) + '(a b c d (d) (a . b) "X" 0.5 1.5 3.14 9 9.0)) + ;; Multi-switch cond form + (mapcar (lambda (p) (let ((x (car p)) (y (cadr p))) + (cond ((consp x) 11) + ((eq x 'a) 22) + ((memql x '(b 7 a -3)) 33) + ((equal y "a") 44) + ((memq y '(c d e)) 55) + ((booleanp x) 66) + ((eq x 'q) 77) + ((memq x '(r s)) 88) + ((eq x 't) 99) + (t 999)))) + '((a c) (b c) (7 c) (-3 c) (nil nil) (t c) (q c) (r c) (s c) + (t c) (x "a") (x "c") (x c) (x d) (x e))) -(defun bytecomp-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) - (error nil))) - (v1 (condition-case nil - (funcall (byte-compile (list 'lambda nil pat))) - (error nil)))) - (equal v0 v1))) - -(put 'bytecomp-check-1 'ert-explainer 'bytecomp-explain-1) - -(defun bytecomp-explain-1 (pat) - (let ((v0 (condition-case nil - (eval pat) - (error nil))) - (v1 (condition-case nil - (funcall (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-tests () - "Test the Emacs byte compiler." - (dolist (pat byte-opt-testsuite-arith-data) - (should (bytecomp-check-1 pat)))) - -(defun test-byte-opt-arithmetic (&optional arg) - "Unit test for byte-opt arithmetic operations. -Subtests signal errors if something goes wrong." - (interactive "P") - (switch-to-buffer (generate-new-buffer "*Font Pase Test*")) + (mapcar (lambda (x) (ignore-errors (cond ((member '(a . b) x) 1) + ((equal x '(c)) 2)))) + '(((a . b)) a b (c) (d))) + (mapcar (lambda (x) (ignore-errors (cond ((memq '(a . b) x) 1) + ((equal x '(c)) 2)))) + '(((a . b)) a b (c) (d))) + (mapcar (lambda (x) (ignore-errors (cond ((member '(a b) x) 1) + ((equal x '(c)) 2)))) + '(((a b)) a b (c) (d))) + (mapcar (lambda (x) (ignore-errors (cond ((memq '(a b) x) 1) + ((equal x '(c)) 2)))) + '(((a b)) a b (c) (d))) + + (assoc 'b '((a 1) (b 2) (c 3))) + (assoc "b" '(("a" 1) ("b" 2) ("c" 3))) + (let ((x '((a 1) (b 2) (c 3)))) (assoc 'c x)) + (assoc 'a '((a 1) (b 2) (c 3)) (lambda (u v) (not (equal u v)))) + + ;; Constprop test cases + (let ((a 'alpha) (b (concat "be" "ta")) (c nil) (d t) (e :gamma) + (f '(delta epsilon))) + (list a b c d e f)) + + (let ((x 1) (y (+ 3 4))) + (list + (let (q (y x) (z y)) + (if q x (list x y z))))) + + (let* ((x 3) (y (* x 2)) (x (1+ y))) + x) + + (let ((x 1) (bytecomp-test-var 2) (y 3)) + (list x bytecomp-test-var (bytecomp-test-get-var) y)) + + (progn + (defvar d) + (let ((x 'a) (y 'b)) (list x y))) + + (let ((x 2)) + (list x (setq x 13) (setq x (* x 2)) x)) + + (let ((x 'a) (y 'b)) + (setq y x + x (cons 'c y) + y x) + (list x y)) + + (let ((x 3)) + (let ((y x) z) + (setq x 5) + (setq y (+ y 8)) + (setq z (if (bytecomp-test-identity t) + (progn + (setq x (+ x 1)) + (list x y)) + (setq x (+ x 2)) + (list x y))) + (list x y z))) + + (let ((i 1) (s 0) (x 13)) + (while (< i 5) + (setq s (+ s i)) + (setq i (1+ i))) + (list s x i)) + + (let ((x 2)) + (list (or (bytecomp-test-identity 'a) (setq x 3)) x)) + + (mapcar (lambda (b) + (let ((a nil)) + (+ 0 + (progn + (setq a b) + (setq b 1) + a)))) + '(10)) + + (let* ((x 1) + (y (condition-case x + (/ 1 0) + (arith-error x)))) + (list x y)) + + (funcall + (condition-case x + (/ 1 0) + (arith-error (prog1 (lambda (y) (+ y x)) + (setq x 10)))) + 4) + + ;; Loop constprop: set the inner and outer variables in the inner + ;; and outer loops, all combinations. + (bytecomp-test-loop nil nil nil nil ) + (bytecomp-test-loop nil nil nil (setq x 6)) + (bytecomp-test-loop nil nil (setq x 5) nil ) + (bytecomp-test-loop nil nil (setq x 5) (setq x 6)) + (bytecomp-test-loop nil (setq x 4) nil nil ) + (bytecomp-test-loop nil (setq x 4) nil (setq x 6)) + (bytecomp-test-loop nil (setq x 4) (setq x 5) nil ) + (bytecomp-test-loop nil (setq x 4) (setq x 5) (setq x 6)) + (bytecomp-test-loop (setq x 3) nil nil nil ) + (bytecomp-test-loop (setq x 3) nil nil (setq x 6)) + (bytecomp-test-loop (setq x 3) nil (setq x 5) nil ) + (bytecomp-test-loop (setq x 3) nil (setq x 5) (setq x 6)) + (bytecomp-test-loop (setq x 3) (setq x 4) nil nil ) + (bytecomp-test-loop (setq x 3) (setq x 4) nil (setq x 6)) + (bytecomp-test-loop (setq x 3) (setq x 4) (setq x 5) nil ) + (bytecomp-test-loop (setq x 3) (setq x 4) (setq x 5) (setq x 6)) + + ;; No error, no success handler. + (condition-case x + (list 42) + (error (cons 'bad x))) + ;; Error, no success handler. + (condition-case x + (/ 1 0) + (error (cons 'bad x))) + ;; No error, success handler. + (condition-case x + (list 42) + (error (cons 'bad x)) + (:success (cons 'good x))) + ;; Error, success handler. + (condition-case x + (/ 1 0) + (error (cons 'bad x)) + (:success (cons 'good x))) + ;; Verify that the success code is not subject to the error handlers. + (condition-case x + (list 42) + (error (cons 'bad x)) + (:success (/ (car x) 0))) + ;; Check variable scoping on success. + (let ((x 2)) + (condition-case x + (list x) + (error (list 'bad x)) + (:success (list 'good x)))) + ;; Check variable scoping on failure. + (let ((x 2)) + (condition-case x + (/ 1 0) + (error (list 'bad x)) + (:success (list 'good x)))) + ;; Check capture of mutated result variable. + (funcall + (condition-case x + 3 + (:success (prog1 (lambda (y) (+ y x)) + (setq x 10)))) + 4) + ;; Check for-effect context, on error. + (let ((f (lambda (x) + (condition-case nil + (/ 1 0) + (error 'bad) + (:success 'good)) + (1+ x)))) + (funcall f 3)) + ;; Check for-effect context, on success. + (let ((f (lambda (x) + (condition-case nil + nil + (error 'bad) + (:success 'good)) + (1+ x)))) + (funcall f 3)) + + ;; Check `not' in cond switch (bug#49746). + (mapcar (lambda (x) (cond ((equal x "a") 1) + ((member x '("b" "c")) 2) + ((not x) 3))) + '("a" "b" "c" "d" nil)) + + ;; `let' and `let*' optimizations with body being constant or variable + (let* (a + (b (progn (setq a (cons 1 a)) 2)) + (c (1+ b)) + (d (list a c))) + d) + (let ((a nil)) + (let ((b (progn (setq a (cons 1 a)) 2)) + (c (progn (setq a (cons 3 a)))) + (d (list a))) + d)) + (let* ((_a 1) + (_b 2)) + 'z) + (let ((_a 1) + (_b 2)) + 'z) + (let (x y) + y) + (let* (x y) + y) + (let (x y) + 'a) + (let* (x y) + 'a) + + ;; Check empty-list optimizations. + (mapcar (lambda (x) (member x nil)) '("a" 2 nil)) + (mapcar (lambda (x) (memql x nil)) '(a 2 nil)) + (mapcar (lambda (x) (memq x nil)) '(a nil)) + (let ((n 0)) + (list (mapcar (lambda (x) (member (setq n (1+ n)) nil)) '(a "nil")) + n)) + (mapcar (lambda (x) (assoc x nil)) '("a" nil)) + (mapcar (lambda (x) (assq x nil)) '(a nil)) + (mapcar (lambda (x) (rassoc x nil)) '("a" nil)) + (mapcar (lambda (x) (rassq x nil)) '(a nil)) + (let ((n 0)) + (list (mapcar (lambda (x) (assoc (setq n (1+ n)) nil)) '(a "nil")) + n)) + + ;; Exercise variable-aliasing optimizations. + (let ((a (list 1))) + (let ((b a)) + (let ((a (list 2))) + (list a b)))) + + (let ((a (list 1))) + (let ((a (list 2)) + (b a)) + (list a b))) + + (let* ((a (list 1)) + (b a) + (a (list 2))) + (condition-case a + (list a b) + (error (list 'error a b)))) + + (let* ((a (list 1)) + (b a) + (a (list 2))) + (condition-case a + (/ 0) + (error (list 'error a b)))) + + (let* ((a (list 1)) + (b a) + (a (list 2)) + (f (list (lambda (x) (list x a))))) + (funcall (car f) 3)) + + (let* ((a (list 1)) + (b a) + (f (list (lambda (x) (setq a x))))) + (funcall (car f) 3) + (list a b)) + + (let* ((a (list 1)) + (b a) + (a (list 2)) + (f (list (lambda (x) (setq a x))))) + (funcall (car f) 3) + (list a b)) + + (cond) + (mapcar (lambda (x) (cond ((= x 0)))) '(0 1)) + + ;; These expressions give different results in lexbind and dynbind modes, + ;; but in each the compiler and interpreter should agree! + ;; (They look much the same but come in pairs exercising both the + ;; `let' and `let*' paths.) + (let ((f (lambda (x) + (lambda () + (let ((g (lambda () x))) + (let ((x 'a)) + (list x (funcall g)))))))) + (funcall (funcall f 'b))) + (let ((f (lambda (x) + (lambda () + (let ((g (lambda () x))) + (let* ((x 'a)) + (list x (funcall g)))))))) + (funcall (funcall f 'b))) + (let ((f (lambda (x) + (lambda () + (let ((g (lambda () x))) + (setq x (list x x)) + (let ((x 'a)) + (list x (funcall g)))))))) + (funcall (funcall f 'b))) + (let ((f (lambda (x) + (lambda () + (let ((g (lambda () x))) + (setq x (list x x)) + (let* ((x 'a)) + (list x (funcall g)))))))) + (funcall (funcall f 'b))) + (let ((f (lambda (x) + (let ((g (lambda () x)) + (h (lambda () (setq x (list x x))))) + (let ((x 'a)) + (list x (funcall g) (funcall h))))))) + (funcall (funcall f 'b))) + (let ((f (lambda (x) + (let ((g (lambda () x)) + (h (lambda () (setq x (list x x))))) + (let* ((x 'a)) + (list x (funcall g) (funcall h))))))) + (funcall (funcall f 'b))) + + ;; Test constant-propagation of access to captured variables. + (let* ((x 2) + (f (lambda () + (let ((y x)) (list y 3 y))))) + (funcall f)) + + ;; Test rewriting of `set' to `setq' (only done on dynamic variables). + (let ((xx 1)) (set 'xx 2) xx) + (let ((bytecomp-tests--xx 1)) + (set 'bytecomp-tests--xx 2) + bytecomp-tests--xx) + (let ((aaa 1)) (set (make-local-variable 'aaa) 2) aaa) + (let ((bytecomp-tests--xx 1)) + (set (make-local-variable 'bytecomp-tests--xx) 2) + bytecomp-tests--xx) + ) + "List of expressions for cross-testing interpreted and compiled code.") + +(defconst bytecomp-tests--test-cases-lexbind-only + `( + ;; This would infloop (and exhaust stack) with dynamic binding. + (let ((f #'car)) + (let ((f (lambda (x) (cons (funcall f x) (cdr x))))) + (funcall f '(1 . 2)))) + ) + "List of expressions for cross-testing interpreted and compiled code. +These are only tested with lexical binding.") + +(defun bytecomp-tests--eval-interpreted (form) + "Evaluate FORM using the Lisp interpreter, returning errors as a +special value." + (condition-case err + (eval form lexical-binding) + (error (list 'bytecomp-check-error (car err))))) + +(defun bytecomp-tests--eval-compiled (form) + "Evaluate FORM using the Lisp byte-code compiler, returning errors as a +special value." (let ((warning-minimum-log-level :emergency) - (byte-compile-warnings nil) - (pass-face '((t :foreground "green"))) - (fail-face '((t :foreground "red"))) - (print-escape-nonascii t) - (print-escape-newlines t) - (print-quoted t) - v0 v1) - (dolist (pat byte-opt-testsuite-arith-data) - (condition-case nil - (setq v0 (eval pat)) - (error (setq v0 nil))) - (condition-case nil - (setq v1 (funcall (byte-compile (list 'lambda nil pat)))) - (error (setq v1 nil))) - (insert (format "%s" pat)) - (indent-to-column 65) - (if (equal v0 v1) - (insert (propertize "OK" 'face pass-face)) - (insert (propertize "FAIL\n" 'face fail-face)) - (indent-to-column 55) - (insert (propertize (format "[%s] vs [%s]" v0 v1) - 'face fail-face))) - (insert "\n")))) + (byte-compile-warnings nil)) + (condition-case err + (funcall (byte-compile (list 'lambda nil form))) + (error (list 'bytecomp-check-error (car err)))))) + +(ert-deftest bytecomp-tests-lexbind () + "Check that various expressions behave the same when interpreted and +byte-compiled. Run with lexical binding." + (let ((lexical-binding t)) + (dolist (form (append bytecomp-tests--test-cases-lexbind-only + bytecomp-tests--test-cases)) + (ert-info ((prin1-to-string form) :prefix "form: ") + (should (equal (bytecomp-tests--eval-interpreted form) + (bytecomp-tests--eval-compiled form))))))) + +(ert-deftest bytecomp-tests-dynbind () + "Check that various expressions behave the same when interpreted and +byte-compiled. Run with dynamic binding." + (let ((lexical-binding nil)) + (dolist (form bytecomp-tests--test-cases) + (ert-info ((prin1-to-string form) :prefix "form: ") + (should (equal (bytecomp-tests--eval-interpreted form) + (bytecomp-tests--eval-compiled form))))))) (defun test-byte-comp-compile-and-load (compile &rest forms) - (let ((elfile nil) - (elcfile nil)) - (unwind-protect - (progn - (setf elfile (make-temp-file "test-bytecomp" nil ".el")) - (when compile - (setf elcfile (make-temp-file "test-bytecomp" nil ".elc"))) - (with-temp-buffer - (dolist (form forms) - (print form (current-buffer))) - (write-region (point-min) (point-max) elfile nil 'silent)) - (if compile - (let ((byte-compile-dest-file-function - (lambda (e) elcfile))) - (byte-compile-file elfile t)) - (load elfile nil 'nomessage))) - (when elfile (delete-file elfile)) - (when elcfile (delete-file elcfile))))) -(put 'test-byte-comp-compile-and-load 'lisp-indent-function 1) + (declare (indent 1)) + (ert-with-temp-file elfile + :suffix ".el" + (ert-with-temp-file elcfile + :suffix ".elc" + (with-temp-buffer + (insert ";;; -*- lexical-binding: t -*-\n") + (dolist (form forms) + (print form (current-buffer))) + (write-region (point-min) (point-max) elfile nil 'silent)) + (if compile + (let ((byte-compile-dest-file-function + (lambda (e) elcfile))) + (byte-compile-file elfile))) + (load elfile nil 'nomessage)))) (ert-deftest test-byte-comp-macro-expansion () (test-byte-comp-compile-and-load t @@ -405,9 +803,13 @@ Subtests signal errors if something goes wrong." (defun def () (m)))) (should (equal (funcall 'def) 4))) + +;;;; Warnings. + (ert-deftest bytecomp-tests--warnings () (with-current-buffer (get-buffer-create "*Compile-Log*") (let ((inhibit-read-only t)) (erase-buffer))) + (mapc #'fmakunbound '(my-test0 my--test11 my--test12 my--test2)) (test-byte-comp-compile-and-load t '(progn (defun my-test0 () @@ -431,6 +833,219 @@ Subtests signal errors if something goes wrong." ;; Should not warn that mt--test2 is not known to be defined. (should-not (re-search-forward "my--test2" nil t)))) +(defmacro bytecomp--with-warning-test (re-warning &rest form) + (declare (indent 1)) + `(with-current-buffer (get-buffer-create "*Compile-Log*") + (let ((inhibit-read-only t)) (erase-buffer)) + (byte-compile ,@form) + (ert-info ((prin1-to-string (buffer-string)) :prefix "buffer: ") + (should (re-search-forward ,(string-replace " " "[ \n]+" re-warning)))))) + +(ert-deftest bytecomp-warn-wrong-args () + (bytecomp--with-warning-test "remq.*3.*2" + '(remq 1 2 3))) + +(ert-deftest bytecomp-warn-wrong-args-subr () + (bytecomp--with-warning-test "safe-length.*3.*1" + '(safe-length 1 2 3))) + +(ert-deftest bytecomp-warn-variable-lacks-prefix () + (bytecomp--with-warning-test "foo.*lacks a prefix" + '(defvar foo nil))) + +(defvar bytecomp-tests--docstring (make-string 100 ?x)) + +(ert-deftest bytecomp-warn-wide-docstring/defconst () + (bytecomp--with-warning-test "defconst.*foo.*wider than.*characters" + `(defconst foo t ,bytecomp-tests--docstring))) + +(ert-deftest bytecomp-warn-wide-docstring/defvar () + (bytecomp--with-warning-test "defvar.*foo.*wider than.*characters" + `(defvar foo t ,bytecomp-tests--docstring))) + +(defmacro bytecomp--define-warning-file-test (file re-warning &optional reverse) + `(ert-deftest ,(intern (format "bytecomp/%s" file)) () + (with-current-buffer (get-buffer-create "*Compile-Log*") + (let ((inhibit-read-only t)) (erase-buffer)) + (byte-compile-file ,(ert-resource-file file)) + (ert-info ((buffer-string) :prefix "buffer: ") + (,(if reverse 'should-not 'should) + (re-search-forward ,re-warning nil t)))))) + +(bytecomp--define-warning-file-test "error-lexical-var-with-add-hook.el" + "add-hook.*lexical var") + +(bytecomp--define-warning-file-test "error-lexical-var-with-remove-hook.el" + "remove-hook.*lexical var") + +(bytecomp--define-warning-file-test "error-lexical-var-with-run-hook-with-args-until-failure.el" + "args-until-failure.*lexical var") + +(bytecomp--define-warning-file-test "error-lexical-var-with-run-hook-with-args-until-success.el" + "args-until-success.*lexical var") + +(bytecomp--define-warning-file-test "error-lexical-var-with-run-hook-with-args.el" + "args.*lexical var") + +(bytecomp--define-warning-file-test "error-lexical-var-with-symbol-value.el" + "symbol-value.*lexical var") + +(bytecomp--define-warning-file-test "warn-autoload-not-on-top-level.el" + "compiler ignores.*autoload.*") + +(bytecomp--define-warning-file-test "warn-callargs.el" + "with 2 arguments, but accepts only 1") + +(bytecomp--define-warning-file-test "warn-callargs-defsubst.el" + "with 2 arguments, but accepts only 1") + +(bytecomp--define-warning-file-test "warn-defcustom-nogroup.el" + "fails to specify containing group") + +(bytecomp--define-warning-file-test "warn-defcustom-notype.el" + "fails to specify type") + +(bytecomp--define-warning-file-test "warn-defvar-lacks-prefix.el" + "var.*foo.*lacks a prefix") + +(bytecomp--define-warning-file-test "warn-format.el" + "called with 2 args to fill 1 format field") + +(bytecomp--define-warning-file-test "warn-free-setq.el" + "free.*foo") + +(bytecomp--define-warning-file-test "warn-free-variable-reference.el" + "free variable .bar") + +(bytecomp--define-warning-file-test "warn-make-variable-buffer-local.el" + "make-variable-buffer-local. not called at toplevel") + +(bytecomp--define-warning-file-test "warn-interactive-only.el" + "next-line.*interactive use only.*forward-line") + +(bytecomp--define-warning-file-test "warn-lambda-malformed-interactive-spec.el" + "malformed .interactive. specification") + +(bytecomp--define-warning-file-test "warn-obsolete-defun.el" + "foo-obsolete. is an obsolete function (as of 99.99)") + +(defvar bytecomp--tests-obsolete-var nil) +(make-obsolete-variable 'bytecomp--tests-obsolete-var nil "99.99") + +(bytecomp--define-warning-file-test "warn-obsolete-hook.el" + "bytecomp--tests-obsolete-var. is an obsolete variable (as of 99.99)") + +(bytecomp--define-warning-file-test "warn-obsolete-variable-same-file.el" + "foo-obs.*obsolete.*99.99" t) + +(bytecomp--define-warning-file-test "warn-obsolete-variable.el" + "bytecomp--tests-obsolete-var. is an obsolete variable (as of 99.99)") + +(bytecomp--define-warning-file-test "warn-obsolete-variable-bound.el" + "bytecomp--tests-obs.*obsolete.*99.99" t) + +(bytecomp--define-warning-file-test "warn-redefine-defun-as-macro.el" + "as both function and macro") + +(bytecomp--define-warning-file-test "warn-redefine-macro-as-defun.el" + "as both function and macro") + +(bytecomp--define-warning-file-test "warn-redefine-defun.el" + "defined multiple") + +(bytecomp--define-warning-file-test "warn-save-excursion.el" + "with-current.*rather than save-excursion") + +(bytecomp--define-warning-file-test "warn-variable-let-bind-constant.el" + "let-bind constant") + +(bytecomp--define-warning-file-test "warn-variable-let-bind-nonvariable.el" + "let-bind nonvariable") + +(bytecomp--define-warning-file-test "warn-variable-set-constant.el" + "attempt to set constant") + +(bytecomp--define-warning-file-test "warn-variable-setq-nonvariable.el" + "attempt to set non-variable") + +(bytecomp--define-warning-file-test "warn-variable-setq-odd.el" + "odd number of arguments") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-autoload.el" + "autoload .foox. docstring wider than .* characters") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-custom-declare-variable.el" + "custom-declare-variable .foo. docstring wider than .* characters") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-defalias.el" + "defalias .foo. docstring wider than .* characters") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-defconst.el" + "defconst .foo-bar. docstring wider than .* characters") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-define-abbrev-table.el" + "define-abbrev-table .foo. docstring wider than .* characters") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-define-obsolete-function-alias.el" + "defalias .foo. docstring wider than .* characters") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-define-obsolete-variable-alias.el" + "defvaralias .foo. docstring wider than .* characters") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-defun.el" + "Warning: docstring wider than .* characters") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-defvar.el" + "defvar .foo-bar. docstring wider than .* characters") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-defvaralias.el" + "defvaralias .foo-bar. docstring wider than .* characters") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-ignore-fill-column.el" + "defvar .foo-bar. docstring wider than .* characters" 'reverse) + +(bytecomp--define-warning-file-test + "warn-wide-docstring-ignore-function-signature.el" + "defvar .foo-bar. docstring wider than .* characters" 'reverse) + +(bytecomp--define-warning-file-test + "warn-wide-docstring-ignore-override.el" + "defvar .foo-bar. docstring wider than .* characters" 'reverse) + +(bytecomp--define-warning-file-test + "warn-wide-docstring-ignore-substitutions.el" + "defvar .foo-bar. docstring wider than .* characters" 'reverse) + +(bytecomp--define-warning-file-test + "warn-wide-docstring-ignore.el" + "defvar .foo-bar. docstring wider than .* characters" 'reverse) + +(bytecomp--define-warning-file-test + "warn-wide-docstring-multiline-first.el" + "defvar .foo-bar. docstring wider than .* characters") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-multiline.el" + "defvar .foo-bar. docstring wider than .* characters") + +(bytecomp--define-warning-file-test + "nowarn-inline-after-defvar.el" + "Lexical argument shadows" 'reverse) + + +;;;; Macro expansion. + (ert-deftest test-eager-load-macro-expansion () (test-byte-comp-compile-and-load nil '(progn (defmacro abc (arg) 1) (defun def () (abc 2)))) @@ -465,54 +1080,12 @@ 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)))) - (defmacro bytecomp-tests--with-temp-file (file-name-var &rest body) (declare (indent 1)) (cl-check-type file-name-var symbol) - `(let ((,file-name-var (make-temp-file "emacs"))) + `(ert-with-temp-file ,file-name-var (unwind-protect (progn ,@body) - (delete-file ,file-name-var) (let ((elc (concat ,file-name-var ".elc"))) (if (file-exists-p elc) (delete-file elc)))))) @@ -520,37 +1093,28 @@ bytecompiled code, and their results compared.") "Check that byte compiling warns about unescaped character literals (Bug#20852)." (should (boundp 'lread--unescaped-character-literals)) - (bytecomp-tests--with-temp-file source - (write-region "(list ?) ?( ?; ?\" ?[ ?])" nil source) - (bytecomp-tests--with-temp-file destination - (let* ((byte-compile-dest-file-function (lambda (_) destination)) - (byte-compile-error-on-warn t) - (byte-compile-debug t) - (err (should-error (byte-compile-file source)))) - (should (equal (cdr err) - (list (concat "unescaped character literals " - "`?\"', `?(', `?)', `?;', `?[', `?]' " - "detected!")))))))) - -(ert-deftest bytecomp-tests--old-style-backquotes () - "Check that byte compiling warns about old-style backquotes." - (should (boundp 'lread--old-style-backquotes)) - (bytecomp-tests--with-temp-file source - (write-region "(` (a b))" nil source) - (bytecomp-tests--with-temp-file destination - (let* ((byte-compile-dest-file-function (lambda (_) destination)) - (byte-compile-error-on-warn t) - (byte-compile-debug t) - (err (should-error (byte-compile-file source)))) - (should (equal (cdr err) - (list "!! The file uses old-style backquotes !! -This functionality has been obsolete for more than 10 years already -and will be removed soon. See (elisp)Backquote in the manual."))))))) - + (let ((byte-compile-error-on-warn t) + (byte-compile-debug t)) + (bytecomp-tests--with-temp-file source + (write-region "(list ?) ?( ?; ?\" ?[ ?])" nil source) + (bytecomp-tests--with-temp-file destination + (let* ((byte-compile-dest-file-function (lambda (_) destination)) + (err (should-error (byte-compile-file source)))) + (should (equal (cdr err) + `(,(concat "unescaped character literals " + "`?\"', `?(', `?)', `?;', `?[', `?]' " + "detected, " + "`?\\\"', `?\\(', `?\\)', `?\\;', `?\\[', " + "`?\\]' expected!"))))))) + ;; But don't warn in subsequent compilations (Bug#36068). + (bytecomp-tests--with-temp-file source + (write-region "(list 1 2 3)" nil source) + (bytecomp-tests--with-temp-file destination + (let ((byte-compile-dest-file-function (lambda (_) destination))) + (should (byte-compile-file source))))))) (ert-deftest bytecomp-tests-function-put () "Check `function-put' operates during compilation." - (should (boundp 'lread--old-style-backquotes)) (bytecomp-tests--with-temp-file source (dolist (form '((function-put 'bytecomp-tests--foo 'foo 1) (function-put 'bytecomp-tests--foo 'bar 2) @@ -561,12 +1125,547 @@ and will be removed soon. See (elisp)Backquote in the manual."))))))) (setq bytecomp-tests--foobar (bytecomp-tests--foobar)))) (print form (current-buffer))) (write-region (point-min) (point-max) source nil 'silent) - (byte-compile-file source t) + (byte-compile-file source) + (load source) (should (equal bytecomp-tests--foobar (cons 1 2))))) +(ert-deftest bytecomp-tests--test-no-warnings-with-advice () + (defun f ()) + (define-advice f (:around (oldfun &rest args) test) + (apply oldfun args)) + (with-current-buffer (get-buffer-create "*Compile-Log*") + (let ((inhibit-read-only t)) (erase-buffer))) + (test-byte-comp-compile-and-load t '(defun f ())) + (with-current-buffer (get-buffer-create "*Compile-Log*") + (goto-char (point-min)) + (should-not (search-forward "Warning" nil t)))) + +(ert-deftest bytecomp-test-featurep-warnings () + (let ((byte-compile-log-buffer (generate-new-buffer " *Compile-Log*"))) + (unwind-protect + (progn + (with-temp-buffer + (insert "\ +\(defun foo () + (an-undefined-function)) + +\(defun foo1 () + (if (featurep 'xemacs) + (some-undefined-function-if))) + +\(defun foo2 () + (and (featurep 'xemacs) + (some-undefined-function-and))) + +\(defun foo3 () + (if (not (featurep 'emacs)) + (some-undefined-function-not))) + +\(defun foo4 () + (or (featurep 'emacs) + (some-undefined-function-or))) +") + (byte-compile-from-buffer (current-buffer))) + (with-current-buffer byte-compile-log-buffer + (should (search-forward "an-undefined-function" nil t)) + (should-not (search-forward "some-undefined-function" nil t)))) + (if (buffer-live-p byte-compile-log-buffer) + (kill-buffer byte-compile-log-buffer))))) + +(ert-deftest bytecomp-test--switch-duplicates () + "Check that duplicates in switches are eliminated correctly (bug#35770)." + :expected-result (if byte-compile-cond-use-jump-table :passed :failed) + (dolist (params + '(((lambda (x) + (cond ((eq x 'a) 111) + ((eq x 'b) 222) + ((eq x 'a) 333) + ((eq x 'c) 444))) + (a b c) + string<) + ((lambda (x) + (cond ((eql x #x10000000000000000) 111) + ((eql x #x10000000000000001) 222) + ((eql x #x10000000000000000) 333) + ((eql x #x10000000000000002) 444))) + (#x10000000000000000 #x10000000000000001 #x10000000000000002) + <) + ((lambda (x) + (cond ((equal x "a") 111) + ((equal x "b") 222) + ((equal x "a") 333) + ((equal x "c") 444))) + ("a" "b" "c") + string<))) + (let* ((lisp (nth 0 params)) + (keys (nth 1 params)) + (lessp (nth 2 params)) + (bc (byte-compile lisp)) + (lap (byte-decompile-bytecode (aref bc 1) (aref bc 2))) + ;; Assume the first constant is the switch table. + (table (cadr (assq 'byte-constant lap)))) + (should (hash-table-p table)) + (should (equal (sort (hash-table-keys table) lessp) keys)) + (should (member '(byte-constant 111) lap)) + (should (member '(byte-constant 222) lap)) + (should-not (member '(byte-constant 333) lap)) + (should (member '(byte-constant 444) lap))))) + +(defun test-suppression (form suppress match) + (let ((lexical-binding t) + (byte-compile-log-buffer (generate-new-buffer " *Compile-Log*"))) + ;; Check that we get a warning without suppression. + (with-current-buffer byte-compile-log-buffer + (setq-local fill-column 9999) + (setq-local warning-fill-column fill-column) + (let ((inhibit-read-only t)) + (erase-buffer))) + (test-byte-comp-compile-and-load t form) + (with-current-buffer byte-compile-log-buffer + (unless match + (error "%s" (buffer-string))) + (goto-char (point-min)) + (should (string-match match (buffer-string)))) + ;; And that it's gone now. + (with-current-buffer byte-compile-log-buffer + (let ((inhibit-read-only t)) + (erase-buffer))) + (test-byte-comp-compile-and-load t + `(with-suppressed-warnings ,suppress + ,form)) + (with-current-buffer byte-compile-log-buffer + (goto-char (point-min)) + (should-not (string-match match (buffer-string)))) + ;; Also check that byte compiled forms are identical. + (should (equal (byte-compile form) + (byte-compile + `(with-suppressed-warnings ,suppress ,form)))))) + +(ert-deftest bytecomp-test--with-suppressed-warnings () + (test-suppression + '(defvar prefixless) + '((lexical prefixless)) + "global/dynamic var .prefixless. lacks") + + ;; FIXME: These messages cannot be suppressed reliably right now, + ;; but attempting mutate `nil' or `5' is a rather daft thing to do + ;; in the first place. Preventing mutation of constants such as + ;; `most-positive-fixnum' makes more sense but the compiler doesn't + ;; warn about that at all right now (it's caught at runtime, and we + ;; allow writing the same value). + ;; + ;; (test-suppression + ;; '(defun foo() + ;; (let ((nil t)) + ;; (message-mail))) + ;; '((constants nil)) + ;; "Warning: attempt to let-bind constant .nil.") + + (test-suppression + '(progn + (defun obsolete () + (declare (obsolete foo "22.1"))) + (defun zot () + (obsolete))) + '((obsolete obsolete)) + "Warning: .obsolete. is an obsolete function") + + (test-suppression + '(progn + (defun wrong-params (foo &optional unused) + (ignore unused) + foo) + (defun zot () + (wrong-params 1 2 3))) + '((callargs wrong-params)) + "Warning: .wrong-params. called with") + + (test-byte-comp-compile-and-load nil + (defvar obsolete-variable nil) + (make-obsolete-variable 'obsolete-variable nil "24.1")) + (test-suppression + '(defun zot () + obsolete-variable) + '((obsolete obsolete-variable)) + "obsolete") + + (test-suppression + '(defun zot () + (next-line)) + '((interactive-only next-line)) + "interactive use only") + + (test-suppression + '(defun zot () + (mapcar #'list '(1 2 3)) + nil) + '((mapcar mapcar)) + "Warning: .mapcar. called for effect") + + (test-suppression + '(defun zot () + free-variable) + '((free-vars free-variable)) + "Warning: reference to free variable") + + (test-suppression + '(defun zot () + (save-excursion + (set-buffer (get-buffer-create "foo")) + nil)) + '((suspicious set-buffer)) + "Warning: Use .with-current-buffer. rather than")) + +(ert-deftest bytecomp-tests--not-writable-directory () + "Test that byte compilation works if the output directory isn't +writable (Bug#44631)." + (ert-with-temp-directory directory + (let* ((input-file (expand-file-name "test.el" directory)) + (output-file (expand-file-name "test.elc" directory)) + (byte-compile-dest-file-function + (lambda (_) output-file)) + (byte-compile-error-on-warn t)) + (unwind-protect + (progn + (write-region "" nil input-file nil nil nil 'excl) + (write-region "" nil output-file nil nil nil 'excl) + (set-file-modes input-file #o400) + (set-file-modes output-file #o200) + (set-file-modes directory #o500) + (should (byte-compile-file input-file)) + (should (file-regular-p output-file)) + (should (cl-plusp (file-attribute-size + (file-attributes output-file))))) + ;; Allow the directory to be deleted. + (set-file-modes directory #o777))))) + +(ert-deftest bytecomp-tests--dest-mountpoint () + "Test that byte compilation works if the destination file is a +mountpoint (Bug#44631)." + (let ((bwrap (executable-find "bwrap")) + (emacs (expand-file-name invocation-name invocation-directory))) + (skip-unless bwrap) + (skip-unless (file-executable-p bwrap)) + (skip-unless (not (file-remote-p bwrap))) + (skip-unless (file-executable-p emacs)) + (skip-unless (not (file-remote-p emacs))) + (ert-with-temp-directory directory + (let* ((input-file (expand-file-name "test.el" directory)) + (output-file (expand-file-name "test.elc" directory)) + (unquoted-file (file-name-unquote output-file)) + (byte-compile-dest-file-function + (lambda (_) output-file)) + (byte-compile-error-on-warn t)) + (should-not (file-remote-p input-file)) + (should-not (file-remote-p output-file)) + (write-region "" nil input-file nil nil nil 'excl) + (write-region "" nil output-file nil nil nil 'excl) + (unwind-protect + (progn + (set-file-modes input-file #o400) + (set-file-modes output-file #o200) + (set-file-modes directory #o500) + (with-temp-buffer + (let ((status (call-process + bwrap nil t nil + "--ro-bind" "/" "/" + "--bind" unquoted-file unquoted-file + emacs "--quick" "--batch" "--load=bytecomp" + (format "--eval=%S" + `(setq byte-compile-dest-file-function + (lambda (_) ,output-file) + byte-compile-error-on-warn t)) + "--funcall=batch-byte-compile" input-file))) + (unless (eql status 0) + (ert-fail `((status . ,status) + (output . ,(buffer-string))))))) + (should (file-regular-p output-file)) + (should (cl-plusp (file-attribute-size + (file-attributes output-file))))) + ;; Allow the directory to be deleted. + (set-file-modes directory #o777)))))) + +(ert-deftest bytecomp-tests--target-file-no-directory () + "Check that Bug#45287 is fixed." + (ert-with-temp-directory directory + (let* ((default-directory directory) + (byte-compile-dest-file-function (lambda (_) "test.elc")) + (byte-compile-error-on-warn t)) + (write-region "" nil "test.el" nil nil nil 'excl) + (should (byte-compile-file "test.el")) + (should (file-regular-p "test.elc")) + (should (cl-plusp (file-attribute-size + (file-attributes "test.elc"))))))) + +(defun bytecomp-tests--get-vars () + (list (ignore-errors (symbol-value 'bytecomp-tests--var1)) + (ignore-errors (symbol-value 'bytecomp-tests--var2)))) + +(ert-deftest bytecomp-local-defvar () + "Check that local `defvar' declarations work correctly, both +interpreted and compiled." + (let ((lexical-binding t)) + (let ((fun '(lambda () + (defvar bytecomp-tests--var1) + (let ((bytecomp-tests--var1 'a) ; dynamic + (bytecomp-tests--var2 'b)) ; still lexical + (ignore bytecomp-tests--var2) ; avoid warning + (bytecomp-tests--get-vars))))) + (should (listp fun)) ; Guard against overzealous refactoring! + (should (equal (funcall (eval fun t)) '(a nil))) + (should (equal (funcall (byte-compile fun)) '(a nil))) + ) + + ;; `progn' does not constitute a lexical scope for `defvar' (bug#46387). + (let ((fun '(lambda () + (progn + (defvar bytecomp-tests--var1) + (defvar bytecomp-tests--var2)) + (let ((bytecomp-tests--var1 'c) + (bytecomp-tests--var2 'd)) + (bytecomp-tests--get-vars))))) + (should (listp fun)) + (should (equal (funcall (eval fun t)) '(c d))) + (should (equal (funcall (byte-compile fun)) '(c d)))))) + +(ert-deftest bytecomp-reify-function () + "Check that closures that modify their bound variables are +compiled correctly." + (cl-letf ((lexical-binding t) + ((symbol-function 'counter) nil)) + (let ((x 0)) + (defun counter () (cl-incf x)) + (should (equal (counter) 1)) + (should (equal (counter) 2)) + ;; byte compiling should not cause counter to always return the + ;; same value (bug#46834) + (byte-compile 'counter) + (should (equal (counter) 3)) + (should (equal (counter) 4))) + (let ((x 0)) + (let ((x 1)) + (defun counter () x) + (should (equal (counter) 1)) + ;; byte compiling should not cause the outer binding to shadow + ;; the inner one (bug#46834) + (byte-compile 'counter) + (should (equal (counter) 1)))))) + +(ert-deftest bytecomp-string-vs-docstring () + ;; Don't confuse a string return value for a docstring. + (let ((lexical-binding t)) + (should (equal (funcall (byte-compile '(lambda (x) "foo")) 'dummy) "foo")))) + +(ert-deftest bytecomp-condition-case-success () + ;; No error, no success handler. + (should (equal (condition-case x + (list 42) + (error (cons 'bad x))) + '(42))) + ;; Error, no success handler. + (should (equal (condition-case x + (/ 1 0) + (error (cons 'bad x))) + '(bad arith-error))) + ;; No error, success handler. + (should (equal (condition-case x + (list 42) + (error (cons 'bad x)) + (:success (cons 'good x))) + '(good 42))) + ;; Error, success handler. + (should (equal (condition-case x + (/ 1 0) + (error (cons 'bad x)) + (:success (cons 'good x))) + '(bad arith-error))) + ;; Verify that the success code is not subject to the error handlers. + (should-error (condition-case x + (list 42) + (error (cons 'bad x)) + (:success (/ (car x) 0))) + :type 'arith-error) + ;; Check variable scoping. + (let ((x 2)) + (should (equal (condition-case x + (list x) + (error (list 'bad x)) + (:success (list 'good x))) + '(good (2)))) + (should (equal (condition-case x + (/ 1 0) + (error (list 'bad x)) + (:success (list 'good x))) + '(bad (arith-error))))) + ;; Check capture of mutated result variable. + (should (equal (funcall + (condition-case x + 3 + (:success (prog1 (lambda (y) (+ y x)) + (setq x 10)))) + 4) + 14)) + ;; Check for-effect context, on error. + (should (equal (let ((f (lambda (x) + (condition-case nil + (/ 1 0) + (error 'bad) + (:success 'good)) + (1+ x)))) + (funcall f 3)) + 4)) + ;; Check for-effect context, on success. + (should (equal (let ((f (lambda (x) + (condition-case nil + nil + (error 'bad) + (:success 'good)) + (1+ x)))) + (funcall f 3)) + 4))) + +(declare-function bc-test-alpha-f (ert-resource-file "bc-test-alpha.el")) + +(ert-deftest bytecomp-defsubst () + ;; Check that lexical variables don't leak into inlined code. See + ;; https://lists.gnu.org/archive/html/emacs-devel/2021-05/msg01227.html + + ;; First, remove any trace of the functions and package defined: + (fmakunbound 'bc-test-alpha-f) + (fmakunbound 'bc-test-beta-f) + (setq features (delq 'bc-test-beta features)) + ;; Byte-compile one file that uses a function from another file that isn't + ;; compiled. + (let ((file (ert-resource-file "bc-test-alpha.el")) + (load-path (cons (ert-resource-directory) load-path))) + (byte-compile-file file) + (load-file (concat file "c")) + (should (equal (bc-test-alpha-f 'a) '(nil a))))) + +(ert-deftest bytecomp-tests-byte-compile--wide-docstring-p/func-arg-list () + (should-not (byte-compile--wide-docstring-p "\ +\(dbus-register-property BUS SERVICE PATH INTERFACE PROPERTY ACCESS \ +[TYPE] VALUE &optional EMITS-SIGNAL DONT-REGISTER-SERVICE)" fill-column)) + (should-not (byte-compile--wide-docstring-p "\ +(fn CMD FLAGS FIS &key (BUF (cvs-temp-buffer)) DONT-CHANGE-DISC CVSARGS \ +POSTPROC)" fill-column)) + ;; Bug#49007 + (should-not (byte-compile--wide-docstring-p "\ +(fn (THIS rudel-protocol-backend) TRANSPORT \ +INFO INFO-CALLBACK &optional PROGRESS-CALLBACK)" fill-column)) + (should-not (byte-compile--wide-docstring-p "\ +\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ +[:tags \\='(TAG...)] BODY...)" fill-column)) + (should-not (byte-compile--wide-docstring-p "\ +(make-soap-xs-element &key NAME NAMESPACE-TAG ID TYPE^ OPTIONAL? MULTIPLE? \ +REFERENCE SUBSTITUTION-GROUP ALTERNATIVES IS-GROUP)" fill-column)) + (should-not (byte-compile--wide-docstring-p "\ +(fn NAME FIXTURE INPUT &key SKIP-PAIR-STRING EXPECTED-STRING \ +EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \ +(TEST-IN-COMMENTS t) (TEST-IN-STRINGS t) (TEST-IN-CODE t) \ +(FIXTURE-FN \\='#\\='electric-pair-mode))" fill-column))) + +(defun test-bytecomp-defgroup-choice () + (should-not (byte-compile--suspicious-defcustom-choice 'integer)) + (should-not (byte-compile--suspicious-defcustom-choice + '(choice (const :tag "foo" bar)))) + (should (byte-compile--suspicious-defcustom-choice + '(choice (const :tag "foo" 'bar))))) + +(ert-deftest bytecomp-function-attributes () + ;; Check that `byte-compile' keeps the declarations, interactive spec and + ;; doc string of the function (bug#55830). + (let ((fname 'bytecomp-test-fun)) + (fset fname nil) + (put fname 'pure nil) + (put fname 'lisp-indent-function nil) + (eval `(defun ,fname (x) + "tata" + (declare (pure t) (indent 1)) + (interactive "P") + (list 'toto x)) + t) + (let ((bc (byte-compile fname))) + (should (byte-code-function-p bc)) + (should (equal (funcall bc 'titi) '(toto titi))) + (should (equal (aref bc 5) "P")) + (should (equal (get fname 'pure) t)) + (should (equal (get fname 'lisp-indent-function) 1)) + (should (equal (aref bc 4) "tata\n\n(fn X)"))))) + +(ert-deftest bytecomp-fun-attr-warn () + ;; Check that warnings are emitted when doc strings, `declare' and + ;; `interactive' forms don't come in the proper order, or more than once. + (let* ((filename "fun-attr-warn.el") + (el (ert-resource-file filename)) + (elc (concat el "c")) + (text-quoting-style 'grave)) + (with-current-buffer (get-buffer-create "*Compile-Log*") + (let ((inhibit-read-only t)) + (erase-buffer)) + (byte-compile-file el) + (let ((expected + '("70:4: Warning: `declare' after `interactive'" + "74:4: Warning: Doc string after `interactive'" + "79:4: Warning: Doc string after `interactive'" + "84:4: Warning: Doc string after `declare'" + "89:4: Warning: Doc string after `declare'" + "96:4: Warning: `declare' after `interactive'" + "102:4: Warning: `declare' after `interactive'" + "108:4: Warning: `declare' after `interactive'" + "106:4: Warning: Doc string after `interactive'" + "114:4: Warning: `declare' after `interactive'" + "112:4: Warning: Doc string after `interactive'" + "118:4: Warning: Doc string after `interactive'" + "119:4: Warning: `declare' after `interactive'" + "124:4: Warning: Doc string after `interactive'" + "125:4: Warning: `declare' after `interactive'" + "130:4: Warning: Doc string after `declare'" + "136:4: Warning: Doc string after `declare'" + "142:4: Warning: Doc string after `declare'" + "148:4: Warning: Doc string after `declare'" + "159:4: Warning: More than one doc string" + "165:4: Warning: More than one doc string" + "171:4: Warning: More than one doc string" + "178:4: Warning: More than one doc string" + "186:4: Warning: More than one doc string" + "192:4: Warning: More than one doc string" + "200:4: Warning: More than one doc string" + "206:4: Warning: More than one doc string" + "215:4: Warning: More than one `declare' form" + "222:4: Warning: More than one `declare' form" + "230:4: Warning: More than one `declare' form" + "237:4: Warning: More than one `declare' form" + "244:4: Warning: More than one `interactive' form" + "251:4: Warning: More than one `interactive' form" + "258:4: Warning: More than one `interactive' form" + "257:4: Warning: `declare' after `interactive'" + "265:4: Warning: More than one `interactive' form" + "264:4: Warning: `declare' after `interactive'"))) + (goto-char (point-min)) + (let ((actual nil)) + (while (re-search-forward + (rx bol (* (not ":")) ":" + (group (+ digit) ":" (+ digit) ": Warning: " + (or "More than one " (+ nonl) " form" + (: (+ nonl) " after " (+ nonl)))) + eol) + nil t) + (push (match-string 1) actual)) + (setq actual (nreverse actual)) + (should (equal actual expected))))))) + +(ert-deftest byte-compile-file/no-byte-compile () + (let* ((src-file (ert-resource-file "no-byte-compile.el")) + (dest-file (make-temp-file "bytecomp-tests-" nil ".elc")) + (byte-compile-dest-file-function (lambda (_) dest-file))) + (should (eq (byte-compile-file src-file) 'no-byte-compile)) + (should-not (file-exists-p dest-file)))) + + ;; Local Variables: ;; no-byte-compile: t ;; End: (provide 'bytecomp-tests) -;; bytecomp-tests.el ends here. +;;; bytecomp-tests.el ends here diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el new file mode 100644 index 00000000000..37470f863f3 --- /dev/null +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -0,0 +1,361 @@ +;;; cconv-tests.el --- Tests for cconv.el -*- lexical-binding: t -*- + +;; Copyright (C) 2018-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'generator) +(require 'bytecomp) + +(ert-deftest cconv-tests-lambda-:documentation () + "Docstring for lambda can be specified with :documentation." + (let ((fun (lambda () + (:documentation (concat "lambda" " documentation")) + 'lambda-result))) + (should (string= (documentation fun) "lambda documentation")) + (should (eq (funcall fun) 'lambda-result)))) + +(ert-deftest cconv-tests-pcase-lambda-:documentation () + "Docstring for pcase-lambda can be specified with :documentation." + (let ((fun (pcase-lambda (`(,a ,b)) + (:documentation (concat "pcase-lambda" " documentation")) + (list b a)))) + (should (string= (documentation fun) "pcase-lambda documentation")) + (should (equal '(2 1) (funcall fun '(1 2)))))) + +(defun cconv-tests-defun () + (:documentation (concat "defun" " documentation")) + 'defun-result) +(ert-deftest cconv-tests-defun-:documentation () + "Docstring for defun can be specified with :documentation." + (should (string= (documentation 'cconv-tests-defun) + "defun documentation")) + (should (eq (cconv-tests-defun) 'defun-result))) + +(cl-defun cconv-tests-cl-defun () + (:documentation (concat "cl-defun" " documentation")) + 'cl-defun-result) +(ert-deftest cconv-tests-cl-defun-:documentation () + "Docstring for cl-defun can be specified with :documentation." + (should (string= (documentation 'cconv-tests-cl-defun) + "cl-defun documentation")) + (should (eq (cconv-tests-cl-defun) 'cl-defun-result))) + +;; FIXME: The byte-complier croaks on this. See Bug#28557. +;; (defmacro cconv-tests-defmacro () +;; (:documentation (concat "defmacro" " documentation")) +;; '(quote defmacro-result)) +;; (ert-deftest cconv-tests-defmacro-:documentation () +;; "Docstring for defmacro can be specified with :documentation." +;; (should (string= (documentation 'cconv-tests-defmacro) +;; "defmacro documentation")) +;; (should (eq (cconv-tests-defmacro) 'defmacro-result))) + +;; FIXME: The byte-complier croaks on this. See Bug#28557. +;; (cl-defmacro cconv-tests-cl-defmacro () +;; (:documentation (concat "cl-defmacro" " documentation")) +;; '(quote cl-defmacro-result)) +;; (ert-deftest cconv-tests-cl-defmacro-:documentation () +;; "Docstring for cl-defmacro can be specified with :documentation." +;; (should (string= (documentation 'cconv-tests-cl-defmacro) +;; "cl-defmacro documentation")) +;; (should (eq (cconv-tests-cl-defmacro) 'cl-defmacro-result))) + +(cl-iter-defun cconv-tests-cl-iter-defun () + (:documentation (concat "cl-iter-defun" " documentation")) + (iter-yield 'cl-iter-defun-result)) +(ert-deftest cconv-tests-cl-iter-defun-:documentation () + "Docstring for cl-iter-defun can be specified with :documentation." + (should (string= (documentation 'cconv-tests-cl-iter-defun) + "cl-iter-defun documentation")) + (should (eq (iter-next (cconv-tests-cl-iter-defun)) + 'cl-iter-defun-result))) + +(iter-defun cconv-tests-iter-defun () + (:documentation (concat "iter-defun" " documentation")) + (iter-yield 'iter-defun-result)) +(ert-deftest cconv-tests-iter-defun-:documentation () + "Docstring for iter-defun can be specified with :documentation." + (should (string= (documentation 'cconv-tests-iter-defun) + "iter-defun documentation")) + (should (eq (iter-next (cconv-tests-iter-defun)) 'iter-defun-result))) + +(ert-deftest cconv-tests-iter-lambda-:documentation () + "Docstring for iter-lambda can be specified with :documentation." + (let ((iter-fun + (iter-lambda () + (:documentation (concat "iter-lambda" " documentation")) + (iter-yield 'iter-lambda-result)))) + (should (string= (documentation iter-fun) "iter-lambda documentation")) + (should (eq (iter-next (funcall iter-fun)) 'iter-lambda-result)))) + +(ert-deftest cconv-tests-cl-function-:documentation () + "Docstring for cl-function can be specified with :documentation." + (let ((fun (cl-function (lambda (&key arg) + (:documentation (concat "cl-function" + " documentation")) + (list arg 'cl-function-result))))) + (should (string-match "\\`cl-function documentation$" (documentation fun))) + (should (equal (funcall fun :arg t) '(t cl-function-result))))) + +(ert-deftest cconv-tests-function-:documentation () + "Docstring for lambda inside function can be specified with :documentation." + (let ((fun #'(lambda (arg) + (:documentation (concat "function" " documentation")) + (list arg 'function-result)))) + (should (string= (documentation fun) "function documentation")) + (should (equal (funcall fun t) '(t function-result))))) + +(fmakunbound 'cconv-tests-cl-defgeneric) +(setplist 'cconv-tests-cl-defgeneric nil) +(cl-defgeneric cconv-tests-cl-defgeneric (n) + (:documentation (concat "cl-defgeneric" " documentation"))) +(cl-defmethod cconv-tests-cl-defgeneric ((n integer)) + (:documentation (concat "cl-defmethod" " documentation")) + (+ 1 n)) +(ert-deftest cconv-tests-cl-defgeneric-:documentation () + "Docstring for cl-defgeneric can be specified with :documentation." + (let ((descr (describe-function 'cconv-tests-cl-defgeneric))) + (set-text-properties 0 (length descr) nil descr) + (should (string-match-p "cl-defgeneric documentation" descr)) + (should (string-match-p "cl-defmethod documentation" descr))) + (should (= 11 (cconv-tests-cl-defgeneric 10)))) + +(fmakunbound 'cconv-tests-cl-defgeneric-literal) +(setplist 'cconv-tests-cl-defgeneric-literal nil) +(cl-defgeneric cconv-tests-cl-defgeneric-literal (n) + (:documentation "cl-defgeneric-literal documentation")) +(cl-defmethod cconv-tests-cl-defgeneric-literal ((n integer)) + (:documentation "cl-defmethod-literal documentation") + (+ 1 n)) +(ert-deftest cconv-tests-cl-defgeneric-literal-:documentation () + "Docstring for cl-defgeneric can be specified with :documentation." + (let ((descr (describe-function 'cconv-tests-cl-defgeneric-literal))) + (set-text-properties 0 (length descr) nil descr) + (should (string-match-p "cl-defgeneric-literal documentation" descr)) + (should (string-match-p "cl-defmethod-literal documentation" descr))) + (should (= 11 (cconv-tests-cl-defgeneric-literal 10)))) + +(defsubst cconv-tests-defsubst () + (:documentation (concat "defsubst" " documentation")) + 'defsubst-result) +(ert-deftest cconv-tests-defsubst-:documentation () + "Docstring for defsubst can be specified with :documentation." + (should (string= (documentation 'cconv-tests-defsubst) + "defsubst documentation")) + (should (eq (cconv-tests-defsubst) 'defsubst-result))) + +(cl-defsubst cconv-tests-cl-defsubst () + (:documentation (concat "cl-defsubst" " documentation")) + 'cl-defsubst-result) +(ert-deftest cconv-tests-cl-defsubst-:documentation () + "Docstring for cl-defsubst can be specified with :documentation." + (should (string= (documentation 'cconv-tests-cl-defsubst) + "cl-defsubst documentation")) + (should (eq (cconv-tests-cl-defsubst) 'cl-defsubst-result))) + +(ert-deftest cconv-convert-lambda-lifted () + ;; Verify that lambda-lifting is actually performed at all. + (should (equal (cconv-closure-convert + '#'(lambda (x) (let ((f #'(lambda () (+ x 1)))) + (funcall f)))) + '#'(lambda (x) (let ((f #'(lambda (x) (+ x 1)))) + (funcall f x))))) + + ;; Bug#30872. + (should + (equal (funcall + (byte-compile + '#'(lambda (handle-fun arg) + (let* ((subfun + #'(lambda (params) + (ignore handle-fun) + (funcall #'(lambda () (setq params 42))) + params))) + (funcall subfun arg)))) + nil 99) + 42))) + +(defun cconv-tests--intern-all (x) + "Intern all symbols in X." + (cond ((symbolp x) (intern (symbol-name x))) + ((consp x) (cons (cconv-tests--intern-all (car x)) + (cconv-tests--intern-all (cdr x)))) + ;; Assume we don't need to deal with vectors etc. + (t x))) + +(ert-deftest cconv-closure-convert-remap-var () + ;; Verify that we correctly remap shadowed lambda-lifted variables. + + ;; We intern all symbols for ease of comparison; this works because + ;; the `cconv-closure-convert' result should contain no pair of + ;; distinct symbols having the same name. + + ;; Sanity check: captured variable, no lambda-lifting or shadowing: + (should (equal (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + #'(lambda () x)))) + '#'(lambda (x) + (internal-make-closure + nil (x) nil + (internal-get-closed-var 0))))) + + ;; Basic case: + (should (equal (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + (let ((f #'(lambda () x))) + (let ((x 'b)) + (list x (funcall f))))))) + '#'(lambda (x) + (let ((f #'(lambda (x) x))) + (let ((x 'b) + (closed-x x)) + (list x (funcall f closed-x))))))) + (should (equal (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + (let ((f #'(lambda () x))) + (let* ((x 'b)) + (list x (funcall f))))))) + '#'(lambda (x) + (let ((f #'(lambda (x) x))) + (let* ((closed-x x) + (x 'b)) + (list x (funcall f closed-x))))))) + + ;; With the lambda-lifted shadowed variable also being captured: + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + #'(lambda () + (let ((f #'(lambda () x))) + (let ((x 'a)) + (list x (funcall f)))))))) + '#'(lambda (x) + (internal-make-closure + nil (x) nil + (let ((f #'(lambda (x) x))) + (let ((x 'a) + (closed-x (internal-get-closed-var 0))) + (list x (funcall f closed-x)))))))) + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + #'(lambda () + (let ((f #'(lambda () x))) + (let* ((x 'a)) + (list x (funcall f)))))))) + '#'(lambda (x) + (internal-make-closure + nil (x) nil + (let ((f #'(lambda (x) x))) + (let* ((closed-x (internal-get-closed-var 0)) + (x 'a)) + (list x (funcall f closed-x)))))))) + ;; With lambda-lifted shadowed variable also being mutably captured: + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + #'(lambda () + (let ((f #'(lambda () x))) + (setq x x) + (let ((x 'a)) + (list x (funcall f)))))))) + '#'(lambda (x) + (let ((x (list x))) + (internal-make-closure + nil (x) nil + (let ((f #'(lambda (x) (car-safe x)))) + (setcar (internal-get-closed-var 0) + (car-safe (internal-get-closed-var 0))) + (let ((x 'a) + (closed-x (internal-get-closed-var 0))) + (list x (funcall f closed-x))))))))) + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + #'(lambda () + (let ((f #'(lambda () x))) + (setq x x) + (let* ((x 'a)) + (list x (funcall f)))))))) + '#'(lambda (x) + (let ((x (list x))) + (internal-make-closure + nil (x) nil + (let ((f #'(lambda (x) (car-safe x)))) + (setcar (internal-get-closed-var 0) + (car-safe (internal-get-closed-var 0))) + (let* ((closed-x (internal-get-closed-var 0)) + (x 'a)) + (list x (funcall f closed-x))))))))) + ;; Lambda-lifted variable that isn't actually captured where it is shadowed: + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + (let ((g #'(lambda () x)) + (h #'(lambda () (setq x x)))) + (let ((x 'b)) + (list x (funcall g) (funcall h))))))) + '#'(lambda (x) + (let ((x (list x))) + (let ((g #'(lambda (x) (car-safe x))) + (h #'(lambda (x) (setcar x (car-safe x))))) + (let ((x 'b) + (closed-x x)) + (list x (funcall g closed-x) (funcall h closed-x)))))))) + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + (let ((g #'(lambda () x)) + (h #'(lambda () (setq x x)))) + (let* ((x 'b)) + (list x (funcall g) (funcall h))))))) + '#'(lambda (x) + (let ((x (list x))) + (let ((g #'(lambda (x) (car-safe x))) + (h #'(lambda (x) (setcar x (car-safe x))))) + (let* ((closed-x x) + (x 'b)) + (list x (funcall g closed-x) (funcall h closed-x)))))))) + ) + +(ert-deftest cconv-tests-interactive-closure-bug51695 () + (let ((f (let ((d 51695)) + (lambda (data) + (interactive (progn (setq d (1+ d)) (list d))) + (list (called-interactively-p 'any) data))))) + (should (equal (list (call-interactively f) + (funcall f 51695) + (call-interactively f)) + '((t 51696) (nil 51695) (t 51697)))))) + +(provide 'cconv-tests) +;;; cconv-tests.el ends here diff --git a/test/lisp/emacs-lisp/check-declare-tests.el b/test/lisp/emacs-lisp/check-declare-tests.el new file mode 100644 index 00000000000..59dfc10163d --- /dev/null +++ b/test/lisp/emacs-lisp/check-declare-tests.el @@ -0,0 +1,108 @@ +;;; check-declare-tests.el --- Tests for check-declare.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020-2022 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl <simenheg@gmail.com> +;; Keywords: + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'check-declare) +(require 'ert) +(require 'ert-x) +(eval-when-compile (require 'subr-x)) + +(ert-deftest check-declare-tests-locate () + (should (file-exists-p (check-declare-locate "check-declare" ""))) + (should + (string-prefix-p "ext:" (check-declare-locate "ext:foo" "")))) + +(ert-deftest check-declare-tests-scan () + (ert-with-temp-file file + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(declare-function ring-insert \"ring\" (ring item))" + "(let ((foo 'code)) foo)") + "\n"))) + (let ((res (check-declare-scan file))) + (should (= (length res) 1)) + (pcase-let ((`((,fnfile ,fn ,arglist ,fileonly)) res)) + (should (string-match-p "ring" fnfile)) + (should (equal "ring-insert" fn)) + (should (equal '(ring item) arglist)) + (should-not fileonly))))) + +(ert-deftest check-declare-tests-verify () + (ert-with-temp-file file + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(defun foo-fun ())" + "(defun ring-insert (ring item)" + "\"Insert onto ring RING the item ITEM.\"" + "nil)") + "\n"))) + (should-not + (check-declare-verify + file '(("foo.el" "ring-insert" (ring item))))))) + +(ert-deftest check-declare-tests-verify-mismatch () + (ert-with-temp-file file + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(defun foo-fun ())" + "(defun ring-insert (ring)" + "\"Insert onto ring RING the item ITEM.\"" + "nil)") + "\n"))) + (should + (equal + (check-declare-verify + file '(("foo.el" "ring-insert" (ring item)))) + '(("foo.el" "ring-insert" "arglist mismatch")))))) + +(ert-deftest check-declare-tests-sort () + (should-not (check-declare-sort '())) + (should (equal (check-declare-sort '((a (1 a)) (b (2)) (d (1 d)))) + '((2 (b)) (1 (a a) (d d)))))) + +(ert-deftest check-declare-tests-warn () + (with-temp-buffer + (let ((check-declare-warning-buffer (buffer-name))) + (check-declare-warn + "foo-file" "foo-fun" "bar-file" "it wasn't" 999) + (let ((res (buffer-string))) + ;; Don't care too much about the format of the output, but + ;; check that key information is present. + (should (string-search "foo-file" res)) + (should (string-search "foo-fun" res)) + (should (string-search "bar-file" res)) + (should (string-search "it wasn't" res)) + (should (string-search "999" res)))))) + +(provide 'check-declare-tests) +;;; check-declare-tests.el ends here diff --git a/test/lisp/emacs-lisp/checkdoc-tests.el b/test/lisp/emacs-lisp/checkdoc-tests.el index d832a862280..289476f0246 100644 --- a/test/lisp/emacs-lisp/checkdoc-tests.el +++ b/test/lisp/emacs-lisp/checkdoc-tests.el @@ -1,6 +1,6 @@ ;;; checkdoc-tests.el --- unit tests for checkdoc.el -*- lexical-binding: t; -*- -;; Copyright (C) 2016-2017 Free Software Foundation, Inc. +;; Copyright (C) 2016-2022 Free Software Foundation, Inc. ;; Author: Philipp Stephani <phst@google.com> @@ -37,6 +37,78 @@ (insert "(defun foo())") (should-error (checkdoc-defun) :type 'user-error))) +(ert-deftest checkdoc-cl-defmethod-ok () + "Checkdoc should be happy with a simple correct cl-defmethod." + (with-temp-buffer + (emacs-lisp-mode) + (insert "(cl-defmethod foo (a) \"Return A.\")") + (checkdoc-defun))) + +(ert-deftest checkdoc-cl-defmethod-with-types-ok () + "Checkdoc should be happy with a cl-defmethod using types." + (with-temp-buffer + (emacs-lisp-mode) + ;; this method matches if A is the symbol `smthg' and if b is a list: + (insert "(cl-defmethod foo ((a (eql 'smthg)) (b list)) \"Return A+B.\")") + (checkdoc-defun))) + +(ert-deftest checkdoc-cl-defmethod-qualified-ok () + "Checkdoc should be happy with a `cl-defmethod' using qualifiers." + (with-temp-buffer + (emacs-lisp-mode) + (insert "(cl-defmethod test :around ((a (eql 'smthg))) \"Return A.\")") + (checkdoc-defun))) + +(ert-deftest checkdoc-cl-defmethod-with-extra-qualifier-ok () + "Checkdoc should be happy with a :extra qualified `cl-defmethod'." + (with-temp-buffer + (emacs-lisp-mode) + (insert "(cl-defmethod foo :extra \"foo\" ((a (eql 'smthg))) \"Return A.\")") + (checkdoc-defun)) + + (with-temp-buffer + (emacs-lisp-mode) + (insert + "(cl-defmethod foo :extra \"foo\" :after ((a (eql 'smthg))) \"Return A.\")") + (checkdoc-defun))) + +(ert-deftest checkdoc-cl-defmethod-with-extra-qualifier-and-nil-args-ok () + "Checkdoc should be happy with a 0-arity :extra qualified `cl-defmethod'." + (with-temp-buffer + (emacs-lisp-mode) + (insert "(cl-defmethod foo :extra \"foo\" () \"Return A.\")") + (checkdoc-defun))) + +(ert-deftest checkdoc-cl-defun-with-key-ok () + "Checkdoc should be happy with a cl-defun using &key." + (with-temp-buffer + (emacs-lisp-mode) + (insert "(cl-defun foo (&key a (b 27)) \"Return :A+:B.\")") + (checkdoc-defun))) + +(ert-deftest checkdoc-cl-defun-with-allow-other-keys-ok () + "Checkdoc should be happy with a cl-defun using &allow-other-keys." + (with-temp-buffer + (emacs-lisp-mode) + (insert "(cl-defun foo (&key a &allow-other-keys) \"Return :A.\")") + (checkdoc-defun))) + +(ert-deftest checkdoc-cl-defun-with-default-optional-value-ok () + "Checkdoc should be happy with a cl-defun using default values for optional args." + (with-temp-buffer + (emacs-lisp-mode) + ;; B is optional and equals 1+a if not provided. HAS-BS is non-nil + ;; if B was provided in the call: + (insert "(cl-defun foo (a &optional (b (1+ a) has-bs)) \"Return A + B.\")") + (checkdoc-defun))) + +(ert-deftest checkdoc-cl-defun-with-destructuring-ok () + "Checkdoc should be happy with a cl-defun destructuring its arguments." + (with-temp-buffer + (emacs-lisp-mode) + (insert "(cl-defun foo ((a b &optional c) d) \"Return A+B+C+D.\")") + (checkdoc-defun))) + (ert-deftest checkdoc-tests--next-docstring () "Checks that the one-argument form of `defvar' works. See the comments in Bug#24998." @@ -50,4 +122,100 @@ See the comments in Bug#24998." (should (looking-at-p "\"baz\")")) (should-not (checkdoc-next-docstring)))) +(defun checkdoc-tests--abbrev-test (buffer-contents goto-string) + (with-temp-buffer + (emacs-lisp-mode) + (insert buffer-contents) + (goto-char (point-min)) + (re-search-forward goto-string) + (checkdoc-in-abbreviation-p (point)))) + +(ert-deftest checkdoc-tests-in-abbrevation-p/basic-case () + (should (checkdoc-tests--abbrev-test "foo bar e.g. baz" "e.g")) + (should (checkdoc-tests--abbrev-test "behavior/errors etc. that" "etc")) + (should (checkdoc-tests--abbrev-test "foo vs. bar" "vs")) + (should (checkdoc-tests--abbrev-test "spy a.k.a. spy" "a.k.a"))) + +(ert-deftest checkdoc-tests-in-abbrevation-p/with-parens () + (should (checkdoc-tests--abbrev-test "foo bar (e.g. baz)" "e.g"))) + +(ert-deftest checkdoc-tests-in-abbrevation-p/with-escaped-parens () + (should (checkdoc-tests--abbrev-test "foo\n\\(e.g. baz)" "e.g"))) + +(ert-deftest checkdoc-tests-in-abbrevation-p/single-char () + (should (checkdoc-tests--abbrev-test "a. foo bar" "a"))) + +(ert-deftest checkdoc-tests-in-abbrevation-p/with-em-dash () + (should (checkdoc-tests--abbrev-test "foo bar baz---e.g." "e.g"))) + +(ert-deftest checkdoc-tests-in-abbrevation-p/incorrect-abbreviation () + (should-not (checkdoc-tests--abbrev-test "foo bar a.b.c." "a.b.c"))) + +(defun checkdoc-test-error-format-is-good (msg &optional reverse literal) + (with-temp-buffer + (erase-buffer) + (emacs-lisp-mode) + (let ((standard-output (current-buffer))) + (if literal + (print (format "(error \"%s\")" msg)) + (prin1 `(error ,msg)))) + (goto-char (length "(error \"")) + (if reverse + (should (checkdoc--error-bad-format-p)) + (should-not (checkdoc--error-bad-format-p))))) + +(defun checkdoc-test-error-format-is-bad (msg &optional literal) + (checkdoc-test-error-format-is-good msg t literal)) + +(ert-deftest checkdoc-tests-error-message-bad-format-p () + (checkdoc-test-error-format-is-good "Foo") + (checkdoc-test-error-format-is-good "Foo: bar baz") + (checkdoc-test-error-format-is-good "some-symbol: Foo") + (checkdoc-test-error-format-is-good "`some-symbol' foo bar") + (checkdoc-test-error-format-is-good "%sfoo") + (checkdoc-test-error-format-is-good "avl-tree-enter:\\ + Updated data does not match existing data" nil 'literal)) + +(ert-deftest checkdoc-tests-error-message-bad-format-p/defined-symbols () + (defvar checkdoc-tests--var-symbol nil) + (checkdoc-test-error-format-is-good "checkdoc-tests--var-symbol foo bar baz") + (defun checkdoc-tests--fun-symbol ()) + (checkdoc-test-error-format-is-good "checkdoc-tests--fun-symbol foo bar baz")) + +(ert-deftest checkdoc-tests-error-message-bad-format-p/not-capitalized () + (checkdoc-test-error-format-is-bad "foo") + (checkdoc-test-error-format-is-bad "some-symbol: foo") + (checkdoc-test-error-format-is-bad "avl-tree-enter:\ + updated data does not match existing data")) + +(ert-deftest checkdoc-tests-fix-y-or-n-p () + (with-temp-buffer + (emacs-lisp-mode) + (let ((standard-output (current-buffer)) + (checkdoc-autofix-flag 'automatic)) + (prin1 '(y-or-n-p "foo")) ; "foo" + (goto-char (length "(y-or-n-p ")) + (checkdoc--fix-y-or-n-p) + (should (equal (buffer-string) "(y-or-n-p \"foo?\")"))))) + +(ert-deftest checkdoc-tests-fix-y-or-n-p/no-change () + (with-temp-buffer + (emacs-lisp-mode) + (let ((standard-output (current-buffer)) + (checkdoc-autofix-flag 'automatic)) + (prin1 '(y-or-n-p "foo?")) ; "foo?" + (goto-char (length "(y-or-n-p ")) + (checkdoc--fix-y-or-n-p) + (should (equal (buffer-string) "(y-or-n-p \"foo?\")"))))) + +(ert-deftest checkdoc-tests-fix-y-or-n-p/with-space () + (with-temp-buffer + (emacs-lisp-mode) + (let ((standard-output (current-buffer)) + (checkdoc-autofix-flag 'automatic)) + (prin1 '(y-or-n-p "foo? ")) ; "foo? " + (goto-char (length "(y-or-n-p ")) + (checkdoc--fix-y-or-n-p) + (should (equal (buffer-string) "(y-or-n-p \"foo? \")"))))) + ;;; checkdoc-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-extra-tests.el b/test/lisp/emacs-lisp/cl-extra-tests.el index c37caa1aab7..297e413d858 100644 --- a/test/lisp/emacs-lisp/cl-extra-tests.el +++ b/test/lisp/emacs-lisp/cl-extra-tests.el @@ -1,21 +1,21 @@ ;;; cl-extra-tests.el --- tests for emacs-lisp/cl-extra.el -*- lexical-binding:t -*- -;; Copyright (C) 2013-2017 Free Software Foundation, Inc. +;; Copyright (C) 2013-2022 Free Software Foundation, Inc. ;; 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. -;; +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: @@ -77,7 +77,7 @@ (fn3 (lambda (x _y _z) (string-to-char (format "%S" x))))) (should (equal lst (cl-map 'list fn1 lst))) (should (equal (vconcat lst2) (cl-map 'vector fn2 lst lst2))) - (should (equal (mapconcat (lambda (x) (format "%S" x)) lst "") + (should (equal (mapconcat (lambda (x) (format "%S" x)) lst) (cl-map 'string fn3 lst lst2 lst3))))) (ert-deftest cl-extra-test-maplist () @@ -94,4 +94,17 @@ (should (equal (list lst3 (cdr lst3) (cddr lst3)) (cl-maplist fn3 lst lst2 lst3))))) +(ert-deftest cl-extra-test-cl-make-random-state () + (let ((s (cl-make-random-state))) + ;; Test for Bug#33731. + (should-not (eq s (cl-make-random-state s))))) + +(ert-deftest cl-concatenate () + (should (equal (cl-concatenate 'list '(1 2 3) '(4 5 6)) + '(1 2 3 4 5 6))) + (should (equal (cl-concatenate 'vector [1 2 3] [4 5 6]) + [1 2 3 4 5 6])) + (should (equal (cl-concatenate 'string "123" "456") + "123456"))) + ;;; cl-extra-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-generic-tests.el b/test/lisp/emacs-lisp/cl-generic-tests.el index 9b2b04bcca4..56b766769ea 100644 --- a/test/lisp/emacs-lisp/cl-generic-tests.el +++ b/test/lisp/emacs-lisp/cl-generic-tests.el @@ -1,6 +1,6 @@ ;;; cl-generic-tests.el --- Tests for cl-generic.el functionality -*- lexical-binding: t; -*- -;; Copyright (C) 2015-2017 Free Software Foundation, Inc. +;; Copyright (C) 2015-2022 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> @@ -23,8 +23,15 @@ ;;; Code: -(eval-when-compile (require 'ert)) ;Don't indirectly require cl-lib at run-time. (require 'cl-generic) +(require 'edebug) + +;; Don't indirectly require `cl-lib' at run-time. +(require 'ert) +(declare-function ert--should-signal-hook "ert") +(declare-function ert--signal-should-execution "ert") +(declare-function ert-fail "ert") +(declare-function ert-set-test "ert") (fmakunbound 'cl--generic-1) (cl-defgeneric cl--generic-1 (x y)) @@ -49,7 +56,14 @@ (should (equal (cl--generic-1 'a nil) '(a))) (should (equal (cl--generic-1 4 nil) '("quatre" 4))) (should (equal (cl--generic-1 5 nil) '("cinq" 5))) - (should (equal (cl--generic-1 6 nil) '("six" a)))) + (should (equal (cl--generic-1 6 nil) '("six" a))) + (defvar cl--generic-fooval 41) + (cl-defmethod cl--generic-1 ((_x (eql (+ cl--generic-fooval 1))) _y) + "forty-two") + (cl-defmethod cl--generic-1 (_x (_y (eql 42))) + "FORTY-TWO") + (should (equal (cl--generic-1 42 nil) "forty-two")) + (should (equal (cl--generic-1 nil 42) "FORTY-TWO"))) (cl-defstruct cl-generic-struct-parent a b) (cl-defstruct (cl-generic-struct-child1 (:include cl-generic-struct-parent)) c) @@ -186,9 +200,14 @@ (fmakunbound 'cl--generic-1) (cl-defgeneric cl--generic-1 (x y)) (cl-defmethod cl--generic-1 ((x t) y) - (list x y (cl-next-method-p))) + (list x y + (with-suppressed-warnings ((obsolete cl-next-method-p)) + (cl-next-method-p)))) (cl-defmethod cl--generic-1 ((_x (eql 4)) _y) - (cl-list* "quatre" (cl-next-method-p) (cl-call-next-method))) + (cl-list* "quatre" + (with-suppressed-warnings ((obsolete cl-next-method-p)) + (cl-next-method-p)) + (cl-call-next-method))) (should (equal (cl--generic-1 4 5) '("quatre" t 4 5 nil)))) (ert-deftest cl-generic-test-12-context () @@ -233,7 +252,7 @@ (let ((retval (cl--generic-method-files 'cl-generic-tests--generic))) (should (equal (length retval) 2)) (mapc (lambda (x) - (should (equal (car x) cl-generic-tests--this-file)) + (should (equal (file-truename (car x)) cl-generic-tests--this-file)) (should (equal (cadr x) 'cl-generic-tests--generic))) retval) (should-not (equal (nth 0 retval) (nth 1 retval))))) @@ -243,5 +262,40 @@ (should-not (cl--generic-method-files 'cl-generic-tests--undefined-generic)) (should-not (cl--generic-method-files 'cl-generic-tests--generic-without-methods))) +(ert-deftest cl-defgeneric/edebug/method () + "Check that `:method' forms in `cl-defgeneric' create unique +Edebug symbols (Bug#42672)." + (with-temp-buffer + (dolist (form '((cl-defgeneric cl-defgeneric/edebug/method/1 (_) + (:method ((_ number)) 1) + (:method ((_ string)) 2) + (:method :around ((_ number)) 3)) + (cl-defgeneric cl-defgeneric/edebug/method/2 (_) + (:method ((_ number)) 3)))) + (print form (current-buffer))) + (let* ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop) + (instrumented-names ()) + (edebug-new-definition-function + (lambda (name) + (when (memq name instrumented-names) + (error "Duplicate definition of `%s'" name)) + (push name instrumented-names) + (edebug-new-definition name)))) + (eval-buffer) + (should (equal + (reverse instrumented-names) + ;; The generic function definitions come after the + ;; method definitions because their body ends later. + ;; FIXME: We'd rather have names such as + ;; `cl-defgeneric/edebug/method/1 ((_ number))', but + ;; that requires further changes to Edebug. + (list (intern "cl-defgeneric/edebug/method/1 (number)") + (intern "cl-defgeneric/edebug/method/1 (string)") + (intern "cl-defgeneric/edebug/method/1 :around (number)") + 'cl-defgeneric/edebug/method/1 + (intern "cl-defgeneric/edebug/method/2 (number)") + 'cl-defgeneric/edebug/method/2)))))) + (provide 'cl-generic-tests) ;;; cl-generic-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index 13c9af9bd6d..b19494af746 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -1,21 +1,21 @@ ;;; cl-lib-tests.el --- tests for emacs-lisp/cl-lib.el -*- lexical-binding:t -*- -;; Copyright (C) 2013-2017 Free Software Foundation, Inc. +;; Copyright (C) 2013-2022 Free Software Foundation, Inc. ;; 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. -;; +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -201,6 +201,10 @@ :b :a :a 42) '(42 :a)))) +(ert-deftest cl-lib-empty-keyargs () + (should-error (funcall (cl-function (lambda (&key) 1)) + :b 1))) + (cl-defstruct (mystruct (:constructor cl-lib--con-1 (&aux (abc 1))) (:constructor cl-lib--con-2 (&optional def) "Constructor docstring.")) @@ -216,7 +220,7 @@ (should-error (cl-struct-slot-offset 'mystruct 'marypoppins)) (should (pcase (cl-struct-slot-info 'mystruct) (`((cl-tag-slot) (abc 5 :readonly t) - (def . ,(or `nil `(nil)))) + (def . ,(or 'nil '(nil)))) t))))) (ert-deftest cl-lib-struct-constructors () (should (string-match "\\`Constructor docstring." @@ -238,6 +242,22 @@ (should (= (cl-the integer (cl-incf side-effect)) 1)) (should (= side-effect 1)))) +(ert-deftest cl-lib-test-incf () + (let ((var 0)) + (should (= (cl-incf var) 1)) + (should (= var 1))) + (let ((alist)) + (should (= (cl-incf (alist-get 'a alist 0)) 1)) + (should (= (alist-get 'a alist 0) 1)))) + +(ert-deftest cl-lib-test-decf () + (let ((var 1)) + (should (= (cl-decf var) 0)) + (should (= var 0))) + (let ((alist)) + (should (= (cl-decf (alist-get 'a alist 0)) -1)) + (should (= (alist-get 'a alist 0) -1)))) + (ert-deftest cl-lib-test-plusp () (should-not (cl-plusp -1.0e+INF)) (should-not (cl-plusp -1.5e2)) @@ -333,13 +353,6 @@ (should (= 5 (cl-fifth '(1 2 3 4 5 6)))) (should-error (cl-fifth "12345") :type 'wrong-type-argument)) -(ert-deftest cl-lib-test-fifth () - (should (null (cl-fifth '()))) - (should (null (cl-fifth '(1 2 3 4)))) - (should (= 5 (cl-fifth '(1 2 3 4 5)))) - (should (= 5 (cl-fifth '(1 2 3 4 5 6)))) - (should-error (cl-fifth "12345") :type 'wrong-type-argument)) - (ert-deftest cl-lib-test-sixth () (should (null (cl-sixth '()))) (should (null (cl-sixth '(1 2 3 4 5)))) @@ -397,22 +410,6 @@ (should-error (cl-nth-value -1 (cl-values 2 3)) :type 'args-out-of-range) (should (string= (cl-nth-value 0 "only lists") "only lists"))) -(ert-deftest cl-test-caaar () - (should (null (cl-caaar '()))) - (should (null (cl-caaar '(() (2))))) - (should (null (cl-caaar '((() (2)) (a b))))) - (should-error (cl-caaar '(1 2)) :type 'wrong-type-argument) - (should-error (cl-caaar '((1 2))) :type 'wrong-type-argument) - (should (= 1 (cl-caaar '(((1 2) (3 4)))))) - (should (null (cl-caaar '((() (3 4))))))) - -(ert-deftest cl-test-caadr () - (should (null (cl-caadr '()))) - (should (null (cl-caadr '(1)))) - (should-error (cl-caadr '(1 2)) :type 'wrong-type-argument) - (should (= 2 (cl-caadr '(1 (2 3))))) - (should (equal '((2) (3)) (cl-caadr '((1) (((2) (3))) (4)))))) - (ert-deftest cl-test-ldiff () (let ((l '(1 2 3))) (should (null (cl-ldiff '() '()))) @@ -512,15 +509,18 @@ (ert-deftest cl-lib-symbol-macrolet-2 () (should (equal (cl-lib-symbol-macrolet-4+5) (+ 4 5)))) -(defun cl-lib-tests--dummy-function () - ;; Dummy function to see if the file is compiled. - t) + +(ert-deftest cl-lib-symbol-macrolet-hide () + ;; bug#26325, bug#26073 + (should (equal (let ((y 5)) + (cl-symbol-macrolet ((x y)) + (list x + (let ((x 6)) (list x y)) + (cl-letf ((x 6)) (list x y)) + (apply (lambda (x) (+ x 1)) (list 8))))) + '(5 (6 5) (6 6) 9)))) (ert-deftest cl-lib-defstruct-record () - ;; This test fails when compiled, see Bug#24402/27718. - :expected-result (if (byte-code-function-p - (symbol-function 'cl-lib-tests--dummy-function)) - :failed :passed) (cl-defstruct foo x) (let ((x (make-foo :x 42))) (should (recordp x)) @@ -535,6 +535,7 @@ (should (eq (type-of x) 'vector)) (cl-old-struct-compat-mode 1) + (defvar cl-struct-foo) (let ((cl-struct-foo (cl--struct-get-class 'foo))) (setf (symbol-function 'cl-struct-foo) :quick-object-witness-check) (should (eq (type-of x) 'foo)) @@ -550,4 +551,9 @@ (should cl-old-struct-compat-mode) (cl-old-struct-compat-mode (if saved 1 -1)))) +(ert-deftest cl-constantly () + (should (equal (mapcar (cl-constantly 3) '(a b c d)) + '(3 3 3 3)))) + + ;;; cl-lib-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 575f170af6c..f742637ee35 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -1,21 +1,21 @@ ;;; cl-macs-tests.el --- tests for emacs-lisp/cl-macs.el -*- lexical-binding:t -*- -;; Copyright (C) 2017 Free Software Foundation, Inc. +;; Copyright (C) 2017-2022 Free Software Foundation, Inc. ;; 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. -;; +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -23,14 +23,17 @@ (require 'cl-lib) (require 'cl-macs) +(require 'edebug) (require 'ert) +(require 'ert-x) +(require 'pcase) ;;;; cl-loop tests -- many adapted from Steele's CLtL2 ;;; ANSI 6.1.1.7 Destructuring (ert-deftest cl-macs-loop-and-assignment () - ;; Bug#6583 + "Bug#6583" :expected-result :failed (should (equal (cl-loop for numlist in '((1 2 4.0) (5 6 8.3) (8 9 10.4)) for a = (cl-first numlist) @@ -39,6 +42,15 @@ collect (list c b a)) '((4.0 2 1) (8.3 6 5) (10.4 9 8))))) +(ert-deftest cl-macs-loop-and-arrays () + "Bug#40727" + (should (equal (cl-loop for y = (- (or x 0)) and x across [1 2] + collect (cons x y)) + '((1 . 0) (2 . -1)))) + (should (equal (cl-loop for x across [1 2] and y = (- (or x 0)) + collect (cons x y)) + '((1 . 0) (2 . -1))))) + (ert-deftest cl-macs-loop-destructure () (should (equal (cl-loop for (a b c) in '((1 2 4.0) (5 6 8.3) (8 9 10.4)) collect (list c b a)) @@ -61,7 +73,6 @@ ;;; 6.1.2.1.1 The for-as-arithmetic subclause (ert-deftest cl-macs-loop-for-as-arith () "Test various for-as-arithmetic subclauses." - :expected-result :failed (should (equal (cl-loop for i to 10 by 3 collect i) '(0 3 6 9))) (should (equal (cl-loop for i upto 3 collect i) @@ -74,9 +85,9 @@ '(10 8 6))) (should (equal (cl-loop for i from 10 downto 1 by 3 collect i) '(10 7 4 1))) - (should (equal (cl-loop for i above 0 by 2 downfrom 10 collect i) + (should (equal (cl-loop for i downfrom 10 above 0 by 2 collect i) '(10 8 6 4 2))) - (should (equal (cl-loop for i downto 10 from 15 collect i) + (should (equal (cl-loop for i from 15 downto 10 collect i) '(15 14 13 12 11 10)))) (ert-deftest cl-macs-loop-for-as-arith-order-side-effects () @@ -417,7 +428,9 @@ collection clause." '(2 3 4 5 6)))) (ert-deftest cl-macs-loop-across-ref () - (should (equal (cl-loop with my-vec = ["one" "two" "three"] + (should (equal (cl-loop with my-vec = (vector (cl-copy-seq "one") + (cl-copy-seq "two") + (cl-copy-seq "three")) for x across-ref my-vec do (setf (aref x 0) (upcase (aref x 0))) finally return my-vec) @@ -497,4 +510,297 @@ 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))) + (should (equal '((0 0) (1 1) (2 2)) + (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)) + +(ert-deftest cl-macs-test--symbol-macrolet () + ;; A `setq' shouldn't be converted to a `setf' just because it occurs within + ;; a symbol-macrolet! + (should-error + ;; Use `eval' so the error is signaled when running the test rather than + ;; when macroexpanding it. + (eval '(let ((l (list 1))) (cl-symbol-macrolet ((x 1)) (setq (car l) 0))) t)) + ;; Make sure `gv-synthetic-place' isn't macro-expanded before `setf' gets to + ;; see its `gv-expander'. + (should (equal (let ((l '(0))) + (let ((cl (car l))) + (cl-symbol-macrolet + ((p (gv-synthetic-place cl (lambda (v) `(setcar l ,v))))) + (cl-incf p))) + l) + '(1))) + ;; Make sure `gv-synthetic-place' isn't macro-expanded before + ;; `cl-letf' gets to see its `gv-expander'. + (should (equal + (condition-case err + (let ((x 1)) + (list x + (cl-letf (((gv-synthetic-place (+ 1 2) + (lambda (v) `(setq x ,v))) + 7)) + x) + x)) + (error err)) + '(1 7 3))) + (should (equal + (let ((x (list 42))) + (cl-symbol-macrolet ((m (car x))) + (list m + (cl-letf ((m 5)) m) + m))) + '(42 5 42)))) + +(ert-deftest cl-macs-loop-conditional-step-clauses () + "These tests failed under the initial fixes in #bug#29799." + (should (cl-loop for i from 1 upto 100 and j = 1 then (1+ j) + if (not (= i j)) + return nil + end + until (> j 10) + finally return t)) + + (should (equal (let* ((size 7) + (arr (make-vector size 0))) + (cl-loop for k below size + for x = (* 2 k) and y = (1+ (elt arr k)) + collect (list k x y))) + '((0 0 1) (1 2 1) (2 4 1) (3 6 1) (4 8 1) (5 10 1) (6 12 1)))) + + (should (equal (cl-loop for x below 3 + for y below 2 and z = 1 + collect x) + '(0 1))) + + (should (equal (cl-loop for x below 3 + and y below 2 + collect x) + '(0 1))) + + ;; this is actually disallowed in clisp, but is semantically consistent + (should (equal (cl-loop with result + for x below 3 + for y = (progn (push x result) x) and z = 1 + append (list x y) into result1 + finally return (append result result1)) + '(2 1 0 0 0 1 1 2 2))) + + (should (equal (cl-loop with result + for x below 3 + for _y = (progn (push x result)) + finally return result) + '(2 1 0))) + + ;; this unintuitive result is replicated by clisp + (should (equal (cl-loop with result + for x below 3 + and y = (progn (push x result)) + finally return result) + '(2 1 0 0))) + + ;; this unintuitive result is replicated by clisp + (should (equal (cl-loop with result + for x below 3 + and y = (progn (push x result)) then (progn (push (1+ x) result)) + finally return result) + '(3 2 1 0))) + + (should (cl-loop with result + for x below 3 + for y = (progn (push x result) x) then (progn (push (1+ x) result) (1+ x)) + and z = 1 + collect y into result1 + finally return (equal (nreverse result) result1)))) + +(ert-deftest cl-macs-aux-edebug () + "Check that Bug#40431 is fixed." + (with-temp-buffer + (prin1 '(cl-defun cl-macs-aux-edebug-test-fun (&aux ((a . b) '(1 . 2))) + (list a b)) + (current-buffer)) + ;; Just make sure the function can be instrumented. + (edebug-defun))) + +;;; cl-labels + +(ert-deftest cl-macs--labels () + ;; Simple recursive function. + (cl-labels ((len (xs) (if xs (1+ (len (cdr xs))) 0))) + (should (equal (len (make-list 42 t)) 42))) + + (let ((list-42 (make-list 42 t)) + (list-42k (make-list 42000 t))) + + (cl-labels + ;; Simple tail-recursive function. + ((len (xs n) (if xs (len (cdr xs) (1+ n)) n)) + ;; Slightly obfuscated version to exercise tail calls from + ;; `let', `progn', `and' and `or'. + (len2 (xs n) (or (and (not xs) n) + (let (n1) + (and xs + (progn (setq n1 (1+ n)) + (len2 (cdr xs) n1)))))) + ;; Tail calls in error and success handlers. + (len3 (xs n) + (if xs + (condition-case k + (/ 1 (logand n 1)) + (arith-error (len3 (cdr xs) (1+ n))) + (:success (len3 (cdr xs) (+ n k)))) + n)) + + ;; Tail calls in `cond'. + (len4 (xs n) + (cond (xs (cond (nil 'nevertrue) + ((len4 (cdr xs) (1+ n))))) + (t n)))) + (should (equal (len nil 0) 0)) + (should (equal (len2 nil 0) 0)) + (should (equal (len3 nil 0) 0)) + (should (equal (len4 nil 0) 0)) + (should (equal (len list-42 0) 42)) + (should (equal (len2 list-42 0) 42)) + (should (equal (len3 list-42 0) 42)) + (should (equal (len4 list-42 0) 42)) + ;; Should not bump into stack depth limits. + (should (equal (len list-42k 0) 42000)) + (should (equal (len2 list-42k 0) 42000)) + (should (equal (len3 list-42k 0) 42000)) + (should (equal (len4 list-42k 0) 42000)))) + + ;; Check that non-recursive functions are handled more efficiently. + (should (pcase (macroexpand '(cl-labels ((f (x) (+ x 1))) (f 5))) + (`(let* ,_ (funcall ,_ 5)) t))) + + ;; Case of "tail-recursive lambdas". + (should (pcase (macroexpand + '(cl-labels ((len (xs n) (if xs (len (cdr xs) (1+ n)) n))) + #'len)) + (`(function (lambda (,_ ,_) . ,_)) t))) + + ;; Verify that there is no tail position inside dynamic variable bindings. + (defvar dyn-var) + (let ((dyn-var 'a)) + (cl-labels ((f (x) (if x + dyn-var + (let ((dyn-var 'b)) + (f dyn-var))))) + (should (equal (f nil) 'b)))) + + ;; Control: same as above but with lexical binding. + (let ((lex-var 'a)) + (cl-labels ((f (x) (if x + lex-var + (let ((lex-var 'b)) + (f lex-var))))) + (should (equal (f nil) 'a))))) + +(ert-deftest cl-macs--progv () + (defvar cl-macs--test) + (defvar cl-macs--test1) + (defvar cl-macs--test2) + (should (= (cl-progv '(cl-macs--test cl-macs--test) '(1 2) cl-macs--test) 2)) + (should (equal (cl-progv '(cl-macs--test1 cl-macs--test2) '(1 2) + (list cl-macs--test1 cl-macs--test2)) + '(1 2)))) + +(ert-deftest cl-define-compiler-macro/edebug () + "Check that we can instrument compiler macros." + (with-temp-buffer + (dolist (form '((defun cl-define-compiler-macro/edebug (a b) nil) + (cl-define-compiler-macro + cl-define-compiler-macro/edebug + (&whole w a b) + w))) + (print form (current-buffer))) + (let ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop)) + ;; Just make sure the forms can be instrumented. + (eval-buffer)))) + +(ert-deftest cl-defstruct/edebug () + "Check that we can instrument `cl-defstruct' forms." + (with-temp-buffer + (dolist (form '((cl-defstruct cl-defstruct/edebug/1) + (cl-defstruct (cl-defstruct/edebug/2 + :noinline)) + (cl-defstruct (cl-defstruct/edebug/3 + (:noinline t))) + (cl-defstruct (cl-defstruct/edebug/4 + :named)) + (cl-defstruct (cl-defstruct/edebug/5 + (:named t))))) + (print form (current-buffer))) + (let ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop)) + ;; Just make sure the forms can be instrumented. + (eval-buffer)))) + +(ert-deftest cl-case-error () + "Test that `cl-case' and `cl-ecase' signal an error if a t or +`otherwise' key is misplaced." + (let ((text-quoting-style 'grave)) + (dolist (form '((cl-case val (t 1) (123 2)) + (cl-ecase val (t 1) (123 2)) + (cl-ecase val (123 2) (t 1)))) + (ert-info ((prin1-to-string form) :prefix "Form: ") + (let ((error (should-error (macroexpand form)))) + (should (equal (cdr error) + '("Misplaced t or `otherwise' clause")))))))) + +(ert-deftest cl-case-warning () + "Test that `cl-case' and `cl-ecase' warn about suspicious +constructs." + (let ((text-quoting-style 'grave)) + (pcase-dolist (`(,case . ,message) + `((nil . "Case nil will never match") + ('nil . ,(concat "Case 'nil will match `quote'. " + "If that's intended, write " + "(nil quote) instead. " + "Otherwise, don't quote `nil'.")) + ('t . ,(concat "Case 't will match `quote'. " + "If that's intended, write " + "(t quote) instead. " + "Otherwise, don't quote `t'.")) + ('foo . ,(concat "Case 'foo will match `quote'. " + "If that's intended, write " + "(foo quote) instead. " + "Otherwise, don't quote `foo'.")) + (#'foo . ,(concat "Case #'foo will match " + "`function'. If that's " + "intended, write (foo function) " + "instead. Otherwise, don't " + "quote `foo'.")))) + (dolist (macro '(cl-case cl-ecase)) + (let ((form `(,macro val (,case 1)))) + (ert-info ((prin1-to-string form) :prefix "Form: ") + (ert-with-message-capture messages + (macroexpand form) + (should (equal messages + (concat "Warning: " message "\n")))))))))) + +(ert-deftest cl-case-no-warning () + "Test that `cl-case' and `cl-ecase' don't warn in some valid cases. +See Bug#57915." + (dolist (case '(quote (quote) function (function))) + (dolist (macro '(cl-case cl-ecase)) + (let ((form `(,macro val (,case 1)))) + (ert-info ((prin1-to-string form) :prefix "Form: ") + (ert-with-message-capture messages + (macroexpand form) + (should (string-empty-p messages)))))))) + ;;; 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 00000000000..43cd7b6bff1 --- /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-2022 Free Software Foundation, Inc. +;; Author: Philipp Stephani <phst@google.com> + +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. + +;;; 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 diff --git a/test/lisp/emacs-lisp/cl-print-tests.el b/test/lisp/emacs-lisp/cl-print-tests.el index a5dd5abf46b..57fe52a948e 100644 --- a/test/lisp/emacs-lisp/cl-print-tests.el +++ b/test/lisp/emacs-lisp/cl-print-tests.el @@ -1,6 +1,6 @@ ;;; cl-print-tests.el --- Test suite for the cl-print facility. -*- lexical-binding:t -*- -;; Copyright (C) 2017 Free Software Foundation, Inc. +;; Copyright (C) 2017-2022 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -19,40 +19,146 @@ ;;; Commentary: +;; See test/src/print-tests.el for tests which apply to both +;; cl-print.el and src/print.c. + ;;; Code: (require 'ert) -(cl-defstruct cl-print--test a b) +(cl-defstruct (cl-print-tests-struct + (:constructor cl-print-tests-con)) + a b c d e) -(ert-deftest cl-print-tests-1 () - "Test cl-print code." - (let ((x (make-cl-print--test :a 1 :b 2))) - (let ((print-circle nil)) - (should (equal (cl-prin1-to-string `((x . ,x) (y . ,x))) - "((x . #s(cl-print--test :a 1 :b 2)) (y . #s(cl-print--test :a 1 :b 2)))"))) - (let ((print-circle t)) - (should (equal (cl-prin1-to-string `((x . ,x) (y . ,x))) - "((x . #1=#s(cl-print--test :a 1 :b 2)) (y . #1#))"))) - (should (string-match "\\`#f(compiled-function (x) \"[^\"]+\" [^\)]*)\\'" - (cl-prin1-to-string (symbol-function #'caar)))))) - -(ert-deftest cl-print-tests-2 () - (let ((x (record 'foo 1 2 3))) - (should (equal - x - (car (read-from-string (with-output-to-string (prin1 x)))))) - (let ((print-circle t)) - (should (string-match - "\\`(#1=#s(foo 1 2 3) #1#)\\'" - (cl-prin1-to-string (list x x))))))) +(ert-deftest cl-print-tests-ellipsis-cons () + "Ellipsis expansion works in conses." + (let ((print-length 4) + (print-level 3)) + (cl-print-tests-check-ellipsis-expansion + '(0 1 2 3 4 5) "(0 1 2 3 ...)" "4 5") + (cl-print-tests-check-ellipsis-expansion + '(0 1 2 3 4 5 6 7 8 9) "(0 1 2 3 ...)" "4 5 6 7 ...") + (cl-print-tests-check-ellipsis-expansion + '(a (b (c (d (e))))) "(a (b (c ...)))" "(d (e))") + (cl-print-tests-check-ellipsis-expansion + (let ((x (make-list 6 'b))) + (setf (nthcdr 6 x) 'c) + x) + "(b b b b ...)" "b b . c"))) -(ert-deftest cl-print-circle () - (let ((x '(#1=(a . #1#) #1#))) +(ert-deftest cl-print-tests-ellipsis-vector () + "Ellipsis expansion works in vectors." + (let ((print-length 4) + (print-level 3)) + (cl-print-tests-check-ellipsis-expansion + [0 1 2 3 4 5] "[0 1 2 3 ...]" "4 5") + (cl-print-tests-check-ellipsis-expansion + [0 1 2 3 4 5 6 7 8 9] "[0 1 2 3 ...]" "4 5 6 7 ...") + (cl-print-tests-check-ellipsis-expansion + [a [b [c [d [e]]]]] "[a [b [c ...]]]" "[d [e]]"))) + +(ert-deftest cl-print-tests-ellipsis-string () + "Ellipsis expansion works in strings." + (let ((print-length 4) + (print-level 3)) + (cl-print-tests-check-ellipsis-expansion + "abcdefg" "\"abcd...\"" "efg") + (cl-print-tests-check-ellipsis-expansion + "abcdefghijk" "\"abcd...\"" "efgh...") + (cl-print-tests-check-ellipsis-expansion + '(1 (2 (3 #("abcde" 0 5 (test t))))) + "(1 (2 (3 ...)))" "#(\"abcd...\" 0 5 (test t))") + (cl-print-tests-check-ellipsis-expansion + #("abcd" 0 1 (bold t) 1 2 (invisible t) 3 4 (italic t)) + "#(\"abcd\" 0 1 (bold t) ...)" "1 2 (invisible t) ..."))) + +(ert-deftest cl-print-tests-ellipsis-struct () + "Ellipsis expansion works in structures." + (let ((print-length 4) + (print-level 3) + (struct (cl-print-tests-con))) + (cl-print-tests-check-ellipsis-expansion + struct "#s(cl-print-tests-struct :a nil :b nil :c nil :d nil ...)" ":e nil") + (let ((print-length 2)) + (cl-print-tests-check-ellipsis-expansion + struct "#s(cl-print-tests-struct :a nil :b nil ...)" ":c nil :d nil ...")) + (cl-print-tests-check-ellipsis-expansion + `(a (b (c ,struct))) + "(a (b (c ...)))" + "#s(cl-print-tests-struct :a nil :b nil :c nil :d nil ...)"))) + +(ert-deftest cl-print-tests-ellipsis-circular () + "Ellipsis expansion works with circular objects." + (let ((wide-obj (list 0 1 2 3 4)) + (deep-obj `(0 (1 (2 (3 (4)))))) + (print-length 4) + (print-level 3)) + (setf (nth 4 wide-obj) wide-obj) + (setf (car (cadadr (cadadr deep-obj))) deep-obj) (let ((print-circle nil)) - (should (string-match "\\`((a . #[0-9]) (a . #[0-9]))\\'" - (cl-prin1-to-string x)))) + (cl-print-tests-check-ellipsis-expansion-rx + wide-obj (regexp-quote "(0 1 2 3 ...)") "\\`#[0-9]\\'") + (cl-print-tests-check-ellipsis-expansion-rx + deep-obj (regexp-quote "(0 (1 (2 ...)))") "\\`(3 (#[0-9]))\\'")) (let ((print-circle t)) - (should (equal "(#1=(a . #1#) #1#)" (cl-prin1-to-string x)))))) + (cl-print-tests-check-ellipsis-expansion + wide-obj "#1=(0 1 2 3 ...)" "#1#") + (cl-print-tests-check-ellipsis-expansion + deep-obj "#1=(0 (1 (2 ...)))" "(3 (#1#))")))) + +(defun cl-print-tests-check-ellipsis-expansion (obj expected expanded) + (let* ((result (cl-prin1-to-string obj)) + (pos (next-single-property-change 0 'cl-print-ellipsis result)) + value) + (should pos) + (setq value (get-text-property pos 'cl-print-ellipsis result)) + (should (equal expected result)) + (should (equal expanded (with-output-to-string (cl-print-expand-ellipsis + value nil)))))) + +(defun cl-print-tests-check-ellipsis-expansion-rx (obj expected expanded) + (let* ((result (cl-prin1-to-string obj)) + (pos (next-single-property-change 0 'cl-print-ellipsis result)) + (value (get-text-property pos 'cl-print-ellipsis result))) + (should (string-match expected result)) + (should (string-match expanded (with-output-to-string + (cl-print-expand-ellipsis value nil)))))) + +(ert-deftest cl-print-tests-print-to-string-with-limit () + (let* ((thing10 (make-list 10 'a)) + (thing100 (make-list 100 'a)) + (thing10x10 (make-list 10 thing10)) + (nested-thing (let ((val 'a)) + (dotimes (_i 20) + (setq val (list val))) + val)) + ;; Make a consistent environment for this test. + (print-circle nil) + (print-level nil) + (print-length nil)) + + ;; Print something that fits in the space given. + (should (string= (cl-prin1-to-string thing10) + (cl-print-to-string-with-limit #'cl-prin1 thing10 100))) + + ;; Print something which needs to be abbreviated and which can be. + (should (< (length (cl-print-to-string-with-limit #'cl-prin1 thing100 100)) + 100 + (length (cl-prin1-to-string thing100)))) + + ;; Print something resistant to easy abbreviation. + (should (string= (cl-prin1-to-string thing10x10) + (cl-print-to-string-with-limit #'cl-prin1 thing10x10 100))) + + ;; Print something which should be abbreviated even if the limit is large. + (should (< (length (cl-print-to-string-with-limit #'cl-prin1 nested-thing 1000)) + (length (cl-prin1-to-string nested-thing)))) + + ;; Print with no limits. + (dolist (thing (list thing10 thing100 thing10x10 nested-thing)) + (let ((rep (cl-prin1-to-string thing))) + (should (string= rep (cl-print-to-string-with-limit #'cl-prin1 thing 0))) + (should (string= rep (cl-print-to-string-with-limit #'cl-prin1 thing nil))))))) + ;;; cl-print-tests.el ends here. diff --git a/test/lisp/emacs-lisp/cl-seq-tests.el b/test/lisp/emacs-lisp/cl-seq-tests.el index 8c0d55663ca..f42ae69873f 100644 --- a/test/lisp/emacs-lisp/cl-seq-tests.el +++ b/test/lisp/emacs-lisp/cl-seq-tests.el @@ -1,6 +1,6 @@ ;;; cl-seq-tests.el --- Tests for cl-seq.el functionality -*- lexical-binding: t; -*- -;; Copyright (C) 2015-2017 Free Software Foundation, Inc. +;; Copyright (C) 2015-2022 Free Software Foundation, Inc. ;; Author: Nicolas Richard <youngfrog@members.fsf.org> @@ -294,6 +294,7 @@ Body are forms defining the test." (ert-deftest cl-seq-test-bug24264 () "Test for https://debbugs.gnu.org/24264 ." + :tags '(:expensive-test) (let ((list (append (make-list 8000005 1) '(8))) (list2 (make-list 8000005 2))) (should (cl-position 8 list)) @@ -302,6 +303,14 @@ Body are forms defining the test." (should (equal '(2 8) (last (cl-replace list list2) 2))) (should (equal '(1 1) (last (cl-fill list 1) 2))))) +(ert-deftest cl-seq-bignum-eql () + (let ((x (+ most-positive-fixnum 1)) + (y (+ most-positive-fixnum 1))) + (let ((l (list y))) + (should (eq (cl-member x l) l))) + (let ((a (list (cons y 1) (cons 2 y)))) + (should (eq (cl-assoc x a) (car a))) + (should (eq (cl-rassoc x a) (cadr a)))))) (provide 'cl-seq-tests) ;;; cl-seq-tests.el ends here diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el new file mode 100644 index 00000000000..ba7ab6331ef --- /dev/null +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -0,0 +1,233 @@ +;;; comp-cstr-tests.el --- unit tests for src/comp.c -*- lexical-binding: t; -*- + +;; Copyright (C) 2020-2022 Free Software Foundation, Inc. + +;; Author: Andrea Corallo <akrl@sdf.org> + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Unit tests for lisp/emacs-lisp/comp-cstr.el + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'comp-cstr) + +(cl-eval-when (compile eval load) + + (defun comp-cstr-test-ts (type-spec) + "Create a constraint from TYPE-SPEC and convert it back to type specifier." + (let ((comp-ctxt (make-comp-cstr-ctxt))) + (comp-cstr-to-type-spec (comp-type-spec-to-cstr type-spec)))) + + (defun comp-cstr-typespec-test (number type-spec expected-type-spec) + `(ert-deftest ,(intern (concat "comp-cstr-test-" (int-to-string number))) () + (should (equal (comp-cstr-test-ts ',type-spec) + ',expected-type-spec)))) + + (defconst comp-cstr-typespec-tests-alist + `(;; 1 + (symbol . symbol) + ;; 2 + ((or string array) . array) + ;; 3 + ((or symbol number) . (or number symbol)) + ;; 4 + ((or cons atom) . (or atom cons)) ;; SBCL return T + ;; 5 + ((or integer number) . number) + ;; 6 + ((or (or integer symbol) number) . (or number symbol)) + ;; 7 + ((or (or integer symbol) (or number list)) . (or list number symbol)) + ;; 8 + ((or (or integer number) nil) . number) + ;; 9 + ((member foo) . (member foo)) + ;; 10 + ((member foo bar) . (member bar foo)) + ;; 11 + ((or (member foo) (member bar)) . (member bar foo)) + ;; 12 + ((or (member foo) symbol) . symbol) ;; SBCL return (OR SYMBOL (MEMBER FOO)) + ;; 13 + ((or (member foo) number) . (or (member foo) number)) + ;; 14 + ((or (integer 1 3) number) . number) + ;; 15 + (integer . integer) + ;; 16 + ((integer 1 2) . (integer 1 2)) + ;; 17 + ((or (integer -1 0) (integer 3 4)) . (or (integer -1 0) (integer 3 4))) + ;; 18 + ((or (integer -1 2) (integer 3 4)) . (integer -1 4)) + ;; 19 + ((or (integer -1 3) (integer 3 4)) . (integer -1 4)) + ;; 20 + ((or (integer -1 4) (integer 3 4)) . (integer -1 4)) + ;; 21 + ((or (integer -1 5) (integer 3 4)) . (integer -1 5)) + ;; 22 + ((or (integer -1 *) (integer 3 4)) . (integer -1 *)) + ;; 23 + ((or (integer -1 2) (integer * 4)) . (integer * 4)) + ;; 24 + ((and string array) . string) + ;; 25 + ((and cons atom) . nil) + ;; 26 + ((and (member foo) (member foo bar baz)) . (member foo)) + ;; 27 + ((and (member foo) (member bar)) . nil) + ;; 28 + ((and (member foo) symbol) . (member foo)) + ;; 29 + ((and (member foo) string) . nil) + ;; 30 + ((and (member foo) (integer 1 2)) . nil) + ;; 31 + ((and (member 1 2) (member 3 2)) . (integer 2 2)) + ;; 32 + ((and number (integer 1 2)) . (integer 1 2)) + ;; 33 + ((and integer (integer 1 2)) . (integer 1 2)) + ;; 34 + ((and (integer -1 0) (integer 3 5)) . nil) + ;; 35 + ((and (integer -1 2) (integer 3 5)) . nil) + ;; 36 + ((and (integer -1 3) (integer 3 5)) . (integer 3 3)) + ;; 37 + ((and (integer -1 4) (integer 3 5)) . (integer 3 4)) + ;; 38 + ((and (integer -1 5) nil) . nil) + ;; 39 + ((not symbol) . (not symbol)) + ;; 40 + ((or (member foo) (not (member foo bar))) . (not (member bar))) + ;; 41 + ((or (member foo bar) (not (member foo))) . t) + ;; 42 + ((or symbol (not sequence)) . (not sequence)) + ;; 43 + ((or symbol (not symbol)) . t) + ;; 44 + ((or symbol (not sequence)) . (not sequence)) + ;; 45 Conservative. + ((or vector (not sequence)) . t) + ;; 46 + ((or (integer 1 10) (not (integer * 5))) . (not (integer * 0))) + ;; 47 + ((or symbol (integer 1 10) (not (integer * 5))) . (not (integer * 0))) + ;; 48 + ((or (not symbol) (integer 1 10) (not (integer * 5))) . (not (or symbol (integer * 0)))) + ;; 49 + ((or symbol (not (member foo))) . (not (member foo))) + ;; 50 + ((or (not symbol) (not (member foo))) . (not symbol)) + ;; 51 Conservative. + ((or (not (member foo)) string) . (not (member foo))) + ;; 52 Conservative. + ((or (member foo) (not string)) . (not string)) + ;; 53 + ((or (not (integer 1 2)) integer) . t) + ;; 54 + ((or (not (integer 1 2)) (not integer)) . (not integer)) + ;; 55 + ((or (integer 1 2) (not integer)) . (not (or (integer * 0) (integer 3 *)))) + ;; 56 + ((or number (not (integer 1 2))) . t) + ;; 57 + ((or atom (not (integer 1 2))) . t) + ;; 58 + ((or atom (not (member foo))) . t) + ;; 59 + ((and symbol (not cons)) . symbol) + ;; 60 + ((and symbol (not symbol)) . nil) + ;; 61 + ((and atom (not symbol)) . atom) + ;; 62 + ((and atom (not string)) . (or array sequence atom)) + ;; 63 Conservative + ((and symbol (not (member foo))) . symbol) + ;; 64 Conservative + ((and symbol (not (member 3))) . symbol) + ;; 65 + ((and (not (member foo)) (integer 1 10)) . (integer 1 10)) + ;; 66 + ((and (member foo) (not (integer 1 10))) . (member foo)) + ;; 67 + ((and t (not (member foo))) . (not (member foo))) + ;; 68 + ((and integer (not (integer 3 4))) . (or (integer * 2) (integer 5 *))) + ;; 69 + ((and (integer 0 20) (not (integer 5 10))) . (or (integer 0 4) (integer 11 20))) + ;; 70 + ((and (not (member a)) (not (member b))) . (not (member a b))) + ;; 71 + ((and (not boolean) (not (member b))) . (not (or (member b) boolean))) + ;; 72 + ((and t (integer 1 1)) . (integer 1 1)) + ;; 73 + ((not (integer -1 5)) . (not (integer -1 5))) + ;; 74 + ((and boolean (or number marker)) . nil) + ;; 75 + ((and atom (or number marker)) . (or marker number)) + ;; 76 + ((and symbol (or number marker)) . nil) + ;; 77 + ((and (or symbol string) (or number marker)) . nil) + ;; 78 + ((and t t) . t) + ;; 79 + ((and (or marker number) (integer 0 0)) . (integer 0 0)) + ;; 80 + ((and t (not t)) . nil) + ;; 81 + ((or (integer 1 1) (not (integer 1 1))) . t) + ;; 82 + ((not t) . nil) + ;; 83 + ((not nil) . t) + ;; 84 + ((or (not string) t) . t) + ;; 85 + ((or (not vector) sequence) . sequence) + ;; 86 + ((or (not symbol) null) . t) + ;; 87 + ((and (or null integer) (not (or null integer))) . nil) + ;; 88 + ((and (or (member a b c)) (not (or (member a b)))) . (member c))) + "Alist type specifier -> expected type specifier.")) + +(defmacro comp-cstr-synthesize-tests () + "Generate all tests from `comp-cstr-typespec-tests-alist'." + `(progn + ,@(cl-loop + for i from 1 + for (ts . exp-ts) in comp-cstr-typespec-tests-alist + append (list (comp-cstr-typespec-test i ts exp-ts))))) + +(comp-cstr-synthesize-tests) + +;;; comp-cstr-tests.el ends here diff --git a/test/lisp/emacs-lisp/copyright-tests.el b/test/lisp/emacs-lisp/copyright-tests.el new file mode 100644 index 00000000000..b00d697aa64 --- /dev/null +++ b/test/lisp/emacs-lisp/copyright-tests.el @@ -0,0 +1,96 @@ +;;; copyright-tests.el --- tests for copyright.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'copyright) + +(defmacro with-copyright-test (orig result) + `(cl-letf (((symbol-function 'format-time-string) (lambda (&rest _) "2019"))) + (let ((copyright-query nil) + (copyright-current-year 2019)) + (with-temp-buffer + (insert ,orig) + (copyright-update) + (should (equal (buffer-string) ,result)))))) + +(defvar copyright-tests--data + '((";; Copyright (C) 2017 Free Software Foundation, Inc." + . ";; Copyright (C) 2017, 2019 Free Software Foundation, Inc.") + (";; Copyright (C) 2017-2018 Free Software Foundation, Inc." + . ";; Copyright (C) 2017-2019 Free Software Foundation, Inc.") + (";; Copyright (C) 2017–2018 Free Software Foundation, Inc." + . ";; Copyright (C) 2017–2019 Free Software Foundation, Inc.") + (";; Copyright (C) 2005-2006, 2015, 2017-2018 Free Software Foundation, Inc." + . ";; Copyright (C) 2005-2006, 2015, 2017-2019 Free Software Foundation, Inc.") + (";; Copyright (C) 2005–2006, 2015, 2017–2018 Free Software Foundation, Inc." + . ";; Copyright (C) 2005–2006, 2015, 2017–2019 Free Software Foundation, Inc.") + (";; copyright '18 FSF" + . ";; copyright '18, '19 FSF"))) + +(ert-deftest test-copyright-update () + (dolist (test copyright-tests--data) + (with-copyright-test (car test) (cdr test)))) + +(ert-deftest test-end-chop () + (should + (equal + (with-temp-buffer + (let ((copyright-query nil)) + (insert (make-string (- copyright-limit 14) ?x) "\n" + "\nCopyright 2006, 2007, 2008 Foo Bar\n\n") + (copyright-update) + (buffer-substring (- (point-max) 42) (point-max)))) + "Copyright 2006, 2007, 2008, 2022 Foo Bar\n\n"))) + +(ert-deftest test-correct-notice () + (should (equal + (with-temp-buffer + (dotimes (_ 2) + (insert "Copyright 2021 FSF\n")) + (let ((copyright-at-end-flag t) + (copyright-query nil)) + (copyright-update)) + (buffer-string)) + "Copyright 2021 FSF\nCopyright 2021, 2022 FSF\n"))) + +(defmacro with-copyright-fix-years-test (orig result) + `(let ((copyright-year-ranges t)) + (with-temp-buffer + (insert ,orig) + (copyright-fix-years) + (should (equal (buffer-string) ,result))))) + +(defvar copyright-fix-years-tests--data + '((";; Copyright (C) 2008, 2010, 2012" + . ";; Copyright (C) 2008, 2010, 2012") + (";; Copyright (C) 2008, 2009, 2010, 2013, 2014, 2015, 2016, 2018" + . ";; Copyright (C) 2008-2010, 2013-2016, 2018") + (";; Copyright (C) 2008-2010, 2011, 2015, 2016, 2017" + . ";; Copyright (C) 2008-2010, 2011, 2015-2017"))) + +(ert-deftest text-copyright-fix-years () + "Test basics of \\[copyright-fix-years]." + (dolist (test copyright-fix-years-tests--data) + (with-copyright-fix-years-test (car test) (cdr test)))) + +(provide 'copyright-tests) +;;; copyright-tests.el ends here diff --git a/test/lisp/emacs-lisp/derived-tests.el b/test/lisp/emacs-lisp/derived-tests.el new file mode 100644 index 00000000000..547b16843d4 --- /dev/null +++ b/test/lisp/emacs-lisp/derived-tests.el @@ -0,0 +1,64 @@ +;;; derived-tests.el --- tests for derived.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2017-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) + +(define-derived-mode derived-tests--parent-mode prog-mode "P" + :after-hook + (let ((f (let ((x "S")) (lambda () x)))) + (insert (format "AFP=%s " (let ((x "D")) x (funcall f))))) + (insert "PB ")) + +(define-derived-mode derived-tests--child-mode derived-tests--parent-mode "C" + :after-hook + (let ((f (let ((x "S")) (lambda () x)))) + (insert (format "AFC=%s " (let ((x "D")) x (funcall f))))) + (insert "CB ")) + +(ert-deftest derived-tests-after-hook-lexical () + (with-temp-buffer + (let ((derived-tests--child-mode-hook + (lambda () (insert "MH ")))) + (derived-tests--child-mode) + (should (equal (buffer-string) "PB CB MH AFP=S AFC=S "))))) + +(declare-function mode-a "derived-tests") +(declare-function mode-b "derived-tests") +(declare-function mode-c "derived-tests") +(ert-deftest test-add-font-lock () + (define-derived-mode mode-a fundamental-mode "mode-a" + (font-lock-add-keywords nil `(("a" 0 'font-lock-keyword-face)))) + (define-derived-mode mode-b mode-a "mode-b" + (font-lock-add-keywords nil `(("b" 0 'font-lock-builtin-face)))) + (define-derived-mode mode-c mode-b "mode-c" + (font-lock-add-keywords nil `(("c" 0 'font-lock-constant-face)))) + + (with-temp-buffer + (mode-c) + (should (equal font-lock-keywords + '(t (("c" 0 'font-lock-constant-face) + ("b" 0 'font-lock-builtin-face) + ("a" 0 'font-lock-keyword-face)) + ("c" (0 'font-lock-constant-face)) + ("b" (0 'font-lock-builtin-face)) + ("a" (0 'font-lock-keyword-face))))))) + +;;; derived-tests.el ends here diff --git a/test/lisp/emacs-lisp/easy-mmode-tests.el b/test/lisp/emacs-lisp/easy-mmode-tests.el new file mode 100644 index 00000000000..f6d07196727 --- /dev/null +++ b/test/lisp/emacs-lisp/easy-mmode-tests.el @@ -0,0 +1,63 @@ +;;; easy-mmode-tests.el --- tests for easy-mmode.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'easy-mmode) +(require 'message) + +(ert-deftest easy-mmode--globalized-predicate () + (with-temp-buffer + (emacs-lisp-mode) + (should (eq (easy-mmode--globalized-predicate-p nil) nil)) + (should (eq (easy-mmode--globalized-predicate-p t) t)) + (should (eq (easy-mmode--globalized-predicate-p '(not text-mode)) t)) + (should (eq (easy-mmode--globalized-predicate-p '(not text-mode)) t)) + (should (eq (easy-mmode--globalized-predicate-p '((not text-mode))) nil)) + (should (eq (easy-mmode--globalized-predicate-p '((not text-mode) t)) t)) + (should (eq (easy-mmode--globalized-predicate-p + '(c-mode emacs-lisp-mode)) + t)) + (mail-mode) + (should (eq (easy-mmode--globalized-predicate-p + '(c-mode (not message-mode mail-mode) text-mode)) + nil)) + (text-mode) + (should (eq (easy-mmode--globalized-predicate-p + '(c-mode (not message-mode mail-mode) text-mode)) + t)))) + +(define-minor-mode easy-mmode-test-mode "A test.") + +(ert-deftest easy-mmode--minor-mode () + (with-temp-buffer + (should (eq easy-mmode-test-mode nil)) + (easy-mmode-test-mode nil) + (should (eq easy-mmode-test-mode t)) + (easy-mmode-test-mode -33) + (should (eq easy-mmode-test-mode nil)) + (easy-mmode-test-mode 33) + (should (eq easy-mmode-test-mode t)) + (easy-mmode-test-mode 'toggle) + (should (eq easy-mmode-test-mode nil)) + (easy-mmode-test-mode 'toggle) + (should (eq easy-mmode-test-mode t)))) + +;;; easy-mmode-tests.el ends here diff --git a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el index f52a2b1896c..42d06889ea7 100644 --- a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el +++ b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el @@ -1,23 +1,23 @@ -;;; edebug-test-code.el --- Sample code for the Edebug test suite +;;; edebug-test-code.el --- Sample code for the Edebug test suite -*- lexical-binding:t -*- -;; Copyright (C) 2017 Free Software Foundation, Inc. +;; Copyright (C) 2017-2022 Free Software Foundation, Inc. ;; Author: Gemini Lasswell ;; 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. -;; +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -41,7 +41,7 @@ (defun edebug-test-code-range (num) !start!(let ((index 0) (result nil)) - (while (< index num)!test! + (while !lt!(< index num)!test! (push index result)!loop! (cl-incf index))!end-loop! (nreverse result))) @@ -62,12 +62,12 @@ (defun edebug-test-code-format-vector-node (node) !start!(concat "[" - (apply 'concat (mapcar 'edebug-test-code-format-node node))!apply! + (apply #'concat (mapcar #'edebug-test-code-format-node node))!apply! "]")) (defun edebug-test-code-format-list-node (node) !start!(concat "{" - (apply 'concat (mapcar 'edebug-test-code-format-node node))!apply! + (apply #'concat (mapcar #'edebug-test-code-format-node node))!apply! "}")) (defun edebug-test-code-format-node (node) @@ -126,5 +126,32 @@ !start!(with-current-buffer (get-buffer-create "*edebug-test-code-buffer*") !body!(format "current-buffer: %s" (current-buffer)))) +(defun edebug-test-code-use-destructuring-bind () + (let ((two 2) (three 3)) + (cl-destructuring-bind (x . y) (cons two three) (+ x!x! y!y!)))) + +(defun edebug-test-code-use-cl-macrolet (x) + (cl-macrolet ((wrap (func &rest args) + `(format "The result of applying %s to %s is %S" + ',func!func! ',args + ,(cons func args)))) + (wrap + 1 x))) + +(defun edebug-test-code-cl-flet1 () + (cl-flet + ;; This `&rest' sexp head should not collide with + ;; the Edebug spec elem of the same name. + ((f (&rest x) x) + (gate (x) (+ x 5))) + ;; This call to `gate' shouldn't collide with the Edebug spec elem + ;; of the same name. + (message "Hi %s" (gate 7)))) + +(defun edebug-test-code-use-gv-expander (x) + (declare (gv-expander + (lambda (do) + (funcall do `(car ,x) (lambda (v) `(setcar ,x ,v)))))) + (car x)) + (provide 'edebug-test-code) ;;; edebug-test-code.el ends here diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index 02f4d1c5abe..dea6e9ed611 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -1,23 +1,23 @@ ;;; edebug-tests.el --- Edebug test suite -*- lexical-binding:t -*- -;; Copyright (C) 2017 Free Software Foundation, Inc. +;; Copyright (C) 2017-2022 Free Software Foundation, Inc. ;; Author: Gemini Lasswell ;; 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. -;; +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -36,17 +36,6 @@ (require 'edebug) (require 'kmacro) -;; Use `eval-and-compile' because this is used by the macro -;; `edebug-tests-deftest'. -(eval-and-compile - (defvar edebug-tests-sample-code-file - (expand-file-name - "edebug-resources/edebug-test-code.el" - (file-name-directory (or (bound-and-true-p byte-compile-current-file) - load-file-name - buffer-file-name))) - "Name of file containing code samples for Edebug tests.")) - (defvar edebug-tests-temp-file nil "Name of temp file containing sample code stripped of stop point symbols.") (defvar edebug-tests-stop-points nil @@ -64,22 +53,20 @@ Since `should' failures which happen inside `post-command-hook' will be trapped by the command loop, this preserves them until we get back to the top level.") -(defvar edebug-tests-keymap - (let ((map (make-sparse-keymap))) - (define-key map "@" 'edebug-tests-call-instrumented-func) - (define-key map "C-u" 'universal-argument) - (define-key map "C-p" 'previous-line) - (define-key map "C-n" 'next-line) - (define-key map "C-b" 'backward-char) - (define-key map "C-a" 'move-beginning-of-line) - (define-key map "C-e" 'move-end-of-line) - (define-key map "C-k" 'kill-line) - (define-key map "M-x" 'execute-extended-command) - (define-key map "C-M-x" 'eval-defun) - (define-key map "C-x X b" 'edebug-set-breakpoint) - (define-key map "C-x X w" 'edebug-where) - map) - "Keys used by the keyboard macros in Edebug's tests.") +(defvar-keymap edebug-tests-keymap + :doc "Keys used by the keyboard macros in Edebug's tests." + "@" 'edebug-tests-call-instrumented-func + "C-u" 'universal-argument + "C-p" 'previous-line + "C-n" 'next-line + "C-b" 'backward-char + "C-a" 'move-beginning-of-line + "C-e" 'move-end-of-line + "C-k" 'kill-line + "M-x" 'execute-extended-command + "C-M-x" 'eval-defun + "C-x X b" 'edebug-set-breakpoint + "C-x X w" 'edebug-where) ;;; Macros for defining tests: @@ -108,33 +95,37 @@ back to the top level.") ;; sit-on interferes with keyboard macros. (edebug-sit-on-break nil) - (edebug-continue-kbd-macro t)) + (edebug-continue-kbd-macro t) + + ;; don't print backtraces, otherwise error messages don't match + (backtrace-on-error-noninteractive nil)) ,@body)) (defmacro edebug-tests-with-normal-env (&rest body) "Set up the environment for an Edebug test BODY, run it, and clean up." (declare (debug (body))) `(edebug-tests-with-default-config - (let ((edebug-tests-failure-in-post-command nil) - (edebug-tests-temp-file (make-temp-file "edebug-tests-" nil ".el"))) - (edebug-tests-setup-code-file edebug-tests-temp-file) - (ert-with-message-capture - edebug-tests-messages - (unwind-protect - (with-current-buffer (find-file edebug-tests-temp-file) - (read-only-mode) - (setq lexical-binding t) - (eval-buffer) - ,@body - (when edebug-tests-failure-in-post-command - (signal (car edebug-tests-failure-in-post-command) - (cdr edebug-tests-failure-in-post-command)))) - (unload-feature 'edebug-test-code) - (with-current-buffer (find-file-noselect edebug-tests-temp-file) - (set-buffer-modified-p nil)) - (ignore-errors (kill-buffer (find-file-noselect - edebug-tests-temp-file))) - (ignore-errors (delete-file edebug-tests-temp-file))))))) + (ert-with-temp-file edebug-tests-temp-file + :suffix ".el" + (let ((edebug-tests-failure-in-post-command nil) + (find-file-suppress-same-file-warnings t)) + (edebug-tests-setup-code-file edebug-tests-temp-file) + (ert-with-message-capture + edebug-tests-messages + (unwind-protect + (with-current-buffer (find-file edebug-tests-temp-file) + (read-only-mode) + (setq lexical-binding t) + (eval-buffer) + ,@body + (when edebug-tests-failure-in-post-command + (signal (car edebug-tests-failure-in-post-command) + (cdr edebug-tests-failure-in-post-command)))) + (unload-feature 'edebug-test-code) + (with-current-buffer (find-file-noselect edebug-tests-temp-file) + (set-buffer-modified-p nil)) + (ignore-errors (kill-buffer (find-file-noselect + edebug-tests-temp-file))))))))) ;; The following macro and its support functions implement an extension ;; to keyboard macros to allow interleaving of keyboard macro @@ -210,7 +201,7 @@ All other elements will be nil." (defvar edebug-tests-thunks nil "List containing thunks to run after each command in a keyboard macro.") (defvar edebug-tests-kbd-macro-index nil - "Index into `edebug-tests-run-unpacked-kbd-macro's current keyboard macro.") + "Index into `edebug-tests-run-kbd-macro's current keyboard macro.") (defun edebug-tests-run-macro (kbdmac &rest thunks) "Run a keyboard macro and execute a thunk after each command in it. @@ -221,20 +212,21 @@ be the same as every keystroke) execute the thunk at the same index." (let* ((edebug-tests-thunks thunks) (edebug-tests-kbd-macro-index 0) + (find-file-suppress-same-file-warnings t) saved-local-map) (with-current-buffer (find-file-noselect edebug-tests-temp-file) (setq saved-local-map overriding-local-map) (setq overriding-local-map edebug-tests-keymap) - (add-hook 'post-command-hook 'edebug-tests-post-command)) + (add-hook 'post-command-hook #'edebug-tests-post-command)) (advice-add 'exit-recursive-edit - :around 'edebug-tests-preserve-keyboard-macro-state) + :around #'edebug-tests-preserve-keyboard-macro-state) (unwind-protect (kmacro-call-macro nil nil nil kbdmac) (advice-remove 'exit-recursive-edit - 'edebug-tests-preserve-keyboard-macro-state) + #'edebug-tests-preserve-keyboard-macro-state) (with-current-buffer (find-file-noselect edebug-tests-temp-file) (setq overriding-local-map saved-local-map) - (remove-hook 'post-command-hook 'edebug-tests-post-command))))) + (remove-hook 'post-command-hook #'edebug-tests-post-command))))) (defun edebug-tests-preserve-keyboard-macro-state (orig &rest args) "Call ORIG with ARGS preserving the value of `executing-kbd-macro'. @@ -344,7 +336,7 @@ evaluate to \"symbol\", \"symbol-1\", \"symbol-2\", etc." Write the loadable code to a buffer for TMPFILE, and set `edebug-tests-stop-points' to a map from defined symbols to stop point names to positions in the file." - (with-current-buffer (find-file-noselect edebug-tests-sample-code-file) + (with-current-buffer (find-file-noselect (ert-resource-file "edebug-test-code.el")) (let ((marked-up-code (buffer-string))) (with-temp-file tmpfile (insert marked-up-code)))) @@ -432,9 +424,12 @@ test and possibly others should be updated." (verify-keybinding "P" 'edebug-view-outside) ;; same as v (verify-keybinding "W" 'edebug-toggle-save-windows) (verify-keybinding "?" 'edebug-help) - (verify-keybinding "d" 'edebug-backtrace) + (verify-keybinding "d" 'edebug-pop-to-backtrace) (verify-keybinding "-" 'negative-argument) - (verify-keybinding "=" 'edebug-temp-display-freq-count))) + (verify-keybinding "=" 'edebug-temp-display-freq-count) + (should (eq (lookup-key backtrace-mode-map "n") 'backtrace-forward-frame)) + (should (eq (lookup-key edebug-backtrace-mode-map "s") + 'backtrace-goto-source)))) (ert-deftest edebug-tests-stop-point-at-start-of-first-instrumented-function () "Edebug stops at the beginning of an instrumented function." @@ -727,7 +722,7 @@ test and possibly others should be updated." (edebug-on-error nil) error-message (command-error-function (lambda (&rest args) - (setq error-message (cl-cadar args))))) + (setq error-message (cadar args))))) (edebug-tests-run-kbd-macro "@" (edebug-tests-should-be-at "format-node" "start") "SPC" (edebug-tests-should-be-at "format-node" "vectorp") @@ -748,7 +743,7 @@ test and possibly others should be updated." (edebug-on-error nil) (error-message "") (command-error-function (lambda (&rest args) - (setq error-message (cl-cadar args))))) + (setq error-message (cadar args))))) (edebug-tests-run-kbd-macro "@ SPC SPC SPC SPC SPC" (edebug-tests-should-be-at "try-flavors" "macro") @@ -861,18 +856,22 @@ test and possibly others should be updated." (ert-deftest edebug-tests-trivial-backquote () "Edebug can instrument a trivial backquote expression (Bug#23651)." (edebug-tests-with-normal-env - (read-only-mode -1) - (delete-region (point-min) (point-max)) - (insert "`1") - (read-only-mode) - (edebug-eval-defun nil) - (should (string-match-p (regexp-quote "1 (#o1, #x1, ?\\C-a)") + (let ((inhibit-read-only t)) + (delete-region (point-min) (point-max)) + (insert "`1")) + (with-suppressed-warnings ((obsolete edebug-eval-defun)) + (edebug-eval-defun nil)) + ;; `eval-defun' outputs its message to the echo area in a rather + ;; funny way, so the "1" and the " (#o1, #x1, ?\C-a)" end up placed + ;; there in separate pieces (via `print' rather than via `message'). + (should (string-match-p (regexp-quote " (#o1, #x1, ?\\C-a)") edebug-tests-messages)) (setq edebug-tests-messages "") (setq edebug-initial-mode 'go) ;; In Bug#23651 Edebug would hang reading `1. - (edebug-eval-defun t))) + (with-suppressed-warnings ((obsolete edebug-eval-defun)) + (edebug-eval-defun t)))) (ert-deftest edebug-tests-trivial-comma () "Edebug can read a trivial comma expression (Bug#23651)." @@ -881,7 +880,8 @@ test and possibly others should be updated." (delete-region (point-min) (point-max)) (insert ",1") (read-only-mode) - (should-error (edebug-eval-defun t)))) + (with-suppressed-warnings ((obsolete edebug-eval-defun)) + (should-error (edebug-eval-defun t))))) (ert-deftest edebug-tests-circular-read-syntax () "Edebug can instrument code using circular read object syntax (Bug#23660)." @@ -899,5 +899,220 @@ test and possibly others should be updated." "@g" (should (equal edebug-tests-@-result '(#("abcd" 1 3 (face italic)) 511)))))) +(ert-deftest edebug-tests-dotted-forms () + "Edebug can instrument code matching the tail of a dotted spec (Bug#6415)." + (edebug-tests-with-normal-env + (edebug-tests-setup-@ "use-destructuring-bind" nil t) + (edebug-tests-run-kbd-macro + "@ SPC SPC SPC SPC SPC SPC" + (edebug-tests-should-be-at "use-destructuring-bind" "x") + (edebug-tests-should-match-result-in-messages "2 (#o2, #x2, ?\\C-b)") + "SPC" + (edebug-tests-should-be-at "use-destructuring-bind" "y") + (edebug-tests-should-match-result-in-messages "3 (#o3, #x3, ?\\C-c)") + "g" + (should (equal edebug-tests-@-result 5))))) + +(ert-deftest edebug-tests-cl-macrolet () + "Edebug can instrument `cl-macrolet' expressions. (Bug#29919)" + (edebug-tests-with-normal-env + (edebug-tests-locate-def "use-cl-macrolet") + (edebug-tests-run-kbd-macro + "C-u C-M-x SPC" + (edebug-tests-should-be-at "use-cl-macrolet" "func") + (edebug-tests-should-match-result-in-messages "+")) + (let ((edebug-initial-mode 'Go-nonstop)) + (edebug-tests-setup-@ "use-cl-macrolet" '(10) t)) + (edebug-tests-run-kbd-macro + "@ SPC g" + (should (equal edebug-tests-@-result "The result of applying + to (1 x) is 11")) + ))) + +(ert-deftest edebug-tests-backtrace-goto-source () + "Edebug can jump to instrumented source from its *Edebug-Backtrace* buffer." + (edebug-tests-with-normal-env + (edebug-tests-setup-@ "range" '(2) t) + (edebug-tests-run-kbd-macro + "@ SPC SPC" + (edebug-tests-should-be-at "range" "lt") + "dns" ; Pop to backtrace, next frame, goto source. + (edebug-tests-should-be-at "range" "start") + "g" + (should (equal edebug-tests-@-result '(0 1)))))) + +(ert-deftest edebug-cl-defmethod-qualifier () + "Check that secondary `cl-defmethod' forms don't stomp over +primary ones (Bug#42671)." + (with-temp-buffer + (let* ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop) + (defined-symbols ()) + (edebug-new-definition-function + (lambda (def-name) + (push def-name defined-symbols) + (edebug-new-definition def-name)))) + (dolist (form '((cl-defmethod edebug-cl-defmethod-qualifier ((_ number))) + (cl-defmethod edebug-cl-defmethod-qualifier + :around ((_ number))))) + (print form (current-buffer))) + (eval-buffer) + (should + (equal + defined-symbols + (list (intern "edebug-cl-defmethod-qualifier :around (number)") + (intern "edebug-cl-defmethod-qualifier (number)"))))))) + +(ert-deftest edebug-tests--conflicting-internal-names () + "Check conflicts between form's head symbols and Edebug spec elements." + (edebug-tests-with-normal-env + (edebug-tests-setup-@ "cl-flet1" '(10) t))) + +(ert-deftest edebug-tests-gv-expander () + "Edebug can instrument `gv-expander' expressions." + (edebug-tests-with-normal-env + (edebug-tests-setup-@ "use-gv-expander" nil t) + (should (equal + (catch 'text + (run-at-time 0 nil + (lambda () (throw 'text (buffer-substring (point) (+ (point) 5))))) + (eval '(setf (edebug-test-code-use-gv-expander (cons 'a 'b)) 3) t)) + "(func")))) + +(defun edebug-tests--read (form spec) + (with-temp-buffer + (print form (current-buffer)) + (goto-char (point-min)) + (cl-letf ((edebug-all-forms t) + ((get (car form) 'edebug-form-spec) spec)) + (edebug--read nil (current-buffer))))) + +(ert-deftest edebug-tests--&rest-behavior () + ;; `&rest' is documented to allow the last "repetition" to be aborted early. + (should (edebug-tests--read '(dummy x 1 y 2 z) + '(&rest symbolp integerp))) + ;; `&rest' should notice here that the "symbolp integerp" sequence + ;; is not respected. + (should-error (edebug-tests--read '(dummy x 1 2 y) + '(&rest symbolp integerp)))) + +(ert-deftest edebug-tests-cl-flet () + "Check that Edebug can instrument `cl-flet' forms without name +clashes (Bug#41853)." + (with-temp-buffer + (dolist (form '((defun edebug-tests-cl-flet-1 () + (cl-flet ((inner () 0)) (message "Hi")) + (cl-flet ((inner () 1)) (inner))) + (defun edebug-tests-cl-flet-2 () + (cl-flet ((inner () 2)) (inner))))) + (print form (current-buffer))) + (let* ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop) + (instrumented-names ()) + (edebug-new-definition-function + (lambda (name) + (when (memq name instrumented-names) + (error "Duplicate definition of `%s'" name)) + (push name instrumented-names) + (edebug-new-definition name))) + ;; Make generated symbols reproducible. + (gensym-counter 10000)) + (eval-buffer) + ;; Use `format' so as to throw away differences due to + ;; interned/uninterned symbols. + (should (equal (format "%s" (reverse instrumented-names)) + ;; The outer definitions come after the inner + ;; ones because their body ends later. + ;; FIXME: We'd rather have names such as + ;; `edebug-tests-cl-flet-1@inner@cl-flet@10000', + ;; but that requires further changes to Edebug. + (format "%s" '(inner@cl-flet@10000 + inner@cl-flet@10001 + edebug-tests-cl-flet-1 + inner@cl-flet@10002 + edebug-tests-cl-flet-2))))))) + +(defmacro edebug-tests--duplicate-symbol-backtrack (arg) + "Helper macro that exemplifies Bug#42701. +ARG is either (FORM) or (FORM IGNORED)." + (declare (debug ([&or (form) (form sexp)]))) + (car arg)) + +(ert-deftest edebug-tests-duplicate-symbol-backtrack () + "Check that Edebug doesn't create duplicate symbols when +backtracking (Bug#42701)." + (with-temp-buffer + (print '(defun edebug-tests-duplicate-symbol-backtrack () + (edebug-tests--duplicate-symbol-backtrack + ;; Passing (FORM IGNORED) forces backtracking. + ((lambda () 123) ignored))) + (current-buffer)) + (let* ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop) + (instrumented-names ()) + (edebug-new-definition-function + (lambda (name) + (when (memq name instrumented-names) + (error "Duplicate definition of `%s'" name)) + (push name instrumented-names) + (edebug-new-definition name))) + ;; Make generated symbols reproducible. + (gensym-counter 10000)) + (eval-buffer) + ;; The anonymous symbols are uninterned. Use their names so we + ;; can perform the assertion. The names should still be unique. + (should (equal (mapcar #'symbol-name (reverse instrumented-names)) + ;; The outer definition comes after the inner + ;; ones because its body ends later. + ;; FIXME: There are twice as many inner + ;; definitions as expected due to Bug#42701. + ;; Once that bug is fixed, remove the duplicates. + '("edebug-anon10000" + "edebug-anon10001" + "edebug-tests-duplicate-symbol-backtrack")))))) + +(defmacro edebug-tests--duplicate-&define (_arg) + "Helper macro for the ERT test `edebug-tests-duplicate-&define'. +The Edebug specification is similar to the one used by `cl-flet' +previously; see Bug#41988." + (declare (debug (&or (&define name function-form) (defun))))) + +(ert-deftest edebug-tests-duplicate-&define () + "Check that Edebug doesn't backtrack out of `&define' forms. +This avoids potential duplicate definitions (Bug#41988)." + (with-temp-buffer + (print '(defun edebug-tests-duplicate-&define () + (edebug-tests--duplicate-&define + (edebug-tests-duplicate-&define-inner () nil))) + (current-buffer)) + (let* ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop) + (instrumented-names ()) + (edebug-new-definition-function + (lambda (name) + (when (memq name instrumented-names) + (error "Duplicate definition of `%s'" name)) + (push name instrumented-names) + (edebug-new-definition name)))) + (should-error (eval-buffer) :type 'invalid-read-syntax)))) + +(ert-deftest edebug-tests-inline () + "Check that Edebug can instrument inline functions (Bug#53068)." + (with-temp-buffer + (print '(define-inline edebug-tests-inline (arg) + (inline-quote ,arg)) + (current-buffer)) + (let ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop)) + (eval-buffer)))) + +(ert-deftest edebug-test-dot-reader () + (with-temp-buffer + (insert "(defun x () `(t .,t))") + (goto-char (point-min)) + (should (equal (save-excursion + (edebug-read-storing-offsets (current-buffer))) + (save-excursion + (read (current-buffer))))))) + (provide 'edebug-tests) ;;; edebug-tests.el ends here diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el index 818b3e76a1e..af19c122b9f 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el @@ -1,6 +1,6 @@ -;;; eieio-testsinvoke.el -- eieio tests for method invocation +;;; eieio-test-methodinvoke.el --- eieio tests for method invocation -*- lexical-binding:t -*- -;; Copyright (C) 2005, 2008, 2010, 2013-2017 Free Software Foundation, +;; Copyright (C) 2005, 2008, 2010, 2013-2022 Free Software Foundation, ;; Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> @@ -22,22 +22,22 @@ ;;; Commentary: ;; -;; Test method invocation order. From the common lisp reference -;; manual: +;; Test method invocation order. From the Common Lisp Reference +;; Manual: ;; ;; QUOTE: ;; - All the :before methods are called, in most-specific-first ;; order. Their values are ignored. An error is signaled if ;; call-next-method is used in a :before method. ;; -;; - The most specific primary method is called. Inside the body of a +;; - The most specific primary method is called. Inside the body of a ;; primary method, call-next-method may be used to call the next -;; most specific primary method. When that method returns, the +;; most specific primary method. When that method returns, the ;; previous primary method can execute more code, perhaps based on -;; the returned value or values. The generic function no-next-method +;; the returned value or values. The generic function no-next-method ;; is invoked if call-next-method is used and there are no more -;; applicable primary methods. The function next-method-p may be -;; used to determine whether a next method exists. If +;; applicable primary methods. The function next-method-p may be +;; used to determine whether a next method exists. If ;; call-next-method is not used, only the most specific primary ;; method is called. ;; @@ -46,13 +46,18 @@ ;; call-next-method is used in a :after method. ;; ;; -;; Also test behavior of `call-next-method'. From clos.org: +;; Also test behavior of `call-next-method'. From clos.org: ;; ;; QUOTE: ;; When call-next-method is called with no arguments, it passes the ;; current method's original arguments to the next method. +;;; Code: + (require 'eieio) +;; FIXME: See Bug#52971. +(with-no-warnings + (require 'eieio-compat)) (require 'ert) (defvar eieio-test-method-order-list nil @@ -83,37 +88,40 @@ (defclass eitest-B-base2 () ()) (defclass eitest-B (eitest-B-base1 eitest-B-base2) ()) -(defmethod eitest-F :BEFORE ((p eitest-B-base1)) - (eieio-test-method-store :BEFORE 'eitest-B-base1)) - -(defmethod eitest-F :BEFORE ((p eitest-B-base2)) - (eieio-test-method-store :BEFORE 'eitest-B-base2)) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete call-next-method) + (obsolete next-method-p)) + (defmethod eitest-F :BEFORE ((_p eitest-B-base1)) + (eieio-test-method-store :BEFORE 'eitest-B-base1)) -(defmethod eitest-F :BEFORE ((p eitest-B)) - (eieio-test-method-store :BEFORE 'eitest-B)) + (defmethod eitest-F :BEFORE ((_p eitest-B-base2)) + (eieio-test-method-store :BEFORE 'eitest-B-base2)) -(defmethod eitest-F ((p eitest-B)) - (eieio-test-method-store :PRIMARY 'eitest-B) - (call-next-method)) + (defmethod eitest-F :BEFORE ((_p eitest-B)) + (eieio-test-method-store :BEFORE 'eitest-B)) -(defmethod eitest-F ((p eitest-B-base1)) - (eieio-test-method-store :PRIMARY 'eitest-B-base1) - (call-next-method)) + (defmethod eitest-F ((_p eitest-B)) + (eieio-test-method-store :PRIMARY 'eitest-B) + (call-next-method)) -(defmethod eitest-F ((p eitest-B-base2)) - (eieio-test-method-store :PRIMARY 'eitest-B-base2) - (when (next-method-p) + (defmethod eitest-F ((_p eitest-B-base1)) + (eieio-test-method-store :PRIMARY 'eitest-B-base1) (call-next-method)) - ) -(defmethod eitest-F :AFTER ((p eitest-B-base1)) - (eieio-test-method-store :AFTER 'eitest-B-base1)) + (defmethod eitest-F ((_p eitest-B-base2)) + (eieio-test-method-store :PRIMARY 'eitest-B-base2) + (when (next-method-p) + (call-next-method))) + + (defmethod eitest-F :AFTER ((_p eitest-B-base1)) + (eieio-test-method-store :AFTER 'eitest-B-base1)) -(defmethod eitest-F :AFTER ((p eitest-B-base2)) - (eieio-test-method-store :AFTER 'eitest-B-base2)) + (defmethod eitest-F :AFTER ((_p eitest-B-base2)) + (eieio-test-method-store :AFTER 'eitest-B-base2)) -(defmethod eitest-F :AFTER ((p eitest-B)) - (eieio-test-method-store :AFTER 'eitest-B)) + (defmethod eitest-F :AFTER ((_p eitest-B)) + (eieio-test-method-store :AFTER 'eitest-B))) (ert-deftest eieio-test-method-order-list-3 () (let ((eieio-test-method-order-list nil) @@ -136,9 +144,11 @@ ;;; Test static invocation ;; -(defmethod eitest-H :STATIC ((class eitest-A)) - "No need to do work in here." - 'moose) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod eitest-H :STATIC ((_class eitest-A)) + "No need to do work in here." + 'moose)) (ert-deftest eieio-test-method-order-list-4 () ;; Both of these situations should succeed. @@ -147,17 +157,19 @@ ;;; Return value from :PRIMARY ;; -(defmethod eitest-I :BEFORE ((a eitest-A)) - (eieio-test-method-store :BEFORE 'eitest-A) - ":before") +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod eitest-I :BEFORE ((_a eitest-A)) + (eieio-test-method-store :BEFORE 'eitest-A) + ":before") -(defmethod eitest-I :PRIMARY ((a eitest-A)) - (eieio-test-method-store :PRIMARY 'eitest-A) - ":primary") + (defmethod eitest-I :PRIMARY ((_a eitest-A)) + (eieio-test-method-store :PRIMARY 'eitest-A) + ":primary") -(defmethod eitest-I :AFTER ((a eitest-A)) - (eieio-test-method-store :AFTER 'eitest-A) - ":after") + (defmethod eitest-I :AFTER ((_a eitest-A)) + (eieio-test-method-store :AFTER 'eitest-A) + ":after")) (ert-deftest eieio-test-method-order-list-5 () (let ((eieio-test-method-order-list nil) @@ -173,18 +185,20 @@ (defclass C-base2 () ()) (defclass C (C-base1 C-base2) ()) -;; Just use the obsolete name once, to make sure it also works. -(defmethod constructor :STATIC ((p C-base1) &rest args) - (eieio-test-method-store :STATIC 'C-base1) - (if (next-method-p) (call-next-method)) - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + ;; Just use the obsolete name once, to make sure it also works. + (defmethod constructor :STATIC ((_p C-base1) &rest _args) + (eieio-test-method-store :STATIC 'C-base1) + (if (next-method-p) (call-next-method))) -(defmethod make-instance :STATIC ((p C-base2) &rest args) - (eieio-test-method-store :STATIC 'C-base2) - (if (next-method-p) (call-next-method)) - ) + (defmethod make-instance :STATIC ((_p C-base2) &rest _args) + (eieio-test-method-store :STATIC 'C-base2) + (if (next-method-p) (call-next-method)))) -(cl-defmethod make-instance ((p (subclass C)) &rest args) +(cl-defmethod make-instance ((_p (subclass C)) &rest _args) (eieio-test-method-store :STATIC 'C) (cl-call-next-method) ) @@ -192,7 +206,7 @@ (ert-deftest eieio-test-method-order-list-6 () ;; FIXME repeated intermittent failures on hydra (bug#24503) ;; ((:STATIC C) (:STATIC C-base1) (:STATIC C-base2)) != ((:STATIC C))") - (skip-unless (not (getenv "EMACS_HYDRA_CI"))) + :tags '(:unstable) (let ((eieio-test-method-order-list nil) (ans '( (:STATIC C) @@ -213,29 +227,32 @@ (defclass D-base2 (D-base0) () :method-invocation-order :depth-first) (defclass D (D-base1 D-base2) () :method-invocation-order :depth-first) -(defmethod eitest-F ((p D)) - "D" - (eieio-test-method-store :PRIMARY 'D) - (call-next-method)) - -(defmethod eitest-F ((p D-base0)) - "D-base0" - (eieio-test-method-store :PRIMARY 'D-base0) - ;; This should have no next - ;; (when (next-method-p) (call-next-method)) - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete call-next-method) + (obsolete next-method-p)) + (defmethod eitest-F ((_p D)) + "D" + (eieio-test-method-store :PRIMARY 'D) + (call-next-method)) -(defmethod eitest-F ((p D-base1)) - "D-base1" - (eieio-test-method-store :PRIMARY 'D-base1) - (call-next-method)) + (defmethod eitest-F ((_p D-base0)) + "D-base0" + (eieio-test-method-store :PRIMARY 'D-base0) + ;; This should have no next + ;; (when (next-method-p) (call-next-method)) + ) -(defmethod eitest-F ((p D-base2)) - "D-base2" - (eieio-test-method-store :PRIMARY 'D-base2) - (when (next-method-p) + (defmethod eitest-F ((_p D-base1)) + "D-base1" + (eieio-test-method-store :PRIMARY 'D-base1) (call-next-method)) - ) + + (defmethod eitest-F ((_p D-base2)) + "D-base2" + (eieio-test-method-store :PRIMARY 'D-base2) + (when (next-method-p) + (call-next-method)))) (ert-deftest eieio-test-method-order-list-7 () (let ((eieio-test-method-order-list nil) @@ -256,25 +273,28 @@ (defclass E-base2 (E-base0) () :method-invocation-order :breadth-first) (defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first) -(defmethod eitest-F ((p E)) - (eieio-test-method-store :PRIMARY 'E) - (call-next-method)) - -(defmethod eitest-F ((p E-base0)) - (eieio-test-method-store :PRIMARY 'E-base0) - ;; This should have no next - ;; (when (next-method-p) (call-next-method)) - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + (defmethod eitest-F ((_p E)) + (eieio-test-method-store :PRIMARY 'E) + (call-next-method)) -(defmethod eitest-F ((p E-base1)) - (eieio-test-method-store :PRIMARY 'E-base1) - (call-next-method)) + (defmethod eitest-F ((_p E-base0)) + (eieio-test-method-store :PRIMARY 'E-base0) + ;; This should have no next + ;; (when (next-method-p) (call-next-method)) + ) -(defmethod eitest-F ((p E-base2)) - (eieio-test-method-store :PRIMARY 'E-base2) - (when (next-method-p) + (defmethod eitest-F ((_p E-base1)) + (eieio-test-method-store :PRIMARY 'E-base1) (call-next-method)) - ) + + (defmethod eitest-F ((_p E-base2)) + (eieio-test-method-store :PRIMARY 'E-base2) + (when (next-method-p) + (call-next-method)))) (ert-deftest eieio-test-method-order-list-8 () (let ((eieio-test-method-order-list nil) @@ -293,24 +313,32 @@ (defclass eitest-Ja () ()) -(defmethod initialize-instance :after ((this eitest-Ja) &rest slots) - ;(message "+Ja") - ;; FIXME: Using next-method-p in an after-method is invalid! - (when (next-method-p) - (call-next-method)) - ;(message "-Ja") - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + (defmethod initialize-instance :after ((_this eitest-Ja) &rest _slots) + ;;(message "+Ja") + ;; FIXME: Using next-method-p in an after-method is invalid! + (when (next-method-p) + (call-next-method)) + ;;(message "-Ja") + )) (defclass eitest-Jb () ()) -(defmethod initialize-instance :after ((this eitest-Jb) &rest slots) - ;(message "+Jb") - ;; FIXME: Using next-method-p in an after-method is invalid! - (when (next-method-p) - (call-next-method)) - ;(message "-Jb") - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + (defmethod initialize-instance :after ((_this eitest-Jb) &rest _slots) + ;;(message "+Jb") + ;; FIXME: Using next-method-p in an after-method is invalid! + (when (next-method-p) + (call-next-method)) + ;;(message "-Jb") + )) (defclass eitest-Jc (eitest-Jb) ()) @@ -318,15 +346,19 @@ (defclass eitest-Jd (eitest-Jc eitest-Ja) ()) -(defmethod initialize-instance ((this eitest-Jd) &rest slots) - ;(message "+Jd") - (when (next-method-p) - (call-next-method)) - ;(message "-Jd") - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + (defmethod initialize-instance ((_this eitest-Jd) &rest _slots) + ;;(message "+Jd") + (when (next-method-p) + (call-next-method)) + ;;(message "-Jd") + )) (ert-deftest eieio-test-method-order-list-9 () - (should (eitest-Jd "test"))) + (should (eitest-Jd))) ;;; call-next-method with replacement arguments across a simple class hierarchy. ;; @@ -343,36 +375,40 @@ (defclass CNM-2 (CNM-1-1 CNM-1-2) ()) -(defmethod CNM-M ((this CNM-0) args) - (push (cons 'CNM-0 (copy-sequence args)) - eieio-test-call-next-method-arguments) - (when (next-method-p) - (call-next-method - this (cons 'CNM-0 args)))) - -(defmethod CNM-M ((this CNM-1-1) args) - (push (cons 'CNM-1-1 (copy-sequence args)) - eieio-test-call-next-method-arguments) - (when (next-method-p) - (call-next-method - this (cons 'CNM-1-1 args)))) - -(defmethod CNM-M ((this CNM-1-2) args) - (push (cons 'CNM-1-2 (copy-sequence args)) - eieio-test-call-next-method-arguments) - (when (next-method-p) - (call-next-method))) - -(defmethod CNM-M ((this CNM-2) args) - (push (cons 'CNM-2 (copy-sequence args)) - eieio-test-call-next-method-arguments) - (when (next-method-p) - (call-next-method - this (cons 'CNM-2 args)))) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + (defmethod CNM-M ((this CNM-0) args) + (push (cons 'CNM-0 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-0 args)))) + + (defmethod CNM-M ((this CNM-1-1) args) + (push (cons 'CNM-1-1 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-1-1 args)))) + + (defmethod CNM-M ((_this CNM-1-2) args) + (push (cons 'CNM-1-2 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method))) + + (defmethod CNM-M ((this CNM-2) args) + (push (cons 'CNM-2 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-2 args))))) (ert-deftest eieio-test-method-order-list-10 () (let ((eieio-test-call-next-method-arguments nil)) - (CNM-M (CNM-2 "") '(INIT)) + (CNM-M (CNM-2) '(INIT)) (should (equal (eieio-test-arguments-for 'CNM-0) '(CNM-1-1 CNM-2 INIT))) (should (equal (eieio-test-arguments-for 'CNM-1-1) @@ -403,3 +439,5 @@ (should (equal (eieio-test--1 (make-instance 'CNM-2) 5) '("CNM-1-1" "CNM-1-2" "CNM-0" 7 5))) (should (equal (eieio-test--1 'CNM-2 6) '("subclass CNM-1-2" CNM-2 6)))) + +;;; eieio-test-methodinvoke.el ends here diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el index 738711c9c84..e839e1262fa 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el @@ -1,8 +1,8 @@ -;;; eieio-persist.el --- Tests for eieio-persistent class +;;; eieio-test-persist.el --- Tests for eieio-persistent class -*- lexical-binding:t -*- -;; Copyright (C) 2011-2017 Free Software Foundation, Inc. +;; Copyright (C) 2011-2022 Free Software Foundation, Inc. -;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Author: Eric M. Ludlam <zappo@gnu.org> ;; This file is part of GNU Emacs. @@ -40,6 +40,17 @@ This is usually a symbol that starts with `:'." (car tuple) nil))) +(defun hash-equal (hash1 hash2) + "Compare two hash tables to see whether they are equal." + (and (= (hash-table-count hash1) + (hash-table-count hash2)) + (catch 'flag + (maphash (lambda (x y) + (or (equal (gethash x hash2) y) + (throw 'flag nil))) + hash1) + (throw 'flag t)))) + (defun persist-test-save-and-compare (original) "Compare the object ORIGINAL against the one read fromdisk." @@ -49,8 +60,8 @@ This is usually a symbol that starts with `:'." (class (eieio-object-class original)) (fromdisk (eieio-persistent-read file class)) (cv (cl--find-class class)) - (slots (eieio--class-slots cv)) - ) + (slots (eieio--class-slots cv))) + (unless (object-of-class-p fromdisk class) (error "Persistent class %S != original class %S" (eieio-object-class fromdisk) @@ -62,18 +73,24 @@ This is usually a symbol that starts with `:'." (origvalue (eieio-oref original oneslot)) (fromdiskvalue (eieio-oref fromdisk oneslot)) (initarg-p (eieio--attribute-to-initarg - (cl--find-class class) oneslot)) - ) + (cl--find-class class) oneslot))) (if initarg-p - (unless (equal origvalue fromdiskvalue) + (unless + (cond ((and (hash-table-p origvalue) (hash-table-p fromdiskvalue)) + (hash-equal origvalue fromdiskvalue)) + (t (equal origvalue fromdiskvalue))) (error "Slot %S Original Val %S != Persistent Val %S" oneslot origvalue fromdiskvalue)) ;; Else !initarg-p - (unless (equal (cl--slot-descriptor-initform slot) fromdiskvalue) + (let ((origval (cl--slot-descriptor-initform slot)) + (diskval fromdiskvalue)) + (unless + (cond ((and (hash-table-p origval) (hash-table-p diskval)) + (hash-equal origval diskval)) + (t (equal origval diskval))) (error "Slot %S Persistent Val %S != Default Value %S" - oneslot fromdiskvalue (cl--slot-descriptor-initform slot)))) - )))) + oneslot diskval origvalue)))))))) ;;; Simple Case ;; @@ -82,7 +99,7 @@ This is usually a symbol that starts with `:'." (defclass persist-simple (eieio-persistent) ((slot1 :initarg :slot1 :type symbol - :initform moose) + :initform 'moose) (slot2 :initarg :slot2 :initform "foo") (slot3 :initform 2)) @@ -90,7 +107,7 @@ This is usually a symbol that starts with `:'." (ert-deftest eieio-test-persist-simple-1 () (let ((persist-simple-1 - (persist-simple "simple 1" :slot1 'goose :slot2 "testing" + (persist-simple :slot1 'goose :slot2 "testing" :file (concat default-directory "test-ps1.pt")))) (should persist-simple-1) @@ -124,7 +141,7 @@ Assume SLOTVALUE is a symbol of some sort." (ert-deftest eieio-test-persist-printer () (let ((persist-:printer-1 - (persist-:printer "persist" :slot1 'goose :slot2 "testing" + (persist-:printer :slot1 'goose :slot2 "testing" :file (concat default-directory "test-ps2.pt")))) (should persist-:printer-1) (persist-test-save-and-compare persist-:printer-1) @@ -148,9 +165,9 @@ Assume SLOTVALUE is a symbol of some sort." ((slot1 :initarg :slot1 :initform 1) (slot2 :initform 2)) - "Class for testing persistent saving of an object that isn't -persistent. This class is instead used as a slot value in a -persistent class.") + "Class for testing persistent saving of an object that isn't persistent. +This class is instead used as a slot value in a persistent +class.") (defclass persistent-with-objs-slot (eieio-persistent) ((pnp :initarg :pnp @@ -161,8 +178,7 @@ persistent class.") (ert-deftest eieio-test-non-persistent-as-slot () (let ((persist-wos (persistent-with-objs-slot - "persist wos 1" - :pnp (persist-not-persistent "pnp 1" :slot1 3) + :pnp (persist-not-persistent :slot1 3) :file (concat default-directory "test-ps3.pt")))) (persist-test-save-and-compare persist-wos) @@ -188,8 +204,7 @@ persistent class.") (ert-deftest eieio-test-non-persistent-as-slot-child () (let ((persist-woss (persistent-with-objs-slot-subs - "persist woss 1" - :pnp (persist-not-persistent-subclass "pnps 1" :slot1 3) + :pnp (persist-not-persistent-subclass :slot1 3) :file (concat default-directory "test-ps4.pt")))) (persist-test-save-and-compare persist-woss) @@ -205,13 +220,16 @@ persistent class.") ((slot1 :initarg :slot1 :type (or persistent-random-class null persist-not-persistent)) (slot2 :initarg :slot2 - :type (or persist-not-persistent persist-random-class null)))) + :type (or persist-not-persistent persistent-random-class null)) + (slot3 :initarg :slot3 + :type persistent-random-class))) (ert-deftest eieio-test-multiple-class-slot () (let ((persist - (persistent-multiclass-slot "random string" + (persistent-multiclass-slot :slot1 (persistent-random-class) :slot2 (persist-not-persistent) + :slot3 (persistent-random-class) :file (concat default-directory "test-ps5.pt")))) (unwind-protect (persist-test-save-and-compare persist) @@ -229,13 +247,109 @@ persistent class.") (ert-deftest eieio-test-slot-with-list-of-objects () (let ((persist-wols (persistent-with-objs-list-slot - "persist wols 1" - :pnp (list (persist-not-persistent "pnp 1" :slot1 3) - (persist-not-persistent "pnp 2" :slot1 4) - (persist-not-persistent "pnp 3" :slot1 5)) + :pnp (list (persist-not-persistent :slot1 3) + (persist-not-persistent :slot1 4) + (persist-not-persistent :slot1 5)) :file (concat default-directory "test-ps5.pt")))) (persist-test-save-and-compare persist-wols) (delete-file (oref persist-wols file)))) +;;; Tests targeted at popular libraries in the wild. + +;; Objects inside hash tables and vectors (pcache), see bug#29220. +(defclass person () + ((name :type string :initarg :name))) + +(defclass classy (eieio-persistent) + ((teacher + :type person + :initarg :teacher) + (students + :initarg :students :initform (make-hash-table :test 'equal)) + (janitors + :type list + :initarg :janitors) + (random-vector + :type vector + :initarg :random-vector))) + +(defun eieio-test-persist-hash-and-vector () + (let* ((jane (make-instance 'person :name "Jane")) + (bob (make-instance 'person :name "Bob")) + (hans (make-instance 'person :name "Hans")) + (dierdre (make-instance 'person :name "Dierdre")) + (class (make-instance 'classy + :teacher jane + :janitors (list [tuesday nil] + [friday nil]) + :random-vector [nil] + :file (concat default-directory "classy-" emacs-version ".eieio")))) + (puthash "Bob" bob (slot-value class 'students)) + (aset (slot-value class 'random-vector) 0 + (make-instance 'persistent-random-class)) + (unwind-protect + (persist-test-save-and-compare class) + (delete-file (oref class file))) + (aset (car (slot-value class 'janitors)) 1 hans) + (aset (nth 1 (slot-value class 'janitors)) 1 dierdre) + (unwind-protect + (persist-test-save-and-compare class) + (delete-file (oref class file))))) + +(ert-deftest eieio-persist-hash-and-vector-backward-compatibility () + (let ((eieio-backward-compatibility t)) ; The default. + (eieio-test-persist-hash-and-vector))) + +(ert-deftest eieio-persist-hash-and-vector-no-backward-compatibility () + :expected-result :failed ;; Bug#29220. + (let ((eieio-backward-compatibility nil)) + (eieio-test-persist-hash-and-vector))) + +;; Extra quotation of lists inside other objects (Gnus registry), also +;; bug#29220. + +(defclass eieio-container (eieio-persistent) + ((alist + :initarg :alist + :type list) + (vec + :initarg :vec + :type vector) + (htab + :initarg :htab + :type hash-table))) + +(defun eieio-test-persist-interior-lists () + (let* ((thing (make-instance + 'eieio-container + :vec [nil] + :htab (make-hash-table :test #'equal) + :file (concat default-directory + "container-" emacs-version ".eieio"))) + (john (make-instance 'person :name "John")) + (alexie (make-instance 'person :name "Alexie")) + (alst '(("first" (one two three)) + ("second" (four five six))))) + (setf (slot-value thing 'alist) alst) + (puthash "alst" alst (slot-value thing 'htab)) + (aset (slot-value thing 'vec) 0 alst) + (unwind-protect + (persist-test-save-and-compare thing) + (delete-file (slot-value thing 'file))) + (setf (nth 2 (cadar alst)) john + (nth 2 (cadadr alst)) alexie) + (unwind-protect + (persist-test-save-and-compare thing) + (delete-file (slot-value thing 'file))))) + +(ert-deftest eieio-test-persist-interior-lists-backward-compatibility () + (let ((eieio-backward-compatibility t)) ; The default. + (eieio-test-persist-interior-lists))) + +(ert-deftest eieio-test-persist-interior-lists-no-backward-compatibility () + :expected-result :failed ;; Bug#29220. + (let ((eieio-backward-compatibility nil)) + (eieio-test-persist-interior-lists))) + ;;; eieio-test-persist.el ends here diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el index fbdb9896a40..9b27d4ab938 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@ -1,6 +1,6 @@ -;;; eieio-tests.el -- eieio tests routines +;;; eieio-tests.el --- eieio test routines -*- lexical-binding: t -*- -;; Copyright (C) 1999-2003, 2005-2010, 2012-2017 Free Software +;; Copyright (C) 1999-2003, 2005-2010, 2012-2022 Free Software ;; Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> @@ -27,18 +27,26 @@ (require 'ert) (require 'eieio) (require 'eieio-base) +;; FIXME: See Bug#52971. +(with-no-warnings + (require 'eieio-compat)) (require 'eieio-opt) (eval-when-compile (require 'cl-lib)) +;; Silence byte-compiler. +(eval-when-compile + (dolist (slot '(:a :b ooga-booga :derived-value missing-slot)) + (cl-pushnew slot eieio--known-slot-names))) + ;;; Code: ;; Set up some test classes (defclass class-a () ((water :initarg :water - :initform h20 + :initform 'h20 :type symbol :documentation "Detail about water.") - (classslot :initform penguin + (classslot :initform 'penguin :type symbol :documentation "A class allocated slot." :allocation :class) @@ -48,53 +56,57 @@ :type (or null class-a) :documentation "Test self referencing types.") ) - "Class A") + "Class A.") + +;; Silence compiler warning about `water' not being a class-allocated slot. +(defclass eieio-tests--dummy () ((water :allocation :class))) (defclass class-b () ((land :initform "Sc" :type string :documentation "Detail about land.")) - "Class B") + "Class B.") (defclass class-ab (class-a class-b) ((amphibian :initform "frog" :documentation "Detail about amphibian on land and water.")) "Class A and B combined.") -(defclass class-c () - ((slot-1 :initarg :moose - :initform moose - :type symbol - :allocation :instance - :documentation "First slot testing slot arguments." - :custom symbol - :label "Wild Animal" - :group borg - :protection :public) - (slot-2 :initarg :penguin - :initform "penguin" - :type string - :allocation :instance - :documentation "Second slot testing slot arguments." - :custom string - :label "Wild bird" - :group vorlon - :accessor get-slot-2 - :protection :private) - (slot-3 :initarg :emu - :initform emu - :type symbol - :allocation :class - :documentation "Third slot test class allocated accessor" - :custom symbol - :label "Fuzz" - :group tokra - :accessor get-slot-3 - :protection :private) - ) - (:custom-groups (foo)) - "A class for testing slot arguments." - ) +(with-no-warnings ; FIXME: Make more specific. + (defclass class-c () + ((slot-1 :initarg :moose + :initform 'moose + :type symbol + :allocation :instance + :documentation "First slot testing slot arguments." + :custom symbol + :label "Wild Animal" + :group borg + :protection :public) + (slot-2 :initarg :penguin + :initform "penguin" + :type string + :allocation :instance + :documentation "Second slot testing slot arguments." + :custom string + :label "Wild bird" + :group vorlon + :accessor get-slot-2 + :protection :private) + (slot-3 :initarg :emu + :initform 'emu + :type symbol + :allocation :class + :documentation "Third slot test class allocated accessor" + :custom symbol + :label "Fuzz" + :group tokra + :accessor get-slot-3 + :protection :private) + ) + (:custom-groups (foo)) + "A class for testing slot arguments." + )) (defclass class-subc (class-c) ((slot-1 ;; :initform moose - don't override this @@ -132,21 +144,25 @@ ;; (error "invalid-slot-type thrown when eieio-error-unsupported-class-tags is nil") ;; ))) +;; Silence byte-compiler. +(declare-function eitest-subordinate--eieio-childp nil) +(declare-function class-alloc-initarg--eieio-childp nil) (ert-deftest eieio-test-01-mix-alloc-initarg () ;; Only run this test if the message framework thingy works. - (when (and (message "foo") (string= "foo" (current-message))) + (skip-unless (and (message "foo") (string= "foo" (current-message)))) - ;; Defining this class should generate a warning(!) message that - ;; you should not mix :initarg with class allocated slots. + ;; Defining this class should generate a warning(!) message that + ;; you should not mix :initarg with class allocated slots. + (with-no-warnings ; FIXME: Make more specific. (defclass class-alloc-initarg () ((throwwarning :initarg :throwwarning - :allocation :class)) - "Throw a warning mixing allocation class and an initarg.") + :allocation :class)) + "Throw a warning mixing allocation class and an initarg.")) - ;; Check that message is there - (should (current-message)) - (should (string-match "Class allocated slots do not need :initarg" - (current-message))))) + ;; Check that message is there + (should (current-message)) + (should (string-match "Class allocated slots do not need :initarg" + (current-message)))) (defclass abstract-class () ((some-slot :initarg :some-slot @@ -160,30 +176,33 @@ ;; error (should-error (abstract-class))) -(defgeneric generic1 () "First generic function") +(with-suppressed-warnings ((obsolete defgeneric)) + (defgeneric generic1 () "First generic function.")) (ert-deftest eieio-test-03-generics () - (defun anormalfunction () "A plain function for error testing." nil) - (should-error - (progn - (defgeneric anormalfunction () - "Attempt to turn it into a generic."))) - - ;; Check that generic-p works - (should (generic-p 'generic1)) - - (defmethod generic1 ((c class-a)) - "Method on generic1." - 'monkey) - - (defmethod generic1 (not-an-object) - "Method generic1 that can take a non-object." - not-an-object) - - (let ((ans-obj (generic1 (class-a))) - (ans-num (generic1 666))) - (should (eq ans-obj 'monkey)) - (should (eq ans-num 666)))) + (with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defun anormalfunction () "A plain function for error testing." nil) + (should-error + (progn + (defgeneric anormalfunction () + "Attempt to turn it into a generic."))) + + ;; Check that generic-p works + (should (generic-p 'generic1)) + + (defmethod generic1 ((_c class-a)) + "Method on generic1." + 'monkey) + + (defmethod generic1 (not-an-object) + "Method generic1 that can take a non-object." + not-an-object) + + (let ((ans-obj (generic1 (class-a))) + (ans-num (generic1 666))) + (should (eq ans-obj 'monkey)) + (should (eq ans-num 666))))) (defclass static-method-class () ((some-slot :initform nil @@ -191,12 +210,17 @@ :documentation "A slot.")) :documentation "A class used for testing static methods.") -(defmethod static-method-class-method :STATIC ((c static-method-class) value) - "Test static methods. +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod static-method-class-method :STATIC ((c static-method-class) value) + "Test static methods. Argument C is the class bound to this static method." - (if (eieio-object-p c) (setq c (eieio-object-class c))) - (oset-default c some-slot value)) + (if (eieio-object-p c) (setq c (eieio-object-class c))) + (oset-default c some-slot value))) +;; Silence byte-compiler. +(declare-function static-method-class-2 nil) +(declare-function static-method-class-2--eieio-childp nil) (ert-deftest eieio-test-04-static-method () ;; Call static method on a class and see if it worked (static-method-class-method 'static-method-class 'class) @@ -209,11 +233,13 @@ Argument C is the class bound to this static method." () "A second class after the previous for static methods.") - (defmethod static-method-class-method :STATIC ((c static-method-class-2) value) - "Test static methods. + (with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod static-method-class-method :STATIC ((c static-method-class-2) value) + "Test static methods. Argument C is the class bound to this static method." - (if (eieio-object-p c) (setq c (eieio-object-class c))) - (oset-default c some-slot (intern (concat "moose-" (symbol-name value))))) + (if (eieio-object-p c) (setq c (eieio-object-class c))) + (oset-default c some-slot (intern (concat "moose-" (symbol-name value)))))) (static-method-class-method 'static-method-class-2 'class) (should (eq (oref-default 'static-method-class-2 some-slot) 'moose-class)) @@ -240,64 +266,71 @@ Argument C is the class bound to this static method." (should (make-instance 'class-a :water 'cho)) (should (make-instance 'class-b))) -(defmethod class-cn ((a class-a)) - "Try calling `call-next-method' when there isn't one. +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod class-cn ((_a class-a)) + "Try calling `call-next-method' when there isn't one. Argument A is object of type symbol `class-a'." - (call-next-method)) + (with-suppressed-warnings ((obsolete call-next-method)) + (call-next-method))) -(defmethod no-next-method ((a class-a) &rest args) - "Override signal throwing for variable `class-a'. + (defmethod no-next-method ((_a class-a) &rest _args) + "Override signal throwing for variable `class-a'. Argument A is the object of class variable `class-a'." - 'moose) + 'moose)) (ert-deftest eieio-test-08-call-next-method () ;; Play with call-next-method (should (eq (class-cn eitest-ab) 'moose))) -(defmethod no-applicable-method ((b class-b) method &rest args) - "No need. +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod no-applicable-method ((_b class-b) _method &rest _args) + "No need. Argument B is for booger. METHOD is the method that was attempting to be called." - 'moose) + 'moose)) (ert-deftest eieio-test-09-no-applicable-method () ;; Non-existing methods. (should (eq (class-cn eitest-b) 'moose))) -(defmethod class-fun ((a class-a)) - "Fun with class A." - 'moose) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod class-fun ((_a class-a)) + "Fun with class A." + 'moose) -(defmethod class-fun ((b class-b)) - "Fun with class B." - (error "Class B fun should not be called") - ) + (defmethod class-fun ((_b class-b)) + "Fun with class B." + (error "Class B fun should not be called")) -(defmethod class-fun-foo ((b class-b)) - "Foo Fun with class B." - 'moose) + (defmethod class-fun-foo ((_b class-b)) + "Foo Fun with class B." + 'moose) -(defmethod class-fun2 ((a class-a)) - "More fun with class A." - 'moose) + (defmethod class-fun2 ((_a class-a)) + "More fun with class A." + 'moose) -(defmethod class-fun2 ((b class-b)) - "More fun with class B." - (error "Class B fun2 should not be called") - ) + (defmethod class-fun2 ((_b class-b)) + "More fun with class B." + (error "Class B fun2 should not be called")) -(defmethod class-fun2 ((ab class-ab)) - "More fun with class AB." - (call-next-method)) + (defmethod class-fun2 ((_ab class-ab)) + "More fun with class AB." + (with-suppressed-warnings ((obsolete call-next-method)) + (call-next-method))) -;; How about if B is the only slot? -(defmethod class-fun3 ((b class-b)) - "Even More fun with class B." - 'moose) + ;; How about if B is the only slot? + (defmethod class-fun3 ((_b class-b)) + "Even More fun with class B." + 'moose) -(defmethod class-fun3 ((ab class-ab)) - "Even More fun with class AB." - (call-next-method)) + (defmethod class-fun3 ((_ab class-ab)) + "Even More fun with class AB." + (with-suppressed-warnings ((obsolete call-next-method)) + (call-next-method)))) (ert-deftest eieio-test-10-multiple-inheritance () ;; play with methods and mi @@ -314,20 +347,22 @@ METHOD is the method that was attempting to be called." (defvar class-fun-value-seq '()) -(defmethod class-fun-value :BEFORE ((a class-a)) - "Return `before', and push `before' in `class-fun-value-seq'." - (push 'before class-fun-value-seq) - 'before) - -(defmethod class-fun-value :PRIMARY ((a class-a)) - "Return `primary', and push `primary' in `class-fun-value-seq'." - (push 'primary class-fun-value-seq) - 'primary) - -(defmethod class-fun-value :AFTER ((a class-a)) - "Return `after', and push `after' in `class-fun-value-seq'." - (push 'after class-fun-value-seq) - 'after) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod class-fun-value :BEFORE ((_a class-a)) + "Return `before', and push `before' in `class-fun-value-seq'." + (push 'before class-fun-value-seq) + 'before) + + (defmethod class-fun-value :PRIMARY ((_a class-a)) + "Return `primary', and push `primary' in `class-fun-value-seq'." + (push 'primary class-fun-value-seq) + 'primary) + + (defmethod class-fun-value :AFTER ((_a class-a)) + "Return `after', and push `after' in `class-fun-value-seq'." + (push 'after class-fun-value-seq) + 'after)) (ert-deftest eieio-test-12-generic-function-call () ;; Test value of a generic function call @@ -343,20 +378,23 @@ METHOD is the method that was attempting to be called." ;; (ert-deftest eieio-test-13-init-methods () - (defmethod initialize-instance ((a class-a) &rest slots) - "Initialize the slots of class-a." - (call-next-method) - (if (/= (oref a test-tag) 1) - (error "shared-initialize test failed.")) - (oset a test-tag 2)) - - (defmethod shared-initialize ((a class-a) &rest slots) - "Shared initialize method for class-a." - (call-next-method) - (oset a test-tag 1)) - - (let ((ca (class-a))) - (should-not (/= (oref ca test-tag) 2)))) + (with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete call-next-method)) + (defmethod initialize-instance ((a class-a) &rest _slots) + "Initialize the slots of class-a." + (call-next-method) + (if (/= (oref a test-tag) 1) + (error "shared-initialize test failed.")) + (oset a test-tag 2)) + + (defmethod shared-initialize ((a class-a) &rest _slots) + "Shared initialize method for class-a." + (call-next-method) + (oset a test-tag 1)) + + (let ((ca (class-a))) + (should (= (oref ca test-tag) 2))))) ;;; Perform slot testing @@ -368,10 +406,11 @@ METHOD is the method that was attempting to be called." (should (oref eitest-ab amphibian))) (ert-deftest eieio-test-15-slot-missing () - - (defmethod slot-missing ((ab class-ab) &rest foo) - "If a slot in AB is unbound, return something cool. FOO." - 'moose) + (with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod slot-missing ((_ab class-ab) &rest _foo) + "If a slot in AB is unbound, return something cool. FOO." + 'moose)) (should (eq (oref eitest-ab ooga-booga) 'moose)) (should-error (oref eitest-a ooga-booga) :type 'invalid-slot-name)) @@ -391,17 +430,20 @@ METHOD is the method that was attempting to be called." (defclass virtual-slot-class () ((base-value :initarg :base-value)) "Class has real slot :base-value and simulated slot :derived-value.") -(defmethod slot-missing ((vsc virtual-slot-class) - slot-name operation &optional new-value) - "Simulate virtual slot derived-value." - (cond - ((or (eq slot-name :derived-value) - (eq slot-name 'derived-value)) - (with-slots (base-value) vsc - (if (eq operation 'oref) - (+ base-value 1) - (setq base-value (- new-value 1))))) - (t (call-next-method)))) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod slot-missing ((vsc virtual-slot-class) + slot-name operation &optional new-value) + "Simulate virtual slot derived-value." + (cond + ((or (eq slot-name :derived-value) + (eq slot-name 'derived-value)) + (with-slots (base-value) vsc + (if (eq operation 'oref) + (+ base-value 1) + (setq base-value (- new-value 1))))) + (t (with-suppressed-warnings ((obsolete call-next-method)) + (call-next-method)))))) (ert-deftest eieio-test-17-virtual-slot () (setq eitest-vsca (virtual-slot-class :base-value 1)) @@ -424,35 +466,37 @@ METHOD is the method that was attempting to be called." (should (= (oref eitest-vscb :derived-value) 5))) (ert-deftest eieio-test-18-slot-unbound () - - (defmethod slot-unbound ((a class-a) &rest foo) - "If a slot in A is unbound, ignore FOO." - 'moose) - - (should (eq (oref eitest-a water) 'moose)) - - ;; Check if oset of unbound works - (oset eitest-a water 'moose) - (should (eq (oref eitest-a water) 'moose)) - - ;; oref/oref-default comparison - (should-not (eq (oref eitest-a water) (oref-default eitest-a water))) - - ;; oset-default -> oref/oref-default comparison - (oset-default (eieio-object-class eitest-a) water 'moose) - (should (eq (oref eitest-a water) (oref-default eitest-a water))) - - ;; After setting 'water to 'moose, make sure a new object has - ;; the right stuff. - (oset-default (eieio-object-class eitest-a) water 'penguin) - (should (eq (oref (class-a) water) 'penguin)) - - ;; Revert the above - (defmethod slot-unbound ((a class-a) &rest foo) - "If a slot in A is unbound, ignore FOO." - ;; Disable the old slot-unbound so we can run this test - ;; more than once - (call-next-method))) + (with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod slot-unbound ((_a class-a) &rest _foo) + "If a slot in A is unbound, ignore FOO." + 'moose) + + (should (eq (oref eitest-a water) 'moose)) + + ;; Check if oset of unbound works + (oset eitest-a water 'moose) + (should (eq (oref eitest-a water) 'moose)) + + ;; oref/oref-default comparison + (should-not (eq (oref eitest-a water) (oref-default eitest-a water))) + + ;; oset-default -> oref/oref-default comparison + (oset-default (eieio-object-class eitest-a) water 'moose) + (should (eq (oref eitest-a water) (oref-default eitest-a water))) + + ;; After setting 'water to 'moose, make sure a new object has + ;; the right stuff. + (oset-default (eieio-object-class eitest-a) water 'penguin) + (should (eq (oref (class-a) water) 'penguin)) + + ;; Revert the above + (defmethod slot-unbound ((_a class-a) &rest _foo) + "If a slot in A is unbound, ignore FOO." + ;; Disable the old slot-unbound so we can run this test + ;; more than once + (with-suppressed-warnings ((obsolete call-next-method)) + (call-next-method))))) (ert-deftest eieio-test-19-slot-type-checking () ;; Slot type checking @@ -489,7 +533,7 @@ METHOD is the method that was attempting to be called." (defclass inittest nil ((staticval :initform 1) - (symval :initform eieio-test-permuting-value) + (symval :initform 'eieio-test-permuting-value) (evalval :initform (symbol-value 'eieio-test-permuting-value)) (evalnow :initform (symbol-value 'eieio-test-permuting-value) :allocation :class) @@ -506,8 +550,10 @@ METHOD is the method that was attempting to be called." (should (eq (oref eitest-pvinit evalval) 2)) (should (eq (oref eitest-pvinit evalnow) 1))) +;; Silence byte-compiler. (defvar eitest-tests nil) - +(declare-function eitest-superior nil) +(declare-function eitest-superior--eieio-childp nil) (ert-deftest eieio-test-22-init-forms-dont-match-runnable () ;; Init forms with types that don't match the runnable. (defclass eitest-subordinate nil @@ -515,7 +561,7 @@ METHOD is the method that was attempting to be called." "Test class that will be a calculated value.") (defclass eitest-superior nil - ((sub :initform (eitest-subordinate) + ((sub :initform (funcall #'eitest-subordinate) :type eitest-subordinate)) "A class with an initform that creates a class.") @@ -555,7 +601,10 @@ METHOD is the method that was attempting to be called." (should-not (cl-typep listooa '(list-of class-b))) (should-not (cl-typep listoob '(list-of class-a))))) +;; Silence byte-compiler. (defvar eitest-t1 nil) +(declare-function eieio-tests-initform-not-evaluated-when-initarg-is-present nil) +(declare-function eieio-tests-initform-not-evaluated-when-initarg-is-present--eieio-childp nil) (ert-deftest eieio-test-25-slot-tests () (setq eitest-t1 (class-c)) ;; Slot initialization @@ -574,7 +623,21 @@ METHOD is the method that was attempting to be called." (setf (get-slot-3 eitest-t1) 'setf-emu) (should (eq (get-slot-3 eitest-t1) 'setf-emu)) ;; Roll back - (setf (get-slot-3 eitest-t1) 'emu)) + (setf (get-slot-3 eitest-t1) 'emu) + (defvar eieio-tests-initform-was-evaluated) + (defclass eieio-tests-initform-not-evaluated-when-initarg-is-present () + ((slot-with-initarg-and-initform + :initarg :slot-with-initarg-and-initform + :initform (setf eieio-tests-initform-was-evaluated t)))) + (setq eieio-tests-initform-was-evaluated nil) + (make-instance + 'eieio-tests-initform-not-evaluated-when-initarg-is-present) + (should eieio-tests-initform-was-evaluated) + (setq eieio-tests-initform-was-evaluated nil) + (make-instance + 'eieio-tests-initform-not-evaluated-when-initarg-is-present + :slot-with-initarg-and-initform t) + (should-not eieio-tests-initform-was-evaluated)) (defvar eitest-t2 nil) (ert-deftest eieio-test-26-default-inheritance () @@ -603,12 +666,14 @@ METHOD is the method that was attempting to be called." () "Protection testing baseclass.") -(defmethod prot0-slot-2 ((s2 prot-0)) - "Try to access slot-2 from this class which doesn't have it. +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod prot0-slot-2 ((s2 prot-0)) + "Try to access slot-2 from this class which doesn't have it. The object S2 passed in will be of class prot-1, which does have the slot. This could be allowed, and currently is in EIEIO. Needed by the eieio persistent base class." - (oref s2 slot-2)) + (oref s2 slot-2))) (defclass prot-1 (prot-0) ((slot-1 :initarg :slot-1 @@ -626,26 +691,28 @@ Needed by the eieio persistent base class." nil "A class for testing the :protection option.") -(defmethod prot1-slot-2 ((s2 prot-1)) - "Try to access slot-2 in S2." - (oref s2 slot-2)) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod prot1-slot-2 ((s2 prot-1)) + "Try to access slot-2 in S2." + (oref s2 slot-2)) -(defmethod prot1-slot-2 ((s2 prot-2)) - "Try to access slot-2 in S2." - (oref s2 slot-2)) + (defmethod prot1-slot-2 ((s2 prot-2)) + "Try to access slot-2 in S2." + (oref s2 slot-2)) -(defmethod prot1-slot-3-only ((s2 prot-1)) - "Try to access slot-3 in S2. + (defmethod prot1-slot-3-only ((s2 prot-1)) + "Try to access slot-3 in S2. Do not override for `prot-2'." - (oref s2 slot-3)) + (oref s2 slot-3)) -(defmethod prot1-slot-3 ((s2 prot-1)) - "Try to access slot-3 in S2." - (oref s2 slot-3)) + (defmethod prot1-slot-3 ((s2 prot-1)) + "Try to access slot-3 in S2." + (oref s2 slot-3)) -(defmethod prot1-slot-3 ((s2 prot-2)) - "Try to access slot-3 in S2." - (oref s2 slot-3)) + (defmethod prot1-slot-3 ((s2 prot-2)) + "Try to access slot-3 in S2." + (oref s2 slot-3))) (defvar eitest-p1 nil) (defvar eitest-p2 nil) @@ -689,13 +756,24 @@ Do not override for `prot-2'." (defvar eitest-II2 nil) (defvar eitest-II3 nil) (ert-deftest eieio-test-29-instance-inheritor () - (setq eitest-II1 (II "II Test.")) + (setq eitest-II1 (II)) (oset eitest-II1 slot2 'cat) (setq eitest-II2 (clone eitest-II1 "eitest-II2 Test.")) (oset eitest-II2 slot1 'moose) (setq eitest-II3 (clone eitest-II2 "eitest-II3 Test.")) (oset eitest-II3 slot3 'penguin) + ;; Test that slots are non-initialized slots are unbounded + (oref eitest-II2 slot1) + (should (slot-boundp eitest-II2 'slot1)) + (should-not (slot-boundp eitest-II2 'slot2)) + (should-not (slot-boundp eitest-II2 'slot3)) + (should-not (slot-boundp eitest-II3 'slot2)) + (should-not (slot-boundp eitest-II3 'slot1)) + (should-not (slot-boundp eitest-II3 'slot2)) + (should (eieio-instance-inheritor-slot-boundp eitest-II3 'slot2)) + (should (slot-boundp eitest-II3 'slot3)) + ;; Test level 1 inheritance (should (eq (oref eitest-II3 slot1) 'moose)) ;; Test level 2 inheritance @@ -704,7 +782,7 @@ Do not override for `prot-2'." (should (eq (oref eitest-II3 slot3) 'penguin))) (defclass slotattr-base () - ((initform :initform init) + ((initform :initform 'init) (type :type list) (initarg :initarg :initarg) (protection :protection :private) @@ -719,7 +797,7 @@ Do not override for `prot-2'." Subclasses to override slot attributes.") (defclass slotattr-ok (slotattr-base) - ((initform :initform no-init) + ((initform :initform 'no-init) (initarg :initarg :initblarg) (custom :custom string :label "One String" @@ -753,28 +831,29 @@ Subclasses to override slot attributes.") (let ((obj (slotattr-ok))) (should (eq (oref obj initform) 'no-init)))) -(defclass slotattr-class-base () - ((initform :allocation :class - :initform init) - (type :allocation :class - :type list) - (initarg :allocation :class - :initarg :initarg) - (protection :allocation :class - :protection :private) - (custom :allocation :class - :custom (repeat string) - :label "Custom Strings" - :group moose) - (docstring :allocation :class - :documentation - "Replace the doc-string for this property.") - ) - "Baseclass we will attempt to subclass. -Subclasses to override slot attributes.") +(with-no-warnings ; FIXME: Make more specific. + (defclass slotattr-class-base () + ((initform :allocation :class + :initform 'init) + (type :allocation :class + :type list) + (initarg :allocation :class + :initarg :initarg) + (protection :allocation :class + :protection :private) + (custom :allocation :class + :custom (repeat string) + :label "Custom Strings" + :group moose) + (docstring :allocation :class + :documentation + "Replace the doc-string for this property.") + ) + "Baseclass we will attempt to subclass. +Subclasses to override slot attributes.")) (defclass slotattr-class-ok (slotattr-class-base) - ((initform :initform no-init) + ((initform :initform 'no-init) (initarg :initarg :initblarg) (custom :custom string :label "One String" @@ -836,11 +915,12 @@ Subclasses to override slot attributes.") (should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1)))) (defclass IT (eieio-instance-tracker) - ((tracking-symbol :initform IT-list) + ((tracking-symbol :initform 'IT-list) (slot1 :initform 'die)) "Instance Tracker test object.") (ert-deftest eieio-test-33-instance-tracker () + (defvar IT-list) (let (IT-list IT1) (should (setq IT1 (IT))) ;; The instance tracker must find this @@ -862,8 +942,7 @@ Subclasses to override slot attributes.") (should (oref obj1 a-slot)))) (defclass NAMED (eieio-named) - ((some-slot :initform nil) - ) + ((some-slot :initform nil)) "A class inheriting from eieio-named.") (ert-deftest eieio-test-35-named-object () @@ -876,12 +955,12 @@ Subclasses to override slot attributes.") (defclass opt-test1 () () - "Abstract base class" + "Abstract base class." :abstract t) (defclass opt-test2 (opt-test1) () - "Instantiable child") + "Instantiable child.") (ert-deftest eieio-test-36-build-class-alist () (should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2)) @@ -889,19 +968,83 @@ Subclasses to override slot attributes.") (defclass eieio--testing () ()) -(defmethod constructor :static ((_x eieio--testing) newname &rest _args) - (list newname 2)) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod constructor :static ((_x eieio--testing) newname &rest _args) + (list newname 2))) (ert-deftest eieio-test-37-obsolete-name-in-constructor () - ;; FIXME repeated intermittent failures on hydra (bug#24503) - (skip-unless (not (getenv "EMACS_HYDRA_CI"))) - (should (equal (eieio--testing "toto") '("toto" 2)))) + ;; FIXME repeated intermittent failures on hydra and elsewhere (bug#24503). + :tags '(:unstable) + ;; Disable byte-compiler "Warning: Obsolete name arg "toto" to + ;; constructor eieio--testing". This could be made more specific + ;; with changes to `with-suppressed-warnings', but it's not worth + ;; the hassle for just this one test. + (with-no-warnings + (should (equal (eieio--testing "toto") '("toto" 2))))) (ert-deftest eieio-autoload () "Tests to see whether reftex-auc has been autoloaded" (should (fboundp 'eieio--defalias))) +(ert-deftest eieio-test-38-clone-named-object () + (let* ((A (NAMED :object-name "aa")) + (B (clone A :object-name "bb")) + (C (clone A "cc")) + (D (clone A)) + (E (clone D))) + (should (string= "aa" (oref A object-name))) + (should (string= "bb" (oref B object-name))) + (should (string= "cc" (oref C object-name))) + (should (string= "aa-1" (oref D object-name))) + (should (string= "aa-2" (oref E object-name))))) + +(defclass TII (eieio-instance-inheritor) + ((a :initform 1 :initarg :a) + (b :initarg :b) + (c :initarg :c)) + "Instance Inheritor test class.") + +(ert-deftest eieio-test-39-clone-instance-inheritor-with-args () + (let* ((A (TII)) + (B (clone A :b "bb")) + (C (clone B :a "aa"))) + + (should (string= "aa" (oref C :a))) + (should (string= "bb" (oref C :b))) + + (should (slot-boundp A :a)) + (should-not (slot-boundp A :b)) + (should-not (slot-boundp A :c)) + + (should-not (slot-boundp B :a)) + (should (slot-boundp B :b)) + (should-not (slot-boundp A :c)) + + (should (slot-boundp C :a)) + (should-not (slot-boundp C :b)) + (should-not (slot-boundp C :c)) + + (should (eieio-instance-inheritor-slot-boundp C :a)) + (should (eieio-instance-inheritor-slot-boundp C :b)) + (should-not (eieio-instance-inheritor-slot-boundp C :c)))) + +;;;; Interaction with defstruct + +(cl-defstruct eieio-test--struct a b (c nil :read-only t)) + +(ert-deftest eieio-test-defstruct-slot-value () + (let ((x (make-eieio-test--struct :a 'A :b 'B :c 'C))) + (should (eq (eieio-test--struct-a x) + (slot-value x 'a))) + (should (eq (eieio-test--struct-b x) + (slot-value x 'b))) + (should (eq (eieio-test--struct-c x) + (slot-value x 'c))) + (setf (slot-value x 'a) 1) + (should (eq (eieio-test--struct-a x) 1)) + (should-error (setf (slot-value x 'c) 3) :type 'eieio-read-only))) (provide 'eieio-tests) diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index b620a662846..84c28e11315 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -1,23 +1,23 @@ ;;; ert-tests.el --- ERT's self-tests -*- lexical-binding: t -*- -;; Copyright (C) 2007-2008, 2010-2017 Free Software Foundation, Inc. +;; Copyright (C) 2007-2008, 2010-2022 Free Software Foundation, Inc. ;; Author: Christian Ohler <ohler@gnu.org> ;; 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. -;; +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -39,10 +39,11 @@ (defun ert-self-test () "Run ERT's self-tests and make sure they actually ran." (let ((window-configuration (current-window-configuration))) - (let ((ert--test-body-was-run nil)) + (let ((ert--test-body-was-run nil) + (ert--output-buffer-name " *ert self-tests*")) ;; The buffer name chosen here should not compete with the default ;; results buffer name for completion in `switch-to-buffer'. - (let ((stats (ert-run-tests-interactively "^ert-" " *ert self-tests*"))) + (let ((stats (ert-run-tests-interactively "^ert-"))) (cl-assert ert--test-body-was-run) (if (zerop (ert-stats-completed-unexpected stats)) ;; Hide results window only when everything went well. @@ -188,7 +189,7 @@ failed or if there was a problem." (ert-deftest ert-test-should-with-macrolet () (let ((test (make-ert-test :body (lambda () - (cl-macrolet ((foo () `(progn t nil))) + (cl-macrolet ((foo () '(progn t nil))) (should (foo))))))) (let ((result (let ((ert-debug-on-error nil)) (ert-run-test test)))) @@ -376,8 +377,11 @@ This macro is used to test if macroexpansion in `should' works." (test (make-ert-test :body test-body)) (result (ert-run-test test))) (should (ert-test-failed-p result)) - (should (eq (nth 1 (car (ert-test-failed-backtrace result))) - 'signal)))) + (should (memq (backtrace-frame-fun (car (ert-test-failed-backtrace result))) + ;;; This is `ert-fail' on nativecomp and `signal' + ;;; otherwise. It's not clear whether that's a bug + ;;; or not (bug#51308). + '(ert-fail signal))))) (ert-deftest ert-test-messages () :tags '(:causes-redisplay) @@ -490,54 +494,18 @@ This macro is used to test if macroexpansion in `should' works." :name nil :body nil :tags '(a b)))) - (should (equal (ert-select-tests `(tag a) (list test)) (list test))) - (should (equal (ert-select-tests `(tag b) (list test)) (list test))) - (should (equal (ert-select-tests `(tag c) (list test)) '())))) + (should (equal (ert-select-tests '(tag a) (list test)) (list test))) + (should (equal (ert-select-tests '(tag b) (list test)) (list test))) + (should (equal (ert-select-tests '(tag c) (list test)) '())))) +(ert-deftest ert-test-select-undefined () + (let* ((symbol (make-symbol "ert-not-a-test")) + (data (should-error (ert-select-tests symbol t) + :type 'ert-test-unbound))) + (should (eq (cadr data) symbol)))) -;;; Tests for utility functions. -(ert-deftest ert-test-proper-list-p () - (should (ert--proper-list-p '())) - (should (ert--proper-list-p '(1))) - (should (ert--proper-list-p '(1 2))) - (should (ert--proper-list-p '(1 2 3))) - (should (ert--proper-list-p '(1 2 3 4))) - (should (not (ert--proper-list-p 'a))) - (should (not (ert--proper-list-p '(1 . a)))) - (should (not (ert--proper-list-p '(1 2 . a)))) - (should (not (ert--proper-list-p '(1 2 3 . a)))) - (should (not (ert--proper-list-p '(1 2 3 4 . a)))) - (let ((a (list 1))) - (setf (cdr (last a)) a) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2))) - (setf (cdr (last a)) a) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3))) - (setf (cdr (last a)) a) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) a) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2))) - (setf (cdr (last a)) (cdr a)) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3))) - (setf (cdr (last a)) (cdr a)) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) (cdr a)) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3))) - (setf (cdr (last a)) (cddr a)) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) (cddr a)) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) (cl-cdddr a)) - (should (not (ert--proper-list-p a))))) +;;; Tests for utility functions. (ert-deftest ert-test-parse-keys-and-body () (should (equal (ert--parse-keys-and-body '(foo)) '(nil (foo)))) (should (equal (ert--parse-keys-and-body '(:bar foo)) '((:bar foo) nil))) @@ -561,17 +529,18 @@ This macro is used to test if macroexpansion in `should' works." :body (lambda () (ert-skip "skip message"))))) (let ((ert-debug-on-error nil)) - (let* ((buffer-name (generate-new-buffer-name " *ert-test-run-tests*")) - (messages nil) - (mock-message-fn - (lambda (format-string &rest args) - (push (apply #'format format-string args) messages)))) + (cl-letf* ((buffer-name (generate-new-buffer-name + " *ert-test-run-tests*")) + (ert--output-buffer-name buffer-name) + (messages nil) + ((symbol-function 'message) + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) (save-window-excursion (unwind-protect (let ((case-fold-search nil)) (ert-run-tests-interactively - `(member ,passing-test ,failing-test, skipped-test) buffer-name - mock-message-fn) + `(member ,passing-test ,failing-test, skipped-test)) (should (equal messages `(,(concat "Ran 3 tests, 1 results were " "as expected, 1 unexpected, " @@ -593,6 +562,69 @@ This macro is used to test if macroexpansion in `should' works." (when (get-buffer buffer-name) (kill-buffer buffer-name)))))))) +(ert-deftest ert-test-run-tests-batch () + (let* ((complex-list '((:1 (:2 (:3 (:4 (:5 (:6 "abc")))))))) + (long-list (make-list 11 1)) + (failing-test-1 + (make-ert-test :name 'failing-test-1 + :body (lambda () (should (equal complex-list 1))))) + (failing-test-2 + (make-ert-test :name 'failing-test-2 + :body (lambda () (should (equal long-list 1)))))) + (let ((ert-debug-on-error nil) + messages) + (cl-letf* (((symbol-function 'message) + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) + (save-window-excursion + (unwind-protect + (let ((case-fold-search nil) + (ert-batch-backtrace-right-margin nil) + (ert-batch-print-level 10) + (ert-batch-print-length 11)) + (ert-run-tests-batch + `(member ,failing-test-1 ,failing-test-2)))))) + (let ((long-text "(different-types[ \t\n]+(1 1 1 1 1 1 1 1 1 1 1)[ \t\n]+1)))[ \t\n]*$") + (complex-text "(different-types[ \t\n]+((:1[ \t\n]+(:2[ \t\n]+(:3[ \t\n]+(:4[ \t\n]+(:5[ \t\n]+(:6[ \t\n]+\"abc\")))))))[ \t\n]+1)))[ \t\n]*$") + found-long + found-complex) + (cl-loop for msg in (reverse messages) + do + (unless found-long + (setq found-long (string-match long-text msg))) + (unless found-complex + (setq found-complex (string-match complex-text msg)))) + (should found-long) + (should found-complex))))) + +(ert-deftest ert-test-run-tests-batch-expensive () + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) + (let* ((complex-list '((:1 (:2 (:3 (:4 (:5 (:6 "abc")))))))) + (failing-test-1 + (make-ert-test :name 'failing-test-1 + :body (lambda () (should (equal complex-list 1)))))) + (let ((ert-debug-on-error nil) + messages) + (cl-letf* (((symbol-function 'message) + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) + (save-window-excursion + (unwind-protect + (let ((case-fold-search nil) + (ert-batch-backtrace-right-margin nil) + (ert-batch-backtrace-line-length nil) + (ert-batch-print-level 6) + (ert-batch-print-length 11)) + (ert-run-tests-batch + `(member ,failing-test-1)))))) + (let ((frame "ert-fail(((should (equal complex-list 1)) :form (equal ((:1 (:2 (:3 (:4 (:5 (:6 \"abc\"))))))) 1) :value nil :explanation (different-types ((:1 (:2 (:3 (:4 (:5 (:6 \"abc\"))))))) 1)))") + found-frame) + (cl-loop for msg in (reverse messages) + do + (unless found-frame + (setq found-frame (cl-search frame msg :test 'equal)))) + (should found-frame))))) + (ert-deftest ert-test-special-operator-p () (should (ert--special-operator-p 'if)) (should-not (ert--special-operator-p 'car)) @@ -669,6 +701,29 @@ This macro is used to test if macroexpansion in `should' works." (should (equal (ert--explain-equal 'a sym) `(different-symbols-with-the-same-name a ,sym))))) +(ert-deftest ert-test-explain-equal-strings () + (should (equal (ert--explain-equal "abc" "axc") + '(array-elt 1 (different-atoms + (?b "#x62" "?b") + (?x "#x78" "?x"))))) + (should (equal (ert--explain-equal "abc" "abxc") + '(arrays-of-different-length + 3 4 "abc" "abxc" first-mismatch-at 2))) + (should (equal (ert--explain-equal "xyA" "xyÅ") + '(array-elt 2 (different-atoms + (?A "#x41" "?A") + (?Å "#xc5" "?Å"))))) + (should (equal (ert--explain-equal "m\xff" "m\u00ff") + `(array-elt + 1 (different-atoms + (#x3fffff "#x3fffff" ,(string-to-multibyte "?\xff")) + (#xff "#xff" "?ÿ"))))) + (should (equal (ert--explain-equal (string-to-multibyte "m\xff") "m\u00ff") + `(array-elt + 1 (different-atoms + (#x3fffff "#x3fffff" ,(string-to-multibyte "?\xff")) + (#xff "#xff" "?ÿ")))))) + (ert-deftest ert-test-explain-equal-improper-list () (should (equal (ert--explain-equal '(a . b) '(a . c)) '(cdr (different-atoms b c))))) @@ -714,49 +769,40 @@ This macro is used to test if macroexpansion in `should' works." (should (equal (ert--abbreviate-string "bar" 0 t) ""))) (ert-deftest ert-test-explain-equal-string-properties () - (should - (equal (ert--explain-equal-including-properties #("foo" 0 1 (a b)) - "foo") - '(char 0 "f" - (different-properties-for-key a (different-atoms b nil)) - context-before "" - context-after "oo"))) - (should (equal (ert--explain-equal-including-properties + (should-not (ert--explain-equal-including-properties-rec "foo" "foo")) + (should-not (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a b)) + (propertize "foo" 'a 'b))) + (should-not (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a b c d)) + (propertize "foo" 'a 'b 'c 'd))) + (should-not (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a (t))) + (propertize "foo" 'a (list t)))) + + (should (equal (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a b c e)) + (propertize "foo" 'a 'b 'c 'd)) + '(char 0 "f" (different-properties-for-key c (different-atoms e d)) + context-before "" + context-after "oo"))) + (should (equal (ert--explain-equal-including-properties-rec + #("foo" 0 1 (a b)) + "foo") + '(char 0 "f" + (different-properties-for-key a (different-atoms b nil)) + context-before "" + context-after "oo"))) + (should (equal (ert--explain-equal-including-properties-rec #("foo" 1 3 (a b)) #("goo" 0 1 (c d))) '(array-elt 0 (different-atoms (?f "#x66" "?f") (?g "#x67" "?g"))))) - (should - (equal (ert--explain-equal-including-properties - #("foo" 0 1 (a b c d) 1 3 (a b)) - #("foo" 0 1 (c d a b) 1 2 (a foo))) - '(char 1 "o" (different-properties-for-key a (different-atoms b foo)) - context-before "f" context-after "o")))) - -(ert-deftest ert-test-equal-including-properties () - (should (equal-including-properties "foo" "foo")) - (should (ert-equal-including-properties "foo" "foo")) - - (should (equal-including-properties #("foo" 0 3 (a b)) - (propertize "foo" 'a 'b))) - (should (ert-equal-including-properties #("foo" 0 3 (a b)) - (propertize "foo" 'a 'b))) - - (should (equal-including-properties #("foo" 0 3 (a b c d)) - (propertize "foo" 'a 'b 'c 'd))) - (should (ert-equal-including-properties #("foo" 0 3 (a b c d)) - (propertize "foo" 'a 'b 'c 'd))) - - (should-not (equal-including-properties #("foo" 0 3 (a b c e)) - (propertize "foo" 'a 'b 'c 'd))) - (should-not (ert-equal-including-properties #("foo" 0 3 (a b c e)) - (propertize "foo" 'a 'b 'c 'd))) - - ;; This is bug 6581. - (should-not (equal-including-properties #("foo" 0 3 (a (t))) - (propertize "foo" 'a (list t)))) - (should (ert-equal-including-properties #("foo" 0 3 (a (t))) - (propertize "foo" 'a (list t))))) + (should (equal (ert--explain-equal-including-properties-rec + #("foo" 0 1 (a b c d) 1 3 (a b)) + #("foo" 0 1 (c d a b) 1 2 (a foo))) + '(char 1 "o" (different-properties-for-key a (different-atoms b foo)) + context-before "f" context-after "o")))) (ert-deftest ert-test-stats-set-test-and-result () (let* ((test-1 (make-ert-test :name 'test-1 @@ -820,6 +866,28 @@ This macro is used to test if macroexpansion in `should' works." (should (eql 0 (ert-stats-completed-unexpected stats))) (should (eql 1 (ert-stats-skipped stats))))) +(ert-deftest ert-test-with-demoted-errors () + "Check that ERT correctly handles `with-demoted-errors'." + :expected-result :failed ;; FIXME! Bug#11218 + (should-not (with-demoted-errors "FOO: %S" (error "Foo")))) + +(ert-deftest ert-test-fail-inside-should () + "Check that `ert-fail' inside `should' works correctly." + (let ((result (ert-run-test + (make-ert-test + :name 'test-1 + :body (lambda () (should (integerp (ert-fail "Boo")))))))) + (should (ert-test-failed-p result)) + (should (equal (ert-test-failed-condition result) + '(ert-test-failed "Boo"))))) + +(ert-deftest ert-test-deftest-lexical-binding-t () + "Check that `lexical-binding' in `ert-deftest' has the file value." + (should (equal lexical-binding t))) + +(ert-deftest ert-test-get-explainer () + (should (eq (ert--get-explainer 'string-equal) 'ert--explain-string-equal)) + (should (eq (ert--get-explainer 'string=) 'ert--explain-string-equal))) (provide 'ert-tests) diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el index 0cc89ac9977..63e7cd7608f 100644 --- a/test/lisp/emacs-lisp/ert-x-tests.el +++ b/test/lisp/emacs-lisp/ert-x-tests.el @@ -1,24 +1,24 @@ -;;; ert-x-tests.el --- Tests for ert-x.el +;;; ert-x-tests.el --- Tests for ert-x.el -*- lexical-binding:t -*- -;; Copyright (C) 2008, 2010-2017 Free Software Foundation, Inc. +;; Copyright (C) 2008, 2010-2022 Free Software Foundation, Inc. ;; Author: Phil Hagelberg ;; Christian Ohler <ohler@gnu.org> ;; 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. -;; +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -82,6 +82,21 @@ (should-not (buffer-live-p buffer-1)) (should (buffer-live-p buffer-2)))))) +(ert-deftest ert-test-with-test-buffer-selected/selected () + (ert-with-test-buffer-selected () + (should (eq (window-buffer) (current-buffer))))) + +(ert-deftest ert-test-with-test-buffer-selected/modification-hooks () + (ert-with-test-buffer-selected () + (should (null inhibit-modification-hooks)))) + +(ert-deftest ert-test-with-test-buffer-selected/return-value () + (should (equal (ert-with-test-buffer-selected () "foo") "foo"))) + +(ert-deftest ert-test-with-test-buffer-selected/buffer-name () + (should (equal (ert-with-test-buffer (:name "foo") (buffer-name)) + (ert-with-test-buffer-selected (:name "foo") + (buffer-name))))) (ert-deftest ert-filter-string () (should (equal (ert-filter-string "foo bar baz" "quux") @@ -90,10 +105,10 @@ "foo baz"))) (ert-deftest ert-propertized-string () - (should (ert-equal-including-properties + (should (equal-including-properties (ert-propertized-string "a" '(a b) "b" '(c t) "cd") #("abcd" 1 2 (a b) 2 4 (c t)))) - (should (ert-equal-including-properties + (should (equal-including-properties (ert-propertized-string "foo " '(face italic) "bar" " baz" nil " quux") #("foo bar baz quux" 4 11 (face italic))))) @@ -103,23 +118,27 @@ (ert-deftest ert-test-run-tests-interactively-2 () :tags '(:causes-redisplay) - (let* ((passing-test (make-ert-test :name 'passing-test - :body (lambda () (ert-pass)))) - (failing-test (make-ert-test :name 'failing-test - :body (lambda () - (ert-info ((propertize "foo\nbar" - 'a 'b)) - (ert-fail - "failure message"))))) - (skipped-test (make-ert-test :name 'skipped-test - :body (lambda () (ert-skip - "skip message")))) - (ert-debug-on-error nil) - (buffer-name (generate-new-buffer-name "*ert-test-run-tests*")) - (messages nil) - (mock-message-fn - (lambda (format-string &rest args) - (push (apply #'format format-string args) messages)))) + (cl-letf* ((passing-test (make-ert-test + :name 'passing-test + :body (lambda () (ert-pass)))) + (failing-test (make-ert-test + :name 'failing-test + :body (lambda () + (ert-info ((propertize "foo\nbar" + 'a 'b)) + (ert-fail + "failure message"))))) + (skipped-test (make-ert-test + :name 'skipped-test + :body (lambda () (ert-skip + "skip message")))) + (ert-debug-on-error nil) + (messages nil) + (buffer-name (generate-new-buffer-name "*ert-test-run-tests*")) + ((symbol-function 'message) + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages))) + (ert--output-buffer-name buffer-name)) (cl-flet ((expected-string (with-font-lock-p) (ert-propertized-string "Selector: (member <passing-test> <failing-test> " @@ -152,21 +171,19 @@ "failing-test" nil "\n Info: " '(a b) "foo\n" nil " " '(a b) "bar" - nil "\n (ert-test-failed \"failure message\")\n\n\n" - ))) + nil "\n (ert-test-failed \"failure message\")\n\n\n"))) (save-window-excursion (unwind-protect (let ((case-fold-search nil)) (ert-run-tests-interactively - `(member ,passing-test ,failing-test ,skipped-test) buffer-name - mock-message-fn) + `(member ,passing-test ,failing-test ,skipped-test)) (should (equal messages `(,(concat "Ran 3 tests, 1 results were " "as expected, 1 unexpected, " "1 skipped")))) (with-current-buffer buffer-name (font-lock-mode 0) - (should (ert-equal-including-properties + (should (equal-including-properties (ert-filter-string (buffer-string) '("Started at:\\(.*\\)$" 1) '("Finished at:\\(.*\\)$" 1)) @@ -175,7 +192,7 @@ ;; pretend we are. (let ((noninteractive nil)) (font-lock-mode 1)) - (should (ert-equal-including-properties + (should (equal-including-properties (ert-filter-string (buffer-string) '("Started at:\\(.*\\)$" 1) '("Finished at:\\(.*\\)$" 1)) @@ -187,18 +204,15 @@ "Tests `ert-describe-test'." (save-window-excursion (ert-with-buffer-renamed ("*Help*") - (if (< emacs-major-version 24) - (should (equal (should-error (ert-describe-test 'ert-describe-test)) - '(error "Requires Emacs 24"))) - (ert-describe-test 'ert-test-describe-test) - (with-current-buffer "*Help*" - (let ((case-fold-search nil)) - (should (string-match (concat - "\\`ert-test-describe-test is a test" - " defined in" - " ['`‘]ert-x-tests.elc?['’]\\.\n\n" - "Tests ['`‘]ert-describe-test['’]\\.\n\\'") - (buffer-string))))))))) + (ert-describe-test 'ert-test-describe-test) + (with-current-buffer "*Help*" + (let ((case-fold-search nil)) + (should (string-match (concat + "\\`ert-test-describe-test is a test" + " defined in" + " ['`‘]ert-x-tests.elc?['’]\\.\n\n" + "Tests ['`‘]ert-describe-test['’]\\.\n\\'") + (buffer-string)))))))) (ert-deftest ert-test-message-log-truncation () :tags '(:causes-redisplay) @@ -274,6 +288,62 @@ desired effect." (cl-loop for x in '(0 1 2 3 4 t) do (should (equal (c x) (lisp x)))))) +(ert-deftest ert-x-tests--with-temp-file-generate-suffix () + (should (equal (ert--with-temp-file-generate-suffix "foo.el") "-foo")) + (should (equal (ert--with-temp-file-generate-suffix "foo-test.el") "-foo")) + (should (equal (ert--with-temp-file-generate-suffix "foo-tests.el") "-foo")) + (should (equal (ert--with-temp-file-generate-suffix "foo-bar-baz.el") + "-foo-bar-baz")) + (should (equal (ert--with-temp-file-generate-suffix "/foo/bar/baz.el") + "-baz"))) + +(ert-deftest ert-x-tests-with-temp-file () + (let (saved) + (ert-with-temp-file fil + (setq saved fil) + (should (file-exists-p fil)) + (should (file-regular-p fil))) + (should-not (file-exists-p saved)))) + +(ert-deftest ert-x-tests-with-temp-file/handle-error () + (let (saved) + (ignore-errors + (ert-with-temp-file fil + (setq saved fil) + (error "foo"))) + (should-not (file-exists-p saved)))) + +(ert-deftest ert-x-tests-with-temp-file/prefix-and-suffix-kwarg () + (ert-with-temp-file fil + :prefix "foo" + :suffix "bar" + (should (string-match "foo.*bar" fil)))) + +(ert-deftest ert-x-tests-with-temp-file/text-kwarg () + (ert-with-temp-file fil + :text "foobar3" + (let ((buf (find-file-noselect fil))) + (unwind-protect + (with-current-buffer buf + (should (equal (buffer-string) "foobar3"))) + (kill-buffer buf))))) + +(ert-deftest ert-x-tests-with-temp-file/unknown-kwarg-signals-error () + (should-error + (ert-with-temp-file fil :foo "foo" nil))) + +(ert-deftest ert-x-tests-with-temp-directory () + (let (saved) + (ert-with-temp-directory dir + (setq saved dir) + (should (file-exists-p dir)) + (should (file-directory-p dir)) + (should (equal dir (file-name-as-directory dir)))) + (should-not (file-exists-p saved)))) + +(ert-deftest ert-x-tests-with-temp-directory/text-signals-error () + (should-error + (ert-with-temp-directory dir :text "foo" nil))) (provide 'ert-x-tests) diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el new file mode 100644 index 00000000000..9b9c863aa0b --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el @@ -0,0 +1,76 @@ +;;; faceup-test-mode.el --- Dummy major mode for testing `faceup'. -*- lexical-binding:t -*- + +;; Copyright (C) 2014-2022 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Keywords: languages, faces + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Dummy major-mode for testing `faceup', a regression test system for +;; font-lock keywords (syntax highlighting rules for Emacs). +;; +;; This mode use `syntax-propertize' to set the `syntax-table' +;; property on "<" and ">" in "<TEXT>" to make them act like +;; parentheses. +;; +;; This mode also sets the `help-echo' property on the text WARNING, +;; the effect is that Emacs displays a tooltip when you move your +;; mouse on to the text. + +;;; Code: + +(defvar faceup-test-mode-syntax-table + (make-syntax-table) + "Syntax table for `faceup-test-mode'.") + +(defvar faceup-test-font-lock-keywords + '(("\\_<WARNING\\_>" + (0 (progn + (add-text-properties (match-beginning 0) + (match-end 0) + '(help-echo "Balloon tip: Fly smoothly!")) + font-lock-warning-face)))) + "Highlight rules for `faceup-test-mode'.") + +(defun faceup-test-syntax-propertize (start end) + (goto-char start) + (funcall + (syntax-propertize-rules + ("\\(<\\)\\([^<>\n]*\\)\\(>\\)" + (1 "() ") + (3 ")( "))) + start end)) + +(defmacro faceup-test-define-prog-mode (mode name &rest args) + "Define a major mode for a programming language. +If `prog-mode' is defined, inherit from it." + (declare (indent defun)) + `(define-derived-mode + ,mode ,(and (fboundp 'prog-mode) 'prog-mode) + ,name ,@args)) + +(faceup-test-define-prog-mode faceup-test-mode "faceup-test" + "Dummy major mode for testing `faceup', a test system for font-lock." + (setq-local syntax-propertize-function + #'faceup-test-syntax-propertize) + (setq font-lock-defaults '(faceup-test-font-lock-keywords nil))) + +(provide 'faceup-test-mode) + +;;; faceup-test-mode.el ends here diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el new file mode 100644 index 00000000000..137b43a5dfd --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el @@ -0,0 +1,32 @@ +;;; faceup-test-this-file-directory.el --- Support file for faceup tests -*- lexical-binding:t -*- + +;; Copyright (C) 2014-2022 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Keywords: languages, faces + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Support file for `faceup-test-basics.el'. This file is used to test +;; `faceup-this-file-directory' in various contexts. + +;;; Code: + +(defvar faceup-test-this-file-directory (faceup-this-file-directory)) + +;;; faceup-test-this-file-directory.el ends here diff --git a/test/lisp/emacs-lisp/faceup-resources/files/test1.txt b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt new file mode 100644 index 00000000000..d971f364c2d --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt @@ -0,0 +1,15 @@ +This is a test of `faceup', a regression test system for font-lock +keywords. It should use major mode `faceup-test-mode'. + +WARNING: The first word on this line should use +`font-lock-warning-face', and a tooltip should be displayed if the +mouse pointer is moved over it. + +In this mode "<" and ">" are parentheses, but only when on the same +line without any other "<" and ">" characters between them. +<OK> <NOT <OK> > +< +NOT OK +> + +test1.txt ends here. diff --git a/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup new file mode 100644 index 00000000000..ec9e82148fd --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup @@ -0,0 +1,15 @@ +This is a test of `faceup', a regression test system for font-lock +keywords. It should use major mode `faceup-test-mode'. + +«(help-echo):"Balloon tip: Fly smoothly!":«w:WARNING»»: The first word on this line should use +`font-lock-warning-face', and a tooltip should be displayed if the +mouse pointer is moved over it. + +In this mode «s:"«(syntax-table):(4 . 41):<»"» and «s:"«(syntax-table):(5 . 40):>»"» are parentheses, but only when on the same +line without any other «s:"«(syntax-table):(4 . 41):<»"» and «s:"«(syntax-table):(5 . 40):>»"» characters between them. +«(syntax-table):(4 . 41):<»OK«(syntax-table):(5 . 40):>» <NOT «(syntax-table):(4 . 41):<»OK«(syntax-table):(5 . 40):>» > +< +NOT OK +> + +test1.txt ends here. diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el new file mode 100644 index 00000000000..b9fcb4e8863 --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el @@ -0,0 +1,269 @@ +;;; faceup-test-basics.el --- Tests for the `faceup' package. -*- lexical-binding:t -*- + +;; Copyright (C) 2014-2022 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Keywords: languages, faces + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Basic tests for the `faceup' package. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(require 'faceup) + +(ert-deftest faceup-functions () + "Test primitive functions." + (should (equal (faceup-normalize-face-property '()) '())) + (should (equal (faceup-normalize-face-property 'a) '(a))) + (should (equal (faceup-normalize-face-property '(a)) '(a))) + (should (equal (faceup-normalize-face-property '(:x t)) '((:x t)))) + (should (equal (faceup-normalize-face-property '(:x t a)) '((:x t)))) + (should (equal (faceup-normalize-face-property '(:x t a b)) '((:x t)))) + (should (equal (faceup-normalize-face-property '(a :x t)) '(a (:x t)))) + (should (equal (faceup-normalize-face-property '(a b :x t)) + '(a b (:x t)))) + + (should (equal (faceup-normalize-face-property '(:x t :y nil)) + '((:y nil) (:x t)))) + (should (equal (faceup-normalize-face-property '(:x t :y nil a)) + '((:y nil) (:x t)))) + (should (equal (faceup-normalize-face-property '(:x t :y nil a b)) + '((:y nil) (:x t)))) + (should (equal (faceup-normalize-face-property '(a :x t :y nil)) + '(a (:y nil) (:x t)))) + (should (equal (faceup-normalize-face-property '(a b :x t :y nil)) + '(a b (:y nil) (:x t))))) + + +(ert-deftest faceup-markup-basics () + (should (equal (faceup-markup-string "") "")) + (should (equal (faceup-markup-string "test") "test"))) + +(ert-deftest faceup-markup-escaping () + (should (equal (faceup-markup-string "«") "««")) + (should (equal (faceup-markup-string "«A«B«C«") "««A««B««C««")) + (should (equal (faceup-markup-string "»") "«»")) + (should (equal (faceup-markup-string "»A»B»C»") "«»A«»B«»C«»"))) + +(ert-deftest faceup-markup-plain () + ;; UU + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face underline))) + "AB«U:CD»EF"))) + +(ert-deftest faceup-markup-plain-full-text () + ;; UUUUUU + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" 0 6 (face underline))) + "«U:ABCDEF»"))) + +(ert-deftest faceup-markup-anonymous-face () + ;; AA + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face (:underline t)))) + "AB«:(:underline t):CD»EF"))) + +(ert-deftest faceup-markup-anonymous-face-2keys () + ;; AA + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face (:foo t :bar nil)))) + "AB«:(:foo t):«:(:bar nil):CD»»EF")) + ;; Plist in list. + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face ((:foo t :bar nil))))) + "AB«:(:foo t):«:(:bar nil):CD»»EF")) + ;; Two plists. + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face ((:foo t) (:bar nil))))) + "AB«:(:bar nil):«:(:foo t):CD»»EF"))) + +(ert-deftest faceup-markup-anonymous-nested () + ;; AA + ;; IIII + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" + 1 2 (face ((:foo t))) + 2 4 (face ((:bar t) (:foo t))) + 4 5 (face ((:foo t))))) + "A«:(:foo t):B«:(:bar t):CD»E»F"))) + +(ert-deftest faceup-markup-nested () + ;; UU + ;; IIII + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" + 1 2 (face italic) + 2 4 (face (underline italic)) + 4 5 (face italic))) + "A«I:B«U:CD»E»F"))) + +(ert-deftest faceup-markup-overlapping () + ;; UUU + ;; III + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" + 1 2 (face italic) + 2 4 (face (underline italic)) + 4 5 (face underline))) + "A«I:B«U:CD»»«U:E»F")) + ;; III + ;; UUU + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" + 1 2 (face italic) + 2 4 (face (italic underline)) + 4 5 (face underline))) + "A«I:B»«U:«I:CD»E»F"))) + +(ert-deftest faceup-markup-multi-face () + ;; More than one face at the same location. + ;; + ;; The property to the front takes precedence, it is rendered as the + ;; innermost parenthesis pair. + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face (underline italic)))) + "AB«I:«U:CD»»EF")) + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face (italic underline)))) + "AB«U:«I:CD»»EF")) + ;; Equal ranges, full text. + (should (equal (faceup-markup-string + #("ABCDEF" 0 6 (face (underline italic)))) + "«I:«U:ABCDEF»»")) + ;; Ditto, with stray markup characters. + (should (equal (faceup-markup-string + #("AB«CD»EF" 0 8 (face (underline italic)))) + "«I:«U:AB««CD«»EF»»"))) + +(ert-deftest faceup-markup-multi-property () + (let ((faceup-properties '(alpha beta gamma))) + ;; One property. + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (alpha (a l p h a)))) + "AB«(alpha):(a l p h a):CD»EF")) + + ;; Two properties, inner enclosed. + (should (equal (faceup-markup-string + (let ((s (copy-sequence "ABCDEFGHIJ"))) + (set-text-properties 2 8 '(alpha (a l p h a)) s) + (font-lock-append-text-property 4 6 'beta '(b e t a) s) + s)) + "AB«(alpha):(a l p h a):CD«(beta):(b e t a):EF»GH»IJ")) + + ;; Two properties, same end + (should (equal (faceup-markup-string + (let ((s (copy-sequence "ABCDEFGH"))) + (set-text-properties 2 6 '(alpha (a)) s) + (add-text-properties 4 6 '(beta (b)) s) + s)) + "AB«(alpha):(a):CD«(beta):(b):EF»»GH")) + + ;; Two properties, overlap. + (should (equal (faceup-markup-string + (let ((s (copy-sequence "ABCDEFGHIJ"))) + (set-text-properties 2 6 '(alpha (a)) s) + (add-text-properties 4 8 '(beta (b)) s) + s)) + "AB«(alpha):(a):CD«(beta):(b):EF»»«(beta):(b):GH»IJ")))) + + +(ert-deftest faceup-clean () + "Test the clean features of `faceup'." + (should (equal (faceup-clean-string "") "")) + (should (equal (faceup-clean-string "test") "test")) + (should (equal (faceup-clean-string "AB«U:CD»EF") "ABCDEF")) + (should (equal (faceup-clean-string "«U:ABCDEF»") "ABCDEF")) + (should (equal (faceup-clean-string "A«I:B«U:CD»E»F") "ABCDEF")) + (should (equal (faceup-clean-string "A«I:B«U:CD»»«U:E»F") "ABCDEF")) + (should (equal (faceup-clean-string "AB«I:«U:CD»»EF") "ABCDEF")) + (should (equal (faceup-clean-string "«I:«U:ABCDEF»»") "ABCDEF")) + (should (equal (faceup-clean-string "«(foo)I:ABC»DEF") "ABCDEF")) + (should (equal (faceup-clean-string "«:(:foo t):ABC»DEF") "ABCDEF")) + ;; Escaped markup characters. + (should (equal (faceup-clean-string "««") "«")) + (should (equal (faceup-clean-string "«»") "»")) + (should (equal (faceup-clean-string "A«I:B«U:CD»«»»«U:E»F") "ABCD»EF"))) + + +(ert-deftest faceup-render () + "Test the render features of `faceup'." + (should (equal (faceup-render-string "") "")) + (should (equal (faceup-render-string "««") "«")) + (should (equal (faceup-render-string "«»") "»")) + (should (equal (faceup-render-string "A«I:B«U:CD»«»»«U:E»F") "ABCD»EF"))) + + +(defvar faceup-test-resources-directory + (concat (file-name-directory + (substring (faceup-this-file-directory) 0 -1)) + "faceup-resources/") + "The `faceup-resources' directory.") + + +(defvar faceup-test-this-file-directory nil + "The result of `faceup-this-file-directory' in various contexts. + +This is set by the file test support file +`faceup-test-this-file-directory.el'.") + + +(ert-deftest faceup-directory () + "Test `faceup-this-file-directory'." + (let ((file (concat faceup-test-resources-directory + "faceup-test-this-file-directory.el")) + (load-file-name nil)) + ;; Test normal load. + (makunbound 'faceup-test-this-file-directory) + (load file nil :nomessage) + (should (equal faceup-test-this-file-directory + faceup-test-resources-directory)) + ;; Test `eval-buffer'. + (makunbound 'faceup-test-this-file-directory) + (save-excursion + (find-file file) + (eval-buffer)) + (should (equal faceup-test-this-file-directory + faceup-test-resources-directory)) + ;; Test `eval-defun'. + (makunbound 'faceup-test-this-file-directory) + (save-excursion + (find-file file) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + ;; Note: In batch mode, this prints the result of the + ;; evaluation. Unfortunately, this is hard to fix. + (eval-defun nil) + (forward-sexp)))) + (should (equal faceup-test-this-file-directory + faceup-test-resources-directory)))) + +(provide 'faceup-test-basics) + +;;; faceup-test-basics.el ends here diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el new file mode 100644 index 00000000000..f07b8d830b9 --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el @@ -0,0 +1,63 @@ +;;; faceup-test-files.el --- Self test of `faceup' using dummy major mode. -*- lexical-binding:t -*- + +;; Copyright (C) 2014-2022 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Keywords: languages, faces + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Self test of `faceup' with a major mode that sets both the +;; `syntax-table' and the `echo-help' property. +;; +;; This file can also be seen as a blueprint of test cases for real +;; major modes. + +;;; Code: + +(require 'faceup) + +;; Note: The byte compiler needs the value to load `faceup-test-mode', +;; hence the `eval-and-compile'. +(eval-and-compile + (defvar faceup-test-files-dir (faceup-this-file-directory) + "The directory of this file.")) + +(require 'faceup-test-mode + (concat faceup-test-files-dir + "../faceup-resources/" + "faceup-test-mode.el")) + +(defun faceup-test-files-check-one (file) + "Test that FILE is fontified as the .faceup file describes. + +FILE is interpreted as relative to this source directory." + (let ((faceup-properties '(face syntax-table help-echo))) + (faceup-test-font-lock-file 'faceup-test-mode + (concat + faceup-test-files-dir + "../faceup-resources/" + file)))) +(faceup-defexplainer faceup-test-files-check-one) + +(ert-deftest faceup-files () + (should (faceup-test-files-check-one "files/test1.txt"))) + +(provide 'faceup-test-files) + +;;; faceup-test-files.el ends here diff --git a/test/lisp/emacs-lisp/find-func-tests.el b/test/lisp/emacs-lisp/find-func-tests.el new file mode 100644 index 00000000000..d18a9dc1a94 --- /dev/null +++ b/test/lisp/emacs-lisp/find-func-tests.el @@ -0,0 +1,125 @@ +;;; find-func-tests.el --- Unit tests for find-func.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020-2022 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert-x) ;For `ert-simulate-keys'. +(require 'find-func) + +(ert-deftest find-func-tests--library-completion () ;bug#43393 + ;; FIXME: How can we make this work in batch (see also + ;; `mule-cmds--test-universal-coding-system-argument')? + ;; (skip-unless (not noninteractive)) + ;; Check that `partial-completion' works when completing library names. + (should (equal "org/org" + (ert-simulate-keys + (kbd "o / o r g TAB RET") + (read-library-name)))) + ;; Check that absolute file names also work. + (should (equal (expand-file-name "nxml/" data-directory) + (ert-simulate-keys + (concat data-directory (kbd "n x / TAB RET")) + (read-library-name))))) + +(ert-deftest find-func-tests--locate-symbols () + (should (cdr + (find-function-search-for-symbol + #'goto-line nil "simple"))) + (should (cdr + (find-function-search-for-symbol + 'minibuffer-history 'defvar "simple"))) + (should (cdr + (find-function-search-for-symbol + 'with-current-buffer nil "subr"))) + (should (cdr + (find-function-search-for-symbol + 'font-lock-warning-face 'defface "font-lock"))) + (should-not (cdr + (find-function-search-for-symbol + 'wrong-variable 'defvar "simple"))) + (should-not (cdr + (find-function-search-for-symbol + 'wrong-function nil "simple"))) + (should (cdr (find-function-noselect #'goto-line))) + (should (cdr (find-function-noselect #'goto-char))) + ;; Setting LISP-ONLY and passing a primitive should error. + (should-error (find-function-noselect #'goto-char t)) + (should-error (find-function-noselect 'wrong-function))) + +(defun test-locate-helper (func &optional expected-result) + "Assert on the result of `find-function-library' for FUNC. +EXPECTED-RESULT is an alist (FUNC . LIBRARY) with the +expected function symbol and function library, respectively." + (cl-destructuring-bind (orig-function . library) + (find-function-library func) + (cl-destructuring-bind (expected-func . expected-library) + expected-result + (should (eq orig-function expected-func)) + (should (and + (not (string-empty-p expected-library)) + (string-match-p expected-library library)))))) + +(ert-deftest find-func-tests--locate-library () + (test-locate-helper #'goto-line '(goto-line . "simple")) + (test-locate-helper #'forward-char '(forward-char . "cmds.c")) + (should-error (test-locate-helper 'wrong-function))) + +(ert-deftest find-func-tests--locate-adviced-symbols () + (defun my-message () + (message "Hello!")) + (advice-add #'mark-sexp :around 'my-message) + (test-locate-helper #'mark-sexp '(mark-sexp . "lisp")) + (advice-remove #'mark-sexp 'my-message)) + +(ert-deftest find-func-tests--find-library-verbose () + (unwind-protect + (progn + (advice-add 'dired :before #'ignore) + ;; bug#41104 + (should (equal (find-function-library #'dired) '(dired . "dired")))) + (advice-remove 'dired #'ignore)) + + (find-function-library #'join-line nil t) + (with-current-buffer "*Messages*" + (save-excursion + (goto-char (point-max)) + (skip-chars-backward "\n") + (should (string-match-p + ".join-line. is an alias for .delete-indentation." + (buffer-substring (pos-bol) (point))))))) + +;; Avoid a byte-compilation warning that may confuse people reading +;; the result of the following test. +(declare-function compilation--message->loc nil "compile") + +(ert-deftest find-func-tests--locate-macro-generated-symbols () ;bug#45443 + (should (cdr (find-function-search-for-symbol + #'compilation--message->loc nil "compile"))) + (should (cdr (find-function-search-for-symbol + 'c-mode-hook 'defvar "cc-mode")))) + +(provide 'find-func-tests) +;;; find-func-tests.el ends here diff --git a/test/lisp/emacs-lisp/float-sup-tests.el b/test/lisp/emacs-lisp/float-sup-tests.el new file mode 100644 index 00000000000..f4353d9e855 --- /dev/null +++ b/test/lisp/emacs-lisp/float-sup-tests.el @@ -0,0 +1,33 @@ +;;; float-sup-tests.el --- Tests for float-sup.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) + +(ert-deftest float-sup-degrees-and-radians () + (should (equal (degrees-to-radians 180.0) float-pi)) + (should (equal (radians-to-degrees float-pi) 180.0)) + (should (equal (radians-to-degrees (degrees-to-radians 360.0)) 360.0)) + (should (equal (degrees-to-radians (radians-to-degrees float-pi)) float-pi))) + +(provide 'float-sup-tests) +;;; float-sup-tests.el ends here diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el index 4cc6c841dac..b7a21d49b2f 100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@ -1,6 +1,6 @@ ;;; generator-tests.el --- Testing generators -*- lexical-binding: t -*- -;; Copyright (C) 2015-2017 Free Software Foundation, Inc. +;; Copyright (C) 2015-2022 Free Software Foundation, Inc. ;; Author: Daniel Colascione <dancol@dancol.org> ;; Keywords: @@ -22,10 +22,16 @@ ;;; Commentary: +;; Unit tests for generator.el. + +;;; Code: + (require 'generator) (require 'ert) (require 'cl-lib) +;;; Code: + (defun generator-list-subrs () (cl-loop for x being the symbols when (and (fboundp x) @@ -38,8 +44,8 @@ `cps-testcase' defines an ERT testcase called NAME that evaluates BODY twice: once using ordinary `eval' and once using lambda-generators. The test ensures that the two forms produce -identical output. -" +identical output." + (declare (indent 1)) `(progn (ert-deftest ,name () (should @@ -57,8 +63,6 @@ identical output. (let ((cps-inhibit-atomic-optimization t)) (iter-lambda () (iter-yield (progn ,@body))))))))))) -(put 'cps-testcase 'lisp-indent-function 1) - (defvar *cps-test-i* nil) (defun cps-get-test-i () *cps-test-i*) @@ -70,7 +74,7 @@ identical output. (cps-testcase cps-prog1-b (prog1 1)) (cps-testcase cps-prog1-c (prog2 1 2 3)) (cps-testcase cps-quote (progn 'hello)) -(cps-testcase cps-function (progn #'hello)) +(cps-testcase cps-function (progn #'message)) (cps-testcase cps-and-fail (and 1 nil 2)) (cps-testcase cps-and-succeed (and 1 2 3)) @@ -81,9 +85,9 @@ identical output. (cps-testcase cps-or-empty (or)) (cps-testcase cps-let* (let* ((i 10)) i)) -(cps-testcase cps-let*-shadow-empty (let* ((i 10)) (let (i) i))) +(cps-testcase cps-let*-shadow-empty (let* ((i 10)) i (let ((i nil)) i))) (cps-testcase cps-let (let ((i 10)) i)) -(cps-testcase cps-let-shadow-empty (let ((i 10)) (let (i) i))) +(cps-testcase cps-let-shadow-empty (let ((i 10)) i (let ((i nil)) i))) (cps-testcase cps-let-novars (let nil 42)) (cps-testcase cps-let*-novars (let* nil 42)) @@ -91,7 +95,7 @@ identical output. (let ((a 5) (b 6)) (let ((a b) (b a)) (list a b)))) (cps-testcase cps-let*-parallel - (let* ((a 5) (b 6)) (let* ((a b) (b a)) (list a b)))) + (let* ((a 5) (b 6)) a (let* ((a b) (b a)) (list a b)))) (cps-testcase cps-while-dynamic (setq *cps-test-i* 0) @@ -215,7 +219,7 @@ identical output. (should (eql (iter-next it -1) 42)) (should (eql (iter-next it -1) -1)))) -(ert-deftest cps-loop () +(ert-deftest cps-loop-2 () (should (equal (cl-loop for x iter-by (mygenerator 42) collect x) @@ -267,7 +271,7 @@ identical output. (unwind-protect (progn (iter-yield 1) - (error "test") + (error "Test") (iter-yield 2)) (cl-incf nr-unwound)))))) (should (equal (iter-next iter) 1)) @@ -282,3 +286,35 @@ identical output. (ert-deftest cps-test-declarations-preserved () (should (equal (documentation 'generator-with-docstring) "Documentation!")) (should (equal (get 'generator-with-docstring 'lisp-indent-function) 5))) + +(ert-deftest cps-iter-lambda-with-dynamic-binding () + "`iter-lambda' with dynamic binding produces correct result (bug#25965)." + (should (= 1 + (iter-next + (funcall (iter-lambda () + (let* ((fill-column 10) ;;any special variable will do + (i 0) + (j (setq i (1+ i)))) + (iter-yield i)))))))) + +(ert-deftest iter-lambda-variable-shadowing () + "`iter-lambda' forms which have local variable shadowing (Bug#26073)." + (should (equal (iter-next + (funcall (iter-lambda () + (let ((it 1)) + (iter-yield (funcall + (lambda (it) (- it)) + (1+ it))))))) + -2))) + +(defun generator-tests-edebug ()) ; silence byte-compiler +(ert-deftest generator-tests-edebug () + "Check that Bug#40434 is fixed." + (with-temp-buffer + (prin1 '(iter-defun generator-tests-edebug () + (iter-yield 123)) + (current-buffer)) + (edebug-defun)) + (should (eql (iter-next (generator-tests-edebug)) 123))) + +;;; generator-tests.el ends here diff --git a/test/lisp/emacs-lisp/gv-tests.el b/test/lisp/emacs-lisp/gv-tests.el index 93f70827133..0757e3c7aa5 100644 --- a/test/lisp/emacs-lisp/gv-tests.el +++ b/test/lisp/emacs-lisp/gv-tests.el @@ -1,6 +1,6 @@ ;;; gv-tests.el --- tests for gv.el -*- lexical-binding: t; -*- -;; Copyright (C) 2017 Free Software Foundation, Inc. +;; Copyright (C) 2017-2022 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -19,23 +19,23 @@ ;;; Code: +(require 'edebug) (require 'ert) +(require 'ert-x) (eval-when-compile (require 'cl-lib)) (cl-defmacro gv-tests--in-temp-dir ((elvar elcvar) (&rest filebody) &rest body) (declare (indent 2)) - `(let ((default-directory (make-temp-file "gv-test" t))) - (unwind-protect - (let ((,elvar "gv-test-deffoo.el") - (,elcvar "gv-test-deffoo.elc")) - (with-temp-file ,elvar - (insert ";; -*- lexical-binding: t; -*-\n") - (dolist (form ',filebody) - (pp form (current-buffer)))) - ,@body) - (delete-directory default-directory t)))) + `(ert-with-temp-directory default-directory + (let ((,elvar "gv-test-deffoo.el") + (,elcvar "gv-test-deffoo.elc")) + (with-temp-file ,elvar + (insert ";; -*- lexical-binding: t; -*-\n") + (dolist (form ',filebody) + (pp form (current-buffer)))) + ,@body))) (ert-deftest gv-define-expander-in-file () (gv-tests--in-temp-dir (el elc) @@ -82,7 +82,10 @@ (with-temp-buffer (call-process (concat invocation-directory invocation-name) nil '(t t) nil - "-Q" "-batch" "--eval" (prin1-to-string `(byte-compile-file ,el)) + "-Q" "-batch" + "--eval" (prin1-to-string + `(let ((backtrace-on-error-noninteractive nil)) + (byte-compile-file ,el))) "-l" elc) (should (equal (buffer-string) "Symbol's function definition is void: \\(setf\\ gv-test-foo\\)\n"))))) @@ -132,10 +135,71 @@ "-Q" "-batch" "--eval" (prin1-to-string `(byte-compile-file ,el)) "-l" elc "--eval" - (prin1-to-string '(progn (setf (gv-test-foo gv-test-pair) 99) - (message "%d" (car gv-test-pair))))) - (should (equal (buffer-string) - "Symbol's function definition is void: \\(setf\\ gv-test-foo\\)\n"))))) + (prin1-to-string + '(let ((backtrace-on-error-noninteractive nil)) + (setf (gv-test-foo gv-test-pair) 99) + (message "%d" (car gv-test-pair))))) + (should (string-match + "\\`Symbol.s function definition is void: \\\\(setf\\\\ gv-test-foo\\\\)\n\\'" + (buffer-string)))))) + +(ert-deftest gv-setter-edebug () + "Check that a setter can be defined and edebugged together with +its getter (Bug#41853)." + (with-temp-buffer + (let ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop)) + (dolist (form '((defun gv-setter-edebug-help (b) b) + (defun gv-setter-edebug-get (a b) + (get a (gv-setter-edebug-help b))) + (gv-define-setter gv-setter-edebug-get (x a b) + `(setf (get ,a (gv-setter-edebug-help ,b)) ,x)) + (push 123 (gv-setter-edebug-get 'gv-setter-edebug + 'gv-setter-edebug-prop)))) + (print form (current-buffer))) + ;; Only check whether evaluation works in general. + (eval-buffer))) + (should (equal (get 'gv-setter-edebug 'gv-setter-edebug-prop) '(123)))) + +(ert-deftest gv-plist-get () + (require 'cl-lib) + + ;; Simple setf usage for plist-get. + (should (equal (let ((target '(:a "a" :b "b" :c "c"))) + (setf (plist-get target :b) "modify") + target) + '(:a "a" :b "modify" :c "c"))) + + ;; Other function (cl-rotatef) usage for plist-get. + (should (equal (let ((target '(:a "a" :b "b" :c "c"))) + (cl-rotatef (plist-get target :b) (plist-get target :c)) + target) + '(:a "a" :b "c" :c "b"))) + + ;; Add new key value pair at top of list if setf for missing key. + (should (equal (let ((target '(:a "a" :b "b" :c "c"))) + (setf (plist-get target :d) "modify") + target) + '(:d "modify" :a "a" :b "b" :c "c"))) + + ;; Rotate with missing value. + ;; The value corresponding to the missing key is assumed to be nil. + (should (equal (let ((target '(:a "a" :b "b" :c "c"))) + (cl-rotatef (plist-get target :b) (plist-get target :d)) + target) + '(:d "b" :a "a" :b nil :c "c"))) + + ;; Simple setf usage for plist-get. (symbol plist) + (should (equal (let ((target '(a "a" b "b" c "c"))) + (setf (plist-get target 'b) "modify") + target) + '(a "a" b "modify" c "c"))) + + ;; Other function (cl-rotatef) usage for plist-get. (symbol plist) + (should (equal (let ((target '(a "a" b "b" c "c"))) + (cl-rotatef (plist-get target 'b) (plist-get target 'c)) + target) + '(a "a" b "c" c "b")))) ;; `ert-deftest' messes up macroexpansion when the test file itself is ;; compiled (see Bug #24402). diff --git a/test/lisp/emacs-lisp/hierarchy-tests.el b/test/lisp/emacs-lisp/hierarchy-tests.el new file mode 100644 index 00000000000..41d3f2f3ccf --- /dev/null +++ b/test/lisp/emacs-lisp/hierarchy-tests.el @@ -0,0 +1,556 @@ +;;; hierarchy-tests.el --- Tests for hierarchy.el -*- lexical-binding:t -*- + +;; Copyright (C) 2017-2019 Damien Cassou + +;; Author: Damien Cassou <damien@cassou.me> +;; Maintainer: emacs-devel@gnu.org + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for hierarchy.el + +;;; Code: + +(require 'ert) +(require 'hierarchy) + +(defun hierarchy-animals () + "Create a sorted animal hierarchy." + (let ((parentfn (lambda (item) (cl-case item + (dove 'bird) + (pigeon 'bird) + (bird 'animal) + (dolphin 'animal) + (cow 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'dove parentfn) + (hierarchy-add-tree hierarchy 'pigeon parentfn) + (hierarchy-add-tree hierarchy 'dolphin parentfn) + (hierarchy-add-tree hierarchy 'cow parentfn) + (hierarchy-sort hierarchy) + hierarchy)) + +(ert-deftest hierarchy-add-one-root () + (let ((parentfn (lambda (_) nil)) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'animal parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))))) + +(ert-deftest hierarchy-add-one-item-with-parent () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))))) + +(ert-deftest hierarchy-add-one-item-with-parent-and-grand-parent () + (let ((parentfn (lambda (item) + (cl-case item + (dove 'bird) + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'dove parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove))))) + +(ert-deftest hierarchy-add-same-root-twice () + (let ((parentfn (lambda (_) nil)) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'animal parentfn) + (hierarchy-add-tree hierarchy 'animal parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))))) + +(ert-deftest hierarchy-add-same-child-twice () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn) + (hierarchy-add-tree hierarchy 'bird parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))))) + +(ert-deftest hierarchy-add-item-and-its-parent () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn) + (hierarchy-add-tree hierarchy 'animal parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))))) + +(ert-deftest hierarchy-add-item-and-its-child () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'animal parentfn) + (hierarchy-add-tree hierarchy 'bird parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))))) + +(ert-deftest hierarchy-add-two-items-sharing-parent () + (let ((parentfn (lambda (item) + (cl-case item + (dove 'bird) + (pigeon 'bird)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'dove parentfn) + (hierarchy-add-tree hierarchy 'pigeon parentfn) + (should (equal (hierarchy-roots hierarchy) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon))))) + +(ert-deftest hierarchy-add-two-hierarchies () + (let ((parentfn (lambda (item) + (cl-case item + (dove 'bird) + (circle 'shape)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'dove parentfn) + (hierarchy-add-tree hierarchy 'circle parentfn) + (should (equal (hierarchy-roots hierarchy) '(bird shape))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove))) + (should (equal (hierarchy-children hierarchy 'shape) '(circle))))) + +(ert-deftest hierarchy-add-with-childrenfn () + (let ((childrenfn (lambda (item) + (cl-case item + (animal '(bird)) + (bird '(dove pigeon))))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'animal nil childrenfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon))))) + +(ert-deftest hierarchy-add-with-parentfn-and-childrenfn () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal) + (animal 'life-form)))) + (childrenfn (lambda (item) + (cl-case item + (bird '(dove pigeon)) + (pigeon '(ashy-wood-pigeon))))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn childrenfn) + (should (equal (hierarchy-roots hierarchy) '(life-form))) + (should (equal (hierarchy-children hierarchy 'life-form) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon))) + (should (equal (hierarchy-children hierarchy 'pigeon) '(ashy-wood-pigeon))))) + +(ert-deftest hierarchy-add-twice-with-parentfn-and-childrenfn () + (let* ((parentfn (lambda (item) + (cl-case item + (dove 'bird) + (bird 'animal)))) + (childrenfn (lambda (item) + (cl-case item + (animal '(bird)) + (bird '(dove))))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn childrenfn) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove))))) + +(ert-deftest hierarchy-add-trees () + (let ((parentfn (lambda (item) + (cl-case item + (dove 'bird) + (pigeon 'bird) + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-trees hierarchy '(dove pigeon) parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon))))) + +(ert-deftest hierarchy-from-list () + (let ((hierarchy (hierarchy-from-list + '(animal (bird (dove) + (pigeon)) + (cow) + (dolphin))))) + (hierarchy-sort hierarchy (lambda (item1 item2) + (string< (car item1) + (car item2)))) + (should (equal (hierarchy-to-string hierarchy (lambda (item) (symbol-name (car item)))) + "animal\n bird\n dove\n pigeon\n cow\n dolphin\n")))) + +(ert-deftest hierarchy-from-list-with-duplicates () + (let ((hierarchy (hierarchy-from-list + '(a (b) (b)) + t))) + (hierarchy-sort hierarchy (lambda (item1 item2) + ;; sort by ID + (< (car item1) (car item2)))) + (should (equal (hierarchy-length hierarchy) 3)) + (should (equal (hierarchy-to-string + hierarchy + (lambda (item) + (format "%s(%s)" + (cadr item) + (car item)))) + "a(1)\n b(2)\n b(3)\n")))) + +(ert-deftest hierarchy-from-list-with-childrenfn () + (let ((hierarchy (hierarchy-from-list + "abc" + nil + (lambda (item) + (when (string= item "abc") + (split-string item "" t)))))) + (hierarchy-sort hierarchy (lambda (item1 item2) (string< item1 item2))) + (should (equal (hierarchy-length hierarchy) 4)) + (should (equal (hierarchy-to-string hierarchy) + "abc\n a\n b\n c\n")))) + +(ert-deftest hierarchy-add-relation-check-error-when-different-parent () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn) + (should-error + (hierarchy--add-relation hierarchy 'bird 'cow #'identity)))) + +(ert-deftest hierarchy-empty-p-return-non-nil-for-empty () + (should (hierarchy-empty-p (hierarchy-new)))) + +(ert-deftest hierarchy-empty-p-return-nil-for-non-empty () + (should-not (hierarchy-empty-p (hierarchy-animals)))) + +(ert-deftest hierarchy-length-of-empty-is-0 () + (should (equal (hierarchy-length (hierarchy-new)) 0))) + +(ert-deftest hierarchy-length-of-non-empty-counts-items () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal) + (dove 'bird) + (pigeon 'bird)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'dove parentfn) + (hierarchy-add-tree hierarchy 'pigeon parentfn) + (should (equal (hierarchy-length hierarchy) 4)))) + +(ert-deftest hierarchy-has-root () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal) + (dove 'bird) + (pigeon 'bird)))) + (hierarchy (hierarchy-new))) + (should-not (hierarchy-has-root hierarchy 'animal)) + (should-not (hierarchy-has-root hierarchy 'bird)) + (hierarchy-add-tree hierarchy 'dove parentfn) + (hierarchy-add-tree hierarchy 'pigeon parentfn) + (should (hierarchy-has-root hierarchy 'animal)) + (should-not (hierarchy-has-root hierarchy 'bird)))) + +(ert-deftest hierarchy-leafs () + (let ((animals (hierarchy-animals))) + (should (equal (hierarchy-leafs animals) + '(dove pigeon dolphin cow))))) + +(ert-deftest hierarchy-leafs-includes-lonely-roots () + (let ((parentfn (lambda (_) nil)) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'foo parentfn) + (should (equal (hierarchy-leafs hierarchy) + '(foo))))) + +(ert-deftest hierarchy-leafs-of-node () + (let ((animals (hierarchy-animals))) + (should (equal (hierarchy-leafs animals 'cow) '())) + (should (equal (hierarchy-leafs animals 'animal) '(dove pigeon dolphin cow))) + (should (equal (hierarchy-leafs animals 'bird) '(dove pigeon))) + (should (equal (hierarchy-leafs animals 'dove) '())))) + +(ert-deftest hierarchy-child-p () + (let ((animals (hierarchy-animals))) + (should (hierarchy-child-p animals 'dove 'bird)) + (should (hierarchy-child-p animals 'bird 'animal)) + (should (hierarchy-child-p animals 'cow 'animal)) + (should-not (hierarchy-child-p animals 'cow 'bird)) + (should-not (hierarchy-child-p animals 'bird 'cow)) + (should-not (hierarchy-child-p animals 'animal 'dove)) + (should-not (hierarchy-child-p animals 'animal 'bird)))) + +(ert-deftest hierarchy-descendant () + (let ((animals (hierarchy-animals))) + (should (hierarchy-descendant-p animals 'dove 'animal)) + (should (hierarchy-descendant-p animals 'dove 'bird)) + (should (hierarchy-descendant-p animals 'bird 'animal)) + (should (hierarchy-descendant-p animals 'cow 'animal)) + (should-not (hierarchy-descendant-p animals 'cow 'bird)) + (should-not (hierarchy-descendant-p animals 'bird 'cow)) + (should-not (hierarchy-descendant-p animals 'animal 'dove)) + (should-not (hierarchy-descendant-p animals 'animal 'bird)))) + +(ert-deftest hierarchy-descendant-if-not-same () + (let ((animals (hierarchy-animals))) + (should-not (hierarchy-descendant-p animals 'cow 'cow)) + (should-not (hierarchy-descendant-p animals 'dove 'dove)) + (should-not (hierarchy-descendant-p animals 'bird 'bird)) + (should-not (hierarchy-descendant-p animals 'animal 'animal)))) + +;; keywords supported: :test :key +(ert-deftest hierarchy--set-equal () + (should (hierarchy--set-equal '(1 2 3) '(1 2 3))) + (should (hierarchy--set-equal '(1 2 3) '(3 2 1))) + (should (hierarchy--set-equal '(3 2 1) '(1 2 3))) + (should-not (hierarchy--set-equal '(2 3) '(3 2 1))) + (should-not (hierarchy--set-equal '(1 2 3) '(2 3))) + (should-not (hierarchy--set-equal '("1" "2") '("2" "1") :test #'eq)) + (should (hierarchy--set-equal '("1" "2") '("2" "1") :test #'equal)) + (should-not (hierarchy--set-equal '(1 2) '(-1 -2))) + (should (hierarchy--set-equal '(1 2) '(-1 -2) :key #'abs)) + (should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)))) + (should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :key #'car)) + (should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :test #'equal)) + (should (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :key #'car :test #'equal))) + +(ert-deftest hierarchy-equal-returns-true-for-same-hierarchy () + (let ((animals (hierarchy-animals))) + (should (hierarchy-equal animals animals)) + (should (hierarchy-equal (hierarchy-animals) animals)))) + +(ert-deftest hierarchy-equal-returns-true-for-hierarchy-copies () + (let ((animals (hierarchy-animals))) + (should (hierarchy-equal animals (hierarchy-copy animals))))) + +(ert-deftest hierarchy-map-item-on-leaf () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map-item (lambda (item indent) (cons item indent)) + 'cow + animals))) + (should (equal result '((cow . 0)))))) + +(ert-deftest hierarchy-map-item-on-leaf-with-indent () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map-item (lambda (item indent) (cons item indent)) + 'cow + animals + 2))) + (should (equal result '((cow . 2)))))) + +(ert-deftest hierarchy-map-item-on-parent () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map-item (lambda (item indent) (cons item indent)) + 'bird + animals))) + (should (equal result '((bird . 0) (dove . 1) (pigeon . 1)))))) + +(ert-deftest hierarchy-map-item-on-grand-parent () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map-item (lambda (item indent) (cons item indent)) + 'animal + animals))) + (should (equal result '((animal . 0) (bird . 1) (dove . 2) (pigeon . 2) + (cow . 1) (dolphin . 1)))))) + +(ert-deftest hierarchy-map-conses () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map (lambda (item indent) + (cons item indent)) + animals))) + (should (equal result '((animal . 0) + (bird . 1) + (dove . 2) + (pigeon . 2) + (cow . 1) + (dolphin . 1)))))) + +(ert-deftest hierarchy-map-tree () + (let ((animals (hierarchy-animals))) + (should (equal (hierarchy-map-tree (lambda (item indent children) + (list item indent children)) + animals) + '(animal + 0 + ((bird 1 ((dove 2 nil) (pigeon 2 nil))) + (cow 1 nil) + (dolphin 1 nil))))))) + +(ert-deftest hierarchy-map-hierarchy-keeps-hierarchy () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map-hierarchy (lambda (item _) (identity item)) + animals))) + (should (hierarchy-equal animals result)))) + +(ert-deftest hierarchy-map-applies-function () + (let* ((animals (hierarchy-animals)) + (parentfn (lambda (item) + (cond + ((equal item "bird") "animal") + ((equal item "dove") "bird") + ((equal item "pigeon") "bird") + ((equal item "cow") "animal") + ((equal item "dolphin") "animal")))) + (expected (hierarchy-new))) + (hierarchy-add-tree expected "dove" parentfn) + (hierarchy-add-tree expected "pigeon" parentfn) + (hierarchy-add-tree expected "cow" parentfn) + (hierarchy-add-tree expected "dolphin" parentfn) + (should (hierarchy-equal + (hierarchy-map-hierarchy (lambda (item _) (symbol-name item)) animals) + expected)))) + +(ert-deftest hierarchy-extract-tree () + (let* ((animals (hierarchy-animals)) + (birds (hierarchy-extract-tree animals 'bird))) + (hierarchy-sort birds) + (should (equal (hierarchy-roots birds) '(animal))) + (should (equal (hierarchy-children birds 'animal) '(bird))) + (should (equal (hierarchy-children birds 'bird) '(dove pigeon))))) + +(ert-deftest hierarchy-extract-tree-nil-if-not-in-hierarchy () + (let* ((animals (hierarchy-animals))) + (should-not (hierarchy-extract-tree animals 'foobar)))) + +(ert-deftest hierarchy-items-of-empty-hierarchy-is-empty () + (should (seq-empty-p (hierarchy-items (hierarchy-new))))) + +(ert-deftest hierarchy-items-returns-sequence-of-same-length () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-items animals))) + (should (= (seq-length result) (hierarchy-length animals))))) + +(ert-deftest hierarchy-items-return-all-elements-of-hierarchy () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-items animals))) + (should (equal (seq-sort #'string< result) '(animal bird cow dolphin dove pigeon))))) + +(ert-deftest hierarchy-labelfn-indent-no-indent-if-0 () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (labelfn (hierarchy-labelfn-indent labelfn-base))) + (should (equal + (with-temp-buffer + (funcall labelfn "bar" 0) + (buffer-substring (point-min) (point-max))) + "foo")))) + +(ert-deftest hierarchy-labelfn-indent-three-times-if-3 () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (labelfn (hierarchy-labelfn-indent labelfn-base))) + (should (equal + (with-temp-buffer + (funcall labelfn "bar" 3) + (buffer-substring (point-min) (point-max))) + " foo")))) + +(ert-deftest hierarchy-labelfn-indent-default-indent-string () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (labelfn (hierarchy-labelfn-indent labelfn-base))) + (should (equal + (with-temp-buffer + (funcall labelfn "bar" 1) + (buffer-substring (point-min) (point-max))) + " foo")))) + +(ert-deftest hierarchy-labelfn-indent-custom-indent-string () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (labelfn (hierarchy-labelfn-indent labelfn-base "###")) + (content (with-temp-buffer + (funcall labelfn "bar" 1) + (buffer-substring (point-min) (point-max))))) + (should (equal content "###foo")))) + +(ert-deftest hierarchy-labelfn-button-propertize () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (actionfn #'identity) + (labelfn (hierarchy-labelfn-button labelfn-base actionfn)) + (properties (with-temp-buffer + (funcall labelfn "bar" 1) + (text-properties-at 1)))) + (should (equal (car properties) 'action)))) + +(ert-deftest hierarchy-labelfn-button-execute-labelfn () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (actionfn #'identity) + (labelfn (hierarchy-labelfn-button labelfn-base actionfn)) + (content (with-temp-buffer + (funcall labelfn "bar" 1) + (buffer-substring-no-properties (point-min) (point-max))))) + (should (equal content "foo")))) + +(ert-deftest hierarchy-labelfn-button-if-does-not-button-unless-condition () + (let ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (spy-count 0) + (condition (lambda (_item _indent) nil))) + (cl-letf (((symbol-function 'hierarchy-labelfn-button) (lambda (_labelfn _actionfn) (lambda (_item _indent) (cl-incf spy-count))))) + (funcall (hierarchy-labelfn-button-if labelfn-base condition #'identity) nil nil) + (should (equal spy-count 0))))) + +(ert-deftest hierarchy-labelfn-button-if-does-button-when-condition () + (let ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (spy-count 0) + (condition (lambda (_item _indent) t))) + (cl-letf (((symbol-function 'hierarchy-labelfn-button) (lambda (_labelfn _actionfn) (lambda (_item _indent) (cl-incf spy-count))))) + (funcall (hierarchy-labelfn-button-if labelfn-base condition #'identity) nil nil) + (should (equal spy-count 1))))) + +(ert-deftest hierarchy-labelfn-to-string () + (let ((labelfn (lambda (item _indent) (insert item)))) + (should (equal (hierarchy-labelfn-to-string labelfn "foo" 1) "foo")))) + +(ert-deftest hierarchy-print () + (let* ((animals (hierarchy-animals)) + (result (with-temp-buffer + (hierarchy-print animals) + (buffer-substring-no-properties (point-min) (point-max))))) + (should (equal result "animal\n bird\n dove\n pigeon\n cow\n dolphin\n")))) + +(ert-deftest hierarchy-to-string () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-to-string animals))) + (should (equal result "animal\n bird\n dove\n pigeon\n cow\n dolphin\n")))) + +(ert-deftest hierarchy-tabulated-display () + (let* ((animals (hierarchy-animals)) + (labelfn (lambda (item _indent) (insert (symbol-name item)))) + (contents (with-temp-buffer + (hierarchy-tabulated-display animals labelfn (current-buffer)) + (buffer-substring-no-properties (point-min) (point-max))))) + (should (equal contents "animal\nbird\ndove\npigeon\ncow\ndolphin\n")))) + +(ert-deftest hierarchy-sort-non-root-nodes () + (let* ((animals (hierarchy-animals))) + (should (equal (hierarchy-roots animals) '(animal))) + (should (equal (hierarchy-children animals 'animal) '(bird cow dolphin))) + (should (equal (hierarchy-children animals 'bird) '(dove pigeon))))) + +(ert-deftest hierarchy-sort-roots () + (let* ((organisms (hierarchy-new)) + (parentfn (lambda (item) + (cl-case item + (oak 'plant) + (bird 'animal))))) + (hierarchy-add-tree organisms 'oak parentfn) + (hierarchy-add-tree organisms 'bird parentfn) + (hierarchy-sort organisms) + (should (equal (hierarchy-roots organisms) '(animal plant))))) + +(provide 'hierarchy-tests) +;;; hierarchy-tests.el ends here diff --git a/test/lisp/emacs-lisp/icons-tests.el b/test/lisp/emacs-lisp/icons-tests.el new file mode 100644 index 00000000000..e6e71a8e4fd --- /dev/null +++ b/test/lisp/emacs-lisp/icons-tests.el @@ -0,0 +1,63 @@ +;;; icons-tests.el --- Tests for icons.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'icons) +(require 'ert) +(require 'ert-x) +(require 'cus-edit) + +(define-icon icon-test1 nil + '((symbol ">") + (text "great")) + "Test icon" + :version "29.1") + +(define-icon icon-test2 icon-test1 + '((text "child")) + "Test icon" + :version "29.1") + +(deftheme test-icons-theme "") + +(ert-deftest test-icon-theme () + (let ((icon-preference '(image emoji symbol text))) + (should (equal (icon-string 'icon-test1) ">"))) + (let ((icon-preference '(text))) + (should (equal (icon-string 'icon-test1) "great"))) + (custom-theme-set-icons + 'test-icons-theme + '(icon-test1 ((symbol "<") (text "less")))) + (let ((icon-preference '(image emoji symbol text))) + (should (equal (icon-string 'icon-test1) ">")) + (enable-theme 'test-icons-theme) + (should (equal (icon-string 'icon-test1) "<")))) + +(ert-deftest test-icon-inheretance () + (let ((icon-preference '(image emoji symbol text))) + (should (equal (icon-string 'icon-test2) ">"))) + (let ((icon-preference '(text))) + (should (equal (icon-string 'icon-test2) "child")))) + +;;; icons-tests.el ends here diff --git a/test/lisp/emacs-lisp/let-alist-tests.el b/test/lisp/emacs-lisp/let-alist-tests.el index edcfe8a5291..c4e4feaad30 100644 --- a/test/lisp/emacs-lisp/let-alist-tests.el +++ b/test/lisp/emacs-lisp/let-alist-tests.el @@ -1,6 +1,6 @@ ;;; let-alist.el --- tests for file handling. -*- lexical-binding: t; -*- -;; Copyright (C) 2012-2017 Free Software Foundation, Inc. +;; Copyright (C) 2012-2022 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -82,7 +82,7 @@ (ert-deftest let-alist-list-to-sexp () "Check that multiple dots are handled correctly." - (should (= 1 (eval (let-alist--list-to-sexp '(a b c d) ''((d (c (b (a . 1))))))))) + (should (= 1 (eval (let-alist--list-to-sexp '(a b c d) ''((d (c (b (a . 1)))))) t))) (should (equal (let-alist--access-sexp '.foo.bar.baz 'var) '(cdr (assq 'baz (cdr (assq 'bar (cdr (assq 'foo var)))))))) (should (equal (let-alist--access-sexp '..foo.bar.baz 'var) '.foo.bar.baz))) @@ -95,4 +95,9 @@ See Bug#24641." (should (equal (let-alist--deep-dot-search '(foo .bar (let-alist .qux .baz))) '((.bar . bar) (.qux . qux))))) ; no .baz -;;; let-alist.el ends here +(ert-deftest let-alist--vectors () + (should (equal (let-alist '((a . 1) (b . 2)) + `[,(+ .a) ,(+ .a .b .b)]) + [1 5]))) + +;;; let-alist-tests.el ends here diff --git a/test/lisp/emacs-lisp/lisp-mnt-tests.el b/test/lisp/emacs-lisp/lisp-mnt-tests.el new file mode 100644 index 00000000000..200be7354a0 --- /dev/null +++ b/test/lisp/emacs-lisp/lisp-mnt-tests.el @@ -0,0 +1,44 @@ +;;; lisp-mnt-tests.el --- Tests for lisp-mnt -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'lisp-mnt) + +(ert-deftest lm--tests-crack-address () + (should (equal (lm-crack-address + "Bob Weiner <rsw@gnu.org>, Mats Lidell <matsl@gnu.org>") + '(("Bob Weiner" . "rsw@gnu.org") + ("Mats Lidell" . "matsl@gnu.org"))))) + +(ert-deftest lm--tests-lm-website () + (with-temp-buffer + (insert ";; URL: https://example.org/foo") + (should (string= (lm-website) "https://example.org/foo"))) + (with-temp-buffer + (insert ";; X-URL: <https://example.org/foo>") + (should (string= (lm-website) "https://example.org/foo")))) + +(provide 'lisp-mnt-tests) +;;; lisp-mnt-tests.el ends here diff --git a/test/lisp/emacs-lisp/lisp-mode-tests.el b/test/lisp/emacs-lisp/lisp-mode-tests.el index 6bc916f6c35..996ea201fb0 100644 --- a/test/lisp/emacs-lisp/lisp-mode-tests.el +++ b/test/lisp/emacs-lisp/lisp-mode-tests.el @@ -1,6 +1,8 @@ ;;; lisp-mode-tests.el --- Test Lisp editing commands -*- lexical-binding: t; -*- -;; Copyright (C) 2017 Free Software Foundation, Inc. +;; Copyright (C) 2017-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. ;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -20,6 +22,10 @@ (require 'ert) (require 'cl-lib) (require 'lisp-mode) +(require 'faceup) + + +;;; Indentation (defconst lisp-mode-tests--correctly-indented-sexp "\ \(a @@ -113,6 +119,57 @@ noindent\" 3 ;; we're indenting ends on the previous line. (should (equal (buffer-string) original))))) +(ert-deftest indent-sexp-go () + "Make sure `indent-sexp' doesn't stop after #s." + ;; See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=31984. + (with-temp-buffer + (emacs-lisp-mode) + (insert "#s(foo\nbar)\n") + (goto-char (point-min)) + (indent-sexp) + (should (equal (buffer-string) "\ +#s(foo + bar)\n")))) + +(ert-deftest indent-sexp-cant-go () + "`indent-sexp' shouldn't error before a sexp." + ;; See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=31984#32. + (with-temp-buffer + (emacs-lisp-mode) + (insert "(())") + (goto-char (1+ (point-min))) + ;; Paredit calls `indent-sexp' from this position. + (indent-sexp) + (should (equal (buffer-string) "(())")))) + +(ert-deftest indent-sexp-stop-before-eol-comment () + "`indent-sexp' shouldn't look for more sexps after an eol comment." + ;; See https://debbugs.gnu.org/35286. + (with-temp-buffer + (emacs-lisp-mode) + (let ((str "() ;;\n x")) + (insert str) + (goto-char (point-min)) + (indent-sexp) + ;; The "x" is in the next sexp, so it shouldn't get indented. + (should (equal (buffer-string) str))))) + +(ert-deftest indent-sexp-stop-before-eol-non-lisp () + "`indent-sexp' shouldn't be too aggressive in non-Lisp modes." + ;; See https://debbugs.gnu.org/35286#13. + (with-temp-buffer + (prolog-mode) + (let ((str "\ +x(H) --> + {y(H)}. +a(A) --> + b(A).")) + (insert str) + (search-backward "{") + (indent-sexp) + ;; There's no line-spanning sexp, so nothing should be indented. + (should (equal (buffer-string) str))))) + (ert-deftest lisp-indent-region () "Test basics of `lisp-indent-region'." (with-temp-buffer @@ -224,6 +281,79 @@ Expected initialization file: `%s'\" (comment-indent) (should (equal (buffer-string) correct))))) +(ert-deftest lisp-indent-with-read-only-field () + "Test indentation on line with read-only field (Bug#32014)." + (with-temp-buffer + (insert (propertize "prompt> " 'field 'output 'read-only t + 'rear-nonsticky t 'front-sticky '(read-only))) + (insert " foo") + (lisp-indent-line) + (should (equal (buffer-string) "prompt> foo")))) + +(ert-deftest lisp-indent-unfinished-string () + "Don't infloop on unfinished string (Bug#37045)." + (with-temp-buffer + (insert "\"\n") + (lisp-indent-region (point-min) (point-max)))) + +(ert-deftest lisp-indent-defun () + (with-temp-buffer + (lisp-mode) + (let ((orig "(defun x () + (print (quote ( thingy great + stuff))) + (print (quote (thingy great + stuff))))")) + (insert orig) + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) orig))))) + + +;;; Fontification + +(ert-deftest lisp-fontify-confusables () + "Unescaped 'smart quotes' should be fontified in `font-lock-warning-face'." + (with-temp-buffer + (dolist (ch + '(#x2018 ;; LEFT SINGLE QUOTATION MARK + #x2019 ;; RIGHT SINGLE QUOTATION MARK + #x201B ;; SINGLE HIGH-REVERSED-9 QUOTATION MARK + #x201C ;; LEFT DOUBLE QUOTATION MARK + #x201D ;; RIGHT DOUBLE QUOTATION MARK + #x201F ;; DOUBLE HIGH-REVERSED-9 QUOTATION MARK + #x301E ;; DOUBLE PRIME QUOTATION MARK + #xFF02 ;; FULLWIDTH QUOTATION MARK + #xFF07 ;; FULLWIDTH APOSTROPHE + )) + (insert (format "«w:%c»foo \\%cfoo\n" ch ch))) + (let ((faceup (buffer-string))) + (faceup-clean-buffer) + (should (faceup-test-font-lock-buffer 'emacs-lisp-mode faceup))))) + +(ert-deftest test-lisp-current-defun-name () + (require 'edebug) + (with-temp-buffer + (emacs-lisp-mode) + (insert "(defun foo ()\n'bar)\n") + (goto-char 5) + (should (equal (lisp-current-defun-name) "foo"))) + (with-temp-buffer + (emacs-lisp-mode) + (insert "(define-flabbergast-test zot ()\n'bar)\n") + (goto-char 5) + (should (equal (lisp-current-defun-name) "zot"))) + ;; These tests should probably work after bug#49592 has been fixed. + ;; (with-temp-buffer + ;; (emacs-lisp-mode) + ;; (insert "(progn\n ;; comment\n ;; about that\n (define-key ...)\n )") + ;; (goto-char 5) + ;; (should (equal (lisp-current-defun-name) "progn"))) + ;; (with-temp-buffer + ;; (emacs-lisp-mode) + ;; (insert "(defblarg \"a\" 'b)") + ;; (goto-char 5) + ;; (should (equal (lisp-current-defun-name) "defblarg"))) + ) (provide 'lisp-mode-tests) ;;; lisp-mode-tests.el ends here diff --git a/test/lisp/emacs-lisp/lisp-tests.el b/test/lisp/emacs-lisp/lisp-tests.el index ae1302bdce4..901447ecd27 100644 --- a/test/lisp/emacs-lisp/lisp-tests.el +++ b/test/lisp/emacs-lisp/lisp-tests.el @@ -1,6 +1,6 @@ ;;; lisp-tests.el --- Test Lisp editing commands -*- lexical-binding: t; -*- -;; Copyright (C) 2013-2017 Free Software Foundation, Inc. +;; Copyright (C) 2013-2022 Free Software Foundation, Inc. ;; Author: Aaron S. Hawley <aaron.s.hawley@gmail.com> ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> @@ -8,6 +8,8 @@ ;; Author: Marcin Borkowski <mbork@mbork.pl> ;; Keywords: 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 @@ -136,8 +138,7 @@ (text-mode) (insert "\"foo\"") (goto-char (point-min)) - (delete-pair) - (should (string-equal "fo\"" (buffer-string))))) + (should-error (delete-pair)))) (ert-deftest lisp-delete-pair-quotes-text-mode-syntax-table () "Test \\[delete-pair] with modified Text Mode syntax for #15014." @@ -212,6 +213,7 @@ (should-error (forward-sexp)))) ;; FIXME: Shouldn't be an error. ;; Test some core Elisp rules. +(defvar c-e-x) (ert-deftest core-elisp-tests-1-defvar-in-let () "Test some core Elisp rules." (with-temp-buffer @@ -234,7 +236,7 @@ (should (or (not mark-active) (mark))))) (ert-deftest core-elisp-tests-3-backquote () - (should (eq 3 (eval ``,,'(+ 1 2))))) + (should (eq 3 (eval ``,,'(+ 1 2) t)))) ;; Test up-list and backward-up-list. (defun lisp-run-up-list-test (fn data start instructions) @@ -296,7 +298,7 @@ (lambda () (up-list 1 t t)) (or "(1 '2 ( 2' 1 '2 ) 2' 1)") ;; abcdefghijklmnopqrstuvwxy - i k x scan-error) + i k x user-error) (define-lisp-up-list-test backward-up-list-basic (lambda () (backward-up-list)) @@ -323,7 +325,7 @@ start." (declare (indent 1) (debug (def-form body))) (let* ((var-pos nil) (text (with-temp-buffer - (insert (eval contents)) + (insert (eval contents t)) (goto-char (point-min)) (while (re-search-forward elisp-test-point-position-regex nil t) (push (list (intern (match-string-no-properties 1)) @@ -367,6 +369,61 @@ start." " "Test buffer for `mark-defun'.")) +;;; end-of-defun + +(ert-deftest end-of-defun-twice () + "Test behavior of prefix arg for `end-of-defun' (Bug#24427). +Calling `end-of-defun' twice should be the same as a prefix arg +of two." + (setq last-command nil) + (cl-flet ((eod2 (lambda () + (goto-char (point-min)) + (end-of-defun) + (end-of-defun) + (let ((pt-eod2 (point))) + (goto-char (point-min)) + (end-of-defun 2) + (should (= (point) pt-eod2)))))) + (with-temp-buffer + (insert "\ +\(defun a ()) + +\(defun b ()) + +\(defun c ())") + (eod2)) + (with-temp-buffer + (insert "\ +\(defun a ()) +\(defun b ()) +\(defun c ())") + (eod2))) + (elisp-tests-with-temp-buffer ";; Comment header + +\(defun func-1 (arg) + \"docstring\" + body) +=!p1= +;; Comment before a defun +\(defun func-2 (arg) + \"docstring\" + body) + +\(defun func-3 (arg) + \"docstring\" + body) +=!p2=(defun func-4 (arg) + \"docstring\" + body) + +;; end +" + (goto-char p1) + (end-of-defun 2) + (should (= (point) p2)))) + +;;; mark-defun + (ert-deftest mark-defun-no-arg-region-inactive () "Test `mark-defun' with no prefix argument and inactive region." @@ -589,5 +646,36 @@ region." (should (= (point) before)) (should (= (mark) after)))) +(ert-deftest lisp-fill-paragraph-colon () + "Keywords below Emacs Lisp docstrings should not be filled (Bug#24622). +Keywords inside docstrings should be filled (Bug#7751)." + (elisp-tests-with-temp-buffer + " +\(defcustom custom value + \"First\n +Second\n +=!inside=Third line\" + =!keywords=:type 'sexp + :version \"26.1\" + :group 'lisp-tests)" + (goto-char inside) + (fill-paragraph) + (goto-char keywords) + (beginning-of-line) + (should (looking-at " :type 'sexp\n :version \"26.1\"\n :"))) + (elisp-tests-with-temp-buffer + " +\(defun foo () + \"Summary. +=!inside=Testing keywords: :one :two :three\" + (body))" ; FIXME: Remove parens around body to test Bug#28937 once it's fixed + (goto-char inside) + (let ((emacs-lisp-docstring-fill-column 30)) + (fill-paragraph)) + (forward-line) + (should (looking-at ":three")) + (end-of-line) + (should-not (eq (preceding-char) ?\))))) + (provide 'lisp-tests) ;;; lisp-tests.el ends here diff --git a/test/lisp/emacs-lisp/macroexp-resources/m1.el b/test/lisp/emacs-lisp/macroexp-resources/m1.el new file mode 100644 index 00000000000..88c51e75261 --- /dev/null +++ b/test/lisp/emacs-lisp/macroexp-resources/m1.el @@ -0,0 +1,36 @@ +;;; m1.el --- Some sample code for macroexp-tests -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(defconst macroexp--m1-tests-filename (macroexp-file-name)) + +(eval-when-compile + (defconst macroexp--m1-tests-comp-filename (macroexp-file-name))) + +(defun macroexp--m1-tests-file-name () + (macroexp--test-get-file-name)) + +(provide 'm1) +;;; m1.el ends here diff --git a/test/lisp/emacs-lisp/macroexp-resources/m2.el b/test/lisp/emacs-lisp/macroexp-resources/m2.el new file mode 100644 index 00000000000..cebe4cac125 --- /dev/null +++ b/test/lisp/emacs-lisp/macroexp-resources/m2.el @@ -0,0 +1,33 @@ +;;; m2.el --- More sample code for macroexp-tests -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(defconst macroexp--m2-tests-filename (macroexp-file-name)) + +(byte-compile-file (expand-file-name + "m1.el" (file-name-directory macroexp--m2-tests-filename))) + +(provide 'm2) +;;; m2.el ends here diff --git a/test/lisp/emacs-lisp/macroexp-resources/vk.el b/test/lisp/emacs-lisp/macroexp-resources/vk.el new file mode 100644 index 00000000000..d9ca33671ef --- /dev/null +++ b/test/lisp/emacs-lisp/macroexp-resources/vk.el @@ -0,0 +1,130 @@ +;;; vk.el --- test code for macroexp-tests -*- lexical-binding: t -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'macroexp) + +(defmacro vk-variable-kind (var) + (if (macroexp--dynamic-variable-p var) ''dyn ''lex)) + +(defvar vk-a 1) +(defconst vk-b 2) +(defvar vk-c) + +(defun vk-f1 (x) + (defvar vk-u1) + (let ((vk-a 10) + (vk-b 20) + (vk-c 30) + (vk-u1 40) + (y 50)) + (ignore vk-a vk-b vk-c vk-u1 x y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-c) ; dyn + (vk-variable-kind vk-u1) ; dyn + (vk-variable-kind x) ; lex + (vk-variable-kind y)))) ; lex + +(eval-and-compile + (defvar vk-u2) + (defun vk-f2 (x) + (defvar vk-v2) + (let ((vk-u2 11) + (vk-v2 12) + (y 13)) + (ignore vk-u2 vk-v2 x y) + (list + (vk-variable-kind vk-u2) ; dyn + (vk-variable-kind vk-v2) ; dyn + (vk-variable-kind x) ; lex + (vk-variable-kind y))))) ; lex + +(eval-when-compile + (defvar vk-u3) + (defun vk-f3 (x) + (defvar vk-v3) + (let ((vk-a 23) + (vk-b 24) + (vk-u3 25) + (vk-v3 26) + (y 27)) + (ignore vk-a vk-b vk-u3 vk-v3 x y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-u3) ; dyn + (vk-variable-kind vk-v3) ; dyn + (vk-variable-kind x) ; lex + (vk-variable-kind y))))) ; lex + +(defconst vk-val3 (eval-when-compile (vk-f3 0))) + +(defconst vk-f4 '(lambda (x) + (defvar vk-v4) + (let ((vk-v4 31) + (y 32)) + (ignore vk-v4 x y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-v4) ; dyn + (vk-variable-kind x) ; dyn + (vk-variable-kind y))))) ; dyn + +(defconst vk-f5 '(closure (t) (x) + (defvar vk-v5) + (let ((vk-v5 41) + (y 42)) + (ignore vk-v5 x y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-v5) ; dyn + (vk-variable-kind x) ; lex + (vk-variable-kind y))))) ; lex + +(defun vk-f6 () + (eval '(progn + (defvar vk-v6) + (let ((vk-v6 51) + (y 52)) + (ignore vk-v6 y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-v6) ; dyn + (vk-variable-kind vk-y)))))) ; dyn + +(defun vk-f7 () + (eval '(progn + (defvar vk-v7) + (let ((vk-v7 51) + (y 52)) + (ignore vk-v7 y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-v7) ; dyn + (vk-variable-kind vk-y)))) ; lex + t)) + +(provide 'vk) diff --git a/test/lisp/emacs-lisp/macroexp-tests.el b/test/lisp/emacs-lisp/macroexp-tests.el new file mode 100644 index 00000000000..4e6bd8b8fcd --- /dev/null +++ b/test/lisp/emacs-lisp/macroexp-tests.el @@ -0,0 +1,127 @@ +;;; macroexp-tests.el --- Tests for macroexp.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'macroexp) +(require 'ert-x) + +(ert-deftest macroexp--tests-fgrep () + (should (equal (macroexp--fgrep '((x) (y)) '([x] z ((u)))) + '((x)))) + (should (equal (macroexp--fgrep '((x) (y)) '#2=([y] ((y #2#)))) + '((y)))) + (should (equal (macroexp--fgrep '((x) (y)) '#2=([r] ((a x)) a b c d . #2#)) + '((x))))) + +(defconst macroexp--tests-filename (macroexp-file-name)) + +(defmacro macroexp--test-get-file-name () (macroexp-file-name)) + +(ert-deftest macroexp--tests-file-name () + (should (string-match + "\\`macroexp-tests.elc?\\'" + (file-name-nondirectory macroexp--tests-filename))) + (let ((rsrc-dir (expand-file-name + "macroexp-resources" + (file-name-directory macroexp--tests-filename)))) + (with-current-buffer + (find-file-noselect (expand-file-name "m1.el" rsrc-dir)) + (defvar macroexp--m1-tests-filename) + (declare-function macroexp--m1-tests-file-name "m1" ()) + ;; `macroexp-file-name' should work with `eval-buffer'. + (eval-buffer) + (should (equal "m1.el" + (file-name-nondirectory macroexp--m1-tests-filename))) + (should (equal "m1.el" + (file-name-nondirectory (macroexp--m1-tests-file-name)))) + (search-forward "macroexp--m1-tests-filename") + (makunbound 'macroexp--m1-tests-filename) + ;; `macroexp-file-name' should also work with `eval-defun'. + (eval-defun nil) + (should (equal "m1.el" + (file-name-nondirectory macroexp--m1-tests-filename)))) + + ;; Test the case where we load a file which byte-compiles another. + (defvar macroexp--m1-tests-comp-filename) + (makunbound 'macroexp--m1-tests-comp-filename) + (load (expand-file-name "m2.el" rsrc-dir)) + (should (equal "m1.el" + (file-name-nondirectory macroexp--m1-tests-comp-filename))))) + +(defun macroexp-tests--run-emacs (&rest args) + "Run Emacs in batch mode with ARGS, return output." + (let ((emacs (expand-file-name invocation-name invocation-directory))) + (with-temp-buffer + (let ((res (apply #'call-process emacs nil t nil + "-Q" "--batch" args)) + (output (buffer-string))) + (unless (equal res 0) + (message "%s" output) + (error "Inferior Emacs exited with status %S" res)) + output)))) + +(defun macroexp-tests--eval-in-subprocess (file expr) + (let ((output (macroexp-tests--run-emacs + "-l" file (format "--eval=(print %S)" expr)))) + (car (read-from-string output)))) + +(defun macroexp-tests--byte-compile-in-subprocess (file) + "Byte-compile FILE using a subprocess to avoid contaminating the lisp state." + (let ((output (macroexp-tests--run-emacs "-f" "batch-byte-compile" file))) + (when output + (message "%s" output)))) + +(ert-deftest macroexp--tests-dynamic-variable-p () + "Test `macroexp--dynamic-variable-p'." + (let* ((vk-el (ert-resource-file "vk.el")) + (vk-elc (concat vk-el "c")) + (expr '(list (vk-f1 0) + (vk-f2 0) + vk-val3 + (funcall vk-f4 0) + (funcall vk-f5 0) + (vk-f6) + (vk-f7)))) + ;; We compile and run the test in separate processes for complete + ;; isolation between test cases. + (should (equal (macroexp-tests--eval-in-subprocess vk-el expr) + '((dyn dyn dyn dyn lex lex) + (dyn dyn lex lex) + (dyn dyn dyn dyn lex lex) + (dyn dyn dyn dyn dyn) + (dyn dyn dyn lex lex) + (dyn dyn dyn dyn) + (dyn dyn dyn lex)))) + (macroexp-tests--byte-compile-in-subprocess vk-el) + (should (equal (macroexp-tests--eval-in-subprocess vk-elc expr) + '((dyn dyn dyn dyn lex lex) + (dyn dyn lex lex) + (dyn dyn dyn dyn lex lex) + (dyn dyn dyn dyn dyn) + (dyn dyn dyn lex lex) + (dyn dyn dyn dyn) + (dyn dyn dyn lex)))))) + +;;; macroexp-tests.el ends here diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el index 0a888d88b72..314a1c9e302 100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@ -1,6 +1,6 @@ ;;; map-tests.el --- Tests for map.el -*- lexical-binding:t -*- -;; Copyright (C) 2015-2017 Free Software Foundation, Inc. +;; Copyright (C) 2015-2022 Free Software Foundation, Inc. ;; Author: Nicolas Petton <nicolas@petton.fr> ;; Maintainer: emacs-devel@gnu.org @@ -22,7 +22,7 @@ ;;; Commentary: -;; Tests for map.el +;; Tests for map.el. ;;; Code: @@ -30,101 +30,196 @@ (require 'map) (defmacro with-maps-do (var &rest body) - "Successively bind VAR to an alist, vector and hash-table. + "Successively bind VAR to an alist, plist, vector, and hash-table. Each map is built from the following alist data: -'((0 . 3) (1 . 4) (2 . 5)). -Evaluate BODY for each created map. - -\(fn (var map) body)" - (declare (indent 1) (debug t)) + \\='((0 . 3) (1 . 4) (2 . 5)). +Evaluate BODY for each created map." + (declare (indent 1) (debug (symbolp body))) (let ((alist (make-symbol "alist")) + (plist (make-symbol "plist")) (vec (make-symbol "vec")) (ht (make-symbol "ht"))) `(let ((,alist (list (cons 0 3) (cons 1 4) (cons 2 5))) + (,plist (list 0 3 1 4 2 5)) (,vec (vector 3 4 5)) (,ht (make-hash-table))) (puthash 0 3 ,ht) (puthash 1 4 ,ht) (puthash 2 5 ,ht) - (dolist (,var (list ,alist ,vec ,ht)) + (dolist (,var (list ,alist ,plist ,vec ,ht)) ,@body)))) +(defmacro with-empty-maps-do (var &rest body) + "Like `with-maps-do', but with empty maps." + (declare (indent 1) (debug (symbolp body))) + `(dolist (,var (list (list) (vector) (make-hash-table))) + ,@body)) + +(ert-deftest test-map-plist-p () + "Test `map--plist-p'." + (with-empty-maps-do map + (should-not (map--plist-p map))) + (should-not (map--plist-p "")) + (should-not (map--plist-p '((())))) + (should (map--plist-p '(:a))) + (should (map--plist-p '(a))) + (should (map--plist-p '(nil))) + (should (map--plist-p '("")))) + (ert-deftest test-map-elt () (with-maps-do map (should (= 3 (map-elt map 0))) (should (= 4 (map-elt map 1))) (should (= 5 (map-elt map 2))) - (should (null (map-elt map -1))) - (should (null (map-elt map 4))))) + (should-not (map-elt map -1)) + (should-not (map-elt map 4)) + (should-not (map-elt map 0.1)))) (ert-deftest test-map-elt-default () (with-maps-do map - (should (= 5 (map-elt map 7 5))))) + (should (= 5 (map-elt map 7 5))) + (should (= 5 (map-elt map 0.1 5)))) + (with-empty-maps-do map + (should (= 5 (map-elt map 0 5))))) (ert-deftest test-map-elt-testfn () - (let ((map (list (cons "a" 1) (cons "b" 2))) - ;; Make sure to use a non-eq "a", even when compiled. - (noneq-key (string ?a))) - (should-not (map-elt map noneq-key)) - (should (map-elt map noneq-key nil 'equal)))) + (let* ((a (string ?a)) + (map `((,a . 0) (,(string ?b) . 1)))) + (should (= (map-elt map a) 0)) + (should (= (map-elt map "a") 0)) + (should (= (map-elt map (string ?a)) 0)) + (should (= (map-elt map "b") 1)) + (should (= (map-elt map (string ?b)) 1)))) (ert-deftest test-map-elt-with-nil-value () - (should (null (map-elt '((a . 1) - (b)) - 'b - '2)))) + (should-not (map-elt '((a . 1) (b)) 'b 2))) -(ert-deftest test-map-put () +(ert-deftest test-map-put! () (with-maps-do map (setf (map-elt map 2) 'hello) (should (eq (map-elt map 2) 'hello))) (with-maps-do map - (map-put map 2 'hello) + (with-suppressed-warnings ((obsolete map-put)) + (map-put map 2 'hello)) (should (eq (map-elt map 2) 'hello))) - (let ((ht (make-hash-table))) - (setf (map-elt ht 2) 'a) - (should (eq (map-elt ht 2) - 'a))) - (let ((alist '((0 . a) (1 . b) (2 . c)))) - (setf (map-elt alist 2) 'a) - (should (eq (map-elt alist 2) - 'a))) - (let ((vec [3 4 5])) - (should-error (setf (map-elt vec 3) 6)))) + (with-maps-do map + (map-put! map 2 'hello) + (should (eq (map-elt map 2) 'hello)) + (if (not (or (hash-table-p map) + (map--plist-p map))) + (should-error (map-put! map 5 'value) + ;; For vectors, it could arguably signal + ;; map-not-inplace as well, but it currently doesn't. + :type (if (listp map) + 'map-not-inplace + 'error)) + (map-put! map 5 'value) + (should (eq (map-elt map 5) 'value))))) + +(ert-deftest test-map-put!-new-keys () + "Test `map-put!' with new keys." + (with-maps-do map + (let ((size (map-length map))) + (if (arrayp map) + (progn + (should-error (setf (map-elt map 'k) 'v)) + (should-error (setf (map-elt map size) 'v))) + (setf (map-elt map 'k) 'v) + (should (eq (map-elt map 'k) 'v)) + (setf (map-elt map size) 'v) + (should (eq (map-elt map size) 'v)))))) + +(ert-deftest test-map-put!-alist () + "Test `map-put!' test function on alists." + (let ((key (string ?a)) + (val 0) + map) + (should-error (map-put! map key val) :type 'map-not-inplace) + (setq map (list (cons key val))) + (map-put! map key (1- val)) + (should (equal map '(("a" . -1)))) + (map-put! map (string ?a) (1+ val)) + (should (equal map '(("a" . 1)))) + (should-error (map-put! map (string ?a) val #'eq) :type 'map-not-inplace))) (ert-deftest test-map-put-alist-new-key () "Regression test for Bug#23105." - (let ((alist '((0 . a)))) - (map-put alist 2 'b) - (should (eq (map-elt alist 2) - 'b)))) + (let ((alist (list (cons 0 'a)))) + (with-suppressed-warnings ((obsolete map-put)) + (map-put alist 2 'b)) + (should (eq (map-elt alist 2) 'b)))) (ert-deftest test-map-put-testfn-alist () (let ((alist (list (cons "a" 1) (cons "b" 2))) ;; Make sure to use a non-eq "a", even when compiled. (noneq-key (string ?a))) - (map-put alist noneq-key 3 'equal) - (should-not (cddr alist)) - (map-put alist noneq-key 9) - (should (cddr alist)))) + (with-suppressed-warnings ((obsolete map-put)) + (map-put alist noneq-key 3 #'equal) + (should-not (cddr alist)) + (map-put alist noneq-key 9 #'eql) + (should (cddr alist))))) (ert-deftest test-map-put-return-value () (let ((ht (make-hash-table))) - (should (eq (map-put ht 'a 'hello) 'hello)))) + (with-suppressed-warnings ((obsolete map-put)) + (should (eq (map-put ht 'a 'hello) 'hello))))) + +(ert-deftest test-map-insert-empty () + "Test `map-insert' on empty maps." + (with-empty-maps-do map + (if (arrayp map) + (should-error (map-insert map 0 6)) + (let ((new (map-insert map 0 6))) + (should-not (eq map new)) + (should-not (map-pairs map)) + (should (= (map-elt new 0) 6)))))) + +(ert-deftest test-map-insert () + "Test `map-insert'." + (with-maps-do map + (let ((pairs (map-pairs map)) + (size (map-length map)) + (new (map-insert map 0 6))) + (should-not (eq map new)) + (should (equal (map-pairs map) pairs)) + (should (= (map-elt new 0) 6)) + (if (arrayp map) + (should-error (map-insert map size 7)) + (setq new (map-insert map size 7)) + (should-not (eq map new)) + (should (equal (map-pairs map) pairs)) + (should (= (map-elt new size) 7)))))) (ert-deftest test-map-delete () (with-maps-do map - (map-delete map 1) - (should (null (map-elt map 1)))) + (should (map-elt map 1)) + (should (eq map (map-delete map 1))) + (should-not (map-elt map 1))) (with-maps-do map - (map-delete map -2) - (should (null (map-elt map -2))))) - -(ert-deftest test-map-delete-return-value () - (let ((ht (make-hash-table))) - (should (eq (map-delete ht 'a) ht)))) + (should-not (map-elt map -2)) + (should (eq map (map-delete map -2))) + (should-not (map-elt map -2))) + (with-maps-do map + ;; Check for OBOE. + (let ((key (map-length map))) + (should-not (map-elt map key)) + (should (eq map (map-delete map key))) + (should-not (map-elt map key))))) + +(ert-deftest test-map-delete-empty () + (with-empty-maps-do map + (should (eq map (map-delete map t))))) + +(ert-deftest test-map-delete-alist () + "Test `map-delete' test function on alists." + (let* ((a (string ?a)) + (map `((,a) (,(string ?b))))) + (setq map (map-delete map a)) + (should (equal map '(("b")))) + (setq map (map-delete map (string ?b))) + (should-not map))) (ert-deftest test-map-nested-elt () (let ((vec [a b [c d [e f]]])) @@ -134,8 +229,9 @@ Evaluate BODY for each created map. (d . 3) (e . ((f . 4) (g . 5)))))))) - (should (eq (map-nested-elt alist '(b e f)) - 4))) + (should (eq (map-nested-elt alist '(b e f)) 4))) + (let ((plist '(a 1 b (c 2 d 3 e (f 4 g 5))))) + (should (eq (map-nested-elt plist '(b e f)) 4))) (let ((ht (make-hash-table))) (setf (map-elt ht 'a) 1) (setf (map-elt ht 'b) (make-hash-table)) @@ -145,218 +241,318 @@ Evaluate BODY for each created map. (ert-deftest test-map-nested-elt-default () (let ((vec [a b [c d]])) - (should (null (map-nested-elt vec '(2 3)))) - (should (null (map-nested-elt vec '(2 1 1)))) + (should-not (map-nested-elt vec '(2 3))) + (should-not (map-nested-elt vec '(2 1 1))) (should (= 4 (map-nested-elt vec '(2 1 1) 4))))) (ert-deftest test-mapp () - (should (mapp nil)) - (should (mapp '((a . b) (c . d)))) - (should (mapp '(a b c d))) - (should (mapp [])) - (should (mapp [1 2 3])) - (should (mapp (make-hash-table))) + (with-empty-maps-do map + (should (mapp map))) + (with-maps-do map + (should (mapp map))) + (should (mapp "")) (should (mapp "hello")) - (should (not (mapp 1))) - (should (not (mapp 'hello)))) + (should-not (mapp 1)) + (should-not (mapp 'hello))) (ert-deftest test-map-keys () (with-maps-do map (should (equal (map-keys map) '(0 1 2)))) - (should (null (map-keys nil))) - (should (null (map-keys [])))) + (with-empty-maps-do map + (should-not (map-keys map)))) (ert-deftest test-map-values () (with-maps-do map - (should (equal (map-values map) '(3 4 5))))) + (should (equal (map-values map) '(3 4 5)))) + (with-empty-maps-do map + (should-not (map-values map)))) (ert-deftest test-map-pairs () (with-maps-do map - (should (equal (map-pairs map) '((0 . 3) - (1 . 4) - (2 . 5)))))) + (should (equal (map-pairs map) + '((0 . 3) + (1 . 4) + (2 . 5))))) + (with-empty-maps-do map + (should-not (map-pairs map)))) (ert-deftest test-map-length () - (let ((ht (make-hash-table))) - (puthash 'a 1 ht) - (puthash 'b 2 ht) - (puthash 'c 3 ht) - (puthash 'd 4 ht) - (should (= 0 (map-length nil))) - (should (= 0 (map-length []))) - (should (= 0 (map-length (make-hash-table)))) - (should (= 5 (map-length [0 1 2 3 4]))) - (should (= 2 (map-length '((a . 1) (b . 2))))) - (should (= 4 (map-length ht))))) + (with-empty-maps-do map + (should (zerop (map-length map)))) + (with-maps-do map + (should (= 3 (map-length map)))) + (should (= 1 (map-length '(nil 1)))) + (should (= 2 (map-length '(nil 1 t 2)))) + (should (= 2 (map-length '((a . 1) (b . 2))))) + (should (= 5 (map-length [0 1 2 3 4]))) + (should (= 4 (map-length #s(hash-table data (a 1 b 2 c 3 d 4)))))) (ert-deftest test-map-copy () (with-maps-do map (let ((copy (map-copy map))) - (should (equal (map-keys map) (map-keys copy))) - (should (equal (map-values map) (map-values copy))) - (should (not (eq map copy)))))) + (should (equal (map-pairs map) (map-pairs copy))) + (should-not (eq map copy)) + (map-put! map 0 0) + (should-not (equal (map-pairs map) (map-pairs copy))))) + (with-empty-maps-do map + (should-not (map-pairs (map-copy map))))) + +(ert-deftest test-map-copy-alist () + "Test use of `copy-alist' for alists." + (let* ((cons (list 'a 1 2)) + (alist (list cons)) + (copy (map-copy alist))) + (setcar cons 'b) + (should (equal alist '((b 1 2)))) + (should (equal copy '((a 1 2)))) + (setcar (cdr cons) 0) + (should (equal alist '((b 0 2)))) + (should (equal copy '((a 0 2)))) + (setcdr cons 3) + (should (equal alist '((b . 3)))) + (should (equal copy '((a 0 2)))))) (ert-deftest test-map-apply () - (with-maps-do map - (should (equal (map-apply (lambda (k v) (cons (int-to-string k) v)) - map) - '(("0" . 3) ("1" . 4) ("2" . 5))))) - (let ((vec [a b c])) - (should (equal (map-apply (lambda (k v) (cons (1+ k) v)) - vec) - '((1 . a) - (2 . b) - (3 . c)))))) + (let ((fn (lambda (k v) (cons (number-to-string k) v)))) + (with-maps-do map + (should (equal (map-apply fn map) + '(("0" . 3) ("1" . 4) ("2" . 5))))) + (with-empty-maps-do map + (should-not (map-apply fn map))))) (ert-deftest test-map-do () - (with-maps-do map - (let ((result nil)) - (map-do (lambda (k v) - (add-to-list 'result (list (int-to-string k) v))) - map) - (should (equal result '(("2" 5) ("1" 4) ("0" 3))))))) + (let* (res + (fn (lambda (k v) + (push (list (number-to-string k) v) res)))) + (with-empty-maps-do map + (should-not (map-do fn map)) + (should-not res)) + (with-maps-do map + (setq res nil) + (should-not (map-do fn map)) + (should (equal res '(("2" 5) ("1" 4) ("0" 3))))))) (ert-deftest test-map-keys-apply () (with-maps-do map - (should (equal (map-keys-apply (lambda (k) (int-to-string k)) - map) - '("0" "1" "2")))) - (let ((vec [a b c])) - (should (equal (map-keys-apply (lambda (k) (1+ k)) - vec) - '(1 2 3))))) + (should (equal (map-keys-apply #'1+ map) '(1 2 3)))) + (with-empty-maps-do map + (let (ks) + (should-not (map-keys-apply (lambda (k) (push k ks)) map)) + (should-not ks)))) (ert-deftest test-map-values-apply () (with-maps-do map - (should (equal (map-values-apply (lambda (v) (1+ v)) - map) - '(4 5 6)))) - (let ((vec [a b c])) - (should (equal (map-values-apply (lambda (v) (symbol-name v)) - vec) - '("a" "b" "c"))))) + (should (equal (map-values-apply #'1+ map) '(4 5 6)))) + (with-empty-maps-do map + (let (vs) + (should-not (map-values-apply (lambda (v) (push v vs)) map)) + (should-not vs)))) (ert-deftest test-map-filter () (with-maps-do map - (should (equal (map-keys (map-filter (lambda (_k v) - (<= 4 v)) - map)) - '(1 2))) - (should (null (map-filter (lambda (k _v) - (eq 'd k)) - map)))) - (should (null (map-filter (lambda (_k v) - (eq 3 v)) - [1 2 4 5]))) - (should (equal (map-filter (lambda (k _v) - (eq 3 k)) - [1 2 4 5]) - '((3 . 5))))) + (should (equal (map-filter (lambda (_k v) (> v 3)) map) + '((1 . 4) (2 . 5)))) + (should (equal (map-filter #'always map) (map-pairs map))) + (should-not (map-filter #'ignore map))) + (with-empty-maps-do map + (should-not (map-filter #'always map)) + (should-not (map-filter #'ignore map)))) (ert-deftest test-map-remove () (with-maps-do map - (should (equal (map-keys (map-remove (lambda (_k v) - (>= v 4)) - map)) - '(0))) - (should (equal (map-keys (map-remove (lambda (k _v) - (eq 'd k)) - map)) - (map-keys map)))) - (should (equal (map-remove (lambda (_k v) - (eq 3 v)) - [1 2 4 5]) - '((0 . 1) - (1 . 2) - (2 . 4) - (3 . 5)))) - (should (null (map-remove (lambda (k _v) - (>= k 0)) - [1 2 4 5])))) + (should (equal (map-remove (lambda (_k v) (> v 3)) map) + '((0 . 3)))) + (should (equal (map-remove #'ignore map) (map-pairs map))) + (should-not (map-remove #'always map))) + (with-empty-maps-do map + (should-not (map-remove #'always map)) + (should-not (map-remove #'ignore map)))) (ert-deftest test-map-empty-p () - (should (map-empty-p nil)) - (should (not (map-empty-p '((a . b) (c . d))))) - (should (map-empty-p [])) - (should (not (map-empty-p [1 2 3]))) - (should (map-empty-p (make-hash-table))) - (should (not (map-empty-p "hello"))) - (should (map-empty-p ""))) + (with-empty-maps-do map + (should (map-empty-p map))) + (should (map-empty-p "")) + (should-not (map-empty-p '((a . b) (c . d)))) + (should-not (map-empty-p [1 2 3])) + (should-not (map-empty-p "hello"))) (ert-deftest test-map-contains-key () - (should (map-contains-key '((a . 1) (b . 2)) 'a)) - (should (not (map-contains-key '((a . 1) (b . 2)) 'c))) - (should (map-contains-key '(("a" . 1)) "a")) - (should (not (map-contains-key '(("a" . 1)) "a" #'eq))) - (should (map-contains-key [a b c] 2)) - (should (not (map-contains-key [a b c] 3)))) + (with-empty-maps-do map + (should-not (map-contains-key map -1)) + (should-not (map-contains-key map 0)) + (should-not (map-contains-key map 1)) + (should-not (map-contains-key map (map-length map)))) + (with-maps-do map + (should-not (map-contains-key map -1)) + (should (map-contains-key map 0)) + (should (map-contains-key map 1)) + (should-not (map-contains-key map (map-length map))))) + +(ert-deftest test-map-contains-key-testfn () + "Test `map-contains-key' under different equalities." + (let ((key (string ?a)) + (plist '("a" 1 a 2)) + (alist '(("a" . 1) (a . 2)))) + (should (map-contains-key alist 'a)) + (should (map-contains-key plist 'a)) + (should (map-contains-key alist 'a #'eq)) + (should (map-contains-key plist 'a #'eq)) + (should (map-contains-key alist key)) + (should-not (map-contains-key plist key)) + (should-not (map-contains-key alist key #'eq)) + (should-not (map-contains-key plist key #'eq)))) (ert-deftest test-map-some () (with-maps-do map - (should (map-some (lambda (k _v) - (eq 1 k)) - map)) - (should-not (map-some (lambda (k _v) - (eq 'd k)) - map))) - (let ((vec [a b c])) - (should (map-some (lambda (k _v) - (> k 1)) - vec)) - (should-not (map-some (lambda (k _v) - (> k 3)) - vec)))) + (should (eq (map-some (lambda (k _v) (and (= k 1) 'found)) map) + 'found)) + (should-not (map-some #'ignore map))) + (with-empty-maps-do map + (should-not (map-some #'always map)) + (should-not (map-some #'ignore map)))) (ert-deftest test-map-every-p () (with-maps-do map - (should (map-every-p (lambda (k _v) - k) - map)) - (should (not (map-every-p (lambda (_k _v) - nil) - map)))) - (let ((vec [a b c])) - (should (map-every-p (lambda (k _v) - (>= k 0)) - vec)) - (should (not (map-every-p (lambda (k _v) - (> k 3)) - vec))))) + (should (map-every-p #'always map)) + (should-not (map-every-p #'ignore map)) + (should-not (map-every-p (lambda (k _v) (zerop k)) map))) + (with-empty-maps-do map + (should (map-every-p #'always map)) + (should (map-every-p #'ignore map)) + (should (map-every-p (lambda (k _v) (zerop k)) map)))) (ert-deftest test-map-into () - (let* ((alist '((a . 1) (b . 2))) - (ht (map-into alist 'hash-table))) + (let* ((plist '(a 1 b 2)) + (alist '((a . 1) (b . 2))) + (ht (map-into alist 'hash-table)) + (ht2 (map-into alist '(hash-table :test equal)))) (should (hash-table-p ht)) - (should (equal (map-into (map-into alist 'hash-table) 'list) - alist)) - (should (listp (map-into ht 'list))) - (should (equal (map-keys (map-into (map-into ht 'list) 'hash-table)) - (map-keys ht))) - (should (equal (map-values (map-into (map-into ht 'list) 'hash-table)) - (map-values ht))) - (should (null (map-into nil 'list))) - (should (map-empty-p (map-into nil 'hash-table))) - (should-error (map-into [1 2 3] 'string)))) + (should (equal (map-into ht 'list) alist)) + (should (equal (map-pairs (map-into (map-into ht 'list) 'hash-table)) + (map-pairs ht))) + (should (equal (map-into ht 'alist) (map-into ht2 'alist))) + (should (equal (map-into alist 'list) alist)) + (should (equal (map-into alist 'alist) alist)) + (should (equal (map-into alist 'plist) plist)) + (should (equal (map-into plist 'alist) alist)) + (should (equal (map-into plist 'plist) plist))) + (should-error (map-into [1 2 3] 'string) :type 'cl-no-applicable-method)) + +(ert-deftest test-map-into-hash-test () + "Test `map-into' with different hash-table test functions." + (should (eq (hash-table-test (map-into () 'hash-table)) #'equal)) + (should (eq (hash-table-test (map-into () '(hash-table))) #'eql)) + (should (eq (hash-table-test (map-into () '(hash-table :test eq))) #'eq)) + (should (eq (hash-table-test (map-into () '(hash-table :test eql))) #'eql)) + (should (eq (hash-table-test (map-into () '(hash-table :test equal))) + #'equal))) + +(ert-deftest test-map-into-empty () + "Test `map-into' with empty maps." + (with-empty-maps-do map + (should-not (map-into map 'list)) + (should-not (map-into map 'alist)) + (should-not (map-into map 'plist)) + (should (map-empty-p (map-into map 'hash-table))))) (ert-deftest test-map-let () (map-let (foo bar baz) '((foo . 1) (bar . 2)) (should (= foo 1)) (should (= bar 2)) - (should (null baz))) + (should-not baz)) (map-let (('foo a) ('bar b) ('baz c)) '((foo . 1) (bar . 2)) (should (= a 1)) (should (= b 2)) - (should (null c)))) + (should-not c))) + +(ert-deftest test-map-merge () + "Test `map-merge'." + (should (equal (sort (map-merge 'list '(a 1) '((b . 2) (c . 3)) + #s(hash-table data (c 4))) + (lambda (x y) (string< (car x) (car y)))) + '((a . 1) (b . 2) (c . 4)))) + (should (equal (map-merge 'list () '(:a 1)) '((:a . 1)))) + (should (equal (map-merge 'alist () '(:a 1)) '((:a . 1)))) + (should (equal (map-merge 'plist () '(:a 1)) '(:a 1)))) (ert-deftest test-map-merge-with () - (should (equal (map-merge-with 'list #'+ - '((1 . 2)) - '((1 . 3) (2 . 4)) - '((1 . 1) (2 . 5) (3 . 0))) - '((3 . 0) (2 . 9) (1 . 6))))) + (should (equal (sort (map-merge-with 'list #'+ + '((1 . 2)) + '((1 . 3) (2 . 4)) + '((1 . 1) (2 . 5) (3 . 0))) + #'car-less-than-car) + '((1 . 6) (2 . 9) (3 . 0)))) + (should (equal (map-merge-with 'list #'+ () '(:a 1)) '((:a . 1)))) + (should (equal (map-merge-with 'alist #'+ () '(:a 1)) '((:a . 1)))) + (should (equal (map-merge-with 'plist #'+ () '(:a 1)) '(:a 1)))) + +(ert-deftest test-map-merge-empty () + "Test merging of empty maps." + (should-not (map-merge 'list)) + (should-not (map-merge 'alist)) + (should-not (map-merge 'plist)) + (should-not (map-merge-with 'list #'+)) + (should-not (map-merge-with 'alist #'+)) + (should-not (map-merge-with 'plist #'+)) + (should (map-empty-p (map-merge 'hash-table))) + (should (map-empty-p (map-merge-with 'hash-table #'+))) + (should-error (map-merge 'array) :type 'cl-no-applicable-method) + (should-error (map-merge-with 'array #'+) :type 'cl-no-applicable-method)) + +(ert-deftest test-map-plist-pcase () + (let ((plist '(:one 1 :two 2))) + (should (equal (pcase-let (((map :one (:two two)) plist)) + (list one two)) + '(1 2))))) + +(ert-deftest test-map-setf-alist-insert-key () + (let ((alist)) + (should (equal (setf (map-elt alist 'key) 'value) + 'value)) + (should (equal alist '((key . value)))))) + +(ert-deftest test-map-setf-alist-overwrite-key () + (let ((alist '((key . value1)))) + (should (equal (setf (map-elt alist 'key) 'value2) + 'value2)) + (should (equal alist '((key . value2)))))) + +(ert-deftest test-map-setf-plist-insert-key () + (let ((plist '(key value))) + (should (equal (setf (map-elt plist 'key2) 'value2) + 'value2)) + (should (equal plist '(key value key2 value2))))) + +(ert-deftest test-map-setf-plist-overwrite-key () + (let ((plist '(key value))) + (should (equal (setf (map-elt plist 'key) 'value2) + 'value2)) + (should (equal plist '(key value2))))) + +(ert-deftest test-hash-table-setf-insert-key () + (let ((ht (make-hash-table))) + (should (equal (setf (map-elt ht 'key) 'value) + 'value)) + (should (equal (map-elt ht 'key) 'value)))) + +(ert-deftest test-hash-table-setf-overwrite-key () + (let ((ht (make-hash-table))) + (puthash 'key 'value1 ht) + (should (equal (setf (map-elt ht 'key) 'value2) + 'value2)) + (should (equal (map-elt ht 'key) 'value2)))) + +(ert-deftest test-setf-map-with-function () + (let ((num 0) + (map nil)) + (setf (map-elt map 'foo) + (funcall (lambda () + (cl-incf num)))) + ;; Check that the function is only called once. + (should (= num 1)))) (provide 'map-tests) ;;; map-tests.el ends here diff --git a/test/lisp/emacs-lisp/memory-report-tests.el b/test/lisp/emacs-lisp/memory-report-tests.el new file mode 100644 index 00000000000..869144163b7 --- /dev/null +++ b/test/lisp/emacs-lisp/memory-report-tests.el @@ -0,0 +1,83 @@ +;;; memory-report-tests.el --- tests for memory-report.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'memory-report) + +(defun setup-memory-report-tests () + ;; Set the sizes on things based on a 64-bit architecture. (We're + ;; hard-coding this to be able to write simple tests that'll work on + ;; all architectures.) + (memory-report--set-size + '((conses 16 499173 99889) + (symbols 48 22244 3) + (strings 32 92719 4559) + (string-bytes 1 40402011) + (vectors 16 31919) + (vector-slots 8 385148 149240) + (floats 8 434 4519) + (intervals 56 24499 997) + (buffers 984 33)))) + +(ert-deftest memory-report-sizes () + (setup-memory-report-tests) + (should (equal (memory-report-object-size (cons nil nil)) 16)) + (should (equal (memory-report-object-size (cons 1 2)) 16)) + + (should (equal (memory-report-object-size (list 1 2)) 32)) + (should (equal (memory-report-object-size (list 1)) 16)) + + (should (equal (memory-report-object-size (list 'foo)) 16)) + + (should (equal (memory-report-object-size (vector 1 2 3)) 64)) + (should (equal (memory-report-object-size (vector 1 2 3 4)) 80)) + + (should (equal (memory-report-object-size "") 32)) + (should (equal (memory-report-object-size "a") 33)) + (should (equal (memory-report-object-size (propertize "a" 'face 'foo)) + 81))) + +(ert-deftest memory-report-sizes-vectors () + (should (= (memory-report--object-size + (make-hash-table :test #'eq) + ["long string that should be at least 40 bytes"]) + 108)) + (let ((string "long string that should be at least 40 bytes")) + (should (= (memory-report--object-size + (make-hash-table :test #'eq) + (vector string)) + 108)) + (should (= (memory-report--object-size + (make-hash-table :test #'eq) + (vector string string)) + 124)))) + +(ert-deftest memory-report-sizes-structs () + (cl-defstruct memory-report-test-struct + (item0 nil) + (item1 nil)) + (let ((s (make-memory-report-test-struct :item0 "hello" :item1 "world"))) + (should (= (memory-report-object-size s) + 90)))) + +(provide 'memory-report-tests) + +;;; memory-report-tests.el ends here diff --git a/test/lisp/emacs-lisp/multisession-tests.el b/test/lisp/emacs-lisp/multisession-tests.el new file mode 100644 index 00000000000..5807c27bd20 --- /dev/null +++ b/test/lisp/emacs-lisp/multisession-tests.el @@ -0,0 +1,207 @@ +;;; multisession-tests.el --- Tests for multisession.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'multisession) +(require 'ert) +(require 'ert-x) +(require 'cl-lib) + +(declare-function sqlite-close "sqlite.c") + +(ert-deftest multi-test-sqlite-simple () + (skip-unless (sqlite-available-p)) + (ert-with-temp-file dir + :directory t + (let ((user-init-file "/tmp/foo.el") + (multisession-storage 'sqlite) + (multisession-directory dir)) + (unwind-protect + (progn + (define-multisession-variable multisession--foo 0 + "" + :synchronized t) + (should (= (multisession-value multisession--foo) 0)) + (cl-incf (multisession-value multisession--foo)) + (should (= (multisession-value multisession--foo) 1)) + (call-process + (concat invocation-directory invocation-name) + nil t nil + "-Q" "-batch" + "--eval" (prin1-to-string + `(progn + (require 'multisession) + (let ((multisession-directory ,dir) + (multisession-storage 'sqlite) + (user-init-file "/tmp/foo.el")) + (define-multisession-variable multisession--foo 0 + "" + :synchronized t) + (cl-incf (multisession-value multisession--foo)))))) + (should (= (multisession-value multisession--foo) 2))) + (sqlite-close multisession--db) + (setq multisession--db nil))))) + +(ert-deftest multi-test-sqlite-busy () + (skip-unless (sqlite-available-p)) + (ert-with-temp-file dir + :directory t + (let ((user-init-file "/tmp/foo.el") + (multisession-directory dir) + (multisession-storage 'sqlite) + proc) + (unwind-protect + (progn + (define-multisession-variable multisession--bar 0 + "" + :synchronized t) + (should (= (multisession-value multisession--bar) 0)) + (cl-incf (multisession-value multisession--bar)) + (should (= (multisession-value multisession--bar) 1)) + (setq proc + (start-process + "other-emacs" + nil + (concat invocation-directory invocation-name) + "-Q" "-batch" + "--eval" (prin1-to-string + `(progn + (require 'multisession) + (let ((multisession-directory ,dir) + (multisession-storage 'sqlite) + (user-init-file "/tmp/bar.el")) + (define-multisession-variable multisession--bar 0 + "" :synchronized t) + (dotimes (i 100) + (cl-incf (multisession-value multisession--bar)))))))) + (while (process-live-p proc) + (ignore-error 'sqlite-locked-error + (message "multisession--bar %s" (multisession-value multisession--bar)) + ;;(cl-incf (multisession-value multisession--bar)) + ) + (sleep-for 0.1)) + (message "multisession--bar ends up as %s" (multisession-value multisession--bar)) + (should (< (multisession-value multisession--bar) 1003))) + (sqlite-close multisession--db) + (setq multisession--db nil))))) + +(ert-deftest multi-test-files-simple () + (ert-with-temp-file dir + :directory t + (let ((user-init-file "/tmp/sfoo.el") + (multisession-storage 'files) + (multisession-directory dir)) + (define-multisession-variable multisession--sfoo 0 + "" + :synchronized t) + (should (= (multisession-value multisession--sfoo) 0)) + (cl-incf (multisession-value multisession--sfoo)) + (should (= (multisession-value multisession--sfoo) 1)) + ;; On Windows and Haiku, we don't have sub-second resolution, so + ;; let some time pass to make the "later" logic work. + (when (memq system-type '(windows-nt haiku)) + (sleep-for 0.6)) + (call-process + (concat invocation-directory invocation-name) + nil t nil + "-Q" "-batch" + "--eval" (prin1-to-string + `(progn + (require 'multisession) + (let ((multisession-directory ,dir) + (multisession-storage 'files) + (user-init-file "/tmp/sfoo.el")) + (define-multisession-variable multisession--sfoo 0 + "" + :synchronized t) + (cl-incf (multisession-value multisession--sfoo)))))) + (should (= (multisession-value multisession--sfoo) 2))))) + +(ert-deftest multi-test-files-busy () + (skip-unless (sqlite-available-p)) + (ert-with-temp-file dir + :directory t + (let ((user-init-file "/tmp/foo.el") + (multisession-storage 'files) + (multisession-directory dir) + proc) + (define-multisession-variable multisession--sbar 0 + "" + :synchronized t) + (should (= (multisession-value multisession--sbar) 0)) + (cl-incf (multisession-value multisession--sbar)) + (should (= (multisession-value multisession--sbar) 1)) + (setq proc + (start-process + "other-emacs" + nil + (concat invocation-directory invocation-name) + "-Q" "-batch" + "--eval" (prin1-to-string + `(progn + (require 'multisession) + (let ((multisession-directory ,dir) + (multisession-storage 'files) + (user-init-file "/tmp/sbar.el")) + (define-multisession-variable multisession--sbar 0 + "" :synchronized t) + (dotimes (i 100) + (cl-incf (multisession-value multisession--sbar)))))))) + (while (process-live-p proc) + (message "multisession--sbar %s" (multisession-value multisession--sbar)) + ;;(cl-incf (multisession-value multisession--sbar)) + (sleep-for 0.1)) + (message "multisession--sbar ends up as %s" (multisession-value multisession--sbar)) + (should (< (multisession-value multisession--sbar) 200))))) + +(ert-deftest multi-test-files-some-values () + (ert-with-temp-file dir + :directory t + (let ((user-init-file "/tmp/sfoo.el") + (multisession-storage 'files) + (multisession-directory dir)) + (define-multisession-variable multisession--foo1 nil) + (should (eq (multisession-value multisession--foo1) nil)) + (setf (multisession-value multisession--foo1) nil) + (should (eq (multisession-value multisession--foo1) nil)) + (setf (multisession-value multisession--foo1) t) + (should (eq (multisession-value multisession--foo1) t)) + + (define-multisession-variable multisession--foo2 t) + (setf (multisession-value multisession--foo2) nil) + (should (eq (multisession-value multisession--foo2) nil)) + (setf (multisession-value multisession--foo2) t) + (should (eq (multisession-value multisession--foo2) t)) + + (define-multisession-variable multisession--foo3 t) + (should-error (setf (multisession-value multisession--foo3) (make-marker))) + + (let ((string (with-temp-buffer + (set-buffer-multibyte nil) + (insert 0 1 2) + (buffer-string)))) + (should-not (multibyte-string-p string)) + (define-multisession-variable multisession--foo4 nil) + (setf (multisession-value multisession--foo4) string) + (should (equal (multisession-value multisession--foo4) string)))))) + +;;; multisession-tests.el ends here diff --git a/test/lisp/emacs-lisp/nadvice-tests.el b/test/lisp/emacs-lisp/nadvice-tests.el index 5cee61ee67d..a675986b90b 100644 --- a/test/lisp/emacs-lisp/nadvice-tests.el +++ b/test/lisp/emacs-lisp/nadvice-tests.el @@ -1,6 +1,6 @@ -;;; advice-tests.el --- Test suite for the new advice thingy. +;;; nadvice-tests.el --- Test suite for the new advice thingy. -*- lexical-binding:t -*- -;; Copyright (C) 2012-2017 Free Software Foundation, Inc. +;; Copyright (C) 2012-2022 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -153,13 +153,13 @@ function being an around advice." (ert-deftest advice-test-call-interactively () "Check interaction between advice on call-interactively and called-interactively-p." - (defun sm-test7.4 () (interactive) (cons 1 (called-interactively-p))) - (let ((old (symbol-function 'call-interactively))) + (let ((sm-test7.4 (lambda () (interactive) (cons 1 (called-interactively-p)))) + (old (symbol-function 'call-interactively))) (unwind-protect (progn (advice-add 'call-interactively :before #'ignore) - (should (equal (sm-test7.4) '(1 . nil))) - (should (equal (call-interactively 'sm-test7.4) '(1 . t)))) + (should (equal (funcall sm-test7.4) '(1 . nil))) + (should (equal (call-interactively sm-test7.4) '(1 . t)))) (advice-remove 'call-interactively #'ignore) (should (eq (symbol-function 'call-interactively) old))))) @@ -204,8 +204,17 @@ function being an around advice." (remove-function (var sm-test10) sm-advice) (should (equal (funcall sm-test10 5) 15)))) +(ert-deftest advice-test-print () + (let ((x (list 'cdr))) + (add-function :after (car x) 'car) + (should (equal (cl-prin1-to-string (car x)) + "#f(advice car :after cdr)")) + (add-function :before (car x) 'first) + (should (equal (cl-prin1-to-string (car x)) + "#f(advice first :before #f(advice car :after cdr))")))) + ;; Local Variables: ;; no-byte-compile: t ;; End: -;;; advice-tests.el ends here. +;;; nadvice-tests.el ends here diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el new file mode 100644 index 00000000000..00b008845c0 --- /dev/null +++ b/test/lisp/emacs-lisp/oclosure-tests.el @@ -0,0 +1,166 @@ +;;; oclosure-tests.e; --- Tests for Open Closures -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'oclosure) +(require 'cl-lib) +(require 'eieio) + +(oclosure-define (oclosure-test + (:copier oclosure-test-copy) + (:copier oclosure-test-copy1 (fst))) + "Simple OClosure." + fst snd (name :mutable t)) + +(cl-defmethod oclosure-test-gen ((_x compiled-function)) "#<bytecode>") + +(cl-defmethod oclosure-test-gen ((_x cons)) "#<cons>") + +(cl-defmethod oclosure-test-gen ((_x oclosure)) + (format "#<oclosure:%s>" (cl-call-next-method))) + +(cl-defmethod oclosure-test-gen ((_x oclosure-test)) + (format "#<oclosure-test:%s>" (cl-call-next-method))) + +(ert-deftest oclosure-test () + (let* ((i 42) + (ocl1 (oclosure-lambda (oclosure-test (fst 1) (snd 2) (name "hi")) + () + (list fst snd i))) + (ocl2 (oclosure-lambda (oclosure-test (name (cl-incf i)) (fst (cl-incf i))) + () + (list fst snd 152 i)))) + (should (equal (list (oclosure-test--fst ocl1) + (oclosure-test--snd ocl1) + (oclosure-test--name ocl1)) + '(1 2 "hi"))) + (should (equal (list (oclosure-test--fst ocl2) + (oclosure-test--snd ocl2) + (oclosure-test--name ocl2)) + '(44 nil 43))) + (should (equal (funcall ocl1) '(1 2 44))) + (should (equal (funcall ocl2) '(44 nil 152 44))) + (should (equal (funcall (oclosure-test-copy ocl1 :fst 7)) '(7 2 44))) + (should (equal (funcall (oclosure-test-copy1 ocl1 9)) '(9 2 44))) + (should (cl-typep ocl1 'oclosure-test)) + (should (cl-typep ocl1 'oclosure)) + (should (member (oclosure-test-gen ocl1) + '("#<oclosure-test:#<oclosure:#<cons>>>" + "#<oclosure-test:#<oclosure:#<bytecode>>>"))) + (should (stringp (documentation #'oclosure-test--fst))) + )) + +(ert-deftest oclosure-test-limits () + (defvar byte-compile-debug) + (should + (condition-case err + (let ((lexical-binding t) + (byte-compile-debug t)) + (byte-compile '(lambda () + (let ((inc-fst nil)) + (oclosure-lambda (oclosure-test (fst 'foo)) () + (setq inc-fst (lambda () (setq fst (1+ fst)))) + fst)))) + nil) + (error + (and (eq 'error (car err)) + (string-match "fst.*mutated" (cadr err)))))) + (should + (condition-case err + (progn (macroexpand-all '(oclosure-define oclosure--foo a a)) + nil) + (error + (and (eq 'error (car err)) + (string-match "Duplicate slot name: a$" (cadr err)))))) + (should + (condition-case err + (progn (macroexpand-all + '(oclosure-define (oclosure--foo (:parent oclosure-test)) fst)) + nil) + (error + (and (eq 'error (car err)) + (string-match "Duplicate slot name: fst$" (cadr err)))))) + (should + (condition-case err + (progn (macroexpand '(oclosure-lambda (oclosure-test (fst 1) (fst 2)) + () fst)) + nil) + (error + (and (eq 'error (car err)) + (string-match "Duplicate slot: fst$" (cadr err))))))) + +(cl-defmethod oclosure-interactive-form ((ot oclosure-test)) + (let ((snd (oclosure-test--snd ot))) + (if (stringp snd) (list 'interactive snd)))) + +(ert-deftest oclosure-test-interactive-form () + (should (equal (interactive-form + (oclosure-lambda (oclosure-test (fst 1) (snd 2)) () fst)) + nil)) + (should (equal (interactive-form + (oclosure-lambda (oclosure-test (fst 1) (snd 2)) () + (interactive "r") + fst)) + '(interactive "r"))) + (should (equal (interactive-form + (oclosure-lambda (oclosure-test (fst 1) (snd "P")) () fst)) + '(interactive "P"))) + (should (not (commandp + (oclosure-lambda (oclosure-test (fst 1) (snd 2)) () fst)))) + (should (commandp + (oclosure-lambda (oclosure-test (fst 1) (snd "P")) () fst)))) + +(oclosure-define (oclosure-test-mut + (:parent oclosure-test) + (:copier oclosure-test-mut-copy)) + "Simple OClosure with a mutable field." + (mut :mutable t)) + +(ert-deftest oclosure-test-mutate () + (let* ((f (oclosure-lambda (oclosure-test-mut (fst 0) (mut 3)) + (x) + (+ x fst mut))) + (f2 (oclosure-test-mut-copy f :fst 50))) + (should (equal (oclosure-test-mut--mut f) 3)) + (should (equal (funcall f 5) 8)) + (should (equal (funcall f2 5) 58)) + (cl-incf (oclosure-test-mut--mut f) 7) + (should (equal (oclosure-test-mut--mut f) 10)) + (should (equal (funcall f 5) 15)) + (should (equal (funcall f2 15) 68)))) + +(ert-deftest oclosure-test-slot-value () + (require 'eieio) + (let ((ocl (oclosure-lambda + (oclosure-test (fst 'fst1) (snd 'snd1) (name 'name1)) + (x) + (list name fst snd x)))) + (should (equal 'fst1 (slot-value ocl 'fst))) + (should (equal 'snd1 (slot-value ocl 'snd))) + (should (equal 'name1 (slot-value ocl 'name))) + (setf (slot-value ocl 'name) 'new-name) + (should (equal 'new-name (slot-value ocl 'name))) + (should (equal '(new-name fst1 snd1 arg) (funcall ocl 'arg))) + (should-error (setf (slot-value ocl 'fst) 'new-fst) :type 'setting-constant) + (should (equal 'fst1 (slot-value ocl 'fst))) + )) + +;;; oclosure-tests.el ends here. diff --git a/test/lisp/emacs-lisp/package-resources/key.pub b/test/lisp/emacs-lisp/package-resources/key.pub index a326d34e54f..99965723baf 100644 --- a/test/lisp/emacs-lisp/package-resources/key.pub +++ b/test/lisp/emacs-lisp/package-resources/key.pub @@ -1,18 +1,17 @@ -----BEGIN PGP PUBLIC KEY BLOCK----- -Version: GnuPG v1.4.14 (GNU/Linux) -mQENBFJNB8gBCACfbtpvYrM8V1HM0KFlIwatcEJugHqwOHpr/Z9mrCW0fxyQAW/d -2L+3QVNsN9Tz/K9lLcBUgeR7rhVEzHNqhmhNj/HnikwGqXbIofhp+QbZmBKnAlCz -d77kg8K9lozHtfTkm1gX/7DdPzQKmgi7WOzzi2395wGubeqJLvYaEcqVbI0Eob+E -3CzRjNy/e/Tf3TJRW5etTcdZN6LVuIY7tNCHqlQZTwyycON/hfLTX6cLCnzDsqm/ -NxCuwn9aqP9aGRGfIu7Y+If3zTymvrXEPUN98OEID814bOKdx0uVTZRiSMbvuTGI -8uMa/kpGX/78rqI61gbZV51RFoU7pT2tzwY/ABEBAAG0HkouIFIuIEhhY2tlciA8 -anJoQGV4YW1wbGUuY29tPokBOAQTAQIAIgUCUk0HyAIbAwYLCQgHAwIGFQgCCQoL -BBYCAwECHgECF4AACgkQtpVAhgkYletuhQf+JAyHYhTZNxjq0UYlikuLX8EtYbXX -PB+03J0B73SMzEai5XsiTU2ADxqxwr7pveVK1INf+IGLiiXBlQq+4DSOvQY4xLfp -58jTOYRV1ECvlXK/JtvVOwufXREADaydf9l/MUxA5G2PPBWIuQknh3ysPSsx68OJ -SzNHFwklLn0DKc4WloE/GLDpTzimnCg7QGzuUo3Iilpjdy8EvTdI5d3jx/mGJIwI -goB+YZgyxSPM+GjDwh5DEwD7OexNqqa7RynnmU0epmlYyi9UufCHLwgiiEIzjpWi -6+iF+CQ45ZAKncovByenIUv73J3ImOudrsskeAHBmahljv1he6uV9Egj2Q== -=b5Kg +mQGiBGFQyDcRBACmAI6cfY3fM02vb9JtC1BS19boKXbBsDoVrD9qRf8tDFROOpO3 +ZMlbuz+O9Vnljo6Y4WZGnyeWWAMqCditMOfr1cLbux77wSrmAVgZ9exwtGzkmUhM +xcptzKuyod8NuhghXbJgVbfJZ6HlBkk4kiWv98iJQwUBZJfjBUfIv+acjwCg4M2i +Ifu2A3UYl9VqF7qfcDOZudEEAI7V35yfsBDnr9ndKqdGYNw0alX9BEG3KwnAe0fF +O1jDVW12Y/bwnyyrRTrz6o1G8dj7M4XVZQb5PpT9mpNzOSZ6yxqhg+foeJwn2JkD +vyP+kMYU7SZ/tWuMOCdzN95Ki1rf+ti7pLnSMqKx+t3vOWwQbtnsbI6RCLLwETPA +esghA/0X3Dw7cdiE5Xq4TRaPSGViCWP4ekL2KYKqmKv6M/4f2pgFNJY7C+2SIiiP +T62zFlIjs5tF2Df34/M5mh4Vx6E8341r55+XO++kfFWJ5QjLiydRAY6ochG9IFgB +xyBCkCNpiby9PpKyPodedBScdMxIAe4eJR7rG/j9gFC1MypBurQnSm9obm55IFJv +Y2tldHMgPGpvaG5ueS5yb2NrZXRzQGdmeS5vcmc+iHgEExECADgWIQRIVz1DPzm4 +REDIXNtltQG5ACv6lwUCYVDINwIbAwULCQgHAgYVCgkICwIEFgIDAQIeAQIXgAAK +CRBltQG5ACv6l4iZAKCqldroRYH7vUzVV0Uv1NcDVcpLngCgmEoLVxGLKSwDEXNq +qjRDzDRpReg= +=/l51 -----END PGP PUBLIC KEY BLOCK----- diff --git a/test/lisp/emacs-lisp/package-resources/key.sec b/test/lisp/emacs-lisp/package-resources/key.sec index d21e6ae9a45..5bbac1226ae 100644 --- a/test/lisp/emacs-lisp/package-resources/key.sec +++ b/test/lisp/emacs-lisp/package-resources/key.sec @@ -1,33 +1,17 @@ -----BEGIN PGP PRIVATE KEY BLOCK----- -Version: GnuPG v1.4.14 (GNU/Linux) -lQO+BFJNB8gBCACfbtpvYrM8V1HM0KFlIwatcEJugHqwOHpr/Z9mrCW0fxyQAW/d -2L+3QVNsN9Tz/K9lLcBUgeR7rhVEzHNqhmhNj/HnikwGqXbIofhp+QbZmBKnAlCz -d77kg8K9lozHtfTkm1gX/7DdPzQKmgi7WOzzi2395wGubeqJLvYaEcqVbI0Eob+E -3CzRjNy/e/Tf3TJRW5etTcdZN6LVuIY7tNCHqlQZTwyycON/hfLTX6cLCnzDsqm/ -NxCuwn9aqP9aGRGfIu7Y+If3zTymvrXEPUN98OEID814bOKdx0uVTZRiSMbvuTGI -8uMa/kpGX/78rqI61gbZV51RFoU7pT2tzwY/ABEBAAH+AwMCKCCpPNXkXuVgF7cz -eByuvgIO7wImDYGOdJqsASSzV4q0u1acnGtlxg7WphKDF9RnC5+1ZZ1ZcrBcv2uJ -xZm2jHdjqM3FmgQTN70GVzO1nKEur2wxlKotG4Q+8BtaRDwHdKpQFk+QW9aInH3C -BkNWTK97iFwZaoUGxKuRJb35qjMe3SsDE7kdbtOqO+tOeppRVeOOZCn7F33ir/6i -j2gmIME6LFDzvBi6YAyMBSh90Ak70HJINt0QfXlZf5MtX1NaxaEcnsRmwwcNqxh9 -JvcC9q4WrR92NhHCHI+lOsAe7hbwo/VkwRjSSx0HdKkx6kvdcNj/9LeX/jykzLvg -kEqvAqT4Jmk57W2seqvpNcAO+eUVrJ5D1OR6khsUtikPp2pQH5MDXJDGcie+ZAFb -w6BwoWBDBjooKtfuP0LKqrdtJG2JLe6yhBhWvfqHPBlUU1SsA7a5aTCLo8FiqgEI -Kyy60zMx/2Mi48oN1a/mAoV1MTWLhOVUWJlIHM7nVLj1OaX0316LcLX/uTLTq40p -apHKwERanzY7f8ROiv/Fa/J+9cCsfOLKfjFAjpBVUVoOb39HsyS/vvkGMY4kgaD6 -K6r9JPdsaoYvsLkxk5HyHF7Mk2uS1z1EIArD2/3lRiX6ag+IU1Nl3XDkgfZj06K3 -juS84dGF8CmN49uOEjzAJAQZH9jTs5OKzUuZhGJF+gt0L78vLOoKRr8bu1N1GPqU -wnS908HWruXzjJl1CAhnuCa8FnDaU+tmEKjYpWuelx85kolpMW7LT5gOFZr84MIj -Kq3Rt2hU6qQ7Cdy1ep531YKkmyh9Y4l/Tgir1OtnQQqtNuwHI497l7qAUnKZBBHZ -guApjS9BoHsRXkw2mgDssZ+khOwj/xJm876nFSiQeCD0aIbU/4zJ9e2HUOJAZI1r -d7QeSi4gUi4gSGFja2VyIDxqcmhAZXhhbXBsZS5jb20+iQE4BBMBAgAiBQJSTQfI -AhsDBgsJCAcDAgYVCAIJCgsEFgIDAQIeAQIXgAAKCRC2lUCGCRiV626FB/4kDIdi -FNk3GOrRRiWKS4tfwS1htdc8H7TcnQHvdIzMRqLleyJNTYAPGrHCvum95UrUg1/4 -gYuKJcGVCr7gNI69BjjEt+nnyNM5hFXUQK+Vcr8m29U7C59dEQANrJ1/2X8xTEDk -bY88FYi5CSeHfKw9KzHrw4lLM0cXCSUufQMpzhaWgT8YsOlPOKacKDtAbO5SjciK -WmN3LwS9N0jl3ePH+YYkjAiCgH5hmDLFI8z4aMPCHkMTAPs57E2qprtHKeeZTR6m -aVjKL1S58IcvCCKIQjOOlaLr6IX4JDjlkAqdyi8HJ6chS/vcnciY652uyyR4AcGZ -qGWO/WF7q5X0SCPZ -=5FZK +lQG7BGFQyDcRBACmAI6cfY3fM02vb9JtC1BS19boKXbBsDoVrD9qRf8tDFROOpO3 +ZMlbuz+O9Vnljo6Y4WZGnyeWWAMqCditMOfr1cLbux77wSrmAVgZ9exwtGzkmUhM +xcptzKuyod8NuhghXbJgVbfJZ6HlBkk4kiWv98iJQwUBZJfjBUfIv+acjwCg4M2i +Ifu2A3UYl9VqF7qfcDOZudEEAI7V35yfsBDnr9ndKqdGYNw0alX9BEG3KwnAe0fF +O1jDVW12Y/bwnyyrRTrz6o1G8dj7M4XVZQb5PpT9mpNzOSZ6yxqhg+foeJwn2JkD +vyP+kMYU7SZ/tWuMOCdzN95Ki1rf+ti7pLnSMqKx+t3vOWwQbtnsbI6RCLLwETPA +esghA/0X3Dw7cdiE5Xq4TRaPSGViCWP4ekL2KYKqmKv6M/4f2pgFNJY7C+2SIiiP +T62zFlIjs5tF2Df34/M5mh4Vx6E8341r55+XO++kfFWJ5QjLiydRAY6ochG9IFgB +xyBCkCNpiby9PpKyPodedBScdMxIAe4eJR7rG/j9gFC1MypBugAAn0mvGeJi+oSo +5jXAeXBhRiTyI5WPCuK0J0pvaG5ueSBSb2NrZXRzIDxqb2hubnkucm9ja2V0c0Bn +Znkub3JnPoh4BBMRAgA4FiEESFc9Qz85uERAyFzbZbUBuQAr+pcFAmFQyDcCGwMF +CwkIBwIGFQoJCAsCBBYCAwECHgECF4AACgkQZbUBuQAr+peImQCgqpXa6EWB+71M +1VdFL9TXA1XKS54AoJhKC1cRiyksAxFzaqo0Q8w0aUXo +=cyQm -----END PGP PRIVATE KEY BLOCK----- diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el new file mode 100644 index 00000000000..724f88ec9ea --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el @@ -0,0 +1,12 @@ +;;; macro-builtin-aux.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> + +;;; Code: + +(defun macro-builtin-aux-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(provide 'macro-builtin-aux) +;;; macro-builtin-aux.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el new file mode 100644 index 00000000000..828968a0576 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el @@ -0,0 +1,21 @@ +;;; macro-builtin.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> +;; Keywords: tools +;; Version: 1.0 + +;;; Code: + +(require 'macro-builtin-aux) + +(defmacro macro-builtin-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(defun macro-builtin-func () + "" + (macro-builtin-1 'a 'b) + (macro-builtin-aux-1 'a 'b)) + +(provide 'macro-builtin) +;;; macro-builtin.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el new file mode 100644 index 00000000000..9f257d9d22c --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el @@ -0,0 +1,16 @@ +;;; macro-builtin-aux.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> + +;;; Code: + +(defmacro macro-builtin-aux-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(defmacro macro-builtin-aux-3 ( &rest _) + "Description" + 90) + +(provide 'macro-builtin-aux) +;;; macro-builtin-aux.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el new file mode 100644 index 00000000000..5d241c082d0 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el @@ -0,0 +1,30 @@ +;;; macro-builtin.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> +;; Keywords: tools +;; Version: 2.0 + +;;; Code: + +(require 'macro-builtin-aux) + +(defmacro macro-builtin-1 ( &rest forms) + "Description" + `(progn ,(cadr (car forms)))) + + +(defun macro-builtin-func () + "" + (list (macro-builtin-1 '1 'b) + (macro-builtin-aux-1 'a 'b))) + +(defmacro macro-builtin-3 (&rest _) + "Description" + 10) + +(defun macro-builtin-10-and-90 () + "" + (list (macro-builtin-3 haha) (macro-builtin-aux-3 hehe))) + +(provide 'macro-builtin) +;;; macro-builtin.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-aux.el b/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-aux.el index f43232224af..ad20a3507a6 100644 --- a/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-aux.el +++ b/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-aux.el @@ -5,7 +5,7 @@ ;;; Code: (defun macro-aux-1 ( &rest forms) - "Description" + "Description." `(progn ,@forms)) (provide 'macro-aux) diff --git a/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-problem.el b/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-problem.el index 0533b1bd9c4..6e5e54e54fd 100644 --- a/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-problem.el +++ b/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-problem.el @@ -9,11 +9,11 @@ (require 'macro-aux) (defmacro macro-problem-1 ( &rest forms) - "Description" + "Description." `(progn ,@forms)) (defun macro-problem-func () - "" + "Description." (macro-problem-1 'a 'b) (macro-aux-1 'a 'b)) diff --git a/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-aux.el b/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-aux.el index 6a55a40e3b4..814d77183ab 100644 --- a/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-aux.el +++ b/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-aux.el @@ -5,11 +5,11 @@ ;;; Code: (defmacro macro-aux-1 ( &rest forms) - "Description" + "Description." `(progn ,@forms)) (defmacro macro-aux-3 ( &rest _) - "Description" + "Description." 90) (provide 'macro-aux) diff --git a/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-problem.el b/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-problem.el index cad4ed93f19..aef5eda7c6c 100644 --- a/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-problem.el +++ b/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-problem.el @@ -9,21 +9,21 @@ (require 'macro-aux) (defmacro macro-problem-1 ( &rest forms) - "Description" + "Description." `(progn ,(cadr (car forms)))) (defun macro-problem-func () - "" + "Description." (list (macro-problem-1 '1 'b) (macro-aux-1 'a 'b))) (defmacro macro-problem-3 (&rest _) - "Description" + "Description." 10) (defun macro-problem-10-and-90 () - "" + "Description." (list (macro-problem-3 haha) (macro-aux-3 hehe))) (provide 'macro-problem) diff --git a/test/lisp/emacs-lisp/package-resources/newer-versions/new-pkg-1.0.el b/test/lisp/emacs-lisp/package-resources/newer-versions/new-pkg-1.0.el index 7251622fa59..61c1b045990 100644 --- a/test/lisp/emacs-lisp/package-resources/newer-versions/new-pkg-1.0.el +++ b/test/lisp/emacs-lisp/package-resources/newer-versions/new-pkg-1.0.el @@ -1,4 +1,4 @@ -;;; new-pkg.el --- A package only seen after "updating" archive-contents +;;; new-pkg.el --- A package only seen after "updating" archive-contents -*- lexical-binding:t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.0 diff --git a/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el b/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el index 7b1c00c06db..be6bedf8a1c 100644 --- a/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el +++ b/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el @@ -1,4 +1,4 @@ -;;; simple-single.el --- A single-file package with no dependencies +;;; simple-single.el --- A single-file package with no dependencies -*- lexical-binding:t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.4 @@ -7,14 +7,14 @@ ;;; Commentary: ;; This package provides a minor mode to frobnicate and/or bifurcate -;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" +;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" ;; and all your dreams will come true. ;; ;; This is a new, updated version. ;;; Code: -(defgroup simple-single nil "Simply a file" +(defgroup simple-single nil "Simply a file." :group 'lisp) (defcustom simple-single-super-sunday nil @@ -29,7 +29,7 @@ Default changed to nil." ;;;###autoload (define-minor-mode simple-single-mode - "It does good things to stuff") + "It does good things to stuff.") (provide 'simple-single) diff --git a/test/lisp/emacs-lisp/package-resources/signed/archive-contents.sig b/test/lisp/emacs-lisp/package-resources/signed/archive-contents.sig Binary files differindex 658edd3f60e..b40620a0e89 100644 --- a/test/lisp/emacs-lisp/package-resources/signed/archive-contents.sig +++ b/test/lisp/emacs-lisp/package-resources/signed/archive-contents.sig diff --git a/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el b/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el index 3734823876e..781077251e9 100644 --- a/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el +++ b/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el @@ -1,4 +1,4 @@ -;;; signed-bad.el --- A single-file package with bad signature +;;; signed-bad.el --- A single-file package with bad signature -*- lexical-binding: t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.0 @@ -8,12 +8,12 @@ ;;; Commentary: ;; This package provides a minor mode to frobnicate and/or bifurcate -;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" +;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" ;; and all your dreams will come true. ;;; Code: -(defgroup signed-bad nil "Simply a file" +(defgroup signed-bad nil "Simply a file." :group 'lisp) (defcustom signed-bad-super-sunday t @@ -26,7 +26,7 @@ ;;;###autoload (define-minor-mode signed-bad-mode - "It does good things to stuff") + "It does good things to stuff.") (provide 'signed-bad) diff --git a/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el b/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el index 22718df2763..8a408c1f301 100644 --- a/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el +++ b/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el @@ -1,4 +1,4 @@ -;;; signed-good.el --- A single-file package with good signature +;;; signed-good.el --- A single-file package with good signature -*- lexical-binding: t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.0 @@ -8,12 +8,12 @@ ;;; Commentary: ;; This package provides a minor mode to frobnicate and/or bifurcate -;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" +;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" ;; and all your dreams will come true. ;;; Code: -(defgroup signed-good nil "Simply a file" +(defgroup signed-good nil "Simply a file." :group 'lisp) (defcustom signed-good-super-sunday t @@ -26,7 +26,7 @@ ;;;###autoload (define-minor-mode signed-good-mode - "It does good things to stuff") + "It does good things to stuff.") (provide 'signed-good) diff --git a/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el.sig b/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el.sig Binary files differindex 747918794ca..11092411601 100644 --- a/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el.sig +++ b/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el.sig diff --git a/test/lisp/emacs-lisp/package-resources/signed/update-signatures.sh b/test/lisp/emacs-lisp/package-resources/signed/update-signatures.sh new file mode 100755 index 00000000000..c3e82fd1737 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/signed/update-signatures.sh @@ -0,0 +1,32 @@ +#! /bin/sh + +# Generate a new key and update the signatures for tests. + +# Copyright (C) 2020-2022 Free Software Foundation, Inc. + +# This file is part of GNU Emacs. + +# GNU Emacs is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. + +# GNU Emacs is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +export GPG_AGENT="" +KEYRING="./key.ring" +TRUSTDB="./trust.db" +GPG="gpg --no-default-keyring --trustdb-name $TRUSTDB --keyring $KEYRING --yes" + +rm $KEYRING +$GPG --full-generate-key +$GPG --export --armor > "../key.pub" +$GPG --export-secret-keys -armor > "../key.sec" +$GPG --detach-sign --sign "./archive-contents" +$GPG --detach-sign --sign "./signed-good-1.0.el" diff --git a/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el b/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el index b58b658d024..f1ee8627610 100644 --- a/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el +++ b/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el @@ -1,4 +1,4 @@ -;;; simple-depend.el --- A single-file package with a dependency. +;;; simple-depend.el --- A single-file package with a dependency. -*- lexical-binding:t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.0 @@ -12,6 +12,6 @@ ;;; Code: (defvar simple-depend "Value" - "Some trivial code") + "Some trivial code.") ;;; simple-depend.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el b/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el index 6756a28080b..459801d78cf 100644 --- a/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el +++ b/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el @@ -1,4 +1,4 @@ -;;; simple-single.el --- A single-file package with no dependencies +;;; simple-single.el --- A single-file package with no dependencies -*- lexical-binding:t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.3 @@ -8,12 +8,12 @@ ;;; Commentary: ;; This package provides a minor mode to frobnicate and/or bifurcate -;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" +;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" ;; and all your dreams will come true. ;;; Code: -(defgroup simple-single nil "Simply a file" +(defgroup simple-single nil "Simply a file." :group 'lisp) (defcustom simple-single-super-sunday t @@ -26,7 +26,7 @@ ;;;###autoload (define-minor-mode simple-single-mode - "It does good things to stuff") + "It does good things to stuff.") (provide 'simple-single) diff --git a/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el b/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el index 9cfe5c0d4e2..8de6141d67a 100644 --- a/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el +++ b/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el @@ -1,4 +1,4 @@ -;;; simple-two-depend.el --- A single-file package with two dependencies. +;;; simple-two-depend.el --- A single-file package with two dependencies. -*- lexical-binding:t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.1 @@ -12,6 +12,6 @@ ;;; Code: (defvar simple-two-depend "Value" - "Some trivial code") + "Some trivial code.") ;;; simple-two-depend.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/with-nil-entry/archive-contents b/test/lisp/emacs-lisp/package-resources/with-nil-entry/archive-contents new file mode 100644 index 00000000000..03e6aa7f7c6 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/with-nil-entry/archive-contents @@ -0,0 +1,8 @@ +(1 + (foo . + [(1 0) + nil "foo package" single]) + nil + (bar . + [(1 0) + nil "bar package" single])) diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index 33209d3d990..b903cd781ba 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -1,6 +1,6 @@ -;;; package-test.el --- Tests for the Emacs package system +;;; package-tests.el --- Tests for the Emacs package system -*- lexical-binding:t -*- -;; Copyright (C) 2013-2017 Free Software Foundation, Inc. +;; Copyright (C) 2013-2022 Free Software Foundation, Inc. ;; Author: Daniel Hackney <dan@haxney.org> ;; Version: 1.0 @@ -28,12 +28,18 @@ ;; Run this in a clean Emacs session using: ;; -;; $ emacs -Q --batch -L . -l package-test.el -l ert -f ert-run-tests-batch-and-exit +;; $ emacs -Q --batch -L . -l package-tests.el -l ert -f ert-run-tests-batch-and-exit +;; +;; From the top level directory of the Emacs development repository, +;; you can use this instead: +;; +;; $ make -C test package-tests ;;; Code: (require 'package) (require 'ert) +(require 'ert-x) (require 'cl-lib) (setq package-menu-async nil) @@ -97,13 +103,9 @@ (multi-file (0 1)))) "`package-desc' used for testing dependencies.") -(defvar package-test-data-dir (expand-file-name "package-resources" package-test-file-dir) +(defvar package-test-data-dir (ert-resource-directory) "Base directory of package test files.") -(defvar package-test-fake-contents-file - (expand-file-name "archive-contents" package-test-data-dir) - "Path to a static copy of \"archive-contents\".") - (cl-defmacro with-package-test ((&optional &key file basedir install @@ -112,52 +114,60 @@ upload-base) &rest body) "Set up temporary locations and variables for testing." - (declare (indent 1)) - `(let* ((package-test-user-dir (make-temp-file "pkg-test-user-dir-" t)) - (process-environment (cons (format "HOME=%s" package-test-user-dir) - process-environment)) - (package-user-dir package-test-user-dir) - (package-gnupghome-dir (expand-file-name "gnupg" package-user-dir)) - (package-archives `(("gnu" . ,(or ,location package-test-data-dir)))) - (default-directory package-test-file-dir) - abbreviated-home-dir - package--initialized - package-alist - ,@(if update-news - '(package-update-news-on-upload t) - (list (cl-gensym))) - ,@(if upload-base - '((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t)) - (package-archive-upload-base package-test-archive-upload-base)) - (list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind nil - (let ((buf (get-buffer "*Packages*"))) - (when (buffer-live-p buf) - (kill-buffer buf))) - (unwind-protect - (progn - ,(if basedir `(cd ,basedir)) - (unless (file-directory-p package-user-dir) - (mkdir package-user-dir)) - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest r) t)) - ((symbol-function 'y-or-n-p) (lambda (&rest r) t))) - ,@(when install - `((package-initialize) - (package-refresh-contents) - (mapc 'package-install ,install))) - (with-temp-buffer - ,(if file - `(insert-file-contents ,file)) - ,@body))) - - (when (file-directory-p package-test-user-dir) - (delete-directory package-test-user-dir t)) - - (when (and (boundp 'package-test-archive-upload-base) - (file-directory-p package-test-archive-upload-base)) - (delete-directory package-test-archive-upload-base t))))) + (declare (indent 1) (debug (([&rest form]) body))) + `(ert-with-temp-directory package-test-user-dir + (let* ((process-environment (cons (format "HOME=%s" package-test-user-dir) + process-environment)) + (package-user-dir package-test-user-dir) + (package-gnupghome-dir (expand-file-name "gnupg" package-user-dir)) + (package-archives `(("gnu" . ,(or ,location package-test-data-dir)))) + (default-directory package-test-file-dir) + abbreviated-home-dir + package--initialized + package-alist + ,@(if update-news + '(package-update-news-on-upload t) + (list (cl-gensym))) + ,@(if upload-base + '((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t)) + (package-archive-upload-base package-test-archive-upload-base)) + (list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind nil + (let ((buf (get-buffer "*Packages*"))) + (when (buffer-live-p buf) + (kill-buffer buf))) + (unwind-protect + (progn + ,(if basedir `(cd ,basedir)) + (unless (file-directory-p package-user-dir) + (mkdir package-user-dir)) + (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t)) + ((symbol-function 'y-or-n-p) (lambda (&rest _) t))) + ,@(when install + `((package-initialize) + (package-refresh-contents) + (mapc 'package-install ,install))) + (with-temp-buffer + ,(if file + `(insert-file-contents ,file)) + ,@body))) + + (when ,upload-base + (dolist (f '("archive-contents" + "simple-single-1.3.el" + "simple-single-1.4.el" + "simple-single-readme.txt")) + (ignore-errors + (delete-file + (expand-file-name f package-test-archive-upload-base)))) + (delete-directory package-test-archive-upload-base)) + + (when (and (boundp 'package-test-archive-upload-base) + (file-directory-p package-test-archive-upload-base)) + (delete-directory package-test-archive-upload-base t)))))) (defmacro with-fake-help-buffer (&rest body) "Execute BODY in a temp buffer which is treated as the \"*Help*\" buffer." + (declare (debug body)) `(with-temp-buffer (help-mode) ;; Trick `help-buffer' into using the temp buffer. @@ -168,10 +178,9 @@ (replace-regexp-in-string "-pkg\\.el\\'" "" (package--description-file dir))) (defun package-test-suffix-matches (base suffix-list) - "Return file names matching BASE concatenated with each item in SUFFIX-LIST" - (cl-mapcan - '(lambda (item) (file-expand-wildcards (concat base item))) - suffix-list)) + "Return file names matching BASE concatenated with each item in SUFFIX-LIST." + (mapcan (lambda (item) (file-expand-wildcards (concat base item))) + suffix-list)) (defvar tar-parse-info) (declare-function tar-header-name "tar-mode" (cl-x) t) ; defstruct @@ -189,20 +198,41 @@ Must called from within a `tar-mode' buffer." "Return the package version as a string." (package-version-join (package-desc-version desc))) +(defun package-test--compatible-p (pkg-desc pkg-sample &optional kind) + (and (cl-every (lambda (f) + (equal (funcall f pkg-desc) + (funcall f pkg-sample))) + (cons (if kind #'package-desc-kind #'ignore) + '(package-desc-name + package-desc-version + package-desc-summary + package-desc-reqs + package-desc-archive + package-desc-dir + package-desc-signed))) + ;; The `extras' field should contain at least the specified elements. + (let ((extras (package-desc-extras pkg-desc)) + (extras-sample (package-desc-extras pkg-sample))) + (cl-every (lambda (sample-elem) + (member sample-elem extras)) + extras-sample)))) + (ert-deftest package-test-desc-from-buffer () "Parse an elisp buffer to get a `package-desc' object." - (with-package-test (:basedir "package-resources" :file "simple-single-1.3.el") - (should (equal (package-buffer-info) simple-single-desc))) - (with-package-test (:basedir "package-resources" :file "simple-depend-1.0.el") - (should (equal (package-buffer-info) simple-depend-desc))) - (with-package-test (:basedir "package-resources" + (with-package-test (:basedir (ert-resource-directory) :file "simple-single-1.3.el") + (should (package-test--compatible-p + (package-buffer-info) simple-single-desc 'kind))) + (with-package-test (:basedir (ert-resource-directory) :file "simple-depend-1.0.el") + (should (package-test--compatible-p + (package-buffer-info) simple-depend-desc 'kind))) + (with-package-test (:basedir (ert-resource-directory) :file "multi-file-0.2.3.tar") (tar-mode) (should (equal (package-tar-file-info) multi-file-desc)))) (ert-deftest package-test-install-single () "Install a single file without using an archive." - (with-package-test (:basedir "package-resources" :file "simple-single-1.3.el") + (with-package-test (:basedir (ert-resource-directory) :file "simple-single-1.3.el") (should (package-install-from-buffer)) (package-initialize) (should (package-installed-p 'simple-single)) @@ -222,18 +252,83 @@ Must called from within a `tar-mode' buffer." (with-temp-buffer (insert-file-contents (expand-file-name "simple-single-pkg.el" simple-pkg-dir)) - (should (string= (buffer-string) - (concat ";;; -*- no-byte-compile: t -*-\n" - "(define-package \"simple-single\" \"1.3\" " - "\"A single-file package " - "with no dependencies\" 'nil " - ":authors '((\"J. R. Hacker\" . \"jrh@example.com\")) " - ":maintainer '(\"J. R. Hacker\" . \"jrh@example.com\") " - ":url \"http://doodles.au\"" - ")\n")))) + (goto-char (point-min)) + (let ((sexp (read (current-buffer)))) + (should (eq (car-safe sexp) 'define-package)) + (should (package-test--compatible-p + (apply #'package-desc-from-define (cdr sexp)) + simple-single-desc)))) (should (file-exists-p autoloads-file)) (should-not (get-file-buffer autoloads-file))))) +(ert-deftest package-test-install-file () + "Install files with `package-install-file'." + (with-package-test (:basedir (ert-resource-directory)) + (package-initialize) + (let* ((pkg-el "simple-single-1.3.el") + (source-file (expand-file-name pkg-el (ert-resource-directory)))) + (should-not (package-installed-p 'simple-single)) + (package-install-file source-file) + (should (package-installed-p 'simple-single)) + (package-delete (cadr (assq 'simple-single package-alist))) + (should-not (package-installed-p 'simple-single))) + + (let* ((pkg-el "multi-file-0.2.3.tar") + (source-file (expand-file-name pkg-el (ert-resource-directory)))) + (package-initialize) + (should-not (package-installed-p 'multie-file)) + (package-install-file source-file) + (should (package-installed-p 'multi-file)) + (package-delete (cadr (assq 'multi-file package-alist)))) + )) + +(ert-deftest package-test-install-file-EOLs () + "Install same file multiple time with `package-install-file' +but with a different end of line convention (bug#48137)." + (with-package-test (:basedir (ert-resource-directory)) + (package-initialize) + (let* ((pkg-el "simple-single-1.3.el") + (source-file (expand-file-name pkg-el (ert-resource-directory)))) + + (with-temp-buffer + (insert-file-contents source-file) + + (let (hashes) + (dolist (coding '(unix dos mac) hashes) + (let* ((eol-file (expand-file-name pkg-el package-test-user-dir))) + ;; save package with this EOL convention. + (set-buffer-file-coding-system coding) + (write-region (point-min) (point-max) eol-file) + + (should-not (package-installed-p 'simple-single)) + (package-install-file eol-file) + (should (package-installed-p 'simple-single)) + + ;; check the package file has been installed unmodified. + (let ((eol-hash (with-temp-buffer + (insert-file-contents-literally eol-file) + (buffer-hash)))) + ;; also perform an additional check that the package + ;; file created with this EOL convention is different + ;; than all the others created so far. + (should-not (member eol-hash hashes)) + (setq hashes (cons eol-hash hashes)) + + (let* ((descr (cadr (assq 'simple-single package-alist))) + (pkg-dir (package-desc-dir descr)) + (dest-file (expand-file-name "simple-single.el" pkg-dir )) + (dest-hash (with-temp-buffer + (insert-file-contents-literally dest-file) + (buffer-hash)))) + + (should (string= dest-hash eol-hash)))) + + (package-delete (cadr (assq 'simple-single package-alist))) + (should-not (package-installed-p 'simple-single)) + (delete-file eol-file) + (should-not (file-exists-p eol-file)) + ))))))) + (ert-deftest package-test-install-dependency () "Install a package which includes a dependency." (with-package-test () @@ -243,9 +338,16 @@ Must called from within a `tar-mode' buffer." (should (package-installed-p 'simple-single)) (should (package-installed-p 'simple-depend)))) +(declare-function macro-problem-func "macro-problem" ()) +(declare-function macro-problem-10-and-90 "macro-problem" ()) +(declare-function macro-builtin-func "macro-builtin" ()) +(declare-function macro-builtin-10-and-90 "macro-builtin" ()) + (ert-deftest package-test-macro-compilation () - "Install a package which includes a dependency." - (with-package-test (:basedir "package-resources") + "\"Activation has to be done before compilation, so that if we're + upgrading and macros have changed we load the new definitions + before compiling.\" -- package.el" + (with-package-test (:basedir (ert-resource-directory)) (package-install-file (expand-file-name "macro-problem-package-1.0/")) (require 'macro-problem) ;; `macro-problem-func' uses a macro from `macro-aux'. @@ -257,6 +359,32 @@ Must called from within a `tar-mode' buffer." ;; `macro-problem-10-and-90' depends on an entirely new macro from `macro-aux'. (should (equal (macro-problem-10-and-90) '(10 90))))) +(ert-deftest package-test-macro-compilation-gz () + "Built-in's can be superseded as well." + (with-package-test (:basedir (ert-resource-directory)) + (let ((dir (expand-file-name "macro-builtin-package-1.0"))) + (unwind-protect + (let ((load-path load-path)) + (add-to-list 'load-path (directory-file-name dir)) + (byte-recompile-directory dir 0 t) + (mapc (lambda (f) (call-process "gzip" nil nil nil f)) + (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")) + (require 'macro-builtin) + (should (member (expand-file-name "macro-builtin-aux.elc" dir) + (mapcar #'car load-history))) + ;; `macro-builtin-func' uses a macro from `macro-aux'. + (should (equal (macro-builtin-func) '(progn a b))) + (package-install-file (expand-file-name "macro-builtin-package-2.0/")) + ;; After upgrading, `macro-builtin-func' depends on a new version + ;; of the macro from `macro-builtin-aux'. + (should (equal (macro-builtin-func) '(1 b))) + ;; `macro-builtin-10-and-90' depends on an entirely new macro from `macro-aux'. + (should (equal (macro-builtin-10-and-90) '(10 90)))) + (mapc #'delete-file + (directory-files-recursively dir "\\`[^\\.].*\\.elc\\'")) + (mapc (lambda (f) (call-process "gunzip" nil nil nil f)) + (directory-files-recursively dir "\\`[^\\.].*\\.el\\.gz\\'")))))) + (ert-deftest package-test-install-two-dependencies () "Install a package which includes a dependency." (with-package-test () @@ -284,8 +412,7 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-test-install-prioritized () "Install a lower version from a higher-prioritized archive." (with-package-test () - (let* ((newer-version (expand-file-name "package-resources/newer-versions" - package-test-file-dir)) + (let* ((newer-version (ert-resource-file "newer-versions")) (package-archives `(("older" . ,package-test-data-dir) ("newer" . ,newer-version))) (package-archive-priorities '(("older" . 100)))) @@ -300,7 +427,7 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-test-install-multifile () "Check properties of the installed multi-file package." - (with-package-test (:basedir "package-resources" :install '(multi-file)) + (with-package-test (:basedir (ert-resource-directory) :install '(multi-file)) (let ((autoload-file (expand-file-name "multi-file-autoloads.el" (expand-file-name @@ -325,35 +452,130 @@ Must called from within a `tar-mode' buffer." (goto-char (point-min)) (should (re-search-forward re nil t))))))) + +;;; Package Menu tests + +(defmacro with-package-menu-test (&rest body) + "Set up Package Menu (\"*Packages*\") buffer for testing." + (declare (indent 0) (debug (([&rest form]) body))) + `(with-package-test () + (let ((buf (package-list-packages))) + (unwind-protect + (progn ,@body) + (kill-buffer buf))))) + (ert-deftest package-test-update-listing () "Ensure installed package status is updated." + (with-package-menu-test + (search-forward-regexp "^ +simple-single") + (package-menu-mark-install) + (package-menu-execute) + (run-hooks 'post-command-hook) + (should (package-installed-p 'simple-single)) + (switch-to-buffer "*Packages*") + (goto-char (point-min)) + (should (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+installed" nil t)) + (goto-char (point-min)) + (should-not (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+\\(available\\|new\\)" nil t)))) + +(ert-deftest package-test-list-filter-by-archive () + "Ensure package list is filtered correctly by archive version." + (with-package-menu-test + ;; TODO: Add another package archive to test filtering, because + ;; the testing environment currently only has one. + (package-menu-filter-by-archive "gnu") + (goto-char (point-min)) + (should (looking-at "^\\s-+multi-file")) + (should (= (count-lines (point-min) (point-max)) 4)) + (should-error (package-menu-filter-by-archive "non-existent archive")))) + +(ert-deftest package-test-list-filter-by-keyword () + "Ensure package list is filtered correctly by package keyword." + (with-package-menu-test + (package-menu-filter-by-keyword "frobnicate") + (goto-char (point-min)) + (should (re-search-forward "^\\s-+simple-single" nil t)) + (should (= (count-lines (point-min) (point-max)) 1)) + (should-error (package-menu-filter-by-keyword "non-existent-keyword")))) + +(ert-deftest package-test-list-filter-by-name () + "Ensure package list is filtered correctly by package name." + (with-package-menu-test () + (package-menu-filter-by-name "ansi-color") + (goto-char (point-min)) + (should (re-search-forward "^\\s-+ansi-color" nil t)) + (should (= (count-lines (point-min) (point-max)) 1)))) + +(ert-deftest package-test-list-filter-by-status () + "Ensure package list is filtered correctly by package status." + (with-package-menu-test + (package-menu-filter-by-status "available") + (goto-char (point-min)) + (should (re-search-forward "^\\s-+multi-file" nil t)) + (should (= (count-lines (point-min) (point-max)) 4)) + ;; No installed packages in default environment. + (should-error (package-menu-filter-by-status "installed")))) + +(ert-deftest package-test-list-filter-marked () + "Ensure package list is filtered correctly by non-empty mark." (with-package-test () - (let ((buf (package-list-packages))) - (search-forward-regexp "^ +simple-single") - (package-menu-mark-install) - (package-menu-execute) - (run-hooks 'post-command-hook) - (should (package-installed-p 'simple-single)) - (switch-to-buffer "*Packages*") - (goto-char (point-min)) - (should (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+installed" nil t)) - (goto-char (point-min)) - (should-not (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+\\(available\\|new\\)" nil t)) - (kill-buffer buf)))) + (package-list-packages) + (revert-buffer) + (search-forward-regexp "^ +simple-single") + (package-menu-mark-install) + (package-menu-filter-marked) + (goto-char (point-min)) + (should (re-search-forward "^I +simple-single" nil t)) + (should (= (count-lines (point-min) (point-max)) 1)) + (package-menu-mark-unmark) + ;; No marked packages in default environment. + (should-error (package-menu-filter-marked)))) + +(ert-deftest package-test-list-filter-by-version () + (with-package-menu-test + (should-error (package-menu-filter-by-version "1.1" 'unknown-symbol))) ) + +(defun package-test-filter-by-version (version predicate name) + (with-package-menu-test + (package-menu-filter-by-version version predicate) + (goto-char (point-min)) + ;; We just check that the given package is included in the + ;; listing. One could be more ambitious. + (should (re-search-forward name)))) + +(ert-deftest package-test-list-filter-by-version-= () + "Ensure package list is filtered correctly by package version (=)." + (package-test-filter-by-version "1.1" '= "^\\s-+simple-two-depend")) + +(ert-deftest package-test-list-filter-by-version-< () + "Ensure package list is filtered correctly by package version (<)." + (package-test-filter-by-version "1.2" '< "^\\s-+simple-two-depend")) + +(ert-deftest package-test-list-filter-by-version-> () + "Ensure package list is filtered correctly by package version (>)." + (package-test-filter-by-version "1.0" '> "^\\s-+simple-two-depend")) + +(ert-deftest package-test-list-clear-filter () + "Ensure package list filter is cleared correctly." + (with-package-menu-test + (let ((num-packages (count-lines (point-min) (point-max)))) + (package-menu-filter-by-name "ansi-color") + (should (= (count-lines (point-min) (point-max)) 1)) + (package-menu-clear-filter) + (should (= (count-lines (point-min) (point-max)) num-packages))))) (ert-deftest package-test-update-archives () "Test updating package archives." (with-package-test () - (let ((buf (package-list-packages))) - (package-menu-refresh) + (let ((_buf (package-list-packages))) + (revert-buffer) (search-forward-regexp "^ +simple-single") (package-menu-mark-install) (package-menu-execute) (should (package-installed-p 'simple-single)) - (let ((package-test-data-dir - (expand-file-name "package-resources/newer-versions" package-test-file-dir))) + (let ((package-test-data-dir (ert-resource-file "newer-versions"))) (setq package-archives `(("gnu" . ,package-test-data-dir))) - (package-menu-refresh) + (revert-buffer) ;; New version should be available and old version should be installed (goto-char (point-min)) @@ -365,11 +587,12 @@ Must called from within a `tar-mode' buffer." (package-menu-mark-upgrades) (package-menu-execute) - (package-menu-refresh) + (revert-buffer) (should (package-installed-p 'simple-single '(1 4))))))) (ert-deftest package-test-update-archives-async () "Test updating package archives asynchronously." + :tags '(:expensive-test) (skip-unless (executable-find "python2")) (let* ((package-menu-async t) (default-directory package-test-data-dir) @@ -389,7 +612,7 @@ Must called from within a `tar-mode' buffer." (when (re-search-forward "Server started, \\(.*\\)\n" nil t) (setq addr (match-string 1)))) addr))) - (with-package-test (:basedir package-test-data-dir :location addr) + (with-package-test (:basedir (ert-resource-directory) :location addr) (list-packages) (should package--downloads-in-progress) (should mode-line-process) @@ -406,6 +629,30 @@ Must called from within a `tar-mode' buffer." (search-forward-regexp "^ +simple-single" nil t)))) (if (process-live-p process) (kill-process process))))) +(ert-deftest package-test-update-archives/ignore-nil-entry () + "Ignore any packages that are nil. Test for Bug#28502." + (with-package-test () + (let* ((with-nil-entry (ert-resource-file "with-nil-entry")) + (package-archives `(("with-nil-entry" . ,with-nil-entry)))) + (package-initialize) + (package-refresh-contents) + (should (equal (length package-archive-contents) 2))))) + +(ert-deftest package-test-package-installed-p () + "Test package-installed-p before and after package initialization." + (with-package-test () + ;; Verify that `package-installed-p' evaluates true for a built-in + ;; package, in this case `project', before package initialization. + (should (not package--initialized)) + (should (package-installed-p 'project nil)) + (should (not (package-installed-p 'imaginary-package nil))) + + ;; The results don't change after package initialization. + (package-initialize) + (should package--initialized) + (should (package-installed-p 'project nil)) + (should (not (package-installed-p 'imaginary-package nil))))) + (ert-deftest package-test-describe-package () "Test displaying help for a package." @@ -414,7 +661,7 @@ Must called from within a `tar-mode' buffer." (with-fake-help-buffer (describe-package '5x5) (goto-char (point-min)) - (should (search-forward "5x5 is a built-in package." nil t)) + (should (search-forward "5x5 is built-in." nil t)) ;; Don't assume the descriptions are in any particular order. (save-excursion (should (search-forward "Status: Built-in." nil t))) (save-excursion (should (search-forward "Summary: simple little puzzle game" nil t))) @@ -428,17 +675,30 @@ Must called from within a `tar-mode' buffer." (with-fake-help-buffer (describe-package 'simple-single) (goto-char (point-min)) - (should (search-forward "simple-single is an installed package." nil t)) + (should (search-forward "Package simple-single is installed." nil t)) (save-excursion (should (re-search-forward "Status: Installed in ['`‘]simple-single-1.3/['’] (unsigned)." nil t))) (save-excursion (should (search-forward "Version: 1.3" nil t))) (save-excursion (should (search-forward "Summary: A single-file package with no dependencies" nil t))) - (save-excursion (should (search-forward "Homepage: http://doodles.au" nil t))) + (save-excursion (should (search-forward "Website: http://doodles.au" nil t))) (save-excursion (should (re-search-forward "Keywords: \\[?frobnicate\\]?" nil t))) - ;; No description, though. Because at this point we don't know - ;; what archive the package originated from, and we don't have - ;; its readme file saved. + (save-excursion (should (search-forward "This package provides a minor mode to frobnicate" + nil t))) ))) +(ert-deftest package-test-describe-installed-multi-file-package () + "Test displaying of the readme for installed multi-file package." + + (with-package-test () + (package-initialize) + (package-refresh-contents) + (package-install 'multi-file) + (with-fake-help-buffer + (describe-package 'multi-file) + (goto-char (point-min)) + (should (search-forward "Website: http://puddles.li" nil t)) + (should (search-forward "This is a bare-bones readme file for the multi-file" + nil t))))) + (ert-deftest package-test-describe-non-installed-package () "Test displaying of the readme for non-installed package." @@ -448,7 +708,7 @@ Must called from within a `tar-mode' buffer." (with-fake-help-buffer (describe-package 'simple-single) (goto-char (point-min)) - (should (search-forward "Homepage: http://doodles.au" nil t)) + (should (search-forward "Website: http://doodles.au" nil t)) (should (search-forward "This package provides a minor mode to frobnicate" nil t))))) @@ -461,40 +721,50 @@ Must called from within a `tar-mode' buffer." (with-fake-help-buffer (describe-package 'multi-file) (goto-char (point-min)) - (should (search-forward "Homepage: http://puddles.li" nil t)) + (should (search-forward "Website: http://puddles.li" nil t)) (should (search-forward "This is a bare-bones readme file for the multi-file" nil t))))) +(defvar epg-config--program-alist) ; Silence byte-compiler. (ert-deftest package-test-signed () "Test verifying package signature." - (skip-unless (ignore-errors - (let ((homedir (make-temp-file "package-test" t))) - (unwind-protect - (let ((process-environment - (cons (format "HOME=%s" homedir) - process-environment))) - (epg-check-configuration (epg-configuration)) - (epg-find-configuration 'OpenPGP)) - (delete-directory homedir t))))) + (skip-unless (ert-with-temp-directory homedir + (let ((process-environment + (cons (concat "HOME=" homedir) + process-environment))) + (require 'epg-config) + (defvar epg-config--program-alist) + (epg-find-configuration + 'OpenPGP nil + ;; By default we require gpg2 2.1+ due to some + ;; practical problems with pinentry. But this + ;; test works fine with 2.0 as well. + (let ((prog-alist (copy-tree epg-config--program-alist))) + (setf (alist-get "gpg2" + (alist-get 'OpenPGP prog-alist) + nil nil #'equal) + "2.0") + prog-alist))))) (let* ((keyring (expand-file-name "key.pub" package-test-data-dir)) - (package-test-data-dir - (expand-file-name "package-resources/signed" package-test-file-dir))) + (package-test-data-dir (ert-resource-file "signed"))) (with-package-test () (package-initialize) (package-import-keyring keyring) (package-refresh-contents) (let ((package-check-signature 'allow-unsigned)) - (should (package-install 'signed-good)) + (should (progn (package-install 'signed-good) 'noerror)) (should-error (package-install 'signed-bad))) + (package-delete (car (alist-get 'signed-good package-alist))) (let ((package-check-signature t)) - (should (package-install 'signed-good)) + (should (progn (package-install 'signed-good) 'noerror)) (should-error (package-install 'signed-bad))) + (package-delete (car (alist-get 'signed-good package-alist))) (let ((package-check-signature nil)) - (should (package-install 'signed-good)) - (should (package-install 'signed-bad))) + (should (progn (package-install 'signed-good) 'noerror)) + (should (progn (package-install 'signed-bad) 'noerror))) ;; Check if the installed package status is updated. - (let ((buf (package-list-packages))) - (package-menu-refresh) + (let ((_buf (package-list-packages))) + (revert-buffer) (should (re-search-forward "^\\s-+signed-good\\s-+\\(\\S-+\\)\\s-+\\(\\S-+\\)\\s-" nil t)) @@ -504,7 +774,7 @@ Must called from within a `tar-mode' buffer." (with-fake-help-buffer (describe-package 'signed-good) (goto-char (point-min)) - (should (re-search-forward "signed-good is an? \\(\\S-+\\) package." nil t)) + (should (re-search-forward "Package signed-good is \\(\\S-+\\)\\." nil t)) (should (string-equal (match-string-no-properties 1) "installed")) (should (re-search-forward "Status: Installed in ['`‘]signed-good-1.0/['’]." @@ -537,7 +807,7 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-x-test-upload-buffer () "Test creating an \"archive-contents\" file" - (with-package-test (:basedir "package-resources" + (with-package-test (:basedir (ert-resource-directory) :file "simple-single-1.3.el" :upload-base t) (package-upload-buffer) @@ -556,12 +826,21 @@ Must called from within a `tar-mode' buffer." (setq archive-contents (package-read-from-string (buffer-substring (point-min) (point-max))))) - (should (equal archive-contents - (list 1 package-x-test--single-archive-entry-1-3)))))) + (should (equal 1 (car archive-contents))) + (should (equal 2 (length archive-contents))) + (let ((pac (cadr archive-contents)) + (pac-sample package-x-test--single-archive-entry-1-3)) + (should (equal (pop pac) (pop pac-sample))) + (dotimes (i 4) + (should (equal (aref pac i) (aref pac-sample i)))) + ;; The `extras' field should contain at least the specified elements. + (should (cl-every (lambda (sample-elem) + (member sample-elem (aref pac 4))) + (aref pac-sample 4))))))) (ert-deftest package-x-test-upload-new-version () "Test uploading a new version of a package" - (with-package-test (:basedir "package-resources" + (with-package-test (:basedir (ert-resource-directory) :file "simple-single-1.3.el" :upload-base t) (package-upload-buffer) @@ -577,8 +856,17 @@ Must called from within a `tar-mode' buffer." (setq archive-contents (package-read-from-string (buffer-substring (point-min) (point-max))))) - (should (equal archive-contents - (list 1 package-x-test--single-archive-entry-1-4)))))) + (should (equal 1 (car archive-contents))) + (should (equal 2 (length archive-contents))) + (let ((pac (cadr archive-contents)) + (pac-sample package-x-test--single-archive-entry-1-4)) + (should (equal (pop pac) (pop pac-sample))) + (dotimes (i 4) + (should (equal (aref pac i) (aref pac-sample i)))) + ;; The `extras' field should contain at least the specified elements. + (should (cl-every (lambda (sample-elem) + (member sample-elem (aref pac 4))) + (aref pac-sample 4))))))) (ert-deftest package-test-get-deps () "Test `package--get-deps' with complex structures." @@ -589,25 +877,16 @@ Must called from within a `tar-mode' buffer." multi-file-desc new-pkg-desc simple-depend-desc-1 - simple-depend-desc-2)))) - (should - (equal (package--get-deps 'simple-depend) - '(simple-single))) - (should - (equal (package--get-deps 'simple-depend 'indirect) - nil)) - (should - (equal (package--get-deps 'simple-depend 'direct) - '(simple-single))) - (should - (equal (package--get-deps 'simple-depend-2) - '(simple-depend-1 multi-file simple-depend simple-single))) + simple-depend-desc-2))) + (pkg-cmp #'string-lessp)) (should - (equal (package--get-deps 'simple-depend-2 'indirect) - '(simple-depend multi-file simple-single))) + (equal (sort (package--get-deps '(simple-depend)) pkg-cmp) + (sort (list 'simple-depend 'simple-single) pkg-cmp))) (should - (equal (package--get-deps 'simple-depend-2 'direct) - '(simple-depend-1 multi-file))))) + (equal (sort (package--get-deps '(simple-depend-2)) pkg-cmp) + (sort (list 'simple-depend-2 'simple-depend-1 'multi-file + 'simple-depend 'simple-single) + pkg-cmp))))) (ert-deftest package-test-sort-by-dependence () "Test `package--sort-by-dependence' with complex structures." @@ -638,4 +917,4 @@ Must called from within a `tar-mode' buffer." (provide 'package-test) -;;; package-test.el ends here +;;; package-tests.el ends here diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index 3bd14ed4b42..80607990808 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -1,6 +1,6 @@ -;;; pcase-tests.el --- Test suite for pcase macro. +;;; pcase-tests.el --- Test suite for pcase macro. -*- lexical-binding:t -*- -;; Copyright (C) 2012-2017 Free Software Foundation, Inc. +;; Copyright (C) 2012-2022 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -32,6 +32,10 @@ (should (equal (pcase '(2 . 3) ;bug#18554 (`(,hd . ,(and (pred atom) tl)) (list hd tl)) ((pred consp) nil)) + '(2 3))) + (should (equal (pcase '(2 . 3) + (`(,hd . ,(and (pred (not consp)) tl)) (list hd tl)) + ((pred consp) nil)) '(2 3)))) (pcase-defmacro pcase-tests-plus (pat n) @@ -51,11 +55,15 @@ (ert-deftest pcase-tests-member () (should (pcase-tests-grep - 'memq (macroexpand-all '(pcase x ((or 1 2 3) body))))) + 'memq (macroexpand-all '(pcase x ((or 'a 'b 'c) body))))) + (should (pcase-tests-grep + 'memql (macroexpand-all '(pcase x ((or 1 2 3 'a) body))))) (should (pcase-tests-grep - 'member (macroexpand-all '(pcase x ((or '"a" '2 '3) body))))) + 'member (macroexpand-all '(pcase x ((or "a" 2 3 'a) body))))) (should-not (pcase-tests-grep 'memq (macroexpand-all '(pcase x ((or "a" 2 3) body))))) + (should-not (pcase-tests-grep + 'memql (macroexpand-all '(pcase x ((or "a" 2 3) body))))) (let ((exp (macroexpand-all '(pcase x ("a" body1) @@ -67,8 +75,89 @@ (ert-deftest pcase-tests-vectors () (should (equal (pcase [1 2] (`[,x] 1) (`[,x ,y] (+ x y))) 3))) -;; Local Variables: -;; no-byte-compile: t -;; End: +(ert-deftest pcase-tests-bug14773 () + (let ((f (lambda (x) + (pcase 'dummy + ((and (let var x) (guard var)) 'left) + ((and (let var (not x)) (guard var)) 'right))))) + (should (equal (funcall f t) 'left)) + (should (equal (funcall f nil) 'right)))) + +(ert-deftest pcase-tests-bug46786 () + (let ((self 'outer)) + (ignore self) + (should (equal (cl-macrolet ((show-self () `(list 'self self))) + (pcase-let ((`(,self ,_self2) '(inner "2"))) + (show-self))) + '(self inner))))) + +(ert-deftest pcase-tests-or-vars () + (let ((f (lambda (v) + (pcase v + ((or (and 'b1 (let x1 4) (let x2 5)) + (and 'b2 (let y1 8) (let y2 9))) + (list x1 x2 y1 y2)))))) + (should (equal (funcall f 'b1) '(4 5 nil nil))) + (should (equal (funcall f 'b2) '(nil nil 8 9))))) + +(ert-deftest pcase-tests-cl-type () + (should (equal (pcase 1 + ((cl-type integer) 'integer)) + 'integer)) + (should (equal (pcase 1 + ((cl-type (integer 0 2)) 'integer-0<=n<=2)) + 'integer-0<=n<=2)) + (should-error + ;; Avoid error at compile time due to compiler macro. + (eval '(pcase 1 + ((cl-type notatype) 'integer)) + t))) + +(ert-deftest pcase-tests-setq () + (should (equal (let (a b) + (pcase-setq `((,a) (,b)) '((1) (2))) + (list a b)) + (list 1 2))) + + (should (equal (list nil nil) + (let ((a 'unset) + (b 'unset)) + (pcase-setq `(head ,a ,b) nil) + (list a b)))) + + (should (equal (let (a b) + (pcase-setq `[,a ,b] [1 2]) + (list a b)) + '(1 2))) + + (should-error (let (a b) + (pcase-setq `[,a ,b] nil) + (list a b))) + + (should (equal (let (a b) + (pcase-setq a 1 b 2) + (list a b)) + '(1 2))) + + (should (= (let (a) + (pcase-setq a 1 `(,a) '(2)) + a) + 2)) + + (should (equal (let (array list-item array-copy) + (pcase-setq (or `(,list-item) array) [1 2 3] + array-copy array + ;; This re-sets `array' to nil. + (or `(,list-item) array) '(4)) + (list array array-copy list-item)) + '(nil [1 2 3] 4))) + + (let ((a nil)) + (should-error (pcase-setq a 1 b) + :type '(wrong-number-of-arguments)) + (should (eq a nil))) + + (should-error (pcase-setq a) + :type '(wrong-number-of-arguments))) ;;; pcase-tests.el ends here. diff --git a/test/lisp/emacs-lisp/pp-resources/code-formats.erts b/test/lisp/emacs-lisp/pp-resources/code-formats.erts new file mode 100644 index 00000000000..c3e3023cb19 --- /dev/null +++ b/test/lisp/emacs-lisp/pp-resources/code-formats.erts @@ -0,0 +1,142 @@ +Code: + (lambda () + (emacs-lisp-mode) + (let ((code (read (current-buffer)))) + (erase-buffer) + (pp-emacs-lisp-code code) + (untabify (point-min) (point-max)))) + +Name: code-formats1 + +=-= +(defun foo (bar) + "Yes." + (let ((a 1) + (b 2)) + (zot 1 2 (funcall bar 2)))) +=-=-= + + +Name: code-formats2 + +=-= +(defun pp-emacs-lisp-code (sexp) + "Insert SEXP into the current buffer, formatted as Emacs Lisp code." + (require 'edebug) + (let ((start (point)) + (standard-output (current-buffer))) + (pp--insert-lisp sexp) + (insert "\n") + (goto-char start) + (indent-sexp))) +=-=-= + + +Name: code-formats3 + +=-= +(defun foo (bar) + "Yes." + (let ((a 1) + (b 2)) + (zot-zot-zot-zot-zot-zot 1 2 (funcall + bar-bar-bar-bar-bar-bar-bar-bar-bar-bar + 2)))) +=-=-= + + +Name: code-formats4 + +=-= +(defun foo (bar) + "Yes." + (let ((a 1) + (b 2) + foo bar zotfoo bar zotfoo bar zotfoo bar zotfoo bar zotfoo bar zotfoo + bar zot) + (zot 1 2 (funcall bar 2)))) +=-=-= + + +Name: code-formats5 + +=-= +(defgroup pp () + "Pretty printer for Emacs Lisp." + :prefix "pp-" + :group 'lisp) +=-=-= + +Name: code-formats6 + +=-= +(defcustom pp-escape-newlines t + "Value of `print-escape-newlines' used by pp-* functions." + :type 'boolean + :group 'pp) +=-=-= + +Name: code-formats7 + +=-= +(defun pp (object &optional stream) + (princ (pp-to-string object) (or stream standard-output))) +=-=-= + + +Name: code-formats8 + +=-= +(defun pp-eval-expression (expression) + "Evaluate EXPRESSION and pretty-print its value. +Also add the value to the front of the list in the variable `values'." + (interactive (list (read--expression "Eval: "))) + (message "Evaluating...") + (let ((result (eval expression lexical-binding))) + (values--store-value result) + (pp-display-expression result "*Pp Eval Output*"))) +=-=-= + +Name: code-formats9 + +=-= +(lambda () + (interactive) + 1) +=-=-= + + +Name: code-formats10 + +=-= +(funcall foo (concat "zot" (if (length> site 0) site + "bar") + "+" + (string-replace " " "+" query))) +=-=-= + + +Name: code-formats11 + +=-= +(lambda () + [(foo bar) (foo bar)]) +=-=-= + +Name: code-formats12 + +=-= +(global-set-key (kbd "s-x") #'kill-region) +=-=-= + +Name: code-formats13 + +=-= +'("a") +=-=-= + +Name: code-formats14 + +=-= +'("a" . "b") +=-=-= diff --git a/test/lisp/emacs-lisp/pp-tests.el b/test/lisp/emacs-lisp/pp-tests.el index aed2d3770fb..01ac572c537 100644 --- a/test/lisp/emacs-lisp/pp-tests.el +++ b/test/lisp/emacs-lisp/pp-tests.el @@ -1,6 +1,6 @@ ;;; pp-tests.el --- Test suite for pretty printer. -*- lexical-binding: t -*- -;; Copyright (C) 2017 Free Software Foundation, Inc. +;; Copyright (C) 2017-2022 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -20,6 +20,7 @@ ;;; Code: (require 'pp) +(require 'ert-x) (ert-deftest pp-print-quote () (should (string= (pp-to-string 'quote) "quote")) @@ -32,4 +33,7 @@ (should (string= (pp-to-string '(quotefoo)) "(quotefoo)\n")) (should (string= (pp-to-string '(a b)) "(a b)\n"))) +(ert-deftest test-indentation () + (ert-test-erts-file (ert-resource-file "code-formats.erts"))) + ;;; pp-tests.el ends here. diff --git a/test/lisp/emacs-lisp/range-tests.el b/test/lisp/emacs-lisp/range-tests.el new file mode 100644 index 00000000000..660110aa1fb --- /dev/null +++ b/test/lisp/emacs-lisp/range-tests.el @@ -0,0 +1,65 @@ +;;; range-tests.el --- Tests for range.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'range) +(require 'ert) +(require 'ert-x) + +(ert-deftest ranges () + (should (equal (range-compress-list '(2 3 4 5 9 11 12 13)) + '((2 . 5) 9 (11 . 13)))) + (should (equal (range-uncompress '((2 . 5) 9 (11 . 13))) + '(2 3 4 5 9 11 12 13))) + (should (equal (range-normalize '(1 . 2)) + '((1 . 2)))) + (should (equal (range-difference '((1 . 10)) + '((2 . 7))) + '(1 (8 . 10)))) + (should (equal (range-intersection '((2 . 5) 9 (11 . 13)) + '((5 . 12))) + '(5 9 (11 . 12)))) + (should (equal (range-add-list '((2 . 5) 9 (11 . 13)) + '(10 11 12 15 16 17)) + '((2 . 5) (9 . 10) (11 . 13) (15 . 17)))) + (should (equal (range-remove (copy-tree '((2 . 5) 9 (11 . 13))) + '((5 . 9))) + '((2 . 4) (11 . 13)))) + (should (range-member-p 9 '((2 . 5) 9 (11 . 13)))) + (should (range-member-p 12 '((2 . 5) 9 (11 . 13)))) + (should (equal (range-list-intersection + '(4 5 6 7 8 9) + '((2 . 5) 9 (11 . 13))) + '(4 5 9))) + (should (equal (range-list-difference + '(4 5 6 7 8 9) + '((2 . 5) 9 (11 . 13))) + '(6 7 8))) + (should (equal (range-length '((2 . 5) 9 (11 . 13))) + 8)) + (should (equal (range-concat '((2 . 5) 9 (11 . 13)) + '(6 (12 . 15))) + '((2 . 6) 9 (11 . 15))))) + +;;; range-tests.el ends here diff --git a/test/lisp/emacs-lisp/regexp-opt-tests.el b/test/lisp/emacs-lisp/regexp-opt-tests.el index 4beb7bfa1ca..46ed7c29b28 100644 --- a/test/lisp/emacs-lisp/regexp-opt-tests.el +++ b/test/lisp/emacs-lisp/regexp-opt-tests.el @@ -1,6 +1,6 @@ -;;; regexp-tests.el --- Test suite for regular expression handling. +;;; regexp-opt-tests.el --- Tests for regexp-opt.el -*- lexical-binding: t -*- -;; Copyright (C) 2013-2017 Free Software Foundation, Inc. +;; Copyright (C) 2013-2022 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: internal @@ -25,9 +25,45 @@ (require 'regexp-opt) -(ert-deftest regexp-test-regexp-opt () - "Test the `compilation-error-regexp-alist' regexps. -The test data is in `compile-tests--test-regexps-data'." - (should (string-match (regexp-opt-charset '(?^)) "a^b"))) +(defun regexp-opt-test--permutations (l) + "All permutations of L, assuming no duplicates." + (if (cdr l) + (mapcan (lambda (x) + (mapcar (lambda (p) (cons x p)) + (regexp-opt-test--permutations (remove x l)))) + l) + (list l))) -;;; regexp-tests.el ends here. +(ert-deftest regexp-opt-longest-match () + "Check that the regexp always matches as much as possible." + (let ((s "abcd")) + (dolist (perm (regexp-opt-test--permutations '("a" "ab" "ac" "abc"))) + (should (equal (and (string-match (regexp-opt perm) s) + (match-string 0 s)) + "abc"))))) + +(ert-deftest regexp-opt-charset () + (should (equal (regexp-opt-charset '(?a ?b ?a)) "[ab]")) + (should (equal (regexp-opt-charset '(?D ?d ?B ?a ?b ?C ?7 ?a ?c ?A)) + "[7A-Da-d]")) + (should (equal (regexp-opt-charset '(?a)) "a")) + + (should (equal (regexp-opt-charset '(?^)) "\\^")) + (should (equal (regexp-opt-charset '(?-)) "-")) + (should (equal (regexp-opt-charset '(?\])) "]")) + (should (equal (regexp-opt-charset '(?^ ?\])) "[]^]")) + (should (equal (regexp-opt-charset '(?^ ?-)) "[-^]")) + (should (equal (regexp-opt-charset '(?- ?\])) "[]-]")) + (should (equal (regexp-opt-charset '(?- ?\] ?^)) "[]^-]")) + + (should (equal (regexp-opt-charset '(?^ ?a)) "[a^]")) + (should (equal (regexp-opt-charset '(?- ?a)) "[a-]")) + (should (equal (regexp-opt-charset '(?\] ?a)) "[]a]")) + (should (equal (regexp-opt-charset '(?^ ?\] ?a)) "[]a^]")) + (should (equal (regexp-opt-charset '(?^ ?- ?a)) "[a^-]")) + (should (equal (regexp-opt-charset '(?- ?\] ?a)) "[]a-]")) + (should (equal (regexp-opt-charset '(?- ?\] ?^ ?a)) "[]a^-]")) + + (should (equal (regexp-opt-charset '()) regexp-unmatchable))) + +;;; regexp-opt-tests.el ends here diff --git a/test/lisp/emacs-lisp/ring-tests.el b/test/lisp/emacs-lisp/ring-tests.el index 00bcf8401c4..6bbcd94f201 100644 --- a/test/lisp/emacs-lisp/ring-tests.el +++ b/test/lisp/emacs-lisp/ring-tests.el @@ -1,6 +1,6 @@ ;;; ring-tests.el --- Tests for ring.el -*- lexical-binding: t; -*- -;; Copyright (C) 2016-2017 Free Software Foundation, Inc. +;; Copyright (C) 2016-2022 Free Software Foundation, Inc. ;; Author: Simen Heggestøyl <simenheg@gmail.com> ;; Keywords: @@ -162,7 +162,44 @@ (should (= (ring-size ring) 5)) (should (equal (ring-elements ring) '(3 2 1))))) -(ert-deftest ring-tests-insert () +(ert-deftest ring-resize/grow () + (let ((ring (make-ring 3))) + (ring-insert ring 1) + (ring-insert ring 2) + (ring-insert ring 3) + (ring-resize ring 5) + (should (= (ring-size ring) 5)) + (should (equal (ring-elements ring) '(3 2 1))))) + +(ert-deftest ring-resize/grow-empty () + (let ((ring (make-ring 3))) + (ring-resize ring 5) + (should (= (ring-size ring) 5)) + (should (equal (ring-elements ring) '())))) + +(ert-deftest ring-resize/grow-wrapped-ring () + (let ((ring (make-ring 3))) + (ring-insert ring 1) + (ring-insert ring 2) + (ring-insert ring 3) + (ring-insert ring 4) + (ring-insert ring 5) + (ring-resize ring 5) + (should (= (ring-size ring) 5)) + (should (equal (ring-elements ring) '(5 4 3))))) + +(ert-deftest ring-resize/shrink () + (let ((ring (make-ring 5))) + (ring-insert ring 1) + (ring-insert ring 2) + (ring-insert ring 3) + (ring-insert ring 4) + (ring-insert ring 5) + (ring-resize ring 3) + (should (= (ring-size ring) 3)) + (should (equal (ring-elements ring) '(5 4 3))))) + +(ert-deftest ring-tests-insert-2 () (let ((ring (make-ring 2))) (ring-insert+extend ring :a) (ring-insert+extend ring :b) diff --git a/test/lisp/emacs-lisp/rmc-tests.el b/test/lisp/emacs-lisp/rmc-tests.el new file mode 100644 index 00000000000..385b0fe44a5 --- /dev/null +++ b/test/lisp/emacs-lisp/rmc-tests.el @@ -0,0 +1,91 @@ +;;; rmc-tests.el --- Test suite for rmc.el -*- lexical-binding: t -*- + +;; Copyright (C) 2017-2022 Free Software Foundation, Inc. + +;; Author: Tino Calancha <tino.calancha@gmail.com> +;; Keywords: + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'rmc) +(require 'cl-lib) +(eval-when-compile (require 'cl-lib)) + +(ert-deftest test-rmc--add-key-description () + (cl-letf (((symbol-function 'display-supports-face-attributes-p) (lambda (_ _) t))) + (should (equal (rmc--add-key-description '(?y "yes")) + '(?y . "yes"))) + (should (equal (rmc--add-key-description '(?n "foo")) + '(?n . "n foo"))) + (should (equal (rmc--add-key-description '(?\s "foo bar")) + `(?\s . "SPC foo bar"))))) + +(ert-deftest test-rmc--add-key-description/with-attributes () + (cl-letf (((symbol-function 'display-supports-face-attributes-p) (lambda (_ _) t))) + (should (equal-including-properties + (rmc--add-key-description '(?y "yes")) + `(?y . ,(concat (propertize "y" 'face 'read-multiple-choice-face) "es")))) + (should (equal-including-properties + (rmc--add-key-description '(?n "foo")) + `(?n . ,(concat (propertize "n" 'face 'read-multiple-choice-face) " foo")))) + (should (equal-including-properties + (rmc--add-key-description '(?\s "foo bar")) + `(?\s . ,(concat (propertize "SPC" 'face 'read-multiple-choice-face) " foo bar")))))) + +(ert-deftest test-rmc--add-key-description/non-graphical-display () + (cl-letf (((symbol-function 'display-supports-face-attributes-p) (lambda (_ _) nil))) + (should (equal-including-properties + (rmc--add-key-description '(?y "yes")) + '(?y . "[Y]es"))) + (should (equal-including-properties + (rmc--add-key-description '(?n "foo")) + `(?n . ,(concat (propertize "n" 'face 'help-key-binding) " foo")))))) + +(ert-deftest test-read-multiple-choice () + (dolist (char '(?y ?n)) + (cl-letf* (((symbol-function #'read-event) (lambda () char)) + (str (if (eq char ?y) "yes" "no"))) + (should (equal (list char str) + (read-multiple-choice "Do it? " '((?y "yes") (?n "no")))))))) + +(ert-deftest test-read-multiple-choice-help () + (let ((chars '(?o ?a)) + help) + (cl-letf* (((symbol-function #'read-event) + (lambda () + (message "chars %S" chars) + (when (= 1 (length chars)) + (with-current-buffer "*Multiple Choice Help*" + (setq help (buffer-string)))) + (pop chars)))) + (read-multiple-choice + "Choose:" + '((?a "aaa") + (?b "bbb") + (?c "ccc" "a really long description of ccc"))) + (should (equal help "Choose: + +a: [A]aa b: [B]bb c: [C]cc + a really long + description of ccc + \n"))))) + +;;; rmc-tests.el ends here diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el index d9ebb769613..125ddee8595 100644 --- a/test/lisp/emacs-lisp/rx-tests.el +++ b/test/lisp/emacs-lisp/rx-tests.el @@ -1,6 +1,6 @@ -;;; rx-tests.el --- test for rx.el functions -*- lexical-binding: t -*- +;;; rx-tests.el --- tests for rx.el -*- lexical-binding: t -*- -;; Copyright (C) 2016-2017 Free Software Foundation, Inc. +;; Copyright (C) 2016-2022 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -17,23 +17,149 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. -;;; Commentary: +;;; Code: (require 'ert) (require 'rx) -;;; Code: +(ert-deftest rx-seq () + (should (equal (rx "a.b" "*" "c") + "a\\.b\\*c")) + (should (equal (rx (seq "a" (: "b" (and "c" (sequence "d" nonl) + "e") + "f") + "g")) + "abcd.efg")) + (should (equal (rx "a$" "b") + "a\\$b")) + (should (equal (rx bol "a" "b" ?c eol) + "^abc$")) + (should (equal (rx "a" "" "b") + "ab")) + (should (equal (rx (seq)) + "")) + (should (equal (rx "" (or "ab" nonl) "") + "ab\\|."))) + +(ert-deftest rx-or () + (should (equal (rx (or "ab" (| "c" nonl) "de")) + "ab\\|c\\|.\\|de")) + (should (equal (rx (or "ab" "abc" ?a)) + "\\(?:a\\(?:bc?\\)?\\)")) + (should (equal (rx (or "ab" (| (or "abcd" "abcde")) (or "a" "abc"))) + "\\(?:a\\(?:b\\(?:c\\(?:de?\\)?\\)?\\)?\\)")) + (should (equal (rx (or "a" (eval (string ?a ?b)))) + "\\(?:ab?\\)")) + (should (equal (rx (| nonl "a") (| "b" blank)) + "\\(?:.\\|a\\)\\(?:b\\|[[:blank:]]\\)")) + (should (equal (rx (|)) + "\\`a\\`"))) + +(ert-deftest rx-def-in-or () + (rx-let ((a b) + (b (or "abc" c)) + (c ?a) + (d (any "a-z"))) + (should (equal (rx (or a (| "ab" "abcde") "abcd")) + "\\(?:a\\(?:b\\(?:c\\(?:de?\\)?\\)?\\)?\\)")) + (should (equal (rx (or ?m (not d))) + "[^a-ln-z]")))) (ert-deftest rx-char-any () - "Test character alternatives with `\]' and `-' (Bug#25123)." - (should (string-match + "Test character alternatives with `]' and `-' (Bug#25123)." + (should (equal + ;; relint suppression: Range .<-]. overlaps previous .]-{ (rx string-start (1+ (char (?\] . ?\{) (?< . ?\]) (?- . ?:))) string-end) - (apply #'string (nconc (number-sequence ?\] ?\{) - (number-sequence ?< ?\]) - (number-sequence ?- ?:)))))) + "\\`[.-:<-{-]+\\'"))) + +(ert-deftest rx-char-any-range-nl () + "Test character alternatives with LF as a range endpoint." + (should (equal (rx (any "\n-\r")) + "[\n-\r]")) + (should (equal (rx (any "\a-\n")) + "[\a-\n]"))) + +(ert-deftest rx-char-any-raw-byte () + "Test raw bytes in character alternatives." + + ;; The multibyteness of the rx return value sometimes depends on whether + ;; the test had been byte-compiled or not, so we add explicit conversions. + + ;; Separate raw characters. + (should (equal (string-to-multibyte (rx (any "\326A\333B"))) + (string-to-multibyte "[AB\326\333]"))) + ;; Range of raw characters, unibyte. + (should (equal (string-to-multibyte (rx (any "\200-\377"))) + (string-to-multibyte "[\200-\377]"))) + + ;; Range of raw characters, multibyte. + (should (equal (rx (any "Å\211\326-\377\177")) + "[\177Å\211\326-\377]")) + ;; Split range; \177-\377ÿ should not be optimized to \177-\377. + (should (equal (rx (any "\177-\377" ?ÿ)) + "[\177ÿ\200-\377]"))) + +(ert-deftest rx-any () + (should (equal (rx (any ?A (?C . ?D) "F-H" "J-L" "M" "N-P" "Q" "RS")) + "[ACDF-HJ-S]")) + (should (equal (rx (in "a!f" ?c) (char "q-z" "0-3") + (not-char "a-e1-5") (not (in "A-M" ?q))) + "[!acf][0-3q-z][^1-5a-e][^A-Mq]")) + (should (equal (rx (any "^") (any "]") (any "-") + (not (any "^")) (not (any "]")) (not (any "-"))) + "\\^]-[^^][^]][^-]")) + (should (equal (rx (any "]" "^") (any "]" "-") (any "-" "^") + (not (any "]" "^")) (not (any "]" "-")) + (not (any "-" "^"))) + "[]^][]-][-^][^]^][^]-][^-^]")) + (should (equal (rx (any "]" "^" "-") (not (any "]" "^" "-"))) + "[]^-][^]^-]")) + (should (equal (rx (any "-" ascii) (any "^" ascii) (any "]" ascii)) + "[[:ascii:]-][[:ascii:]^][][:ascii:]]")) + (should (equal (rx (not (any "-" ascii)) (not (any "^" ascii)) + (not (any "]" ascii))) + "[^[:ascii:]-][^[:ascii:]^][^][:ascii:]]")) + (should (equal (rx (any "-]" ascii) (any "^]" ascii) (any "-^" ascii)) + "[][:ascii:]-][]^[:ascii:]][[:ascii:]^-]")) + (should (equal (rx (not (any "-]" ascii)) (not (any "^]" ascii)) + (not (any "-^" ascii))) + "[^][:ascii:]-][^]^[:ascii:]][^[:ascii:]^-]")) + (should (equal (rx (any "-]^" ascii) (not (any "-]^" ascii))) + "[]^[:ascii:]-][^]^[:ascii:]-]")) + (should (equal (rx (any "^" lower upper) (not (any "^" lower upper))) + "[[:lower:]^[:upper:]][^[:lower:]^[:upper:]]")) + (should (equal (rx (any "-" lower upper) (not (any "-" lower upper))) + "[[:lower:][:upper:]-][^[:lower:][:upper:]-]")) + (should (equal (rx (any "]" lower upper) (not (any "]" lower upper))) + "[][:lower:][:upper:]][^][:lower:][:upper:]]")) + ;; relint suppression: Duplicated character .-. + ;; relint suppression: Single-character range .f-f + ;; relint suppression: Range .--/. overlaps previous .- + ;; relint suppression: Range .\*--. overlaps previous .--/ + (should (equal (rx (any "-a" "c-" "f-f" "--/*--") (any "," "-" "A")) + "[*-/acf][,A-]")) + (should (equal (rx (any "]-a" ?-) (not (any "]-a" ?-))) + "[]-a-][^]-a-]")) + (should (equal (rx (any "--]") (not (any "--]")) + (any "-" "^-a") (not (any "-" "^-a"))) + "[].-\\-][^].-\\-][-^-a][^-^-a]")) + (should (equal (rx (not (any "!a" "0-8" digit nonascii))) + "[^!0-8a[:digit:][:nonascii:]]")) + (should (equal (rx (any) (not (any))) + "\\`a\\`[^z-a]")) + (should (equal (rx (any "") (not (any ""))) + "\\`a\\`[^z-a]")) + ;; relint suppression: Duplicated class .space. + (should (equal (rx (any space ?a digit space)) + "[a[:space:][:digit:]]")) + (should (equal (rx (not "\n") (not ?\n) (not (any "\n")) (not-char ?\n) + (| (not (in "a\n")) (not (char ?\n (?b . ?b))))) + "....."))) (ert-deftest rx-pcase () + (should (equal (pcase "i18n" ((rx (let x (+ digit))) (list 'ok x))) + '(ok "18"))) (should (equal (pcase "a 1 2 3 1 1 b" ((rx (let u (+ digit)) space (let v (+ digit)) space @@ -41,7 +167,423 @@ (backref u) space (backref 1)) (list u v))) - '("1" "3")))) + '("1" "3"))) + (should (equal (pcase "bz" + ((rx "a" (let x nonl)) (list 1 x)) + (_ 'no)) + 'no)) + (should (equal (pcase "az" + ((rx "a" (let x nonl)) (list 1 x)) + ((rx "b" (let x nonl)) (list 2 x)) + (_ 'no)) + '(1 "z"))) + (should (equal (pcase "bz" + ((rx "a" (let x nonl)) (list 1 x)) + ((rx "b" (let x nonl)) (list 2 x)) + (_ 'no)) + '(2 "z"))) + (let ((k "blue")) + (should (equal (pcase "<blue>" + ((rx "<" (literal k) ">") 'ok)) + 'ok))) + (should (equal (pcase "abc" + ((rx (? (let x alpha)) (?? (let y alnum)) ?c) + (list x y))) + '("a" "b"))) + (should (equal (pcase 'not-a-string + ((rx nonl) 'wrong) + (_ 'correct)) + 'correct)) + (should (equal (pcase "PQR" + ((and (rx (let a nonl)) (rx ?z)) + (list 'one a)) + ((rx (let b ?Q)) + (list 'two b))) + '(two "Q"))) + (should (equal (pcase-let (((rx ?B (let z nonl)) "ABC")) + (list 'ok z)) + '(ok "C"))) + (should (equal (pcase-let* (((rx ?E (let z nonl)) "DEF")) + (list 'ok z)) + '(ok "F")))) + +(ert-deftest rx-kleene () + "Test greedy and non-greedy repetition operators." + (should (equal (rx (* "a") (+ "b") (\? "c") (?\s "d") + (*? "e") (+? "f") (\?? "g") (?? "h")) + "a*b+c?d?e*?f+?g??h??")) + (should (equal (rx (zero-or-more "a") (0+ "b") + (one-or-more "c") (1+ "d") + (zero-or-one "e") (optional "f") (opt "g")) + "a*b*c+d+e?f?g?")) + (should (equal (rx (minimal-match + (seq (* "a") (+ "b") (\? "c") (?\s "d") + (*? "e") (+? "f") (\?? "g") (?? "h")))) + "a*b+c?d?e*?f+?g??h??")) + (should (equal (rx (minimal-match + (seq (zero-or-more "a") (0+ "b") + (one-or-more "c") (1+ "d") + (zero-or-one "e") (optional "f") (opt "g")))) + "a*?b*?c+?d+?e??f??g??")) + (should (equal (rx (maximal-match + (seq (* "a") (+ "b") (\? "c") (?\s "d") + (*? "e") (+? "f") (\?? "g") (?? "h")))) + "a*b+c?d?e*?f+?g??h??")) + (should (equal (rx "a" (*) (+ (*)) (? (*) (+)) "b") + "ab"))) + +(ert-deftest rx-repeat () + (should (equal (rx (= 3 "a") (>= 51 "b") + (** 2 11 "c") (repeat 6 "d") (repeat 4 8 "e")) + "a\\{3\\}b\\{51,\\}c\\{2,11\\}d\\{6\\}e\\{4,8\\}")) + (should (equal (rx (= 0 "k") (>= 0 "l") (** 0 0 "m") (repeat 0 "n") + (repeat 0 0 "o")) + "k\\{0\\}l\\{0,\\}m\\{0\\}n\\{0\\}o\\{0\\}")) + (should (equal (rx (opt (0+ "a"))) + "\\(?:a*\\)?")) + (should (equal (rx (opt (= 4 "a"))) + "a\\{4\\}?")) + (should (equal (rx "a" (** 3 7) (= 4) (>= 3) (= 4 (>= 7) (= 2)) "b") + "ab"))) + +(ert-deftest rx-atoms () + (should (equal (rx anychar anything) + "[^z-a][^z-a]")) + (should (equal (rx unmatchable) + "\\`a\\`")) + (should (equal (rx line-start not-newline nonl any line-end) + "^...$")) + (should (equal (rx bol string-start string-end buffer-start buffer-end + bos eos bot eot eol) + "^\\`\\'\\`\\'\\`\\'\\`\\'$")) + (should (equal (rx point word-start word-end bow eow symbol-start symbol-end + word-boundary not-word-boundary not-wordchar) + "\\=\\<\\>\\<\\>\\_<\\_>\\b\\B\\W")) + (should (equal (rx digit numeric num control cntrl) + "[[:digit:]][[:digit:]][[:digit:]][[:cntrl:]][[:cntrl:]]")) + (should (equal (rx hex-digit hex xdigit blank) + "[[:xdigit:]][[:xdigit:]][[:xdigit:]][[:blank:]]")) + (should (equal (rx graph graphic print printing) + "[[:graph:]][[:graph:]][[:print:]][[:print:]]")) + (should (equal (rx alphanumeric alnum letter alphabetic alpha) + "[[:alnum:]][[:alnum:]][[:alpha:]][[:alpha:]][[:alpha:]]")) + (should (equal (rx ascii nonascii lower lower-case) + "[[:ascii:]][[:nonascii:]][[:lower:]][[:lower:]]")) + (should (equal (rx punctuation punct space whitespace white) + "[[:punct:]][[:punct:]][[:space:]][[:space:]][[:space:]]")) + (should (equal (rx upper upper-case word wordchar) + "[[:upper:]][[:upper:]][[:word:]][[:word:]]")) + (should (equal (rx unibyte multibyte) + "[[:unibyte:]][[:multibyte:]]"))) + +(ert-deftest rx-syntax () + (should (equal (rx (syntax whitespace) (syntax punctuation) + (syntax word) (syntax symbol) + (syntax open-parenthesis) (syntax close-parenthesis)) + "\\s-\\s.\\sw\\s_\\s(\\s)")) + (should (equal (rx (syntax string-quote) (syntax paired-delimiter) + (syntax escape) (syntax character-quote) + (syntax comment-start) (syntax comment-end) + (syntax string-delimiter) (syntax comment-delimiter)) + "\\s\"\\s$\\s\\\\s/\\s<\\s>\\s|\\s!"))) + +(ert-deftest rx-category () + (should (equal (rx (category space-for-indent) (category base) + (category consonant) (category base-vowel) + (category upper-diacritical-mark) + (category lower-diacritical-mark) + (category tone-mark) (category symbol) + (category digit) + (category vowel-modifying-diacritical-mark) + (category vowel-sign) (category semivowel-lower) + (category not-at-end-of-line) + (category not-at-beginning-of-line)) + "\\c \\c.\\c0\\c1\\c2\\c3\\c4\\c5\\c6\\c7\\c8\\c9\\c<\\c>")) + (should (equal (rx (category alpha-numeric-two-byte) + (category chinese-two-byte) (category greek-two-byte) + (category japanese-hiragana-two-byte) + (category indian-two-byte) + (category japanese-katakana-two-byte) + (category strong-left-to-right) + (category korean-hangul-two-byte) + (category strong-right-to-left) + (category cyrillic-two-byte) + (category combining-diacritic)) + "\\cA\\cC\\cG\\cH\\cI\\cK\\cL\\cN\\cR\\cY\\c^")) + (should (equal (rx (category ascii) (category arabic) (category chinese) + (category ethiopic) (category greek) (category korean) + (category indian) (category japanese) + (category japanese-katakana) (category latin) + (category lao) (category tibetan)) + "\\ca\\cb\\cc\\ce\\cg\\ch\\ci\\cj\\ck\\cl\\co\\cq")) + (should (equal (rx (category japanese-roman) (category thai) + (category vietnamese) (category hebrew) + (category cyrillic) (category can-break)) + "\\cr\\ct\\cv\\cw\\cy\\c|")) + (should (equal (rx (category ?g) (not (category ?~))) + "\\cg\\C~"))) + +(ert-deftest rx-not () + (should (equal (rx (not word-boundary)) + "\\B")) + (should (equal (rx (not ascii) (not lower-case) (not wordchar)) + "[^[:ascii:]][^[:lower:]][^[:word:]]")) + (should (equal (rx (not (syntax punctuation)) (not (syntax escape))) + "\\S.\\S\\")) + (should (equal (rx (not (category tone-mark)) (not (category lao))) + "\\C4\\Co")) + (should (equal (rx (not (not ascii)) (not (not (not (any "a-z"))))) + "[[:ascii:]][^a-z]")) + (should (equal (rx (not ?a) (not "b") (not (not "c")) (not (not ?d))) + "[^a][^b]cd"))) + +(ert-deftest rx-charset-or () + (should (equal (rx (or)) + "\\`a\\`")) + (should (equal (rx (or (any "ba"))) + "[ab]")) + (should (equal (rx (| (any "a-f") (any "c-k" ?y) (any ?r "x-z"))) + "[a-krx-z]")) + (should (equal (rx (or (not (any "a-m")) (not (any "f-p")))) + "[^f-m]")) + (should (equal (rx (| (any "e-m") (not (any "a-z")))) + "[^a-dn-z]")) + (should (equal (rx (or (not (any "g-r")) (not (any "t")))) + "[^z-a]")) + (should (equal (rx (not (or (not (any "g-r")) (not (any "t"))))) + "\\`a\\`")) + (should (equal (rx (or (| (any "a-f") (any "u-z")) + (any "g-r"))) + "[a-ru-z]")) + (should (equal (rx (or (intersection (any "c-z") (any "a-g")) + (not (any "a-k")))) + "[^abh-k]")) + (should (equal (rx (or ?f (any "b-e") "a") (not (or ?x "y" (any "s-w")))) + "[a-f][^s-y]")) + (should (equal (rx (not (or (in "abc") (char "bcd")))) + "[^a-d]")) + (should (equal (rx (or (not (in "abc")) (not (char "bcd")))) + "[^bc]")) + (should (equal (rx (or "x" (? "yz"))) + "x\\|\\(?:yz\\)?"))) + +(ert-deftest rx-def-in-charset-or () + (rx-let ((a (any "badc")) + (b (| a (any "def"))) + (c ?a) + (d "b")) + (should (equal (rx (or b (any "q")) (or c d)) + "[a-fq][ab]"))) + (rx-let ((diff-| (a b) (not (or (not a) b)))) + (should (equal (rx (diff-| (any "a-z") (any "gr"))) + "[a-fh-qs-z]")))) + +(ert-deftest rx-intersection () + (should (equal (rx (intersection)) + "[^z-a]")) + (should (equal (rx (intersection (any "ba"))) + "[ab]")) + (should (equal (rx (intersection (any "a-j" "u-z") (any "c-k" ?y) + (any "a-i" "x-z"))) + "[c-iy]")) + (should (equal (rx (intersection (not (any "a-m")) (not (any "f-p")))) + "[^a-p]")) + (should (equal (rx (intersection (any "a-z") (not (any "g-q")))) + "[a-fr-z]")) + (should (equal (rx (intersection (any "a-d") (any "e"))) + "\\`a\\`")) + (should (equal (rx (not (intersection (any "a-d") (any "e")))) + "[^z-a]")) + (should (equal (rx (intersection (any "d-u") + (intersection (any "e-z") (any "a-m")))) + "[e-m]")) + (should (equal (rx (intersection (or (any "a-f") (any "f-t")) + (any "e-w"))) + "[e-t]")) + (should (equal (rx (intersection ?m (any "a-z") "m")) + "m"))) + +(ert-deftest rx-def-in-intersection () + (rx-let ((a (any "a-g")) + (b (intersection a (any "d-j")))) + (should (equal (rx (intersection b (any "e-k"))) + "[e-g]"))) + (rx-let ((diff-& (a b) (intersection a (not b)))) + (should (equal (rx (diff-& (any "a-z") (any "m-p"))) + "[a-lq-z]")))) + +(ert-deftest rx-group () + (should (equal (rx (group nonl) (submatch "x") + (group-n 3 "y") (submatch-n 13 "z") (backref 1)) + "\\(.\\)\\(x\\)\\(?3:y\\)\\(?13:z\\)\\1")) + (should (equal (rx (group) (group-n 2)) + "\\(\\)\\(?2:\\)"))) + +(ert-deftest rx-regexp () + (should (equal (rx (regexp "abc") (regex "[de]")) + "\\(?:abc\\)[de]")) + (should (equal (rx "a" (regexp "$")) + "a\\(?:$\\)")) + (let ((x "a*")) + (should (equal (rx (regexp x) "b") + "\\(?:a*\\)b")) + (should (equal (rx "" (regexp x) (eval "")) + "a*")))) + +(ert-deftest rx-eval () + (should (equal (rx (eval (list 'syntax 'symbol))) + "\\s_")) + (should (equal (rx "a" (eval (concat)) "b") + "ab"))) + +(ert-deftest rx-literal () + (should (equal (rx (literal "$a")) + "\\$a")) + (should (equal (rx (literal (char-to-string 42)) nonl) + "\\*.")) + (let ((x "a+b")) + (should (equal (rx (opt (literal (upcase x)))) + "\\(?:A\\+B\\)?")))) + +(ert-deftest rx-to-string () + (should (equal (rx-to-string '(or nonl "\nx")) + "\\(?:.\\|\nx\\)")) + (should (equal (rx-to-string '(or nonl "\nx") t) + ".\\|\nx"))) + +(ert-deftest rx-let () + (rx-let ((beta gamma) + (gamma delta) + (delta (+ digit)) + (epsilon (or gamma nonl))) + (should (equal (rx bol delta epsilon) + "^[[:digit:]]+\\(?:[[:digit:]]+\\|.\\)"))) + (rx-let ((p () point) + (separated (x sep) (seq x (* sep x))) + (comma-separated (x) (separated x ",")) + (semi-separated (x) (separated x ";")) + (matrix (v) (semi-separated (comma-separated v)))) + (should (equal (rx (p) (matrix (+ "a")) eos) + "\\=a+\\(?:,a+\\)*\\(?:;a+\\(?:,a+\\)*\\)*\\'"))) + (rx-let ((b bol) + (z "B") + (three (x) (= 3 x))) + (rx-let ((two (x) (seq x x)) + (z "A") + (e eol)) + (should (equal (rx b (two (three z)) e) + "^A\\{3\\}A\\{3\\}$")))) + (rx-let ((f (a b &rest r) (seq "<" a ";" b ":" r ">"))) + (should (equal (rx bol (f ?x ?y) ?! (f ?u ?v ?w) ?! (f ?k ?l ?m ?n) eol) + "^<x;y:>!<u;v:w>!<k;l:mn>$"))) + + ;; Rest parameters are expanded by splicing. + (rx-let ((f (&rest r) (or bol r eol))) + (should (equal (rx (f "ab" nonl)) + "^\\|ab\\|.\\|$"))) + + ;; Substitution is done in number positions. + (rx-let ((stars (n) (= n ?*))) + (should (equal (rx (stars 4)) + "\\*\\{4\\}"))) + + ;; Substitution is done inside dotted pairs. + (rx-let ((f (x y z) (any x (y . z)))) + (should (equal (rx (f ?* ?a ?t)) + "[*a-t]"))) + + ;; Substitution is done in the head position of forms. + (rx-let ((f (x) (x "a"))) + (should (equal (rx (f +)) + "a+")))) + +(ert-deftest rx-define () + (rx-define rx--a (seq "x" (opt "y"))) + (should (equal (rx bol rx--a eol) + "^xy?$")) + (rx-define rx--c (lb rb &rest stuff) (seq lb stuff rb)) + (should (equal (rx bol (rx--c "<" ">" rx--a nonl) eol) + "^<xy?.>$")) + (rx-define rx--b (* rx--a)) + (should (equal (rx rx--b) + "\\(?:xy?\\)*")) + (rx-define rx--a "z") + (should (equal (rx rx--b) + "z*"))) + +(defun rx--test-rx-to-string-define () + ;; `rx-define' won't expand to code inside `ert-deftest' since we use + ;; `eval-and-compile'. Put it into a defun as a workaround. + (rx-define rx--d "Q") + (rx-to-string '(seq bol rx--d) t)) + +(ert-deftest rx-to-string-define () + "Check that `rx-to-string' uses definitions made by `rx-define'." + (should (equal (rx--test-rx-to-string-define) + "^Q"))) + +(ert-deftest rx-let-define () + "Test interaction between `rx-let' and `rx-define'." + (rx-define rx--e "one") + (rx-define rx--f "eins") + (rx-let ((rx--e "two")) + (should (equal (rx rx--e nonl rx--f) "two.eins")) + (rx-define rx--e "three") + (should (equal (rx rx--e) "two")) + (rx-define rx--f "zwei") + (should (equal (rx rx--f) "zwei"))) + (should (equal (rx rx--e nonl rx--f) "three.zwei"))) + +(ert-deftest rx-let-eval () + (rx-let-eval '((a (* digit)) + (f (x &rest r) (seq x nonl r))) + (should (equal (rx-to-string '(seq a (f bow a ?b)) t) + "[[:digit:]]*\\<.[[:digit:]]*b")))) + +(ert-deftest rx-redefine-builtin () + (should-error (rx-define sequence () "x")) + (should-error (rx-define sequence "x")) + (should-error (rx-define nonl () "x")) + (should-error (rx-define nonl "x")) + (should-error (rx-let ((punctuation () "x")) nil)) + (should-error (rx-let ((punctuation "x")) nil)) + (should-error (rx-let-eval '((not-char () "x")) nil)) + (should-error (rx-let-eval '((not-char "x")) nil))) + +(ert-deftest rx-def-in-not () + "Test definition expansion inside (not ...)." + (rx-let ((a alpha) + (b (not hex)) + (c (not (category base))) + (d (x) (any ?a x ?z)) + (e (x) (syntax x)) + (f (not b))) + (should (equal (rx (not a) (not b) (not c) (not f)) + "[^[:alpha:]][[:xdigit:]]\\c.[^[:xdigit:]]")) + (should (equal (rx (not (d ?m)) (not (e symbol))) + "[^amz]\\S_")))) + +(ert-deftest rx-constituents () + (let ((rx-constituents + (append '((beta . gamma) + (gamma . "a*b") + (delta . ((lambda (form) + (regexp-quote (format "<%S>" form))) + 1 nil symbolp)) + (epsilon . delta)) + rx-constituents))) + (should (equal (rx-to-string '(seq (+ beta) nonl gamma) t) + "\\(?:a*b\\)+.\\(?:a*b\\)")) + (should (equal (rx-to-string '(seq (delta a b c) (* (epsilon d e))) t) + "\\(?:<(delta a b c)>\\)\\(?:<(epsilon d e)>\\)*")))) + +(ert-deftest rx-compat () + "Test old symbol retained for compatibility (bug#37517)." + (should (equal + (with-no-warnings + (rx-submatch-n '(group-n 3 (+ nonl) eol))) + "\\(?3:.+$\\)"))) (provide 'rx-tests) -;; rx-tests.el ends here. + +;;; rx-tests.el ends here diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el index 5aa794a43b0..d95b35c45eb 100644 --- a/test/lisp/emacs-lisp/seq-tests.el +++ b/test/lisp/emacs-lisp/seq-tests.el @@ -1,6 +1,6 @@ -;;; seq-tests.el --- Tests for sequences.el +;;; seq-tests.el --- Tests for seq.el -*- lexical-binding:t -*- -;; Copyright (C) 2014-2017 Free Software Foundation, Inc. +;; Copyright (C) 2014-2022 Free Software Foundation, Inc. ;; Author: Nicolas Petton <nicolas@petton.fr> ;; Maintainer: emacs-devel@gnu.org @@ -29,6 +29,9 @@ (require 'ert) (require 'seq) +(eval-when-compile + (require 'cl-lib)) + (defmacro with-test-sequences (spec &rest body) "Successively bind VAR to a list, vector, and string built from SEQ. Evaluate BODY for each created sequence. @@ -108,16 +111,12 @@ Evaluate BODY for each created sequence. '((a 0) (b 1) (c 2) (d 3))))) (ert-deftest test-seq-do-indexed () - (let ((result nil)) - (seq-do-indexed (lambda (elt i) - (add-to-list 'result (list elt i))) - nil) - (should (equal result nil))) + (let (result) + (seq-do-indexed (lambda (elt i) (push (list elt i) result)) ()) + (should-not result)) (with-test-sequences (seq '(4 5 6)) - (let ((result nil)) - (seq-do-indexed (lambda (elt i) - (add-to-list 'result (list elt i))) - seq) + (let (result) + (seq-do-indexed (lambda (elt i) (push (list elt i) result)) seq) (should (equal (seq-elt result 0) '(6 2))) (should (equal (seq-elt result 1) '(5 1))) (should (equal (seq-elt result 2) '(4 0)))))) @@ -126,7 +125,7 @@ Evaluate BODY for each created sequence. (with-test-sequences (seq '(6 7 8 9 10)) (should (equal (seq-filter #'test-sequences-evenp seq) '(6 8 10))) (should (equal (seq-filter #'test-sequences-oddp seq) '(7 9))) - (should (equal (seq-filter (lambda (elt) nil) seq) '()))) + (should (equal (seq-filter (lambda (_) nil) seq) '()))) (with-test-sequences (seq '()) (should (equal (seq-filter #'test-sequences-evenp seq) '())))) @@ -134,15 +133,23 @@ Evaluate BODY for each created sequence. (with-test-sequences (seq '(6 7 8 9 10)) (should (equal (seq-remove #'test-sequences-evenp seq) '(7 9))) (should (equal (seq-remove #'test-sequences-oddp seq) '(6 8 10))) - (should (same-contents-p (seq-remove (lambda (elt) nil) seq) seq))) + (should (same-contents-p (seq-remove (lambda (_) nil) seq) seq))) (with-test-sequences (seq '()) (should (equal (seq-remove #'test-sequences-evenp seq) '())))) +(ert-deftest test-seq-remove-at-position () + (with-test-sequences (seq '(1 2 3 4)) + (should (same-contents-p (seq-remove-at-position seq 2) '(1 2 4))) + (should (same-contents-p (seq-remove-at-position seq 0) '(2 3 4))) + (should (same-contents-p (seq-remove-at-position seq 3) '(1 2 3))) + (should (eq (type-of (seq-remove-at-position seq 2)) + (type-of seq))))) + (ert-deftest test-seq-count () (with-test-sequences (seq '(6 7 8 9 10)) (should (equal (seq-count #'test-sequences-evenp seq) 3)) (should (equal (seq-count #'test-sequences-oddp seq) 2)) - (should (equal (seq-count (lambda (elt) nil) seq) 0))) + (should (equal (seq-count (lambda (_) nil) seq) 0))) (with-test-sequences (seq '()) (should (equal (seq-count #'test-sequences-evenp seq) 0)))) @@ -174,20 +181,34 @@ Evaluate BODY for each created sequence. (should (seq-find #'null '(1 2 3) 'sentinel))) (ert-deftest test-seq-contains () - (with-test-sequences (seq '(3 4 5 6)) - (should (seq-contains seq 3)) - (should-not (seq-contains seq 7))) - (with-test-sequences (seq '()) - (should-not (seq-contains seq 3)) - (should-not (seq-contains seq nil)))) + (with-suppressed-warnings ((obsolete seq-contains)) + (with-test-sequences (seq '(3 4 5 6)) + (should (seq-contains seq 3)) + (should-not (seq-contains seq 7))) + (with-test-sequences (seq '()) + (should-not (seq-contains seq 3)) + (should-not (seq-contains seq nil))))) (ert-deftest test-seq-contains-should-return-the-elt () + (with-suppressed-warnings ((obsolete seq-contains)) + (with-test-sequences (seq '(3 4 5 6)) + (should (= 5 (seq-contains seq 5)))))) + +(ert-deftest test-seq-contains-p () (with-test-sequences (seq '(3 4 5 6)) - (should (= 5 (seq-contains seq 5))))) + (should (eq (seq-contains-p seq 3) t)) + (should-not (seq-contains-p seq 7))) + (with-test-sequences (seq '()) + (should-not (seq-contains-p seq 3)) + (should-not (seq-contains-p seq nil)))) + +(ert-deftest test-seq-contains-p-with-nil () + (should (seq-contains-p [nil] nil)) + (should (seq-contains-p '(nil) nil))) (ert-deftest test-seq-every-p () (with-test-sequences (seq '(43 54 22 1)) - (should (seq-every-p (lambda (elt) t) seq)) + (should (seq-every-p (lambda (_) t) seq)) (should-not (seq-every-p #'test-sequences-oddp seq)) (should-not (seq-every-p #'test-sequences-evenp seq))) (with-test-sequences (seq '(42 54 22 2)) @@ -244,6 +265,19 @@ Evaluate BODY for each created sequence. (with-test-sequences (seq '()) (should (equal (seq-uniq seq) '())))) +(defun seq-tests--list-subseq-ref (list start &optional end) + "Reference implementation of `seq-subseq' for lists." + (let ((len (length list))) + (when (< start 0) + (setq start (+ start len))) + (unless end + (setq end len)) + (when (< end 0) + (setq end (+ end len))) + (if (<= 0 start end len) + (take (- end start) (nthcdr start list)) + (error "bad args")))) + (ert-deftest test-seq-subseq () (with-test-sequences (seq '(2 3 4 5)) (should (equal (seq-subseq seq 0 4) seq)) @@ -262,7 +296,21 @@ Evaluate BODY for each created sequence. (should-error (seq-subseq [] -1)) (should-error (seq-subseq "" -1)) (should-not (seq-subseq '() 0)) - (should-error (seq-subseq '() 0 -1))) + (should-error (seq-subseq '() 0 -1)) + + (dolist (list '(() (a b c d))) + (ert-info ((prin1-to-string list) :prefix "list: ") + (let ((len (length list))) + (dolist (start (number-sequence (- -2 len) (+ 2 len))) + (ert-info ((prin1-to-string start) :prefix "start: ") + (dolist (end (cons nil (number-sequence (- -2 len) (+ 2 len)))) + (ert-info ((prin1-to-string end) :prefix "end: ") + (condition-case res + (seq-tests--list-subseq-ref list start end) + (error + (should-error (seq-subseq list start end))) + (:success + (should (equal (seq-subseq list start end) res)))))))))))) (ert-deftest test-seq-concatenate () (with-test-sequences (seq '(2 4 6)) @@ -325,6 +373,33 @@ Evaluate BODY for each created sequence. (should (same-contents-p list vector)) (should (vectorp vector)))) +(ert-deftest test-seq-union () + (let ((v1 '(1 2 3)) + (v2 '(3 5))) + (should (same-contents-p (seq-union v1 v2) + '(1 2 3 5)))) + + (let ((v1 '(1 2 3 4 5 6)) + (v2 '(4 5 6 7 8 9))) + (should (same-contents-p (seq-union v1 v2) + '(1 2 3 4 5 6 7 8 9)))) + + (let ((v1 [1 2 3 4 5]) + (v2 [4 5 6 "a"])) + (should (same-contents-p (seq-union v1 v2) + '(1 2 3 4 5 6 "a")))) + + (let ((v1 '("a" "b" "c")) + (v2 '("f" "c" "e" "a"))) + (should (same-contents-p (seq-union v1 v2) + '("a" "b" "c" "f" "e")))) + + (let ((v1 '("a")) + (v2 '("a")) + (testfn #'eq)) + (should (same-contents-p (seq-union v1 v2 testfn) + '("a" "a"))))) + (ert-deftest test-seq-intersection () (let ((v1 [2 3 4 5]) (v2 [1 3 5 6 7])) @@ -366,12 +441,36 @@ Evaluate BODY for each created sequence. (let ((seq '(1 (2 (3 (4)))))) (seq-let (_ (_ (_ (a)))) seq (should (= a 4)))) - (let (seq) + (let ((seq nil)) (seq-let (a b c) seq (should (null a)) (should (null b)) (should (null c))))) +(ert-deftest test-seq-setq () + (with-test-sequences (seq '(1 2 3 4)) + (let (a b c d e) + (seq-setq (a b c d e) seq) + (should (= a 1)) + (should (= b 2)) + (should (= c 3)) + (should (= d 4)) + (should (null e))) + (let (a b others) + (seq-setq (a b &rest others) seq) + (should (= a 1)) + (should (= b 2)) + (should (same-contents-p others (seq-drop seq 2))))) + (let ((a) + (seq '(1 (2 (3 (4)))))) + (seq-setq (_ (_ (_ (a)))) seq) + (should (= a 4))) + (let ((seq nil) a b c) + (seq-setq (a b c) seq) + (should (null a)) + (should (null b)) + (should (null c)))) + (ert-deftest test-seq-min-max () (with-test-sequences (seq '(4 5 3 2 0 4)) (should (= (seq-min seq) 0)) @@ -391,6 +490,13 @@ Evaluate BODY for each created sequence. (should (= (seq-position seq 'a #'eq) 0)) (should (null (seq-position seq (make-symbol "a") #'eq))))) +(ert-deftest test-seq-positions () + (with-test-sequences (seq '(1 2 3 1 4)) + (should (equal '(0 3) (seq-positions seq 1))) + (should (seq-empty-p (seq-positions seq 9)))) + (with-test-sequences (seq '(11 5 7 12 9 15)) + (should (equal '(0 3 5) (seq-positions seq 10 #'>=))))) + (ert-deftest test-seq-sort-by () (let ((seq ["x" "xx" "xxx"])) (should (equal (seq-sort-by #'seq-length #'> seq) @@ -398,12 +504,10 @@ Evaluate BODY for each created sequence. (ert-deftest test-seq-random-elt-take-all () (let ((seq '(a b c d e)) - (elts '())) - (should (= 0 (length elts))) + elts) (dotimes (_ 1000) (let ((random-elt (seq-random-elt seq))) - (add-to-list 'elts - random-elt))) + (cl-pushnew random-elt elts))) (should (= 5 (length elts))))) (ert-deftest test-seq-random-elt-signal-on-empty () @@ -424,5 +528,69 @@ Evaluate BODY for each created sequence. (should (eq (seq-into vec 'vector) vec)) (should (eq (seq-into str 'string) str)))) +(ert-deftest test-seq-first () + (let ((lst '(1 2 3)) + (vec [1 2 3])) + (should (eq (seq-first lst) 1)) + (should (eq (seq-first vec) 1)))) + +(ert-deftest test-seq-rest () + (let ((lst '(1 2 3)) + (vec [1 2 3])) + (should (equal (seq-rest lst) '(2 3))) + (should (equal (seq-rest vec) [2 3])))) + +;; Regression tests for bug#34852 +(progn + (ert-deftest test-seq-intersection-with-nil () + (should (equal (seq-intersection '(1 2 nil) '(1 nil)) '(1 nil)))) + + (ert-deftest test-seq-set-equal-p-with-nil () + (should (seq-set-equal-p '("a" "b" nil) + '(nil "b" "a")))) + + (ert-deftest test-difference-with-nil () + (should (equal (seq-difference '(1 nil) '(2 nil)) + '(1))))) + +(ert-deftest test-seq-split () + (let ((seq [0 1 2 3 4 5 6 7 8 9 10])) + (should (equal seq (car (seq-split seq 20)))) + (should (equal seq (car (seq-split seq 11)))) + (should (equal (seq-split seq 10) + '([0 1 2 3 4 5 6 7 8 9] [10]))) + (should (equal (seq-split seq 5) + '([0 1 2 3 4] [5 6 7 8 9] [10]))) + (should (equal (seq-split seq 1) + '([0] [1] [2] [3] [4] [5] [6] [7] [8] [9] [10]))) + (should-error (seq-split seq 0)) + (should-error (seq-split seq -10))) + (let ((seq '(0 1 2 3 4 5 6 7 8 9))) + (should (equal (seq-split seq 5) + '((0 1 2 3 4) (5 6 7 8 9))))) + (let ((seq "0123456789")) + (should (equal (seq-split seq 2) + '("01" "23" "45" "67" "89"))) + (should (equal (seq-split seq 3) + '("012" "345" "678" "9"))))) + +(ert-deftest test-seq-uniq-list () + (let ((list '(1 2 3))) + (should (equal (seq-uniq (append list list)) '(1 2 3)))) + (let ((list '(1 2 3 2 1))) + (should (equal (seq-uniq list) '(1 2 3)))) + (let ((list (list (substring "1") + (substring "2") + (substring "3") + (substring "2") + (substring "1")))) + (should (equal (seq-uniq list) '("1" "2" "3"))) + (should (equal (seq-uniq list #'eq) '("1" "2" "3" "2" "1")))) + ;; Long lists have a different code path. + (let ((list (seq-map-indexed (lambda (_ i) i) + (make-list 10000 nil)))) + (should (= (length list) 10000)) + (should (= (length (seq-uniq (append list list))) 10000)))) + (provide 'seq-tests) ;;; seq-tests.el ends here diff --git a/test/lisp/emacs-lisp/shadow-resources/p1/foo.el b/test/lisp/emacs-lisp/shadow-resources/p1/foo.el new file mode 100644 index 00000000000..ffe68f9356f --- /dev/null +++ b/test/lisp/emacs-lisp/shadow-resources/p1/foo.el @@ -0,0 +1 @@ +;;; This file intentionally left blank. -*- lexical-binding:t -*- diff --git a/test/lisp/emacs-lisp/shadow-resources/p2/FOO.el b/test/lisp/emacs-lisp/shadow-resources/p2/FOO.el new file mode 100644 index 00000000000..ffe68f9356f --- /dev/null +++ b/test/lisp/emacs-lisp/shadow-resources/p2/FOO.el @@ -0,0 +1 @@ +;;; This file intentionally left blank. -*- lexical-binding:t -*- diff --git a/test/lisp/emacs-lisp/shadow-tests.el b/test/lisp/emacs-lisp/shadow-tests.el new file mode 100644 index 00000000000..a91c4efd048 --- /dev/null +++ b/test/lisp/emacs-lisp/shadow-tests.el @@ -0,0 +1,42 @@ +;;; shadow-tests.el --- Test suite for shadow. -*- lexical-binding: t -*- + +;; Copyright (C) 2018-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'ert-x) +(require 'shadow) +(eval-when-compile (require 'cl-lib)) + +(ert-deftest shadow-case-insensitive () + "Test shadowing for case insensitive filenames." + ;; Override `file-name-case-insensitive-p' so we test the same thing + ;; regardless of what file system we're running on. + (cl-letf (((symbol-function 'file-name-case-insensitive-p) (lambda (_f) t))) + (should (equal (list (ert-resource-file "p1/foo") + (ert-resource-file "p2/FOO")) + (load-path-shadows-find + (list (ert-resource-file "p1/") + (ert-resource-file "p2/")))))) + (cl-letf (((symbol-function 'file-name-case-insensitive-p) (lambda (_f) nil))) + (should-not (load-path-shadows-find + (list (ert-resource-file "p1/") + (ert-resource-file "p2/")))))) + +;;; shadow-tests.el ends here. diff --git a/test/lisp/emacs-lisp/shortdoc-tests.el b/test/lisp/emacs-lisp/shortdoc-tests.el new file mode 100644 index 00000000000..8515b9fdfb9 --- /dev/null +++ b/test/lisp/emacs-lisp/shortdoc-tests.el @@ -0,0 +1,60 @@ +;;; shortdoc-tests.el --- tests for shortdoc.el -*- lexical-binding: t -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'shortdoc) + +(defun shortdoc-tests--tree-contains (tree fun) + "Whether TREE contains a call to FUN." + (and (proper-list-p tree) + (or (eq (car tree) fun) + (cl-some (lambda (x) (shortdoc-tests--tree-contains x fun)) tree)))) + +(ert-deftest shortdoc-examples () + "Check that each example actually contains the corresponding form." + (dolist (group shortdoc--groups) + (dolist (item group) + (when (consp item) + (let ((fun (car item)) + (props (cdr item))) + (while props + (when (memq (car props) '(:eval :no-eval :no-eval* :no-value)) + (let* ((example (cadr props)) + (expr (cond + ((consp example) example) + ((stringp example) (read example))))) + (should (shortdoc-tests--tree-contains expr fun)))) + (setq props (cddr props)))))))) + +(ert-deftest shortdoc-all-groups-work () + "Test that all defined shortdoc groups display correctly." + (dolist (group (mapcar (lambda (x) (car x)) shortdoc--groups)) + (let ((buf-name (format "*Shortdoc %s*" group)) buf) + (unwind-protect + (progn + (shortdoc-display-group group) + (should (setq buf (get-buffer buf-name)))) + (when buf + (kill-buffer buf)))))) + +(provide 'shortdoc-tests) + +;;; shortdoc-tests.el ends here diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el index 0e8871d9a9c..7a3efe9db62 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -1,22 +1,24 @@ -;;; subr-x-tests.el --- Testing the extended lisp routines +;;; subr-x-tests.el --- Testing the extended lisp routines -*- lexical-binding:t -*- -;; Copyright (C) 2014-2017 Free Software Foundation, Inc. +;; Copyright (C) 2014-2022 Free Software Foundation, Inc. ;; Author: Fabián E. Gallina <fgallina@gnu.org> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; 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. ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -148,34 +150,34 @@ "Test `if-let' with falsie bindings." (should (equal (if-let* ((a nil)) - (list a b c) + "yes" "no") "no")) (should (equal (if-let* ((a nil) (b 2) (c 3)) - (list a b c) + "yes" "no") "no")) (should (equal (if-let* ((a 1) (b nil) (c 3)) - (list a b c) + "yes" "no") "no")) (should (equal (if-let* ((a 1) (b 2) (c nil)) - (list a b c) + "yes" "no") "no")) (should (equal - (let (z) + (let ((z nil)) (if-let* (z (a 1) (b 2) (c 3)) - (list a b c) + "yes" "no")) "no")) (should (equal - (let (d) + (let ((d nil)) (if-let* ((a 1) (b 2) (c 3) d) - (list a b c) + "yes" "no")) "no"))) @@ -189,7 +191,7 @@ (ert-deftest subr-x-test-if-let*-and-laziness-is-preserved () "Test `if-let' respects `and' laziness." - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) c-called) (should (equal (if-let* ((a nil) (b (setq b-called t)) @@ -197,7 +199,7 @@ "yes" (list a-called b-called c-called)) (list nil nil nil)))) - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) c-called) (should (equal (if-let* ((a (setq a-called t)) (b nil) @@ -205,12 +207,12 @@ "yes" (list a-called b-called c-called)) (list t nil nil)))) - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) c-called) (should (equal (if-let* ((a (setq a-called t)) - (b (setq b-called t)) - (c nil) - (d (setq c-called t))) + (b (setq b-called t)) + (c nil) + (d (setq c-called t))) "yes" (list a-called b-called c-called)) (list t t nil))))) @@ -312,34 +314,28 @@ "Test `when-let' with falsie bindings." (should (equal (when-let* ((a nil)) - (list a b c) "no") nil)) (should (equal (when-let* ((a nil) (b 2) (c 3)) - (list a b c) "no") nil)) (should (equal (when-let* ((a 1) (b nil) (c 3)) - (list a b c) "no") nil)) (should (equal (when-let* ((a 1) (b 2) (c nil)) - (list a b c) "no") nil)) (should (equal - (let (z) + (let ((z nil)) (when-let* (z (a 1) (b 2) (c 3)) - (list a b c) "no")) nil)) (should (equal - (let (d) + (let ((d nil)) (when-let* ((a 1) (b 2) (c 3) d) - (list a b c) "no")) nil))) @@ -352,7 +348,7 @@ (ert-deftest subr-x-test-when-let*-and-laziness-is-preserved () "Test `when-let' respects `and' laziness." - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) (c-called nil)) (should (equal (progn (when-let* ((a nil) @@ -361,7 +357,7 @@ "yes") (list a-called b-called c-called)) (list nil nil nil)))) - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) (c-called nil)) (should (equal (progn (when-let* ((a (setq a-called t)) @@ -370,7 +366,7 @@ "yes") (list a-called b-called c-called)) (list t nil nil)))) - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) (c-called nil)) (should (equal (progn (when-let* ((a (setq a-called t)) @@ -403,7 +399,7 @@ (should-error (eval '(and-let* (nil (x 1))) lexical-binding) :type 'setting-constant) (should (equal nil (and-let* ((nil) (x 1))))) - (should-error (eval (and-let* (2 (x 1))) lexical-binding) + (should-error (eval '(and-let* (2 (x 1))) lexical-binding) :type 'wrong-type-argument) (should (equal 1 (and-let* ((2) (x 1))))) (should (equal 2 (and-let* ((x 1) (2))))) @@ -459,18 +455,18 @@ "Test `thread-first' wraps single function names." (should (equal (macroexpand '(thread-first 5 - -)) + -)) '(- 5))) (should (equal (macroexpand '(thread-first (+ 1 2) - -)) + -)) '(- (+ 1 2))))) (ert-deftest subr-x-test-thread-first-expansion () "Test `thread-first' expands correctly." (should (equal (macroexpand '(thread-first - 5 + 5 (+ 20) (/ 25) - @@ -481,13 +477,13 @@ "Test several `thread-first' examples." (should (equal (thread-first (+ 40 2)) 42)) (should (equal (thread-first - 5 + 5 (+ 20) (/ 25) - (+ 40)) 39)) (should (equal (thread-first - "this-is-a-string" + "this-is-a-string" (split-string "-") (nbutlast 2) (append (list "good"))) @@ -504,18 +500,18 @@ "Test `thread-last' wraps single function names." (should (equal (macroexpand '(thread-last 5 - -)) + -)) '(- 5))) (should (equal (macroexpand '(thread-last (+ 1 2) - -)) + -)) '(- (+ 1 2))))) (ert-deftest subr-x-test-thread-last-expansion () "Test `thread-last' expands correctly." (should (equal (macroexpand '(thread-last - 5 + 5 (+ 20) (/ 25) - @@ -526,18 +522,254 @@ "Test several `thread-last' examples." (should (equal (thread-last (+ 40 2)) 42)) (should (equal (thread-last - 5 + 5 (+ 20) (/ 25) - (+ 40)) 39)) (should (equal (thread-last - (list 1 -2 3 -4 5) + (list 1 -2 3 -4 5) (mapcar #'abs) (cl-reduce #'+) (format "abs sum is: %s")) "abs sum is: 15"))) + +;; Substring tests + +(ert-deftest subr-x-test-string-trim-left () + "Test `string-trim-left' behavior." + (should (equal (string-trim-left "") "")) + (should (equal (string-trim-left " \t\n\r") "")) + (should (equal (string-trim-left " \t\n\ra") "a")) + (should (equal (string-trim-left "a \t\n\r") "a \t\n\r")) + (should (equal (string-trim-left "" "") "")) + (should (equal (string-trim-left "a" "") "a")) + (should (equal (string-trim-left "aa" "a*") "")) + (should (equal (string-trim-left "ba" "a*") "ba")) + (should (equal (string-trim-left "aa" "a*?") "aa")) + (should (equal (string-trim-left "aa" "a+?") "a"))) + +(ert-deftest subr-x-test-string-trim-right () + "Test `string-trim-right' behavior." + (should (equal (string-trim-right "") "")) + (should (equal (string-trim-right " \t\n\r") "")) + (should (equal (string-trim-right " \t\n\ra") " \t\n\ra")) + (should (equal (string-trim-right "a \t\n\r") "a")) + (should (equal (string-trim-right "" "") "")) + (should (equal (string-trim-right "a" "") "a")) + (should (equal (string-trim-right "aa" "a*") "")) + (should (equal (string-trim-right "ab" "a*") "ab")) + (should (equal (string-trim-right "aa" "a*?") ""))) + +(ert-deftest subr-x-test-string-remove-prefix () + "Test `string-remove-prefix' behavior." + (should (equal (string-remove-prefix "" "") "")) + (should (equal (string-remove-prefix "" "a") "a")) + (should (equal (string-remove-prefix "a" "") "")) + (should (equal (string-remove-prefix "a" "b") "b")) + (should (equal (string-remove-prefix "a" "a") "")) + (should (equal (string-remove-prefix "a" "aa") "a")) + (should (equal (string-remove-prefix "a" "ab") "b"))) + +(ert-deftest subr-x-test-string-remove-suffix () + "Test `string-remove-suffix' behavior." + (should (equal (string-remove-suffix "" "") "")) + (should (equal (string-remove-suffix "" "a") "a")) + (should (equal (string-remove-suffix "a" "") "")) + (should (equal (string-remove-suffix "a" "b") "b")) + (should (equal (string-remove-suffix "a" "a") "")) + (should (equal (string-remove-suffix "a" "aa") "a")) + (should (equal (string-remove-suffix "a" "ba") "b"))) + +(ert-deftest subr-clean-whitespace () + (should (equal (string-clean-whitespace " foo ") "foo")) + (should (equal (string-clean-whitespace " foo \r\n\t Bar") "foo Bar"))) + +(ert-deftest subr-string-fill () + (should (equal (string-fill "foo" 10) "foo")) + (should (equal (string-fill "foobar" 5) "foobar")) + (should (equal (string-fill "foo bar zot" 5) "foo\nbar\nzot")) + (should (equal (string-fill "foo bar zot" 7) "foo bar\nzot"))) + +(ert-deftest subr-string-limit () + (should (equal (string-limit "foo" 10) "foo")) + (should (equal (string-limit "foo" 2) "fo")) + (should (equal (string-limit "foo" 2 t) "oo")) + (should (equal (string-limit "abc" 10 t) "abc")) + (should (equal (string-limit "foo" 0) "")) + (should-error (string-limit "foo" -1))) + +(ert-deftest subr-string-limit-coding () + (should (not (multibyte-string-p (string-limit "foó" 10 nil 'utf-8)))) + (should (equal (string-limit "foó" 10 nil 'utf-8) "fo\303\263")) + (should (equal (string-limit "foó" 3 nil 'utf-8) "fo")) + (should (equal (string-limit "foó" 4 nil 'utf-8) "fo\303\263")) + (should (equal (string-limit "foóa" 4 nil 'utf-8) "fo\303\263")) + (should (equal (string-limit "foóá" 4 nil 'utf-8) "fo\303\263")) + (should (equal (string-limit "foóá" 2 nil 'utf-8-with-signature) + "")) + (should (equal (string-limit "foóá" 4 nil 'utf-8-with-signature) + "\357\273\277f")) + (should (equal (string-limit "foóa" 4 nil 'iso-8859-1) "fo\363a")) + (should (equal (string-limit "foóá" 4 nil 'iso-8859-1) "fo\363\341")) + (should (equal (string-limit "foóá" 3 nil 'utf-16) "")) + (should (equal (string-limit "foóá" 6 nil 'utf-16) "\376\377\000f\000o")) + + (should (equal (string-limit "foó" 10 t 'utf-8) "fo\303\263")) + (should (equal (string-limit "foó" 3 t 'utf-8) "o\303\263")) + (should (equal (string-limit "foó" 4 t 'utf-8) "fo\303\263")) + (should (equal (string-limit "foóa" 4 t 'utf-8) "o\303\263a")) + (should (equal (string-limit "foóá" 4 t 'utf-8) "\303\263\303\241")) + (should (equal (string-limit "foóá" 2 t 'utf-8-with-signature) + "")) + (should (equal (string-limit "foóa" 4 t 'iso-8859-1) "fo\363a")) + (should (equal (string-limit "foóá" 4 t 'iso-8859-1) "fo\363\341")) + (should (equal (string-limit "foóá" 6 t 'utf-16) "\376\377\000\363\000\341"))) + +(ert-deftest subr-string-limit-glyphs () + (should (equal (encode-coding-string "Hello, 👼🏻🧑🏼🤝🧑🏻" 'utf-8) + "Hello, \360\237\221\274\360\237\217\273\360\237\247\221\360\237\217\274\342\200\215\360\237\244\235\342\200\215\360\237\247\221\360\237\217\273")) + (should (= (length (encode-coding-string "Hello, 👼🏻🧑🏼🤝🧑🏻" 'utf-8)) 41)) + (should (equal (string-limit "Hello, 👼🏻🧑🏼🤝🧑🏻" 100 nil 'utf-8) + "Hello, \360\237\221\274\360\237\217\273\360\237\247\221\360\237\217\274\342\200\215\360\237\244\235\342\200\215\360\237\247\221\360\237\217\273")) + (should (equal (string-limit "Hello, 👼🏻🧑🏼🤝🧑🏻" 15 nil 'utf-8) + "Hello, \360\237\221\274\360\237\217\273")) + (should (equal (string-limit "Hello, 👼🏻🧑🏼🤝🧑🏻" 10 nil 'utf-8) + "Hello, "))) + +(ert-deftest subr-string-lines () + (should (equal (string-lines "foo") '("foo"))) + (should (equal (string-lines "foo \nbar") '("foo " "bar")))) + +(ert-deftest subr-string-pad () + (should (equal (string-pad "foo" 5) "foo ")) + (should (equal (string-pad "foo" 5 ?-) "foo--")) + (should (equal (string-pad "foo" 5 ?- t) "--foo")) + (should (equal (string-pad "foo" 2 ?-) "foo"))) + +(ert-deftest subr-string-chop-newline () + (should (equal (string-chop-newline "foo\n") "foo")) + (should (equal (string-chop-newline "foo\nbar\n") "foo\nbar")) + (should (equal (string-chop-newline "foo\nbar") "foo\nbar"))) + +(ert-deftest subr-ensure-empty-lines () + (should + (equal + (with-temp-buffer + (insert "foo") + (goto-char (point-min)) + (ensure-empty-lines 2) + (buffer-string)) + "\n\nfoo")) + (should + (equal + (with-temp-buffer + (insert "foo") + (ensure-empty-lines 2) + (buffer-string)) + "foo\n\n\n")) + (should + (equal + (with-temp-buffer + (insert "foo\n") + (ensure-empty-lines 2) + (buffer-string)) + "foo\n\n\n")) + (should + (equal + (with-temp-buffer + (insert "foo\n\n\n\n\n") + (ensure-empty-lines 2) + (buffer-string)) + "foo\n\n\n")) + (should + (equal + (with-temp-buffer + (insert "foo\n\n\n") + (ensure-empty-lines 0) + (buffer-string)) + "foo\n"))) + +(ert-deftest subr-x-test-add-display-text-property () + (with-temp-buffer + (insert "Foo bar zot gazonk") + (add-display-text-property 4 8 'height 2.0) + (add-display-text-property 2 12 'raise 0.5) + (should (equal (get-text-property 2 'display) '(raise 0.5))) + (should (equal (get-text-property 5 'display) + '((raise 0.5) (height 2.0)))) + (should (equal (get-text-property 9 'display) '(raise 0.5)))) + (with-temp-buffer + (insert "Foo bar zot gazonk") + (put-text-property 4 8 'display [(height 2.0)]) + (add-display-text-property 2 12 'raise 0.5) + (should (equal (get-text-property 2 'display) '(raise 0.5))) + (should (equal (get-text-property 5 'display) + [(raise 0.5) (height 2.0)])) + (should (equal (get-text-property 9 'display) '(raise 0.5))))) + +(ert-deftest subr-x-named-let () + (let ((funs ())) + (named-let loop + ((rest '(1 42 3)) + (sum 0)) + (when rest + ;; Here, we make sure that the variables are distinct in every + ;; iteration, since a naive tail-call optimization would tend to end up + ;; with a single `sum' variable being shared by all the closures. + (push (lambda () sum) funs) + ;; Here we add a dummy `sum' variable which shadows the `sum' iteration + ;; variable since a naive tail-call optimization could also trip here + ;; thinking it can `(setq sum ...)' to set the iteration + ;; variable's value. + (let ((sum sum)) + (loop (cdr rest) (+ sum (car rest)))))) + (should (equal (mapcar #'funcall funs) '(43 1 0))))) + +(ert-deftest test-with-buffer-unmodified-if-unchanged () + (with-temp-buffer + (with-buffer-unmodified-if-unchanged + (insert "t")) + (should (buffer-modified-p))) + + (with-temp-buffer + (with-buffer-unmodified-if-unchanged + (insert "t") + (delete-char -1)) + (should-not (buffer-modified-p))) + + ;; Shouldn't error. + (should + (with-temp-buffer + (with-buffer-unmodified-if-unchanged + (insert "t") + (delete-char -1) + (kill-buffer)))) + + (with-temp-buffer + (let ((outer (current-buffer))) + (with-temp-buffer + (let ((inner (current-buffer))) + (with-buffer-unmodified-if-unchanged + (insert "t") + (delete-char -1) + (set-buffer outer)) + (with-current-buffer inner + (should-not (buffer-modified-p)))))))) + +(ert-deftest subr-x--hash-table-keys-and-values () + (let ((h (make-hash-table))) + (puthash 'a 1 h) + (puthash 'c 3 h) + (puthash 'b 2 h) + (should (equal (sort (hash-table-keys h) #'string<) '(a b c))) + (should (equal (sort (hash-table-values h) #'<) '(1 2 3))))) + +(ert-deftest test-string-truncate-left () + (should (equal (string-truncate-left "band" 3) "...d")) + (should (equal (string-truncate-left "band" 2) "...d")) + (should (equal (string-truncate-left "longstring" 8) "...tring"))) (provide 'subr-x-tests) ;;; subr-x-tests.el ends here diff --git a/test/lisp/emacs-lisp/syntax-tests.el b/test/lisp/emacs-lisp/syntax-tests.el new file mode 100644 index 00000000000..f266db5c702 --- /dev/null +++ b/test/lisp/emacs-lisp/syntax-tests.el @@ -0,0 +1,63 @@ +;;; syntax-tests.el --- tests for syntax.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'syntax) + +(ert-deftest syntax-propertize--shift-groups-and-backrefs () + "Test shifting of numbered groups and back-references in regexps." + ;; A numbered group must be shifted. + (should + (string= + (syntax-propertize--shift-groups-and-backrefs + "\\(?2:[abc]+\\)foobar" 2) + "\\(?4:[abc]+\\)foobar")) + ;; A back-reference \1 on a normal sub-regexp context must be + ;; shifted. + (should + (string= + (syntax-propertize--shift-groups-and-backrefs "\\(a\\)\\1" 2) + "\\(a\\)\\3")) + ;; Shifting must not happen if the \1 appears in a character class, + ;; or in a \{\} repetition construct (although \1 isn't valid there + ;; anyway). + (let ((rx-with-class "\\(a\\)[\\1-2]") + (rx-with-rep "\\(a\\)\\{1,\\1\\}")) + (should + (string= + (syntax-propertize--shift-groups-and-backrefs rx-with-class 2) + rx-with-class)) + (should + (string= + (syntax-propertize--shift-groups-and-backrefs rx-with-rep 2) + rx-with-rep))) + ;; Now numbered groups and back-references in combination. + (should + (string= + (syntax-propertize--shift-groups-and-backrefs + "\\(?2:[abc]+\\)foo\\(\\2\\)" 2) + "\\(?4:[abc]+\\)foo\\(\\4\\)")) + ;; Emacs supports only the back-references \1,...,\9, so when a + ;; shift would result in \10 or more, an error must be signalled. + (should-error + (syntax-propertize--shift-groups-and-backrefs "\\(a\\)\\3" 7))) + +;;; syntax-tests.el ends here. diff --git a/test/lisp/emacs-lisp/tabulated-list-test.el b/test/lisp/emacs-lisp/tabulated-list-tests.el index 30a4f8f61b4..3ce4a63f4f0 100644 --- a/test/lisp/emacs-lisp/tabulated-list-test.el +++ b/test/lisp/emacs-lisp/tabulated-list-tests.el @@ -1,6 +1,6 @@ -;;; tabulated-list-test.el --- Tests for emacs-lisp/tabulated-list.el -*- lexical-binding: t; -*- +;;; tabulated-list-tests.el --- Tests for emacs-lisp/tabulated-list.el -*- lexical-binding: t; -*- -;; Copyright (C) 2015-2017 Free Software Foundation, Inc. +;; Copyright (C) 2015-2022 Free Software Foundation, Inc. ;; Author: Artur Malabarba <bruce.connor.am@gmail.com> @@ -55,28 +55,37 @@ (ert-deftest tabulated-list-print () (tabulated-list--test-with-buffer ;; Basic printing. - (should (string= (buffer-substring-no-properties (point-min) (point-max)) - " zzzz-game zzzz-game 2113 installed play zzzz in Emacs + (should (string-equal + (buffer-substring-no-properties (point-min) (point-max)) + "\ + zzzz-game zzzz-game 2113 installed play zzzz in Emacs 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions abc-mode abc-mode 944 available Major mode for editing abc music files - mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) + mode mode 1128 installed A simple mode for editing Actionscript 3 files +")) ;; Preserve position. (forward-line 3) (let ((pos (thing-at-point 'line))) (pop tabulated-list-entries) (tabulated-list-print t) (should (equal (thing-at-point 'line) pos)) - (should (string= (buffer-substring-no-properties (point-min) (point-max)) - " 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions + (should (string-equal + (buffer-substring-no-properties (point-min) (point-max)) + "\ + 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions abc-mode abc-mode 944 available Major mode for editing abc music files - mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) + mode mode 1128 installed A simple mode for editing Actionscript 3 files +")) ;; Check the UPDATE argument (pop tabulated-list-entries) (setf (cdr (car tabulated-list-entries)) (list ["x" "x" "944" "available" " XX"])) (tabulated-list-print t t) - (should (string= (buffer-substring-no-properties (point-min) (point-max)) - " x x 944 available XX - mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) + (should (string-equal + (buffer-substring-no-properties (point-min) (point-max)) + "\ + x x 944 available XX + mode mode 1128 installed A simple mode for editing Actionscript 3 files +")) (should (equal (thing-at-point 'line) pos))))) (ert-deftest tabulated-list-sort () @@ -86,25 +95,32 @@ (skip-chars-forward "[:blank:]") (tabulated-list-sort) (let ((text (buffer-substring-no-properties (point-min) (point-max)))) - (should (string= text " 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions + (should (string-equal + text + "\ + 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions abc-mode abc-mode 944 available Major mode for editing abc music files mode mode 1128 installed A simple mode for editing Actionscript 3 files - zzzz-game zzzz-game 2113 installed play zzzz in Emacs\n")) + zzzz-game zzzz-game 2113 installed play zzzz in Emacs +")) (skip-chars-forward "^[:blank:]") (skip-chars-forward "[:blank:]") (should (equal (get-text-property (point) 'tabulated-list-column-name) "name-2")) (tabulated-list-sort) - ;; Check a `t' as the sorting predicate. + ;; Check a t as the sorting predicate. (should (string= text (buffer-substring-no-properties (point-min) (point-max)))) ;; Invert. (tabulated-list-sort 1) - (should (string= (buffer-substring-no-properties (point-min) (point-max)) - " zzzz-game zzzz-game 2113 installed play zzzz in Emacs + (should (string-equal + (buffer-substring-no-properties (point-min) (point-max)) + "\ + zzzz-game zzzz-game 2113 installed play zzzz in Emacs mode mode 1128 installed A simple mode for editing Actionscript 3 files abc-mode abc-mode 944 available Major mode for editing abc music files - 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions\n")) + 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions +")) ;; Again (tabulated-list-sort 1) (should (string= text (buffer-substring-no-properties (point-min) (point-max))))) @@ -114,5 +130,4 @@ (should-error (tabulated-list-sort) :type 'user-error) (should-error (tabulated-list-sort 4) :type 'user-error))) -(provide 'tabulated-list-test) -;;; tabulated-list-test.el ends here +;;; tabulated-list-tests.el ends here diff --git a/test/lisp/emacs-lisp/testcover-resources/testcases.el b/test/lisp/emacs-lisp/testcover-resources/testcases.el index edb539f4c27..46040be1a6c 100644 --- a/test/lisp/emacs-lisp/testcover-resources/testcases.el +++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el @@ -1,23 +1,23 @@ ;;;; testcases.el -- Test cases for testcover-tests.el -;; Copyright (C) 2017 Free Software Foundation, Inc. +;; Copyright (C) 2017-2022 Free Software Foundation, Inc. ;; Author: Gemini Lasswell ;; 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. -;; +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -53,7 +53,6 @@ ;; ==== constants-bug-25316 ==== "Testcover doesn't splotch constants." -:expected-result :failed ;; ==== (defconst testcover-testcase-const "apples") (defun testcover-testcase-zero () 0) @@ -76,15 +75,14 @@ ;; ==== customize-defcustom-bug-25326 ==== "Testcover doesn't prevent testing of defcustom values." -:expected-result :failed ;; ==== (defgroup testcover-testcase nil - "Test case for testcover" + "Test case for testcover." :group 'lisp :prefix "testcover-testcase-" :version "26.0") (defcustom testcover-testcase-flag t - "Test value used by testcover-tests.el" + "Test value used by testcover-tests.el." :type 'boolean :group 'testcover-testcase) (defun testcover-testcase-get-flag () @@ -113,7 +111,7 @@ "Wrapping a form with noreturn prevents splotching." ;; ==== (defun testcover-testcase-cancel (spacecraft) - (error "no destination for %s" spacecraft)) + (error "No destination for %s" spacecraft)) (defun testcover-testcase-launch (spacecraft planet) (if (null planet) (noreturn (testcover-testcase-cancel spacecraft%%%)) @@ -135,7 +133,6 @@ ;; ==== 1-value-symbol-bug-25316 ==== "Wrapping a form with 1value prevents splotching." -:expected-result :failed ;; ==== (defun testcover-testcase-always-zero (num) (- num%%% num%%%)%%%) @@ -223,14 +220,13 @@ (defun testcover-testcase-cc (arg) (condition-case nil (if (null arg%%%)%%% - (error "foo") + (error "Foo") "0")!!! (error nil))) (should-not (testcover-testcase-cc nil)) ;; ==== quotes-within-backquotes-bug-25316 ==== -"Forms to instrument are found within quotes within backquotes." -:expected-result :failed +"Forms to analyze are found within quotes within backquotes." ;; ==== (defun testcover-testcase-make-list () (list 'defun 'defvar)) @@ -296,7 +292,6 @@ ;; ==== backquote-1value-bug-24509 ==== "Commas within backquotes are recognized as non-1value." -:expected-result :failed ;; ==== (defmacro testcover-testcase-lambda (&rest body) `(lambda () ,@body)) @@ -320,7 +315,6 @@ ;; ==== pcase-bug-24688 ==== "Testcover copes with condition-case within backquoted list." -:expected-result :failed ;; ==== (defun testcover-testcase-pcase (form) (pcase form%%% @@ -335,7 +329,6 @@ ;; ==== defun-in-backquote-bug-11307-and-24743 ==== "Testcover handles defun forms within backquoted list." -:expected-result :failed ;; ==== (defmacro testcover-testcase-defun (name &rest body) (declare (debug (symbolp def-body))) @@ -348,7 +341,6 @@ ;; ==== closure-1value-bug ==== "Testcover does not mark closures as 1value." -:expected-result :failed ;; ==== ;; -*- lexical-binding:t -*- (setq testcover-testcase-foo nil) @@ -365,7 +357,6 @@ ;; ==== by-value-vs-by-reference-bug-25351 ==== "An object created by a 1value expression may be modified by other code." -:expected-result :failed ;; ==== (defun testcover-testcase-ab () (list 'a 'b)) @@ -386,7 +377,7 @@ (should-error (testcover-testcase-thing 3)) ;; ==== dotted-backquote ==== -"Testcover correctly instruments dotted backquoted lists." +"Testcover can analyze code inside dotted backquoted lists." ;; ==== (defun testcover-testcase-dotted-bq (flag extras) (let* ((bq @@ -396,9 +387,16 @@ (should (equal '(a b c) (testcover-testcase-dotted-bq nil '(d e)))) (should (equal '(a b c d e) (testcover-testcase-dotted-bq t '(d e)))) +;; ==== quoted-backquote ==== +"Testcover correctly handles the quoted backquote symbol." +;; ==== +(defun testcover-testcase-special-symbols () + (list '\` '\, '\,@)) + +(should (equal '(\` \, \,@) (testcover-testcase-special-symbols))) + ;; ==== backquoted-vector-bug-25316 ==== -"Testcover reinstruments within backquoted vectors." -:expected-result :failed +"Testcover can analyze code within backquoted vectors." ;; ==== (defun testcover-testcase-vec (a b c) `[,a%%% ,(list b%%% c%%%)%%%]%%%) @@ -413,14 +411,20 @@ (should (equal '([[4 5] 6]) (testcover-testcase-vec-in-list 4 5 6))) (should (equal '([100]) (testcover-testcase-vec-arg 100))) +;; ==== dotted-list-in-vector-bug-30909 ==== +"Testcover can analyze dotted pairs within vectors." +;; ==== +(defun testcover-testcase-vectors-with-dotted-pairs () + (equal [(1 . "x")] [(1 2 . "y")])%%%) +(should-not (testcover-testcase-vectors-with-dotted-pairs)) + ;; ==== vector-in-macro-spec-bug-25316 ==== -"Testcover reinstruments within vectors." -:expected-result :failed +"Testcover can analyze code inside vectors." ;; ==== (defmacro testcover-testcase-nth-case (arg vec) (declare (indent 1) (debug (form (vector &rest form)))) - `(eval (aref ,vec%%% ,arg%%%))%%%) + `(eval (aref ,vec%%% ,arg%%%) t)%%%) (defun testcover-testcase-use-nth-case (choice val) (testcover-testcase-nth-case choice @@ -435,7 +439,6 @@ ;; ==== mapcar-is-not-compose ==== "Mapcar with 1value arguments is not 1value." -:expected-result :failed ;; ==== (defvar testcover-testcase-num 0) (defun testcover-testcase-add-num (n) @@ -450,10 +453,10 @@ ;; ==== function-with-edebug-spec-bug-25316 ==== "Functions can have edebug specs too. -See c-make-font-lock-search-function for an example in the Emacs -sources. The other issue is that it's ok to use quote in an -edebug spec, so testcover needs to cope with that." -:expected-result :failed +See `c-make-font-lock-search-function' for an example in the +Emacs sources. `c-make-font-lock-search-function''s Edebug spec +also contains a quote. See comment in `testcover-analyze-coverage' +regarding the odd-looking coverage result for the quoted form." ;; ==== (defun testcover-testcase-make-function (forms) `(lambda (flag) (if flag 0 ,@forms%%%))%%%) @@ -462,7 +465,7 @@ edebug spec, so testcover needs to cope with that." (("quote" (&rest def-form)))) (defun testcover-testcase-thing () - (testcover-testcase-make-function '((+ 1 (+ 2 (+ 3 (+ 4 5))))))%%%) + (testcover-testcase-make-function '(!!!(+ 1 !!!(+ 2 !!!(+ 3 !!!(+ 4 5)%%%)%%%)%%%)%%%))%%%) (defun testcover-testcase-use-thing () (funcall (testcover-testcase-thing)%%% nil)%%%) @@ -470,7 +473,7 @@ edebug spec, so testcover needs to cope with that." (should (equal (testcover-testcase-use-thing) 15)) ;; ==== backquoted-dotted-alist ==== -"Testcover can instrument a dotted alist constructed with backquote." +"Testcover can analyze a dotted alist constructed with backquote." ;; ==== (defun testcover-testcase-make-alist (expr entries) `((0 . ,expr%%%) . ,entries%%%)%%%) @@ -480,7 +483,6 @@ edebug spec, so testcover needs to cope with that." ;; ==== coverage-of-the-unknown-symbol-bug-25471 ==== "Testcover correctly records coverage of code which uses `unknown'" -:expected-result :failed ;; ==== (defun testcover-testcase-how-do-i-know-you (name) (let ((val 'unknown)) @@ -494,10 +496,18 @@ edebug spec, so testcover needs to cope with that." "Testcover captures and ignores circular list errors." ;; ==== (defun testcover-testcase-cyc1 (a) - (let ((ls (make-list 10 a%%%))) - (nconc ls ls) - ls)) + (let ((ls (make-list 10 a%%%)%%%)) + (nconc ls%%% ls%%%) + ls)) ; The lack of a mark here is due to an ignored circular list error. (testcover-testcase-cyc1 1) (testcover-testcase-cyc1 1) - -;; testcases.el ends here. +(defun testcover-testcase-cyc2 (a b) + (let ((ls1 (make-list 10 a%%%)%%%) + (ls2 (make-list 10 b))) + (nconc ls2 ls2) + (nconc ls1%%% ls2) + ls1)) +(testcover-testcase-cyc2 1 2) +(testcover-testcase-cyc2 1 4) + +;;; testcases.el ends here diff --git a/test/lisp/emacs-lisp/testcover-tests.el b/test/lisp/emacs-lisp/testcover-tests.el index 0f0ee9a5095..39cd3175c26 100644 --- a/test/lisp/emacs-lisp/testcover-tests.el +++ b/test/lisp/emacs-lisp/testcover-tests.el @@ -1,23 +1,23 @@ ;;; testcover-tests.el --- Testcover test suite -*- lexical-binding:t -*- -;; Copyright (C) 2017 Free Software Foundation, Inc. +;; Copyright (C) 2017-2022 Free Software Foundation, Inc. ;; Author: Gemini Lasswell ;; 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. -;; +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -31,26 +31,10 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'testcover) (require 'skeleton) -;; Use `eval-and-compile' around all these definitions because they're -;; used by the macro `testcover-tests-define-tests'. - -(eval-and-compile - (defvar testcover-tests-file-dir - (expand-file-name - "testcover-resources/" - (file-name-directory (or (bound-and-true-p byte-compile-current-file) - load-file-name - buffer-file-name))) - "Directory of the \"testcover-tests.el\" file.")) - -(eval-and-compile - (defvar testcover-tests-test-cases - (expand-file-name "testcases.el" testcover-tests-file-dir) - "File containing marked up code to instrument and check.")) - ;; Convert Testcover's overlays to plain text. (eval-and-compile @@ -61,33 +45,34 @@ testcases.el. This can be used to create test cases if Testcover is working correctly on a code sample. OPTARGS are optional arguments for `testcover-start'." (interactive "r") - (let ((tempfile (make-temp-file "testcover-tests-" nil ".el")) - (code (buffer-substring beg end)) - (marked-up-code)) - (unwind-protect - (progn - (with-temp-file tempfile - (insert code)) - (save-current-buffer - (let ((buf (find-file-noselect tempfile))) - (set-buffer buf) - (apply 'testcover-start (cons tempfile optargs)) - (testcover-mark-all buf) - (dolist (overlay (overlays-in (point-min) (point-max))) - (let ((ov-face (overlay-get overlay 'face))) - (goto-char (overlay-end overlay)) - (cond - ((eq ov-face 'testcover-nohits) (insert "!!!")) - ((eq ov-face 'testcover-1value) (insert "%%%")) - (t nil)))) - (setq marked-up-code (buffer-string))) - (set-buffer-modified-p nil))) - (ignore-errors (kill-buffer (find-file-noselect tempfile))) - (ignore-errors (delete-file tempfile))) - - ;; Now replace the original code with the marked up code. - (delete-region beg end) - (insert marked-up-code)))) + (ert-with-temp-file tempfile + :suffix ".el" + (let ((find-file-suppress-same-file-warnings t) + (code (buffer-substring beg end)) + (marked-up-code)) + (unwind-protect + (progn + (with-temp-file tempfile + (insert code)) + (save-current-buffer + (let ((buf (find-file-noselect tempfile))) + (set-buffer buf) + (apply 'testcover-start (cons tempfile optargs)) + (testcover-mark-all buf) + (dolist (overlay (overlays-in (point-min) (point-max))) + (let ((ov-face (overlay-get overlay 'face))) + (goto-char (overlay-end overlay)) + (cond + ((eq ov-face 'testcover-nohits) (insert "!!!")) + ((eq ov-face 'testcover-1value) (insert "%%%")) + (t nil)))) + (setq marked-up-code (buffer-string))) + (set-buffer-modified-p nil))) + (ignore-errors (kill-buffer (find-file-noselect tempfile)))) + + ;; Now replace the original code with the marked up code. + (delete-region beg end) + (insert marked-up-code))))) (eval-and-compile (defun testcover-tests-unmarkup-region (beg end) @@ -114,33 +99,32 @@ arguments for `testcover-start'." (eval-and-compile (defun testcover-tests-run-test-case (marked-up-code) "Test the operation of Testcover on the string MARKED-UP-CODE." - (let ((tempfile (make-temp-file "testcover-tests-" nil ".el"))) - (unwind-protect - (progn - (with-temp-file tempfile - (insert marked-up-code)) - ;; Remove the marks and mark the code up again. The original - ;; and recreated versions should match. - (save-current-buffer - (set-buffer (find-file-noselect tempfile)) - ;; Fail the test if the debugger tries to become active, - ;; which will happen if Testcover's reinstrumentation - ;; leaves an edebug-enter in the code. This will also - ;; prevent debugging these tests using Edebug. - (cl-letf (((symbol-function #'edebug-enter) - (lambda (&rest _args) - (ert-fail - (concat "Debugger invoked during test run " - "(possible edebug-enter not replaced)"))))) - (dolist (byte-compile '(t nil)) - (testcover-tests-unmarkup-region (point-min) (point-max)) - (unwind-protect - (testcover-tests-markup-region (point-min) (point-max) byte-compile) - (set-buffer-modified-p nil)) - (should (string= marked-up-code - (buffer-string))))))) - (ignore-errors (kill-buffer (find-file-noselect tempfile))) - (ignore-errors (delete-file tempfile)))))) + (ert-with-temp-file tempfile + :suffix ".el" + (let ((find-file-suppress-same-file-warnings t)) + (unwind-protect + (progn + (with-temp-file tempfile + (insert marked-up-code)) + ;; Remove the marks and mark the code up again. The original + ;; and recreated versions should match. + (save-current-buffer + (set-buffer (find-file-noselect tempfile)) + ;; Fail the test if the debugger tries to become active, + ;; which can happen if Testcover fails to attach itself + ;; correctly. Note that this will prevent debugging + ;; these tests using Edebug. + (cl-letf (((symbol-function #'edebug-default-enter) + (lambda (&rest _args) + (ert-fail "Debugger invoked during test run")))) + (dolist (byte-compile '(t nil)) + (testcover-tests-unmarkup-region (point-min) (point-max)) + (unwind-protect + (testcover-tests-markup-region (point-min) (point-max) byte-compile) + (set-buffer-modified-p nil)) + (should (string= marked-up-code + (buffer-string))))))) + (ignore-errors (kill-buffer (find-file-noselect tempfile)))))))) ;; Convert test case file to ert-defmethod. @@ -151,7 +135,7 @@ Construct and return a list of `ert-deftest' forms. See testcases.el for documentation of the test definition format." (let (results) (with-temp-buffer - (insert-file-contents testcover-tests-test-cases) + (insert-file-contents (ert-resource-file "testcases.el")) (goto-char (point-min)) (while (re-search-forward (concat "^;; ==== \\([^ ]+?\\) ====\n" diff --git a/test/lisp/emacs-lisp/text-property-search-tests.el b/test/lisp/emacs-lisp/text-property-search-tests.el new file mode 100644 index 00000000000..98fdd55e85f --- /dev/null +++ b/test/lisp/emacs-lisp/text-property-search-tests.el @@ -0,0 +1,175 @@ +;;; text-property-search-tests.el --- Testing text-property-search -*- lexical-binding:t -*- + +;; Copyright (C) 2018-2022 Free Software Foundation, Inc. + +;; Author: Lars Ingebrigtsen <larsi@gnus.org> +;; Keywords: + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'text-property-search) +(require 'cl-lib) + +(defun text-property-setup () + (insert "This is " + (propertize "bold1" 'face 'bold) + " and this is " + (propertize "italic1" 'face 'italic) + (propertize "bold2" 'face 'bold) + (propertize "italic2" 'face 'italic) + " at the end") + (goto-char (point-min))) + +(defmacro with-test (form result &optional point) + `(with-temp-buffer + (text-property-setup) + (when ,point + (goto-char ,point)) + (should + (equal + (cl-loop for match = ,form + while match + collect (buffer-substring (prop-match-beginning match) + (prop-match-end match))) + ,result)))) + +(ert-deftest text-property-search-forward-bold-t () + (with-test (text-property-search-forward 'face 'bold t) + '("bold1" "bold2"))) + +(ert-deftest text-property-search-forward-bold-nil () + (with-test (text-property-search-forward 'face 'bold nil) + '("This is " " and this is italic1" "italic2 at the end"))) + +(ert-deftest text-property-search-forward-nil-t () + (with-test (text-property-search-forward 'face nil t) + '("This is " " and this is " " at the end"))) + +(ert-deftest text-property-search-forward-nil-nil () + (with-test (text-property-search-forward 'face nil nil) + '("bold1" "italic1" "bold2" "italic2"))) + +(ert-deftest text-property-search-forward-partial-bold-t () + (with-test (text-property-search-forward 'face 'bold t) + '("old1" "bold2") + 10)) + +(ert-deftest text-property-search-forward-partial-non-current-bold-t () + (with-test (text-property-search-forward 'face 'bold t t) + '("bold2") + 10)) + + +(ert-deftest text-property-search-backward-bold-t () + (with-test (text-property-search-backward 'face 'bold t) + '("bold2" "bold1") + (point-max))) + +(ert-deftest text-property-search-backward-bold-nil () + (with-test (text-property-search-backward 'face 'bold nil) + '( "italic2 at the end" " and this is italic1" "This is ") + (point-max))) + +(ert-deftest text-property-search-backward-nil-t () + (with-test (text-property-search-backward 'face nil t) + '(" at the end" " and this is " "This is ") + (point-max))) + +(ert-deftest text-property-search-backward-nil-nil () + (with-test (text-property-search-backward 'face nil nil) + '("italic2" "bold2" "italic1" "bold1") + (point-max))) + +(ert-deftest text-property-search-backward-partial-bold-t () + (with-test (text-property-search-backward 'face 'bold t) + '("b" "bold1") + 35)) + +(ert-deftest text-property-search-backward-partial-non-current-bold-t () + (with-test (text-property-search-backward 'face 'bold t t) + '("bold1") + 35)) + +(defmacro with-match-test (form beginning end value &optional point) + `(with-temp-buffer + (text-property-setup) + (when ,point + (goto-char ,point)) + (should (equal ,form + (make-prop-match :beginning ,beginning + :end ,end + :value ,value))))) + +(ert-deftest text-property-search-forward-prop-match-match-face-nil-nil () + (with-match-test + (text-property-search-forward 'face nil nil) + 9 14 'bold)) + +(ert-deftest text-property-search-forward-prop-match-match-face-bold-t () + (with-match-test + (text-property-search-forward 'face 'bold t) + 9 14 'bold)) + +(ert-deftest text-property-search-forward-prop-match-match-face-bold-nil () + (with-match-test + (text-property-search-forward 'face 'bold nil) + 1 9 nil)) + +(ert-deftest text-property-search-backward-prop-match-match-face-nil-nil () + (with-match-test + (text-property-search-backward 'face nil nil) + 39 46 'italic + (point-max))) + +(ert-deftest text-property-search-backward-prop-match-match-face-italic-t () + (with-match-test + (text-property-search-backward 'face 'italic t) + 39 46 'italic + (point-max))) + +(ert-deftest text-property-search-backward-prop-match-match-face-italic-nil () + (with-match-test + (text-property-search-backward 'face 'italic nil) + 46 57 nil + (point-max))) + + +;;;; Position after search. + +(ert-deftest text-property-search-forward/point-at-beginning () + (with-temp-buffer + (insert (concat "1234" (propertize "567" 'x t) "890")) + (goto-char (point-min)) + (text-property-search-forward 'x t) + (should (= (point) 5)))) + +(ert-deftest text-property-search-backward/point-at-end () + (with-temp-buffer + (insert (concat "1234" (propertize "567" 'x t) "890")) + (goto-char (point-max)) + (text-property-search-backward 'x t) + (should (= (point) 8)))) + +(provide 'text-property-search-tests) + +;;; text-property-search-tests.el ends here diff --git a/test/lisp/emacs-lisp/thunk-tests.el b/test/lisp/emacs-lisp/thunk-tests.el index 973a14b8180..f593737fd22 100644 --- a/test/lisp/emacs-lisp/thunk-tests.el +++ b/test/lisp/emacs-lisp/thunk-tests.el @@ -1,6 +1,6 @@ ;;; thunk-tests.el --- Tests for thunk.el -*- lexical-binding: t -*- -;; Copyright (C) 2015-2017 Free Software Foundation, Inc. +;; Copyright (C) 2015-2022 Free Software Foundation, Inc. ;; Author: Nicolas Petton <nicolas@petton.fr> ;; Maintainer: emacs-devel@gnu.org @@ -51,5 +51,55 @@ (thunk-force thunk) (should (= x 1)))) + + +;; thunk-let tests + +(ert-deftest thunk-let-basic-test () + "Test whether bindings are established." + (should (equal (thunk-let ((x 1) (y 2)) (+ x y)) 3))) + +(ert-deftest thunk-let*-basic-test () + "Test whether bindings are established." + (should (equal (thunk-let* ((x 1) (y (+ 1 x))) (+ x y)) 3))) + +(ert-deftest thunk-let-bound-vars-cant-be-set-test () + "Test whether setting a `thunk-let' bound variable fails." + (should-error + (eval '(thunk-let ((x 1)) (let ((y 7)) (setq x (+ x y)) (* 10 x))) t))) + +(ert-deftest thunk-let-laziness-test () + "Test laziness of `thunk-let'." + (should + (equal (let ((x-evalled nil) + (y-evalled nil)) + (thunk-let ((x (progn (setq x-evalled t) (+ 1 2))) + (y (progn (setq y-evalled t) (+ 3 4)))) + (let ((evalled-y y)) + (list x-evalled y-evalled evalled-y)))) + (list nil t 7)))) + +(ert-deftest thunk-let*-laziness-test () + "Test laziness of `thunk-let*'." + (should + (equal (let ((x-evalled nil) + (y-evalled nil) + (z-evalled nil) + (a-evalled nil)) + (thunk-let* ((x (progn (setq x-evalled t) (+ 1 1))) + (y (progn (setq y-evalled t) (+ x 1))) + (z (progn (setq z-evalled t) (+ y 1))) + (a (progn (setq a-evalled t) (+ z 1)))) + (let ((evalled-z z)) + (list x-evalled y-evalled z-evalled a-evalled evalled-z)))) + (list t t t nil 4)))) + +(ert-deftest thunk-let-bad-binding-test () + "Test whether a bad binding causes an error when expanding." + (should-error (macroexpand '(thunk-let ((x 1 1)) x))) + (should-error (macroexpand '(thunk-let (27) x))) + (should-error (macroexpand '(thunk-let x x)))) + + (provide 'thunk-tests) ;;; thunk-tests.el ends here diff --git a/test/lisp/emacs-lisp/timer-tests.el b/test/lisp/emacs-lisp/timer-tests.el index 916625cac3a..4d974cfd9d7 100644 --- a/test/lisp/emacs-lisp/timer-tests.el +++ b/test/lisp/emacs-lisp/timer-tests.el @@ -1,6 +1,6 @@ ;;; timer-tests.el --- tests for timers -*- lexical-binding:t -*- -;; Copyright (C) 2013-2017 Free Software Foundation, Inc. +;; Copyright (C) 2013-2022 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -36,7 +36,33 @@ (ert-deftest timer-tests-debug-timer-check () ;; This function exists only if --enable-checking. - (if (fboundp 'debug-timer-check) - (should (debug-timer-check)) t)) + (skip-unless (fboundp 'debug-timer-check)) + (when (fboundp 'debug-timer-check) ; silence byte-compiler + (should (debug-timer-check)))) + +(ert-deftest timer-test-multiple-of-time () + (should (time-equal-p + (timer-next-integral-multiple-of-time '(0 0 0 1) (1+ (ash 1 53))) + (list (ash 1 (- 53 16)) 1)))) + +(ert-deftest timer-next-integral-multiple-of-time-2 () + "Test bug#33071." + (let* ((tc (current-time)) + (delta-ticks 1000) + (hz 128000) + (tce (time-convert tc hz)) + (tc+delta (time-add tce (cons delta-ticks hz))) + (tc+deltae (time-convert tc+delta hz)) + (tc+delta-ticks (car tc+deltae)) + (tc-nexte (cons (- tc+delta-ticks (% tc+delta-ticks delta-ticks)) hz)) + (nt (timer-next-integral-multiple-of-time + tc (/ (float delta-ticks) hz))) + (nte (time-convert nt hz))) + (should (equal tc-nexte nte)))) + +(ert-deftest timer-next-integral-multiple-of-time-3 () + "Test bug#33071." + (let ((nt (timer-next-integral-multiple-of-time '(32770 . 65539) 0.5))) + (should (time-equal-p 1 nt)))) ;;; timer-tests.el ends here diff --git a/test/lisp/emacs-lisp/unsafep-tests.el b/test/lisp/emacs-lisp/unsafep-tests.el new file mode 100644 index 00000000000..fdd82b4fc3d --- /dev/null +++ b/test/lisp/emacs-lisp/unsafep-tests.el @@ -0,0 +1,154 @@ +;;; unsafep-tests.el --- tests for unsafep.el -*- lexical-binding: t; -*- + +;; Author: Jonathan Yavner <jyavner@member.fsf.org> + +;; Copyright (C) 2002-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'unsafep) + +(defvar safe-functions) + +;;; These forms are all considered safe +(defconst unsafep-tests--safe + '(((lambda (x) (* x 2)) 14) + (apply 'cdr (mapcar (lambda (x) (car x)) y)) + (cond ((= x 4) 5) (t 27)) + (condition-case x (car y) (error (car x))) + (let (x) (dolist (y '(1 2 3) (1+ y)) (push y x))) + (let (x) (apply (lambda (x) (* x 2)) 14)) + (let ((x '(2))) (push 1 x) (pop x) (add-to-list 'x 2)) + (let ((x 1) (y 2)) (setq x (+ x y))) + (let ((x 1)) (let ((y (+ x 3))) (* x y))) + (let* nil (current-time)) + (let* ((x 1) (y (+ x 3))) (* x y)) + (mapcar (lambda (x &optional y &rest z) (setq y (+ x 2)) (* y 3)) '(1 2 3)) + (mapconcat #'(lambda (var) (propertize var 'face 'bold)) '("1" "2") ", ") + (setq buffer-display-count 14 mark-active t) + ;;This is not safe if you insert it into a buffer! + (propertize "x" 'display '(height (progn (delete-file "x") 1)))) + "List of forms that `unsafep' should decide are safe.") + +;;; These forms are considered unsafe +(defconst unsafep-tests--unsafe + '(( (add-to-list x y) + . (unquoted x)) + ( (add-to-list y x) + . (unquoted y)) + ( (add-to-list 'y x) + . (global-variable y)) + ( (not (delete-file "unsafep.el")) + . (function delete-file)) + ( (cond (t (aset local-abbrev-table 0 0))) + . (function aset)) + ( (cond (t (setq unsafep-vars ""))) + . (risky-local-variable unsafep-vars)) + ( (condition-case format-alist 1) + . (risky-local-variable format-alist)) + ( (condition-case x 1 (error (setq format-alist ""))) + . (risky-local-variable format-alist)) + ( (dolist (x (sort globalvar 'car)) (princ x)) + . (function sort)) + ( (dotimes (x 14) (delete-file "x")) + . (function delete-file)) + ( (let ((post-command-hook "/tmp/")) 1) + . (risky-local-variable post-command-hook)) + ( (let ((x (delete-file "x"))) 2) + . (function delete-file)) + ( (let (x) (add-to-list 'x (delete-file "x"))) + . (function delete-file)) + ( (let (x) (condition-case y (setq x 1 z 2))) + . (global-variable z)) + ( (let (x) (condition-case z 1 (error (delete-file "x")))) + . (function delete-file)) + ( (let (x) (mapc (lambda (x) (setcar x 1)) '((1 . 2) (3 . 4)))) + . (function setcar)) + ( (let (y) (push (delete-file "x") y)) + . (function delete-file)) + ( (let* ((x 1)) (setq y 14)) + . (global-variable y)) + ( (mapc 'car (list '(1 . 2) (cons 3 4) (kill-buffer "unsafep.el"))) + . (function kill-buffer)) + ( (mapcar x y) + . (unquoted x)) + ( (mapcar (lambda (x) (rename-file x "x")) '("unsafep.el")) + . (function rename-file)) + ( (mapconcat x1 x2 " ") + . (unquoted x1)) + ( (pop format-alist) + . (risky-local-variable format-alist)) + ( (push 1 format-alist) + . (risky-local-variable format-alist)) + ( (setq buffer-display-count (delete-file "x")) + . (function delete-file)) + ;;These are actually safe (they signal errors) + ( (apply '(x) '(1 2 3)) + . (function (x))) + ( (let (((x))) 1) + . (variable (x))) + ( (let (1) 2) + . (variable 1)) + ( (error "Asdf") + . #'error) + ( (signal 'error "asdf") + . #'signal) + ( (throw 'asdf) + . #'throw) + ( (catch 'asdf 17) + . #'catch) + ( (play-sound-file "asdf") + . #'play-sound-file) + ( (replace-regexp-in-string "a" "b") + . #'replace-regexp-in-string) + ) + "A-list of (FORM . REASON)... that `unsafep' should decide are unsafe.") + +(ert-deftest test-unsafep/safe () + "Check safe forms with safe-functions nil." + (let (safe-functions) + (dolist (x unsafep-tests--safe) + (should-not (unsafep x))))) + +(ert-deftest test-unsafep/message () + "Check that message is considered unsafe." + (should (unsafep '(dolist (x y) (message "here: %s" x)))) + (should (unsafep '(dotimes (x 14 (* x 2)) (message "here: %d" x))))) + +(ert-deftest test-unsafep/unsafe () + "Check unsafe forms with safe-functions nil." + (let (safe-functions) + (dolist (x unsafep-tests--unsafe) + (should (equal (unsafep (car x)) (cdr x)))))) + +(ert-deftest test-unsafep/safe-functions-t () + "safe-functions=t should allow delete-file" + (let ((safe-functions t)) + (should-not (unsafep '(delete-file "x"))) + (should-not (unsafep-function 'delete-file)))) + +(ert-deftest test-unsafep/safe-functions-setcar () + "safe-functions=(setcar) should allow setcar but not setcdr" + (let ((safe-functions '(setcar))) + (should-not (unsafep '(setcar x 1))) + (should (unsafep '(setcdr x 1))))) + +(provide 'unsafep-tests) + +;;; unsafep-tests.el ends here diff --git a/test/lisp/emacs-lisp/vtable-tests.el b/test/lisp/emacs-lisp/vtable-tests.el new file mode 100644 index 00000000000..627d9f9c5df --- /dev/null +++ b/test/lisp/emacs-lisp/vtable-tests.el @@ -0,0 +1,42 @@ +;;; vtable-tests.el --- Tests for vtable.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'vtable) +(require 'ert) +(require 'ert-x) + +(ert-deftest test-vstable-compute-columns () + (should + (equal (mapcar + (lambda (column) + (vtable-column-align column)) + (vtable--compute-columns + (make-vtable :columns '("a" "b" "c") + :objects '(("foo" 1 2) + ("bar" 3 :zot)) + :insert nil))) + '(left right left)))) + +;;; vtable-tests.el ends here diff --git a/test/lisp/emacs-lisp/warnings-tests.el b/test/lisp/emacs-lisp/warnings-tests.el new file mode 100644 index 00000000000..3b12092505d --- /dev/null +++ b/test/lisp/emacs-lisp/warnings-tests.el @@ -0,0 +1,60 @@ +;;; warnings-tests.el --- tests for warnings.el -*- lexical-binding: t; -*- + +;; Author: Stefan Kangas <stefankangas@gmail.com> + +;; Copyright (C) 2020-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'warnings) + +(ert-deftest test-warning-suppress-p () + (should (warning-suppress-p 'foo '((foo)))) + (should (warning-suppress-p '(foo bar) '((foo bar)))) + (should (warning-suppress-p '(foo bar baz) '((foo bar)))) + (should-not (warning-suppress-p '(foo bar baz) '((foo bax)))) + (should-not (warning-suppress-p 'foobar nil))) + +(ert-deftest test-display-warning () + (dolist (level '(:emergency :error :warning)) + (with-temp-buffer + (display-warning '(foo) "Hello123" level (current-buffer)) + (should (string-match "foo" (buffer-string))) + (should (string-match "Hello123" (buffer-string)))) + (with-current-buffer "*Messages*" + (should (string-match "Hello123" (buffer-string)))))) + +(ert-deftest test-display-warning/warning-minimum-level () + ;; This test only works interactively: + :expected-result :failed + (let ((warning-minimum-level :emergency)) + (with-temp-buffer + (display-warning '(foo) "baz" :warning (current-buffer))) + (with-current-buffer "*Messages*" + (should-not (string-match "baz" (buffer-string)))))) + +(ert-deftest test-display-warning/warning-minimum-log-level () + (let ((warning-minimum-log-level :error)) + (with-temp-buffer + (display-warning '(foo) "hello" :warning (current-buffer)) + (should-not (string-match "hello" (buffer-string)))))) + +(provide 'warnings-tests) + +;;; warnings-tests.el ends here |