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

moving to the other computer

Browse Source 
svn: r13249
This commit is contained in:
Robby Findler 2009-01-21 16:06:27 +00:00
parent ea0958e362
commit 395d977832
2 changed files with 70 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/redex/private/term-test.ss
View File

@ -76,4 +76,10 @@
(term (((metafun x) y) ...))))
'((whatever 4) (whatever 5) (whatever 6)))
#;
(test (term-let-fn ((metafun (λ (x) x)))
(term-let (((y ...) '(4 5 6)))
(term ((y (metafun 1)) ...))))
'((4 1) (5 1) (6 1)))
(print-tests-passed 'term-test.ss))

108
collects/redex/private/term.ss
View File

@ -24,70 +24,90 @@
(define outer-bindings '())
(define (rewrite stx)
(let-values ([(rewritten has-term-let-bound-id?)
(rewrite/has-term-let-bound-id? stx)])
rewritten))
(define (rewrite/has-term-let-bound-id? stx)
(let loop ([stx stx]
[depth 0])
(syntax-case stx (unquote unquote-splicing in-hole in-named-hole hole hole-here)
[(f arg ...)
(and (identifier? (syntax f))
(term-fn? (syntax-local-value (syntax f) (λ () #f))))
(let ([term-fn (syntax-local-value (syntax f) (λ () #f))])
(with-syntax ([f (term-fn-get-id term-fn)]
[(f-results) (generate-temporaries '(f-results))])
(let d-loop ([arg-dots (loop (syntax (arg ...)) depth)]
[fres (syntax f-results)]
[func (syntax (lambda (x) (f (syntax-object->datum x))))]
[depth depth])
(cond
[(zero? depth)
(let ([res
(with-syntax ([fres fres]
[func func]
[arg-dots arg-dots])
(set! outer-bindings (cons (syntax [fres (func (quasisyntax arg-dots))])
outer-bindings))
(syntax f-results))])
res)]
[else
(with-syntax ([dots (quote-syntax ...)]
[arg-dots arg-dots]
[fres fres])
(d-loop (syntax (arg-dots dots))
(syntax (fres dots))
(with-syntax ([f func])
(syntax (lambda (l) (map f (syntax->list l)))))
(- depth 1)))]))))]
(let-values ([(rewritten has-term-let-bound-id?) (loop (syntax (arg ...)) depth)])
(cond
[(or #t has-term-let-bound-id?)
(let ([term-fn (syntax-local-value (syntax f) (λ () #f))])
(with-syntax ([f (term-fn-get-id term-fn)]
[(f-results) (generate-temporaries '(f-results))])
(let d-loop ([arg-dots rewritten]
[fres (syntax f-results)]
[func (syntax (lambda (x) (f (syntax-object->datum x))))]
[depth depth])
(cond
[(zero? depth)
(let ([res
(with-syntax ([fres fres]
[func func]
[arg-dots arg-dots])
(set! outer-bindings (cons (syntax [fres (func (quasisyntax arg-dots))])
outer-bindings))
(syntax f-results))])
(values res #t))]
[else
(with-syntax ([dots (quote-syntax ...)]
[arg-dots arg-dots]
[fres fres])
(d-loop (syntax (arg-dots dots))
(syntax (fres dots))
(with-syntax ([f func])
(syntax (lambda (l) (map f (syntax->list l)))))
(- depth 1)))]))))]
[else
(with-syntax ([(args ...) rewritten])
(syntax/loc stx (f args ...)))]))]
[f
(and (identifier? (syntax f))
(term-fn? (syntax-local-value (syntax f) (λ () #f))))
(raise-syntax-error 'term "metafunction must be in an application" orig-stx stx)]
[(unquote x)
(syntax (unsyntax x))]
(values (syntax (unsyntax x)) #f)]
[(unquote . x)
(raise-syntax-error 'term "malformed unquote" orig-stx stx)]
[(unquote-splicing x)
(syntax (unsyntax-splicing x))]
(values (syntax (unsyntax-splicing x)) #f)]
[(unquote-splicing . x)
(raise-syntax-error 'term "malformed unquote splicing" orig-stx stx)]
[(in-hole id body)
(syntax (unsyntax (plug (term id) (term body))))]
(values (syntax (unsyntax (plug (term id) (term body)))) #f)]
[(in-hole . x)
(raise-syntax-error 'term "malformed in-hole" orig-stx stx)]
[hole (syntax (unsyntax the-hole))]
[hole (values (syntax (unsyntax the-hole)) #f)]
[(x ...)
(with-syntax ([(x-rewrite ...)
(let i-loop ([xs (syntax->list (syntax (x ...)))])
(cond
[(null? xs) null]
[(null? (cdr xs)) (list (loop (car xs) depth))]
[(and (identifier? (cadr xs))
(free-identifier=? (quote-syntax ...) (cadr xs)))
(cons (loop (car xs) (+ depth 1))
(i-loop (cdr xs)))]
[else
(cons (loop (car xs) depth)
(i-loop (cdr xs)))]))])
(syntax/loc stx (x-rewrite ...)))]
[_ stx])))
(let-values ([(x-rewrite has-term-let-bound-id?)
(let i-loop ([xs (syntax->list (syntax (x ...)))])
(cond
[(null? xs) (values null #f)]
[else
(let ([new-depth (if (and (not (null? (cdr xs)))
(identifier? (cadr xs))
(free-identifier=? (quote-syntax ...)
(cadr xs)))
(+ depth 1)
depth)])
(let-values ([(fst fst-has-term-let-bound-id?)
(loop (car xs) new-depth)]
[(rst rst-has-term-let-bound-id?)
(i-loop (cdr xs))])
(values (cons fst rst)
(or fst-has-term-let-bound-id?
rst-has-term-let-bound-id?))))]))])
(with-syntax ([(x-rewrite ...) x-rewrite])
(values (syntax/loc stx (x-rewrite ...))
has-term-let-bound-id?)))]
[_ (values stx #f)])))
(syntax-case orig-stx ()
[(_ arg)