1#lang racket/base 2 3(require (for-syntax racket/base 4 racket/syntax 5 syntax/parse 6 racket/list) 7 racket/list) 8 9(provide define-parameter-group parameterize/group parameterize*/group) 10 11(begin-for-syntax 12 (struct parameter-group (ids) #:transparent 13 #:property prop:procedure 14 (λ (g stx) 15 (syntax-case stx () 16 [(_) 17 (with-syntax ([(ids ...) (parameter-group-ids g)]) 18 (syntax/loc stx 19 (list (ids) ...)))])))) 20 21(define-syntax (define-parameter-group stx) 22 (syntax-parse stx 23 [(_ name:id (param:id ...)) 24 (syntax/loc stx 25 (define-syntax name (parameter-group (list #'param ...))))])) 26 27(define-for-syntax (make-list-ref val i) 28 (cond [(= i 0) #`(car #,val)] 29 [else (make-list-ref #`(cdr #,val) (- i 1))])) 30 31(define-for-syntax (expand-parameter-groups id val) 32 (define group (syntax-local-value id (λ () #f))) 33 (if (and group (parameter-group? group)) 34 (let ([ids (parameter-group-ids group)]) 35 (append* 36 (map (λ (id i) (expand-parameter-groups id (make-list-ref val i))) 37 ids 38 (build-list (length ids) values)))) 39 (list #`[#,id #,val]))) 40 41;; Corresponds to parameterize 42(define-syntax (parameterize/group stx) 43 (syntax-parse stx 44 [(_ ([p:id v] ...) . body) 45 (with-syntax* ([(v-name ...) (generate-temporaries #'(v ...))] 46 [([p new-v] ...) (append* (map expand-parameter-groups 47 (syntax->list #'(p ...)) 48 (syntax->list #'(v-name ...))))]) 49 (syntax/loc stx 50 (let ([v-name v] ...) 51 (parameterize ([p new-v] ...) . body))))])) 52 53;; Corresponds to parameterize* 54(define-syntax parameterize*/group 55 (syntax-rules () 56 [(_ () . body) 57 (let () . body)] 58 [(_ ([lhs1 rhs1] [lhs rhs] ...) . body) 59 (parameterize/group ([lhs1 rhs1]) (parameterize*/group ([lhs rhs] ...) . body))])) 60