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

scheme/splicing: added splicing variants of local and letrec-syntaxes+values

Browse Source 
svn: r14188
This commit is contained in:
Ryan Culpepper 2009-03-19 13:45:45 +00:00
parent afc5ad8d83
commit d154493077
4 changed files with 240 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
collects/scheme/local.ss
View File

@ -1,66 +1,7 @@
#lang scheme/base
(require (for-syntax scheme/base
syntax/context
syntax/kerncase))
(require (for-syntax scheme/base)
"private/local.ss")
(provide local)
(define-syntax (local stx)
(syntax-case stx ()
[(_ (defn ...) body1 body ...)
(let ([defs (let ([expand-context (generate-expand-context)])
(let loop ([defns (syntax->list (syntax (defn ...)))])
(apply
append
(map
(lambda (defn)
(let ([d (local-expand
defn
expand-context
(kernel-form-identifier-list))]
[check-ids (lambda (ids)
(for-each
(lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"not an identifier for definition"
stx
id)))
ids))])
(syntax-case d (define-values define-syntaxes begin)
[(begin defn ...)
(loop (syntax->list (syntax (defn ...))))]
[(define-values (id ...) body)
(begin
(check-ids (syntax->list (syntax (id ...))))
(list d))]
[(define-values . rest)
(raise-syntax-error
#f "ill-formed definition" stx d)]
[(define-syntaxes (id ...) body)
(begin
(check-ids (syntax->list (syntax (id ...))))
(list d))]
[(define-syntaxes . rest)
(raise-syntax-error
#f "ill-formed definition" stx d)]
[_else
(raise-syntax-error
#f "not a definition" stx defn)])))
defns))))])
(let ([ids (apply append
(map
(lambda (d)
(syntax-case d ()
[(_ ids . __) (syntax->list (syntax ids))]))
defs))])
(let ([dup (check-duplicate-identifier ids)])
(when dup
(raise-syntax-error #f "duplicate identifier" stx dup)))
(with-syntax ([(def ...) defs])
(syntax/loc stx
(let () def ... (let () body1 body ...))))))]
[(_ x body1 body ...)
(raise-syntax-error #f "not a definition sequence" stx (syntax x))]))
(do-local stx #'letrec-syntaxes+values))

81
collects/scheme/private/local.ss Normal file
View File

@ -0,0 +1,81 @@
#lang scheme/base
(require (for-syntax scheme/base)
(for-syntax syntax/context)
(for-syntax syntax/kerncase))
(provide (for-syntax do-local))
(define-for-syntax (do-local stx letrec-syntaxes+values-id)
(syntax-case stx ()
[(_ (defn ...) body1 body ...)
(let ([defs (let ([expand-context (generate-expand-context)])
(let loop ([defns (syntax->list (syntax (defn ...)))])
(apply
append
(map
(lambda (defn)
(let ([d (local-expand
defn
expand-context
(kernel-form-identifier-list))]
[check-ids (lambda (ids)
(for-each
(lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"not an identifier for definition"
stx
id)))
ids))])
(syntax-case d (define-values define-syntaxes begin)
[(begin defn ...)
(loop (syntax->list (syntax (defn ...))))]
[(define-values (id ...) body)
(begin
(check-ids (syntax->list (syntax (id ...))))
(list d))]
[(define-values . rest)
(raise-syntax-error
#f "ill-formed definition" stx d)]
[(define-syntaxes (id ...) body)
(begin
(check-ids (syntax->list (syntax (id ...))))
(list d))]
[(define-syntaxes . rest)
(raise-syntax-error
#f "ill-formed definition" stx d)]
[_else
(raise-syntax-error
#f "not a definition" stx defn)])))
defns))))])
(let ([ids (apply append
(map
(lambda (d)
(syntax-case d ()
[(_ ids . __) (syntax->list (syntax ids))]))
defs))]
[vbindings (apply append
(map (lambda (d)
(syntax-case d (define-values)
[(define-values ids rhs)
(list #'(ids rhs))]
[_ null]))
defs))]
[sbindings (apply append
(map (lambda (d)
(syntax-case d (define-syntaxes)
[(define-syntaxes ids rhs)
(list #'(ids rhs))]
[_ null]))
defs))])
(let ([dup (check-duplicate-identifier ids)])
(when dup
(raise-syntax-error #f "duplicate identifier" stx dup)))
(with-syntax ([sbindings sbindings]
[vbindings vbindings]
[LSV letrec-syntaxes+values-id])
(syntax/loc stx
(LSV sbindings vbindings
body1 body ...)))))]
[(_ x body1 body ...)
(raise-syntax-error #f "not a definition sequence" stx (syntax x))]))

115
collects/scheme/splicing.ss
View File

@ -2,7 +2,8 @@
(require (for-syntax scheme/base
syntax/kerncase)
"stxparam.ss"
"private/stxparam.ss")
"private/stxparam.ss"
"private/local.ss")
(provide splicing-let-syntax
splicing-let-syntaxes
@ -12,45 +13,43 @@
splicing-let-values
splicing-letrec
splicing-letrec-values
splicing-letrec-syntaxes+values
splicing-local
splicing-syntax-parameterize)
(define-for-syntax ((check-id stx) id-stx)
(unless (identifier? id-stx)
(raise-syntax-error #f "expected an identifier" stx id-stx))
(list id-stx))
(define-for-syntax ((check-ids stx) ids-stx)
(let ([ids (syntax->list ids-stx)])
(unless ids
(raise-syntax-error
#f
"expected a parenthesized sequence of identifiers"
stx
ids-stx))
(for-each (check-id stx) ids)
ids))
(define-for-syntax (check-dup-binding stx idss)
(let ([dup-id (check-duplicate-identifier (apply append idss))])
(when dup-id
(raise-syntax-error #f "duplicate binding" stx dup-id))))
(define-for-syntax (do-let-syntax stx rec? multi? let-id def-id need-top-decl?)
(syntax-case stx ()
[(_ ([ids expr] ...) body ...)
(let ([all-ids (map (lambda (ids-stx)
(let ([ids (if multi?
(syntax->list ids-stx)
(list ids-stx))])
(unless ids
(raise-syntax-error
#f
"expected a parenthesized sequence of identifiers"
stx
ids-stx))
(for-each (lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"expected an identifier"
stx
id)))
ids)
ids))
(let ([all-ids (map ((if multi? check-ids check-id) stx)
(syntax->list #'(ids ...)))])
(let ([dup-id (check-duplicate-identifier
(apply append all-ids))])
(when dup-id
(raise-syntax-error
#f
"duplicate binding"
stx
dup-id)))
(check-dup-binding stx all-ids)
(if (eq? 'expression (syntax-local-context))
(with-syntax ([LET let-id])
(syntax/loc stx
(LET ([ids expr] ...)
(#%expression body)
...)))
(#%expression body)
...)))
(let ([def-ctx (syntax-local-make-definition-context)]
[ctx (list (gensym 'intdef))])
(syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx)
@ -111,6 +110,62 @@
;; ----------------------------------------
(define-syntax (splicing-letrec-syntaxes+values stx)
(syntax-case stx ()
[(_ ([sids sexpr] ...) ([vids vexpr] ...) body ...)
(let* ([all-sids (map (check-ids stx)
(syntax->list #'(sids ...)))]
[all-vids (map (check-ids stx)
(syntax->list #'(vids ...)))]
[all-ids (append all-sids all-vids)])
(check-dup-binding stx all-ids)
(if (eq? 'expression (syntax-local-context))
(syntax/loc stx
(letrec-syntaxes+values ([sids sexpr] ...) ([vids vexpr] ...)
(#%expression body) ...))
(let ([def-ctx (syntax-local-make-definition-context)]
[ctx (list (gensym 'intdef))])
(syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx)
(internal-definition-context-seal def-ctx)
(let* ([add-context
(lambda (expr)
(let ([q (local-expand #`(quote #,expr)
ctx
(list #'quote)
def-ctx)])
(syntax-case q ()
[(_ expr) #'expr])))]
[add-context-to-idss
(lambda (idss)
(map add-context idss))])
(with-syntax ([((sid ...) ...)
(map add-context-to-idss all-sids)]
[((vid ...) ...)
(map add-context-to-idss all-vids)]
[(sexpr ...)
(map add-context (syntax->list #'(sexpr ...)))]
[(vexpr ...)
(map add-context (syntax->list #'(vexpr ...)))]
[(body ...)
(map add-context (syntax->list #'(body ...)))])
(with-syntax ([top-decl
(if (equal? 'top-level (syntax-local-context))
#'(define-syntaxes (vid ... ...) (values))
#'(begin))])
(syntax/loc stx
(begin
top-decl
(define-syntaxes (sid ...) sexpr) ...
(define-values (vid ...) vexpr) ...
body ...))))))))]))
(define-syntax (splicing-local stx)
(do-local stx #'splicing-letrec-syntaxes+values))
;; ----------------------------------------
(define-syntax (splicing-syntax-parameterize stx)
(if (eq? 'expression (syntax-local-context))
;; Splicing is no help in an expression context:

72
collects/tests/mzscheme/syntax.ss
View File

@ -1249,7 +1249,77 @@
x)))
exn:fail:contract:variable?)
(test 82 'splicing-letrec-syntaxes+values
(let ()
(define q 77)
(splicing-letrec-syntaxes+values
([(mx) (lambda (stx) (quote-syntax (x)))]
[(m) (lambda (stx) (quote-syntax (mx)))])
([(x) (lambda () (q))]
[(q) (lambda () 82)])
(define (a) (m)))
(a)))
(test 82 'splicing-letrec-syntaxes+values
(eval
'(begin
(define q 77)
(splicing-letrec-syntaxes+values
([(mx) (lambda (stx) (quote-syntax (x)))]
[(m) (lambda (stx) (quote-syntax (mx)))])
([(x) (lambda () (q))]
[(q) (lambda () 82)])
(define (a) (m)))
(a))))
(test 82 'splicing-local
(let ()
(define (x) q)
(define q 77)
(define-syntax (m stx) (quote-syntax (x)))
(splicing-local
[(define-syntax (m stx) (quote-syntax (mx)))
(define (x) (q))
(define-syntax (mx stx) (quote-syntax (x)))
(define (q) 82)]
(define (a) (m)))
(a)))
(test 82 'splicing-local
(eval
'(begin
(define (x) q)
(define q 77)
(define-syntax (m stx) (quote-syntax (x)))
(splicing-local
[(define-syntax (m stx) (quote-syntax (mx)))
(define (x) (q))
(define-syntax (mx stx) (quote-syntax (x)))
(define (q) 82)]
(define (a) (m)))
(a))))
;; local names are not visible outside
(test 77 'splicing-local
(let ()
(define q 77)
(define-syntax (m stx) (quote-syntax (x)))
(splicing-local
[(define-syntax (m stx) (quote-syntax (q)))
(define (q) 82)]
(define (a) (m)))
(m)))
(test 77 'splicing-local
(eval
'(begin
(define q 77)
(define-syntax (m stx) (quote-syntax (x)))
(splicing-local
[(define-syntax (m stx) (quote-syntax (q)))
(define (q) 82)]
(define (a) (m)))
(m))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)