separate out the error location tests
also, Rackety
This commit is contained in:
Robby Findler
parent
34c5b32746
commit
4bcb44c442
170
pkgs/redex-pkgs/redex-test/redex/tests/err-loc-test.rkt
Normal file
170
pkgs/redex-pkgs/redex-test/redex/tests/err-loc-test.rkt
Normal file
|
|
@ -0,0 +1,170 @@
|
|||
#lang racket/base
|
||||
|
||||
(module util racket/base
|
||||
(require setup/path-to-relative
|
||||
racket/runtime-path
|
||||
"test-util.rkt"
|
||||
(for-syntax racket/base))
|
||||
(provide exec-syntax-error-tests
|
||||
exec-runtime-error-tests
|
||||
syn-err-test-namespace)
|
||||
|
||||
(define-runtime-path this-dir ".")
|
||||
|
||||
(define syn-err-test-namespace (make-base-namespace))
|
||||
(parameterize ([current-namespace syn-err-test-namespace])
|
||||
(eval '(require redex/reduction-semantics)))
|
||||
|
||||
(define (syntax-error-test-setup thunk)
|
||||
(parameterize ([current-namespace syn-err-test-namespace])
|
||||
(with-handlers ([exn:fail:syntax?
|
||||
(λ (exn)
|
||||
(values (exn-message exn)
|
||||
(map source-location (exn:fail:syntax-exprs exn))))])
|
||||
(thunk))))
|
||||
(define (runtime-error-test-setup thunk)
|
||||
(define errortrace-key (dynamic-require 'errortrace/errortrace-key 'errortrace-key))
|
||||
(parameterize ([current-compile ((dynamic-require 'errortrace/errortrace-lib
|
||||
'make-errortrace-compile-handler))])
|
||||
(with-handlers ([exn:fail?
|
||||
(λ (exn)
|
||||
(values (exn-message exn)
|
||||
(let ([ans (let ([marks (continuation-mark-set->list
|
||||
(exn-continuation-marks exn)
|
||||
errortrace-key)])
|
||||
(if (null? marks) '() (list (cdar marks))))])
|
||||
(let loop ([ans ans])
|
||||
(cond
|
||||
[(pair? ans) (cons (loop (car ans)) (loop (cdr ans)))]
|
||||
[(path? ans) (path->relative-string/library ans)]
|
||||
[else ans])))))])
|
||||
(thunk))))
|
||||
|
||||
(define ((exec-error-tests setup exec) path)
|
||||
(for ([test (read-tests (build-path this-dir path))])
|
||||
(exec-error-test test exec setup)))
|
||||
(define exec-syntax-error-tests
|
||||
(exec-error-tests syntax-error-test-setup expand))
|
||||
(define exec-runtime-error-tests
|
||||
(exec-error-tests runtime-error-test-setup eval))
|
||||
|
||||
(define (exec-error-test spec exec setup)
|
||||
(define-values (file line expected-message expected-sources test)
|
||||
(make-error-test spec))
|
||||
(let-values ([(actual-message actual-sources)
|
||||
(setup (λ () (begin (exec test) (values "" '()))))])
|
||||
(test/proc (λ () actual-message) expected-message line file)
|
||||
(test/proc (λ () actual-sources) expected-sources line file)))
|
||||
|
||||
(define (make-error-test spec)
|
||||
(syntax-case spec ()
|
||||
[(message named-pieces body)
|
||||
(make-error-test (syntax/loc spec (message named-pieces () body)))]
|
||||
[(message ([loc-name loc-piece] ...) ([non-loc-name non-loc-piece] ...) body)
|
||||
(values (and (path? (syntax-source spec))
|
||||
(path->relative-string/library (syntax-source spec)))
|
||||
(syntax-line spec)
|
||||
(syntax-e #'message)
|
||||
(map source-location (syntax->list #'(loc-piece ...)))
|
||||
#'(let-syntax ([subst
|
||||
(λ (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ loc-name ... non-loc-name ...)
|
||||
#'body]))])
|
||||
(subst loc-piece ... non-loc-piece ...)
|
||||
(void)))]))
|
||||
|
||||
(define (source-location stx)
|
||||
(list (and (path? (syntax-source stx))
|
||||
(path->relative-string/library (syntax-source stx)))
|
||||
(syntax-line stx)
|
||||
(syntax-column stx)
|
||||
(syntax-position stx)
|
||||
(syntax-span stx)))
|
||||
|
||||
(define (read-tests path)
|
||||
(call-with-input-file path
|
||||
(λ (port)
|
||||
(port-count-lines! port)
|
||||
(let loop ()
|
||||
(define test (read-syntax path port))
|
||||
(if (eof-object? test)
|
||||
'()
|
||||
(cons test (loop))))))))
|
||||
|
||||
(require "test-util.rkt"
|
||||
redex/reduction-semantics
|
||||
(for-syntax racket/base)
|
||||
'util)
|
||||
|
||||
(reset-count)
|
||||
|
||||
(parameterize ([current-namespace syn-err-test-namespace])
|
||||
(eval (quote-syntax
|
||||
(define-language syn-err-lang
|
||||
(M (M M)
|
||||
number)
|
||||
(E hole
|
||||
(E M)
|
||||
(number E))
|
||||
(X (number any)
|
||||
(any number))
|
||||
(Q (Q ...)
|
||||
variable)
|
||||
(UN (add1 UN)
|
||||
zero)))))
|
||||
|
||||
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(eval '(require redex/reduction-semantics redex/pict))
|
||||
(eval '(define-language L
|
||||
(s a b c)))
|
||||
(exec-runtime-error-tests "run-err-tests/define-union-language.rktd"))
|
||||
|
||||
(exec-syntax-error-tests "syn-err-tests/language-definition.rktd")
|
||||
|
||||
;; term with #:lang tests
|
||||
(exec-syntax-error-tests "syn-err-tests/term-lang.rktd")
|
||||
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(eval '(require redex/reduction-semantics))
|
||||
(exec-runtime-error-tests "run-err-tests/judgment-form-undefined.rktd"))
|
||||
|
||||
(exec-syntax-error-tests "syn-err-tests/metafunction-definition.rktd")
|
||||
|
||||
(exec-syntax-error-tests "syn-err-tests/relation-definition.rktd")
|
||||
|
||||
(exec-syntax-error-tests "syn-err-tests/reduction-relation-definition.rktd")
|
||||
|
||||
(exec-syntax-error-tests "syn-err-tests/redex-let.rktd")
|
||||
|
||||
(exec-syntax-error-tests "syn-err-tests/judgment-form-definition.rktd")
|
||||
(exec-syntax-error-tests "syn-err-tests/judgment-holds.rktd")
|
||||
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(eval '(require redex/reduction-semantics))
|
||||
(eval '(define-language L
|
||||
(s a b c)))
|
||||
(eval '(define-judgment-form L
|
||||
#:mode (ctc-fail I O)
|
||||
#:contract (ctc-fail s s)
|
||||
[(ctc-fail a q)]
|
||||
[(ctc-fail b s)
|
||||
(ctc-fail q s)]
|
||||
[(ctc-fail c s)
|
||||
(ctc-fail a s)]))
|
||||
(exec-runtime-error-tests "run-err-tests/judgment-form-contracts.rktd")
|
||||
(exec-runtime-error-tests "run-err-tests/judgment-form-undefined.rktd")
|
||||
(exec-runtime-error-tests "run-err-tests/judgment-form-ellipses.rktd"))
|
||||
|
||||
|
||||
(require redex/private/term
|
||||
redex/private/lang-struct)
|
||||
(define-namespace-anchor here)
|
||||
(define ns (namespace-anchor->namespace here))
|
||||
(parameterize ([current-namespace ns])
|
||||
(exec-runtime-error-tests "run-err-tests/term.rktd"))
|
||||
|
||||
(exec-syntax-error-tests "syn-err-tests/term.rktd")
|
||||
|
||||
(print-tests-passed 'err-loc-test.rkt)
|
||||
|
|
@ -24,6 +24,7 @@
|
|||
"unify-tests.rkt"
|
||||
"dq-test.rkt"
|
||||
"tl-test.rkt"
|
||||
"err-loc-test.rkt"
|
||||
"term-test.rkt"
|
||||
"rg-test.rkt"
|
||||
"gen-test.rkt"
|
||||
|
|
|
|||
|
|
@ -1,112 +1,105 @@
|
|||
(module term-test scheme
|
||||
(require redex/private/term
|
||||
redex/private/lang-struct
|
||||
redex/private/matcher
|
||||
"test-util.rkt")
|
||||
|
||||
(reset-count)
|
||||
(test (term 1) 1)
|
||||
(test (term (1 2)) (list 1 2))
|
||||
(test (term (1 ,(+ 1 1))) (list 1 2))
|
||||
(test (term-let ([x 1]) (term (x x))) (list 1 1))
|
||||
(test (term-let ([(x ...) (list 1 2 3)]) (term ((y x) ...))) '((y 1) (y 2) (y 3)))
|
||||
|
||||
(test (term (in-hole (1 hole) 2)) (term (1 2)))
|
||||
(test (term (in-hole (1 hole (hole x)) 2)) (term (1 2 (hole x))))
|
||||
|
||||
(test (equal? (term hole) (term hole)) #t)
|
||||
(test (hole? (term hole)) #t)
|
||||
(test (hole? (term (hole #f))) #f)
|
||||
(test (hole? (term (hole the-name))) #f)
|
||||
|
||||
(test (term-let-fn ((f (lambda (q) q)))
|
||||
(term (f 1 2 3)))
|
||||
(term (1 2 3)))
|
||||
|
||||
(test (term-let-fn ((f (lambda (q) `(y ,(car q)))))
|
||||
(term (f (zzzz))))
|
||||
(term (y (zzzz))))
|
||||
|
||||
(test (term-let-fn ((f (λ (x) (add1 (car x)))))
|
||||
(term (f 2)))
|
||||
(term 3))
|
||||
|
||||
(test (term-let ([((x ...) ...) (list (list 1 1) (list 2 2) (list 3 3))])
|
||||
(term-let-fn ((f (λ (x) (car x))))
|
||||
(term ((qq (f x) ...) ...))))
|
||||
(term ((qq 1 1) (qq 2 2) (qq 3 3))))
|
||||
|
||||
(test (term-let-fn ((f (lambda (x) (car x))))
|
||||
(term (f hole)))
|
||||
(term hole))
|
||||
|
||||
(test (term-let-fn ((f (lambda (q) `(y ,(car q)))))
|
||||
(term-let-fn ((g (lambda (x) `(ff ,(car x)))))
|
||||
(term (g (f (zzzz))))))
|
||||
(term (ff (y (zzzz)))))
|
||||
|
||||
(test (term-let-fn ((f (lambda (q) `(y ,(car q)))))
|
||||
(term-let-fn ((g (lambda (x) `(ff ,(car x)))))
|
||||
(term (f (g (f (zzzz)))))))
|
||||
(term (y (ff (y (zzzz))))))
|
||||
|
||||
(test (term-let ([x 1])
|
||||
(term (x . y)))
|
||||
(term (1 . y)))
|
||||
|
||||
(test (term-let ([(x ...) (list 3 2 1)])
|
||||
(term (x ... . y)))
|
||||
(term (3 2 1 . y)))
|
||||
|
||||
(test (term-let ([(x . y) (cons 1 2)])
|
||||
(term (x y)))
|
||||
(term (1 2)))
|
||||
|
||||
;; test that the implicit `plug' inserted by `in-hole'
|
||||
;; deals with ellipses properly
|
||||
(test (term-let ([(E ...) '(1 2 3)])
|
||||
(term ((in-hole E x) ...)))
|
||||
(term (1 2 3)))
|
||||
|
||||
(test (term-let-fn ((metafun car))
|
||||
(term-let ((x 'whatever)
|
||||
((y ...) '(4 5 6)))
|
||||
(term (((metafun x) y) ...))))
|
||||
'((whatever 4) (whatever 5) (whatever 6)))
|
||||
|
||||
(test (term-let-fn ((metafun (λ (x) (car x))))
|
||||
(term-let (((y ...) '(4 5 6)))
|
||||
(term ((y (metafun 1)) ...))))
|
||||
'((4 1) (5 1) (6 1)))
|
||||
|
||||
(test (term-let-fn ((f (compose add1 car)))
|
||||
(term-let (((x ...) '(1 2 3))
|
||||
((y ...) '(a b c)))
|
||||
(term (((f x) y) ...))))
|
||||
'((2 a) (3 b) (4 c)))
|
||||
|
||||
(test (term-let-fn ((f (curry foldl + 0)))
|
||||
(term-let (((x ...) '(1 2 3)))
|
||||
(term (f x ...))))
|
||||
6)
|
||||
|
||||
(test (term-let-fn ((f (compose add1 car)))
|
||||
(term-let (((x ...) '(1 2 3))
|
||||
(((y ...) ...) '((a b c) (d e f) (g h i))))
|
||||
(term ((((f x) y) ...) ...))))
|
||||
'(((2 a) (3 b) (4 c)) ((2 d) (3 e) (4 f)) ((2 g) (3 h) (4 i))))
|
||||
|
||||
(test (term-let-fn ((f (curry foldl + 0)))
|
||||
(term-let ((((x ...) ...) '((1 2) (3 4 5) (6))))
|
||||
(term ((f x ...) ...))))
|
||||
'(3 12 6))
|
||||
#lang racket/base
|
||||
(require redex/private/term
|
||||
redex/private/lang-struct
|
||||
redex/private/matcher
|
||||
racket/function
|
||||
"test-util.rkt")
|
||||
|
||||
(define-namespace-anchor here)
|
||||
(define ns (namespace-anchor->namespace here))
|
||||
|
||||
(parameterize ([current-namespace ns])
|
||||
(exec-runtime-error-tests "run-err-tests/term.rktd"))
|
||||
|
||||
(exec-syntax-error-tests "syn-err-tests/term.rktd")
|
||||
|
||||
(print-tests-passed 'term-test.rkt))
|
||||
(reset-count)
|
||||
(test (term 1) 1)
|
||||
(test (term (1 2)) (list 1 2))
|
||||
(test (term (1 ,(+ 1 1))) (list 1 2))
|
||||
(test (term-let ([x 1]) (term (x x))) (list 1 1))
|
||||
(test (term-let ([(x ...) (list 1 2 3)]) (term ((y x) ...))) '((y 1) (y 2) (y 3)))
|
||||
|
||||
(test (term (in-hole (1 hole) 2)) (term (1 2)))
|
||||
(test (term (in-hole (1 hole (hole x)) 2)) (term (1 2 (hole x))))
|
||||
|
||||
(test (equal? (term hole) (term hole)) #t)
|
||||
(test (hole? (term hole)) #t)
|
||||
(test (hole? (term (hole #f))) #f)
|
||||
(test (hole? (term (hole the-name))) #f)
|
||||
|
||||
(test (term-let-fn ((f (lambda (q) q)))
|
||||
(term (f 1 2 3)))
|
||||
(term (1 2 3)))
|
||||
|
||||
(test (term-let-fn ((f (lambda (q) `(y ,(car q)))))
|
||||
(term (f (zzzz))))
|
||||
(term (y (zzzz))))
|
||||
|
||||
(test (term-let-fn ((f (λ (x) (add1 (car x)))))
|
||||
(term (f 2)))
|
||||
(term 3))
|
||||
|
||||
(test (term-let ([((x ...) ...) (list (list 1 1) (list 2 2) (list 3 3))])
|
||||
(term-let-fn ((f (λ (x) (car x))))
|
||||
(term ((qq (f x) ...) ...))))
|
||||
(term ((qq 1 1) (qq 2 2) (qq 3 3))))
|
||||
|
||||
(test (term-let-fn ((f (lambda (x) (car x))))
|
||||
(term (f hole)))
|
||||
(term hole))
|
||||
|
||||
(test (term-let-fn ((f (lambda (q) `(y ,(car q)))))
|
||||
(term-let-fn ((g (lambda (x) `(ff ,(car x)))))
|
||||
(term (g (f (zzzz))))))
|
||||
(term (ff (y (zzzz)))))
|
||||
|
||||
(test (term-let-fn ((f (lambda (q) `(y ,(car q)))))
|
||||
(term-let-fn ((g (lambda (x) `(ff ,(car x)))))
|
||||
(term (f (g (f (zzzz)))))))
|
||||
(term (y (ff (y (zzzz))))))
|
||||
|
||||
(test (term-let ([x 1])
|
||||
(term (x . y)))
|
||||
(term (1 . y)))
|
||||
|
||||
(test (term-let ([(x ...) (list 3 2 1)])
|
||||
(term (x ... . y)))
|
||||
(term (3 2 1 . y)))
|
||||
|
||||
(test (term-let ([(x . y) (cons 1 2)])
|
||||
(term (x y)))
|
||||
(term (1 2)))
|
||||
|
||||
;; test that the implicit `plug' inserted by `in-hole'
|
||||
;; deals with ellipses properly
|
||||
(test (term-let ([(E ...) '(1 2 3)])
|
||||
(term ((in-hole E x) ...)))
|
||||
(term (1 2 3)))
|
||||
|
||||
(test (term-let-fn ((metafun car))
|
||||
(term-let ((x 'whatever)
|
||||
((y ...) '(4 5 6)))
|
||||
(term (((metafun x) y) ...))))
|
||||
'((whatever 4) (whatever 5) (whatever 6)))
|
||||
|
||||
(test (term-let-fn ((metafun (λ (x) (car x))))
|
||||
(term-let (((y ...) '(4 5 6)))
|
||||
(term ((y (metafun 1)) ...))))
|
||||
'((4 1) (5 1) (6 1)))
|
||||
|
||||
(test (term-let-fn ((f (compose add1 car)))
|
||||
(term-let (((x ...) '(1 2 3))
|
||||
((y ...) '(a b c)))
|
||||
(term (((f x) y) ...))))
|
||||
'((2 a) (3 b) (4 c)))
|
||||
|
||||
(test (term-let-fn ((f (curry foldl + 0)))
|
||||
(term-let (((x ...) '(1 2 3)))
|
||||
(term (f x ...))))
|
||||
6)
|
||||
|
||||
(test (term-let-fn ((f (compose add1 car)))
|
||||
(term-let (((x ...) '(1 2 3))
|
||||
(((y ...) ...) '((a b c) (d e f) (g h i))))
|
||||
(term ((((f x) y) ...) ...))))
|
||||
'(((2 a) (3 b) (4 c)) ((2 d) (3 e) (4 f)) ((2 g) (3 h) (4 i))))
|
||||
|
||||
(test (term-let-fn ((f (curry foldl + 0)))
|
||||
(term-let ((((x ...) ...) '((1 2) (3 4 5) (6))))
|
||||
(term ((f x ...) ...))))
|
||||
'(3 12 6))
|
||||
|
||||
(print-tests-passed 'term-test.rkt)
|
||||
|
|
|
|||
|
|
@ -5,20 +5,11 @@
|
|||
(for-syntax syntax/parse setup/path-to-relative)
|
||||
setup/path-to-relative
|
||||
racket/runtime-path)
|
||||
(provide test test-syn-err tests reset-count
|
||||
syn-err-test-namespace
|
||||
(provide test tests reset-count
|
||||
print-tests-passed
|
||||
equal/bindings?
|
||||
test-contract-violation
|
||||
test-runtime-err
|
||||
exec-syntax-error-tests
|
||||
exec-runtime-error-tests)
|
||||
|
||||
(define-runtime-path this-dir ".")
|
||||
|
||||
(define syn-err-test-namespace (make-base-namespace))
|
||||
(parameterize ([current-namespace syn-err-test-namespace])
|
||||
(eval '(require redex/reduction-semantics)))
|
||||
test/proc)
|
||||
|
||||
(define (read-syntax-test path)
|
||||
(call-with-input-file path
|
||||
|
|
@ -35,100 +26,6 @@
|
|||
"<unknown file>")])
|
||||
(syntax/loc stx (test/proc (λ () expected) got line fn)))]))
|
||||
|
||||
(define (syntax-error-test-setup thunk)
|
||||
(parameterize ([current-namespace syn-err-test-namespace])
|
||||
(with-handlers ([exn:fail:syntax?
|
||||
(λ (exn)
|
||||
(values (exn-message exn)
|
||||
(map source-location (exn:fail:syntax-exprs exn))))])
|
||||
(thunk))))
|
||||
(define (runtime-error-test-setup thunk)
|
||||
(define errortrace-key (dynamic-require 'errortrace/errortrace-key 'errortrace-key))
|
||||
(parameterize ([current-compile ((dynamic-require 'errortrace/errortrace-lib 'make-errortrace-compile-handler))])
|
||||
(with-handlers ([exn:fail?
|
||||
(λ (exn)
|
||||
(values (exn-message exn)
|
||||
(let ([ans (let ([marks (continuation-mark-set->list
|
||||
(exn-continuation-marks exn)
|
||||
errortrace-key)])
|
||||
(if (null? marks) '() (list (cdar marks))))])
|
||||
(let loop ([ans ans])
|
||||
(cond
|
||||
[(pair? ans) (cons (loop (car ans)) (loop (cdr ans)))]
|
||||
[(path? ans) (path->relative-string/library ans)]
|
||||
[else ans])))))])
|
||||
(thunk))))
|
||||
|
||||
(define ((exec-error-tests setup exec) path)
|
||||
(for ([test (read-tests (build-path this-dir path))])
|
||||
(exec-error-test test exec setup)))
|
||||
(define exec-syntax-error-tests
|
||||
(exec-error-tests syntax-error-test-setup expand))
|
||||
(define exec-runtime-error-tests
|
||||
(exec-error-tests runtime-error-test-setup eval))
|
||||
|
||||
(define (exec-error-test spec exec setup)
|
||||
(define-values (file line expected-message expected-sources test)
|
||||
(make-error-test spec))
|
||||
(let-values ([(actual-message actual-sources)
|
||||
(setup (λ () (begin (exec test) (values "" '()))))])
|
||||
(test/proc (λ () actual-message) expected-message line file)
|
||||
(test/proc (λ () actual-sources) expected-sources line file)))
|
||||
|
||||
(define (make-error-test spec)
|
||||
(syntax-case spec ()
|
||||
[(message named-pieces body)
|
||||
(make-error-test (syntax/loc spec (message named-pieces () body)))]
|
||||
[(message ([loc-name loc-piece] ...) ([non-loc-name non-loc-piece] ...) body)
|
||||
(values (and (path? (syntax-source spec))
|
||||
(path->relative-string/library (syntax-source spec)))
|
||||
(syntax-line spec)
|
||||
(syntax-e #'message)
|
||||
(map source-location (syntax->list #'(loc-piece ...)))
|
||||
#'(let-syntax ([subst
|
||||
(λ (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ loc-name ... non-loc-name ...)
|
||||
#'body]))])
|
||||
(subst loc-piece ... non-loc-piece ...)
|
||||
(void)))]))
|
||||
|
||||
(define (source-location stx)
|
||||
(list (and (path? (syntax-source stx))
|
||||
(path->relative-string/library (syntax-source stx)))
|
||||
(syntax-line stx)
|
||||
(syntax-column stx)
|
||||
(syntax-position stx)
|
||||
(syntax-span stx)))
|
||||
|
||||
(define (read-tests path)
|
||||
(call-with-input-file path
|
||||
(λ (port)
|
||||
(port-count-lines! port)
|
||||
(let loop ()
|
||||
(define test (read-syntax path port))
|
||||
(if (eof-object? test)
|
||||
'()
|
||||
(cons test (loop)))))))
|
||||
|
||||
(define-syntax (test-syn-err stx)
|
||||
#'(void))
|
||||
|
||||
(define-syntax (test-runtime-err stx)
|
||||
#'(void)
|
||||
#;
|
||||
#`(parameterize ([current-compile (make-errortrace-compile-handler)])
|
||||
#,(test-error-location
|
||||
stx
|
||||
eval
|
||||
#'[exn:fail?
|
||||
(λ (exn)
|
||||
(values (exn-message exn)
|
||||
(let ([marks (continuation-mark-set->list
|
||||
(exn-continuation-marks exn)
|
||||
errortrace-key)])
|
||||
(if (null? marks) #f (list (cdar marks))))))])))
|
||||
|
||||
(define tests 0)
|
||||
(define failures 0)
|
||||
(define (reset-count)
|
||||
|
|
@ -137,8 +34,15 @@
|
|||
|
||||
(define (print-tests-passed filename)
|
||||
(cond
|
||||
[(= 0 tests)
|
||||
(printf "~a: no tests were run.\n" filename)]
|
||||
[(= 0 failures)
|
||||
(printf "~a: all ~a tests passed.\n" filename tests)]
|
||||
(printf "~a: ~a passed.\n"
|
||||
filename
|
||||
(case tests
|
||||
[(1) "1 test"]
|
||||
[(2) "both tests"]
|
||||
[else (format "~a tests" tests)]))]
|
||||
[else
|
||||
(printf "~a: ~a test~a failed.\n" filename failures (if (= 1 failures) "" "s"))]))
|
||||
|
||||
|
|
|
|||
|
|
@ -8,21 +8,6 @@
|
|||
|
||||
(reset-count)
|
||||
|
||||
(define-namespace-anchor this-namespace)
|
||||
(parameterize ([current-namespace syn-err-test-namespace])
|
||||
(eval (quote-syntax
|
||||
(define-language syn-err-lang
|
||||
(M (M M)
|
||||
number)
|
||||
(E hole
|
||||
(E M)
|
||||
(number E))
|
||||
(X (number any)
|
||||
(any number))
|
||||
(Q (Q ...)
|
||||
variable)
|
||||
(UN (add1 UN)
|
||||
zero)))))
|
||||
|
||||
;
|
||||
;
|
||||
|
|
@ -534,17 +519,6 @@
|
|||
(test (redex-match empty-language number 'a) #f)
|
||||
(test (redex-match empty-language (in-hole hole number) 'a) #f))
|
||||
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(eval '(require redex/reduction-semantics redex/pict))
|
||||
(eval '(define-language L
|
||||
(s a b c)))
|
||||
(exec-runtime-error-tests "run-err-tests/define-union-language.rktd"))
|
||||
|
||||
(exec-syntax-error-tests "syn-err-tests/language-definition.rktd")
|
||||
|
||||
;; term with #:lang tests
|
||||
(exec-syntax-error-tests "syn-err-tests/term-lang.rktd")
|
||||
|
||||
(let ()
|
||||
(define-language L
|
||||
(a number)
|
||||
|
|
@ -1194,22 +1168,19 @@
|
|||
"")
|
||||
#rx"returned different results"))
|
||||
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(eval '(require redex/reduction-semantics))
|
||||
(exec-runtime-error-tests "run-err-tests/judgment-form-undefined.rktd"))
|
||||
|
||||
;; errors for not-yet-defined metafunctions
|
||||
(test (parameterize ([current-namespace (make-empty-namespace)])
|
||||
(namespace-attach-module (namespace-anchor->namespace this-namespace) 'redex/reduction-semantics)
|
||||
(namespace-require 'racket)
|
||||
(eval '(module m racket
|
||||
(require redex/reduction-semantics)
|
||||
(term (q))
|
||||
(define-language L)
|
||||
(define-metafunction L [(q) ()])))
|
||||
(with-handlers ([exn:fail:redex? exn-message])
|
||||
(eval '(require 'm))
|
||||
#f))
|
||||
(test (let ([on (current-namespace)])
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(namespace-attach-module on 'redex/reduction-semantics)
|
||||
(namespace-require 'racket/base)
|
||||
(eval '(module m racket
|
||||
(require redex/reduction-semantics)
|
||||
(term (q))
|
||||
(define-language L)
|
||||
(define-metafunction L [(q) ()])))
|
||||
(with-handlers ([exn:fail:redex? exn-message])
|
||||
(eval '(require 'm))
|
||||
#f)))
|
||||
"reference to metafunction q before its definition")
|
||||
(test (with-handlers ([exn:fail:redex? exn-message])
|
||||
(let ()
|
||||
|
|
@ -1219,7 +1190,6 @@
|
|||
#f))
|
||||
"reference to metafunction q before its definition")
|
||||
|
||||
(exec-syntax-error-tests "syn-err-tests/metafunction-definition.rktd")
|
||||
;
|
||||
;
|
||||
;
|
||||
|
|
@ -1419,8 +1389,6 @@
|
|||
)
|
||||
|
||||
|
||||
(exec-syntax-error-tests "syn-err-tests/relation-definition.rktd")
|
||||
|
||||
; ;; ; ;; ;
|
||||
; ; ; ; ;
|
||||
; ;; ;; ;;; ;; ; ;; ;; ;;;; ;;;;; ;;; ;;; ;; ;; ;; ;; ;;; ; ;;; ;;;;; ;;; ;;; ;; ;;
|
||||
|
|
@ -1829,8 +1797,6 @@
|
|||
(test (apply-reduction-relation R (term (0 2 3 4 5))) '())
|
||||
(test (apply-reduction-relation R (term (1 2 3 4 5 () (6) (7 8) (9 10 11)))) '(yes)))
|
||||
|
||||
(exec-syntax-error-tests "syn-err-tests/reduction-relation-definition.rktd")
|
||||
|
||||
;; expect union with duplicate names to fail
|
||||
(test (with-handlers ((exn? (λ (x) 'passed)))
|
||||
(union-reduction-relations
|
||||
|
|
@ -2218,8 +2184,7 @@
|
|||
1)
|
||||
(test
|
||||
(redex-let* L ([(n_1) '(1)] [n_1 1]) (term n_1))
|
||||
1)
|
||||
(exec-syntax-error-tests "syn-err-tests/redex-let.rktd"))
|
||||
1))
|
||||
|
||||
|
||||
;
|
||||
|
|
@ -2238,9 +2203,6 @@
|
|||
; ; ; ;
|
||||
; ;; ;;;
|
||||
|
||||
(exec-syntax-error-tests "syn-err-tests/judgment-form-definition.rktd")
|
||||
(exec-syntax-error-tests "syn-err-tests/judgment-holds.rktd")
|
||||
|
||||
(let ()
|
||||
(define-language nats
|
||||
(n z (s n)))
|
||||
|
|
@ -2710,22 +2672,6 @@
|
|||
[(J b)]))
|
||||
(test (eval '(judgment-holds (J a))) #t))
|
||||
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(eval '(require redex/reduction-semantics))
|
||||
(eval '(define-language L
|
||||
(s a b c)))
|
||||
(eval '(define-judgment-form L
|
||||
#:mode (ctc-fail I O)
|
||||
#:contract (ctc-fail s s)
|
||||
[(ctc-fail a q)]
|
||||
[(ctc-fail b s)
|
||||
(ctc-fail q s)]
|
||||
[(ctc-fail c s)
|
||||
(ctc-fail a s)]))
|
||||
(exec-runtime-error-tests "run-err-tests/judgment-form-contracts.rktd")
|
||||
(exec-runtime-error-tests "run-err-tests/judgment-form-undefined.rktd")
|
||||
(exec-runtime-error-tests "run-err-tests/judgment-form-ellipses.rktd"))
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user