From 395d977832a1a8c7bb7cffe7e1ed2d40f65f4cce Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 21 Jan 2009 16:06:27 +0000 Subject: [PATCH] moving to the other computer svn: r13249 --- collects/redex/private/term-test.ss | 6 ++ collects/redex/private/term.ss | 108 ++++++++++++++++------------ 2 files changed, 70 insertions(+), 44 deletions(-) diff --git a/collects/redex/private/term-test.ss b/collects/redex/private/term-test.ss index 12d357c470..ae462a01d3 100644 --- a/collects/redex/private/term-test.ss +++ b/collects/redex/private/term-test.ss @@ -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)) diff --git a/collects/redex/private/term.ss b/collects/redex/private/term.ss index 59ead46a8b..c86d3eaccf 100644 --- a/collects/redex/private/term.ss +++ b/collects/redex/private/term.ss @@ -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)