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

`where' clauses now properly bind in metafunctions

Browse Source 
svn: r14712
This commit is contained in:
Casey Klein 2009-05-04 13:59:42 +00:00
parent 83cd3964f4
commit 039d24fc17
3 changed files with 188 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -199,6 +199,42 @@
[(_ orig-reduction-relation lang args ...) [(_ orig-reduction-relation lang args ...)
#'(do-reduction-relation extend-reduction-relation orig-reduction-relation #t lang args ...)])) #'(do-reduction-relation extend-reduction-relation orig-reduction-relation #t lang args ...)]))
;; the withs, freshs, and side-conditions come in backwards order
(define-for-syntax (bind-withs orig-name main stx body)
(let loop ([stx stx]
[body body])
(syntax-case stx (side-condition where fresh)
[() body]
[((where x e) y ...)
(loop #'(y ...) #`(term-let ([x (term e)]) #,body))]
[((side-condition s ...) y ...)
(loop #'(y ...) #`(and s ... #,body))]
[((fresh x) y ...)
(identifier? #'x)
(loop #'(y ...) #`(term-let ([x (variable-not-in #,main 'x)]) #,body))]
[((fresh x name) y ...)
(identifier? #'x)
(loop #'(y ...)
#`(term-let ([x (let ([the-name (term name)])
(verify-name-ok '#,orig-name the-name)
(variable-not-in #,main the-name))])
#,body))]
[((fresh (y) (x ...)) z ...)
(loop #'(z ...)
#`(term-let ([(y #,'...)
(variables-not-in #,main
(map (λ (_ignore_) 'y)
(term (x ...))))])
#,body))]
[((fresh (y) (x ...) names) z ...)
(loop #'(z ...)
#`(term-let ([(y #,'...)
(let ([the-names (term names)]
[len-counter (term (x ...))])
(verify-names-ok '#,orig-name the-names len-counter)
(variables-not-in #,main the-names))])
#,body))])))
(define-struct successful (result)) (define-struct successful (result))
(define-syntax-set (do-reduction-relation) (define-syntax-set (do-reduction-relation)
@ -608,42 +644,6 @@
#,(bind-withs orig-name #'main sides/withs/freshs #,(bind-withs orig-name #'main sides/withs/freshs
#'(make-successful (term to))))))))))) #'(make-successful (term to)))))))))))
;; the withs, freshs, and side-conditions come in backwards order
(define (bind-withs orig-name main stx body)
(let loop ([stx stx]
[body body])
(syntax-case stx (side-condition where fresh)
[() body]
[((where x e) y ...)
(loop #'(y ...) #`(term-let ([x (term e)]) #,body))]
[((side-condition s ...) y ...)
(loop #'(y ...) #`(and s ... #,body))]
[((fresh x) y ...)
(identifier? #'x)
(loop #'(y ...) #`(term-let ([x (variable-not-in #,main 'x)]) #,body))]
[((fresh x name) y ...)
(identifier? #'x)
(loop #'(y ...)
#`(term-let ([x (let ([the-name (term name)])
(verify-name-ok '#,orig-name the-name)
(variable-not-in #,main the-name))])
#,body))]
[((fresh (y) (x ...)) z ...)
(loop #'(z ...)
#`(term-let ([(y #,'...)
(variables-not-in #,main
(map (λ (_ignore_) 'y)
(term (x ...))))])
#,body))]
[((fresh (y) (x ...) names) z ...)
(loop #'(z ...)
#`(term-let ([(y #,'...)
(let ([the-names (term names)]
[len-counter (term (x ...))])
(verify-names-ok '#,orig-name the-names len-counter)
(variables-not-in #,main the-names))])
#,body))])))
(define (process-extras stx orig-name name-table extras) (define (process-extras stx orig-name name-table extras)
(let ([the-name #f] (let ([the-name #f]
[the-name-stx #f] [the-name-stx #f]
@ -1012,114 +1012,117 @@
(loop name (cdr names))]))]) (loop name (cdr names))]))])
(with-syntax ([(((tl-side-conds ...) ...) (with-syntax ([(((tl-side-conds ...) ...)
(tl-bindings ...)) (tl-bindings ...)
(extract-side-conditions (syntax-e #'name) stx #'((stuff ...) ...))]) (tl-side-cond/binds ...))
(parse-extras #'((stuff ...) ...))])
(let ([lang-nts (language-id-nts #'lang 'define-metafunction)]) (let ([lang-nts (language-id-nts #'lang 'define-metafunction)])
(with-syntax ([(side-conditions-rewritten ...) (with-syntax ([(tl-withs ...) (map (λ (sc/b) (bind-withs syn-error-name '() sc/b #t))
(map (λ (x) (rewrite-side-conditions/check-errs (syntax->list #'(tl-side-cond/binds ...)))])
lang-nts (with-syntax ([(side-conditions-rewritten ...)
'define-metafunction (map (λ (x) (rewrite-side-conditions/check-errs
#t lang-nts
x)) 'define-metafunction
(syntax->list (syntax ((side-condition lhs (and tl-side-conds ...)) ...))))] #t
[dom-side-conditions-rewritten x))
(and dom-ctcs (syntax->list (syntax ((side-condition lhs tl-withs) ...))))]
(rewrite-side-conditions/check-errs [dom-side-conditions-rewritten
lang-nts (and dom-ctcs
'define-metafunction (rewrite-side-conditions/check-errs
#f lang-nts
dom-ctcs))] 'define-metafunction
[codom-side-conditions-rewritten #f
(rewrite-side-conditions/check-errs dom-ctcs))]
lang-nts [codom-side-conditions-rewritten
'define-metafunction (rewrite-side-conditions/check-errs
#f lang-nts
codom-contract)] 'define-metafunction
[(rhs-fns ...) #f
(map (λ (lhs rhs bindings) codom-contract)]
(let-values ([(names names/ellipses) (extract-names lang-nts 'define-metafunction #t lhs)]) [(rhs-fns ...)
(with-syntax ([(names ...) names] (map (λ (lhs rhs bindings)
[(names/ellipses ...) names/ellipses] (let-values ([(names names/ellipses) (extract-names lang-nts 'define-metafunction #t lhs)])
[rhs rhs] (with-syntax ([(names ...) names]
[((tl-var tl-exp) ...) bindings]) [(names/ellipses ...) names/ellipses]
(syntax [rhs rhs]
(λ (name bindings) [((tl-var tl-exp) ...) bindings])
(term-let-fn ((name name)) (syntax
(term-let ([names/ellipses (lookup-binding bindings 'names)] ...) (λ (name bindings)
(term-let ([tl-var (term tl-exp)] ...) (term-let-fn ((name name))
(term rhs))))))))) (term-let ([names/ellipses (lookup-binding bindings 'names)] ...)
(syntax->list (syntax (lhs ...))) (term-let ([tl-var (term tl-exp)] ...)
(syntax->list (syntax (rhs ...))) (term rhs)))))))))
(syntax->list (syntax (tl-bindings ...))))] (syntax->list (syntax (lhs ...)))
[(name2 name-predicate) (generate-temporaries (syntax (name name)))] (syntax->list (syntax (rhs ...)))
[((side-cond ...) ...) (syntax->list (syntax (tl-bindings ...))))]
;; For generating a pict, separate out side conditions wrapping the LHS and at the top-level [(name2 name-predicate) (generate-temporaries (syntax (name name)))]
(map (lambda (lhs scs) [((side-cond ...) ...)
(append ;; For generating a pict, separate out side conditions wrapping the LHS and at the top-level
(let loop ([lhs lhs]) (map (lambda (lhs scs)
(syntax-case lhs (side-condition term) (append
[(side-condition pat (term sc)) (let loop ([lhs lhs])
(cons #'sc (loop #'pat))] (syntax-case lhs (side-condition term)
[_else null])) [(side-condition pat (term sc))
scs)) (cons #'sc (loop #'pat))]
(syntax->list #'(lhs ...)) [_else null]))
(syntax->list #'((tl-side-conds ...) ...)))] scs))
[(((bind-id . bind-pat) ...) ...) (syntax->list #'(lhs ...))
;; Also for pict, extract pattern bindings (syntax->list #'((tl-side-conds ...) ...)))]
(map extract-pattern-binds (syntax->list #'(lhs ...)))] [(((bind-id . bind-pat) ...) ...)
[(((rhs-bind-id . rhs-bind-pat) ...) ...) ;; Also for pict, extract pattern bindings
;; Also for pict, extract pattern bindings (map extract-pattern-binds (syntax->list #'(lhs ...)))]
(map extract-term-let-binds (syntax->list #'(rhs ...)))] [(((rhs-bind-id . rhs-bind-pat) ...) ...)
[(((where-id where-pat) ...) ...) ;; Also for pict, extract pattern bindings
;; Also for pict, extract where bindings (map extract-term-let-binds (syntax->list #'(rhs ...)))]
#'(tl-bindings ...)]) [(((where-id where-pat) ...) ...)
(syntax-property ;; Also for pict, extract where bindings
#`(begin #'(tl-bindings ...)])
(define-values (name2 name-predicate) (syntax-property
(let ([sc `(side-conditions-rewritten ...)] #`(begin
[dsc `dom-side-conditions-rewritten]) (define-values (name2 name-predicate)
(build-metafunction (let ([sc `(side-conditions-rewritten ...)]
lang [dsc `dom-side-conditions-rewritten])
sc (build-metafunction
(list rhs-fns ...) lang
#,(if prev-metafunction sc
(let ([term-fn (syntax-local-value prev-metafunction)]) (list rhs-fns ...)
#`(metafunc-proc-cps #,(term-fn-get-id term-fn))) #,(if prev-metafunction
#''()) (let ([term-fn (syntax-local-value prev-metafunction)])
#,(if prev-metafunction #`(metafunc-proc-cps #,(term-fn-get-id term-fn)))
(let ([term-fn (syntax-local-value prev-metafunction)]) #''())
#`(metafunc-proc-rhss #,(term-fn-get-id term-fn))) #,(if prev-metafunction
#''()) (let ([term-fn (syntax-local-value prev-metafunction)])
(λ (f/dom cps rhss) #`(metafunc-proc-rhss #,(term-fn-get-id term-fn)))
(make-metafunc-proc #''())
(let ([name (lambda (x) (f/dom x))]) name) (λ (f/dom cps rhss)
(list (list (to-lw lhs-for-lw) (make-metafunc-proc
(list (to-lw/uq side-cond) ...) (let ([name (lambda (x) (f/dom x))]) name)
(list (cons (to-lw bind-id) (list (list (to-lw lhs-for-lw)
(to-lw bind-pat)) (list (to-lw/uq side-cond) ...)
... (list (cons (to-lw bind-id)
(cons (to-lw rhs-bind-id) (to-lw bind-pat))
(to-lw/uq rhs-bind-pat)) ...
... (cons (to-lw rhs-bind-id)
(cons (to-lw where-id) (to-lw/uq rhs-bind-pat))
(to-lw where-pat)) ...
...) (cons (to-lw where-id)
(to-lw rhs)) (to-lw where-pat))
...) ...)
lang (to-lw rhs))
#t ;; multi-args? ...)
'name lang
cps #t ;; multi-args?
rhss 'name
(let ([name (lambda (x) (name-predicate x))]) name) cps
dsc rhss
sc)) (let ([name (lambda (x) (name-predicate x))]) name)
dsc dsc
'codom-side-conditions-rewritten sc))
'name))) dsc
(term-define-fn name name2)) 'codom-side-conditions-rewritten
'disappeared-use 'name)))
(map syntax-local-introduce (syntax->list #'(original-names ...)))))))))))] (term-define-fn name name2))
'disappeared-use
(map syntax-local-introduce (syntax->list #'(original-names ...))))))))))))]
[(_ prev-metafunction name lang clauses ...) [(_ prev-metafunction name lang clauses ...)
(begin (begin
(unless (identifier? #'name) (unless (identifier? #'name)
@ -1199,31 +1202,38 @@
(syntax->list #'(x ...))) (syntax->list #'(x ...)))
(raise-syntax-error syn-error-name "error checking failed.2" stx))])) (raise-syntax-error syn-error-name "error checking failed.2" stx))]))
(define (extract-side-conditions name stx stuffs) (define (parse-extras extras)
(let loop ([stuffs (syntax->list stuffs)] (let loop ([stuffs (syntax->list extras)]
[side-conditionss '()] [side-conditionss '()]
[bindingss '()]) [bindingss '()]
[bothss '()])
(cond (cond
[(null? stuffs) (list (reverse side-conditionss) [(null? stuffs) (list (reverse side-conditionss)
(reverse bindingss))] (reverse bindingss)
(reverse bothss))]
[else [else
(let s-loop ([stuff (syntax->list (car stuffs))] (let s-loop ([stuff (syntax->list (car stuffs))]
[side-conditions '()] [side-conditions '()]
[bindings '()]) [bindings '()]
[boths '()])
(cond (cond
[(null? stuff) (loop (cdr stuffs) [(null? stuff) (loop (cdr stuffs)
(cons (reverse side-conditions) side-conditionss) (cons (reverse side-conditions) side-conditionss)
(cons (reverse bindings) bindingss))] (cons (reverse bindings) bindingss)
; Want these in reverse order.
(cons boths bothss))]
[else [else
(syntax-case (car stuff) (where side-condition) (syntax-case (car stuff) (where side-condition)
[(side-condition tl-side-conds ...) [(side-condition tl-side-conds ...)
(s-loop (cdr stuff) (s-loop (cdr stuff)
(append (syntax->list #'(tl-side-conds ...)) side-conditions) (append (syntax->list #'(tl-side-conds ...)) side-conditions)
bindings)] bindings
(cons (car stuff) boths))]
[(where x e) [(where x e)
(s-loop (cdr stuff) (s-loop (cdr stuff)
side-conditions side-conditions
(cons #'(x e) bindings))] (cons #'(x e) bindings)
(cons (car stuff) boths))]
[_ [_
(raise-syntax-error 'define-metafunction (raise-syntax-error 'define-metafunction
"expected a side-condition or where clause" "expected a side-condition or where clause"

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

@ -820,11 +820,13 @@
; check-metafunction ; check-metafunction
(let () (let ()
(define-language empty) (define-language empty)
(define-metafunction empty (define-metafunction empty
[(m 1) whatever] [(m 1) whatever]
[(m 2) whatever]) [(m 2) whatever])
(define-metafunction empty (define-metafunction empty
[(n (side-condition any #f)) any]) [(n (side-condition any #f)) any])
(let ([generated null]) (let ([generated null])
(test (begin (test (begin
(output (output
@ -832,6 +834,20 @@
(check-metafunction m (λ (t) (set! generated (cons t generated))) #:attempts 1))) (check-metafunction m (λ (t) (set! generated (cons t generated))) #:attempts 1)))
generated) generated)
(reverse '((1) (2))))) (reverse '((1) (2)))))
(test
(let/ec k
(define-language L (n 2))
(define-metafunction L
[(f n)
n
(where number_2 ,(add1 (term n)))
(where number_3 ,(add1 (term number_2)))
(side-condition (k (term number_3)))]
[(f any) 0])
(check-metafunction f (λ (_) #t)))
4)
(test (output (λ () (check-metafunction m (λ (_) #t)))) #rx"no counterexamples") (test (output (λ () (check-metafunction m (λ (_) #t)))) #rx"no counterexamples")
(test (output (λ () (check-metafunction m (curry eq? 1)))) (test (output (λ () (check-metafunction m (curry eq? 1))))
#rx"check-metafunction:.*counterexample found after 1 attempt with clause #1") #rx"check-metafunction:.*counterexample found after 1 attempt with clause #1")

11
collects/redex/private/tl-test.ss
View File

@ -482,6 +482,17 @@
(test (term (f z)) (test (term (f z))
(term ((z z) (z z))))) (term ((z z) (z z)))))
(let ()
(define-metafunction empty-language
[(f number_1)
number_1
(where number_2 ,(add1 (term number_1)))
(where number_3 ,(add1 (term number_2)))
(side-condition (and (number? (term number_3))
(= (term number_3) 4)))]
[(f any) 0])
(test (term (f 2)) 2))
(let () (let ()
(define-language x-lang (define-language x-lang
(x variable)) (x variable))