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))

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

@ -24,16 +24,24 @@
(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-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))]) (let ([term-fn (syntax-local-value (syntax f) (λ () #f))])
(with-syntax ([f (term-fn-get-id term-fn)] (with-syntax ([f (term-fn-get-id term-fn)]
[(f-results) (generate-temporaries '(f-results))]) [(f-results) (generate-temporaries '(f-results))])
(let d-loop ([arg-dots (loop (syntax (arg ...)) depth)] (let d-loop ([arg-dots rewritten]
[fres (syntax f-results)] [fres (syntax f-results)]
[func (syntax (lambda (x) (f (syntax-object->datum x))))] [func (syntax (lambda (x) (f (syntax-object->datum x))))]
[depth depth]) [depth depth])
@ -46,7 +54,7 @@
(set! outer-bindings (cons (syntax [fres (func (quasisyntax arg-dots))]) (set! outer-bindings (cons (syntax [fres (func (quasisyntax arg-dots))])
outer-bindings)) outer-bindings))
(syntax f-results))]) (syntax f-results))])
res)] (values res #t))]
[else [else
(with-syntax ([dots (quote-syntax ...)] (with-syntax ([dots (quote-syntax ...)]
[arg-dots arg-dots] [arg-dots arg-dots]
@ -56,38 +64,50 @@
(with-syntax ([f func]) (with-syntax ([f func])
(syntax (lambda (l) (map f (syntax->list l))))) (syntax (lambda (l) (map f (syntax->list l)))))
(- depth 1)))]))))] (- 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))]
[(and (identifier? (cadr xs))
(free-identifier=? (quote-syntax ...) (cadr xs)))
(cons (loop (car xs) (+ depth 1))
(i-loop (cdr xs)))]
[else [else
(cons (loop (car xs) depth) (let ([new-depth (if (and (not (null? (cdr xs)))
(i-loop (cdr xs)))]))]) (identifier? (cadr xs))
(syntax/loc stx (x-rewrite ...)))] (free-identifier=? (quote-syntax ...)
[_ stx]))) (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 () (syntax-case orig-stx ()
[(_ arg) [(_ arg)