suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: a8fa10621a9cfefe53defb6b7e79ba4923a64cc8
This commit is contained in:
Matthew Flatt 2004-08-24 19:11:39 +00:00
parent 466cdf0187
commit 49167db7df
2 changed files with 55 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/mzlib/private/stxparamkey.ss
View File

@ -1,5 +1,23 @@
(module stxparamkey mzscheme
(define-struct syntax-parameter (target))
(provide (struct syntax-parameter (target))))
(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))
(define (syntax-parameter-target sp)
(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)))))
(provide syntax-parameter?
make-syntax-parameter
syntax-parameter-target
syntax-parameter-target-value))

103
collects/mzlib/stxparam.ss
View File

@ -11,52 +11,11 @@
(with-syntax ([gen-id (car (generate-temporaries (list #'id)))])
#'(begin
(define-syntax gen-id init-val)
(define-syntax id (make-syntax-parameter #'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))])
(unless (syntax-parameter? rt)
(raise-syntax-error
#f
"not bound as a syntax parameter"
stx
id))
(syntax-local-get-shadower
(syntax-local-introduce (syntax-parameter-target rt)))))
ids)])
(let ([dup (check-duplicate-identifier ids)])
(when dup
(raise-syntax-error
#f
"duplicate binding"
stx
dup)))
#'(let-syntax ([gen-id val] ...)
body0 body ...)))]))
;; ----------------------------------------
(require "private/stxparamkey.ss")
(require-for-template mzscheme)
(provide make-parameter-rename-transformer
syntax-parameter-value)
(define (make-parameter-rename-transformer id)
(define-syntax id
(make-set!-transformer
(make-syntax-parameter
(lambda (stx)
(let ([v (syntax-parameter-value (syntax-local-introduce id))])
(let ([v (syntax-parameter-target-value #'gen-id)])
(cond
[(set!-transformer? v) ((set!-transformer-procedure v) stx)]
[(and (procedure? v)
@ -73,16 +32,56 @@
#f
"bad syntax"
stx
#f)])))))
#f)])))
#'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 val] ...)
body0 body ...)))]))
;; ----------------------------------------
(require "private/stxparamkey.ss")
(provide syntax-parameter-value)
(define (syntax-parameter-value id)
(let ([v (syntax-local-value id (lambda () #f))])
(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-local-value (syntax-local-get-shadower target)
(lambda ()
#f
(syntax-local-value
target
(lambda () #f))))))))
(syntax-parameter-target-value target)))))