Mercurial > hg > xemacs-beta
annotate tests/automated/test-harness.el @ 5050:6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
-------------------- ChangeLog entries follow: --------------------
ChangeLog addition:
2010-02-20 Ben Wing <ben@xemacs.org>
* configure.ac (XE_COMPLEX_ARG):
Correct doc of --quick-build: It also doesn't check for Lisp shadows.
src/ChangeLog addition:
2010-02-20 Ben Wing <ben@xemacs.org>
* EmacsFrame.c:
* EmacsFrame.c (EmacsFrameRecomputeCellSize):
* alloca.c (i00afunc):
* buffer.c:
* buffer.c (MARKED_SLOT):
* buffer.c (complex_vars_of_buffer):
* cm.c:
* cm.c (cmcheckmagic):
* console.c:
* console.c (MARKED_SLOT):
* device-x.c:
* device-x.c (x_get_visual_depth):
* emacs.c (sort_args):
* eval.c (throw_or_bomb_out):
* event-stream.c:
* event-stream.c (Fadd_timeout):
* event-stream.c (Fadd_async_timeout):
* event-stream.c (Frecent_keys):
* events.c:
* events.c (Fdeallocate_event):
* events.c (event_pixel_translation):
* extents.c:
* extents.c (process_extents_for_insertion_mapper):
* fns.c (Fbase64_encode_region):
* fns.c (Fbase64_encode_string):
* fns.c (Fbase64_decode_region):
* fns.c (Fbase64_decode_string):
* font-lock.c:
* font-lock.c (find_context):
* frame-x.c:
* frame-x.c (x_wm_mark_shell_size_user_specified):
* frame-x.c (x_wm_mark_shell_position_user_specified):
* frame-x.c (x_wm_set_shell_iconic_p):
* frame-x.c (x_wm_set_cell_size):
* frame-x.c (x_wm_set_variable_size):
* frame-x.c (x_wm_store_class_hints):
* frame-x.c (x_wm_maybe_store_wm_command):
* frame-x.c (x_initialize_frame_size):
* frame.c (delete_frame_internal):
* frame.c (change_frame_size_1):
* free-hook.c (check_free):
* free-hook.c (note_block_input):
* free-hook.c (log_gcpro):
* gccache-gtk.c (gc_cache_lookup):
* gccache-x.c:
* gccache-x.c (gc_cache_lookup):
* glyphs-gtk.c:
* glyphs-gtk.c (init_image_instance_from_gdk_pixmap):
* glyphs-x.c:
* glyphs-x.c (extract_xpm_color_names):
* insdel.c:
* insdel.c (move_gap):
* keymap.c:
* keymap.c (keymap_lookup_directly):
* keymap.c (keymap_delete_inverse_internal):
* keymap.c (accessible_keymaps_mapper_1):
* keymap.c (where_is_recursive_mapper):
* lisp.h:
* lstream.c (make_lisp_buffer_stream_1):
* macros.c:
* macros.c (pop_kbd_macro_event):
* mc-alloc.c (remove_page_from_used_list):
* menubar-x.c:
* menubar-x.c (set_frame_menubar):
* ralloc.c:
* ralloc.c (obtain):
* ralloc.c (relinquish):
* ralloc.c (relocate_blocs):
* ralloc.c (resize_bloc):
* ralloc.c (r_alloc_free):
* ralloc.c (r_re_alloc):
* ralloc.c (r_alloc_thaw):
* ralloc.c (init_ralloc):
* ralloc.c (Free_Addr_Block):
* scrollbar-x.c:
* scrollbar-x.c (x_update_scrollbar_instance_status):
* sunplay.c (init_device):
* unexnt.c:
* unexnt.c (read_in_bss):
* unexnt.c (map_in_heap):
* window.c:
* window.c (real_window):
* window.c (window_display_lines):
* window.c (window_display_buffer):
* window.c (set_window_display_buffer):
* window.c (unshow_buffer):
* window.c (Fget_lru_window):
if (...) ABORT(); ---> assert();
More specifically:
if (x == y) ABORT (); --> assert (x != y);
if (x != y) ABORT (); --> assert (x == y);
if (x > y) ABORT (); --> assert (x <= y);
etc.
if (!x) ABORT (); --> assert (x);
if (x) ABORT (); --> assert (!x);
DeMorgan's Law's applied and manually simplified:
if (x && !y) ABORT (); --> assert (!x || y);
if (!x || y >= z) ABORT (); --> assert (x && y < z);
Checked to make sure that assert() of an expression with side
effects ensures that the side effects get executed even when
asserts are disabled, and add a comment about this being a
requirement of any "disabled assert" expression.
* depend:
* make-src-depend:
* make-src-depend (PrintDeps):
Fix broken code in make-src-depend so it does what it was always
supposed to do, which was separate out config.h and lisp.h and
all the files they include into separate variables in the
depend part of Makefile so that quick-build can turn off the
lisp.h/config.h/text.h/etc. dependencies of the source files, to
speed up recompilation.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Sat, 20 Feb 2010 05:05:54 -0600 |
| parents | e813cf16c015 |
| children | 3daf9fc57cd4 |
| rev | line source |
|---|---|
| 428 | 1 ;; test-harness.el --- Run Emacs Lisp test suites. |
| 2 | |
| 1751 | 3 ;;; Copyright (C) 1998, 2002, 2003 Free Software Foundation, Inc. |
| 4856 | 4 ;;; Copyright (C) 2002, 2010 Ben Wing. |
| 428 | 5 |
| 6 ;; Author: Martin Buchholz | |
| 1761 | 7 ;; Maintainer: Stephen J. Turnbull <stephen@xemacs.org> |
| 428 | 8 ;; Keywords: testing |
| 9 | |
| 10 ;; This file is part of XEmacs. | |
| 11 | |
| 12 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 13 ;; under the terms of the GNU General Public License as published by | |
| 14 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 15 ;; any later version. | |
| 16 | |
| 17 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 20 ;; General Public License for more details. | |
| 21 | |
| 22 ;; You should have received a copy of the GNU General Public License | |
| 23 ;; along with XEmacs; see the file COPYING. If not, write to the | |
| 24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 25 ;; Boston, MA 02111-1307, USA. | |
| 26 | |
| 27 ;;; Synched up with: Not in FSF. | |
| 28 | |
| 29 ;;; Commentary: | |
| 30 | |
| 31 ;;; A test suite harness for testing XEmacs. | |
| 32 ;;; The actual tests are in other files in this directory. | |
| 33 ;;; Basically you just create files of emacs-lisp, and use the | |
| 1095 | 34 ;;; Assert, Check-Error, Check-Message, and Check-Error-Message functions |
| 35 ;;; to create tests. See `test-harness-from-buffer' below. | |
| 36 ;;; Don't suppress tests just because they're due to known bugs not yet | |
| 1413 | 37 ;;; fixed -- use the Known-Bug-Expect-Failure and |
| 38 ;;; Implementation-Incomplete-Expect-Failure wrapper macros to mark them. | |
| 1095 | 39 ;;; A lot of the tests we run push limits; suppress Ebola message with the |
| 40 ;;; Ignore-Ebola wrapper macro. | |
| 3472 | 41 ;;; Some noisy code will call `message'. Output from `message' can be |
| 42 ;;; suppressed with the Silence-Message macro. Functions that are known to | |
| 43 ;;; issue messages include `write-region', `find-tag', `tag-loop-continue', | |
| 44 ;;; `insert', and `mark-whole-buffer'. N.B. The Silence-Message macro | |
| 45 ;;; currently does not suppress the newlines printed by `message'. | |
| 46 ;;; Definitely do not use Silence-Message with Check-Message. | |
| 47 ;;; In general it should probably only be used on code that prepares for a | |
| 48 ;;; test, not on tests. | |
| 1095 | 49 ;;; |
| 428 | 50 ;;; You run the tests using M-x test-emacs-test-file, |
| 51 ;;; or $(EMACS) -batch -l .../test-harness.el -f batch-test-emacs file ... | |
| 52 ;;; which is run for you by the `make check' target in the top-level Makefile. | |
| 53 | |
| 54 (require 'bytecomp) | |
| 55 | |
| 3471 | 56 (defvar unexpected-test-suite-failures 0 |
| 57 "Cumulative number of unexpected failures since test-harness was loaded. | |
| 58 | |
| 59 \"Unexpected failures\" are those caught by a generic handler established | |
| 60 outside of the test context. As such they involve an abort of the test | |
| 61 suite for the file being tested. | |
| 62 | |
| 63 They often occur during preparation of a test or recording of the results. | |
| 64 For example, an executable used to generate test data might not be present | |
| 65 on the system, or a system error might occur while reading a data file.") | |
| 66 | |
| 67 (defvar unexpected-test-suite-failure-files nil | |
| 68 "List of test files causing unexpected failures.") | |
| 69 | |
| 70 ;; Declared for dynamic scope; _do not_ initialize here. | |
| 71 (defvar unexpected-test-file-failures) | |
| 72 | |
| 1758 | 73 (defvar test-harness-test-compiled nil |
|
4366
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
74 "Non-nil means the test code was compiled before execution. |
|
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
75 |
|
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
76 You probably should not make tests depend on compilation. |
|
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
77 However, it can be useful to conditionally change messages based on whether |
|
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
78 the code was compiled or not. For example, the case that motivated the |
|
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
79 implementation of this variable: |
|
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
80 |
|
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
81 \(when test-harness-test-compiled |
|
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
82 ;; this ha-a-ack depends on the failing compiled test coming last |
|
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
83 \(setq test-harness-failure-tag |
|
7b628daa39d4
Move debugging code to usage example.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4323
diff
changeset
|
84 \"KNOWN BUG - fix reverted; after 2003-10-31 notify stephen\n\"))") |
| 1758 | 85 |
| 428 | 86 (defvar test-harness-verbose |
| 87 (and (not noninteractive) (> (device-baud-rate) search-slow-speed)) | |
| 88 "*Non-nil means print messages describing progress of emacs-tester.") | |
| 89 | |
| 1719 | 90 (defvar test-harness-file-results-alist nil |
| 91 "Each element is a list (FILE SUCCESSES TESTS). | |
| 92 The order is the reverse of the order in which tests are run. | |
| 93 | |
| 94 FILE is a string naming the test file. | |
| 95 SUCCESSES is a non-negative integer, the number of successes. | |
| 96 TESTS is a non-negative integer, the number of tests run.") | |
| 97 | |
| 1425 | 98 (defvar test-harness-risk-infloops nil |
| 99 "*Non-nil to run tests that may loop infinitely in buggy implementations.") | |
| 100 | |
| 428 | 101 (defvar test-harness-current-file nil) |
| 102 | |
| 103 (defvar emacs-lisp-file-regexp (purecopy "\\.el\\'") | |
| 104 "*Regexp which matches Emacs Lisp source files.") | |
| 105 | |
| 1751 | 106 (defconst test-harness-file-summary-template |
| 107 (format "%%-%ds %%%dd of %%%dd tests successful (%%3d%%%%)." | |
| 108 (length "byte-compiler-tests.el:") ; use the longest file name | |
| 109 5 | |
| 110 5) | |
| 111 "Format for summary lines printed after each file is run.") | |
| 112 | |
| 113 (defconst test-harness-null-summary-template | |
| 114 (format "%%-%ds No tests run." | |
| 115 (length "byte-compiler-tests.el:")) ; use the longest file name | |
| 116 "Format for \"No tests\" lines printed after a file is run.") | |
| 117 | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
118 (defconst test-harness-aborted-summary-template |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
119 (format "%%-%ds %%%dd tests completed (aborted)." |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
120 (length "byte-compiler-tests.el:") ; use the longest file name |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
121 5) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
122 "Format for summary lines printed after a test run on a file was aborted.") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
123 |
| 428 | 124 ;;;###autoload |
| 125 (defun test-emacs-test-file (filename) | |
| 126 "Test a file of Lisp code named FILENAME. | |
| 127 The output file's name is made by appending `c' to the end of FILENAME." | |
| 128 (interactive | |
| 129 (let ((file buffer-file-name) | |
| 130 (file-name nil) | |
| 131 (file-dir nil)) | |
| 132 (and file | |
| 133 (eq (cdr (assq 'major-mode (buffer-local-variables))) | |
| 134 'emacs-lisp-mode) | |
| 135 (setq file-name (file-name-nondirectory file) | |
| 136 file-dir (file-name-directory file))) | |
| 137 (list (read-file-name "Test file: " file-dir nil nil file-name)))) | |
| 138 ;; Expand now so we get the current buffer's defaults | |
| 139 (setq filename (expand-file-name filename)) | |
| 140 | |
| 141 ;; If we're testing a file that's in a buffer and is modified, offer | |
| 142 ;; to save it first. | |
| 143 (or noninteractive | |
| 144 (let ((b (get-file-buffer (expand-file-name filename)))) | |
| 145 (if (and b (buffer-modified-p b) | |
| 146 (y-or-n-p (format "save buffer %s first? " (buffer-name b)))) | |
| 147 (save-excursion (set-buffer b) (save-buffer))))) | |
| 148 | |
| 149 (if (or noninteractive test-harness-verbose) | |
| 150 (message "Testing %s..." filename)) | |
| 151 (let ((test-harness-current-file filename) | |
| 152 input-buffer) | |
| 153 (save-excursion | |
| 154 (setq input-buffer (get-buffer-create " *Test Input*")) | |
| 155 (set-buffer input-buffer) | |
| 156 (erase-buffer) | |
| 157 (insert-file-contents filename) | |
| 158 ;; Run hooks including the uncompression hook. | |
| 159 ;; If they change the file name, then change it for the output also. | |
| 160 (let ((buffer-file-name filename) | |
| 161 (default-major-mode 'emacs-lisp-mode) | |
| 162 (enable-local-eval nil)) | |
| 163 (normal-mode) | |
| 164 (setq filename buffer-file-name))) | |
| 165 (test-harness-from-buffer input-buffer filename) | |
| 166 (kill-buffer input-buffer) | |
| 167 )) | |
| 168 | |
| 169 (defun test-harness-read-from-buffer (buffer) | |
| 170 "Read forms from BUFFER, and turn it into a lambda test form." | |
| 171 (let ((body nil)) | |
| 172 (goto-char (point-min) buffer) | |
| 173 (condition-case error-info | |
| 174 (while t | |
| 175 (setq body (cons (read buffer) body))) | |
| 176 (end-of-file nil) | |
| 177 (error | |
| 3471 | 178 (incf unexpected-test-file-failures) |
| 1751 | 179 (princ (format "Unexpected error %S reading forms from buffer\n" |
| 180 error-info)))) | |
| 428 | 181 `(lambda () |
| 182 (defvar passes) | |
| 183 (defvar assertion-failures) | |
| 184 (defvar no-error-failures) | |
| 185 (defvar wrong-error-failures) | |
| 186 (defvar missing-message-failures) | |
| 187 (defvar other-failures) | |
| 188 | |
| 189 (defvar trick-optimizer) | |
| 190 | |
| 191 ,@(nreverse body)))) | |
| 192 | |
| 193 (defun test-harness-from-buffer (inbuffer filename) | |
| 194 "Run tests in buffer INBUFFER, visiting FILENAME." | |
| 195 (defvar trick-optimizer) | |
| 196 (let ((passes 0) | |
| 197 (assertion-failures 0) | |
| 198 (no-error-failures 0) | |
| 199 (wrong-error-failures 0) | |
| 200 (missing-message-failures 0) | |
| 201 (other-failures 0) | |
| 3471 | 202 (unexpected-test-file-failures 0) |
| 428 | 203 |
| 973 | 204 ;; #### perhaps this should be a defvar, and output at the very end |
| 205 ;; OTOH, this way AC types can use a null EMACSPACKAGEPATH to find | |
| 206 ;; what stuff is needed, and ways to avoid using them | |
| 207 (skipped-test-reasons (make-hash-table :test 'equal)) | |
| 208 | |
| 428 | 209 (trick-optimizer nil) |
| 826 | 210 (debug-on-error t) |
| 211 (pass-stream nil)) | |
| 428 | 212 (with-output-to-temp-buffer "*Test-Log*" |
| 826 | 213 (princ (format "Testing %s...\n\n" filename)) |
| 1095 | 214 |
| 1413 | 215 (defconst test-harness-failure-tag "FAIL") |
| 216 (defconst test-harness-success-tag "PASS") | |
| 1095 | 217 |
|
4891
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
218 ;;;;; BEGIN DEFINITION OF MACROS USEFUL IN TEST CODE |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
219 |
| 1095 | 220 (defmacro Known-Bug-Expect-Failure (&rest body) |
|
4891
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
221 "Wrap a BODY that consists of tests that are known to fail. |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
222 This causes messages to be printed on failure indicating that this is expected, |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
223 and on success indicating that this is unexpected." |
| 1413 | 224 `(let ((test-harness-failure-tag "KNOWN BUG") |
| 225 (test-harness-success-tag "PASS (FAILURE EXPECTED)")) | |
| 226 ,@body)) | |
|
4323
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
227 |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
228 (defmacro Known-Bug-Expect-Error (expected-error &rest body) |
|
4891
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
229 "Wrap a BODY that consists of tests that are known to trigger an error. |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
230 This causes messages to be printed on failure indicating that this is expected, |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
231 and on success indicating that this is unexpected." |
|
4323
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
232 (let ((quoted-body (if (= 1 (length body)) |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
233 `(quote ,(car body)) `(quote (progn ,@body))))) |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
234 `(let ((test-harness-failure-tag "KNOWN BUG") |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
235 (test-harness-success-tag "PASS (FAILURE EXPECTED)")) |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
236 (condition-case error-info |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
237 (progn |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
238 (setq trick-optimizer (progn ,@body)) |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
239 (Print-Pass |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
240 "%S executed successfully, but expected error %S" |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
241 ,quoted-body |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
242 ',expected-error) |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
243 (incf passes)) |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
244 (,expected-error |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
245 (Print-Failure "%S ==> error %S, as expected" |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
246 ,quoted-body ',expected-error) |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
247 (incf no-error-failures)) |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
248 (error |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
249 (Print-Failure "%S ==> expected error %S, got error %S instead" |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
250 ,quoted-body ',expected-error error-info) |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
251 (incf wrong-error-failures)))))) |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
252 |
| 1413 | 253 (defmacro Implementation-Incomplete-Expect-Failure (&rest body) |
|
4891
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
254 "Wrap a BODY containing tests that are known to fail due to incomplete code. |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
255 This causes messages to be printed on failure indicating that the |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
256 implementation is incomplete (and hence the failure is expected); and on |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
257 success indicating that this is unexpected." |
| 1413 | 258 `(let ((test-harness-failure-tag "IMPLEMENTATION INCOMPLETE") |
| 259 (test-harness-success-tag "PASS (FAILURE EXPECTED)")) | |
| 260 ,@body)) | |
| 826 | 261 |
| 262 (defun Print-Failure (fmt &rest args) | |
| 1413 | 263 (setq fmt (format "%s: %s" test-harness-failure-tag fmt)) |
| 826 | 264 (if (noninteractive) (apply #'message fmt args)) |
| 265 (princ (concat (apply #'format fmt args) "\n"))) | |
| 266 | |
| 267 (defun Print-Pass (fmt &rest args) | |
| 1413 | 268 (setq fmt (format "%s: %s" test-harness-success-tag fmt)) |
| 826 | 269 (and test-harness-verbose |
| 270 (princ (concat (apply #'format fmt args) "\n")))) | |
| 271 | |
| 973 | 272 (defun Print-Skip (test reason &optional fmt &rest args) |
| 1095 | 273 (setq fmt (concat "SKIP: %S BECAUSE %S" fmt)) |
| 973 | 274 (princ (concat (apply #'format fmt test reason args) "\n"))) |
| 275 | |
| 1095 | 276 (defmacro Skip-Test-Unless (condition reason description &rest body) |
| 277 "Unless CONDITION is satisfied, skip test BODY. | |
| 278 REASON is a description of the condition failure, and must be unique (it | |
| 279 is used as a hash key). DESCRIPTION describes the tests that were skipped. | |
| 280 BODY is a sequence of expressions and may contain several tests." | |
| 281 `(if (not ,condition) | |
| 282 (let ((count (gethash ,reason skipped-test-reasons))) | |
| 283 (puthash ,reason (if (null count) 1 (1+ count)) | |
| 284 skipped-test-reasons) | |
| 285 (Print-Skip ,description ,reason)) | |
| 286 ,@body)) | |
| 428 | 287 |
|
4747
294a86d29f99
Eliminate C asserts from c-tests.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4415
diff
changeset
|
288 (defmacro Assert (assertion &optional failing-case description) |
|
294a86d29f99
Eliminate C asserts from c-tests.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4415
diff
changeset
|
289 "Test passes if ASSERTION is true. |
| 4856 | 290 Optional FAILING-CASE describes the particular failure. Optional |
| 291 DESCRIPTION describes the assertion; by default, the unevalated assertion | |
| 292 expression is given. FAILING-CASE and DESCRIPTION are useful when Assert | |
| 293 is used in a loop." | |
| 294 (let ((description | |
| 295 (or description `(quote ,assertion)))) | |
| 296 `(condition-case error-info | |
| 297 (progn | |
| 298 (assert ,assertion) | |
| 299 (Print-Pass "%S" ,description) | |
| 300 (incf passes)) | |
| 301 (cl-assertion-failed | |
| 302 (Print-Failure (if ,failing-case | |
| 303 "Assertion failed: %S; failing case = %S" | |
| 304 "Assertion failed: %S") | |
| 305 ,description ,failing-case) | |
| 306 (incf assertion-failures)) | |
| 307 (t (Print-Failure (if ,failing-case | |
| 308 "%S ==> error: %S; failing case = %S" | |
| 309 "%S ==> error: %S") | |
| 310 ,description error-info ,failing-case) | |
| 311 (incf other-failures) | |
| 312 )))) | |
| 2056 | 313 |
|
4891
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
314 ;;;;; BEGIN DEFINITION OF SPECIFIC KINDS OF ASSERT MACROS |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
315 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
316 (defmacro Assert-test (test testval expected &optional failing-case |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
317 description) |
|
4891
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
318 "Test passes if TESTVAL compares correctly to EXPECTED using TEST. |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
319 TEST should be a two-argument predicate (i.e. a function of two arguments |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
320 that returns t or nil), such as `eq', `eql', `equal', `equalp', `=', `<=', |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
321 '>', 'file-newer-than-file-p' etc. Optional FAILING-CASE describes the |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
322 particular failure; any value given here will be concatenated with a phrase |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
323 describing the expected and actual values of the comparison. Optional |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
324 DESCRIPTION describes the assertion; by default, the unevalated comparison |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
325 expressions are given. FAILING-CASE and DESCRIPTION are useful when Assert |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
326 is used in a loop." |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
327 (let* ((assertion `(,test ,testval ,expected)) |
|
4891
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
328 (failmsg `(format "%S should be `%s' to %S but isn't" |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
329 ,testval ',test ,expected)) |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
330 (failmsg2 (if failing-case `(concat |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
331 (format "%S, " ,failing-case) |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
332 ,failmsg) |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
333 failmsg))) |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
334 `(Assert ,assertion ,failmsg2 ,description))) |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
335 |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
336 (defmacro Assert-test-not (test testval expected &optional failing-case |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
337 description) |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
338 "Test passes if TESTVAL does not compare correctly to EXPECTED using TEST. |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
339 TEST should be a two-argument predicate (i.e. a function of two arguments |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
340 that returns t or nil), such as `eq', `eql', `equal', `equalp', `=', `<=', |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
341 '>', 'file-newer-than-file-p' etc. Optional FAILING-CASE describes the |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
342 particular failure; any value given here will be concatenated with a phrase |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
343 describing the expected and actual values of the comparison. Optional |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
344 DESCRIPTION describes the assertion; by default, the unevalated comparison |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
345 expressions are given. FAILING-CASE and DESCRIPTION are useful when Assert |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
346 is used in a loop." |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
347 (let* ((assertion `(not (,test ,testval ,expected))) |
|
4891
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
348 (failmsg `(format "%S shouldn't be `%s' to %S but is" |
|
732c35cdded8
fix failing-case output of Assert-test, add Assert-test-not
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
349 ,testval ',test ,expected)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
350 (failmsg2 (if failing-case `(concat |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
351 (format "%S, " ,failing-case) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
352 ,failmsg) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
353 failmsg))) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
354 `(Assert ,assertion ,failmsg2 ,description))) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
355 |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
356 ;; Specific versions of `Assert-test'. These are just convenience |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
357 ;; functions, functioning identically to `Assert-test', and duplicating |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
358 ;; the doc string for each would be too annoying. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
359 (defmacro Assert-eq (testval expected &optional failing-case |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
360 description) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
361 `(Assert-test eq ,testval ,expected ,failing-case ,description)) |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
362 (defmacro Assert-eql (testval expected &optional failing-case |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
363 description) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
364 `(Assert-test eql ,testval ,expected ,failing-case ,description)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
365 (defmacro Assert-equal (testval expected &optional failing-case |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
366 description) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
367 `(Assert-test equal ,testval ,expected ,failing-case ,description)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
368 (defmacro Assert-equalp (testval expected &optional failing-case |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
369 description) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
370 `(Assert-test equalp ,testval ,expected ,failing-case ,description)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
371 (defmacro Assert-string= (testval expected &optional failing-case |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
372 description) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
373 `(Assert-test string= ,testval ,expected ,failing-case ,description)) |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
374 (defmacro Assert= (testval expected &optional failing-case |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
375 description) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
376 `(Assert-test = ,testval ,expected ,failing-case ,description)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
377 (defmacro Assert<= (testval expected &optional failing-case |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
378 description) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
379 `(Assert-test <= ,testval ,expected ,failing-case ,description)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4845
diff
changeset
|
380 |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
381 ;; Specific versions of `Assert-test-not'. These are just convenience |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
382 ;; functions, functioning identically to `Assert-test-not', and |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
383 ;; duplicating the doc string for each would be too annoying. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
384 (defmacro Assert-not-eq (testval expected &optional failing-case |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
385 description) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
386 `(Assert-test-not eq ,testval ,expected ,failing-case ,description)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
387 (defmacro Assert-not-eql (testval expected &optional failing-case |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
388 description) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
389 `(Assert-test-not eql ,testval ,expected ,failing-case ,description)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
390 (defmacro Assert-not-equal (testval expected &optional failing-case |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
391 description) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
392 `(Assert-test-not equal ,testval ,expected ,failing-case ,description)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
393 (defmacro Assert-not-equalp (testval expected &optional failing-case |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
394 description) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
395 `(Assert-test-not equalp ,testval ,expected ,failing-case ,description)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
396 (defmacro Assert-not-string= (testval expected &optional failing-case |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
397 description) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
398 `(Assert-test-not string= ,testval ,expected ,failing-case ,description)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
399 (defmacro Assert-not= (testval expected &optional failing-case |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
400 description) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
401 `(Assert-test-not = ,testval ,expected ,failing-case ,description)) |
| 428 | 402 |
| 403 (defmacro Check-Error (expected-error &rest body) | |
| 404 (let ((quoted-body (if (= 1 (length body)) | |
| 405 `(quote ,(car body)) `(quote (progn ,@body))))) | |
| 406 `(condition-case error-info | |
| 407 (progn | |
| 408 (setq trick-optimizer (progn ,@body)) | |
| 826 | 409 (Print-Failure "%S executed successfully, but expected error %S" |
| 428 | 410 ,quoted-body |
| 826 | 411 ',expected-error) |
| 428 | 412 (incf no-error-failures)) |
| 413 (,expected-error | |
| 826 | 414 (Print-Pass "%S ==> error %S, as expected" |
| 415 ,quoted-body ',expected-error) | |
| 428 | 416 (incf passes)) |
| 417 (error | |
| 826 | 418 (Print-Failure "%S ==> expected error %S, got error %S instead" |
| 419 ,quoted-body ',expected-error error-info) | |
| 428 | 420 (incf wrong-error-failures))))) |
| 421 | |
| 826 | 422 (defmacro Check-Error-Message (expected-error expected-error-regexp |
| 423 &rest body) | |
| 428 | 424 (let ((quoted-body (if (= 1 (length body)) |
| 425 `(quote ,(car body)) `(quote (progn ,@body))))) | |
| 426 `(condition-case error-info | |
| 427 (progn | |
| 428 (setq trick-optimizer (progn ,@body)) | |
| 826 | 429 (Print-Failure "%S executed successfully, but expected error %S" |
| 430 ,quoted-body ',expected-error) | |
| 428 | 431 (incf no-error-failures)) |
| 432 (,expected-error | |
| 4199 | 433 ;; #### Damn, this binding doesn't capture frobs, eg, for |
| 434 ;; invalid_argument() ... you only get the REASON. And for | |
| 435 ;; wrong_type_argument(), there's no reason only FROBs. | |
| 436 ;; If this gets fixed, fix tests in regexp-tests.el. | |
| 428 | 437 (let ((error-message (second error-info))) |
| 438 (if (string-match ,expected-error-regexp error-message) | |
| 439 (progn | |
| 826 | 440 (Print-Pass "%S ==> error %S %S, as expected" |
| 441 ,quoted-body error-message ',expected-error) | |
| 428 | 442 (incf passes)) |
| 826 | 443 (Print-Failure "%S ==> got error %S as expected, but error message %S did not match regexp %S" |
| 444 ,quoted-body ',expected-error error-message ,expected-error-regexp) | |
| 428 | 445 (incf wrong-error-failures)))) |
| 446 (error | |
| 826 | 447 (Print-Failure "%S ==> expected error %S, got error %S instead" |
| 448 ,quoted-body ',expected-error error-info) | |
| 428 | 449 (incf wrong-error-failures))))) |
| 450 | |
| 3472 | 451 ;; Do not use this with Silence-Message. |
| 428 | 452 (defmacro Check-Message (expected-message-regexp &rest body) |
| 1095 | 453 (Skip-Test-Unless (fboundp 'defadvice) |
| 454 "can't defadvice" | |
| 455 expected-message-regexp | |
| 973 | 456 (let ((quoted-body (if (= 1 (length body)) |
| 457 `(quote ,(car body)) | |
| 458 `(quote (progn ,@body))))) | |
| 459 `(let ((messages "")) | |
| 460 (defadvice message (around collect activate) | |
| 461 (defvar messages) | |
| 462 (let ((msg-string (apply 'format (ad-get-args 0)))) | |
| 463 (setq messages (concat messages msg-string)) | |
| 464 msg-string)) | |
| 465 (condition-case error-info | |
| 466 (progn | |
| 467 (setq trick-optimizer (progn ,@body)) | |
| 468 (if (string-match ,expected-message-regexp messages) | |
| 469 (progn | |
| 470 (Print-Pass "%S ==> value %S, message %S, matching %S, as expected" | |
| 471 ,quoted-body trick-optimizer messages ',expected-message-regexp) | |
| 472 (incf passes)) | |
| 473 (Print-Failure "%S ==> value %S, message %S, NOT matching expected %S" | |
| 474 ,quoted-body trick-optimizer messages | |
| 475 ',expected-message-regexp) | |
| 476 (incf missing-message-failures))) | |
| 477 (error | |
| 478 (Print-Failure "%S ==> unexpected error %S" | |
| 479 ,quoted-body error-info) | |
| 480 (incf other-failures))) | |
| 481 (ad-unadvise 'message))))) | |
| 428 | 482 |
| 3472 | 483 ;; #### Perhaps this should override `message' itself, too? |
| 484 (defmacro Silence-Message (&rest body) | |
|
4323
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
485 `(flet ((append-message (&rest args) ()) |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
486 (clear-message (&rest args) ())) |
|
94509abd0ef0
Commit a forgotten chunk of 4d0f773d5e21.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4199
diff
changeset
|
487 ,@body)) |
| 3472 | 488 |
| 428 | 489 (defmacro Ignore-Ebola (&rest body) |
| 490 `(let ((debug-issue-ebola-notices -42)) ,@body)) | |
| 491 | |
| 492 (defun Int-to-Marker (pos) | |
| 493 (save-excursion | |
| 494 (set-buffer standard-output) | |
| 495 (save-excursion | |
| 496 (goto-char pos) | |
| 497 (point-marker)))) | |
| 498 | |
| 499 (princ "Testing Interpreted Lisp\n\n") | |
| 500 (condition-case error-info | |
| 501 (funcall (test-harness-read-from-buffer inbuffer)) | |
| 502 (error | |
| 3471 | 503 (incf unexpected-test-file-failures) |
| 428 | 504 (princ (format "Unexpected error %S while executing interpreted code\n" |
| 505 error-info)) | |
| 506 (message "Unexpected error %S while executing interpreted code." error-info) | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
507 (message "Test suite execution aborted.") |
| 428 | 508 )) |
| 509 (princ "\nTesting Compiled Lisp\n\n") | |
| 1758 | 510 (let (code |
| 511 (test-harness-test-compiled t)) | |
| 428 | 512 (condition-case error-info |
| 446 | 513 (setq code |
| 514 ;; our lisp code is often intentionally dubious, | |
| 515 ;; so throw away _all_ the byte compiler warnings. | |
| 516 (letf (((symbol-function 'byte-compile-warn) 'ignore)) | |
| 517 (byte-compile (test-harness-read-from-buffer inbuffer)))) | |
| 428 | 518 (error |
| 519 (princ (format "Unexpected error %S while byte-compiling code\n" | |
| 520 error-info)))) | |
| 521 (condition-case error-info | |
| 522 (if code (funcall code)) | |
| 523 (error | |
| 3471 | 524 (incf unexpected-test-file-failures) |
| 428 | 525 (princ (format "Unexpected error %S while executing byte-compiled code\n" |
| 526 error-info)) | |
| 527 (message "Unexpected error %S while executing byte-compiled code." error-info) | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
528 (message "Test suite execution aborted.") |
| 428 | 529 ))) |
| 826 | 530 (princ (format "\nSUMMARY for %s:\n" filename)) |
| 428 | 531 (princ (format "\t%5d passes\n" passes)) |
| 532 (princ (format "\t%5d assertion failures\n" assertion-failures)) | |
| 533 (princ (format "\t%5d errors that should have been generated, but weren't\n" no-error-failures)) | |
| 534 (princ (format "\t%5d wrong-error failures\n" wrong-error-failures)) | |
| 535 (princ (format "\t%5d missing-message failures\n" missing-message-failures)) | |
| 536 (princ (format "\t%5d other failures\n" other-failures)) | |
| 537 (let* ((total (+ passes | |
| 538 assertion-failures | |
| 539 no-error-failures | |
| 540 wrong-error-failures | |
| 541 missing-message-failures | |
| 542 other-failures)) | |
| 543 (basename (file-name-nondirectory filename)) | |
| 544 (summary-msg | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
545 (cond ((> unexpected-test-file-failures 0) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
546 (format test-harness-aborted-summary-template |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
547 (concat basename ":") total)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
548 ((> total 0) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
549 (format test-harness-file-summary-template |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
550 (concat basename ":") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
551 passes total (/ (* 100 passes) total))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
552 (t |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
553 (format test-harness-null-summary-template |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
554 (concat basename ":"))))) |
| 973 | 555 (reasons "")) |
| 556 (maphash (lambda (key value) | |
| 557 (setq reasons | |
| 558 (concat reasons | |
| 1095 | 559 (format "\n %d tests skipped because %s." |
| 973 | 560 value key)))) |
| 561 skipped-test-reasons) | |
| 562 (when (> (length reasons) 1) | |
| 563 (setq summary-msg (concat summary-msg reasons " | |
|
4415
bceb3e285ae7
case-tests.el: fix it on non-DEBUG_XEMACS; save standard-case-table, use it
Aidan Kehoe <kehoea@parhasard.net>
parents:
4366
diff
changeset
|
564 It may be that XEmacs cannot find your installed packages. Set |
|
bceb3e285ae7
case-tests.el: fix it on non-DEBUG_XEMACS; save standard-case-table, use it
Aidan Kehoe <kehoea@parhasard.net>
parents:
4366
diff
changeset
|
565 EMACSPACKAGEPATH to the package hierarchy root or configure with |
|
bceb3e285ae7
case-tests.el: fix it on non-DEBUG_XEMACS; save standard-case-table, use it
Aidan Kehoe <kehoea@parhasard.net>
parents:
4366
diff
changeset
|
566 --package-path to enable the skipped tests."))) |
| 1719 | 567 (setq test-harness-file-results-alist |
| 568 (cons (list filename passes total) | |
| 569 test-harness-file-results-alist)) | |
| 428 | 570 (message "%s" summary-msg)) |
| 3471 | 571 (when (> unexpected-test-file-failures 0) |
| 572 (setq unexpected-test-suite-failure-files | |
| 573 (cons filename unexpected-test-suite-failure-files)) | |
| 574 (setq unexpected-test-suite-failures | |
| 575 (+ unexpected-test-suite-failures unexpected-test-file-failures)) | |
| 428 | 576 (message "Test suite execution failed unexpectedly.")) |
| 577 (fmakunbound 'Assert) | |
| 578 (fmakunbound 'Check-Error) | |
| 863 | 579 (fmakunbound 'Check-Message) |
| 580 (fmakunbound 'Check-Error-Message) | |
| 428 | 581 (fmakunbound 'Ignore-Ebola) |
| 582 (fmakunbound 'Int-to-Marker) | |
| 1719 | 583 (and noninteractive |
| 584 (message "%s" (buffer-substring-no-properties | |
| 1751 | 585 nil nil "*Test-Log*"))) |
| 586 ))) | |
| 428 | 587 |
| 588 (defvar test-harness-results-point-max nil) | |
| 589 (defmacro displaying-emacs-test-results (&rest body) | |
| 590 `(let ((test-harness-results-point-max test-harness-results-point-max)) | |
| 591 ;; Log the file name. | |
| 592 (test-harness-log-file) | |
| 593 ;; Record how much is logged now. | |
| 594 ;; We will display the log buffer if anything more is logged | |
| 595 ;; before the end of BODY. | |
| 596 (or test-harness-results-point-max | |
| 597 (save-excursion | |
| 598 (set-buffer (get-buffer-create "*Test-Log*")) | |
| 599 (setq test-harness-results-point-max (point-max)))) | |
| 600 (unwind-protect | |
| 601 (condition-case error-info | |
| 602 (progn ,@body) | |
| 603 (error | |
| 604 (test-harness-report-error error-info))) | |
| 605 (save-excursion | |
| 606 ;; If there were compilation warnings, display them. | |
| 607 (set-buffer "*Test-Log*") | |
| 608 (if (= test-harness-results-point-max (point-max)) | |
| 609 nil | |
| 610 (if temp-buffer-show-function | |
| 611 (let ((show-buffer (get-buffer-create "*Test-Log-Show*"))) | |
| 612 (save-excursion | |
| 613 (set-buffer show-buffer) | |
| 614 (setq buffer-read-only nil) | |
| 615 (erase-buffer)) | |
| 616 (copy-to-buffer show-buffer | |
| 617 (save-excursion | |
| 618 (goto-char test-harness-results-point-max) | |
| 619 (forward-line -1) | |
| 620 (point)) | |
| 621 (point-max)) | |
| 622 (funcall temp-buffer-show-function show-buffer)) | |
| 623 (select-window | |
| 624 (prog1 (selected-window) | |
| 625 (select-window (display-buffer (current-buffer))) | |
| 626 (goto-char test-harness-results-point-max) | |
| 627 (recenter 1))))))))) | |
| 628 | |
| 629 (defun batch-test-emacs-1 (file) | |
| 630 (condition-case error-info | |
| 631 (progn (test-emacs-test-file file) t) | |
| 632 (error | |
| 633 (princ ">>Error occurred processing ") | |
| 634 (princ file) | |
| 635 (princ ": ") | |
| 636 (display-error error-info nil) | |
| 637 (terpri) | |
| 638 nil))) | |
| 639 | |
| 640 (defun batch-test-emacs () | |
| 641 "Run `test-harness' on the files remaining on the command line. | |
| 642 Use this from the command line, with `-batch'; | |
| 643 it won't work in an interactive Emacs. | |
| 644 Each file is processed even if an error occurred previously. | |
|
4948
8b230c53075b
fix some tests in `make check', also add our own file-tests
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
645 A directory can be given as well, and all files will be processed -- |
|
8b230c53075b
fix some tests in `make check', also add our own file-tests
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
646 however, the file test-harness.el, which implements the test harness, |
|
8b230c53075b
fix some tests in `make check', also add our own file-tests
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
647 will be skipped. |
|
8b230c53075b
fix some tests in `make check', also add our own file-tests
Ben Wing <ben@xemacs.org>
parents:
4856
diff
changeset
|
648 For example, invoke \"xemacs -batch -f batch-test-emacs tests\"" |
| 428 | 649 ;; command-line-args-left is what is left of the command line (from |
| 650 ;; startup.el) | |
| 651 (defvar command-line-args-left) ;Avoid 'free variable' warning | |
| 652 (defvar debug-issue-ebola-notices) | |
| 653 (if (not noninteractive) | |
| 654 (error "`batch-test-emacs' is to be used only with -batch")) | |
| 655 (let ((error nil)) | |
| 656 (dolist (file command-line-args-left) | |
| 657 (if (file-directory-p file) | |
| 658 (dolist (file-in-dir (directory-files file t)) | |
| 659 (when (and (string-match emacs-lisp-file-regexp file-in-dir) | |
| 660 (not (or (auto-save-file-name-p file-in-dir) | |
| 661 (backup-file-name-p file-in-dir) | |
| 662 (equal (file-name-nondirectory file-in-dir) | |
| 663 "test-harness.el")))) | |
| 664 (or (batch-test-emacs-1 file-in-dir) | |
| 665 (setq error t)))) | |
| 666 (or (batch-test-emacs-1 file) | |
| 667 (setq error t)))) | |
| 1719 | 668 (let ((namelen 0) |
| 669 (succlen 0) | |
| 670 (testlen 0) | |
| 671 (results test-harness-file-results-alist)) | |
| 672 ;; compute maximum lengths of variable components of report | |
| 673 ;; probably should just use (length "byte-compiler-tests.el") | |
| 674 ;; and 5-place sizes -- this will also work for the file-by-file | |
| 675 ;; printing when Adrian's kludge gets reverted | |
| 676 (flet ((print-width (i) | |
| 677 (let ((x 10) (y 1)) | |
| 678 (while (>= i x) | |
| 679 (setq x (* 10 x) y (1+ y))) | |
| 680 y))) | |
| 681 (while results | |
| 682 (let* ((head (car results)) | |
| 683 (nn (length (file-name-nondirectory (first head)))) | |
| 684 (ss (print-width (second head))) | |
| 685 (tt (print-width (third head)))) | |
| 686 (when (> nn namelen) (setq namelen nn)) | |
| 687 (when (> ss succlen) (setq succlen ss)) | |
| 688 (when (> tt testlen) (setq testlen tt))) | |
| 689 (setq results (cdr results)))) | |
| 690 ;; create format and print | |
| 1751 | 691 (let ((results (reverse test-harness-file-results-alist))) |
| 1719 | 692 (while results |
| 693 (let* ((head (car results)) | |
| 1751 | 694 (basename (file-name-nondirectory (first head))) |
| 1719 | 695 (nsucc (second head)) |
| 696 (ntest (third head))) | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
697 (cond ((member (first head) unexpected-test-suite-failure-files) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
698 (message test-harness-aborted-summary-template |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
699 (concat basename ":") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
700 ntest)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
701 ((> ntest 0) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
702 (message test-harness-file-summary-template |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
703 (concat basename ":") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
704 nsucc |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
705 ntest |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
706 (/ (* 100 nsucc) ntest))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
707 (t |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
708 (message test-harness-null-summary-template |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4891
diff
changeset
|
709 (concat basename ":")))) |
| 3471 | 710 (setq results (cdr results))))) |
| 711 (when (> unexpected-test-suite-failures 0) | |
| 712 (message "\n***** There %s %d unexpected test suite %s in %s:" | |
| 713 (if (= unexpected-test-suite-failures 1) "was" "were") | |
| 714 unexpected-test-suite-failures | |
| 715 (if (= unexpected-test-suite-failures 1) "failure" "failures") | |
| 716 (if (= (length unexpected-test-suite-failure-files) 1) | |
| 717 "file" | |
| 718 "files")) | |
| 719 (while unexpected-test-suite-failure-files | |
| 720 (let ((line (pop unexpected-test-suite-failure-files))) | |
| 721 (while (and (< (length line) 61) | |
| 722 unexpected-test-suite-failure-files) | |
| 723 (setq line | |
| 724 (concat line " " | |
| 725 (pop unexpected-test-suite-failure-files)))) | |
| 726 (message line))))) | |
| 1719 | 727 (message "\nDone") |
| 428 | 728 (kill-emacs (if error 1 0)))) |
| 729 | |
| 730 (provide 'test-harness) | |
| 731 | |
| 732 ;;; test-harness.el ends here |