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

fixed bug in rendering of reduction relations; they now preserve the relative ordering of side-conditions and where clauses

Browse Source 
svn: r15354
This commit is contained in:
Robby Findler 2009-07-01 16:29:57 +00:00
parent 158b6de824
commit 62bc659ec8
3 changed files with 46 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -120,11 +120,12 @@
(tp (rule-pict-lhs rp))
(tp (rule-pict-rhs rp))
(rule-pict-label rp)
(map tp (rule-pict-side-conditions rp))
(map tp (rule-pict-fresh-vars rp))
(map (lambda (v)
(cons (tp (car v)) (tp (cdr v))))
(rule-pict-pattern-binds rp)))))
(if (pair? v)
(cons (tp (car v)) (tp (cdr v)))
(tp v)))
(rule-pict-side-conditions/pattern-binds rp))
(map tp (rule-pict-fresh-vars rp)))))
(define current-label-extra-space (make-parameter 0))
(define reduction-relation-rule-separation (make-parameter 4))
@ -304,8 +305,7 @@
(define (rp->side-condition-pict rp max-w)
(side-condition-pict (rule-pict-fresh-vars rp)
(append (rule-pict-side-conditions rp)
(rule-pict-pattern-binds rp))
(rule-pict-side-conditions/pattern-binds rp)
max-w))
(define (rp->pict-label rp)

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

@ -391,71 +391,66 @@
(define (rule->lws rule)
(syntax-case rule ()
[(arrow lhs rhs stuff ...)
(let-values ([(label scs fvars withs)
(let-values ([(label scs/withs fvars)
(let loop ([stuffs (syntax->list #'(stuff ...))]
[label #f]
[scs null]
[fvars null]
[withs null])
[scs/withs null]
[fvars null])
(cond
[(null? stuffs) (values label (reverse scs) (reverse fvars) (reverse withs))]
[(null? stuffs) (values label (reverse scs/withs) (reverse fvars))]
[else
(syntax-case (car stuffs) (where fresh variable-not-in)
[(fresh xs ...)
(loop (cdr stuffs)
label
scs
scs/withs
(append
(reverse (map (λ (x)
(syntax-case x ()
[x
(identifier? #'x)
#'x]
[(x whatever)
(identifier? #'x)
#'x]
[((y dots) (x dots2))
(datum->syntax
#f
`(,(syntax->datum #'y) ...)
#'y)]
[((y dots) (x dots2) whatever)
(datum->syntax
#f
`(,(syntax->datum #'y) ...)
#'y)]))
(to-lw/proc
(syntax-case x ()
[x
(identifier? #'x)
#'x]
[(x whatever)
(identifier? #'x)
#'x]
[((y dots) (x dots2))
(datum->syntax
#f
`(,(syntax->datum #'y) ...)
#'y)]
[((y dots) (x dots2) whatever)
(datum->syntax
#f
`(,(syntax->datum #'y) ...)
#'y)])))
(syntax->list #'(xs ...))))
fvars)
withs)]
fvars))]
[(where x e)
(loop (cdr stuffs)
label
scs
fvars
(cons #'(x e) withs))]
(cons #`(cons #,(to-lw/proc #'x) #,(to-lw/proc #'e))
scs/withs)
fvars)]
[(side-condition sc)
(loop (cdr stuffs)
label
(cons #'sc scs)
fvars
withs)]
(cons (to-lw/uq/proc #'sc) scs/withs)
fvars)]
[x
(identifier? #'x)
(loop (cdr stuffs)
#''x
scs
fvars
withs)]
scs/withs
fvars)]
[x
(string? (syntax-e #'x))
(loop (cdr stuffs)
#'x
scs
fvars
withs)])]))])
(with-syntax ([(scs ...) scs]
scs/withs
fvars)])]))])
(with-syntax ([(scs/withs ...) scs/withs]
[(fvars ...) fvars]
[((where-id where-expr) ...) withs]
[((bind-id . bind-pat) ...)
(extract-pattern-binds #'lhs)]
[((tl-id . tl-pat) ...)
@ -464,9 +459,8 @@
#,(to-lw/proc #'lhs)
#,(to-lw/proc #'rhs)
#,label
(list #,@(map to-lw/uq/proc (syntax->list #'(scs ...))))
(list #,@(map to-lw/proc (syntax->list #'(fvars ...))))
(list #,@(map (λ (bind-id bind-pat)
(list scs/withs ...
#,@(map (λ (bind-id bind-pat)
#`(cons #,(to-lw/proc bind-id)
#,(to-lw/proc bind-pat)))
(syntax->list #'(bind-id ...))
@ -475,12 +469,8 @@
#`(cons #,(to-lw/proc tl-id)
#,(to-lw/uq/proc tl-pat)))
(syntax->list #'(tl-id ...))
(syntax->list #'(tl-pat ...)))
#,@(map (λ (where-id where-expr)
#`(cons #,(to-lw/proc where-id)
#,(to-lw/proc where-expr)))
(syntax->list #'(where-id ...))
(syntax->list #'(where-expr ...)))))))]))
(syntax->list #'(tl-pat ...))))
(list fvars ...))))]))
(define (reduction-relation/helper stx orig-name orig-red-expr lang-id rules shortcuts
lws

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

@ -14,7 +14,7 @@
make-rewrite-proc rewrite-proc? rewrite-proc-name rewrite-proc-lhs rewrite-proc-id
(struct-out rule-pict))
(define-struct rule-pict (arrow lhs rhs label side-conditions fresh-vars pattern-binds))
(define-struct rule-pict (arrow lhs rhs label side-conditions/pattern-binds fresh-vars))
;; type proc = (exp exp (any -> any) (listof any) -> (listof any)))
;; a proc is a `cached' version of a make-proc, specialized to a particular langugage