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

Fixed PR 8765

Browse Source 
svn: r16564
This commit is contained in:
Casey Klein 2009-11-05 19:33:19 +00:00
parent c993533814
commit a021b75a67
6 changed files with 151 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/redex/private/term-fn.ss
View File

@ -9,4 +9,4 @@
(make-struct-type 'term-fn #f 1 0)) (make-struct-type 'term-fn #f 1 0))
(define term-fn-get-id (make-struct-field-accessor term-fn-get 0)) (define term-fn-get-id (make-struct-field-accessor term-fn-get 0))
(define-struct term-id (id)) (define-struct term-id (id depth))

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

@ -1,4 +1,4 @@
(module term-test mzscheme (module term-test scheme
(require "term.ss" (require "term.ss"
"matcher.ss" "matcher.ss"
"test-util.ss") "test-util.ss")
@ -67,10 +67,7 @@
(term ((in-hole E x) ...))) (term ((in-hole E x) ...)))
(term (1 2 3))) (term (1 2 3)))
(fprintf (current-error-port) "term-test.ss commented out test that fails; matches PR 8765\n") (test (term-let-fn ((metafun car))
#;
(test (term-let-fn ((metafun (λ (x) x)))
(term-let ((x 'whatever) (term-let ((x 'whatever)
((y ...) '(4 5 6))) ((y ...) '(4 5 6)))
(term (((metafun x) y) ...)))) (term (((metafun x) y) ...))))
@ -81,4 +78,26 @@
(term ((y (metafun 1)) ...)))) (term ((y (metafun 1)) ...))))
'((4 1) (5 1) (6 1))) '((4 1) (5 1) (6 1)))
(test (term-let-fn ((f (compose add1 car)))
(term-let (((x ...) '(1 2 3))
((y ...) '(a b c)))
(term (((f x) y) ...))))
'((2 a) (3 b) (4 c)))
(test (term-let-fn ((f (curry foldl + 0)))
(term-let (((x ...) '(1 2 3)))
(term (f x ...))))
6)
(test (term-let-fn ((f (compose add1 car)))
(term-let (((x ...) '(1 2 3))
(((y ...) ...) '((a b c) (d e f) (g h i))))
(term ((((f x) y) ...) ...))))
'(((2 a) (3 b) (4 c)) ((2 d) (3 e) (4 f)) ((2 g) (3 h) (4 i))))
(test (term-let-fn ((f (curry foldl + 0)))
(term-let ((((x ...) ...) '((1 2) (3 4 5) (6))))
(term ((f x ...) ...))))
'(3 12 6))
(print-tests-passed 'term-test.ss)) (print-tests-passed 'term-test.ss))

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

@ -5,7 +5,10 @@
syntax/private/util/misc) syntax/private/util/misc)
"matcher.ss") "matcher.ss")
(provide term term-let term-let/error-name term-let-fn term-define-fn) (provide term term-let term-let/error-name term-let-fn term-define-fn hole in-hole)
(define-syntax (hole stx) (raise-syntax-error 'hole "used outside of term"))
(define-syntax (in-hole stx) (raise-syntax-error 'in-hole "used outside of term"))
(define (with-syntax* stx) (define (with-syntax* stx)
(syntax-case stx () (syntax-case stx ()
@ -15,112 +18,95 @@
(define-syntax (term stx) (define-syntax (term stx)
(syntax-case stx () (syntax-case stx ()
[(_ arg) [(_ arg)
#`(term-let-fn ((#,(datum->syntax stx 'in-hole) #`(term/private arg)]))
(λ (x)
(unless (and (list? x)
(= 2 (length x)))
(error 'in-hole "expected two arguments, got ~s" x))
(apply plug x))))
(term/private arg))]))
(define-syntax (term/private orig-stx) (define-syntax (term/private orig-stx)
(define outer-bindings '()) (define outer-bindings '())
(define (rewrite stx) (define (rewrite stx)
(let-values ([(rewritten has-term-let-bound-id?) (let-values ([(rewritten _) (rewrite/max-depth stx 0)])
(rewrite/has-term-let-bound-id? stx)])
rewritten)) rewritten))
(define (rewrite/has-term-let-bound-id? stx) (define (rewrite-application fn args depth)
(let loop ([stx stx] (let-values ([(rewritten max-depth) (rewrite/max-depth args depth)])
[depth 0]) (let ([result-id (car (generate-temporaries '(f-results)))])
(syntax-case stx (unquote unquote-splicing in-hole hole) (with-syntax ([fn fn])
[(metafunc-name arg ...) (let loop ([func (syntax (λ (x) (fn (syntax->datum x))))]
(and (identifier? (syntax metafunc-name)) [args rewritten]
(term-fn? (syntax-local-value (syntax metafunc-name) (λ () #f)))) [res result-id]
(let-values ([(rewritten has-term-let-bound-id?) (loop (syntax (arg ...)) depth)]) [args-depth (min depth max-depth)])
(let ([term-fn (syntax-local-value/catch (syntax metafunc-name) (λ (x) #t))]) (with-syntax ([func func]
(with-syntax ([f (term-fn-get-id term-fn)]) [args args]
(cond [res res])
[has-term-let-bound-id? (if (zero? args-depth)
(with-syntax ([(f-results) (generate-temporaries '(f-results))]) (begin
(let d-loop ([arg-dots rewritten] (set! outer-bindings
[fres (syntax f-results)] (cons (syntax [res (func (quasisyntax args))])
[func (syntax (lambda (x) (f (syntax->datum x))))] outer-bindings))
[depth depth]) (values result-id (min depth max-depth)))
(cond (loop (syntax (λ (l) (map func (syntax->list l))))
[(zero? depth) (syntax (args (... ...)))
(let ([res (syntax (res (... ...)))
(with-syntax ([fres fres] (sub1 args-depth)))))))))
[func func]
[arg-dots arg-dots]) (define (rewrite/max-depth stx depth)
(set! outer-bindings (cons (syntax [fres (func (quasisyntax arg-dots))]) (syntax-case stx (unquote unquote-splicing in-hole hole)
outer-bindings)) [(metafunc-name arg ...)
(syntax f-results))]) (and (identifier? (syntax metafunc-name))
(values res #t))] (term-fn? (syntax-local-value (syntax metafunc-name) (λ () #f))))
[else (rewrite-application (term-fn-get-id (syntax-local-value/catch (syntax metafunc-name) (λ (x) #t)))
(with-syntax ([dots (quote-syntax ...)] (syntax (arg ...))
[arg-dots arg-dots] depth)]
[fres fres]) [f
(d-loop (syntax (arg-dots dots)) (and (identifier? (syntax f))
(syntax (fres dots)) (term-fn? (syntax-local-value (syntax f) (λ () #f))))
(with-syntax ([f func]) (raise-syntax-error 'term "metafunction must be in an application" orig-stx stx)]
(syntax (lambda (l) (map f (syntax->list l))))) [x
(- depth 1)))])))] (and (identifier? (syntax x))
[else (term-id? (syntax-local-value (syntax x) (λ () #f))))
(with-syntax ([rewritten rewritten]) (let ([id (syntax-local-value/catch (syntax x) (λ (x) #t))])
(values (syntax/loc stx (unsyntax (f (syntax->datum (quasisyntax rewritten))))) (values (term-id-id id) (term-id-depth id)))]
#f))]))))] [(unquote x)
[f (values (syntax (unsyntax x)) 0)]
(and (identifier? (syntax f)) [(unquote . x)
(term-fn? (syntax-local-value (syntax f) (λ () #f)))) (raise-syntax-error 'term "malformed unquote" orig-stx stx)]
(raise-syntax-error 'term "metafunction must be in an application" orig-stx stx)] [(unquote-splicing x)
[x (values (syntax (unsyntax-splicing x)) 0)]
(and (identifier? (syntax x)) [(unquote-splicing . x)
(term-id? (syntax-local-value (syntax x) (λ () #f)))) (raise-syntax-error 'term "malformed unquote splicing" orig-stx stx)]
(values (term-id-id (syntax-local-value/catch (syntax x) (λ (x) #t))) #t)] [(in-hole id body)
[(unquote x) (rewrite-application (syntax (λ (x) (apply plug x))) (syntax (id body)) depth)]
(values (syntax (unsyntax x)) #f)] [(in-hole . x)
[(unquote . x) (raise-syntax-error 'term "malformed in-hole" orig-stx stx)]
(raise-syntax-error 'term "malformed unquote" orig-stx stx)] [hole (values (syntax (unsyntax the-hole)) 0)]
[(unquote-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)
(values (syntax (unsyntax (plug (term id) (term body)))) #f)]
[(in-hole . x)
(raise-syntax-error 'term "malformed in-hole" orig-stx stx)]
[hole (values (syntax (unsyntax the-hole)) #f)]
[() (values stx #f)] [() (values stx 0)]
[(x ... . y) [(x ... . y)
(not (null? (syntax->list #'(x ...)))) (not (null? (syntax->list #'(x ...))))
(let-values ([(x-rewrite has-term-let-bound-id?) (let-values ([(x-rewrite max-depth)
(let i-loop ([xs (syntax->list (syntax (x ...)))]) (let i-loop ([xs (syntax->list (syntax (x ...)))])
(cond (cond
[(null? xs) (loop #'y depth)] [(null? xs) (rewrite/max-depth #'y depth)]
[else [else
(let ([new-depth (if (and (not (null? (cdr xs))) (let ([new-depth (if (and (not (null? (cdr xs)))
(identifier? (cadr xs)) (identifier? (cadr xs))
(free-identifier=? (quote-syntax ...) (free-identifier=? (quote-syntax ...)
(cadr xs))) (cadr xs)))
(+ depth 1) (+ depth 1)
depth)]) depth)])
(let-values ([(fst fst-has-term-let-bound-id?) (let-values ([(fst fst-max-depth)
(loop (car xs) new-depth)] (rewrite/max-depth (car xs) new-depth)]
[(rst rst-has-term-let-bound-id?) [(rst rst-max-depth)
(i-loop (cdr xs))]) (i-loop (cdr xs))])
(values (cons fst rst) (values (cons fst rst)
(or fst-has-term-let-bound-id? (max fst-max-depth rst-max-depth))))]))])
rst-has-term-let-bound-id?))))]))])
(with-syntax ([x-rewrite x-rewrite]) (with-syntax ([x-rewrite x-rewrite])
(values (syntax/loc stx x-rewrite) (values (syntax/loc stx x-rewrite)
has-term-let-bound-id?)))] max-depth)))]
[_ (values stx #f)]))) [_ (values stx 0)]))
(syntax-case orig-stx () (syntax-case orig-stx ()
[(_ arg) [(_ arg)
@ -157,38 +143,48 @@
(define-syntax (term-let/error-name stx) (define-syntax (term-let/error-name stx)
(syntax-case stx () (syntax-case stx ()
[(_ error-name ([x1 rhs1] [x rhs] ...) body1 body2 ...) [(_ error-name ([x1 rhs1] [x rhs] ...) body1 body2 ...)
(let-values ([(orig-names new-names new-x1) (let-values ([(orig-names new-names depths new-x1)
(let loop ([stx #'x1]) (let loop ([stx #'x1] [depth 0])
(syntax-case stx () (define ((combine orig-names new-names depths new-pat)
orig-names* new-names* depths* new-pat*)
(values (append orig-names orig-names*)
(append new-names new-names*)
(append depths depths*)
(cons new-pat new-pat*)))
(syntax-case stx (...)
[x [x
(and (identifier? #'x) (and (identifier? #'x)
(not (free-identifier=? (quote-syntax ...) #'x))) (not (free-identifier=? (quote-syntax ...) #'x)))
(let ([new-name (car (generate-temporaries (list #'x)))]) (let ([new-name (car (generate-temporaries (list #'x)))])
(values (list #'x) (values (list #'x)
(list new-name) (list new-name)
(list depth)
new-name))] new-name))]
[(x ...) [(x (... ...) . xs)
(let l-loop ([lst (syntax->list #'(x ...))]) (let-values ([(orig-names new-names depths new-pat)
(cond (call-with-values
[(null? lst) (λ () (loop #'xs depth))
(values '() '() '())] (call-with-values
[else (λ () (loop #'x (add1 depth)))
(let-values ([(hd-orig-names hd-new-names hd-new-pattern) combine))])
(loop (car lst))] (values orig-names new-names depths
[(tl-orig-names tl-new-names tl-new-pattern) (list* (car new-pat) #'(... ...) (cdr new-pat))))]
(l-loop (cdr lst))]) [(x . xs)
(values (append hd-orig-names tl-orig-names) (call-with-values
(append hd-new-names tl-new-names) (λ () (loop #'xs depth))
(cons hd-new-pattern tl-new-pattern)))]))] (call-with-values
(λ () (loop #'x depth))
combine))]
[_ [_
(values '() '() stx)]))]) (values '() '() '() stx)]))])
(with-syntax ([(orig-names ...) orig-names] (with-syntax ([(orig-names ...) orig-names]
[(new-names ...) new-names] [(new-names ...) new-names]
[(depths ...) depths]
[new-x1 new-x1]) [new-x1 new-x1])
(syntax (syntax
(syntax-case rhs1 () (syntax-case rhs1 ()
[new-x1 [new-x1
(let-syntax ([orig-names (make-term-id #'new-names)] ...) (let-syntax ([orig-names (make-term-id #'new-names (syntax-e #'depths))] ...)
(term-let/error-name error-name ((x rhs) ...) body1 body2 ...))] (term-let/error-name error-name ((x rhs) ...) body1 body2 ...))]
[_ (error 'error-name "term ~s does not match pattern ~s" rhs1 'x1)]))))] [_ (error 'error-name "term ~s does not match pattern ~s" rhs1 'x1)]))))]
[(_ error-name () body1 body2 ...) [(_ error-name () body1 body2 ...)

8
collects/redex/redex.scrbl
View File

@ -485,6 +485,14 @@ for two @scheme[term-let]-bound identifiers bound to lists of
different lengths to appear together inside an ellipsis. different lengths to appear together inside an ellipsis.
} }
@defidform[hole]{ Recognized specially within
@scheme[term]. A @scheme[hole] form is an
error elsewhere. }
@defidform[in-hole]{ Recognized specially within
@scheme[reduction-relation]. An @scheme[in-hole] form is an
error elsewhere. }
@defform/subs[(term-let ([tl-pat expr] ...) body) @defform/subs[(term-let ([tl-pat expr] ...) body)
([tl-pat identifier (tl-pat-ele ...)] ([tl-pat identifier (tl-pat-ele ...)]
[tl-pat-ele tl-pat (code:line tl-pat ... (code:comment "a literal ellipsis"))])]{ [tl-pat-ele tl-pat (code:line tl-pat ... (code:comment "a literal ellipsis"))])]{

1
collects/redex/reduction-semantics.ss
View File

@ -11,6 +11,7 @@
(provide reduction-relation (provide reduction-relation
--> fresh with ;; keywords for reduction-relation --> fresh with ;; keywords for reduction-relation
hole in-hole ;; keywords for term
extend-reduction-relation extend-reduction-relation
reduction-relation? reduction-relation?

5
doc/release-notes/redex/HISTORY.txt
View File

@ -1,11 +1,12 @@
v4.2.3
* added support for collecting metafunction coverage, using the * added support for collecting metafunction coverage, using the
'relation-coverage' parameter. This includes a backwards 'relation-coverage' parameter. This includes a backwards
incompatible change: the parameter's value is now a list of incompatible change: the parameter's value is now a list of
coverage structures, to allow coverage collection for multiple coverage structures, to allow coverage collection for multiple
metafunctions and reduction relations at once. metafunctions and reduction relations at once.
* redex/reduction-semantics exports the names `hole' and `in-hole'
(and `term' no longer captures those names).
* minor bug fixes * minor bug fixes
v4.2.2 v4.2.2