55 lines
2.0 KiB
Racket
55 lines
2.0 KiB
Racket
(module test-harness mzscheme
|
|
(require syntax/stx)
|
|
|
|
(provide (all-defined))
|
|
|
|
(define (lst-bound-id=? x y)
|
|
(andmap bound-identifier=? x y))
|
|
|
|
(define (stx-bound-id=? x y)
|
|
(cond
|
|
((and (stx-pair? x)
|
|
(not (syntax-e (stx-car x)))
|
|
(identifier? (stx-cdr x)))
|
|
(and (identifier? y)
|
|
(not (module-identifier=? (stx-cdr x) y))))
|
|
((and (stx-null? x) (stx-null? y))
|
|
#t)
|
|
((and (stx-pair? x) (stx-pair? y))
|
|
(and (stx-bound-id=? (stx-car x) (stx-car y))
|
|
(stx-bound-id=? (stx-cdr x) (stx-cdr y))))
|
|
((and (identifier? x) (identifier? y))
|
|
(bound-identifier=? x y))
|
|
((and (number? (syntax-e x)) (number? (syntax-e y)))
|
|
(= (syntax-e x) (syntax-e y)))
|
|
(else #f)))
|
|
|
|
(define-syntax test-syntax-error
|
|
(syntax-rules ()
|
|
((_ err expr)
|
|
(with-handlers ((exn:fail:syntax? (lambda (exn)
|
|
(printf "syntax error \"~a\"~n got message \"~a\"~n~n"
|
|
err
|
|
(exn-message exn)))))
|
|
(expand #'expr)
|
|
(error 'test-syntax-error "expected syntax error \"~a\" on ~a, got none" err 'expr)))))
|
|
|
|
(define-syntax test-runtime-error
|
|
(syntax-rules ()
|
|
((_ err-pred err expr)
|
|
(with-handlers ((err-pred (lambda (exn)
|
|
(printf "runtime error \"~a\"~n got message \"~a\"~n~n"
|
|
err
|
|
(exn-message exn)))))
|
|
expr
|
|
(error 'test-runtime-error "expected runtime error \"~a\" on ~a, got none" err 'expr)))))
|
|
|
|
(define-syntax test
|
|
(syntax-rules ()
|
|
((_ expected-value expr)
|
|
(test equal? expected-value expr))
|
|
((_ cmp expected-value expr)
|
|
(let ((v expr))
|
|
(unless (cmp expected-value v)
|
|
(error 'test "expected ~a to evaluate to ~a, got ~a" 'expr 'expected-value v)))))))
|