.
original commit: 9d40ed27b30d40cea1d9be135319959e1dc0ba07
This commit is contained in:
parent
1227dbe75a
commit
f0489bbb6c
|
@ -456,9 +456,13 @@
|
|||
(current-directory))))))
|
||||
(local)))])
|
||||
(if (and (pair? dir) (eq? 'plthome (car dir)))
|
||||
(with-syntax ([d dir])
|
||||
(syntax (un-plthome-ify 'd)))
|
||||
(datum->syntax-object (quote-syntax here) dir stx)))]))
|
||||
(with-syntax ([d dir])
|
||||
(syntax (un-plthome-ify 'd)))
|
||||
(datum->syntax-object (quote-syntax here)
|
||||
(if (path? dir)
|
||||
(path->string dir)
|
||||
dir)
|
||||
stx)))]))
|
||||
|
||||
;; This is a macro-generating macro that wants to expand
|
||||
;; expressions used in the generated macro. So it's weird,
|
||||
|
|
|
@ -1,5 +1,7 @@
|
|||
|
||||
(module stxparamkey mzscheme
|
||||
|
||||
(define-struct wrapped-renamer (renamer))
|
||||
|
||||
(define-values (struct:syntax-parameter make-syntax-parameter syntax-parameter? syntax-parameter-ref syntax-parameter-set!)
|
||||
(make-struct-type 'syntax-parameter #f 2 0 #f null (current-inspector) 0))
|
||||
|
@ -8,14 +10,60 @@
|
|||
(syntax-parameter-ref sp 1))
|
||||
|
||||
(define (syntax-parameter-target-value target)
|
||||
(syntax-local-value (syntax-local-get-shadower target)
|
||||
(lambda ()
|
||||
#f
|
||||
(syntax-local-value
|
||||
target
|
||||
(lambda () #f)))))
|
||||
(let ([v (syntax-local-value (syntax-local-get-shadower target)
|
||||
(lambda ()
|
||||
#f
|
||||
(syntax-local-value
|
||||
target
|
||||
(lambda () #f))))])
|
||||
(if (wrapped-renamer? v)
|
||||
(wrapped-renamer-renamer v)
|
||||
v)))
|
||||
|
||||
(provide syntax-parameter?
|
||||
(define (convert-renamer v)
|
||||
(if (rename-transformer? v)
|
||||
(make-wrapped-renamer v)
|
||||
v))
|
||||
|
||||
(define (apply-transformer v stx set!-stx)
|
||||
(cond
|
||||
[(rename-transformer? v)
|
||||
(with-syntax ([target (rename-transformer-target v)])
|
||||
(syntax-case stx ()
|
||||
[(set! id _expr)
|
||||
(module-identifier=? #'set! set!-stx)
|
||||
(syntax/loc stx (set! target expr))]
|
||||
[(id . rest)
|
||||
(let ([v (syntax (target . rest))])
|
||||
(datum->syntax-object
|
||||
stx
|
||||
(syntax-e v)
|
||||
stx))]
|
||||
[_else
|
||||
#'target]))]
|
||||
[(set!-transformer? v) ((set!-transformer-procedure v) stx)]
|
||||
[(and (procedure? v)
|
||||
(procedure-arity-includes? v 1))
|
||||
(syntax-case stx ()
|
||||
[(set! id _)
|
||||
(module-identifier=? #'set! set!-stx)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"cannot mutate syntax identifier"
|
||||
stx
|
||||
#'id)]
|
||||
[else (v stx)])]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax"
|
||||
stx
|
||||
#f)]))
|
||||
|
||||
|
||||
(provide convert-renamer
|
||||
apply-transformer
|
||||
syntax-parameter?
|
||||
make-syntax-parameter
|
||||
syntax-parameter-target
|
||||
syntax-parameter-target-value))
|
||||
|
|
|
@ -10,29 +10,13 @@
|
|||
[(_ id init-val)
|
||||
(with-syntax ([gen-id (car (generate-temporaries (list #'id)))])
|
||||
#'(begin
|
||||
(define-syntax gen-id init-val)
|
||||
(define-syntax gen-id (convert-renamer init-val))
|
||||
(define-syntax id
|
||||
(make-set!-transformer
|
||||
(make-syntax-parameter
|
||||
(lambda (stx)
|
||||
(let ([v (syntax-parameter-target-value #'gen-id)])
|
||||
(cond
|
||||
[(set!-transformer? v) ((set!-transformer-procedure v) stx)]
|
||||
[(and (procedure? v)
|
||||
(procedure-arity-includes? v 1))
|
||||
(syntax-case stx (set!)
|
||||
[(set! id _) (raise-syntax-error
|
||||
#f
|
||||
"cannot mutate syntax identifier"
|
||||
stx
|
||||
#'id)]
|
||||
[else (v stx)])]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax"
|
||||
stx
|
||||
#f)])))
|
||||
(apply-transformer v stx #'set!)))
|
||||
#'gen-id)))))]))
|
||||
|
||||
(define-syntax (syntax-parameterize stx)
|
||||
|
@ -67,7 +51,7 @@
|
|||
"duplicate binding"
|
||||
stx
|
||||
dup)))
|
||||
#'(let-syntax ([gen-id val] ...)
|
||||
#'(let-syntax ([gen-id (convert-renamer val)] ...)
|
||||
body0 body ...)))]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
@ -80,23 +64,7 @@
|
|||
(make-set!-transformer
|
||||
(lambda (stx)
|
||||
(let ([v (syntax-parameter-value (syntax-local-introduce id))])
|
||||
(cond
|
||||
[(set!-transformer? v) ((set!-transformer-procedure v) stx)]
|
||||
[(and (procedure? v)
|
||||
(procedure-arity-includes? v 1))
|
||||
(syntax-case stx (set!)
|
||||
[(set! id _) (raise-syntax-error
|
||||
#f
|
||||
"cannot mutate syntax identifier"
|
||||
stx
|
||||
#'id)]
|
||||
[else (v stx)])]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax"
|
||||
stx
|
||||
#f)])))))
|
||||
(apply-transformer v stx #'set!)))))
|
||||
|
||||
(define (syntax-parameter-value id)
|
||||
(let* ([v (syntax-local-value id (lambda () #f))]
|
||||
|
|
Loading…
Reference in New Issue
Block a user