diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index 35cfcc4901..a81b831fe5 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -975,7 +975,7 @@ (raise-syntax-error syn-error-name "no clauses" orig-stx)) (let-values ([(contract-name dom-ctcs codom-contract pats) (split-out-contract orig-stx syn-error-name #'rest)]) - (with-syntax ([(((name lhs-clauses ...) rhs stuff ...) ...) pats] + (with-syntax ([(((original-names lhs-clauses ...) rhs stuff ...) ...) pats] [(lhs-for-lw ...) (with-syntax ([((lhs-for-lw _ _ ...) ...) pats]) (map (λ (x) (datum->syntax #f (cdr (syntax-e x)) x)) @@ -983,10 +983,10 @@ (with-syntax ([(lhs ...) #'((lhs-clauses ...) ...)] [name (let loop ([name (if contract-name contract-name - (car (syntax->list #'(name ...))))] + (car (syntax->list #'(original-names ...))))] [names (if contract-name - (syntax->list #'(name ...)) - (cdr (syntax->list #'(name ...))))]) + (syntax->list #'(original-names ...)) + (cdr (syntax->list #'(original-names ...))))]) (cond [(null? names) name] [else @@ -1063,50 +1063,53 @@ [(((where-id where-pat) ...) ...) ;; Also for pict, extract where bindings #'(tl-bindings ...)]) - #`(begin - (define-values (name2 name-predicate) - (let ([sc `(side-conditions-rewritten ...)] - [dsc `dom-side-conditions-rewritten]) - (build-metafunction - lang - sc - (list rhs-fns ...) - #,(if prev-metafunction - (let ([term-fn (syntax-local-value prev-metafunction)]) - #`(metafunc-proc-cps #,(term-fn-get-id term-fn))) - #''()) - #,(if prev-metafunction - (let ([term-fn (syntax-local-value prev-metafunction)]) - #`(metafunc-proc-rhss #,(term-fn-get-id term-fn))) - #''()) - (λ (f/dom cps rhss) - (make-metafunc-proc - (let ([name (lambda (x) (f/dom x))]) name) - (list (list (to-lw lhs-for-lw) - (list (to-lw/uq side-cond) ...) - (list (cons (to-lw bind-id) - (to-lw bind-pat)) - ... - (cons (to-lw rhs-bind-id) - (to-lw/uq rhs-bind-pat)) - ... - (cons (to-lw where-id) - (to-lw where-pat)) - ...) - (to-lw rhs)) - ...) - lang - #t ;; multi-args? - 'name - cps - rhss - (let ([name (lambda (x) (name-predicate x))]) name) - dsc - sc)) - dsc - 'codom-side-conditions-rewritten - 'name))) - (term-define-fn name name2)))))))))] + (syntax-property + #`(begin + (define-values (name2 name-predicate) + (let ([sc `(side-conditions-rewritten ...)] + [dsc `dom-side-conditions-rewritten]) + (build-metafunction + lang + sc + (list rhs-fns ...) + #,(if prev-metafunction + (let ([term-fn (syntax-local-value prev-metafunction)]) + #`(metafunc-proc-cps #,(term-fn-get-id term-fn))) + #''()) + #,(if prev-metafunction + (let ([term-fn (syntax-local-value prev-metafunction)]) + #`(metafunc-proc-rhss #,(term-fn-get-id term-fn))) + #''()) + (λ (f/dom cps rhss) + (make-metafunc-proc + (let ([name (lambda (x) (f/dom x))]) name) + (list (list (to-lw lhs-for-lw) + (list (to-lw/uq side-cond) ...) + (list (cons (to-lw bind-id) + (to-lw bind-pat)) + ... + (cons (to-lw rhs-bind-id) + (to-lw/uq rhs-bind-pat)) + ... + (cons (to-lw where-id) + (to-lw where-pat)) + ...) + (to-lw rhs)) + ...) + lang + #t ;; multi-args? + 'name + cps + rhss + (let ([name (lambda (x) (name-predicate x))]) name) + dsc + sc)) + dsc + 'codom-side-conditions-rewritten + 'name))) + (term-define-fn name name2)) + 'disappeared-use + (map syntax-local-introduce (syntax->list #'(original-names ...)))))))))))] [(_ prev-metafunction name lang clauses ...) (begin (unless (identifier? #'name) diff --git a/collects/redex/private/term.ss b/collects/redex/private/term.ss index b54fc9983f..20b7e03cbb 100644 --- a/collects/redex/private/term.ss +++ b/collects/redex/private/term.ss @@ -1,6 +1,8 @@ #lang scheme/base -(require (for-syntax scheme/base "term-fn.ss") +(require (for-syntax scheme/base + "term-fn.ss" + stxclass/util/misc) "matcher.ss") (provide term term-let term-let/error-name term-let-fn term-define-fn) @@ -37,7 +39,7 @@ (and (identifier? (syntax metafunc-name)) (term-fn? (syntax-local-value (syntax metafunc-name) (λ () #f)))) (let-values ([(rewritten has-term-let-bound-id?) (loop (syntax (arg ...)) depth)]) - (let ([term-fn (syntax-local-value (syntax metafunc-name) (λ () #f))]) + (let ([term-fn (syntax-local-value/catch (syntax metafunc-name) (λ (x) #t))]) (with-syntax ([f (term-fn-get-id term-fn)]) (cond [has-term-let-bound-id? @@ -76,7 +78,7 @@ [x (and (identifier? (syntax x)) (term-id? (syntax-local-value (syntax x) (λ () #f)))) - (values (term-id-id (syntax-local-value (syntax x) (λ () #f))) #t)] + (values (term-id-id (syntax-local-value/catch (syntax x) (λ (x) #t))) #t)] [(unquote x) (values (syntax (unsyntax x)) #f)] [(unquote . x) @@ -122,14 +124,15 @@ (syntax-case orig-stx () [(_ arg) - (with-syntax ([rewritten (rewrite (syntax arg))]) - (let loop ([bs (reverse outer-bindings)]) - (cond - [(null? bs) (syntax (syntax->datum (quasisyntax rewritten)))] - [else (with-syntax ([rec (loop (cdr bs))] - [fst (car bs)]) - (syntax (with-syntax (fst) - rec)))])))])) + (with-disappeared-uses + (with-syntax ([rewritten (rewrite (syntax arg))]) + (let loop ([bs (reverse outer-bindings)]) + (cond + [(null? bs) (syntax (syntax->datum (quasisyntax rewritten)))] + [else (with-syntax ([rec (loop (cdr bs))] + [fst (car bs)]) + (syntax (with-syntax (fst) + rec)))]))))])) (define-syntax (term-let-fn stx) (syntax-case stx () @@ -196,6 +199,8 @@ (define-syntax (term-let stx) (syntax-case stx () + [(_ () body1) + #'body1] [(_ ([x rhs] ...) body1 body2 ...) (syntax (term-let/error-name term-let ((x rhs) ...) body1 body2 ...))] diff --git a/doc/release-notes/redex/HISTORY.txt b/doc/release-notes/redex/HISTORY.txt index a8b12407ff..81c51cbfaf 100644 --- a/doc/release-notes/redex/HISTORY.txt +++ b/doc/release-notes/redex/HISTORY.txt @@ -1,10 +1,21 @@ v4.1.5 - - initial-char-width now accepts functions to give finer grained + * define-metafunction and reduction-relation now work better with + Check Syntax, as + + * added the #:arrow keyword to reduction-relation, which lets you use + a different main arrow (mostly useful for the typesetting) + + * added domain specifications to reduction relations via + the #:domain keyword + + * 'traces' copes better with errors during reduction + + * initial-char-width now accepts functions to give finer grained control of the initial widths of the terms. - - traces & traces/ps: added the ability to specify a mixin - to be mixed into the graph pasteboard + * traces & traces/ps: added the ability to specify a mixin + to be mixed into the graph pasteboard v4.1.4