Mirror of GNU Guix
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

1040 lines
35 KiB

  1. ;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
  2. ;; Added "full" support for Chicken, Gauche, Guile and SISC.
  3. ;; Alex Shinn, Copyright (c) 2005.
  4. ;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
  5. ;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
  6. ;;
  7. ;; Permission is hereby granted, free of charge, to any person
  8. ;; obtaining a copy of this software and associated documentation
  9. ;; files (the "Software"), to deal in the Software without
  10. ;; restriction, including without limitation the rights to use, copy,
  11. ;; modify, merge, publish, distribute, sublicense, and/or sell copies
  12. ;; of the Software, and to permit persons to whom the Software is
  13. ;; furnished to do so, subject to the following conditions:
  14. ;;
  15. ;; The above copyright notice and this permission notice shall be
  16. ;; included in all copies or substantial portions of the Software.
  17. ;;
  18. ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  19. ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  20. ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  21. ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
  22. ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
  23. ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
  24. ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  25. ;; SOFTWARE.
  26. (cond-expand
  27. (chicken
  28. (require-extension syntax-case))
  29. (guile-2
  30. (use-modules (srfi srfi-9)
  31. ;; In 2.0.9, srfi-34 and srfi-35 are not well integrated
  32. ;; with either Guile's native exceptions or R6RS exceptions.
  33. ;;(srfi srfi-34) (srfi srfi-35)
  34. (srfi srfi-39)))
  35. (guile
  36. (use-modules (ice-9 syncase) (srfi srfi-9)
  37. ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7
  38. (srfi srfi-39)))
  39. (sisc
  40. (require-extension (srfi 9 34 35 39)))
  41. (kawa
  42. (module-compile-options warn-undefined-variable: #t
  43. warn-invoke-unknown-method: #t)
  44. (provide 'srfi-64)
  45. (provide 'testing)
  46. (require 'srfi-34)
  47. (require 'srfi-35))
  48. (else ()
  49. ))
  50. (cond-expand
  51. (kawa
  52. (define-syntax %test-export
  53. (syntax-rules ()
  54. ((%test-export test-begin . other-names)
  55. (module-export %test-begin . other-names)))))
  56. (else
  57. (define-syntax %test-export
  58. (syntax-rules ()
  59. ((%test-export . names) (if #f #f))))))
  60. ;; List of exported names
  61. (%test-export
  62. test-begin ;; must be listed first, since in Kawa (at least) it is "magic".
  63. test-end test-assert test-eqv test-eq test-equal
  64. test-approximate test-assert test-error test-apply test-with-runner
  65. test-match-nth test-match-all test-match-any test-match-name
  66. test-skip test-expect-fail test-read-eval-string
  67. test-runner-group-path test-group test-group-with-cleanup
  68. test-result-ref test-result-set! test-result-clear test-result-remove
  69. test-result-kind test-passed?
  70. test-log-to-file
  71. ; Misc test-runner functions
  72. test-runner? test-runner-reset test-runner-null
  73. test-runner-simple test-runner-current test-runner-factory test-runner-get
  74. test-runner-create test-runner-test-name
  75. ;; test-runner field setter and getter functions - see %test-record-define:
  76. test-runner-pass-count test-runner-pass-count!
  77. test-runner-fail-count test-runner-fail-count!
  78. test-runner-xpass-count test-runner-xpass-count!
  79. test-runner-xfail-count test-runner-xfail-count!
  80. test-runner-skip-count test-runner-skip-count!
  81. test-runner-group-stack test-runner-group-stack!
  82. test-runner-on-test-begin test-runner-on-test-begin!
  83. test-runner-on-test-end test-runner-on-test-end!
  84. test-runner-on-group-begin test-runner-on-group-begin!
  85. test-runner-on-group-end test-runner-on-group-end!
  86. test-runner-on-final test-runner-on-final!
  87. test-runner-on-bad-count test-runner-on-bad-count!
  88. test-runner-on-bad-end-name test-runner-on-bad-end-name!
  89. test-result-alist test-result-alist!
  90. test-runner-aux-value test-runner-aux-value!
  91. ;; default/simple call-back functions, used in default test-runner,
  92. ;; but can be called to construct more complex ones.
  93. test-on-group-begin-simple test-on-group-end-simple
  94. test-on-bad-count-simple test-on-bad-end-name-simple
  95. test-on-final-simple test-on-test-end-simple
  96. test-on-final-simple)
  97. (cond-expand
  98. (srfi-9
  99. (define-syntax %test-record-define
  100. (syntax-rules ()
  101. ((%test-record-define alloc runner? (name index setter getter) ...)
  102. (define-record-type test-runner
  103. (alloc)
  104. runner?
  105. (name setter getter) ...)))))
  106. (else
  107. (define %test-runner-cookie (list "test-runner"))
  108. (define-syntax %test-record-define
  109. (syntax-rules ()
  110. ((%test-record-define alloc runner? (name index getter setter) ...)
  111. (begin
  112. (define (runner? obj)
  113. (and (vector? obj)
  114. (> (vector-length obj) 1)
  115. (eq (vector-ref obj 0) %test-runner-cookie)))
  116. (define (alloc)
  117. (let ((runner (make-vector 23)))
  118. (vector-set! runner 0 %test-runner-cookie)
  119. runner))
  120. (begin
  121. (define (getter runner)
  122. (vector-ref runner index)) ...)
  123. (begin
  124. (define (setter runner value)
  125. (vector-set! runner index value)) ...)))))))
  126. (%test-record-define
  127. %test-runner-alloc test-runner?
  128. ;; Cumulate count of all tests that have passed and were expected to.
  129. (pass-count 1 test-runner-pass-count test-runner-pass-count!)
  130. (fail-count 2 test-runner-fail-count test-runner-fail-count!)
  131. (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!)
  132. (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!)
  133. (skip-count 5 test-runner-skip-count test-runner-skip-count!)
  134. (skip-list 6 %test-runner-skip-list %test-runner-skip-list!)
  135. (fail-list 7 %test-runner-fail-list %test-runner-fail-list!)
  136. ;; Normally #t, except when in a test-apply.
  137. (run-list 8 %test-runner-run-list %test-runner-run-list!)
  138. (skip-save 9 %test-runner-skip-save %test-runner-skip-save!)
  139. (fail-save 10 %test-runner-fail-save %test-runner-fail-save!)
  140. (group-stack 11 test-runner-group-stack test-runner-group-stack!)
  141. (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!)
  142. (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!)
  143. ;; Call-back when entering a group. Takes (runner suite-name count).
  144. (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!)
  145. ;; Call-back when leaving a group.
  146. (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!)
  147. ;; Call-back when leaving the outermost group.
  148. (on-final 16 test-runner-on-final test-runner-on-final!)
  149. ;; Call-back when expected number of tests was wrong.
  150. (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!)
  151. ;; Call-back when name in test=end doesn't match test-begin.
  152. (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!)
  153. ;; Cumulate count of all tests that have been done.
  154. (total-count 19 %test-runner-total-count %test-runner-total-count!)
  155. ;; Stack (list) of (count-at-start . expected-count):
  156. (count-list 20 %test-runner-count-list %test-runner-count-list!)
  157. (result-alist 21 test-result-alist test-result-alist!)
  158. ;; Field can be used by test-runner for any purpose.
  159. ;; test-runner-simple uses it for a log file.
  160. (aux-value 22 test-runner-aux-value test-runner-aux-value!)
  161. )
  162. (define (test-runner-reset runner)
  163. (test-result-alist! runner '())
  164. (test-runner-pass-count! runner 0)
  165. (test-runner-fail-count! runner 0)
  166. (test-runner-xpass-count! runner 0)
  167. (test-runner-xfail-count! runner 0)
  168. (test-runner-skip-count! runner 0)
  169. (%test-runner-total-count! runner 0)
  170. (%test-runner-count-list! runner '())
  171. (%test-runner-run-list! runner #t)
  172. (%test-runner-skip-list! runner '())
  173. (%test-runner-fail-list! runner '())
  174. (%test-runner-skip-save! runner '())
  175. (%test-runner-fail-save! runner '())
  176. (test-runner-group-stack! runner '()))
  177. (define (test-runner-group-path runner)
  178. (reverse (test-runner-group-stack runner)))
  179. (define (%test-null-callback runner) #f)
  180. (define (test-runner-null)
  181. (let ((runner (%test-runner-alloc)))
  182. (test-runner-reset runner)
  183. (test-runner-on-group-begin! runner (lambda (runner name count) #f))
  184. (test-runner-on-group-end! runner %test-null-callback)
  185. (test-runner-on-final! runner %test-null-callback)
  186. (test-runner-on-test-begin! runner %test-null-callback)
  187. (test-runner-on-test-end! runner %test-null-callback)
  188. (test-runner-on-bad-count! runner (lambda (runner count expected) #f))
  189. (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f))
  190. runner))
  191. ;; Not part of the specification. FIXME
  192. ;; Controls whether a log file is generated.
  193. (define test-log-to-file #t)
  194. (define (test-runner-simple)
  195. (let ((runner (%test-runner-alloc)))
  196. (test-runner-reset runner)
  197. (test-runner-on-group-begin! runner test-on-group-begin-simple)
  198. (test-runner-on-group-end! runner test-on-group-end-simple)
  199. (test-runner-on-final! runner test-on-final-simple)
  200. (test-runner-on-test-begin! runner test-on-test-begin-simple)
  201. (test-runner-on-test-end! runner test-on-test-end-simple)
  202. (test-runner-on-bad-count! runner test-on-bad-count-simple)
  203. (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
  204. runner))
  205. (cond-expand
  206. (srfi-39
  207. (define test-runner-current (make-parameter #f))
  208. (define test-runner-factory (make-parameter test-runner-simple)))
  209. (else
  210. (define %test-runner-current #f)
  211. (define-syntax test-runner-current
  212. (syntax-rules ()
  213. ((test-runner-current)
  214. %test-runner-current)
  215. ((test-runner-current runner)
  216. (set! %test-runner-current runner))))
  217. (define %test-runner-factory test-runner-simple)
  218. (define-syntax test-runner-factory
  219. (syntax-rules ()
  220. ((test-runner-factory)
  221. %test-runner-factory)
  222. ((test-runner-factory runner)
  223. (set! %test-runner-factory runner))))))
  224. ;; A safer wrapper to test-runner-current.
  225. (define (test-runner-get)
  226. (let ((r (test-runner-current)))
  227. (if (not r)
  228. (cond-expand
  229. (srfi-23 (error "test-runner not initialized - test-begin missing?"))
  230. (else #t)))
  231. r))
  232. (define (%test-specifier-matches spec runner)
  233. (spec runner))
  234. (define (test-runner-create)
  235. ((test-runner-factory)))
  236. (define (%test-any-specifier-matches list runner)
  237. (let ((result #f))
  238. (let loop ((l list))
  239. (cond ((null? l) result)
  240. (else
  241. (if (%test-specifier-matches (car l) runner)
  242. (set! result #t))
  243. (loop (cdr l)))))))
  244. ;; Returns #f, #t, or 'xfail.
  245. (define (%test-should-execute runner)
  246. (let ((run (%test-runner-run-list runner)))
  247. (cond ((or
  248. (not (or (eqv? run #t)
  249. (%test-any-specifier-matches run runner)))
  250. (%test-any-specifier-matches
  251. (%test-runner-skip-list runner)
  252. runner))
  253. (test-result-set! runner 'result-kind 'skip)
  254. #f)
  255. ((%test-any-specifier-matches
  256. (%test-runner-fail-list runner)
  257. runner)
  258. (test-result-set! runner 'result-kind 'xfail)
  259. 'xfail)
  260. (else #t))))
  261. (define (%test-begin suite-name count)
  262. (if (not (test-runner-current))
  263. (test-runner-current (test-runner-create)))
  264. (let ((runner (test-runner-current)))
  265. ((test-runner-on-group-begin runner) runner suite-name count)
  266. (%test-runner-skip-save! runner
  267. (cons (%test-runner-skip-list runner)
  268. (%test-runner-skip-save runner)))
  269. (%test-runner-fail-save! runner
  270. (cons (%test-runner-fail-list runner)
  271. (%test-runner-fail-save runner)))
  272. (%test-runner-count-list! runner
  273. (cons (cons (%test-runner-total-count runner)
  274. count)
  275. (%test-runner-count-list runner)))
  276. (test-runner-group-stack! runner (cons suite-name
  277. (test-runner-group-stack runner)))))
  278. (cond-expand
  279. (kawa
  280. ;; Kawa has test-begin built in, implemented as:
  281. ;; (begin
  282. ;; (cond-expand (srfi-64 #!void) (else (require 'srfi-64)))
  283. ;; (%test-begin suite-name [count]))
  284. ;; This puts test-begin but only test-begin in the default environment.,
  285. ;; which makes normal test suites loadable without non-portable commands.
  286. )
  287. (else
  288. (define-syntax test-begin
  289. (syntax-rules ()
  290. ((test-begin suite-name)
  291. (%test-begin suite-name #f))
  292. ((test-begin suite-name count)
  293. (%test-begin suite-name count))))))
  294. (define (test-on-group-begin-simple runner suite-name count)
  295. (if (null? (test-runner-group-stack runner))
  296. (begin
  297. (display "%%%% Starting test ")
  298. (display suite-name)
  299. (if test-log-to-file
  300. (let* ((log-file-name
  301. (if (string? test-log-to-file) test-log-to-file
  302. (string-append suite-name ".log")))
  303. (log-file
  304. (cond-expand (mzscheme
  305. (open-output-file log-file-name 'truncate/replace))
  306. (else (open-output-file log-file-name)))))
  307. (display "%%%% Starting test " log-file)
  308. (display suite-name log-file)
  309. (newline log-file)
  310. (test-runner-aux-value! runner log-file)
  311. (display " (Writing full log to \"")
  312. (display log-file-name)
  313. (display "\")")))
  314. (newline)))
  315. (let ((log (test-runner-aux-value runner)))
  316. (if (output-port? log)
  317. (begin
  318. (display "Group begin: " log)
  319. (display suite-name log)
  320. (newline log))))
  321. #f)
  322. (define (test-on-group-end-simple runner)
  323. (let ((log (test-runner-aux-value runner)))
  324. (if (output-port? log)
  325. (begin
  326. (display "Group end: " log)
  327. (display (car (test-runner-group-stack runner)) log)
  328. (newline log))))
  329. #f)
  330. (define (%test-on-bad-count-write runner count expected-count port)
  331. (display "*** Total number of tests was " port)
  332. (display count port)
  333. (display " but should be " port)
  334. (display expected-count port)
  335. (display ". ***" port)
  336. (newline port)
  337. (display "*** Discrepancy indicates testsuite error or exceptions. ***" port)
  338. (newline port))
  339. (define (test-on-bad-count-simple runner count expected-count)
  340. (%test-on-bad-count-write runner count expected-count (current-output-port))
  341. (let ((log (test-runner-aux-value runner)))
  342. (if (output-port? log)
  343. (%test-on-bad-count-write runner count expected-count log))))
  344. (define (test-on-bad-end-name-simple runner begin-name end-name)
  345. (let ((msg (string-append (%test-format-line runner) "test-end " begin-name
  346. " does not match test-begin " end-name)))
  347. (cond-expand
  348. (srfi-23 (error msg))
  349. (else (display msg) (newline)))))
  350. (define (%test-final-report1 value label port)
  351. (if (> value 0)
  352. (begin
  353. (display label port)
  354. (display value port)
  355. (newline port))))
  356. (define (%test-final-report-simple runner port)
  357. (%test-final-report1 (test-runner-pass-count runner)
  358. "# of expected passes " port)
  359. (%test-final-report1 (test-runner-xfail-count runner)
  360. "# of expected failures " port)
  361. (%test-final-report1 (test-runner-xpass-count runner)
  362. "# of unexpected successes " port)
  363. (%test-final-report1 (test-runner-fail-count runner)
  364. "# of unexpected failures " port)
  365. (%test-final-report1 (test-runner-skip-count runner)
  366. "# of skipped tests " port))
  367. (define (test-on-final-simple runner)
  368. (%test-final-report-simple runner (current-output-port))
  369. (let ((log (test-runner-aux-value runner)))
  370. (if (output-port? log)
  371. (%test-final-report-simple runner log))))
  372. (define (%test-format-line runner)
  373. (let* ((line-info (test-result-alist runner))
  374. (source-file (assq 'source-file line-info))
  375. (source-line (assq 'source-line line-info))
  376. (file (if source-file (cdr source-file) "")))
  377. (if source-line
  378. (string-append file ":"
  379. (number->string (cdr source-line)) ": ")
  380. "")))
  381. (define (%test-end suite-name line-info)
  382. (let* ((r (test-runner-get))
  383. (groups (test-runner-group-stack r))
  384. (line (%test-format-line r)))
  385. (test-result-alist! r line-info)
  386. (if (null? groups)
  387. (let ((msg (string-append line "test-end not in a group")))
  388. (cond-expand
  389. (srfi-23 (error msg))
  390. (else (display msg) (newline)))))
  391. (if (and suite-name (not (equal? suite-name (car groups))))
  392. ((test-runner-on-bad-end-name r) r suite-name (car groups)))
  393. (let* ((count-list (%test-runner-count-list r))
  394. (expected-count (cdar count-list))
  395. (saved-count (caar count-list))
  396. (group-count (- (%test-runner-total-count r) saved-count)))
  397. (if (and expected-count
  398. (not (= expected-count group-count)))
  399. ((test-runner-on-bad-count r) r group-count expected-count))
  400. ((test-runner-on-group-end r) r)
  401. (test-runner-group-stack! r (cdr (test-runner-group-stack r)))
  402. (%test-runner-skip-list! r (car (%test-runner-skip-save r)))
  403. (%test-runner-skip-save! r (cdr (%test-runner-skip-save r)))
  404. (%test-runner-fail-list! r (car (%test-runner-fail-save r)))
  405. (%test-runner-fail-save! r (cdr (%test-runner-fail-save r)))
  406. (%test-runner-count-list! r (cdr count-list))
  407. (if (null? (test-runner-group-stack r))
  408. ((test-runner-on-final r) r)))))
  409. (define-syntax test-group
  410. (syntax-rules ()
  411. ((test-group suite-name . body)
  412. (let ((r (test-runner-current)))
  413. ;; Ideally should also set line-number, if available.
  414. (test-result-alist! r (list (cons 'test-name suite-name)))
  415. (if (%test-should-execute r)
  416. (dynamic-wind
  417. (lambda () (test-begin suite-name))
  418. (lambda () . body)
  419. (lambda () (test-end suite-name))))))))
  420. (define-syntax test-group-with-cleanup
  421. (syntax-rules ()
  422. ((test-group-with-cleanup suite-name form cleanup-form)
  423. (test-group suite-name
  424. (dynamic-wind
  425. (lambda () #f)
  426. (lambda () form)
  427. (lambda () cleanup-form))))
  428. ((test-group-with-cleanup suite-name cleanup-form)
  429. (test-group-with-cleanup suite-name #f cleanup-form))
  430. ((test-group-with-cleanup suite-name form1 form2 form3 . rest)
  431. (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest))))
  432. (define (test-on-test-begin-simple runner)
  433. (let ((log (test-runner-aux-value runner)))
  434. (if (output-port? log)
  435. (let* ((results (test-result-alist runner))
  436. (source-file (assq 'source-file results))
  437. (source-line (assq 'source-line results))
  438. (source-form (assq 'source-form results))
  439. (test-name (assq 'test-name results)))
  440. (display "Test begin:" log)
  441. (newline log)
  442. (if test-name (%test-write-result1 test-name log))
  443. (if source-file (%test-write-result1 source-file log))
  444. (if source-line (%test-write-result1 source-line log))
  445. (if source-form (%test-write-result1 source-form log))))))
  446. (define-syntax test-result-ref
  447. (syntax-rules ()
  448. ((test-result-ref runner pname)
  449. (test-result-ref runner pname #f))
  450. ((test-result-ref runner pname default)
  451. (let ((p (assq pname (test-result-alist runner))))
  452. (if p (cdr p) default)))))
  453. (define (test-on-test-end-simple runner)
  454. (let ((log (test-runner-aux-value runner))
  455. (kind (test-result-ref runner 'result-kind)))
  456. (if (memq kind '(fail xpass))
  457. (let* ((results (test-result-alist runner))
  458. (source-file (assq 'source-file results))
  459. (source-line (assq 'source-line results))
  460. (test-name (assq 'test-name results)))
  461. (if (or source-file source-line)
  462. (begin
  463. (if source-file (display (cdr source-file)))
  464. (display ":")
  465. (if source-line (display (cdr source-line)))
  466. (display ": ")))
  467. (display (if (eq? kind 'xpass) "XPASS" "FAIL"))
  468. (if test-name
  469. (begin
  470. (display " ")
  471. (display (cdr test-name))))
  472. (newline)))
  473. (if (output-port? log)
  474. (begin
  475. (display "Test end:" log)
  476. (newline log)
  477. (let loop ((list (test-result-alist runner)))
  478. (if (pair? list)
  479. (let ((pair (car list)))
  480. ;; Write out properties not written out by on-test-begin.
  481. (if (not (memq (car pair)
  482. '(test-name source-file source-line source-form)))
  483. (%test-write-result1 pair log))
  484. (loop (cdr list)))))))))
  485. (define (%test-write-result1 pair port)
  486. (display " " port)
  487. (display (car pair) port)
  488. (display ": " port)
  489. (write (cdr pair) port)
  490. (newline port))
  491. (define (test-result-set! runner pname value)
  492. (let* ((alist (test-result-alist runner))
  493. (p (assq pname alist)))
  494. (if p
  495. (set-cdr! p value)
  496. (test-result-alist! runner (cons (cons pname value) alist)))))
  497. (define (test-result-clear runner)
  498. (test-result-alist! runner '()))
  499. (define (test-result-remove runner pname)
  500. (let* ((alist (test-result-alist runner))
  501. (p (assq pname alist)))
  502. (if p
  503. (test-result-alist! runner
  504. (let loop ((r alist))
  505. (if (eq? r p) (cdr r)
  506. (cons (car r) (loop (cdr r)))))))))
  507. (define (test-result-kind . rest)
  508. (let ((runner (if (pair? rest) (car rest) (test-runner-current))))
  509. (test-result-ref runner 'result-kind)))
  510. (define (test-passed? . rest)
  511. (let ((runner (if (pair? rest) (car rest) (test-runner-get))))
  512. (memq (test-result-ref runner 'result-kind) '(pass xpass))))
  513. (define (%test-report-result)
  514. (let* ((r (test-runner-get))
  515. (result-kind (test-result-kind r)))
  516. (case result-kind
  517. ((pass)
  518. (test-runner-pass-count! r (+ 1 (test-runner-pass-count r))))
  519. ((fail)
  520. (test-runner-fail-count! r (+ 1 (test-runner-fail-count r))))
  521. ((xpass)
  522. (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r))))
  523. ((xfail)
  524. (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r))))
  525. (else
  526. (test-runner-skip-count! r (+ 1 (test-runner-skip-count r)))))
  527. (%test-runner-total-count! r (+ 1 (%test-runner-total-count r)))
  528. ((test-runner-on-test-end r) r)))
  529. (cond-expand
  530. (guile
  531. (define-syntax %test-evaluate-with-catch
  532. (syntax-rules ()
  533. ((%test-evaluate-with-catch test-expression)
  534. (catch #t
  535. (lambda () test-expression)
  536. (lambda (key . args)
  537. (test-result-set! (test-runner-current) 'actual-error
  538. (cons key args))
  539. #f))))))
  540. (kawa
  541. (define-syntax %test-evaluate-with-catch
  542. (syntax-rules ()
  543. ((%test-evaluate-with-catch test-expression)
  544. (try-catch test-expression
  545. (ex <java.lang.Throwable>
  546. (test-result-set! (test-runner-current) 'actual-error ex)
  547. #f))))))
  548. (srfi-34
  549. (define-syntax %test-evaluate-with-catch
  550. (syntax-rules ()
  551. ((%test-evaluate-with-catch test-expression)
  552. (guard (err (else #f)) test-expression)))))
  553. (chicken
  554. (define-syntax %test-evaluate-with-catch
  555. (syntax-rules ()
  556. ((%test-evaluate-with-catch test-expression)
  557. (condition-case test-expression (ex () #f))))))
  558. (else
  559. (define-syntax %test-evaluate-with-catch
  560. (syntax-rules ()
  561. ((%test-evaluate-with-catch test-expression)
  562. test-expression)))))
  563. (cond-expand
  564. ((or kawa mzscheme)
  565. (cond-expand
  566. (mzscheme
  567. (define-for-syntax (%test-syntax-file form)
  568. (let ((source (syntax-source form)))
  569. (cond ((string? source) file)
  570. ((path? source) (path->string source))
  571. (else #f)))))
  572. (kawa
  573. (define (%test-syntax-file form)
  574. (syntax-source form))))
  575. (define (%test-source-line2 form)
  576. (let* ((line (syntax-line form))
  577. (file (%test-syntax-file form))
  578. (line-pair (if line (list (cons 'source-line line)) '())))
  579. (cons (cons 'source-form (syntax-object->datum form))
  580. (if file (cons (cons 'source-file file) line-pair) line-pair)))))
  581. (guile-2
  582. (define (%test-source-line2 form)
  583. (let* ((src-props (syntax-source form))
  584. (file (and src-props (assq-ref src-props 'filename)))
  585. (line (and src-props (assq-ref src-props 'line)))
  586. (file-alist (if file
  587. `((source-file . ,file))
  588. '()))
  589. (line-alist (if line
  590. `((source-line . ,(+ line 1)))
  591. '())))
  592. (datum->syntax (syntax here)
  593. `((source-form . ,(syntax->datum form))
  594. ,@file-alist
  595. ,@line-alist)))))
  596. (else
  597. (define (%test-source-line2 form)
  598. '())))
  599. (define (%test-on-test-begin r)
  600. (%test-should-execute r)
  601. ((test-runner-on-test-begin r) r)
  602. (not (eq? 'skip (test-result-ref r 'result-kind))))
  603. (define (%test-on-test-end r result)
  604. (test-result-set! r 'result-kind
  605. (if (eq? (test-result-ref r 'result-kind) 'xfail)
  606. (if result 'xpass 'xfail)
  607. (if result 'pass 'fail))))
  608. (define (test-runner-test-name runner)
  609. (test-result-ref runner 'test-name ""))
  610. (define-syntax %test-comp2body
  611. (syntax-rules ()
  612. ((%test-comp2body r comp expected expr)
  613. (let ()
  614. (if (%test-on-test-begin r)
  615. (let ((exp expected))
  616. (test-result-set! r 'expected-value exp)
  617. (let ((res (%test-evaluate-with-catch expr)))
  618. (test-result-set! r 'actual-value res)
  619. (%test-on-test-end r (comp exp res)))))
  620. (%test-report-result)))))
  621. (define (%test-approximate= error)
  622. (lambda (value expected)
  623. (let ((rval (real-part value))
  624. (ival (imag-part value))
  625. (rexp (real-part expected))
  626. (iexp (imag-part expected)))
  627. (and (>= rval (- rexp error))
  628. (>= ival (- iexp error))
  629. (<= rval (+ rexp error))
  630. (<= ival (+ iexp error))))))
  631. (define-syntax %test-comp1body
  632. (syntax-rules ()
  633. ((%test-comp1body r expr)
  634. (let ()
  635. (if (%test-on-test-begin r)
  636. (let ()
  637. (let ((res (%test-evaluate-with-catch expr)))
  638. (test-result-set! r 'actual-value res)
  639. (%test-on-test-end r res))))
  640. (%test-report-result)))))
  641. (cond-expand
  642. ((or kawa mzscheme guile-2)
  643. ;; Should be made to work for any Scheme with syntax-case
  644. ;; However, I haven't gotten the quoting working. FIXME.
  645. (define-syntax test-end
  646. (lambda (x)
  647. (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
  648. (((mac suite-name) line)
  649. (syntax
  650. (%test-end suite-name line)))
  651. (((mac) line)
  652. (syntax
  653. (%test-end #f line))))))
  654. (define-syntax test-assert
  655. (lambda (x)
  656. (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
  657. (((mac tname expr) line)
  658. (syntax
  659. (let* ((r (test-runner-get))
  660. (name tname))
  661. (test-result-alist! r (cons (cons 'test-name tname) line))
  662. (%test-comp1body r expr))))
  663. (((mac expr) line)
  664. (syntax
  665. (let* ((r (test-runner-get)))
  666. (test-result-alist! r line)
  667. (%test-comp1body r expr)))))))
  668. (define (%test-comp2 comp x)
  669. (syntax-case (list x (list (syntax quote) (%test-source-line2 x)) comp) ()
  670. (((mac tname expected expr) line comp)
  671. (syntax
  672. (let* ((r (test-runner-get))
  673. (name tname))
  674. (test-result-alist! r (cons (cons 'test-name tname) line))
  675. (%test-comp2body r comp expected expr))))
  676. (((mac expected expr) line comp)
  677. (syntax
  678. (let* ((r (test-runner-get)))
  679. (test-result-alist! r line)
  680. (%test-comp2body r comp expected expr))))))
  681. (define-syntax test-eqv
  682. (lambda (x) (%test-comp2 (syntax eqv?) x)))
  683. (define-syntax test-eq
  684. (lambda (x) (%test-comp2 (syntax eq?) x)))
  685. (define-syntax test-equal
  686. (lambda (x) (%test-comp2 (syntax equal?) x)))
  687. (define-syntax test-approximate ;; FIXME - needed for non-Kawa
  688. (lambda (x)
  689. (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
  690. (((mac tname expected expr error) line)
  691. (syntax
  692. (let* ((r (test-runner-get))
  693. (name tname))
  694. (test-result-alist! r (cons (cons 'test-name tname) line))
  695. (%test-comp2body r (%test-approximate= error) expected expr))))
  696. (((mac expected expr error) line)
  697. (syntax
  698. (let* ((r (test-runner-get)))
  699. (test-result-alist! r line)
  700. (%test-comp2body r (%test-approximate= error) expected expr))))))))
  701. (else
  702. (define-syntax test-end
  703. (syntax-rules ()
  704. ((test-end)
  705. (%test-end #f '()))
  706. ((test-end suite-name)
  707. (%test-end suite-name '()))))
  708. (define-syntax test-assert
  709. (syntax-rules ()
  710. ((test-assert tname test-expression)
  711. (let* ((r (test-runner-get))
  712. (name tname))
  713. (test-result-alist! r '((test-name . tname)))
  714. (%test-comp1body r test-expression)))
  715. ((test-assert test-expression)
  716. (let* ((r (test-runner-get)))
  717. (test-result-alist! r '())
  718. (%test-comp1body r test-expression)))))
  719. (define-syntax %test-comp2
  720. (syntax-rules ()
  721. ((%test-comp2 comp tname expected expr)
  722. (let* ((r (test-runner-get))
  723. (name tname))
  724. (test-result-alist! r (list (cons 'test-name tname)))
  725. (%test-comp2body r comp expected expr)))
  726. ((%test-comp2 comp expected expr)
  727. (let* ((r (test-runner-get)))
  728. (test-result-alist! r '())
  729. (%test-comp2body r comp expected expr)))))
  730. (define-syntax test-equal
  731. (syntax-rules ()
  732. ((test-equal . rest)
  733. (%test-comp2 equal? . rest))))
  734. (define-syntax test-eqv
  735. (syntax-rules ()
  736. ((test-eqv . rest)
  737. (%test-comp2 eqv? . rest))))
  738. (define-syntax test-eq
  739. (syntax-rules ()
  740. ((test-eq . rest)
  741. (%test-comp2 eq? . rest))))
  742. (define-syntax test-approximate
  743. (syntax-rules ()
  744. ((test-approximate tname expected expr error)
  745. (%test-comp2 (%test-approximate= error) tname expected expr))
  746. ((test-approximate expected expr error)
  747. (%test-comp2 (%test-approximate= error) expected expr))))))
  748. (cond-expand
  749. (guile
  750. (define-syntax %test-error
  751. (syntax-rules ()
  752. ((%test-error r etype expr)
  753. (cond ((%test-on-test-begin r)
  754. (let ((et etype))
  755. (test-result-set! r 'expected-error et)
  756. (%test-on-test-end r
  757. (catch #t
  758. (lambda ()
  759. (test-result-set! r 'actual-value expr)
  760. #f)
  761. (lambda (key . args)
  762. ;; TODO: decide how to specify expected
  763. ;; error types for Guile.
  764. (test-result-set! r 'actual-error
  765. (cons key args))
  766. #t)))
  767. (%test-report-result))))))))
  768. (mzscheme
  769. (define-syntax %test-error
  770. (syntax-rules ()
  771. ((%test-error r etype expr)
  772. (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t)))
  773. (let ()
  774. (test-result-set! r 'actual-value expr)
  775. #f)))))))
  776. (chicken
  777. (define-syntax %test-error
  778. (syntax-rules ()
  779. ((%test-error r etype expr)
  780. (%test-comp1body r (condition-case expr (ex () #t)))))))
  781. (kawa
  782. (define-syntax %test-error
  783. (syntax-rules ()
  784. ((%test-error r #t expr)
  785. (cond ((%test-on-test-begin r)
  786. (test-result-set! r 'expected-error #t)
  787. (%test-on-test-end r
  788. (try-catch
  789. (let ()
  790. (test-result-set! r 'actual-value expr)
  791. #f)
  792. (ex <java.lang.Throwable>
  793. (test-result-set! r 'actual-error ex)
  794. #t)))
  795. (%test-report-result))))
  796. ((%test-error r etype expr)
  797. (if (%test-on-test-begin r)
  798. (let ((et etype))
  799. (test-result-set! r 'expected-error et)
  800. (%test-on-test-end r
  801. (try-catch
  802. (let ()
  803. (test-result-set! r 'actual-value expr)
  804. #f)
  805. (ex <java.lang.Throwable>
  806. (test-result-set! r 'actual-error ex)
  807. (cond ((and (instance? et <gnu.bytecode.ClassType>)
  808. (gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>))
  809. (instance? ex et))
  810. (else #t)))))
  811. (%test-report-result)))))))
  812. ((and srfi-34 srfi-35)
  813. (define-syntax %test-error
  814. (syntax-rules ()
  815. ((%test-error r etype expr)
  816. (%test-comp1body r (guard (ex ((condition-type? etype)
  817. (and (condition? ex) (condition-has-type? ex etype)))
  818. ((procedure? etype)
  819. (etype ex))
  820. ((equal? etype #t)
  821. #t)
  822. (else #t))
  823. expr #f))))))
  824. (srfi-34
  825. (define-syntax %test-error
  826. (syntax-rules ()
  827. ((%test-error r etype expr)
  828. (%test-comp1body r (guard (ex (else #t)) expr #f))))))
  829. (else
  830. (define-syntax %test-error
  831. (syntax-rules ()
  832. ((%test-error r etype expr)
  833. (begin
  834. ((test-runner-on-test-begin r) r)
  835. (test-result-set! r 'result-kind 'skip)
  836. (%test-report-result)))))))
  837. (cond-expand
  838. ((or kawa mzscheme guile-2)
  839. (define-syntax test-error
  840. (lambda (x)
  841. (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
  842. (((mac tname etype expr) line)
  843. (syntax
  844. (let* ((r (test-runner-get))
  845. (name tname))
  846. (test-result-alist! r (cons (cons 'test-name tname) line))
  847. (%test-error r etype expr))))
  848. (((mac etype expr) line)
  849. (syntax
  850. (let* ((r (test-runner-get)))
  851. (test-result-alist! r line)
  852. (%test-error r etype expr))))
  853. (((mac expr) line)
  854. (syntax
  855. (let* ((r (test-runner-get)))
  856. (test-result-alist! r line)
  857. (%test-error r #t expr))))))))
  858. (else
  859. (define-syntax test-error
  860. (syntax-rules ()
  861. ((test-error name etype expr)
  862. (let ((r (test-runner-get)))
  863. (test-result-alist! r `((test-name . ,name)))
  864. (%test-error r etype expr)))
  865. ((test-error etype expr)
  866. (let ((r (test-runner-get)))
  867. (test-result-alist! r '())
  868. (%test-error r etype expr)))
  869. ((test-error expr)
  870. (let ((r (test-runner-get)))
  871. (test-result-alist! r '())
  872. (%test-error r #t expr)))))))
  873. (define (test-apply first . rest)
  874. (if (test-runner? first)
  875. (test-with-runner first (apply test-apply rest))
  876. (let ((r (test-runner-current)))
  877. (if r
  878. (let ((run-list (%test-runner-run-list r)))
  879. (cond ((null? rest)
  880. (%test-runner-run-list! r (reverse run-list))
  881. (first)) ;; actually apply procedure thunk
  882. (else
  883. (%test-runner-run-list!
  884. r
  885. (if (eq? run-list #t) (list first) (cons first run-list)))
  886. (apply test-apply rest)
  887. (%test-runner-run-list! r run-list))))
  888. (let ((r (test-runner-create)))
  889. (test-with-runner r (apply test-apply first rest))
  890. ((test-runner-on-final r) r))))))
  891. (define-syntax test-with-runner
  892. (syntax-rules ()
  893. ((test-with-runner runner form ...)
  894. (let ((saved-runner (test-runner-current)))
  895. (dynamic-wind
  896. (lambda () (test-runner-current runner))
  897. (lambda () form ...)
  898. (lambda () (test-runner-current saved-runner)))))))
  899. ;;; Predicates
  900. (define (%test-match-nth n count)
  901. (let ((i 0))
  902. (lambda (runner)
  903. (set! i (+ i 1))
  904. (and (>= i n) (< i (+ n count))))))
  905. (define-syntax test-match-nth
  906. (syntax-rules ()
  907. ((test-match-nth n)
  908. (test-match-nth n 1))
  909. ((test-match-nth n count)
  910. (%test-match-nth n count))))
  911. (define (%test-match-all . pred-list)
  912. (lambda (runner)
  913. (let ((result #t))
  914. (let loop ((l pred-list))
  915. (if (null? l)
  916. result
  917. (begin
  918. (if (not ((car l) runner))
  919. (set! result #f))
  920. (loop (cdr l))))))))
  921. (define-syntax test-match-all
  922. (syntax-rules ()
  923. ((test-match-all pred ...)
  924. (%test-match-all (%test-as-specifier pred) ...))))
  925. (define (%test-match-any . pred-list)
  926. (lambda (runner)
  927. (let ((result #f))
  928. (let loop ((l pred-list))
  929. (if (null? l)
  930. result
  931. (begin
  932. (if ((car l) runner)
  933. (set! result #t))
  934. (loop (cdr l))))))))
  935. (define-syntax test-match-any
  936. (syntax-rules ()
  937. ((test-match-any pred ...)
  938. (%test-match-any (%test-as-specifier pred) ...))))
  939. ;; Coerce to a predicate function:
  940. (define (%test-as-specifier specifier)
  941. (cond ((procedure? specifier) specifier)
  942. ((integer? specifier) (test-match-nth 1 specifier))
  943. ((string? specifier) (test-match-name specifier))
  944. (else
  945. (error "not a valid test specifier"))))
  946. (define-syntax test-skip
  947. (syntax-rules ()
  948. ((test-skip pred ...)
  949. (let ((runner (test-runner-get)))
  950. (%test-runner-skip-list! runner
  951. (cons (test-match-all (%test-as-specifier pred) ...)
  952. (%test-runner-skip-list runner)))))))
  953. (define-syntax test-expect-fail
  954. (syntax-rules ()
  955. ((test-expect-fail pred ...)
  956. (let ((runner (test-runner-get)))
  957. (%test-runner-fail-list! runner
  958. (cons (test-match-all (%test-as-specifier pred) ...)
  959. (%test-runner-fail-list runner)))))))
  960. (define (test-match-name name)
  961. (lambda (runner)
  962. (equal? name (test-runner-test-name runner))))
  963. (define (test-read-eval-string string)
  964. (let* ((port (open-input-string string))
  965. (form (read port)))
  966. (if (eof-object? (read-char port))
  967. (cond-expand
  968. (guile (eval form (current-module)))
  969. (else (eval form)))
  970. (cond-expand
  971. (srfi-23 (error "(not at eof)"))
  972. (else "error")))))