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

accidentally committed some changes on the branch, now moving back to trunk (w/ some conflicts, argh!): fixed a bug in the way redex expanded metafunctions (it had old code left in there) and improved error messages for domain failures in reduction relations

Browse Source 
svn: r15317
This commit is contained in:
Robby Findler 2009-06-27 13:47:02 +00:00
parent 440ab66ae7
commit ea6c99c69f
6 changed files with 258 additions and 217 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/redex/private/bitmap-test.ss
View File

@ -36,6 +36,20 @@
(extend-reduction-relation red lang (--> 1 2)))
"extended-reduction-relation.png")
;; this test should fail because it gets the order wrong
;; for the where/side-conditions
(define red2
(reduction-relation
lang
(--> (number_a number_b number_c)
any_z
(where (any_x any_y) (number_a number_b))
(side-condition (= (term number_c) 5))
(where any_z any_x))))
(test (render-reduction-relation red2)
"red2.png")
(define-metafunction lang
[(S x v e) e])
@ -92,7 +106,6 @@
(render-metafunction Name))
"metafunction-Name-vertical.png")
;; makes sure that there is no overlap inside or across metafunction calls
;; or when there are unquotes involved
(define-metafunction lang

BIN
collects/redex/private/bmps/metafunction-Name-vertical.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 4.7 KiB

After

Width:  |  Height:  |  Size: 4.7 KiB

28
collects/redex/private/pict.ss
View File

@ -251,7 +251,10 @@
ltl-superimpose ltl-superimpose
(list* 2 (+ 2 (current-label-extra-space))) 2)))
(define (side-condition-pict fresh-vars side-conditions pattern-binds max-w)
;; side-condition-pict : (listof pict) (listof (or/c (cons/c pict pict) pict)) number -> pict
;; the elements of pattern-binds/sc that are pairs are bindings (ie "x = <something>")
;; and the elements of pattern-binds/sc that are just picts are just plain side-conditions
(define (side-condition-pict fresh-vars pattern-binds/sc max-w)
(let* ([frsh
(if (null? fresh-vars)
null
@ -264,16 +267,17 @@
fresh-vars))
(basic-text " fresh" (default-style)))))]
[binds (map (lambda (b)
(if (pair? b)
(htl-append
(car b)
(make-=)
(cdr b)))
pattern-binds)]
(cdr b))
b))
pattern-binds/sc)]
[lst (add-between
'comma
(append
binds
side-conditions
frsh))])
(if (null? lst)
(blank)
@ -293,8 +297,8 @@
(define (rp->side-condition-pict rp max-w)
(side-condition-pict (rule-pict-fresh-vars rp)
(rule-pict-side-conditions rp)
(rule-pict-pattern-binds rp)
(append (rule-pict-side-conditions rp)
(rule-pict-pattern-binds rp))
max-w))
(define (rp->pict-label rp)
@ -737,21 +741,21 @@
[eqns (select-cases all-eqns)]
[lhss (select-cases all-lhss)]
[scs (map (lambda (eqn)
(if (and (null? (list-ref eqn 1))
(null? (list-ref eqn 2)))
(if (null? (list-ref eqn 1))
#f
(side-condition-pict null
(map wrapper->pict (list-ref eqn 1))
(map (lambda (p)
(if (pair? p)
(cons (wrapper->pict (car p))
(wrapper->pict (cdr p))))
(list-ref eqn 2))
(wrapper->pict (cdr p)))
(wrapper->pict p)))
(list-ref eqn 1))
(if (memq style '(up-down/vertical-side-conditions
left-right/vertical-side-conditions))
0
+inf.0))))
eqns)]
[rhss (map (lambda (eqn) (wrapper->pict (list-ref eqn 3))) eqns)]
[rhss (map (lambda (eqn) (wrapper->pict (list-ref eqn 2))) eqns)]
[linebreak-list (or current-linebreaks
(map (lambda (x) #f) eqns))]
[=-pict (make-=)]

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

@ -1165,41 +1165,45 @@
#f
codom-contract)]
[(rhs-fns ...)
(map (λ (lhs rhs/where bindings)
(map (λ (lhs rhs/where)
(let-values ([(names names/ellipses)
(extract-names lang-nts syn-error-name #t lhs)])
(with-syntax ([(names ...) names]
[(names/ellipses ...) names/ellipses]
[rhs/where rhs/where]
[((tl-var tl-exp) ...) bindings])
[rhs/where rhs/where])
(syntax
(λ (name bindings)
(term-let-fn ((name name))
(term-let ([names/ellipses (lookup-binding bindings 'names)] ...)
(term-let ([tl-var (term tl-exp)] ...)
rhs/where))))))))
rhs/where)))))))
(syntax->list (syntax (lhs ...)))
(syntax->list (syntax (rhs/wheres ...)))
(syntax->list (syntax (tl-bindings ...))))]
(syntax->list (syntax (rhs/wheres ...))))]
[(name2 name-predicate) (generate-temporaries (syntax (name name)))]
[((side-cond/lw/uq ...) ...)
(map (lambda (scs) (map to-lw/uq/proc (syntax->list scs)))
(syntax->list #'((tl-side-conds ...) ...)))]
[(((bind-id/lw . bind-pat/lw) ...) ...)
;; Also for pict, extract pattern bindings
(map (λ (x) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/proc (cdr x))))
(extract-pattern-binds x)))
(syntax->list #'(lhs ...)))]
[((where/sc/lw ...) ...)
;; Also for pict, extract where bindings
(map (λ (hm)
(map
(λ (lst)
(syntax-case lst (side-condition where)
[(where pat exp)
#`(cons #,(to-lw/proc #'pat) #,(to-lw/proc #'exp))]
[(side-condition x)
(to-lw/uq/proc #'x)]))
(syntax->list hm)))
(syntax->list #'(tl-side-cond/binds ...)))]
[(((rhs-bind-id/lw . rhs-bind-pat/lw/uq) ...) ...)
;; Also for pict, extract pattern bindings
(map (λ (x) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/uq/proc (cdr x))))
(extract-term-let-binds x)))
(syntax->list #'(rhs ...)))]
[(((where-id/lw where-pat/lw) ...) ...)
;; Also for pict, extract where bindings
(map (λ (lst) (map (λ (ab) (map to-lw/proc (syntax->list ab)))
(syntax->list lst)))
(syntax->list #'(tl-bindings ...)))])
(syntax->list #'(rhs ...)))])
(syntax-property
#`(begin
(define-values (name2 name-predicate)
@ -1224,10 +1228,9 @@
(make-metafunc-proc
(let ([name (lambda (x) (f/dom x))]) name)
(list (list lhs-for-lw
(list side-cond/lw/uq ...)
(list (cons bind-id/lw bind-pat/lw) ...
(cons rhs-bind-id/lw rhs-bind-pat/lw/uq) ...
(cons where-id/lw where-pat/lw) ...)
where/sc/lw ...)
rhs/lw)
...)
lang
@ -1430,7 +1433,7 @@
(redex-error name "~a matched ~s ~a different ways and returned different results"
(if (< num 0)
"a clause from an extended metafunction"
(format "clause ~a" num))
(format "clause #~a (counting from 0)" num))
`(,name ,@exp)
(length mtchs))]
[else

22
collects/redex/private/struct.ss
View File

@ -50,8 +50,13 @@
;; I started to add it, but didn't finish. -robby
(define (build-reduction-relation orig-reduction-relation lang make-procs rule-names lws domain-pattern)
(let* ([make-procs/check-domain
(map (λ (make-proc)
(make-rewrite-proc
(let loop ([make-procs make-procs]
[i 0])
(cond
[(null? make-procs) null]
[else
(let ([make-proc (car make-procs)])
(cons (make-rewrite-proc
(λ (lang)
(let ([compiled-domain-pat (compile-pattern lang domain-pattern #f)]
[proc (make-proc lang)])
@ -63,14 +68,19 @@
(λ (res)
(let ([term (cadr res)])
(unless (match-pattern compiled-domain-pat term)
(error 'reduction-relation "relation reduced to ~s, which is outside its domain"
term))))
(error 'reduction-relation "relation reduced to ~s via ~a, which is outside its domain"
term
(let ([name (rewrite-proc-name make-proc)])
(if name
(format "the rule named ~a" name)
(format "rule #~a (counting from 0)" i)))))))
ress)
ress))))
(rewrite-proc-name make-proc)
(rewrite-proc-lhs make-proc)
(rewrite-proc-id make-proc)))
make-procs)])
(rewrite-proc-id make-proc))
(loop (cdr make-procs)
(+ i 1))))]))])
(cond
[orig-reduction-relation
(let* ([new-names (map rewrite-proc-name make-procs)]

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

@ -647,6 +647,17 @@
(test (term (ex quote)) (term quote)))
(let ()
(define-metafunction empty-language
[(f any ...)
(any ...)
(where variable_1 x)
(side-condition #f)
(where (number ...) y)]
[(f any ...)
12345])
(test (term (f 8)) 12345))
;
@ -924,7 +935,7 @@
(with-handlers ((exn? exn-message))
(apply-reduction-relation red 1)
'no-exception-raised))
"reduction-relation: relation reduced to x, which is outside its domain")
"reduction-relation: relation reduced to x via rule #0 (counting from 0), which is outside its domain")
(let* ([red1
(reduction-relation