79 lines
2.3 KiB
Scheme
79 lines
2.3 KiB
Scheme
|
|
(module stxparam mzscheme
|
|
(require-for-syntax "private/stxparamkey.ss")
|
|
|
|
(provide define-syntax-parameter
|
|
syntax-parameterize)
|
|
|
|
(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-syntax ([gen-id (convert-renamer val)] ...)
|
|
body0 body ...)))]))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(require "private/stxparamkey.ss")
|
|
(provide syntax-parameter-value
|
|
make-parameter-rename-transformer)
|
|
|
|
(define (make-parameter-rename-transformer id)
|
|
(make-set!-transformer
|
|
(lambda (stx)
|
|
(let ([v (syntax-parameter-value (syntax-local-introduce id))])
|
|
(apply-transformer v stx #'set!)))))
|
|
|
|
(define (syntax-parameter-value id)
|
|
(let* ([v (syntax-local-value id (lambda () #f))]
|
|
[v (if (set!-transformer? v)
|
|
(set!-transformer-procedure v)
|
|
v)])
|
|
(unless (syntax-parameter? v)
|
|
(raise-type-error 'syntax-parameter-value "syntax parameter" v))
|
|
(let ([target (syntax-parameter-target v)])
|
|
(syntax-parameter-target-value target)))))
|