(module stxparam '#%kernel (#%require "private/more-scheme.ss" "private/letstx-scheme.ss" "private/define.ss" (for-syntax '#%kernel "stxparam-exptime.ss" "private/stx.ss" "private/stxcase-scheme.ss" "private/small-scheme.ss" "private/stxloc.ss" "private/stxparamkey.ss")) (#%provide define-syntax-parameter syntax-parameterize (for-syntax syntax-parameter-value make-parameter-rename-transformer)) (define-syntax (define-syntax-parameter stx) (syntax-case stx () [(_ id init-val) (with-syntax ([gen-id (car (generate-temporaries (list #'id)))]) #'(begin (define-syntax gen-id (convert-renamer init-val)) (define-syntax id (let ([gen-id ((syntax-local-certifier) #'gen-id)]) (make-set!-transformer (make-syntax-parameter (lambda (stx) (let ([v (syntax-parameter-target-value gen-id)]) (apply-transformer v stx #'set!))) gen-id))))))])) (define-syntax (syntax-parameterize stx) (syntax-case stx () [(_ ([id val] ...) body0 body ...) (let ([ids (syntax->list #'(id ...))]) (with-syntax ([(gen-id ...) (map (lambda (id) (unless (identifier? id) (raise-syntax-error #f "not an identifier" stx id)) (let* ([rt (syntax-local-value id (lambda () #f))] [sp (if (set!-transformer? rt) (set!-transformer-procedure rt) rt)]) (unless (syntax-parameter? sp) (raise-syntax-error #f "not bound as a syntax parameter" stx id)) (syntax-local-get-shadower (syntax-local-introduce (syntax-parameter-target sp))))) ids)]) (let ([dup (check-duplicate-identifier ids)]) (when dup (raise-syntax-error #f "duplicate binding" stx dup))) #'(let-syntaxes ([(gen-id) (convert-renamer val)] ...) body0 body ...)))])))