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

Tests metafunction Check Syntax arrows

Browse Source
This commit is contained in:
Casey Klein 2011-08-16 11:04:11 -05:00
parent efa04066c6
commit 9e2e11e9c4
2 changed files with 40 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/redex/private/reduction-semantics.rkt
View File

@ -2196,7 +2196,10 @@
(identifier? #'id)
(let ([v (syntax-local-value #'id (lambda () #f))])
(if (term-fn? v)
#`(make-metafunction #,(term-fn-get-id v))
(syntax-property
#`(make-metafunction #,(term-fn-get-id v))
'disappeared-use
(list #'id))
(raise-syntax-error
#f
"not bound as a metafunction"

38
collects/redex/tests/check-syntax-test.rkt
View File

@ -35,11 +35,12 @@
(define-namespace-anchor module-anchor)
(define module-namespace
(namespace-anchor->namespace module-anchor))
(define-values (add-syntax done)
(make-traversal module-namespace #f))
;; judgment forms
(let ([annotations (new arrow-collector%)])
(define-values (add-syntax done)
(make-traversal module-namespace #f))
(define language-def-name #'L)
(define language-use-name #'L)
@ -72,4 +73,37 @@
(list (source mode-name) (source render-name))
(list (source mode-name) (source holds-name)))))
;; metafunctions
(let ([annotations (new arrow-collector%)])
(define-values (add-syntax done)
(make-traversal module-namespace #f))
(define language-def-name #'L)
(define language-use-name #'L)
(define contract-name #'f)
(define lhs-name #'f)
(define rhs-name #'f)
(define render-name #'f)
(define term-name #'f)
(parameterize ([current-annotations annotations]
[current-namespace module-namespace])
(add-syntax
(expand #`(let ()
(define-language #,language-def-name)
(define-metafunction #,language-use-name
#,contract-name : () -> ()
[(#,lhs-name) (#,rhs-name)])
(render-metafunction #,render-name)
(term (#,term-name)))))
(done))
(test (send annotations collected-arrows)
(set (list (source language-def-name) (source language-use-name))
(list (source contract-name) (source lhs-name))
(list (source contract-name) (source rhs-name))
(list (source contract-name) (source render-name))
(list (source contract-name) (source term-name)))))
(print-tests-passed 'check-syntax-test.rkt)