From 1b7f7b3bbb6c62edae572e80c29499542ca0ddcc Mon Sep 17 00:00:00 2001 From: shhyou Date: Sat, 6 Jan 2024 17:16:04 -0600 Subject: [PATCH] cosmetic changes to redex-define --- redex-lib/redex/HISTORY.txt | 2 +- .../redex/private/reduction-semantics.rkt | 26 +++++++++---------- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/redex-lib/redex/HISTORY.txt b/redex-lib/redex/HISTORY.txt index f2d3020c..37ea12d7 100644 --- a/redex-lib/redex/HISTORY.txt +++ b/redex-lib/redex/HISTORY.txt @@ -1,6 +1,6 @@ v8.11 - * added `redex-define`, thanks to Shu-Hung You + * added `redex-define` and `term-define`, thanks to Shu-Hung You * documentation fixes diff --git a/redex-lib/redex/private/reduction-semantics.rkt b/redex-lib/redex/private/reduction-semantics.rkt index d841684c..3450f4a3 100644 --- a/redex-lib/redex/private/reduction-semantics.rkt +++ b/redex-lib/redex/private/reduction-semantics.rkt @@ -154,7 +154,7 @@ (unless (identifier? #'lang) (raise-syntax-error (syntax-e #'form-name) "expected an identifier in the language position" stx #'lang)) - (with-syntax ([(syncheck-expr side-conditions-rewritten (names ...) (names/ellipses ...)) + (with-syntax ([(syncheck-expr side-conditions-rewritten (names ...) (names...* ...)) (rewrite-side-conditions/check-errs #'lang (syntax-e #'form-name) #t #'pattern)]) @@ -164,35 +164,35 @@ (syntax-case stx () [(x . y) (get-id #'x)] [x (identifier? #'x) #'x])) - (define binds + (define lookup-exprs #'((lookup-binding (mtch-bindings match) 'names) ...)) ;; filter out duplicate bindings - (define/with-syntax ((names/nodup names/ellipses/nodup binds/nodup) ...) - (for/list ([names (in-syntax #'(names ...))] - [names/ellipsis (in-syntax #'(names/ellipses ...))] - [binds (in-syntax binds)] + (define/with-syntax ((names/nodup names...*/nodup lookup-exprs/nodup) ...) + (for/list ([name (in-syntax #'(names ...))] + [name...* (in-syntax #'(names...* ...))] + [lookup-expr (in-syntax lookup-exprs)] #:unless (free-identifier-mapping-get known - (get-id names/ellipsis) + (get-id name...*) (λ () #f))) (free-identifier-mapping-put! known - (get-id names/ellipsis) + (get-id name...*) #t) - (list names names/ellipsis binds))) - (with-syntax ([(names/tmp/nodup ...) (generate-temporaries (syntax->list #'(names/nodup ...)))]) + (list name name...* lookup-expr))) + (with-syntax ([(fresh-names/nodup ...) (generate-temporaries (syntax->list #'(names/nodup ...)))]) ;; modified from term-matcher #`(begin syncheck-expr - (define-values (names/tmp/nodup ...) + (define-values (fresh-names/nodup ...) ((term-match/single/proc 'form-name lang '(pattern) (list (compile-pattern lang `side-conditions-rewritten #t)) - (list (λ (match) (values binds/nodup ...)))) + (list (λ (match) (values lookup-exprs/nodup ...)))) rhs)) - (term-define/error-name redex-define names/ellipses/nodup names/tmp/nodup) ...))))])) + (term-define/error-name redex-define names...*/nodup fresh-names/nodup) ...))))])) (define (redex-let stx) (define-values (form-name nts)