1;;; 2;;; srfi-64 3;;; 4 5;; This file is based on srfi-64 reference implementation, 6;; but modified to work cooperatively with gauche's test framework. 7 8;; Original copyright follows: 9 10;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner 11;; Added "full" support for Chicken, Gauche, Guile and SISC. 12;; Alex Shinn, Copyright (c) 2005. 13;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012. 14;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014. 15;; 16;; Permission is hereby granted, free of charge, to any person 17;; obtaining a copy of this software and associated documentation 18;; files (the "Software"), to deal in the Software without 19;; restriction, including without limitation the rights to use, copy, 20;; modify, merge, publish, distribute, sublicense, and/or sell copies 21;; of the Software, and to permit persons to whom the Software is 22;; furnished to do so, subject to the following conditions: 23;; 24;; The above copyright notice and this permission notice shall be 25;; included in all copies or substantial portions of the Software. 26;; 27;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 28;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 29;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 30;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 31;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 32;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 33;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 34;; SOFTWARE. 35 36;; Gauche tweak: 37;; 38;; We define a default runner, which is used when a test runner is 39;; implicitly created during gauche.test is active. It differs from 40;; simple runner that (1) it updates test success/failure counts of 41;; gauche.test, and (2) it sends log to stdout, to be merged to the 42;; gauche.test logs. 43 44(define-module srfi-64 45 (use gauche.record) 46 (use gauche.test :prefix test:) 47 (export test-begin 48 test-end test-assert test-eqv test-eq test-equal 49 test-approximate test-assert test-error test-apply test-with-runner 50 test-match-nth test-match-all test-match-any test-match-name 51 test-skip test-expect-fail test-read-eval-string 52 test-runner-group-path test-group test-group-with-cleanup 53 test-result-ref test-result-set! test-result-clear test-result-remove 54 test-result-kind test-passed? 55 test-log-to-file 56 57 ;; Misc test-runner functions 58 test-runner? test-runner-reset test-runner-null 59 test-runner-simple test-runner-current test-runner-factory test-runner-get 60 test-runner-create test-runner-test-name 61 ;; test-runner field setter and getter functions - see %test-record-define: 62 test-runner-pass-count test-runner-pass-count! 63 test-runner-fail-count test-runner-fail-count! 64 test-runner-xpass-count test-runner-xpass-count! 65 test-runner-xfail-count test-runner-xfail-count! 66 test-runner-skip-count test-runner-skip-count! 67 test-runner-group-stack test-runner-group-stack! 68 test-runner-on-test-begin test-runner-on-test-begin! 69 test-runner-on-test-end test-runner-on-test-end! 70 test-runner-on-group-begin test-runner-on-group-begin! 71 test-runner-on-group-end test-runner-on-group-end! 72 test-runner-on-final test-runner-on-final! 73 test-runner-on-bad-count test-runner-on-bad-count! 74 test-runner-on-bad-end-name test-runner-on-bad-end-name! 75 test-result-alist test-result-alist! 76 test-runner-aux-value test-runner-aux-value! 77 ;; default/simple call-back functions, used in default test-runner, 78 ;; but can be called to construct more complex ones. 79 test-on-group-begin-simple test-on-group-end-simple 80 test-on-bad-count-simple test-on-bad-end-name-simple 81 test-on-final-simple test-on-test-end-simple 82 test-on-final-simple)) 83(select-module srfi-64) 84 85(define-record-type test-runner (%test-runner-alloc) test-runner? 86 ;; Cumulate count of all tests that have passed and were expected to. 87 (pass-count test-runner-pass-count test-runner-pass-count!) 88 (fail-count test-runner-fail-count test-runner-fail-count!) 89 (xpass-count test-runner-xpass-count test-runner-xpass-count!) 90 (xfail-count test-runner-xfail-count test-runner-xfail-count!) 91 (skip-count test-runner-skip-count test-runner-skip-count!) 92 (skip-list %test-runner-skip-list %test-runner-skip-list!) 93 (fail-list %test-runner-fail-list %test-runner-fail-list!) 94 ;; Normally #t, except when in a test-apply. 95 (run-list %test-runner-run-list %test-runner-run-list!) 96 (skip-save %test-runner-skip-save %test-runner-skip-save!) 97 (fail-save %test-runner-fail-save %test-runner-fail-save!) 98 (group-stack test-runner-group-stack test-runner-group-stack!) 99 (on-test-begin test-runner-on-test-begin test-runner-on-test-begin!) 100 (on-test-end test-runner-on-test-end test-runner-on-test-end!) 101 ;; Call-back when entering a group. Takes (runner suite-name count). 102 (on-group-begin test-runner-on-group-begin test-runner-on-group-begin!) 103 ;; Call-back when leaving a group. 104 (on-group-end test-runner-on-group-end test-runner-on-group-end!) 105 ;; Call-back when leaving the outermost group. 106 (on-final test-runner-on-final test-runner-on-final!) 107 ;; Call-back when expected number of tests was wrong. 108 (on-bad-count test-runner-on-bad-count test-runner-on-bad-count!) 109 ;; Call-back when name in test=end doesn't match test-begin. 110 (on-bad-end-name test-runner-on-bad-end-name test-runner-on-bad-end-name!) 111 ;; Cumulate count of all tests that have been done. 112 (total-count %test-runner-total-count %test-runner-total-count!) 113 ;; Stack (list) of (count-at-start . expected-count): 114 (count-list %test-runner-count-list %test-runner-count-list!) 115 (result-alist test-result-alist test-result-alist!) 116 ;; Field can be used by test-runner for any purpose. 117 ;; test-runner-simple uses it for a log file. 118 (aux-value test-runner-aux-value test-runner-aux-value!) 119 ) 120 121(define (test-runner-reset runner) 122 (test-result-alist! runner '()) 123 (test-runner-pass-count! runner 0) 124 (test-runner-fail-count! runner 0) 125 (test-runner-xpass-count! runner 0) 126 (test-runner-xfail-count! runner 0) 127 (test-runner-skip-count! runner 0) 128 (%test-runner-total-count! runner 0) 129 (%test-runner-count-list! runner '()) 130 (%test-runner-run-list! runner #t) 131 (%test-runner-skip-list! runner '()) 132 (%test-runner-fail-list! runner '()) 133 (%test-runner-skip-save! runner '()) 134 (%test-runner-fail-save! runner '()) 135 (test-runner-group-stack! runner '()) 136 (test-runner-aux-value! runner #f)) 137 138(define (test-runner-group-path runner) 139 (reverse (test-runner-group-stack runner))) 140 141;;; 142;;; Null runner 143;;; 144 145(define (%test-null-callback runner) #f) 146 147(define (test-runner-null) 148 (let ((runner (%test-runner-alloc))) 149 (test-runner-reset runner) 150 (test-runner-on-group-begin! runner (lambda (runner name count) #f)) 151 (test-runner-on-group-end! runner %test-null-callback) 152 (test-runner-on-final! runner %test-null-callback) 153 (test-runner-on-test-begin! runner %test-null-callback) 154 (test-runner-on-test-end! runner %test-null-callback) 155 (test-runner-on-bad-count! runner (lambda (runner count expected) #f)) 156 (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f)) 157 runner)) 158 159;;; 160;;; Simple runner 161;;; 162 163;; Not part of the specification. FIXME 164;; Controls whether a log file is generated. 165(define test-log-to-file #t) 166 167(define (test-runner-simple) 168 (let ((runner (%test-runner-alloc))) 169 (test-runner-reset runner) 170 (test-runner-on-group-begin! runner test-on-group-begin-simple) 171 (test-runner-on-group-end! runner test-on-group-end-simple) 172 (test-runner-on-final! runner test-on-final-simple) 173 (test-runner-on-test-begin! runner test-on-test-begin-simple) 174 (test-runner-on-test-end! runner test-on-test-end-simple) 175 (test-runner-on-bad-count! runner test-on-bad-count-simple) 176 (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple) 177 runner)) 178 179(define test-runner-current (make-parameter #f)) 180(define test-runner-factory (make-parameter test-runner-simple)) 181 182;; A safer wrapper to test-runner-current. 183(define (test-runner-get) 184 (let ((r (test-runner-current))) 185 (if (not r) 186 (error "test-runner not initialized - test-begin missing?")) 187 r)) 188 189(define (%test-specifier-matches spec runner) 190 (spec runner)) 191 192(define (test-runner-create) 193 ((test-runner-factory))) 194 195(define (%test-any-specifier-matches list runner) 196 (let ((result #f)) 197 (let loop ((l list)) 198 (cond ((null? l) result) 199 (else 200 (if (%test-specifier-matches (car l) runner) 201 (set! result #t)) 202 (loop (cdr l))))))) 203 204;; Returns #f, #t, or 'xfail. 205(define (%test-should-execute runner) 206 (let ((run (%test-runner-run-list runner))) 207 (cond ((or 208 (not (or (eqv? run #t) 209 (%test-any-specifier-matches run runner))) 210 (%test-any-specifier-matches 211 (%test-runner-skip-list runner) 212 runner)) 213 (test-result-set! runner 'result-kind 'skip) 214 #f) 215 ((%test-any-specifier-matches 216 (%test-runner-fail-list runner) 217 runner) 218 (test-result-set! runner 'result-kind 'xfail) 219 'xfail) 220 (else #t)))) 221 222(define (%test-begin suite-name count) 223 (if (not (test-runner-current)) 224 (test-runner-current (if (test:test-running?) 225 (test-runner-default) 226 (test-runner-create)))) 227 (let ((runner (test-runner-current))) 228 ((test-runner-on-group-begin runner) runner suite-name count) 229 (%test-runner-skip-save! runner 230 (cons (%test-runner-skip-list runner) 231 (%test-runner-skip-save runner))) 232 (%test-runner-fail-save! runner 233 (cons (%test-runner-fail-list runner) 234 (%test-runner-fail-save runner))) 235 (%test-runner-count-list! runner 236 (cons (cons (%test-runner-total-count runner) 237 count) 238 (%test-runner-count-list runner))) 239 (test-runner-group-stack! runner (cons suite-name 240 (test-runner-group-stack runner))))) 241(define-syntax test-begin 242 (syntax-rules () 243 ((test-begin suite-name) 244 (%test-begin suite-name #f)) 245 ((test-begin suite-name count) 246 (%test-begin suite-name count)))) 247 248(define (test-on-group-begin-simple runner suite-name count) 249 (if (null? (test-runner-group-stack runner)) 250 (begin 251 (display "%%%% Starting test ") 252 (display suite-name) 253 (if test-log-to-file 254 (let* ((log-file-name 255 (if (string? test-log-to-file) test-log-to-file 256 (string-append suite-name ".log"))) 257 (log-file 258 (cond-expand (mzscheme 259 (open-output-file log-file-name 'truncate/replace)) 260 (else (open-output-file log-file-name))))) 261 (display "%%%% Starting test " log-file) 262 (display suite-name log-file) 263 (newline log-file) 264 (test-runner-aux-value! runner log-file) 265 (display " (Writing full log to \"") 266 (display log-file-name) 267 (display "\")"))) 268 (newline))) 269 (let ((log (test-runner-aux-value runner))) 270 (if (output-port? log) 271 (begin 272 (display "Group begin: " log) 273 (display suite-name log) 274 (newline log)))) 275 #f) 276 277(define (test-on-group-end-simple runner) 278 (let ((log (test-runner-aux-value runner))) 279 (if (output-port? log) 280 (begin 281 (display "Group end: " log) 282 (display (car (test-runner-group-stack runner)) log) 283 (newline log)))) 284 #f) 285 286(define (%test-on-bad-count-write runner count expected-count port) 287 (display "*** Total number of tests was " port) 288 (display count port) 289 (display " but should be " port) 290 (display expected-count port) 291 (display ". ***" port) 292 (newline port) 293 (display "*** Discrepancy indicates testsuite error or exceptions. ***" port) 294 (newline port)) 295 296(define (test-on-bad-count-simple runner count expected-count) 297 (%test-on-bad-count-write runner count expected-count (current-output-port)) 298 (let ((log (test-runner-aux-value runner))) 299 (if (output-port? log) 300 (%test-on-bad-count-write runner count expected-count log)))) 301 302(define (test-on-bad-end-name-simple runner begin-name end-name) 303 (let ((msg (string-append (%test-format-line runner) "test-end " begin-name 304 " does not match test-begin " end-name))) 305 (error msg))) 306 307(define (%test-final-report1 value label port) 308 (if (> value 0) 309 (begin 310 (display label port) 311 (display value port) 312 (newline port)))) 313 314(define (%test-final-report-simple runner port) 315 (%test-final-report1 (test-runner-pass-count runner) 316 "# of expected passes " port) 317 (%test-final-report1 (test-runner-xfail-count runner) 318 "# of expected failures " port) 319 (%test-final-report1 (test-runner-xpass-count runner) 320 "# of unexpected successes " port) 321 (%test-final-report1 (test-runner-fail-count runner) 322 "# of unexpected failures " port) 323 (%test-final-report1 (test-runner-skip-count runner) 324 "# of skipped tests " port)) 325 326(define (test-on-final-simple runner) 327 (%test-final-report-simple runner (current-output-port)) 328 (let ((log (test-runner-aux-value runner))) 329 (if (output-port? log) 330 (%test-final-report-simple runner log)))) 331 332;;; 333;;; Default runner 334;;; 335 336;; KLUDGE: we distinguish test-runner-default by having special marker 337;; in aux-value 338(define (test-runner-default) 339 (let ((runner (%test-runner-alloc))) 340 (test-runner-reset runner) 341 (test-runner-on-group-begin! runner test-on-group-begin-default) 342 (test-runner-on-group-end! runner %test-null-callback) 343 (test-runner-on-final! runner %test-null-callback) 344 (test-runner-on-test-begin! runner %test-null-callback) 345 (test-runner-on-test-end! runner %test-null-callback) 346 (test-runner-on-bad-count! runner (lambda (runner count expected) #f)) 347 (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f)) 348 (test-runner-aux-value! runner *test-runner-default-marker*) 349 runner)) 350 351(define *test-runner-default-marker* (list 'default)) 352 353(define (test-on-group-begin-default runner suite-name count) 354 (test:test-section suite-name) 355 #f) 356 357(define (test-runner-default? runner) 358 (eq? (test-runner-aux-value runner) *test-runner-default-marker*)) 359 360(define (test-runner-default-pre runner expr) 361 (when (test-runner-default? runner) 362 (let ([expect (test-result-ref runner 'expected-value)] 363 [msg (or (test-result-ref runner 'test-name) 364 expr)]) 365 (test-result-set! runner 'test-msg msg) 366 (format #t "test ~a, expects ~s ==> " msg expect) 367 (flush) 368 (test:test-count++)))) 369 370(define (test-runner-default-post runner ok?) 371 (when (test-runner-default? runner) 372 (cond [ok? (format #t "ok\n") (test:test-pass++)] 373 [(eq? (test-result-ref runner 'result-kind) 'xfail) 374 (format #t "ok (expected failure)\n") (test:test-pass++)] 375 [else 376 (let ([expect (test-result-ref runner 'expected-value)] 377 [result (test-result-ref runner 'actual-value)] 378 [msg (test-result-ref runner 'test-msg)]) 379 (begin (format #t "ERROR: GOT ~s\n" result) 380 (test:test-fail++ msg expect result)))]))) 381 382;;; 383;;; Test API 384;;; 385 386(define (%test-format-line runner) 387 (let* ((line-info (test-result-alist runner)) 388 (source-file (assq 'source-file line-info)) 389 (source-line (assq 'source-line line-info)) 390 (file (if source-file (cdr source-file) ""))) 391 (if source-line 392 (string-append file ":" 393 (number->string (cdr source-line)) ": ") 394 ""))) 395 396(define (%test-end suite-name line-info) 397 (let* ((r (test-runner-get)) 398 (groups (test-runner-group-stack r)) 399 (line (%test-format-line r))) 400 (test-result-alist! r line-info) 401 (if (null? groups) 402 (let ((msg (string-append line "test-end not in a group"))) 403 (error msg))) 404 (if (and suite-name (not (equal? suite-name (car groups)))) 405 ((test-runner-on-bad-end-name r) r suite-name (car groups))) 406 (let* ((count-list (%test-runner-count-list r)) 407 (expected-count (cdar count-list)) 408 (saved-count (caar count-list)) 409 (group-count (- (%test-runner-total-count r) saved-count))) 410 (if (and expected-count 411 (not (= expected-count group-count))) 412 ((test-runner-on-bad-count r) r group-count expected-count)) 413 ((test-runner-on-group-end r) r) 414 (test-runner-group-stack! r (cdr (test-runner-group-stack r))) 415 (%test-runner-skip-list! r (car (%test-runner-skip-save r))) 416 (%test-runner-skip-save! r (cdr (%test-runner-skip-save r))) 417 (%test-runner-fail-list! r (car (%test-runner-fail-save r))) 418 (%test-runner-fail-save! r (cdr (%test-runner-fail-save r))) 419 (%test-runner-count-list! r (cdr count-list)) 420 (if (null? (test-runner-group-stack r)) 421 ((test-runner-on-final r) r))))) 422 423(define-syntax test-group 424 (syntax-rules () 425 ((test-group suite-name . body) 426 (let ((r (test-runner-current))) 427 ;; Ideally should also set line-number, if available. 428 (test-result-alist! r (list (cons 'test-name suite-name))) 429 (if (%test-should-execute r) 430 (dynamic-wind 431 (lambda () (test-begin suite-name)) 432 (lambda () . body) 433 (lambda () (test-end suite-name)))))))) 434 435(define-syntax test-group-with-cleanup 436 (syntax-rules () 437 ((test-group-with-cleanup suite-name form cleanup-form) 438 (test-group suite-name 439 (dynamic-wind 440 (lambda () #f) 441 (lambda () form) 442 (lambda () cleanup-form)))) 443 ((test-group-with-cleanup suite-name cleanup-form) 444 (test-group-with-cleanup suite-name #f cleanup-form)) 445 ((test-group-with-cleanup suite-name form1 form2 form3 . rest) 446 (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest)))) 447 448(define (test-on-test-begin-simple runner) 449 (let ((log (test-runner-aux-value runner))) 450 (if (output-port? log) 451 (let* ((results (test-result-alist runner)) 452 (source-file (assq 'source-file results)) 453 (source-line (assq 'source-line results)) 454 (source-form (assq 'source-form results)) 455 (test-name (assq 'test-name results))) 456 (display "Test begin:" log) 457 (newline log) 458 (if test-name (%test-write-result1 test-name log)) 459 (if source-file (%test-write-result1 source-file log)) 460 (if source-line (%test-write-result1 source-line log)) 461 (if source-form (%test-write-result1 source-form log)))))) 462 463(define (test-result-ref runner pname :optional (default #f)) 464 (let ((p (assq pname (test-result-alist runner)))) 465 (if p (cdr p) default))) 466 467(define (test-on-test-end-simple runner) 468 (let ((log (test-runner-aux-value runner)) 469 (kind (test-result-ref runner 'result-kind))) 470 (if (memq kind '(fail xpass)) 471 (let* ((results (test-result-alist runner)) 472 (source-file (assq 'source-file results)) 473 (source-line (assq 'source-line results)) 474 (test-name (assq 'test-name results))) 475 (if (or source-file source-line) 476 (begin 477 (if source-file (display (cdr source-file))) 478 (display ":") 479 (if source-line (display (cdr source-line))) 480 (display ": "))) 481 (display (if (eq? kind 'xpass) "XPASS" "FAIL")) 482 (if test-name 483 (begin 484 (display " ") 485 (display (cdr test-name)))) 486 (newline) 487 (display " expected:") 488 (write (test-result-ref runner 'expected-value)) 489 (newline) 490 (display " actual:") 491 (write (test-result-ref runner 'actual-value)) 492 (newline))) 493 (if (output-port? log) 494 (begin 495 (display "Test end:" log) 496 (newline log) 497 (let loop ((list (test-result-alist runner))) 498 (if (pair? list) 499 (let ((pair (car list))) 500 ;; Write out properties not written out by on-test-begin. 501 (if (not (memq (car pair) 502 '(test-name source-file source-line source-form))) 503 (%test-write-result1 pair log)) 504 (loop (cdr list))))))))) 505 506(define (%test-write-result1 pair port) 507 (display " " port) 508 (display (car pair) port) 509 (display ": " port) 510 (write (cdr pair) port) 511 (newline port)) 512 513(define (test-result-set! runner pname value) 514 (let* ((alist (test-result-alist runner)) 515 (p (assq pname alist))) 516 (if p 517 (set-cdr! p value) 518 (test-result-alist! runner (cons (cons pname value) alist))))) 519 520(define (test-result-clear runner) 521 (test-result-alist! runner '())) 522 523(define (test-result-remove runner pname) 524 (let* ((alist (test-result-alist runner)) 525 (p (assq pname alist))) 526 (if p 527 (test-result-alist! runner 528 (let loop ((r alist)) 529 (if (eq? r p) (cdr r) 530 (cons (car r) (loop (cdr r))))))))) 531 532(define (test-result-kind . rest) 533 (let ((runner (if (pair? rest) (car rest) (test-runner-current)))) 534 (test-result-ref runner 'result-kind))) 535 536(define (test-passed? . rest) 537 (let ((runner (if (pair? rest) (car rest) (test-runner-get)))) 538 (memq (test-result-ref runner 'result-kind) '(pass xpass)))) 539 540(define (%test-report-result) 541 (let* ((r (test-runner-get)) 542 (result-kind (test-result-kind r))) 543 (case result-kind 544 ((pass) 545 (test-runner-pass-count! r (+ 1 (test-runner-pass-count r)))) 546 ((fail) 547 (test-runner-fail-count! r (+ 1 (test-runner-fail-count r)))) 548 ((xpass) 549 (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r)))) 550 ((xfail) 551 (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r)))) 552 (else 553 (test-runner-skip-count! r (+ 1 (test-runner-skip-count r))))) 554 (%test-runner-total-count! r (+ 1 (%test-runner-total-count r))) 555 ((test-runner-on-test-end r) r))) 556 557(define-syntax %test-evaluate-with-catch 558 (syntax-rules () 559 ((%test-evaluate-with-catch test-expression) 560 (guard (err (else (print err) #f)) test-expression)))) 561 562(define (%test-source-line2 form) ; can be something - later 563 '()) 564 565(define (%test-on-test-begin r) 566 (%test-should-execute r) 567 ((test-runner-on-test-begin r) r) 568 (not (eq? 'skip (test-result-ref r 'result-kind)))) 569 570(define (%test-on-test-end r result) 571 (test-result-set! r 'result-kind 572 (if (eq? (test-result-ref r 'result-kind) 'xfail) 573 (if result 'xpass 'xfail) 574 (if result 'pass 'fail)))) 575 576(define (test-runner-test-name runner) 577 (test-result-ref runner 'test-name "")) 578 579(define-syntax %test-comp2body 580 (syntax-rules () 581 ((%test-comp2body r comp expected expr) 582 (let () 583 (if (%test-on-test-begin r) 584 (let ((exp expected)) 585 (test-result-set! r 'expected-value exp) 586 (test-runner-default-pre r 'expr) 587 (let* ((res (%test-evaluate-with-catch expr)) 588 (compared (comp exp res))) 589 (test-result-set! r 'actual-value res) 590 (test-runner-default-post r compared) 591 (%test-on-test-end r compared)))) 592 (%test-report-result))))) 593 594(define (%test-approximate= error) 595 (lambda (value expected) 596 (let ((rval (real-part value)) 597 (ival (imag-part value)) 598 (rexp (real-part expected)) 599 (iexp (imag-part expected))) 600 (and (>= rval (- rexp error)) 601 (>= ival (- iexp error)) 602 (<= rval (+ rexp error)) 603 (<= ival (+ iexp error)))))) 604 605(define-syntax %test-comp1body 606 (syntax-rules () 607 ((%test-comp1body r expr) 608 (let () 609 (if (%test-on-test-begin r) 610 (let () 611 (test-result-set! r 'expected-value #t) 612 (test-runner-default-pre r 'expr) 613 (let ((res (%test-evaluate-with-catch expr))) 614 (test-result-set! r 'actual-value res) 615 (test-runner-default-post r (boolean r)) 616 (%test-on-test-end r res)))) 617 (%test-report-result))))) 618 619(define-syntax test-end 620 (syntax-rules () 621 ((test-end) 622 (%test-end #f '())) 623 ((test-end suite-name) 624 (%test-end suite-name '())))) 625(define-syntax test-assert 626 (syntax-rules () 627 ((test-assert tname test-expression) 628 (let* ((r (test-runner-get)) 629 (name tname)) 630 (test-result-alist! r '((test-name . tname))) 631 (%test-comp1body r test-expression))) 632 ((test-assert test-expression) 633 (let* ((r (test-runner-get))) 634 (test-result-alist! r '()) 635 (%test-comp1body r test-expression))))) 636(define-syntax %test-comp2 637 (syntax-rules () 638 ((%test-comp2 comp tname expected expr) 639 (let* ((r (test-runner-get)) 640 (name tname)) 641 (test-result-alist! r (list (cons 'test-name tname))) 642 (%test-comp2body r comp expected expr))) 643 ((%test-comp2 comp expected expr) 644 (let* ((r (test-runner-get))) 645 (test-result-alist! r (list (cons 'test-name 'expr))) 646 (%test-comp2body r comp expected expr))))) 647(define-syntax test-equal 648 (syntax-rules () 649 ((test-equal . rest) 650 (%test-comp2 equal? . rest)))) 651(define-syntax test-eqv 652 (syntax-rules () 653 ((test-eqv . rest) 654 (%test-comp2 eqv? . rest)))) 655(define-syntax test-eq 656 (syntax-rules () 657 ((test-eq . rest) 658 (%test-comp2 eq? . rest)))) 659(define-syntax test-approximate 660 (syntax-rules () 661 ((test-approximate tname expected expr error) 662 (%test-comp2 (%test-approximate= error) tname expected expr)) 663 ((test-approximate expected expr error) 664 (%test-comp2 (%test-approximate= error) expected expr)))) 665 666(define-syntax %test-error 667 (syntax-rules () 668 ((%test-error r etype expr) 669 (%test-comp1body r (guard (ex ((condition-type? etype) 670 (and (condition? ex) (condition-has-type? ex etype))) 671 ((procedure? etype) 672 (etype ex)) 673 ((equal? etype #t) 674 #t) 675 (else #t)) 676 expr #f))))) 677 678(define-syntax test-error 679 (syntax-rules () 680 ((test-error name etype expr) 681 (let ((r (test-runner-get))) 682 (test-result-alist! r `((test-name . ,name))) 683 (%test-error r etype expr))) 684 ((test-error etype expr) 685 (let ((r (test-runner-get))) 686 (test-result-alist! r '()) 687 (%test-error r etype expr))) 688 ((test-error expr) 689 (let ((r (test-runner-get))) 690 (test-result-alist! r '()) 691 (%test-error r #t expr))))) 692 693(define-syntax test-with-runner 694 (syntax-rules () 695 ((test-with-runner runner form ...) 696 (let ((saved-runner (test-runner-current))) 697 (dynamic-wind 698 (lambda () (test-runner-current runner)) 699 (lambda () form ...) 700 (lambda () (test-runner-current saved-runner))))))) 701 702(define (test-apply first . rest) 703 (if (test-runner? first) 704 (test-with-runner first (apply test-apply rest)) 705 (let ((r (test-runner-current))) 706 (if r 707 (let ((run-list (%test-runner-run-list r))) 708 (cond ((null? rest) 709 (%test-runner-run-list! r (reverse run-list)) 710 (first)) ;; actually apply procedure thunk 711 (else 712 (%test-runner-run-list! 713 r 714 (if (eq? run-list #t) (list first) (cons first run-list))) 715 (apply test-apply rest) 716 (%test-runner-run-list! r run-list)))) 717 (let ((r (test-runner-create))) 718 (test-with-runner r (apply test-apply first rest)) 719 ((test-runner-on-final r) r)))))) 720 721;;; Predicates 722 723(define (%test-match-nth n count) 724 (let ((i 0)) 725 (lambda (runner) 726 (set! i (+ i 1)) 727 (and (>= i n) (< i (+ n count)))))) 728 729(define-syntax test-match-nth 730 (syntax-rules () 731 ((test-match-nth n) 732 (test-match-nth n 1)) 733 ((test-match-nth n count) 734 (%test-match-nth n count)))) 735 736(define (%test-match-all . pred-list) 737 (lambda (runner) 738 (let ((result #t)) 739 (let loop ((l pred-list)) 740 (if (null? l) 741 result 742 (begin 743 (if (not ((car l) runner)) 744 (set! result #f)) 745 (loop (cdr l)))))))) 746 747(define-syntax test-match-all 748 (syntax-rules () 749 ((test-match-all pred ...) 750 (%test-match-all (%test-as-specifier pred) ...)))) 751 752(define (%test-match-any . pred-list) 753 (lambda (runner) 754 (let ((result #f)) 755 (let loop ((l pred-list)) 756 (if (null? l) 757 result 758 (begin 759 (if ((car l) runner) 760 (set! result #t)) 761 (loop (cdr l)))))))) 762 763(define-syntax test-match-any 764 (syntax-rules () 765 ((test-match-any pred ...) 766 (%test-match-any (%test-as-specifier pred) ...)))) 767 768;; Coerce to a predicate function: 769(define (%test-as-specifier specifier) 770 (cond ((procedure? specifier) specifier) 771 ((integer? specifier) (test-match-nth 1 specifier)) 772 ((string? specifier) (test-match-name specifier)) 773 (else 774 (error "not a valid test specifier")))) 775 776(define-syntax test-skip 777 (syntax-rules () 778 ((test-skip pred ...) 779 (let ((runner (test-runner-get))) 780 (%test-runner-skip-list! runner 781 (cons (test-match-all (%test-as-specifier pred) ...) 782 (%test-runner-skip-list runner))))))) 783 784(define-syntax test-expect-fail 785 (syntax-rules () 786 ((test-expect-fail pred ...) 787 (let ((runner (test-runner-get))) 788 (%test-runner-fail-list! runner 789 (cons (test-match-all (%test-as-specifier pred) ...) 790 (%test-runner-fail-list runner))))))) 791 792(define (test-match-name name) 793 (lambda (runner) 794 (equal? name (test-runner-test-name runner)))) 795 796(define (test-read-eval-string string) 797 (let* ((port (open-input-string string)) 798 (form (read port))) 799 (if (eof-object? (read-char port)) 800 (eval form ((with-module gauche.internal vm-current-module))) 801 (error "(not at eof)")))) 802