suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

PR 10650

Browse Source 
svn: r17331
This commit is contained in:
Casey Klein 2009-12-16 20:46:58 +00:00
parent 9e6e9696af
commit eb4403f1c7
2 changed files with 27 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/redex/private/reduction-semantics.ss
View File

@ -936,7 +936,7 @@
other-matches))))) other-matches)))))
(rewrite-proc-name child-make-proc) (rewrite-proc-name child-make-proc)
(λ (lang) (subst lhs-frm-id ((rewrite-proc-lhs child-make-proc) lang) rhs-from)) (λ (lang) (subst lhs-frm-id ((rewrite-proc-lhs child-make-proc) lang) rhs-from))
(rewrite-proc-lhs child-make-proc) (rewrite-proc-lhs-src child-make-proc)
(rewrite-proc-id child-make-proc))) (rewrite-proc-id child-make-proc)))
(define relation-coverage (make-parameter null)) (define relation-coverage (make-parameter null))

44
collects/redex/private/rg-test.ss
View File

@ -699,26 +699,32 @@
exn:fail:redex:generation-failure? exn:fail:redex:generation-failure?
(redex-check lang (side-condition any #f) #t #:retries 42 #:attempts 1)) (redex-check lang (side-condition any #f) #t #:retries 42 #:attempts 1))
#rx"^redex-check: unable .* in 42") #rx"^redex-check: unable .* in 42")
(let-syntax ([test-gen-fail (let ([unable-loc #px"^redex-check: unable to generate LHS of clause at .*:\\d+:\\d+ in 42"])
(syntax-rules () (let-syntax ([test-gen-fail
[(_ rhs expected) (syntax-rules ()
(test [(_ clauses ... expected)
(raised-exn-msg (test
exn:fail:redex:generation-failure? (raised-exn-msg
(redex-check lang any #t exn:fail:redex:generation-failure?
#:source (reduction-relation (redex-check lang any #t
lang #:source (reduction-relation
rhs) lang
#:retries 42 clauses ...)
#:attempts 1)) #:retries 42
expected)])]) #:attempts 1))
(test-gen-fail expected)])])
(--> (side-condition any #f) any) (test-gen-fail
#px"^redex-check: unable to generate LHS of clause at .*:\\d+:\\d+ in 42") (--> (side-condition any #f) any)
unable-loc)
(test-gen-fail (test-gen-fail
(--> (side-condition any #f) any impossible) (==> (side-condition any #f) any)
#rx"^redex-check: unable to generate LHS of impossible in 42"))) with [(--> a b) (==> a b)]
unable-loc)
(test-gen-fail
(--> (side-condition any #f) any impossible)
#rx"^redex-check: unable to generate LHS of impossible in 42"))))
;; check-metafunction-contract ;; check-metafunction-contract
(let () (let ()