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

added support for 'or', \vee, and \cup as builtins to the define-metafunction codomain contracts

Browse Source
This commit is contained in:
Robby Findler 2011-03-26 10:04:39 -05:00
parent f3b0a7454a
commit f69ff3b6b7
3 changed files with 96 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1175,7 +1175,7 @@
(λ () (λ ()
(raise-syntax-error syn-error-name "expected a previously defined metafunction" orig-stx prev-metafunction)))) (raise-syntax-error syn-error-name "expected a previously defined metafunction" orig-stx prev-metafunction))))
(let ([lang-nts (language-id-nts #'lang 'define-metafunction)]) ;; keep this near the beginning, so it signals the first error (PR 10062) (let ([lang-nts (language-id-nts #'lang 'define-metafunction)]) ;; keep this near the beginning, so it signals the first error (PR 10062)
(let-values ([(contract-name dom-ctcs codom-contract pats) (let-values ([(contract-name dom-ctcs codom-contracts pats)
(split-out-contract orig-stx syn-error-name #'rest relation?)]) (split-out-contract orig-stx syn-error-name #'rest relation?)])
(with-syntax ([(((original-names lhs-clauses ...) raw-rhses ...) ...) pats] (with-syntax ([(((original-names lhs-clauses ...) raw-rhses ...) ...) pats]
[(lhs-for-lw ...) [(lhs-for-lw ...)
@ -1273,12 +1273,14 @@
syn-error-name syn-error-name
#f #f
dom-ctcs))] dom-ctcs))]
[codom-side-conditions-rewritten [(codom-side-conditions-rewritten ...)
(rewrite-side-conditions/check-errs (map (λ (codom-contract)
lang-nts (rewrite-side-conditions/check-errs
syn-error-name lang-nts
#f syn-error-name
codom-contract)] #f
codom-contract))
codom-contracts)]
[(rhs-fns ...) [(rhs-fns ...)
(map (λ (names names/ellipses rhs/where) (map (λ (names names/ellipses rhs/where)
(with-syntax ([(names ...) names] (with-syntax ([(names ...) names]
@ -1398,7 +1400,7 @@
dsc dsc
(append cases parent-cases))) (append cases parent-cases)))
dsc dsc
`codom-side-conditions-rewritten `(codom-side-conditions-rewritten ...)
'name 'name
#,relation?)))) #,relation?))))
(term-define-fn name name2))]) (term-define-fn name name2))])
@ -1434,7 +1436,7 @@
;; initial test determines if a contract is specified or not ;; initial test determines if a contract is specified or not
(cond (cond
[(pair? (syntax-e (car (syntax->list rest)))) [(pair? (syntax-e (car (syntax->list rest))))
(values #f #f #'any (check-clauses stx syn-error-name (syntax->list rest) relation?))] (values #f #f (list #'any) (check-clauses stx syn-error-name (syntax->list rest) relation?))]
[else [else
(syntax-case rest () (syntax-case rest ()
[(id colon more ...) [(id colon more ...)
@ -1468,7 +1470,7 @@
[else [else
(values #'id (values #'id
(reverse arg-pats) (reverse arg-pats)
#'any (list #'any)
(check-clauses stx syn-error-name more relation?))])))] (check-clauses stx syn-error-name more relation?))])))]
[else [else
(unless (eq? ': (syntax-e #'colon)) (unless (eq? ': (syntax-e #'colon))
@ -1479,12 +1481,31 @@
[(null? more) [(null? more)
(raise-syntax-error syn-error-name "expected an ->" stx)] (raise-syntax-error syn-error-name "expected an ->" stx)]
[(eq? (syntax-e (car more)) '->) [(eq? (syntax-e (car more)) '->)
(when (null? (cdr more)) (define-values (raw-clauses rev-codomains)
(raise-syntax-error syn-error-name "expected a range contract to follow the arrow" stx (car more))) (let loop ([prev (car more)]
[more (cdr more)]
[codomains '()])
(cond
[(null? more)
(raise-syntax-error syn-error-name "expected a range contract to follow" stx prev)]
[else
(define after-this-one (cdr more))
(cond
[(null? after-this-one)
(values null (cons (car more) codomains))]
[else
(define kwd (cadr more))
(cond
[(member (syntax-e kwd) '(or ∨ ∪))
(loop kwd
(cddr more)
(cons (car more) codomains))]
[else
(values (cdr more)
(cons (car more) codomains))])])])))
(let ([doms (reverse dom-pats)] (let ([doms (reverse dom-pats)]
[codomain (cadr more)] [clauses (check-clauses stx syn-error-name raw-clauses relation?)])
[clauses (check-clauses stx syn-error-name (cddr more) relation?)]) (values #'id doms (reverse rev-codomains) clauses))]
(values #'id doms codomain clauses))]
[else [else
(loop (cdr more) (cons (car more) dom-pats))]))])] (loop (cdr more) (cons (car more) dom-pats))]))])]
[_ [_
@ -1558,9 +1579,10 @@
(syntax->list stuffs))) (syntax->list stuffs)))
(syntax->list extras)))) (syntax->list extras))))
(define (build-metafunction lang cases parent-cases wrap dom-contract-pat codom-contract-pat name relation?) (define (build-metafunction lang cases parent-cases wrap dom-contract-pat codom-contract-pats name relation?)
(let* ([dom-compiled-pattern (and dom-contract-pat (compile-pattern lang dom-contract-pat #f))] (let* ([dom-compiled-pattern (and dom-contract-pat (compile-pattern lang dom-contract-pat #f))]
[codom-compiled-pattern (compile-pattern lang codom-contract-pat #f)] [codom-compiled-patterns (map (λ (codom-contract-pat) (compile-pattern lang codom-contract-pat #f))
codom-contract-pats)]
[all-cases (append cases parent-cases)] [all-cases (append cases parent-cases)]
[lhss-at-lang (map (λ (case) ((metafunc-case-lhs case) lang)) all-cases)] [lhss-at-lang (map (λ (case) ((metafunc-case-lhs case) lang)) all-cases)]
[rhss-at-lang (map (λ (case) ((metafunc-case-rhs case) lang)) all-cases)] [rhss-at-lang (map (λ (case) ((metafunc-case-rhs case) lang)) all-cases)]
@ -1620,7 +1642,8 @@
(let ([ans (let ([ans
(ormap (λ (mtch) (ormap values (rhs traced-metafunc (mtch-bindings mtch)))) (ormap (λ (mtch) (ormap values (rhs traced-metafunc (mtch-bindings mtch))))
mtchs)]) mtchs)])
(unless (match-pattern codom-compiled-pattern ans) (unless (ormap (λ (codom-compiled-pattern) (match-pattern codom-compiled-pattern ans))
codom-compiled-patterns)
(redex-error name "codomain test failed for ~s, call was ~s" ans `(,name ,@exp))) (redex-error name "codomain test failed for ~s, call was ~s" ans `(,name ,@exp)))
(cond (cond
[ans [ans
@ -1648,7 +1671,9 @@
(length mtchs))] (length mtchs))]
[else [else
(let ([ans (car anss)]) (let ([ans (car anss)])
(unless (match-pattern codom-compiled-pattern ans) (unless (ormap (λ (codom-compiled-pattern)
(match-pattern codom-compiled-pattern ans))
codom-compiled-patterns)
(redex-error name (redex-error name
"codomain test failed for ~s, call was ~s" "codomain test failed for ~s, call was ~s"
ans ans

6
collects/redex/redex.scrbl
View File

@ -934,7 +934,11 @@ all non-GUI portions of Redex) and also exported by
[(name @#,ttpattern ...) @#,tttterm extras ...] [(name @#,ttpattern ...) @#,tttterm extras ...]
...) ...)
([metafunction-contract (code:line) ([metafunction-contract (code:line)
(code:line id : @#,ttpattern ... -> @#,ttpattern)] (code:line id : @#,ttpattern ... -> range)]
[range @#,ttpattern
(code:line @#,ttpattern or range)
(code:line @#,ttpattern ∨ range)
(code:line @#,ttpattern ∪ range)]
[extras (side-condition racket-expression) [extras (side-condition racket-expression)
(side-condition/hidden racket-expression) (side-condition/hidden racket-expression)
(where pat @#,tttterm) (where pat @#,tttterm)

47
collects/redex/tests/tl-test.rkt
View File

@ -879,6 +879,53 @@
(test (term (f 0 2 3 4 5)) 'no) (test (term (f 0 2 3 4 5)) 'no)
(test (term (f 1 2 3 4 5 () (6) (7 8) (9 10 11))) 'yes)) (test (term (f 1 2 3 4 5 () (6) (7 8) (9 10 11))) 'yes))
(let ()
(define-language L
[bool #t #f])
(define-metafunction L
f : any -> bool or number
[(f any) any])
(test (term (f 1)) (term 1))
(test (term (f #f)) (term #f)))
(let ()
(define-language L
[bool #t #f])
(define-metafunction L
f : any -> bool ∪ number
[(f any) any])
(test (term (f 1)) (term 1))
(test (term (f #f)) (term #f)))
(let ()
(define-language L
[bool #t #f]
[abc a b c]
[def d e f])
(define-metafunction L
f : any -> bool ∨ number ∪ abc or def
[(f any) any])
(test (term (f 1)) (term 1))
(test (term (f #f)) (term #f))
(test (term (f c)) (term c))
(test (term (f e)) (term e)))
;; test that the contracts are called in order (or else 'car' fails)
(let ()
(define x '())
(define-language L
[seq (any any ...)])
(define-metafunction L
g : any ->
(side-condition any_1 (begin (set! x (cons 1 x)) #f))
or (side-condition any_1 (begin (set! x (cons 2 x)) #f))
or any
[(g any) any])
(test (begin (term (g whatever))
x)
'(2 1)))
(let () (let ()
(test-syn-err (test-syn-err
(define-metafunction grammar (define-metafunction grammar