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

Fixed bug in extending extended metafunctions.

Browse Source 
svn: r16187
This commit is contained in:
Casey Klein 2009-09-30 16:29:34 +00:00
parent bff757d1e2
commit 38ed68b397
3 changed files with 59 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -994,19 +994,19 @@
(symbol->string (bind-name y)))))) (symbol->string (bind-name y))))))
(define-values (struct:metafunc-proc make-metafunc-proc metafunc-proc? metafunc-proc-ref metafunc-proc-set!) (define-values (struct:metafunc-proc make-metafunc-proc metafunc-proc? metafunc-proc-ref metafunc-proc-set!)
(make-struct-type 'metafunc-proc #f 11 0 #f null (current-inspector) 0)) (make-struct-type 'metafunc-proc #f 8 0 #f null (current-inspector) 0))
(define metafunc-proc-pict-info (make-struct-field-accessor metafunc-proc-ref 1)) (define metafunc-proc-pict-info (make-struct-field-accessor metafunc-proc-ref 1))
(define metafunc-proc-lang (make-struct-field-accessor metafunc-proc-ref 2)) (define metafunc-proc-lang (make-struct-field-accessor metafunc-proc-ref 2))
(define metafunc-proc-multi-arg? (make-struct-field-accessor metafunc-proc-ref 3)) (define metafunc-proc-multi-arg? (make-struct-field-accessor metafunc-proc-ref 3))
(define metafunc-proc-name (make-struct-field-accessor metafunc-proc-ref 4)) (define metafunc-proc-name (make-struct-field-accessor metafunc-proc-ref 4))
(define metafunc-proc-cps (make-struct-field-accessor metafunc-proc-ref 5)) (define metafunc-proc-in-dom? (make-struct-field-accessor metafunc-proc-ref 5))
(define metafunc-proc-rhss (make-struct-field-accessor metafunc-proc-ref 6)) (define metafunc-proc-dom-pat (make-struct-field-accessor metafunc-proc-ref 6))
(define metafunc-proc-in-dom? (make-struct-field-accessor metafunc-proc-ref 7)) (define metafunc-proc-cases (make-struct-field-accessor metafunc-proc-ref 7))
(define metafunc-proc-dom-pat (make-struct-field-accessor metafunc-proc-ref 8))
(define metafunc-proc-lhs-pats (make-struct-field-accessor metafunc-proc-ref 9))
(define metafunc-proc-src-locs (make-struct-field-accessor metafunc-proc-ref 10))
(define-struct metafunction (proc)) (define-struct metafunction (proc))
(define-struct metafunc-case (cp rhs lhs-pat src-loc))
(define-syntax (in-domain? stx) (define-syntax (in-domain? stx)
(syntax-case stx () (syntax-case stx ()
[(_ (name exp ...)) [(_ (name exp ...))
@ -1194,20 +1194,22 @@
[dsc `dom-side-conditions-rewritten] [dsc `dom-side-conditions-rewritten]
cp-let-bindings ... ... cp-let-bindings ... ...
rg-cp-let-bindings ... ...) rg-cp-let-bindings ... ...)
(let ([rg-sc `(rg-side-conditions-rewritten ...)]) (let ([cases (map (λ (pat rhs-fn rg-lhs src)
(build-metafunction (make-metafunc-case
lang (compile-pattern lang pat #t) rhs-fn rg-lhs src))
sc sc
(list rhs-fns ...) (list rhs-fns ...)
`(rg-side-conditions-rewritten ...)
`(clause-src ...))]
[parent-cases
#,(if prev-metafunction #,(if prev-metafunction
(let ([term-fn (syntax-local-value prev-metafunction)]) #`(metafunc-proc-cases #,(term-fn-get-id (syntax-local-value prev-metafunction)))
#`(metafunc-proc-cps #,(term-fn-get-id term-fn))) #'null)])
#''()) (build-metafunction
#,(if prev-metafunction lang
(let ([term-fn (syntax-local-value prev-metafunction)]) cases
#`(metafunc-proc-rhss #,(term-fn-get-id term-fn))) parent-cases
#''()) (λ (f/dom)
(λ (f/dom cps rhss)
(make-metafunc-proc (make-metafunc-proc
(let ([name (lambda (x) (f/dom x))]) name) (let ([name (lambda (x) (f/dom x))]) name)
;; !! This code goes back to phase 1 to call `to-lw', but it's delayed ;; !! This code goes back to phase 1 to call `to-lw', but it's delayed
@ -1261,12 +1263,9 @@
lang lang
#t ;; multi-args? #t ;; multi-args?
'name 'name
cps
rhss
(let ([name (lambda (x) (name-predicate x))]) name) (let ([name (lambda (x) (name-predicate x))]) name)
dsc dsc
rg-sc (append cases parent-cases)))
`(clause-src ...)))
dsc dsc
`codom-side-conditions-rewritten `codom-side-conditions-rewritten
'name 'name
@ -1392,10 +1391,8 @@
"expected a side-condition or where clause" "expected a side-condition or where clause"
(car stuff))])]))])))) (car stuff))])]))]))))
(define (build-metafunction lang patterns rhss old-cps old-rhss wrap dom-contract-pat codom-contract-pat name relation?) (define (build-metafunction lang cases parent-cases wrap dom-contract-pat codom-contract-pat name relation?)
(let ([compiled-patterns (append old-cps (let ([dom-compiled-pattern (and dom-contract-pat (compile-pattern lang dom-contract-pat #f))]
(map (λ (pat) (compile-pattern lang pat #t)) patterns))]
[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-pattern (compile-pattern lang codom-contract-pat #f)])
(values (values
(wrap (wrap
@ -1411,24 +1408,21 @@
(redex-error name (redex-error name
"~s is not in my domain" "~s is not in my domain"
`(,name ,@exp)))) `(,name ,@exp))))
(let loop ([patterns compiled-patterns] (let loop ([cases (append cases parent-cases)]
[rhss (append old-rhss rhss)] [num (- (length parent-cases))])
[num (- (length old-cps))])
(cond (cond
[(null? patterns) [(null? cases)
(if relation? (if relation?
(begin (begin
(hash-set! cache exp #f) (hash-set! cache exp #f)
#f) #f)
(redex-error name "no clauses matched for ~s" `(,name . ,exp)))] (redex-error name "no clauses matched for ~s" `(,name . ,exp)))]
[else [else
(let ([pattern (car patterns)] (let ([pattern (metafunc-case-cp (car cases))]
[rhs (car rhss)]) [rhs (metafunc-case-rhs (car cases))])
(let ([mtchs (match-pattern pattern exp)]) (let ([mtchs (match-pattern pattern exp)])
(cond (cond
[(not mtchs) (loop (cdr patterns) [(not mtchs) (loop (cdr cases) (+ num 1))]
(cdr rhss)
(+ num 1))]
[relation? [relation?
(let ([ans (let ([ans
(ormap (λ (mtch) (ormap values (rhs traced-metafunc (mtch-bindings mtch)))) (ormap (λ (mtch) (ormap values (rhs traced-metafunc (mtch-bindings mtch))))
@ -1440,9 +1434,7 @@
(hash-set! cache exp #t) (hash-set! cache exp #t)
#t] #t]
[else [else
(loop (cdr patterns) (loop (cdr cases) (+ num 1))]))]
(cdr rhss)
(+ num 1))]))]
[else [else
(let ([anss (apply append (let ([anss (apply append
(filter values (filter values
@ -1452,9 +1444,7 @@
(for-each (λ (ans) (hash-set! ht ans #t)) anss) (for-each (λ (ans) (hash-set! ht ans #t)) anss)
(cond (cond
[(null? anss) [(null? anss)
(loop (cdr patterns) (loop (cdr cases) (+ num 1))]
(cdr rhss)
(+ num 1))]
[(not (= 1 (hash-count ht))) [(not (= 1 (hash-count ht)))
(redex-error name "~a matched ~s ~a different ways and returned different results" (redex-error name "~a matched ~s ~a different ways and returned different results"
(if (< num 0) (if (< num 0)
@ -1482,12 +1472,10 @@
(ot name (car args) kws kw-args level))]) (ot name (car args) kws kw-args level))])
(trace-call name metafunc exp)) (trace-call name metafunc exp))
(metafunc exp)))]) (metafunc exp)))])
traced-metafunc) traced-metafunc))
compiled-patterns
rhss)
(if dom-compiled-pattern (if dom-compiled-pattern
(λ (exp) (and (match-pattern dom-compiled-pattern exp) #t)) (λ (exp) (and (match-pattern dom-compiled-pattern exp) #t))
(λ (exp) (and (ormap (λ (pat) (match-pattern pat exp)) compiled-patterns) (λ (exp) (and (ormap (λ (case) (match-pattern (metafunc-case-cp case) exp)) cases)
#t)))))) #t))))))
(define current-traced-metafunctions (make-parameter '())) (define current-traced-metafunctions (make-parameter '()))
@ -2149,13 +2137,11 @@
metafunc-proc-pict-info metafunc-proc-pict-info
metafunc-proc-name metafunc-proc-name
metafunc-proc-multi-arg? metafunc-proc-multi-arg?
metafunc-proc-cps
metafunc-proc-rhss
metafunc-proc-in-dom? metafunc-proc-in-dom?
metafunc-proc-dom-pat metafunc-proc-dom-pat
metafunc-proc-lhs-pats metafunc-proc-cases
metafunc-proc-src-locs
metafunc-proc? metafunc-proc?
(struct-out metafunc-case)
(struct-out binds)) (struct-out binds))

8
collects/redex/private/rg.ss
View File

@ -767,7 +767,7 @@
(if source-stx (if source-stx
#`(let-values ([(metafunc/red-rel num-cases) #`(let-values ([(metafunc/red-rel num-cases)
#,(cond [(and (identifier? source-stx) (metafunc source-stx)) #,(cond [(and (identifier? source-stx) (metafunc source-stx))
=> (λ (x) #`(values #,x (length (metafunc-proc-lhs-pats #,x))))] => (λ (x) #`(values #,x (length (metafunc-proc-cases #,x))))]
[else [else
#`(let ([r (assert-rel 'redex-check #,source-stx)]) #`(let ([r (assert-rel 'redex-check #,source-stx)])
(values r (length (reduction-relation-make-procs r))))])]) (values r (length (reduction-relation-make-procs r))))])])
@ -858,7 +858,7 @@
(let ([lang-gen (generate lang decisions@ custom retries what)]) (let ([lang-gen (generate lang decisions@ custom retries what)])
(let-values ([(pats srcs) (let-values ([(pats srcs)
(cond [(metafunc-proc? mf/rr) (cond [(metafunc-proc? mf/rr)
(values (metafunc-proc-lhs-pats mf/rr) (values (map metafunc-case-lhs-pat (metafunc-proc-cases mf/rr))
(metafunction-srcs mf/rr))] (metafunction-srcs mf/rr))]
[(reduction-relation? mf/rr) [(reduction-relation? mf/rr)
(values (map (λ (rwp) ((rewrite-proc-lhs rwp) lang)) (reduction-relation-make-procs mf/rr)) (values (map (λ (rwp) ((rewrite-proc-lhs rwp) lang)) (reduction-relation-make-procs mf/rr))
@ -911,8 +911,8 @@
(reduction-relation-make-procs r))) (reduction-relation-make-procs r)))
(define (metafunction-srcs m) (define (metafunction-srcs m)
(map (curry format "clause at ~a") (map (compose (curry format "clause at ~a") metafunc-case-src-loc)
(metafunc-proc-src-locs m))) (metafunc-proc-cases m)))
(define-syntax (check-reduction-relation stx) (define-syntax (check-reduction-relation stx)
(syntax-case stx () (syntax-case stx ()

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

@ -445,16 +445,22 @@
[(f (any_1 any_2 any_3)) 3]) [(f (any_1 any_2 any_3)) 3])
(define-metafunction/extension f empty-language (define-metafunction/extension f empty-language
[(g (any_1 any_2)) 2]) [(g (any_1 any_2)) 2])
(test (term (g (1 2))) 2) (define-metafunction/extension g empty-language
(test (term (g (1 2 3))) 3)) [(h (any_1)) 1])
(test (term (h (1))) 1)
(test (term (h (1 2))) 2)
(test (term (h (1 2 3))) 3))
(let () (let ()
(define-metafunction empty-language (define-metafunction empty-language
[(f any_1 any_2 any_3) 3]) [(f any_1 any_2 any_3) 3])
(define-metafunction/extension f empty-language (define-metafunction/extension f empty-language
[(g any_1 any_2) 2]) [(g any_1 any_2) 2])
(test (term (g 1 2)) 2) (define-metafunction/extension g empty-language
(test (term (g 1 2 3)) 3)) [(h any_1) 1])
(test (term (h 1)) 1)
(test (term (h 1 2)) 2)
(test (term (h 1 2 3)) 3))
(let () (let ()
(define-metafunction empty-language (define-metafunction empty-language