test/lisp/emacs-lisp/testcover-resources/testcases.el

   1 ;;;; testcases.el -- Test cases for testcover-tests.el
   2
   3 ;; Copyright (C) 2017 Free Software Foundation, Inc.
   4
   5 ;; Author: Gemini Lasswell
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; This program is free software: you can redistribute it and/or
  10 ;; modify it under the terms of the GNU General Public License as
  11 ;; published by the Free Software Foundation, either version 3 of the
  12 ;; License, or (at your option) any later version.
  13 ;;
  14 ;; This program is distributed in the hope that it will be useful, but
  15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 ;; General Public License for more details.
  18 ;;
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program.  If not, see `http://www.gnu.org/licenses/'.
  21
  22 ;;; Commentary:
  23
  24 ;; * This file should not be loaded directly.  It is meant to be read
  25 ;;   by `testcover-tests-build-test-cases'.
  26 ;;
  27 ;; * Test cases begin with ;; ==== name ====.  The symbol name between
  28 ;;   the ===='s is used to create the name of the test.
  29 ;;
  30 ;; * Following the beginning comment place the test docstring and
  31 ;;   any tags or keywords for ERT.  These will be spliced into the
  32 ;;   ert-deftest for the test.
  33 ;;
  34 ;; * To separate the above from the test case code, use another
  35 ;;   comment: ;; ====
  36 ;;
  37 ;; * These special comments should start at the beginning of a line.
  38 ;;
  39 ;; * `testcover-tests-skeleton' will prompt you for a test name and
  40 ;;   insert the special comments.
  41 ;;
  42 ;; * The test case code should be annotated with %%% at the end of
  43 ;;   each form where a tan splotch is expected, and !!! at the end
  44 ;;   of each form where a red mark is expected.
  45 ;;
  46 ;; * If Testcover is working correctly on your code sample, using
  47 ;;   `testcover-tests-markup-region' and
  48 ;;   `testcover-tests-unmarkup-region' can make creating test cases
  49 ;;   easier.
  50
  51 ;;; Code:
  52 ;;; Test Cases:
  53
  54 ;; ==== constants-bug-25316 ====
  55 "Testcover doesn't splotch constants."
  56 :expected-result :failed
  57 ;; ====
  58 (defconst testcover-testcase-const "apples")
  59 (defun testcover-testcase-zero () 0)
  60 (defun testcover-testcase-list-consts ()
  61   (list
  62    emacs-version 10
  63    "hello"
  64    `(a b c ,testcover-testcase-const)
  65    '(1 2 3)
  66    testcover-testcase-const
  67    (testcover-testcase-zero)
  68    nil))
  69
  70 (defun testcover-testcase-add-to-const-list (arg)
  71   (cons arg%%% (testcover-testcase-list-consts))%%%)
  72
  73 (should (equal (testcover-testcase-add-to-const-list 'a)
  74                `(a ,emacs-version 10 "hello" (a b c "apples") (1 2 3)
  75                    "apples" 0 nil)))
  76
  77 ;; ==== customize-defcustom-bug-25326 ====
  78 "Testcover doesn't prevent testing of defcustom values."
  79 :expected-result :failed
  80 ;; ====
  81 (defgroup testcover-testcase nil
  82   "Test case for testcover"
  83   :group 'lisp
  84   :prefix "testcover-testcase-"
  85   :version "26.0")
  86 (defcustom testcover-testcase-flag t
  87   "Test value used by testcover-tests.el"
  88   :type 'boolean
  89   :group 'testcover-testcase)
  90 (defun testcover-testcase-get-flag ()
  91   testcover-testcase-flag)
  92
  93 (testcover-testcase-get-flag)
  94 (setq testcover-testcase-flag (not testcover-testcase-flag))
  95 (testcover-testcase-get-flag)
  96
  97 ;; ==== no-returns ====
  98 "Testcover doesn't splotch functions which don't return."
  99 ;; ====
 100 (defun testcover-testcase-play-ball (retval)
 101   (catch 'ball
 102     (throw 'ball retval%%%))%%%)  ; catch gets marked but not throw
 103
 104 (defun testcover-testcase-not-my-favorite-error-message ()
 105   (signal 'wrong-type-argument (list 'consp nil)))
 106
 107 (should (testcover-testcase-play-ball t))
 108 (condition-case nil
 109     (testcover-testcase-not-my-favorite-error-message)
 110   (error nil))
 111
 112 ;; ==== noreturn-symbol ====
 113 "Wrapping a form with noreturn prevents splotching."
 114 ;; ====
 115 (defun testcover-testcase-cancel (spacecraft)
 116   (error "no destination for %s" spacecraft))
 117 (defun testcover-testcase-launch (spacecraft planet)
 118   (if (null planet)
 119       (noreturn (testcover-testcase-cancel spacecraft%%%))
 120     (list spacecraft%%% planet%%%)%%%)%%%)
 121 (defun testcover-testcase-launch-2 (spacecraft planet)
 122   (if (null planet%%%)%%%
 123     (testcover-testcase-cancel spacecraft%%%)!!!
 124     (list spacecraft!!! planet!!!)!!!)!!!)
 125 (should (equal (testcover-testcase-launch "Curiosity" "Mars") '("Curiosity" "Mars")))
 126 (condition-case err
 127     (testcover-testcase-launch "Voyager" nil)
 128   (error err))
 129 (condition-case err
 130     (testcover-testcase-launch-2 "Voyager II" nil)
 131   (error err))
 132
 133 (should-error (testcover-testcase-launch "Voyager" nil))
 134 (should-error (testcover-testcase-launch-2 "Voyager II" nil))
 135
 136 ;; ==== 1-value-symbol-bug-25316 ====
 137 "Wrapping a form with 1value prevents splotching."
 138 :expected-result :failed
 139 ;; ====
 140 (defun testcover-testcase-always-zero (num)
 141   (- num%%% num%%%)%%%)
 142 (defun testcover-testcase-still-always-zero (num)
 143   (1value (- num%%% num%%% (- num%%% num%%%)%%%)))
 144 (defun testcover-testcase-never-called (num)
 145   (1value (/ num!!! num!!!)!!!)!!!)
 146 (should (eql 0 (testcover-testcase-always-zero 3)))
 147 (should (eql 0 (testcover-testcase-still-always-zero 5)))
 148
 149 ;; ==== dotimes-dolist ====
 150 "Dolist and dotimes with a 1valued return value are 1valued."
 151 ;; ====
 152 (defun testcover-testcase-do-over (things)
 153   (dolist (thing things%%%)
 154     (list thing))
 155   (dolist (thing things%%% 42)
 156     (list thing))
 157   (dolist (thing things%%% things%%%)
 158     (list thing))%%%)
 159 (defun testcover-testcase-do-more (count)
 160   (dotimes (num count%%%)
 161     (+ num num))
 162   (dotimes (num count%%% count%%%)
 163     (+ num num))%%%
 164     (dotimes (num count%%% 0)
 165       (+ num num)))
 166 (should (equal '(a b c) (testcover-testcase-do-over '(a b c))))
 167 (should (eql 0 (testcover-testcase-do-more 2)))
 168
 169 ;; ==== let-last-form ====
 170 "A let form is 1valued if its last form is 1valued."
 171 ;; ====
 172 (defun testcover-testcase-double (num)
 173   (let ((double (* num%%% 2)%%%))
 174     double%%%)%%%)
 175 (defun testcover-testcase-nullbody-let (num)
 176   (let* ((square (* num%%% num%%%)%%%)
 177          (double (* 2 num%%%)%%%))))
 178 (defun testcover-testcase-answer ()
 179   (let ((num 100))
 180     42))
 181 (should-not (testcover-testcase-nullbody-let 3))
 182 (should (eql (testcover-testcase-answer) 42))
 183 (should (eql (testcover-testcase-double 10) 20))
 184
 185 ;; ==== if-with-1value-clauses ====
 186 "An if is 1valued if both then and else are 1valued."
 187 ;; ====
 188 (defun testcover-testcase-describe (val)
 189   (if (zerop val%%%)%%%
 190     "a number"
 191     "a different number"))
 192 (defun testcover-testcase-describe-2 (val)
 193   (if (zerop val)
 194       "zero"
 195     "not zero"))
 196 (defun testcover-testcase-describe-3 (val)
 197   (if (zerop val%%%)%%%
 198     "zero"
 199     (format "%d" val%%%)%%%)%%%)
 200 (should (equal (testcover-testcase-describe 0) "a number"))
 201 (should (equal (testcover-testcase-describe-2 0) "zero"))
 202 (should (equal (testcover-testcase-describe-2 1) "not zero"))
 203 (should (equal (testcover-testcase-describe-3 1) "1"))
 204
 205 ;; ==== cond-with-1value-clauses ====
 206 "A cond form is marked 1valued if all clauses are 1valued."
 207 ;; ====
 208 (defun testcover-testcase-cond (num)
 209   (cond
 210    ((eql num%%% 0)%%% 'a)
 211    ((eql num%%% 1)%%% 'b)
 212    ((eql num!!! 2)!!! 'c)))
 213 (defun testcover-testcase-cond-2 (num)
 214   (cond
 215    ((eql num%%% 0)%%% (cons 'a 0)!!!)
 216    ((eql num%%% 1)%%% 'b))%%%)
 217 (should (eql (testcover-testcase-cond 1) 'b))
 218 (should (eql (testcover-testcase-cond-2 1) 'b))
 219
 220 ;; ==== condition-case-with-1value-components ====
 221 "A condition-case is marked 1valued if its body and handlers are."
 222 ;; ====
 223 (defun testcover-testcase-cc (arg)
 224   (condition-case nil
 225       (if (null arg%%%)%%%
 226         (error "foo")
 227         "0")!!!
 228         (error nil)))
 229 (should-not (testcover-testcase-cc nil))
 230
 231 ;; ==== quotes-within-backquotes-bug-25316 ====
 232 "Forms to instrument are found within quotes within backquotes."
 233 :expected-result :failed
 234 ;; ====
 235 (defun testcover-testcase-make-list ()
 236   (list 'defun 'defvar))
 237 (defmacro testcover-testcase-bq-macro (arg)
 238   (declare (debug t))
 239   `(memq ,arg%%% '(defconst ,@(testcover-testcase-make-list)))%%%)
 240 (defun testcover-testcase-use-bq-macro (arg)
 241   (testcover-testcase-bq-macro arg%%%)%%%)
 242 (should (equal '(defun defvar) (testcover-testcase-use-bq-macro 'defun)))
 243
 244 ;; ==== progn-functions ====
 245 "Some forms are 1value if their last argument is 1value."
 246 ;; ====
 247 (defun testcover-testcase-one (arg)
 248   (progn
 249     (setq arg (1- arg%%%)%%%)%%%)%%%
 250     (progn
 251       (setq arg (1+ arg%%%)%%%)%%%
 252       1))
 253
 254 (should (eql 1 (testcover-testcase-one 0)))
 255 ;; ==== prog1-functions ====
 256 "Some forms are 1value if their first argument is 1value."
 257 ;; ====
 258 (defun testcover-testcase-unwinder (arg)
 259   (unwind-protect
 260       (if ( > arg%%% 0)%%%
 261         1
 262         0)
 263     (format "unwinding %s!" arg%%%)%%%))
 264 (defun testcover-testcase-divider (arg)
 265   (unwind-protect
 266       (/ 100 arg%%%)%%%
 267       (format "unwinding! %s" arg%%%)%%%)%%%)
 268
 269 (should (eq 0 (testcover-testcase-unwinder 0)))
 270 (should (eq 1 (testcover-testcase-divider 100)))
 271
 272 ;; ==== compose-functions ====
 273 "Some functions are 1value if all their arguments are 1value."
 274 ;; ====
 275 (defconst testcover-testcase-count 3)
 276 (defun testcover-testcase-number ()
 277   (+ 1 testcover-testcase-count))
 278 (defun testcover-testcase-more ()
 279   (+ 1 (testcover-testcase-number) testcover-testcase-count))
 280
 281 (should (equal (testcover-testcase-more) 8))
 282
 283 ;; ==== apply-quoted-symbol ====
 284 "Apply with a quoted function symbol treated as 1value if function is."
 285 ;; ====
 286 (defun testcover-testcase-numlist (flag)
 287   (if flag%%%
 288       '(1 2 3)
 289     '(4 5 6)))
 290 (defun testcover-testcase-sum (flag)
 291   (apply '+ (testcover-testcase-numlist flag%%%)))
 292 (defun testcover-testcase-label ()
 293   (apply 'message "edebug uses: %s %s" (list 1 2)!!!)!!!)
 294
 295 (should (equal 6 (testcover-testcase-sum t)))
 296
 297 ;; ==== backquote-1value-bug-24509 ====
 298 "Commas within backquotes are recognized as non-1value."
 299 :expected-result :failed
 300 ;; ====
 301 (defmacro testcover-testcase-lambda (&rest body)
 302   `(lambda () ,@body))
 303
 304 (defun testcover-testcase-example ()
 305   (let ((lambda-1 (testcover-testcase-lambda (format "lambda-%d" 1))%%%)
 306         (lambda-2 (testcover-testcase-lambda (format "lambda-%d" 2))%%%))
 307     (concat (funcall lambda-1%%%)%%% " "
 308             (funcall lambda-2%%%)%%%)%%%)%%%)
 309
 310 (defmacro testcover-testcase-message-symbol (name)
 311   `(message "%s" ',name))
 312
 313 (defun testcover-testcase-example-2 ()
 314   (concat
 315    (testcover-testcase-message-symbol foo)%%%
 316    (testcover-testcase-message-symbol bar)%%%)%%%)
 317
 318 (should (equal "lambda-1 lambda-2" (testcover-testcase-example)))
 319 (should (equal "foobar" (testcover-testcase-example-2)))
 320
 321 ;; ==== pcase-bug-24688 ====
 322 "Testcover copes with condition-case within backquoted list."
 323 :expected-result :failed
 324 ;; ====
 325 (defun testcover-testcase-pcase (form)
 326   (pcase form%%%
 327     (`(condition-case ,var ,protected-form . ,handlers)
 328      (list var%%% protected-form%%% handlers%%%)%%%)
 329     (_ nil))%%%)
 330
 331 (should (equal (testcover-testcase-pcase '(condition-case a
 332                                               (/ 5 a)
 333                                             (error 0)))
 334                '(a (/ 5 a) ((error 0)))))
 335
 336 ;; ==== defun-in-backquote-bug-11307-and-24743 ====
 337 "Testcover handles defun forms within backquoted list."
 338 :expected-result :failed
 339 ;; ====
 340 (defmacro testcover-testcase-defun (name &rest body)
 341   (declare (debug (symbolp def-body)))
 342   `(defun ,name () ,@body))
 343
 344 (testcover-testcase-defun foo (+ 1 2))
 345 (testcover-testcase-defun bar (+ 3 4))
 346 (should (eql (foo) 3))
 347 (should (eql (bar) 7))
 348
 349 ;; ==== closure-1value-bug ====
 350 "Testcover does not mark closures as 1value."
 351 :expected-result :failed
 352 ;; ====
 353 ;; -*- lexical-binding:t -*-
 354 (setq testcover-testcase-foo nil)
 355 (setq testcover-testcase-bar 0)
 356
 357 (defun testcover-testcase-baz (arg)
 358   (setq testcover-testcase-foo
 359         (lambda () (+ arg testcover-testcase-bar%%%))))
 360
 361 (testcover-testcase-baz 2)
 362 (should (equal 2 (funcall testcover-testcase-foo)))
 363 (testcover-testcase-baz 3)
 364 (should (equal 3 (funcall testcover-testcase-foo)))
 365
 366 ;; ==== by-value-vs-by-reference-bug-25351 ====
 367 "An object created by a 1value expression may be modified by other code."
 368 :expected-result :failed
 369 ;; ====
 370 (defun testcover-testcase-ab ()
 371   (list 'a 'b))
 372 (defun testcover-testcase-change-it (arg)
 373   (setf (cadr arg%%%)%%% 'c)%%%
 374   arg%%%)
 375
 376 (should (equal (testcover-testcase-change-it (testcover-testcase-ab)) '(a c)))
 377 (should (equal (testcover-testcase-ab) '(a b)))
 378
 379 ;; ==== 1value-error-test ====
 380 "Forms wrapped by `1value' should always return the same value."
 381 ;; ====
 382 (defun testcover-testcase-thing (arg)
 383   (1value (list 1 arg 3)))
 384
 385 (should (equal '(1 2 3) (testcover-testcase-thing 2)))
 386 (should-error (testcover-testcase-thing 3))
 387
 388 ;; ==== dotted-backquote ====
 389 "Testcover correctly instruments dotted backquoted lists."
 390 ;; ====
 391 (defun testcover-testcase-dotted-bq (flag extras)
 392   (let* ((bq
 393           `(a b c . ,(and flag extras%%%))))
 394     bq))
 395
 396 (should (equal '(a b c) (testcover-testcase-dotted-bq nil '(d e))))
 397 (should (equal '(a b c d e) (testcover-testcase-dotted-bq t '(d e))))
 398
 399 ;; ==== backquoted-vector-bug-25316 ====
 400 "Testcover reinstruments within backquoted vectors."
 401 :expected-result :failed
 402 ;; ====
 403 (defun testcover-testcase-vec (a b c)
 404   `[,a%%% ,(list b%%% c%%%)%%%]%%%)
 405
 406 (defun testcover-testcase-vec-in-list (d e f)
 407   `([[,d%%% ,e%%%] ,f%%%])%%%)
 408
 409 (defun testcover-testcase-vec-arg (num)
 410   (list `[,num%%%]%%%)%%%)
 411
 412 (should (equal [1 (2 3)] (testcover-testcase-vec 1 2 3)))
 413 (should (equal '([[4 5] 6]) (testcover-testcase-vec-in-list 4 5 6)))
 414 (should (equal '([100]) (testcover-testcase-vec-arg 100)))
 415
 416 ;; ==== vector-in-macro-spec-bug-25316 ====
 417 "Testcover reinstruments within vectors."
 418 :expected-result :failed
 419 ;; ====
 420 (defmacro testcover-testcase-nth-case (arg vec)
 421   (declare (indent 1)
 422            (debug (form (vector &rest form))))
 423   `(eval (aref ,vec%%% ,arg%%%))%%%)
 424
 425 (defun testcover-testcase-use-nth-case (choice val)
 426   (testcover-testcase-nth-case choice
 427                                [(+ 1 val!!!)!!!
 428                                 (- 1 val%%%)%%%
 429                                 (* 7 val)
 430                                 (/ 4 val!!!)!!!]))
 431
 432 (should (eql 42 (testcover-testcase-use-nth-case 2 6)))
 433 (should (eql 49 (testcover-testcase-use-nth-case 2 7)))
 434 (should (eql 0 (testcover-testcase-use-nth-case 1 1 )))
 435
 436 ;; ==== mapcar-is-not-compose ====
 437 "Mapcar with 1value arguments is not 1value."
 438 :expected-result :failed
 439 ;; ====
 440 (defvar testcover-testcase-num 0)
 441 (defun testcover-testcase-add-num (n)
 442   (+ testcover-testcase-num n))
 443 (defun testcover-testcase-mapcar-sides ()
 444   (mapcar 'testcover-testcase-add-num '(1 2 3)))
 445
 446 (setq testcover-testcase-num 1)
 447 (should (equal (testcover-testcase-mapcar-sides) '(2 3 4)))
 448 (setq testcover-testcase-num 2)
 449 (should (equal (testcover-testcase-mapcar-sides) '(3 4 5)))
 450
 451 ;; ==== function-with-edebug-spec-bug-25316 ====
 452 "Functions can have edebug specs too.
 453 See c-make-font-lock-search-function for an example in the Emacs
 454 sources.  The other issue is that it's ok to use quote in an
 455 edebug spec, so testcover needs to cope with that."
 456 :expected-result :failed
 457 ;; ====
 458 (defun testcover-testcase-make-function (forms)
 459   `(lambda (flag) (if flag 0 ,@forms%%%))%%%)
 460
 461 (def-edebug-spec testcover-testcase-make-function
 462   (("quote" (&rest def-form))))
 463
 464 (defun testcover-testcase-thing ()
 465   (testcover-testcase-make-function '((+ 1 (+ 2 (+ 3 (+ 4 5))))))%%%)
 466
 467 (defun testcover-testcase-use-thing ()
 468   (funcall (testcover-testcase-thing)%%% nil)%%%)
 469
 470 (should (equal (testcover-testcase-use-thing) 15))
 471
 472 ;; ==== backquoted-dotted-alist ====
 473 "Testcover can instrument a dotted alist constructed with backquote."
 474 ;; ====
 475 (defun testcover-testcase-make-alist (expr entries)
 476   `((0 . ,expr%%%) . ,entries%%%)%%%)
 477
 478 (should (equal (testcover-testcase-make-alist "foo" '((1 . "bar") (2 . "baz")))
 479                '((0 . "foo") (1 . "bar") (2 . "baz"))))
 480
 481 ;; ==== coverage-of-the-unknown-symbol-bug-25471 ====
 482 "Testcover correctly records coverage of code which uses `unknown'"
 483 :expected-result :failed
 484 ;; ====
 485 (defun testcover-testcase-how-do-i-know-you (name)
 486   (let ((val 'unknown))
 487     (when (equal name%%% "Bob")%%%
 488           (setq val 'known)!!!)
 489     val%%%)%%%)
 490
 491 (should (eq (testcover-testcase-how-do-i-know-you "Liz") 'unknown))
 492
 493 ;; testcases.el ends here.