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) ...)))) (term (((metafun x) y) ...))))
'((whatever 4) (whatever 5) (whatever 6))) '((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)) (print-tests-passed 'term-test.ss))

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

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