[Test Failure] XEmacs 21.5-b28 "fuki" (+CVS-20071204) i586-pc-win32

I get these crashes now. Not sure yet whether some local changes have to do with this. The crash is in the following spot in eval.c: { funcall_subr: PROFILE_ENTER_FUNCTION (); =======> FUNCALL_SUBR (val, subr, fun_args, max_args); PROFILE_EXIT_FUNCTION (); }" i 2007/12/05 08:56:00 [[XEmacs]]: "crash during [make check-temacs] from latest CVS assert_failed(const char * 0x01d23000, int 8571376, const char * 0x0082caac) line 3982 Ffuncall(int 17357754, Lisp_Object * 0x026766d8) line 3940 + 226 bytes Feval(Lisp_Object {...}) line 3558 + 6 bytes" o 2007/12/05 08:56:00 i 2007/12/05 08:57:30 [[XEmacs]]: "Crash during [make check] from latest CVS assert_failed(const char * 0x02c6e0a8, int 8571616, const char * 0x0082cb9c) line 3982 Ffuncall(int 17357754, Lisp_Object * 0x035d20d8) line 3940 + 226 bytes Feval(Lisp_Object {...}) line 3558 + 6 bytes" o 2007/12/05 08:57:30 Best regards! Adrian OS version: Microsoft Windows XP [Version 5.1.2600] OS: Windows_NT XEmacs 21.5-b28 "fuki" (+CVS-20071204) configured for `i586-pc-win32'. Building XEmacs using "NMAKE". Building XEmacs using make flags " ". Building XEmacs in source tree "c:\\Hacking\\cvs.xemacs.org\\XEmacs\\xemacs-21.5-clean". For src, using compiler "cl -nologo -W3 -DSTRICT -Zi -O2 -G5 -Ob2 -MDd -c -TP -Ic:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\nt\inc -Ic:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\src -I"c:\Hacking\libs4xemacs\xpm-3.4k" -I"c:\Hacking\libs4xemacs\xpm-3.4k\lib" -I"c:\Hacking\libs4xemacs\libpng-1.2.20" -I"c:\Hacking\libs4xemacs\zlib" -I"c:\Hacking\libs4xemacs\tiff-v3.4\libtiff" -I"c:\Hacking\libs4xemacs\jpeg-6b" -I"c:\Hacking\libs4xemacs\compface" -I"c:\Hacking\libs4xemacs\zlib" -DHAVE_MS_WINDOWS -DHAVE_MENUBARS -DHAVE_SCROLLBARS -DHAVE_TOOLBARS -DHAVE_WIDGETS -DHAVE_DIALOGS -DHAVE_XPM -DFOR_MSW -DHAVE_GIF -DHAVE_PNG -DHAVE_TIFF -DHAVE_JPEG -DHAVE_XFACE -DHAVE_ZLIB -DHAVE_NATIVE_SOUND -DMULE -DUSE_UNION_TYPE -DPDUMP -DNEW_GC -DUSE_KKCC -DSYSTEM_MALLOC -DDEBUG_XEMACS -D_DEBUG -DWIN32_LEAN_AND_MEAN -DWIN32_NATIVE -Demacs -DHAVE_CONFIG_H -DPATH_VERSION=\"21.5-b28\" -DPATH_PROGNAME=\"xemacs\" -DEMACS_VERSION=\"21.5-b28\" -DEMACS_PROGNAME=\"xemacs\" -DSTAC! K_TRACE_EYE_CATCHER=xemacs_21_5_b28_i586_pc_win32 -DPATH_PREFIX=\"..\" -DEMACS_MAJOR_VERSION=21 -DEMACS_MINOR_VERSION=5 -DEMACS_BETA_VERSION=28 -DXEMACS_CODENAME=\""fuki"\" -DXEMACS_EXTRA_NAME=\"(+CVS-20071204)\" -DEMACS_CONFIGURATION=\"i586-pc-win32\"". For lib-src, using compiler "cl -nologo -W3 -DSTRICT -Zi -O2 -G5 -Ob2 -MDd -Ic:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\lib-src -Ic:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\src -DHAVE_CONFIG_H -DWIN32_NATIVE". Compiling as C++. Installing XEmacs in "c:\\Program Files\\XEmacs\\XEmacs-21.5-b28". Compiling in support for Microsoft Windows native GUI. Compiling in international (MULE) support. Compiling in support for XPM images. Compiling in support for GIF images. Compiling in support for PNG images. Compiling in support for TIFF images. Compiling in support for JPEG images. Compiling in support for X-Face message headers. Compiling in support for GZIP compression/decompression. Compiling in support for toolbars. Compiling in support for dialogs. Compiling in support for widgets. Compiling in support for native sounds. Using union type for Lisp object storage. NOTE: --------------------------------------------------------- NOTE: This tends to trigger compiler bugs, especially when combined NOTE: with MULE and ERROR_CHECKING. Crashes in pdump have recently NOTE: been observed using Visual C++ in combination with union type, NOTE: MULE, and ERROR_CHECKING. NOTE: --------------------------------------------------------- Using portable dumper. Using system malloc. Using DLL version of C runtime library. Compiling in debugging support (no slowdown). Compiling with optimization. Using new experimental GC mark algorithms. Using new experimental incremental garbage collector and new allocator. \s-+.+\)*\|^Note:\|Installing\|[Ff]ile(s) copied\|\s-+tests\s-+\|^[A-Z] [^ ]+$\|^Wrong number of arguments:\|^ \*\* " cd c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\ Compilation started at Wed Dec 05 08:18:28 2007 +0100 (W. Europe Standard Time) ? gunzip-error.txt ? man/lispref/errors.texi.new ? nt/xemacs-21.5-clean-make-all-internal-compiler-error-not-cpp.err ? nt/xemacs-21.5-clean-make-all-internal-compiler-error.err ? nt/xemacs-21.5-clean-make-all-texinfo-error.err P version.sh M info/dir P lisp/ChangeLog P lisp/autoload.el P lisp/bytecomp.el M lisp/package-get.el M lisp/process.el U lisp/mule/iso-with-esc.el M src/ChangeLog M src/eval.c P src/file-coding.c M src/fileio.c M src/frame-msw.c M src/gc.c M src/glyphs.c M src/profile.c P tests/ChangeLog P tests/automated/mule-tests.el M tests/automated/region-tests.el Compilation finished at Wed Dec 05 08:20:07 \s-+.+\)*\|^Note:\|Installing\|[Ff]ile(s) copied\|\s-+tests\s-+\|^[A-Z] [^ ]+$\|^Wrong number of arguments:\|^ \*\* " cd c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\nt\ nmake /f xemacs.mak all Compilation started at Wed Dec 05 08:49:23 2007 +0100 (W. Europe Standard Time) Installing XEmacs in "c:\\Program Files\\XEmacs\\XEmacs-21.5-b28". 1 file(s) copied. 1 File(s) copied 1 File(s) copied c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\src\text.c(2180) : warning C4390: ';' : empty controlled statement found; is this the intent? Using load-path (c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\lisp\) Using module-load-path (c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\modules) Generating autoloads for lisp/next-error.el... While compiling call-process-internal in file c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\lisp\process.el: ** variable proc-mark bound but not referenced While compiling the end of the data in file c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\lisp\mule\mule-cmds.el: ** the function set-console-tty-coding-system is not known to be defined. While compiling make-8-bit-generate-helper in file c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\lisp\mule\mule-coding.el: ** variable args-out-of-range bound but not referenced Using load-path (c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\lisp\) Using module-load-path (c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\modules) Warning: doc lost for function unicode-error-translate-region. Warning: doc lost for function frob-unicode-errors-region. While compiling x-win-init-xfree86 in file c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\lisp\x-win-xfree86.el: ** assignment to free variable x-us-keymap-first-keycode ** assignment to free variable x-us-keymap-description While compiling x-win-init-sun in file c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\lisp\x-win-sun.el: ** assignment to free variable x-us-keymap-first-keycode ** assignment to free variable x-us-keymap-description While compiling the end of the data in file c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\lisp\x-font-menu.el: ** The following functions are not known to be defined: fc-find-available-weights-for-family, fc-find-available-font-families, xlfd-font-name-p, fc-font-match, fc-name-parse, fc-pattern-get-family, fc-pattern-get-successp, fc-pattern-get-weight, fc-pattern-get-size, fc-pattern-get-slant, fc-font-weight-translate-to-string, fc-font-slant-translate-to-string, make-fc-pattern, fc-pattern-add-family, fc-pattern-add-weight, fc-font-weight-translate-from-string, fc-pattern-add-size, fc-pattern-add-slant, fc-font-slant-translate-from-string, fc-name-unparse While compiling the end of the data in file c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\lisp\x-faces.el: ** the function default-x-device is not known to be defined. Requiring next-error... Compiling c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\lisp\next-error.el... Wrote c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\lisp\next-error.elc While compiling the end of the data in file c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\lisp\fontconfig.el: ** the function default-x-device is not known to be defined. While compiling xft-font-create-object in file c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\lisp\font.el: ** attempt to inline fc-pattern-get-family before it was defined ** attempt to inline fc-pattern-get-size before it was defined ** attempt to inline fc-pattern-get-weight before it was defined While compiling xft-font-create-name: ** attempt to inline fc-pattern-add-family before it was defined ** attempt to inline fc-pattern-add-size before it was defined While compiling the end of the data: ** the function default-x-device is not known to be defined. While compiling ethio-modify-vowel in file c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\lisp\mule\ethio-util.el: ** decompose-composite-char is an obsolete function; use char-to-string instead. While compiling cyrillic-encode-koi8-r-char in file c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\lisp\mule\cyril-util.el: ** reference to free variable cyrillic-koi8-r-to-external-code-table While compiling cyrillic-encode-alternativnyj-char: ** reference to free variable cyrillic-alternativnyj-to-external-code-table Computing custom-loads for next-error... Compilation finished at Wed Dec 05 08:53:33 \s-+.+\)*\|^Note:\|Installing\|[Ff]ile(s) copied\|\s-+tests\s-+\|^[A-Z] [^ ]+$\|^Wrong number of arguments:\|^ \*\* " cd c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\nt\ nmake /f xemacs.mak check-temacs Compilation started at Wed Dec 05 08:53:56 2007 +0100 (W. Europe Standard Time) Using load-path (c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\lisp\) Using module-load-path (c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\modules) Warning: doc lost for function unicode-error-translate-region. Warning: doc lost for function frob-unicode-errors-region. base64-tests.el: 1234 of 1234 tests successful (100%). 0 errors that should have been generated, but weren't 0 wrong-error failures byte-compiler-tests.el: 66 of 66 tests successful (100%). 38 tests skipped because can't defadvice. 0 errors that should have been generated, but weren't 0 wrong-error failures Fatal error: assertion failed, file c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\src\tests.c, line 141, (len) == sizeof (ext_latin12) - 1 Fatal error. # (condition-case ... . ((cl-assertion-failed (Print-Failure (if nil "Assertion failed: %S; failing case = %S" "Assertion failed: %S") (quote (eq (quote PASS) (funcall fun))) nil) (incf assertion-failures)) (t (Print-Failure (if nil "%S ==> error: %S; failing case = %S" "%S ==> error: %S") (quote (eq (quote PASS) (funcall fun))) error-info nil) (incf other-failures)))) (condition-case error-info (progn (assert (eq (quote PASS) (funcall fun))) (Print-Pass "%S" (quote (eq (quote PASS) (funcall fun)))) (incf passes)) (cl-assertion-failed (Print-Failure (if nil "Assertion failed: %S; failing case = %S" "Assertion failed: %S") (quote (eq (quote PASS) (funcall fun))) nil) (incf assertion-failures)) (t (Print-Failure (if nil "%S ==> error: %S; failing case = %S" "%S ==> error: %S") (quote (eq (quote PASS) (funcall fun))) error-info nil) (incf other-failures))) (lambda nil (defvar passes) (defvar assertion-failures) (defvar no-error-failures) (defvar wrong-error-failures) (defvar missing-message-failures) (defvar other-failures) (defvar trick-optimizer) (eval-when-compile (condition-case nil (require (quote test-harness)) (file-error (push "." load-path) (when (and (boundp (quote load-file-name)) (stringp load-file-name)) (push (file-name-directory load-file-name) load-path)) (require (quote test-harness))))) (when (boundp (quote test-function-list)) (loop for fun in test-function-list do (Assert (eq (quote PASS) (funcall fun))))))() funcall((lambda nil (defvar passes) (defvar assertion-failures) (defvar no-error-failures) (defvar wrong-error-failures) (defvar missing-message-failures) (defvar other-failures) (defvar trick-optimizer) (eval-when-compile (condition-case nil (require (quote test-harness)) (file-error (push "." load-path) (when (and (boundp (quote load-file-name)) (stringp load-file-name)) (push (file-name-directory load-file-name) load-path)) (require (quote test-harness))))) (when (boundp (quote test-function-list)) (loop for fun in test-function-list do (Assert (eq (quote PASS) (funcall fun))))))) # (condition-case ... . ((error (incf unexpected-test-file-failures) (princ (format "Unexpected error %S while executing interpreted code\n" error-info)) (message "Unexpected error %S while executing interpreted code." error-info) (message "Test suite execution aborted." error-info)))) (condition-case error-info (funcall (test-harness-read-from-buffer inbuffer)) (error (incf unexpected-test-file-failures) (princ (format "Unexpected error %S while executing interpreted code\n" error-info)) (message "Unexpected error %S while executing interpreted code." error-info) (message "Test suite execution aborted." error-info))) (with-output-to-temp-buffer "*Test-Log*" (princ (format "Testing %s...\n\n" filename)) (defconst test-harness-failure-tag "FAIL") (defconst test-harness-success-tag "PASS") (defmacro Known-Bug-Expect-Failure (&rest body) (backquote (let ((test-harness-failure-tag "KNOWN BUG") (test-harness-success-tag "PASS (FAILURE EXPECTED)")) (\,＠ body)))) (defmacro Implementation-Incomplete-Expect-Failure (&rest body) (backquote (let ((test-harness-failure-tag "IMPLEMENTATION INCOMPLETE") (test-harness-success-tag "PASS (FAILURE EXPECTED)")) (\,＠ body)))) (defun Print-Failure (fmt &rest args) (setq fmt (format "%s: %s" test-harness-failure-tag fmt)) (if (noninteractive) (apply (function message) fmt args)) (princ (concat (apply (function format) fmt args) "\n"))) (defun Print-Pass (fmt &rest args) (setq fmt (format "%s: %s" test-harness-success-tag fmt)) (and test-harness-verbose (princ (concat (apply (function format) fmt args) "\n")))) (defun Print-Skip (test reason &optional fmt &re! st args) (setq fmt (concat "SKIP: %S BECAUSE %S" fmt)) (princ (concat (apply (function format) fmt test reason args) "\n"))) (defmacro Skip-Test-Unless (condition reason description &rest body) "Unless CONDITION is satisfied, skip test BODY.\nREASON is a description of the condition failure, and must be unique (it\nis used as a hash key). DESCRIPTION describes the tests that were skipped.\nBODY is a sequence of expressions and may contain several tests." (backquote (if (not (\, condition)) (let ((count (gethash (\, reason) skipped-test-reasons))) (puthash (\, reason) (if (null count) 1 (1+ count)) skipped-test-reasons) (Print-Skip (\, description) (\, reason))) (\,＠ body)))) (defmacro Assert (assertion &optional failing-case) (backquote (condition-case error-info (progn (assert (\, assertion)) (Print-Pass "%S" (quote (\, assertion))) (incf passes)) (cl-assertion-failed (Print-Failure (if (\, failing-case) "Assertion failed: %S; failing case = %S" "Assertion failed: %S") (q! uote (\, assertion)) (\, failing-case)) (incf assertion-failur! es)) (t (Print-Failure (if (\, failing-case) "%S ==> error: %S; failing case = %S" "%S ==> error: %S") (quote (\, assertion)) error-info (\, failing-case)) (incf other-failures))))) (defmacro Check-Error (expected-error &rest body) (let ((quoted-body (if (= 1 (length body)) (backquote (quote (\, (car body)))) (backquote (quote (progn (\,＠ body))))))) (backquote (condition-case error-info (progn (setq trick-optimizer (progn (\,＠ body))) (Print-Failure "%S executed successfully, but expected error %S" (\, quoted-body) (quote (\, expected-error))) (incf no-error-failures)) ((\, expected-error) (Print-Pass "%S ==> error %S, as expected" (\, quoted-body) (quote (\, expected-error))) (incf passes)) (error (Print-Failure "%S ==> expected error %S, got error %S instead" (\, quoted-body) (quote (\, expected-error)) error-info) (incf wrong-error-failures)))))) (defmacro Check-Error-Message (expected-error expected-error-regexp &rest body) (let ((quoted-body (if (= 1 (length body)) (backquote! (quote (\, (car body)))) (backquote (quote (progn (\,＠ body))))))) (backquote (condition-case error-info (progn (setq trick-optimizer (progn (\,＠ body))) (Print-Failure "%S executed successfully, but expected error %S" (\, quoted-body) (quote (\, expected-error))) (incf no-error-failures)) ((\, expected-error) (let ((error-message (second error-info))) (if (string-match (\, expected-error-regexp) error-message) (progn (Print-Pass "%S ==> error %S %S, as expected" (\, quoted-body) error-message (quote (\, expected-error))) (incf passes)) (Print-Failure "%S ==> got error %S as expected, but error message %S did not match regexp %S" (\, quoted-body) (quote (\, expected-error)) error-message (\, expected-error-regexp)) (incf wrong-error-failures)))) (error (Print-Failure "%S ==> expected error %S, got error %S instead" (\, quoted-body) (quote (\, expected-error)) error-info) (incf wrong-error-failures)))))) (defmacro Check-Message (expected-message-regexp &rest body) (Skip-Tes! t-Unless (fboundp (quote defadvice)) "can't defadvice" expecte! d-messag e-regexp (let ((quoted-body (if (= 1 (length body)) (backquote (quote (\, (car body)))) (backquote (quote (progn (\,＠ body))))))) (backquote (let ((messages "")) (defadvice message (around collect activate) (defvar messages) (let ((msg-string (apply (quote format) (ad-get-args 0)))) (setq messages (concat messages msg-string)) msg-string)) (condition-case error-info (progn (setq trick-optimizer (progn (\,＠ body))) (if (string-match (\, expected-message-regexp) messages) (progn (Print-Pass "%S ==> value %S, message %S, matching %S, as expected" (\, quoted-body) trick-optimizer messages (quote (\, expected-message-regexp))) (incf passes)) (Print-Failure "%S ==> value %S, message %S, NOT matching expected %S" (\, quoted-body) trick-optimizer messages (quote (\, expected-message-regexp))) (incf missing-message-failures))) (error (Print-Failure "%S ==> unexpected error %S" (\, quoted-body) error-info) (incf other-failures))) (ad-unadvise (quote message))))))) (defmacro Silence-Me! ssage (&rest body) (backquote (flet ((append-message (&rest args) nil)) (\,＠ body)))) (defmacro Ignore-Ebola (&rest body) (backquote (let ((debug-issue-ebola-notices -42)) (\,＠ body)))) (defun Int-to-Marker (pos) (save-excursion (set-buffer standard-output) (save-excursion (goto-char pos) (point-marker)))) (princ "Testing Interpreted Lisp\n\n") (condition-case error-info (funcall (test-harness-read-from-buffer inbuffer)) (error (incf unexpected-test-file-failures) (princ (format "Unexpected error %S while executing interpreted code\n" error-info)) (message "Unexpected error %S while executing interpreted code." error-info) (message "Test suite execution aborted." error-info))) (princ "\nTesting Compiled Lisp\n\n") (let (code (test-harness-test-compiled t)) (condition-case error-info (setq code (letf (((symbol-function (quote byte-compile-warn)) (quote ignore))) (byte-compile (test-harness-read-from-buffer inbuffer)))) (error (princ (format "Unexpected error %S while byte-co! mpiling code\n" error-info)))) (condition-case error-info (if ! code (fu ncall code)) (error (incf unexpected-test-file-failures) (princ (format "Unexpected error %S while executing byte-compiled code\n" error-info)) (message "Unexpected error %S while executing byte-compiled code." error-info) (message "Test suite execution aborted." error-info)))) (princ (format "\nSUMMARY for %s:\n" filename)) (princ (format " %5d passes\n" passes)) (princ (format " %5d assertion failures\n" assertion-failures)) (princ (format " %5d errors that should have been generated, but weren't\n" no-error-failures)) (princ (format " %5d wrong-error failures\n" wrong-error-failures)) (princ (format " %5d missing-message failures\n" missing-message-failures)) (princ (format " %5d other failures\n" other-failures)) (let* ((total (+ passes assertion-failures no-error-failures wrong-error-failures missing-message-failures other-failures)) (basename (file-name-nondirectory filename)) (summary-msg (if (> total 0) (format test-harness-file-summary-template (concat basename ":")! passes total (/ (* 100 passes) total)) (format test-harness-null-summary-template (concat basename ":")))) (reasons "")) (maphash (lambda (key value) (setq reasons (concat reasons (format "\n %d tests skipped because %s." value key)))) skipped-test-reasons) (when (> (length reasons) 1) (setq summary-msg (concat summary-msg reasons "\n Probably XEmacs cannot find your installed packages. Set EMACSPACKAGEPATH\n to the package hierarchy root or configure with --package-path to enable\n the skipped tests."))) (setq test-harness-file-results-alist (cons (list filename passes total) test-harness-file-results-alist)) (message "%s" summary-msg)) (when (> unexpected-test-file-failures 0) (setq unexpected-test-suite-failure-files (cons filename unexpected-test-suite-failure-files)) (setq unexpected-test-suite-failures (+ unexpected-test-suite-failures unexpected-test-file-failures)) (message "Test suite execution failed unexpectedly.")) (fmakunbound (quote Assert)) (fma! kunbound (quote Check-Error)) (fmakunbound (quote Check-Messag! e)) (fma kunbound (quote Check-Error-Message)) (fmakunbound (quote Ignore-Ebola)) (fmakunbound (quote Int-to-Marker)) (and noninteractive (message "%s" (buffer-substring-no-properties nil nil "*Test-Log*")))) # bind (pass-stream debug-on-error trick-optimizer skipped-test-reasons unexpected-test-file-failures other-failures missing-message-failures wrong-error-failures no-error-failures assertion-failures passes) (let ((passes 0) (assertion-failures 0) (no-error-failures 0) (wrong-error-failures 0) (missing-message-failures 0) (other-failures 0) (unexpected-test-file-failures 0) (skipped-test-reasons (make-hash-table :test (quote equal))) (trick-optimizer nil) (debug-on-error t) (pass-stream nil)) (with-output-to-temp-buffer "*Test-Log*" (princ (format "Testing %s...\n\n" filename)) (defconst test-harness-failure-tag "FAIL") (defconst test-harness-success-tag "PASS") (defmacro Known-Bug-Expect-Failure (&rest body) (backquote (let ((test-harness-failure-tag "KNOWN BUG") (test-harness-success-tag "PASS (FAILURE EXPECTED)")) (\,＠ body)))) (defmacro Implementation-Incomplete-Expect-Failure (&rest body) (backquote (let ((test-harness-failure-tag "IMPLEMENTATION INCOMPLETE") (test-harness-success-tag "PASS (FAILURE EXPECTED)")) (\,＠ body)))) (defun Print-Failure (fmt &rest args) (setq fmt (format "%s: %s" test-harness-failure-tag fmt)) (if (noninteractive) (apply (function message) fmt a! rgs)) (princ (concat (apply (function format) fmt args) "\n"))) (defun Print-Pass (fmt &rest args) (setq fmt (format "%s: %s" test-harness-success-tag fmt)) (and test-harness-verbose (princ (concat (apply (function format) fmt args) "\n")))) (defun Print-Skip (test reason &optional fmt &rest args) (setq fmt (concat "SKIP: %S BECAUSE %S" fmt)) (princ (concat (apply (function format) fmt test reason args) "\n"))) (defmacro Skip-Test-Unless (condition reason description &rest body) "Unless CONDITION is satisfied, skip test BODY.\nREASON is a description of the condition failure, and must be unique (it\nis used as a hash key). DESCRIPTION describes the tests that were skipped.\nBODY is a sequence of expressions and may contain several tests." (backquote (if (not (\, condition)) (let ((count (gethash (\, reason) skipped-test-reasons))) (puthash (\, reason) (if (null count) 1 (1+ count)) skipped-test-reasons) (Print-Skip (\, description) (\, reason))) (\,＠ body)))) (defmacro Ass! ert (assertion &optional failing-case) (backquote (condition-c! ase erro r-info (progn (assert (\, assertion)) (Print-Pass "%S" (quote (\, assertion))) (incf passes)) (cl-assertion-failed (Print-Failure (if (\, failing-case) "Assertion failed: %S; failing case = %S" "Assertion failed: %S") (quote (\, assertion)) (\, failing-case)) (incf assertion-failures)) (t (Print-Failure (if (\, failing-case) "%S ==> error: %S; failing case = %S" "%S ==> error: %S") (quote (\, assertion)) error-info (\, failing-case)) (incf other-failures))))) (defmacro Check-Error (expected-error &rest body) (let ((quoted-body (if (= 1 (length body)) (backquote (quote (\, (car body)))) (backquote (quote (progn (\,＠ body))))))) (backquote (condition-case error-info (progn (setq trick-optimizer (progn (\,＠ body))) (Print-Failure "%S executed successfully, but expected error %S" (\, quoted-body) (quote (\, expected-error))) (incf no-error-failures)) ((\, expected-error) (Print-Pass "%S ==> error %S, as expected" (\, quoted-body) (quote (\, expected-error))) (incf passes)) (err! or (Print-Failure "%S ==> expected error %S, got error %S instead" (\, quoted-body) (quote (\, expected-error)) error-info) (incf wrong-error-failures)))))) (defmacro Check-Error-Message (expected-error expected-error-regexp &rest body) (let ((quoted-body (if (= 1 (length body)) (backquote (quote (\, (car body)))) (backquote (quote (progn (\,＠ body))))))) (backquote (condition-case error-info (progn (setq trick-optimizer (progn (\,＠ body))) (Print-Failure "%S executed successfully, but expected error %S" (\, quoted-body) (quote (\, expected-error))) (incf no-error-failures)) ((\, expected-error) (let ((error-message (second error-info))) (if (string-match (\, expected-error-regexp) error-message) (progn (Print-Pass "%S ==> error %S %S, as expected" (\, quoted-body) error-message (quote (\, expected-error))) (incf passes)) (Print-Failure "%S ==> got error %S as expected, but error message %S did not match regexp %S" (\, quoted-body) (quote (\, expected-error)) error-message ! (\, expected-error-regexp)) (incf wrong-error-failures)))) (er! ror (Pri nt-Failure "%S ==> expected error %S, got error %S instead" (\, quoted-body) (quote (\, expected-error)) error-info) (incf wrong-error-failures)))))) (defmacro Check-Message (expected-message-regexp &rest body) (Skip-Test-Unless (fboundp (quote defadvice)) "can't defadvice" expected-message-regexp (let ((quoted-body (if (= 1 (length body)) (backquote (quote (\, (car body)))) (backquote (quote (progn (\,＠ body))))))) (backquote (let ((messages "")) (defadvice message (around collect activate) (defvar messages) (let ((msg-string (apply (quote format) (ad-get-args 0)))) (setq messages (concat messages msg-string)) msg-string)) (condition-case error-info (progn (setq trick-optimizer (progn (\,＠ body))) (if (string-match (\, expected-message-regexp) messages) (progn (Print-Pass "%S ==> value %S, message %S, matching %S, as expected" (\, quoted-body) trick-optimizer messages (quote (\, expected-message-regexp))) (incf passes)) (Print-Failure "%S ==> value %S, message %S, NOT match! ing expected %S" (\, quoted-body) trick-optimizer messages (quote (\, expected-message-regexp))) (incf missing-message-failures))) (error (Print-Failure "%S ==> unexpected error %S" (\, quoted-body) error-info) (incf other-failures))) (ad-unadvise (quote message))))))) (defmacro Silence-Message (&rest body) (backquote (flet ((append-message (&rest args) nil)) (\,＠ body)))) (defmacro Ignore-Ebola (&rest body) (backquote (let ((debug-issue-ebola-notices -42)) (\,＠ body)))) (defun Int-to-Marker (pos) (save-excursion (set-buffer standard-output) (save-excursion (goto-char pos) (point-marker)))) (princ "Testing Interpreted Lisp\n\n") (condition-case error-info (funcall (test-harness-read-from-buffer inbuffer)) (error (incf unexpected-test-file-failures) (princ (format "Unexpected error %S while executing interpreted code\n" error-info)) (message "Unexpected error %S while executing interpreted code." error-info) (message "Test suite execution aborted." error-info))) (princ "\nTe! sting Compiled Lisp\n\n") (let (code (test-harness-test-compil! ed t)) ( condition-case error-info (setq code (letf (((symbol-function (quote byte-compile-warn)) (quote ignore))) (byte-compile (test-harness-read-from-buffer inbuffer)))) (error (princ (format "Unexpected error %S while byte-compiling code\n" error-info)))) (condition-case error-info (if code (funcall code)) (error (incf unexpected-test-file-failures) (princ (format "Unexpected error %S while executing byte-compiled code\n" error-info)) (message "Unexpected error %S while executing byte-compiled code." error-info) (message "Test suite execution aborted." error-info)))) (princ (format "\nSUMMARY for %s:\n" filename)) (princ (format " %5d passes\n" passes)) (princ (format " %5d assertion failures\n" assertion-failures)) (princ (format " %5d errors that should have been generated, but weren't\n" no-error-failures)) (princ (format " %5d wrong-error failures\n" wrong-error-failures)) (princ (format " %5d missing-message failures\n" missing-message-failures)) (princ (format " %5d other f! ailures\n" other-failures)) (let* ((total (+ passes assertion-failures no-error-failures wrong-error-failures missing-message-failures other-failures)) (basename (file-name-nondirectory filename)) (summary-msg (if (> total 0) (format test-harness-file-summary-template (concat basename ":") passes total (/ (* 100 passes) total)) (format test-harness-null-summary-template (concat basename ":")))) (reasons "")) (maphash (lambda (key value) (setq reasons (concat reasons (format "\n %d tests skipped because %s." value key)))) skipped-test-reasons) (when (> (length reasons) 1) (setq summary-msg (concat summary-msg reasons "\n Probably XEmacs cannot find your installed packages. Set EMACSPACKAGEPATH\n to the package hierarchy root or configure with --package-path to enable\n the skipped tests."))) (setq test-harness-file-results-alist (cons (list filename passes total) test-harness-file-results-alist)) (message "%s" summary-msg)) (when (> unexpected-test-file-failures! 0) (setq unexpected-test-suite-failure-files (cons filename u! nexpecte d-test-suite-failure-files)) (setq unexpected-test-suite-failures (+ unexpected-test-suite-failures unexpected-test-file-failures)) (message "Test suite execution failed unexpectedly.")) (fmakunbound (quote Assert)) (fmakunbound (quote Check-Error)) (fmakunbound (quote Check-Message)) (fmakunbound (quote Check-Error-Message)) (fmakunbound (quote Ignore-Ebola)) (fmakunbound (quote Int-to-Marker)) (and noninteractive (message "%s" (buffer-substring-no-properties nil nil "*Test-Log*"))))) # (condition-case ... . ((error (princ ">>Error occurred processing ") (princ file) (princ ": ") (display-error error-info nil) (terpri) nil))) (condition-case error-info (progn (test-emacs-test-file file) t) (error (princ ">>Error occurred processing ") (princ file) (princ ": ") (display-error error-info nil) (terpri) nil)) (or (batch-test-emacs-1 file-in-dir) (setq error t)) (if (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t))) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t))) (while --dolist-temp--30603 (setq file-in-dir (car --dolist-temp--30603)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t))) (setq --dolist-temp--30603 (cdr --dolist-temp--30603))) (let ((--dolist-temp--30603 (directory-files file t)) file-in-dir) (while --dolist-temp--30603 (setq file-in-dir (car --dolist-temp--30603)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t))) (setq --dolist-temp--30603 (cdr --dolist-temp--30603))) nil) (catch (quote --cl-block-nil--) (let ((--dolist-temp--30603 (directory-files file t)) file-in-dir) (while --dolist-temp--30603 (setq file-in-dir (car --dolist-temp--30603)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t))) (setq --dolist-temp--30603 (cdr --dolist-temp--30603))) nil)) (cl-block-wrapper (catch (quote --cl-block-nil--) (let ((--dolist-temp--30603 (directory-files file t)) file-in-dir) (while --dolist-temp--30603 (setq file-in-dir (car --dolist-temp--30603)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t))) (setq --dolist-temp--30603 (cdr --dolist-temp--30603))) nil))) (block nil (let ((--dolist-temp--30603 (directory-files file t)) file-in-dir) (while --dolist-temp--30603 (setq file-in-dir (car --dolist-temp--30603)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t))) (setq --dolist-temp--30603 (cdr --dolist-temp--30603))) nil)) (dolist (file-in-dir (directory-files file t)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t)))) (if (file-directory-p file) (dolist (file-in-dir (directory-files file t)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t)))) (or (batch-test-emacs-1 file) (setq error t))) (while --dolist-temp--30602 (setq file (car --dolist-temp--30602)) (if (file-directory-p file) (dolist (file-in-dir (directory-files file t)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t)))) (or (batch-test-emacs-1 file) (setq error t))) (setq --dolist-temp--30602 (cdr --dolist-temp--30602))) (let ((--dolist-temp--30602 command-line-args-left) file) (while --dolist-temp--30602 (setq file (car --dolist-temp--30602)) (if (file-directory-p file) (dolist (file-in-dir (directory-files file t)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t)))) (or (batch-test-emacs-1 file) (setq error t))) (setq --dolist-temp--30602 (cdr --dolist-temp--30602))) nil) (catch (quote --cl-block-nil--) (let ((--dolist-temp--30602 command-line-args-left) file) (while --dolist-temp--30602 (setq file (car --dolist-temp--30602)) (if (file-directory-p file) (dolist (file-in-dir (directory-files file t)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t)))) (or (batch-test-emacs-1 file) (setq error t))) (setq --dolist-temp--30602 (cdr --dolist-temp--30602))) nil)) (cl-block-wrapper (catch (quote --cl-block-nil--) (let ((--dolist-temp--30602 command-line-args-left) file) (while --dolist-temp--30602 (setq file (car --dolist-temp--30602)) (if (file-directory-p file) (dolist (file-in-dir (directory-files file t)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t)))) (or (batch-test-emacs-1 file) (setq error t))) (setq --dolist-temp--30602 (cdr --dolist-temp--30602))) nil))) (block nil (let ((--dolist-temp--30602 command-line-args-left) file) (while --dolist-temp--30602 (setq file (car --dolist-temp--30602)) (if (file-directory-p file) (dolist (file-in-dir (directory-files file t)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t)))) (or (batch-test-emacs-1 file) (setq error t))) (setq --dolist-temp--30602 (cdr --dolist-temp--30602))) nil)) (dolist (file command-line-args-left) (if (file-directory-p file) (dolist (file-in-dir (directory-files file t)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t)))) (or (batch-test-emacs-1 file) (setq error t)))) # bind (error) (let ((error nil)) (dolist (file command-line-args-left) (if (file-directory-p file) (dolist (file-in-dir (directory-files file t)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t)))) (or (batch-test-emacs-1 file) (setq error t)))) (let ((namelen 0) (succlen 0) (testlen 0) (results test-harness-file-results-alist)) (flet ((print-width (i) (let ((x 10) (y 1)) (while (>= i x) (setq x (* 10 x) y (1+ y))) y))) (while results (let* ((head (car results)) (nn (length (file-name-nondirectory (first head)))) (ss (print-width (second head))) (tt (print-width (third head)))) (when (> nn namelen) (setq namelen nn)) (when (> ss succlen) (setq succlen ss)) (when (> tt testlen) (setq testlen tt))) (setq results (cdr results)))) (let ((results (reverse test-harness-file-results-alist)! )) (while results (let* ((head (car results)) (basename (file-name-nondirectory (first head))) (nsucc (second head)) (ntest (third head))) (if (> ntest 0) (message test-harness-file-summary-template (concat basename ":") nsucc ntest (/ (* 100 nsucc) ntest)) (message test-harness-null-summary-template (concat basename ":"))) (setq results (cdr results))))) (when (> unexpected-test-suite-failures 0) (message "\n***** There %s %d unexpected test suite %s in %s:" (if (= unexpected-test-suite-failures 1) "was" "were") unexpected-test-suite-failures (if (= unexpected-test-suite-failures 1) "failure" "failures") (if (= (length unexpected-test-suite-failure-files) 1) "file" "files")) (while unexpected-test-suite-failure-files (let ((line (pop unexpected-test-suite-failure-files))) (while (and (< (length line) 61) unexpected-test-suite-failure-files) (setq line (concat line " " (pop unexpected-test-suite-failure-files)))) (message line))))) (message "\nDone") (kill-emacs (if error 1! 0))) # bind (error-data) # (condition-case ... . error) \s-+.+\)*\|^Note:\|Installing\|[Ff]ile(s) copied\|\s-+tests\s-+\|^[A-Z] [^ ]+$\|^Wrong number of arguments:\|^ \*\* " cd c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\nt\ nmake /f xemacs.mak check Compilation started at Wed Dec 05 08:56:18 2007 +0100 (W. Europe Standard Time) base64-tests.el: 1234 of 1234 tests successful (100%). 0 errors that should have been generated, but weren't 0 wrong-error failures byte-compiler-tests.el: 104 of 104 tests successful (100%). 0 errors that should have been generated, but weren't 0 wrong-error failures Fatal error: assertion failed, file c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\src\tests.c, line 141, (len) == sizeof (ext_latin12) - 1 Fatal error. # (condition-case ... . ((cl-assertion-failed (Print-Failure (if nil "Assertion failed: %S; failing case = %S" "Assertion failed: %S") (quote (eq (quote PASS) (funcall fun))) nil) (incf assertion-failures)) (t (Print-Failure (if nil "%S ==> error: %S; failing case = %S" "%S ==> error: %S") (quote (eq (quote PASS) (funcall fun))) error-info nil) (incf other-failures)))) (condition-case error-info (progn (assert (eq (quote PASS) (funcall fun))) (Print-Pass "%S" (quote (eq (quote PASS) (funcall fun)))) (incf passes)) (cl-assertion-failed (Print-Failure (if nil "Assertion failed: %S; failing case = %S" "Assertion failed: %S") (quote (eq (quote PASS) (funcall fun))) nil) (incf assertion-failures)) (t (Print-Failure (if nil "%S ==> error: %S; failing case = %S" "%S ==> error: %S") (quote (eq (quote PASS) (funcall fun))) error-info nil) (incf other-failures))) (lambda nil (defvar passes) (defvar assertion-failures) (defvar no-error-failures) (defvar wrong-error-failures) (defvar missing-message-failures) (defvar other-failures) (defvar trick-optimizer) (eval-when-compile (condition-case nil (require (quote test-harness)) (file-error (push "." load-path) (when (and (boundp (quote load-file-name)) (stringp load-file-name)) (push (file-name-directory load-file-name) load-path)) (require (quote test-harness))))) (when (boundp (quote test-function-list)) (loop for fun in test-function-list do (Assert (eq (quote PASS) (funcall fun))))))() funcall((lambda nil (defvar passes) (defvar assertion-failures) (defvar no-error-failures) (defvar wrong-error-failures) (defvar missing-message-failures) (defvar other-failures) (defvar trick-optimizer) (eval-when-compile (condition-case nil (require (quote test-harness)) (file-error (push "." load-path) (when (and (boundp (quote load-file-name)) (stringp load-file-name)) (push (file-name-directory load-file-name) load-path)) (require (quote test-harness))))) (when (boundp (quote test-function-list)) (loop for fun in test-function-list do (Assert (eq (quote PASS) (funcall fun))))))) # (condition-case ... . ((error (incf unexpected-test-file-failures) (princ (format "Unexpected error %S while executing interpreted code\n" error-info)) (message "Unexpected error %S while executing interpreted code." error-info) (message "Test suite execution aborted." error-info)))) (condition-case error-info (funcall (test-harness-read-from-buffer inbuffer)) (error (incf unexpected-test-file-failures) (princ (format "Unexpected error %S while executing interpreted code\n" error-info)) (message "Unexpected error %S while executing interpreted code." error-info) (message "Test suite execution aborted." error-info))) (with-output-to-temp-buffer "*Test-Log*" (princ (format "Testing %s...\n\n" filename)) (defconst test-harness-failure-tag "FAIL") (defconst test-harness-success-tag "PASS") (defmacro Known-Bug-Expect-Failure (&rest body) (backquote (let ((test-harness-failure-tag "KNOWN BUG") (test-harness-success-tag "PASS (FAILURE EXPECTED)")) (\,＠ body)))) (defmacro Implementation-Incomplete-Expect-Failure (&rest body) (backquote (let ((test-harness-failure-tag "IMPLEMENTATION INCOMPLETE") (test-harness-success-tag "PASS (FAILURE EXPECTED)")) (\,＠ body)))) (defun Print-Failure (fmt &rest args) (setq fmt (format "%s: %s" test-harness-failure-tag fmt)) (if (noninteractive) (apply (function message) fmt args)) (princ (concat (apply (function format) fmt args) "\n"))) (defun Print-Pass (fmt &rest args) (setq fmt (format "%s: %s" test-harness-success-tag fmt)) (and test-harness-verbose (princ (concat (apply (function format) fmt args) "\n")))) (defun Print-Skip (test reason &optional fmt &re! st args) (setq fmt (concat "SKIP: %S BECAUSE %S" fmt)) (princ (concat (apply (function format) fmt test reason args) "\n"))) (defmacro Skip-Test-Unless (condition reason description &rest body) "Unless CONDITION is satisfied, skip test BODY.\nREASON is a description of the condition failure, and must be unique (it\nis used as a hash key). DESCRIPTION describes the tests that were skipped.\nBODY is a sequence of expressions and may contain several tests." (backquote (if (not (\, condition)) (let ((count (gethash (\, reason) skipped-test-reasons))) (puthash (\, reason) (if (null count) 1 (1+ count)) skipped-test-reasons) (Print-Skip (\, description) (\, reason))) (\,＠ body)))) (defmacro Assert (assertion &optional failing-case) (backquote (condition-case error-info (progn (assert (\, assertion)) (Print-Pass "%S" (quote (\, assertion))) (incf passes)) (cl-assertion-failed (Print-Failure (if (\, failing-case) "Assertion failed: %S; failing case = %S" "Assertion failed: %S") (q! uote (\, assertion)) (\, failing-case)) (incf assertion-failur! es)) (t (Print-Failure (if (\, failing-case) "%S ==> error: %S; failing case = %S" "%S ==> error: %S") (quote (\, assertion)) error-info (\, failing-case)) (incf other-failures))))) (defmacro Check-Error (expected-error &rest body) (let ((quoted-body (if (= 1 (length body)) (backquote (quote (\, (car body)))) (backquote (quote (progn (\,＠ body))))))) (backquote (condition-case error-info (progn (setq trick-optimizer (progn (\,＠ body))) (Print-Failure "%S executed successfully, but expected error %S" (\, quoted-body) (quote (\, expected-error))) (incf no-error-failures)) ((\, expected-error) (Print-Pass "%S ==> error %S, as expected" (\, quoted-body) (quote (\, expected-error))) (incf passes)) (error (Print-Failure "%S ==> expected error %S, got error %S instead" (\, quoted-body) (quote (\, expected-error)) error-info) (incf wrong-error-failures)))))) (defmacro Check-Error-Message (expected-error expected-error-regexp &rest body) (let ((quoted-body (if (= 1 (length body)) (backquote! (quote (\, (car body)))) (backquote (quote (progn (\,＠ body))))))) (backquote (condition-case error-info (progn (setq trick-optimizer (progn (\,＠ body))) (Print-Failure "%S executed successfully, but expected error %S" (\, quoted-body) (quote (\, expected-error))) (incf no-error-failures)) ((\, expected-error) (let ((error-message (second error-info))) (if (string-match (\, expected-error-regexp) error-message) (progn (Print-Pass "%S ==> error %S %S, as expected" (\, quoted-body) error-message (quote (\, expected-error))) (incf passes)) (Print-Failure "%S ==> got error %S as expected, but error message %S did not match regexp %S" (\, quoted-body) (quote (\, expected-error)) error-message (\, expected-error-regexp)) (incf wrong-error-failures)))) (error (Print-Failure "%S ==> expected error %S, got error %S instead" (\, quoted-body) (quote (\, expected-error)) error-info) (incf wrong-error-failures)))))) (defmacro Check-Message (expected-message-regexp &rest body) (Skip-Tes! t-Unless (fboundp (quote defadvice)) "can't defadvice" expecte! d-messag e-regexp (let ((quoted-body (if (= 1 (length body)) (backquote (quote (\, (car body)))) (backquote (quote (progn (\,＠ body))))))) (backquote (let ((messages "")) (defadvice message (around collect activate) (defvar messages) (let ((msg-string (apply (quote format) (ad-get-args 0)))) (setq messages (concat messages msg-string)) msg-string)) (condition-case error-info (progn (setq trick-optimizer (progn (\,＠ body))) (if (string-match (\, expected-message-regexp) messages) (progn (Print-Pass "%S ==> value %S, message %S, matching %S, as expected" (\, quoted-body) trick-optimizer messages (quote (\, expected-message-regexp))) (incf passes)) (Print-Failure "%S ==> value %S, message %S, NOT matching expected %S" (\, quoted-body) trick-optimizer messages (quote (\, expected-message-regexp))) (incf missing-message-failures))) (error (Print-Failure "%S ==> unexpected error %S" (\, quoted-body) error-info) (incf other-failures))) (ad-unadvise (quote message))))))) (defmacro Silence-Me! ssage (&rest body) (backquote (flet ((append-message (&rest args) nil)) (\,＠ body)))) (defmacro Ignore-Ebola (&rest body) (backquote (let ((debug-issue-ebola-notices -42)) (\,＠ body)))) (defun Int-to-Marker (pos) (save-excursion (set-buffer standard-output) (save-excursion (goto-char pos) (point-marker)))) (princ "Testing Interpreted Lisp\n\n") (condition-case error-info (funcall (test-harness-read-from-buffer inbuffer)) (error (incf unexpected-test-file-failures) (princ (format "Unexpected error %S while executing interpreted code\n" error-info)) (message "Unexpected error %S while executing interpreted code." error-info) (message "Test suite execution aborted." error-info))) (princ "\nTesting Compiled Lisp\n\n") (let (code (test-harness-test-compiled t)) (condition-case error-info (setq code (letf (((symbol-function (quote byte-compile-warn)) (quote ignore))) (byte-compile (test-harness-read-from-buffer inbuffer)))) (error (princ (format "Unexpected error %S while byte-co! mpiling code\n" error-info)))) (condition-case error-info (if ! code (fu ncall code)) (error (incf unexpected-test-file-failures) (princ (format "Unexpected error %S while executing byte-compiled code\n" error-info)) (message "Unexpected error %S while executing byte-compiled code." error-info) (message "Test suite execution aborted." error-info)))) (princ (format "\nSUMMARY for %s:\n" filename)) (princ (format " %5d passes\n" passes)) (princ (format " %5d assertion failures\n" assertion-failures)) (princ (format " %5d errors that should have been generated, but weren't\n" no-error-failures)) (princ (format " %5d wrong-error failures\n" wrong-error-failures)) (princ (format " %5d missing-message failures\n" missing-message-failures)) (princ (format " %5d other failures\n" other-failures)) (let* ((total (+ passes assertion-failures no-error-failures wrong-error-failures missing-message-failures other-failures)) (basename (file-name-nondirectory filename)) (summary-msg (if (> total 0) (format test-harness-file-summary-template (concat basename ":")! passes total (/ (* 100 passes) total)) (format test-harness-null-summary-template (concat basename ":")))) (reasons "")) (maphash (lambda (key value) (setq reasons (concat reasons (format "\n %d tests skipped because %s." value key)))) skipped-test-reasons) (when (> (length reasons) 1) (setq summary-msg (concat summary-msg reasons "\n Probably XEmacs cannot find your installed packages. Set EMACSPACKAGEPATH\n to the package hierarchy root or configure with --package-path to enable\n the skipped tests."))) (setq test-harness-file-results-alist (cons (list filename passes total) test-harness-file-results-alist)) (message "%s" summary-msg)) (when (> unexpected-test-file-failures 0) (setq unexpected-test-suite-failure-files (cons filename unexpected-test-suite-failure-files)) (setq unexpected-test-suite-failures (+ unexpected-test-suite-failures unexpected-test-file-failures)) (message "Test suite execution failed unexpectedly.")) (fmakunbound (quote Assert)) (fma! kunbound (quote Check-Error)) (fmakunbound (quote Check-Messag! e)) (fma kunbound (quote Check-Error-Message)) (fmakunbound (quote Ignore-Ebola)) (fmakunbound (quote Int-to-Marker)) (and noninteractive (message "%s" (buffer-substring-no-properties nil nil "*Test-Log*")))) # bind (pass-stream debug-on-error trick-optimizer skipped-test-reasons unexpected-test-file-failures other-failures missing-message-failures wrong-error-failures no-error-failures assertion-failures passes) (let ((passes 0) (assertion-failures 0) (no-error-failures 0) (wrong-error-failures 0) (missing-message-failures 0) (other-failures 0) (unexpected-test-file-failures 0) (skipped-test-reasons (make-hash-table :test (quote equal))) (trick-optimizer nil) (debug-on-error t) (pass-stream nil)) (with-output-to-temp-buffer "*Test-Log*" (princ (format "Testing %s...\n\n" filename)) (defconst test-harness-failure-tag "FAIL") (defconst test-harness-success-tag "PASS") (defmacro Known-Bug-Expect-Failure (&rest body) (backquote (let ((test-harness-failure-tag "KNOWN BUG") (test-harness-success-tag "PASS (FAILURE EXPECTED)")) (\,＠ body)))) (defmacro Implementation-Incomplete-Expect-Failure (&rest body) (backquote (let ((test-harness-failure-tag "IMPLEMENTATION INCOMPLETE") (test-harness-success-tag "PASS (FAILURE EXPECTED)")) (\,＠ body)))) (defun Print-Failure (fmt &rest args) (setq fmt (format "%s: %s" test-harness-failure-tag fmt)) (if (noninteractive) (apply (function message) fmt a! rgs)) (princ (concat (apply (function format) fmt args) "\n"))) (defun Print-Pass (fmt &rest args) (setq fmt (format "%s: %s" test-harness-success-tag fmt)) (and test-harness-verbose (princ (concat (apply (function format) fmt args) "\n")))) (defun Print-Skip (test reason &optional fmt &rest args) (setq fmt (concat "SKIP: %S BECAUSE %S" fmt)) (princ (concat (apply (function format) fmt test reason args) "\n"))) (defmacro Skip-Test-Unless (condition reason description &rest body) "Unless CONDITION is satisfied, skip test BODY.\nREASON is a description of the condition failure, and must be unique (it\nis used as a hash key). DESCRIPTION describes the tests that were skipped.\nBODY is a sequence of expressions and may contain several tests." (backquote (if (not (\, condition)) (let ((count (gethash (\, reason) skipped-test-reasons))) (puthash (\, reason) (if (null count) 1 (1+ count)) skipped-test-reasons) (Print-Skip (\, description) (\, reason))) (\,＠ body)))) (defmacro Ass! ert (assertion &optional failing-case) (backquote (condition-c! ase erro r-info (progn (assert (\, assertion)) (Print-Pass "%S" (quote (\, assertion))) (incf passes)) (cl-assertion-failed (Print-Failure (if (\, failing-case) "Assertion failed: %S; failing case = %S" "Assertion failed: %S") (quote (\, assertion)) (\, failing-case)) (incf assertion-failures)) (t (Print-Failure (if (\, failing-case) "%S ==> error: %S; failing case = %S" "%S ==> error: %S") (quote (\, assertion)) error-info (\, failing-case)) (incf other-failures))))) (defmacro Check-Error (expected-error &rest body) (let ((quoted-body (if (= 1 (length body)) (backquote (quote (\, (car body)))) (backquote (quote (progn (\,＠ body))))))) (backquote (condition-case error-info (progn (setq trick-optimizer (progn (\,＠ body))) (Print-Failure "%S executed successfully, but expected error %S" (\, quoted-body) (quote (\, expected-error))) (incf no-error-failures)) ((\, expected-error) (Print-Pass "%S ==> error %S, as expected" (\, quoted-body) (quote (\, expected-error))) (incf passes)) (err! or (Print-Failure "%S ==> expected error %S, got error %S instead" (\, quoted-body) (quote (\, expected-error)) error-info) (incf wrong-error-failures)))))) (defmacro Check-Error-Message (expected-error expected-error-regexp &rest body) (let ((quoted-body (if (= 1 (length body)) (backquote (quote (\, (car body)))) (backquote (quote (progn (\,＠ body))))))) (backquote (condition-case error-info (progn (setq trick-optimizer (progn (\,＠ body))) (Print-Failure "%S executed successfully, but expected error %S" (\, quoted-body) (quote (\, expected-error))) (incf no-error-failures)) ((\, expected-error) (let ((error-message (second error-info))) (if (string-match (\, expected-error-regexp) error-message) (progn (Print-Pass "%S ==> error %S %S, as expected" (\, quoted-body) error-message (quote (\, expected-error))) (incf passes)) (Print-Failure "%S ==> got error %S as expected, but error message %S did not match regexp %S" (\, quoted-body) (quote (\, expected-error)) error-message ! (\, expected-error-regexp)) (incf wrong-error-failures)))) (er! ror (Pri nt-Failure "%S ==> expected error %S, got error %S instead" (\, quoted-body) (quote (\, expected-error)) error-info) (incf wrong-error-failures)))))) (defmacro Check-Message (expected-message-regexp &rest body) (Skip-Test-Unless (fboundp (quote defadvice)) "can't defadvice" expected-message-regexp (let ((quoted-body (if (= 1 (length body)) (backquote (quote (\, (car body)))) (backquote (quote (progn (\,＠ body))))))) (backquote (let ((messages "")) (defadvice message (around collect activate) (defvar messages) (let ((msg-string (apply (quote format) (ad-get-args 0)))) (setq messages (concat messages msg-string)) msg-string)) (condition-case error-info (progn (setq trick-optimizer (progn (\,＠ body))) (if (string-match (\, expected-message-regexp) messages) (progn (Print-Pass "%S ==> value %S, message %S, matching %S, as expected" (\, quoted-body) trick-optimizer messages (quote (\, expected-message-regexp))) (incf passes)) (Print-Failure "%S ==> value %S, message %S, NOT match! ing expected %S" (\, quoted-body) trick-optimizer messages (quote (\, expected-message-regexp))) (incf missing-message-failures))) (error (Print-Failure "%S ==> unexpected error %S" (\, quoted-body) error-info) (incf other-failures))) (ad-unadvise (quote message))))))) (defmacro Silence-Message (&rest body) (backquote (flet ((append-message (&rest args) nil)) (\,＠ body)))) (defmacro Ignore-Ebola (&rest body) (backquote (let ((debug-issue-ebola-notices -42)) (\,＠ body)))) (defun Int-to-Marker (pos) (save-excursion (set-buffer standard-output) (save-excursion (goto-char pos) (point-marker)))) (princ "Testing Interpreted Lisp\n\n") (condition-case error-info (funcall (test-harness-read-from-buffer inbuffer)) (error (incf unexpected-test-file-failures) (princ (format "Unexpected error %S while executing interpreted code\n" error-info)) (message "Unexpected error %S while executing interpreted code." error-info) (message "Test suite execution aborted." error-info))) (princ "\nTe! sting Compiled Lisp\n\n") (let (code (test-harness-test-compil! ed t)) ( condition-case error-info (setq code (letf (((symbol-function (quote byte-compile-warn)) (quote ignore))) (byte-compile (test-harness-read-from-buffer inbuffer)))) (error (princ (format "Unexpected error %S while byte-compiling code\n" error-info)))) (condition-case error-info (if code (funcall code)) (error (incf unexpected-test-file-failures) (princ (format "Unexpected error %S while executing byte-compiled code\n" error-info)) (message "Unexpected error %S while executing byte-compiled code." error-info) (message "Test suite execution aborted." error-info)))) (princ (format "\nSUMMARY for %s:\n" filename)) (princ (format " %5d passes\n" passes)) (princ (format " %5d assertion failures\n" assertion-failures)) (princ (format " %5d errors that should have been generated, but weren't\n" no-error-failures)) (princ (format " %5d wrong-error failures\n" wrong-error-failures)) (princ (format " %5d missing-message failures\n" missing-message-failures)) (princ (format " %5d other f! ailures\n" other-failures)) (let* ((total (+ passes assertion-failures no-error-failures wrong-error-failures missing-message-failures other-failures)) (basename (file-name-nondirectory filename)) (summary-msg (if (> total 0) (format test-harness-file-summary-template (concat basename ":") passes total (/ (* 100 passes) total)) (format test-harness-null-summary-template (concat basename ":")))) (reasons "")) (maphash (lambda (key value) (setq reasons (concat reasons (format "\n %d tests skipped because %s." value key)))) skipped-test-reasons) (when (> (length reasons) 1) (setq summary-msg (concat summary-msg reasons "\n Probably XEmacs cannot find your installed packages. Set EMACSPACKAGEPATH\n to the package hierarchy root or configure with --package-path to enable\n the skipped tests."))) (setq test-harness-file-results-alist (cons (list filename passes total) test-harness-file-results-alist)) (message "%s" summary-msg)) (when (> unexpected-test-file-failures! 0) (setq unexpected-test-suite-failure-files (cons filename u! nexpecte d-test-suite-failure-files)) (setq unexpected-test-suite-failures (+ unexpected-test-suite-failures unexpected-test-file-failures)) (message "Test suite execution failed unexpectedly.")) (fmakunbound (quote Assert)) (fmakunbound (quote Check-Error)) (fmakunbound (quote Check-Message)) (fmakunbound (quote Check-Error-Message)) (fmakunbound (quote Ignore-Ebola)) (fmakunbound (quote Int-to-Marker)) (and noninteractive (message "%s" (buffer-substring-no-properties nil nil "*Test-Log*"))))) # (condition-case ... . ((error (princ ">>Error occurred processing ") (princ file) (princ ": ") (display-error error-info nil) (terpri) nil))) (condition-case error-info (progn (test-emacs-test-file file) t) (error (princ ">>Error occurred processing ") (princ file) (princ ": ") (display-error error-info nil) (terpri) nil)) (or (batch-test-emacs-1 file-in-dir) (setq error t)) (if (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t))) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t))) (while --dolist-temp--91803 (setq file-in-dir (car --dolist-temp--91803)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t))) (setq --dolist-temp--91803 (cdr --dolist-temp--91803))) (let ((--dolist-temp--91803 (directory-files file t)) file-in-dir) (while --dolist-temp--91803 (setq file-in-dir (car --dolist-temp--91803)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t))) (setq --dolist-temp--91803 (cdr --dolist-temp--91803))) nil) (catch (quote --cl-block-nil--) (let ((--dolist-temp--91803 (directory-files file t)) file-in-dir) (while --dolist-temp--91803 (setq file-in-dir (car --dolist-temp--91803)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t))) (setq --dolist-temp--91803 (cdr --dolist-temp--91803))) nil)) (cl-block-wrapper (catch (quote --cl-block-nil--) (let ((--dolist-temp--91803 (directory-files file t)) file-in-dir) (while --dolist-temp--91803 (setq file-in-dir (car --dolist-temp--91803)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t))) (setq --dolist-temp--91803 (cdr --dolist-temp--91803))) nil))) (block nil (let ((--dolist-temp--91803 (directory-files file t)) file-in-dir) (while --dolist-temp--91803 (setq file-in-dir (car --dolist-temp--91803)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t))) (setq --dolist-temp--91803 (cdr --dolist-temp--91803))) nil)) (dolist (file-in-dir (directory-files file t)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t)))) (if (file-directory-p file) (dolist (file-in-dir (directory-files file t)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t)))) (or (batch-test-emacs-1 file) (setq error t))) (while --dolist-temp--91802 (setq file (car --dolist-temp--91802)) (if (file-directory-p file) (dolist (file-in-dir (directory-files file t)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t)))) (or (batch-test-emacs-1 file) (setq error t))) (setq --dolist-temp--91802 (cdr --dolist-temp--91802))) (let ((--dolist-temp--91802 command-line-args-left) file) (while --dolist-temp--91802 (setq file (car --dolist-temp--91802)) (if (file-directory-p file) (dolist (file-in-dir (directory-files file t)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t)))) (or (batch-test-emacs-1 file) (setq error t))) (setq --dolist-temp--91802 (cdr --dolist-temp--91802))) nil) (catch (quote --cl-block-nil--) (let ((--dolist-temp--91802 command-line-args-left) file) (while --dolist-temp--91802 (setq file (car --dolist-temp--91802)) (if (file-directory-p file) (dolist (file-in-dir (directory-files file t)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t)))) (or (batch-test-emacs-1 file) (setq error t))) (setq --dolist-temp--91802 (cdr --dolist-temp--91802))) nil)) (cl-block-wrapper (catch (quote --cl-block-nil--) (let ((--dolist-temp--91802 command-line-args-left) file) (while --dolist-temp--91802 (setq file (car --dolist-temp--91802)) (if (file-directory-p file) (dolist (file-in-dir (directory-files file t)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t)))) (or (batch-test-emacs-1 file) (setq error t))) (setq --dolist-temp--91802 (cdr --dolist-temp--91802))) nil))) (block nil (let ((--dolist-temp--91802 command-line-args-left) file) (while --dolist-temp--91802 (setq file (car --dolist-temp--91802)) (if (file-directory-p file) (dolist (file-in-dir (directory-files file t)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t)))) (or (batch-test-emacs-1 file) (setq error t))) (setq --dolist-temp--91802 (cdr --dolist-temp--91802))) nil)) (dolist (file command-line-args-left) (if (file-directory-p file) (dolist (file-in-dir (directory-files file t)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t)))) (or (batch-test-emacs-1 file) (setq error t)))) # bind (error) (let ((error nil)) (dolist (file command-line-args-left) (if (file-directory-p file) (dolist (file-in-dir (directory-files file t)) (when (and (string-match emacs-lisp-file-regexp file-in-dir) (not (or (auto-save-file-name-p file-in-dir) (backup-file-name-p file-in-dir) (equal (file-name-nondirectory file-in-dir) "test-harness.el")))) (or (batch-test-emacs-1 file-in-dir) (setq error t)))) (or (batch-test-emacs-1 file) (setq error t)))) (let ((namelen 0) (succlen 0) (testlen 0) (results test-harness-file-results-alist)) (flet ((print-width (i) (let ((x 10) (y 1)) (while (>= i x) (setq x (* 10 x) y (1+ y))) y))) (while results (let* ((head (car results)) (nn (length (file-name-nondirectory (first head)))) (ss (print-width (second head))) (tt (print-width (third head)))) (when (> nn namelen) (setq namelen nn)) (when (> ss succlen) (setq succlen ss)) (when (> tt testlen) (setq testlen tt))) (setq results (cdr results)))) (let ((results (reverse test-harness-file-results-alist)! )) (while results (let* ((head (car results)) (basename (file-name-nondirectory (first head))) (nsucc (second head)) (ntest (third head))) (if (> ntest 0) (message test-harness-file-summary-template (concat basename ":") nsucc ntest (/ (* 100 nsucc) ntest)) (message test-harness-null-summary-template (concat basename ":"))) (setq results (cdr results))))) (when (> unexpected-test-suite-failures 0) (message "\n***** There %s %d unexpected test suite %s in %s:" (if (= unexpected-test-suite-failures 1) "was" "were") unexpected-test-suite-failures (if (= unexpected-test-suite-failures 1) "failure" "failures") (if (= (length unexpected-test-suite-failure-files) 1) "file" "files")) (while unexpected-test-suite-failure-files (let ((line (pop unexpected-test-suite-failure-files))) (while (and (< (length line) 61) unexpected-test-suite-failure-files) (setq line (concat line " " (pop unexpected-test-suite-failure-files)))) (message line))))) (message "\nDone") (kill-emacs (if error 1! 0))) # bind (error-data) # (condition-case ... . error) Compilation finished at Wed Dec 05 08:57:42 -- Adrian Aichner mailto:adrian＠xemacs.org http://www.xemacs.org/ _______________________________________________ XEmacs-Beta mailing list XEmacs-Beta(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-beta