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

PR 10042 (plus some fixes to earlier Stevie-submitted PRs that werent quite right)

Browse Source 
svn: r13447
This commit is contained in:
Robby Findler 2009-02-05 01:42:00 +00:00
parent 57208dfe14
commit 7e48db0a82
5 changed files with 31 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -92,5 +92,15 @@
(render-metafunction Name))
"metafunction-Name-vertical.png")
(define-metafunction lang
[(multi-arg a
b
c)
(multi-arg a
b
c)])
(test (render-metafunction multi-arg) "metafunction-multi-arg.png")
(printf "bitmap-test.ss: ")
(done)

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

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 3.4 KiB

After

Width:  |  Height:  |  Size: 3.4 KiB

BIN
collects/redex/private/bmps/metafunction.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.1 KiB

After

Width:  |  Height:  |  Size: 1.0 KiB

BIN
collects/redex/private/bmps/reduction-relation.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.7 KiB

After

Width:  |  Height:  |  Size: 1.7 KiB

49
collects/redex/private/core-layout.ss
View File

@ -188,16 +188,6 @@
(pair? (cdr content))
(lw? (cadr content))
(equal? 'term-let (lw-e (cadr content))))
#;
(struct-copy lw
an-lw
[e (adjust-spacing (lw-e (second-to-last content))
(lw-line an-lw)
(lw-line-span an-lw)
(lw-column an-lw)
(lw-column-span an-lw)
'term-let-rewriter)])
(struct-copy lw
an-lw
[e (append (list (just-before "" an-lw) 'spring)
@ -246,9 +236,9 @@
(pair? (cdr e))
(lw? (cadr e))
(lw-metafunction? (cadr e)))
(map ar/lw (adjust-spacing (rewrite-metafunction-app e)
line line-span col col-span
(lw-e (cadr e))))]
(map ar/lw (rewrite-metafunction-app e
line line-span col col-span
(lw-e (cadr e))))]
[else
(map ar/lw e)]))
(ar/lw orig-lw))
@ -266,21 +256,24 @@
snd
(car l))]))]))
(define (rewrite-metafunction-app lst)
(cons (hbl-append
(metafunction-text (symbol->string (lw-e (cadr lst))))
(open-white-square-bracket))
(let loop ([lst (cddr lst)])
(cond
[(null? lst) null]
[(null? (cdr lst))
(let ([last (car lst)])
(list (just-before (close-white-square-bracket) last) ""))]
[(null? (cddr lst))
(cons (car lst) (loop (cdr lst)))]
[else (list* (car lst)
(basic-text ", " (default-style))
(loop (cdr lst)))]))))
(define (rewrite-metafunction-app lst line line-span col col-span something-or-other)
(list* 'spring
(just-after (hbl-append
(metafunction-text (symbol->string (lw-e (cadr lst))))
(open-white-square-bracket))
(cadr lst))
'spring
(let loop ([lst (cddr lst)])
(cond
[(null? lst) null]
[(null? (cdr lst))
(let ([last (car lst)])
(list (just-before (close-white-square-bracket) last)))]
[(null? (cddr lst))
(cons (car lst) (loop (cdr lst)))]
[else (list* (car lst)
(just-after (basic-text "," (default-style)) (car lst))
(loop (cdr lst)))]))))
(define (just-before what lw)
(build-lw (if (symbol? what)