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

add a #:pre keyword to define-metafunction

Browse Source 
The keyword allows the specification of contracts
that relate different arguments

closes PR 13617
This commit is contained in:
Robby Findler 2013-03-18 12:52:59 -05:00
parent 35a093469c
commit 06696d67b4
6 changed files with 67 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/redex/private/judgment-form.rkt
View File

@ -393,13 +393,15 @@
(with-syntax* ([((name trms ...) rest ...) (car pats)]
[(mode-stx ...) #`(#:mode (name I))]
[(ctc-stx ...) (if dom-ctcs
(with-syntax ([(d-ctc ...) dom-ctcs])
#`(#:contract (name (d-ctc ...))))
#`(#:contract (name #,dom-ctcs))
#'())]
[(clauses ...) pats]
[new-body #`(mode-stx ... ctc-stx ... clauses ...)])
(do-extended-judgment-form #'lang (syntax-e #'def-form-id) #'new-body #f stx #t)))]))
;; if relation? is true, then the contract is a list of redex patterns
;; if relation? is false, then the contract is a single redex pattern
;; (meant to match the actual argument as a sequence)
(define-for-syntax (split-out-contract stx syn-error-name rest relation?)
;; initial test determines if a contract is specified or not
(cond
@ -427,7 +429,7 @@
[(null? more)
(raise-syntax-error syn-error-name "expected an ->" stx)]
[(eq? (syntax-e (car more)) '->)
(define-values (raw-clauses rev-codomains)
(define-values (raw-clauses rev-codomains pre-condition)
(let loop ([prev (car more)]
[more (cdr more)]
[codomains '()])
@ -438,7 +440,7 @@
(define after-this-one (cdr more))
(cond
[(null? after-this-one)
(values null (cons (car more) codomains))]
(values null (cons (car more) codomains) #t)]
[else
(define kwd (cadr more))
(cond
@ -446,12 +448,26 @@
(loop kwd
(cddr more)
(cons (car more) codomains))]
[(and (not relation?) (equal? (syntax-e kwd) '#:pre))
(when (null? (cddr more))
(raise-syntax-error 'define-metafunction
"expected an expression to follow #:pre keyword"
kwd))
(values (cdddr more)
(cons (car more) codomains)
(caddr more))]
[else
(values (cdr more)
(cons (car more) codomains))])])])))
(cons (car more) codomains)
#t)])])])))
(let ([doms (reverse dom-pats)]
[clauses (check-clauses stx syn-error-name raw-clauses relation?)])
(values #'id doms (reverse rev-codomains) clauses))]
(values #'id
(if relation?
doms
#`(side-condition #,doms (term #,pre-condition)))
(reverse rev-codomains)
clauses))]
[else
(loop (cdr more) (cons (car more) dom-pats))]))])]
[_

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

@ -1143,7 +1143,7 @@
prev-metafunction
(λ ()
(raise-syntax-error syn-error-name "expected a previously defined metafunction" orig-stx prev-metafunction))))
(let*-values ([(contract-name dom-ctcs codom-contracts pats)
(let*-values ([(contract-name dom-ctc codom-contracts pats)
(split-out-contract orig-stx syn-error-name #'rest #f)]
[(name _) (defined-name (list contract-name) pats orig-stx)])
(when (and prev-metafunction (eq? (syntax-e #'name) (syntax-e prev-metafunction)))
@ -1160,7 +1160,7 @@
#,prev-metafunction
name
name-predicate
#,dom-ctcs
#,dom-ctc
#,codom-contracts
#,pats
#,syn-error-name))
@ -1204,9 +1204,9 @@
(define-syntax (generate-metafunction stx)
(syntax-case stx ()
[(_ orig-stx lang prev-metafunction name name-predicate dom-ctcs codom-contracts pats syn-error-name)
[(_ orig-stx lang prev-metafunction name name-predicate dom-ctc codom-contracts pats syn-error-name)
(let ([prev-metafunction (and (syntax-e #'prev-metafunction) #'prev-metafunction)]
[dom-ctcs (syntax-e #'dom-ctcs)]
[dom-ctc (syntax-e #'dom-ctc)]
[codom-contracts (syntax-e #'codom-contracts)]
[pats (syntax-e #'pats)]
[syn-error-name (syntax-e #'syn-error-name)])
@ -1271,12 +1271,12 @@
(syntax-column lhs)))
pats)]
[(dom-side-conditions-rewritten dom-names dom-names/ellipses)
(if dom-ctcs
(if dom-ctc
(rewrite-side-conditions/check-errs
lang-nts
syn-error-name
#f
dom-ctcs)
dom-ctc)
#'(any () ()))]
[((codom-side-conditions-rewritten codom-names codom-names/ellipses) ...)
(map (λ (codom-contract)
@ -1356,7 +1356,7 @@
#`(extend-lhs-pats #,(term-fn-get-id (syntax-local-value prev-metafunction))
new-lhs-pats)
#`new-lhs-pats)))
#,(if dom-ctcs #'dsc #f)
#,(if dom-ctc #'dsc #f)
`(codom-side-conditions-rewritten ...)
'name))))
'disappeared-use

4
collects/redex/private/rewrite-side-conditions.rkt
View File

@ -107,7 +107,9 @@
(if line
(format "~a:?" line)
(syntax-position stx)))))])
(values (syntax/loc term
(values (syntax/loc (if (syntax? term)
term
(datum->syntax #f 'whatever #f))
(side-condition
pre-term
,(lambda (bindings)

22
collects/redex/scribblings/ref.scrbl
View File

@ -1088,7 +1088,10 @@ reduce it further).
[(name @#,ttpattern ...) @#,tttterm metafunction-extras ...]
...)
([metafunction-contract (code:line)
(code:line id : @#,ttpattern-sequence ... -> range)]
(code:line id : @#,ttpattern-sequence ... -> range
maybe-pre-condition)]
[maybe-pre-condition (code:line #:pre @#,tttterm)
(code:line)]
[range @#,ttpattern
(code:line @#,ttpattern or range)
(code:line @#,ttpattern ∨ range)
@ -1107,14 +1110,21 @@ expressions. The first argument indicates the language used
to resolve non-terminals in the pattern expressions. Each of
the rhs-expressions is implicitly wrapped in @|tttterm|.
The contract, if present, is matched against every input to
the metafunction and, if the match fails, an exception is raised.
If present, the term inside the @racket[maybe-pre-condition] is evaluated
after a successful match to the input pattern in the contract (with
any variables from the input contract bound). If
it returns @racket[#f], then the input contract is considered to not
have matched and an error is also raised.
The @racket[side-condition], @racket[hidden-side-condition],
@racket[where], and @racket[where/hidden] clauses behave as
in the @racket[reduction-relation] form.
Raises an exception recognized by @racket[exn:fail:redex?] if
no clauses match, if one of the clauses matches multiple ways
(and that leads to different results for the different matches),
or if the contract is violated.
The resulting metafunction raises an exception recognized by @racket[exn:fail:redex?] if
no clauses match or if one of the clauses matches multiple ways
(and that leads to different results for the different matches).
The @racket[side-condition] extra is evaluated after a successful match
to the corresponding argument pattern. If it returns @racket[#f],
@ -1227,7 +1237,7 @@ and @racket[#f] otherwise.
rule rule ...)
([mode-spec (code:line #:mode (form-id pos-use ...))]
[contract-spec (code:line)
(code:line #:contract (form-id @#,ttpattern ...))]
(code:line #:contract (form-id @#,ttpattern-sequence ...))]
[pos-use I
O]
[rule [premise

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

@ -1133,6 +1133,21 @@
x)
'(2 1)))
(let ()
(define-metafunction empty-language
[(same any_1 any_1) #t]
[(same any_1 any_2) #f])
(define-metafunction empty-language
m : any_1 any_2 -> any_3
#:pre (same any_1 any_2)
[(m any_x any_y) any_x])
(test (term (m 1 1)) 1)
(test (with-handlers ((exn:fail:redex? exn-message))
(term (m 1 2)))
#rx"is not in my domain"))
(let ()
(define-language L
(n z (s n)))

4
doc/release-notes/redex/HISTORY.txt
View File

@ -11,6 +11,10 @@ v5.3.4
pattern is more general than the contract would allow, that those
terms are discarded instead of used as inputs to the predicate.
* Added the #:pre keyword to define-metafunction. It allows
contracts that have to relate different arguments to a
metafunction.
v5.3.3
No changes