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

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

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

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

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