original commit: 9d40ed27b30d40cea1d9be135319959e1dc0ba07
This commit is contained in:
Matthew Flatt 2004-09-05 14:44:27 +00:00
parent 1227dbe75a
commit f0489bbb6c
3 changed files with 66 additions and 46 deletions

View File

@ -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,

View File

@ -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))

View File

@ -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))]