Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Fixed test-error, improved tests on srfi-2

  • Loading branch information...
commit 747b0f7918195aa6716e60e20ddf6df2c789ff8d 1 parent 4fdf4ea
Álvaro Castro-Castilla authored
Showing with 37 additions and 17 deletions.
  1. +18 −13 srfi/64.scm
  2. +4 −4 srfi/test-2.scm
  3. +15 −0 srfi/test-64.scm
View
31 srfi/64.scm
@@ -23,8 +23,6 @@
;;
;; Adapted to Blackhole for Gambit by Álvaro Castro-Castilla
-(import (std srfi/34))
-
;; List of exported names
(export
test-begin ;; must be listed first, since in Kawa (at least) it is "magic".
@@ -489,7 +487,11 @@
(define-syntax %test-evaluate-with-catch
(syntax-rules ()
((%test-evaluate-with-catch test-expression)
- (guard (err (else #f)) test-expression))))
+ (with-exception-catcher
+ (lambda (x) #f)
+ (lambda () test-expression)))))
+ ;(guard (err (else #f)) test-expression)))) ; implemented with exceptions to
+ ; avoid importing srfi-34
(define (%test-source-line2 form)
'())
@@ -586,26 +588,29 @@
(define-syntax %test-error
(syntax-rules ()
((%test-error r etype expr)
- (%test-comp1body r (guard (ex (else #t)) expr)))))
+ (%test-comp1body r (with-exception-catcher (lambda (x) #t)
+ (lambda () (begin expr #f)))))))
+ ;(%test-comp1body r (guard (ex (else #t)) expr))))) ; Original implementation
+ ; Implemented with exception-catcher to avoid srfi-34
(define-syntax test-error
(syntax-rules ()
((test-error name etype expr)
(let* ((r (test-runner-get))
(name tname))
- ;(test-result-alist! r (cons (cons 'test-name tname) '(TODO:LINE . 0)))
- (%test-error r etype expr)))
- ;(test-assert name (%test-error etype expr)))
+ ;(test-result-alist! r (cons (cons 'test-name tname) '(TODO:LINE . 0)))
+ (%test-error r etype expr)))
((test-error etype expr)
(let* ((r (test-runner-get)))
- ;(test-result-alist! r '(TODO:LINE . 0))
- (%test-error r etype expr)))
- ;(test-assert (%test-error etype expr)))
+ ;(test-result-alist! r '(TODO:LINE . 0))
+ (%test-error r etype expr)))
((test-error expr)
(let* ((r (test-runner-get)))
- ;(test-result-alist! r '(TODO:LINE . 0))
- (%test-error r #t expr)))))
- ;(test-assert (%test-error #t expr)))))
+ ;(test-result-alist! r '(TODO:LINE . 0))
+ (%test-error r #t expr)))))
+ ;(test-assert (%test-error etype expr)))
+ ; In the original version an additional assert was here to ensure it signals
+ ; an error, however, that was executing 2 tests instead of 1
(define (test-apply first . rest)
(if (test-runner? first)
View
8 srfi/test-2.scm
@@ -36,10 +36,10 @@
(test-equal (let ((x 3)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) 3/2)
;; Needs to use eval to expand macro in current environment (CHECK!)
-(test-error (eval '(and-let* ( #f (x 1))) (interaction-environment)))
-(test-error (eval '(and-let* (2 (x 1))) (interaction-environment)))
+(test-error (test-read-eval-string "(and-let* ( #f (x 1)))"))
+(test-error (test-read-eval-string "(and-let* (2 (x 1)))"))
(test-error
- (eval '(let ((x 1)) (and-let* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1)))
- (interaction-environment)))
+ (test-read-eval-string
+ "(let ((x 1)) (and-let* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1)))"))
(test-end "srfi-2")
View
15 srfi/test-64.scm
@@ -0,0 +1,15 @@
+(import ./64)
+
+(define my-simple-runner (test-runner-simple))
+(test-runner-factory
+ (lambda () my-simple-runner))
+
+(test-begin "simple-runner")
+
+(test-assert #t)
+(test-equal 0 0)
+(test-approximate 0.01 0.02 0.1)
+(test-error (error "error"))
+;(test-error #t) ; This is commented because it should fail!
+
+(test-end "simple-runner")
Please sign in to comment.
Something went wrong with that request. Please try again.