Mercurial > hg > xemacs-beta

comparison tests/automated/test-harness.el @ 4906:6ef8256a020a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
implement equalp in C, fix case-folding, add equal() method for keymaps -------------------- ChangeLog entries follow: -------------------- lisp/ChangeLog addition: 2010-02-01 Ben Wing <ben@xemacs.org> * cl-extra.el: * cl-extra.el (cl-string-vector-equalp): Removed. * cl-extra.el (cl-bit-vector-vector-equalp): Removed. * cl-extra.el (cl-vector-array-equalp): Removed. * cl-extra.el (cl-hash-table-contents-equalp): Removed. * cl-extra.el (equalp): Removed. * cl-extra.el (cl-mapcar-many): Comment out the whole `equalp' implementation for the moment; remove once we're sure the C implementation works. * cl-macs.el: * cl-macs.el (equalp): Simplify the compiler-macro for `equalp' -- once it's in C, we don't need to try so hard to expand it. src/ChangeLog addition: 2010-02-01 Ben Wing <ben@xemacs.org> * abbrev.c (abbrev_match_mapper): * buffer.h (CANON_TABLE_OF): * buffer.h: * editfns.c (Fchar_equal): * minibuf.c (scmp_1): * text.c (qxestrcasecmp_i18n): * text.c (qxestrncasecmp_i18n): * text.c (qxetextcasecmp): * text.c (qxetextcasecmp_matching): Create new macro CANONCASE that converts to a canonical mapping and use it to do caseless comparisons instead of DOWNCASE. * alloc.c: * alloc.c (cons_equal): * alloc.c (vector_equal): * alloc.c (string_equal): * bytecode.c (compiled_function_equal): * chartab.c (char_table_entry_equal): * chartab.c (char_table_equal): * data.c (weak_list_equal): * data.c (weak_box_equal): * data.c (ephemeron_equal): * device-msw.c (equal_devmode): * elhash.c (hash_table_equal): * events.c (event_equal): * extents.c (properties_equal): * extents.c (extent_equal): * faces.c: * faces.c (face_equal): * faces.c (face_hash): * floatfns.c (float_equal): * fns.c: * fns.c (bit_vector_equal): * fns.c (plists_differ): * fns.c (Fplists_eq): * fns.c (Fplists_equal): * fns.c (Flax_plists_eq): * fns.c (Flax_plists_equal): * fns.c (internal_equal): * fns.c (internal_equalp): * fns.c (internal_equal_0): * fns.c (syms_of_fns): * glyphs.c (image_instance_equal): * glyphs.c (glyph_equal): * glyphs.c (glyph_hash): * gui.c (gui_item_equal): * lisp.h: * lrecord.h (struct lrecord_implementation): * marker.c (marker_equal): * number.c (bignum_equal): * number.c (ratio_equal): * number.c (bigfloat_equal): * objects.c (color_instance_equal): * objects.c (font_instance_equal): * opaque.c (equal_opaque): * opaque.c (equal_opaque_ptr): * rangetab.c (range_table_equal): * specifier.c (specifier_equal): Add a `foldcase' param to the equal() method and use it to implement `equalp' comparisons. Also add to plists_differ(), although we don't currently use it here. Rewrite internal_equalp(). Implement cross-type vector comparisons. Don't implement our own handling of numeric promotion -- just use the `=' primitive. Add internal_equal_0(), which takes a `foldcase' param and calls either internal_equal() or internal_equalp(). * buffer.h: When given a 0 for buffer (which is the norm when functions don't have a specific buffer available), use the current buffer's table, not `standard-case-table'; otherwise the current settings are ignored. * casetab.c: * casetab.c (set_case_table): When handling old-style vectors of 256 in `set-case-table' don't overwrite the existing table! Instead create a new table and populate. * device-msw.c (sync_printer_with_devmode): * lisp.h: * text.c (lisp_strcasecmp_ascii): Rename lisp_strcasecmp to lisp_strcasecmp_ascii and use lisp_strcasecmp_i18n for caseless comparisons in some places. * elhash.c: Delete unused lisp_string_hash and lisp_string_equal(). * events.h: * keymap-buttons.h: * keymap.h: * keymap.c (keymap_lookup_directly): * keymap.c (keymap_store): * keymap.c (FROB): * keymap.c (key_desc_list_to_event): * keymap.c (describe_map_mapper): * keymap.c (INCLUDE_BUTTON_ZERO): New file keymap-buttons.h; use to handle buttons 1-26 in place of duplicating code 26 times. * frame-gtk.c (allocate_gtk_frame_struct): * frame-msw.c (mswindows_init_frame_1): Fix some comments about internal_equal() in redisplay that don't apply any more. * keymap-slots.h: * keymap.c: New file keymap-slots.h. Use it to notate the slots in a keymap structure, similar to frameslots.h or coding-system-slots.h. * keymap.c (MARKED_SLOT): * keymap.c (keymap_equal): * keymap.c (keymap_hash): Implement. tests/ChangeLog addition: 2010-02-01 Ben Wing <ben@xemacs.org> * automated/case-tests.el: * automated/case-tests.el (uni-mappings): * automated/search-tests.el: Delete old pristine-case-table code. Rewrite the Unicode torture test to take into account whether overlapping mappings exist for more than one character, and not doing the upcase/downcase comparisons in such cases. * automated/lisp-tests.el (foo): * automated/lisp-tests.el (string-variable): * automated/lisp-tests.el (featurep): Replace Assert (equal ... with Assert-equal; same for other types of equality. Replace some awkward equivalents of Assert-equalp with Assert-equalp. Add lots of equalp tests. * automated/case-tests.el: * automated/regexp-tests.el: * automated/search-tests.el: Fix up the comments at the top of the files. Move rules about where to put tests into case-tests.el. * automated/test-harness.el: * automated/test-harness.el (test-harness-aborted-summary-template): New. * automated/test-harness.el (test-harness-from-buffer): * automated/test-harness.el (batch-test-emacs): Fix Assert-test-not. Create Assert-not-equal and variants. Delete the doc strings from all these convenience functions to avoid excessive repetition; instead use one copy in a comment.
author Ben Wing <ben@xemacs.org>
date Mon, 01 Feb 2010 01:02:40 -0600
parents 732c35cdded8
children e813cf16c015
comparison
equal deleted inserted replaced
4903:70089046adef 4906:6ef8256a020a
112 112
113 (defconst test-harness-null-summary-template 113 (defconst test-harness-null-summary-template
114 (format "%%-%ds No tests run." 114 (format "%%-%ds No tests run."
115 (length "byte-compiler-tests.el:")) ; use the longest file name 115 (length "byte-compiler-tests.el:")) ; use the longest file name
116 "Format for \"No tests\" lines printed after a file is run.") 116 "Format for \"No tests\" lines printed after a file is run.")
117
118 (defconst test-harness-aborted-summary-template
119 (format "%%-%ds %%%dd tests completed (aborted)."
120 (length "byte-compiler-tests.el:") ; use the longest file name
121 5)
122 "Format for summary lines printed after a test run on a file was aborted.")
117 123
118 ;;;###autoload 124 ;;;###autoload
119 (defun test-emacs-test-file (filename) 125 (defun test-emacs-test-file (filename)
120 "Test a file of Lisp code named FILENAME. 126 "Test a file of Lisp code named FILENAME.
121 The output file's name is made by appending `c' to the end of FILENAME." 127 The output file's name is made by appending `c' to the end of FILENAME."
336 particular failure; any value given here will be concatenated with a phrase 342 particular failure; any value given here will be concatenated with a phrase
337 describing the expected and actual values of the comparison. Optional 343 describing the expected and actual values of the comparison. Optional
338 DESCRIPTION describes the assertion; by default, the unevalated comparison 344 DESCRIPTION describes the assertion; by default, the unevalated comparison
339 expressions are given. FAILING-CASE and DESCRIPTION are useful when Assert 345 expressions are given. FAILING-CASE and DESCRIPTION are useful when Assert
340 is used in a loop." 346 is used in a loop."
341 (let* ((assertion `(,test ,testval ,expected)) 347 (let* ((assertion `(not (,test ,testval ,expected)))
342 (failmsg `(format "%S shouldn't be `%s' to %S but is" 348 (failmsg `(format "%S shouldn't be `%s' to %S but is"
343 ,testval ',test ,expected)) 349 ,testval ',test ,expected))
344 (failmsg2 (if failing-case `(concat 350 (failmsg2 (if failing-case `(concat
345 (format "%S, " ,failing-case) 351 (format "%S, " ,failing-case)
346 ,failmsg) 352 ,failmsg)
347 failmsg))) 353 failmsg)))
348 `(Assert ,assertion ,failmsg2 ,description))) 354 `(Assert ,assertion ,failmsg2 ,description)))
349 355
350 (defmacro Assert-eq (testval expected &optional failing-case description) 356 ;; Specific versions of `Assert-test'. These are just convenience
351 "Test passes if TESTVAL is 'eq' to EXPECTED. 357 ;; functions, functioning identically to `Assert-test', and duplicating
352 Optional FAILING-CASE describes the particular failure; any value given 358 ;; the doc string for each would be too annoying.
353 here will be concatenated with a phrase describing the expected and actual 359 (defmacro Assert-eq (testval expected &optional failing-case
354 values of the comparison. Optional DESCRIPTION describes the assertion; by 360 description)
355 default, the unevalated comparison expressions are given. FAILING-CASE and
356 DESCRIPTION are useful when Assert is used in a loop."
357 `(Assert-test eq ,testval ,expected ,failing-case ,description)) 361 `(Assert-test eq ,testval ,expected ,failing-case ,description))
358 362 (defmacro Assert-eql (testval expected &optional failing-case
359 (defmacro Assert-eql (testval expected &optional failing-case description) 363 description)
360 "Test passes if TESTVAL is 'eql' to EXPECTED.
361 Optional FAILING-CASE describes the particular failure; any value given
362 here will be concatenated with a phrase describing the expected and actual
363 values of the comparison. Optional DESCRIPTION describes the assertion; by
364 default, the unevalated comparison expressions are given. FAILING-CASE and
365 DESCRIPTION are useful when Assert is used in a loop."
366 `(Assert-test eql ,testval ,expected ,failing-case ,description)) 364 `(Assert-test eql ,testval ,expected ,failing-case ,description))
367
368 (defmacro Assert-equal (testval expected &optional failing-case 365 (defmacro Assert-equal (testval expected &optional failing-case
369 description) 366 description)
370 "Test passes if TESTVAL is 'equal' to EXPECTED.
371 Optional FAILING-CASE describes the particular failure; any value given
372 here will be concatenated with a phrase describing the expected and actual
373 values of the comparison. Optional DESCRIPTION describes the assertion; by
374 default, the unevalated comparison expressions are given. FAILING-CASE and
375 DESCRIPTION are useful when Assert is used in a loop."
376 `(Assert-test equal ,testval ,expected ,failing-case ,description)) 367 `(Assert-test equal ,testval ,expected ,failing-case ,description))
377
378 (defmacro Assert-equalp (testval expected &optional failing-case 368 (defmacro Assert-equalp (testval expected &optional failing-case
379 description) 369 description)
380 "Test passes if TESTVAL is 'equalp' to EXPECTED.
381 Optional FAILING-CASE describes the particular failure; any value given
382 here will be concatenated with a phrase describing the expected and actual
383 values of the comparison. Optional DESCRIPTION describes the assertion; by
384 default, the unevalated comparison expressions are given. FAILING-CASE and
385 DESCRIPTION are useful when Assert is used in a loop."
386 `(Assert-test equalp ,testval ,expected ,failing-case ,description)) 370 `(Assert-test equalp ,testval ,expected ,failing-case ,description))
387
388 (defmacro Assert-string= (testval expected &optional failing-case 371 (defmacro Assert-string= (testval expected &optional failing-case
389 description) 372 description)
390 "Test passes if TESTVAL is 'string=' to EXPECTED.
391 Optional FAILING-CASE describes the particular failure; any value given
392 here will be concatenated with a phrase describing the expected and actual
393 values of the comparison. Optional DESCRIPTION describes the assertion; by
394 default, the unevalated comparison expressions are given. FAILING-CASE and
395 DESCRIPTION are useful when Assert is used in a loop."
396 `(Assert-test string= ,testval ,expected ,failing-case ,description)) 373 `(Assert-test string= ,testval ,expected ,failing-case ,description))
397 374 (defmacro Assert= (testval expected &optional failing-case
398 (defmacro Assert= (testval expected &optional failing-case description) 375 description)
399 "Test passes if TESTVAL is '=' to EXPECTED.
400 Optional FAILING-CASE describes the particular failure; any value given
401 here will be concatenated with a phrase describing the expected and actual
402 values of the comparison. Optional DESCRIPTION describes the assertion; by
403 default, the unevalated comparison expressions are given. FAILING-CASE and
404 DESCRIPTION are useful when Assert is used in a loop."
405 `(Assert-test = ,testval ,expected ,failing-case ,description)) 376 `(Assert-test = ,testval ,expected ,failing-case ,description))
406 377 (defmacro Assert<= (testval expected &optional failing-case
407 (defmacro Assert<= (testval expected &optional failing-case description) 378 description)
408 "Test passes if TESTVAL is '<=' to EXPECTED.
409 Optional FAILING-CASE describes the particular failure; any value given
410 here will be concatenated with a phrase describing the expected and actual
411 values of the comparison. Optional DESCRIPTION describes the assertion; by
412 default, the unevalated comparison expressions are given. FAILING-CASE and
413 DESCRIPTION are useful when Assert is used in a loop."
414 `(Assert-test <= ,testval ,expected ,failing-case ,description)) 379 `(Assert-test <= ,testval ,expected ,failing-case ,description))
380
381 ;; Specific versions of `Assert-test-not'. These are just convenience
382 ;; functions, functioning identically to `Assert-test-not', and
383 ;; duplicating the doc string for each would be too annoying.
384 (defmacro Assert-not-eq (testval expected &optional failing-case
385 description)
386 `(Assert-test-not eq ,testval ,expected ,failing-case ,description))
387 (defmacro Assert-not-eql (testval expected &optional failing-case
388 description)
389 `(Assert-test-not eql ,testval ,expected ,failing-case ,description))
390 (defmacro Assert-not-equal (testval expected &optional failing-case
391 description)
392 `(Assert-test-not equal ,testval ,expected ,failing-case ,description))
393 (defmacro Assert-not-equalp (testval expected &optional failing-case
394 description)
395 `(Assert-test-not equalp ,testval ,expected ,failing-case ,description))
396 (defmacro Assert-not-string= (testval expected &optional failing-case
397 description)
398 `(Assert-test-not string= ,testval ,expected ,failing-case ,description))
399 (defmacro Assert-not= (testval expected &optional failing-case
400 description)
401 `(Assert-test-not = ,testval ,expected ,failing-case ,description))
415 402
416 (defmacro Check-Error (expected-error &rest body) 403 (defmacro Check-Error (expected-error &rest body)
417 (let ((quoted-body (if (= 1 (length body)) 404 (let ((quoted-body (if (= 1 (length body))
418 `(quote ,(car body)) `(quote (progn ,@body))))) 405 `(quote ,(car body)) `(quote (progn ,@body)))))
419 `(condition-case error-info 406 `(condition-case error-info
515 (error 502 (error
516 (incf unexpected-test-file-failures) 503 (incf unexpected-test-file-failures)
517 (princ (format "Unexpected error %S while executing interpreted code\n" 504 (princ (format "Unexpected error %S while executing interpreted code\n"
518 error-info)) 505 error-info))
519 (message "Unexpected error %S while executing interpreted code." error-info) 506 (message "Unexpected error %S while executing interpreted code." error-info)
520 (message "Test suite execution aborted." error-info) 507 (message "Test suite execution aborted.")
521 )) 508 ))
522 (princ "\nTesting Compiled Lisp\n\n") 509 (princ "\nTesting Compiled Lisp\n\n")
523 (let (code 510 (let (code
524 (test-harness-test-compiled t)) 511 (test-harness-test-compiled t))
525 (condition-case error-info 512 (condition-case error-info
536 (error 523 (error
537 (incf unexpected-test-file-failures) 524 (incf unexpected-test-file-failures)
538 (princ (format "Unexpected error %S while executing byte-compiled code\n" 525 (princ (format "Unexpected error %S while executing byte-compiled code\n"
539 error-info)) 526 error-info))
540 (message "Unexpected error %S while executing byte-compiled code." error-info) 527 (message "Unexpected error %S while executing byte-compiled code." error-info)
541 (message "Test suite execution aborted." error-info) 528 (message "Test suite execution aborted.")
542 ))) 529 )))
543 (princ (format "\nSUMMARY for %s:\n" filename)) 530 (princ (format "\nSUMMARY for %s:\n" filename))
544 (princ (format "\t%5d passes\n" passes)) 531 (princ (format "\t%5d passes\n" passes))
545 (princ (format "\t%5d assertion failures\n" assertion-failures)) 532 (princ (format "\t%5d assertion failures\n" assertion-failures))
546 (princ (format "\t%5d errors that should have been generated, but weren't\n" no-error-failures)) 533 (princ (format "\t%5d errors that should have been generated, but weren't\n" no-error-failures))
553 wrong-error-failures 540 wrong-error-failures
554 missing-message-failures 541 missing-message-failures
555 other-failures)) 542 other-failures))
556 (basename (file-name-nondirectory filename)) 543 (basename (file-name-nondirectory filename))
557 (summary-msg 544 (summary-msg
558 (if (> total 0) 545 (cond ((> unexpected-test-file-failures 0)
559 (format test-harness-file-summary-template 546 (format test-harness-aborted-summary-template
560 (concat basename ":") 547 (concat basename ":") total))
561 passes total (/ (* 100 passes) total)) 548 ((> total 0)
562 (format test-harness-null-summary-template 549 (format test-harness-file-summary-template
563 (concat basename ":")))) 550 (concat basename ":")
551 passes total (/ (* 100 passes) total)))
552 (t
553 (format test-harness-null-summary-template
554 (concat basename ":")))))
564 (reasons "")) 555 (reasons ""))
565 (maphash (lambda (key value) 556 (maphash (lambda (key value)
566 (setq reasons 557 (setq reasons
567 (concat reasons 558 (concat reasons
568 (format "\n %d tests skipped because %s." 559 (format "\n %d tests skipped because %s."
698 (while results 689 (while results
699 (let* ((head (car results)) 690 (let* ((head (car results))
700 (basename (file-name-nondirectory (first head))) 691 (basename (file-name-nondirectory (first head)))
701 (nsucc (second head)) 692 (nsucc (second head))
702 (ntest (third head))) 693 (ntest (third head)))
703 (if (> ntest 0) 694 (cond ((member (first head) unexpected-test-suite-failure-files)
704 (message test-harness-file-summary-template 695 (message test-harness-aborted-summary-template
705 (concat basename ":") 696 (concat basename ":")
706 nsucc 697 ntest))
707 ntest 698 ((> ntest 0)
708 (/ (* 100 nsucc) ntest)) 699 (message test-harness-file-summary-template
709 (message test-harness-null-summary-template 700 (concat basename ":")
710 (concat basename ":"))) 701 nsucc
702 ntest
703 (/ (* 100 nsucc) ntest)))
704 (t
705 (message test-harness-null-summary-template
706 (concat basename ":"))))
711 (setq results (cdr results))))) 707 (setq results (cdr results)))))
712 (when (> unexpected-test-suite-failures 0) 708 (when (> unexpected-test-suite-failures 0)
713 (message "\n***** There %s %d unexpected test suite %s in %s:" 709 (message "\n***** There %s %d unexpected test suite %s in %s:"
714 (if (= unexpected-test-suite-failures 1) "was" "were") 710 (if (= unexpected-test-suite-failures 1) "was" "were")
715 unexpected-test-suite-failures 711 unexpected-test-suite-failures