splicing-syntax-parameterize and docs for scheme/splicing
svn: r12600
This commit is contained in:
Matthew Flatt
parent
91cdeb1b6e
commit
2c48c2c817
49
collects/scheme/private/stxparam.ss
Normal file
49
collects/scheme/private/stxparam.ss
Normal file
|
|
@ -0,0 +1,49 @@
|
|||
|
||||
(module stxparam '#%kernel
|
||||
(#%require "more-scheme.ss"
|
||||
"letstx-scheme.ss"
|
||||
"define.ss"
|
||||
(for-syntax '#%kernel
|
||||
"../stxparam-exptime.ss"
|
||||
"stx.ss" "stxcase-scheme.ss"
|
||||
"small-scheme.ss"
|
||||
"stxloc.ss" "stxparamkey.ss"))
|
||||
|
||||
(#%provide (for-syntax do-syntax-parameterize))
|
||||
|
||||
(define-for-syntax (do-syntax-parameterize stx let-syntaxes-id)
|
||||
(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)))
|
||||
(with-syntax ([let-syntaxes let-syntaxes-id])
|
||||
(syntax/loc stx
|
||||
(let-syntaxes ([(gen-id) (convert-renamer val)] ...)
|
||||
body0 body ...)))))])))
|
||||
|
|
@ -1,12 +1,16 @@
|
|||
#lang scheme/base
|
||||
(require (for-syntax scheme/base))
|
||||
(require (for-syntax scheme/base
|
||||
syntax/kerncase)
|
||||
"stxparam.ss"
|
||||
"private/stxparam.ss")
|
||||
|
||||
(provide splicing-let-syntax
|
||||
splicing-let-syntaxes
|
||||
splicing-letrec-syntax
|
||||
splicing-letrec-syntaxes)
|
||||
splicing-letrec-syntaxes
|
||||
splicing-syntax-parameterize)
|
||||
|
||||
(define-for-syntax (do-let-syntax stx rec? multi?)
|
||||
(define-for-syntax (do-let-syntax stx rec? multi? let-stx-id)
|
||||
(syntax-case stx ()
|
||||
[(_ ([ids expr] ...) body ...)
|
||||
(let ([all-ids (map (lambda (ids-stx)
|
||||
|
|
@ -38,13 +42,7 @@
|
|||
stx
|
||||
dup-id)))
|
||||
(if (eq? 'expression (syntax-local-context))
|
||||
(with-syntax ([let-stx (if rec?
|
||||
(if multi?
|
||||
#'letrec-syntaxes
|
||||
#'letrec-syntax)
|
||||
(if multi?
|
||||
#'let-syntaxes
|
||||
#'let-syntax))])
|
||||
(with-syntax ([let-stx let-stx-id])
|
||||
(syntax/loc stx
|
||||
(let-stx ([ids expr] ...)
|
||||
(#%expression body)
|
||||
|
|
@ -78,13 +76,68 @@
|
|||
body ...))))))]))
|
||||
|
||||
(define-syntax (splicing-let-syntax stx)
|
||||
(do-let-syntax stx #f #f))
|
||||
(do-let-syntax stx #f #f #'let-syntax))
|
||||
|
||||
(define-syntax (splicing-let-syntaxes stx)
|
||||
(do-let-syntax stx #f #t))
|
||||
(do-let-syntax stx #f #t #'let-syntaxes))
|
||||
|
||||
(define-syntax (splicing-letrec-syntax stx)
|
||||
(do-let-syntax stx #t #f))
|
||||
(do-let-syntax stx #t #f #'letrec-syntax))
|
||||
|
||||
(define-syntax (splicing-letrec-syntaxes stx)
|
||||
(do-let-syntax stx #t #t))
|
||||
(do-let-syntax stx #t #t #'letrec-syntaxes))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-syntax (splicing-syntax-parameterize stx)
|
||||
(if (eq? 'expression (syntax-local-context))
|
||||
;; Splicing is no help in an expression context:
|
||||
(do-syntax-parameterize stx #'let-syntaxes)
|
||||
;; Let `syntax-parameterize' check syntax, then continue
|
||||
(do-syntax-parameterize stx #'ssp-let-syntaxes)))
|
||||
|
||||
(define-syntax (ssp-let-syntaxes stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ([(id) rhs] ...) body ...)
|
||||
(with-syntax ([(splicing-temp ...) (generate-temporaries #'(id ...))])
|
||||
#'(begin
|
||||
;; Evaluate each RHS only once:
|
||||
(define-syntax splicing-temp rhs) ...
|
||||
;; Partially expand `body' to push down `let-syntax':
|
||||
(expand-ssp-body (id ...) (splicing-temp ...) body)
|
||||
...))]))
|
||||
|
||||
(define-syntax (expand-ssp-body stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (sp-id ...) (temp-id ...) body)
|
||||
(let ([body (local-expand #'(letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))]
|
||||
...)
|
||||
(force-expand body))
|
||||
(syntax-local-context)
|
||||
null ;; `force-expand' actually determines stopping places
|
||||
#f)])
|
||||
;; Extract expanded body out of `body':
|
||||
(syntax-case body (quote)
|
||||
[(ls _ _ (quoute body))
|
||||
(let ([body #'body])
|
||||
(syntax-case body (begin define-values define-syntaxes define-for-syntaxes)
|
||||
[(define-values (id ...) rhs)
|
||||
(syntax/loc body
|
||||
(define-values (id ...)
|
||||
(letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))] ...)
|
||||
rhs)))]
|
||||
[(define-syntaxes . _) body]
|
||||
[(define-for-syntaxes . _) body]
|
||||
[expr (syntax/loc body
|
||||
(letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))] ...)
|
||||
expr))]))]))]))
|
||||
|
||||
(define-syntax (force-expand stx)
|
||||
(syntax-case stx ()
|
||||
[(_ stx)
|
||||
;; Expand `stx' to reveal type of form, and then preserve it via
|
||||
;; `quote':
|
||||
#`(quote #,(local-expand #'stx
|
||||
'module
|
||||
(kernel-form-identifier-list)
|
||||
#f))]))
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
(#%require "private/more-scheme.ss"
|
||||
"private/letstx-scheme.ss"
|
||||
"private/define.ss"
|
||||
"private/stxparam.ss"
|
||||
(for-syntax '#%kernel
|
||||
"stxparam-exptime.ss"
|
||||
"private/stx.ss" "private/stxcase-scheme.ss"
|
||||
|
|
@ -30,36 +31,4 @@
|
|||
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-syntaxes ([(gen-id) (convert-renamer val)] ...)
|
||||
body0 body ...)))])))
|
||||
(do-syntax-parameterize stx #'let-syntaxes)))
|
||||
|
|
|
|||
|
|
@ -16,6 +16,7 @@ called.
|
|||
@include-section["stx-comp.scrbl"]
|
||||
@include-section["stx-trans.scrbl"]
|
||||
@include-section["stx-param.scrbl"]
|
||||
@include-section["splicing.scrbl"]
|
||||
@include-section["stx-props.scrbl"]
|
||||
@include-section["stx-certs.scrbl"]
|
||||
@include-section["stx-expand.scrbl"]
|
||||
|
|
|
|||
|
|
@ -117,3 +117,7 @@ cookies
|
|||
(define vii 8)
|
||||
(define*-seven vii)
|
||||
vii)]}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
||||
@close-eval[pack-eval]
|
||||
|
|
|
|||
58
collects/scribblings/reference/splicing.scrbl
Normal file
58
collects/scribblings/reference/splicing.scrbl
Normal file
|
|
@ -0,0 +1,58 @@
|
|||
#lang scribble/doc
|
||||
@(require "mz.ss"
|
||||
(for-label scheme/splicing
|
||||
scheme/stxparam))
|
||||
|
||||
@(define splice-eval (make-base-eval))
|
||||
@interaction-eval[#:eval splice-eval (require scheme/splicing
|
||||
scheme/stxparam
|
||||
(for-syntax scheme/base))]
|
||||
|
||||
@title[#:tag "splicing"]{Local Binding with Splicing Body}
|
||||
|
||||
@note-lib-only[scheme/splicing]
|
||||
|
||||
@deftogether[(
|
||||
@defidform[splicing-let-syntax]
|
||||
@defidform[splicing-letrec-syntax]
|
||||
@defidform[splicing-let-syntaxes]
|
||||
@defidform[splicing-letrec-syntaxes]
|
||||
)]{
|
||||
|
||||
Like @scheme[let-syntax], @scheme[letrec-syntax],
|
||||
@scheme[let-syntaxes], and @scheme[letrec-syntaxes], except that in a
|
||||
definition context, the body forms are spliced into the enclosing
|
||||
definition context (in the same as as for @scheme[begin]).
|
||||
|
||||
@examples[
|
||||
#:eval splice-eval
|
||||
(splicing-let-syntax ([one (lambda (stx) #'1)])
|
||||
(define o one))
|
||||
o
|
||||
one
|
||||
]}
|
||||
|
||||
@defidform[splicing-syntax-parameterize]{
|
||||
|
||||
Like @scheme[syntax-parameterize], except that in a definition
|
||||
context, the body forms are spliced into the enclosing definition
|
||||
context (in the same as as for @scheme[begin]), as long as the body
|
||||
forms are valid in an internal-definition context. In particular,
|
||||
@scheme[require] and @scheme[provide] forms cannot appear in the body
|
||||
of @scheme[splicing-syntax-parameterize], even if
|
||||
@scheme[splicing-syntax-parameterize] is used in a @scheme[module]
|
||||
body.
|
||||
|
||||
@examples[
|
||||
#:eval splice-eval
|
||||
(define-syntax-parameter place (lambda (stx) #'"Kansas"))
|
||||
(define-syntax-rule (where) `(at ,(place)))
|
||||
(where)
|
||||
(splicing-syntax-parameterize ([place (lambda (stx) #'"Oz")])
|
||||
(define here (where)))
|
||||
here
|
||||
]}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
||||
@close-eval[splice-eval]
|
||||
|
|
@ -1,7 +1,8 @@
|
|||
#lang scribble/doc
|
||||
@(require "mz.ss"
|
||||
(for-label scheme/stxparam
|
||||
scheme/stxparam-exptime))
|
||||
scheme/stxparam-exptime
|
||||
scheme/splicing))
|
||||
|
||||
@title[#:tag "stxparam"]{Syntax Parameters}
|
||||
|
||||
|
|
@ -27,6 +28,8 @@ the target's value.}
|
|||
|
||||
@defform[(syntax-parameterize ((id expr) ...) body-expr ...+)]{
|
||||
|
||||
@margin-note/ref{See also @scheme[splicing-syntax-parameterize].}
|
||||
|
||||
Each @scheme[id] must be bound to a @tech{syntax parameter} using
|
||||
@scheme[define-syntax-parameter]. Each @scheme[expr] is an expression
|
||||
in the @tech{transformer environment}. During the expansion of the
|
||||
|
|
|
|||
|
|
@ -10,7 +10,8 @@
|
|||
scheme/provide-syntax
|
||||
scheme/provide
|
||||
scheme/nest
|
||||
scheme/package))
|
||||
scheme/package
|
||||
scheme/splicing))
|
||||
|
||||
@(define cvt (schemefont "CVT"))
|
||||
|
||||
|
|
@ -1248,6 +1249,8 @@ and in the @scheme[body]s.
|
|||
|
||||
@defform[(let-syntax ([id trans-expr] ...) body ...+)]{
|
||||
|
||||
@margin-note/ref{See also @scheme[splicing-let-syntax].}
|
||||
|
||||
Creates a @tech{transformer binding} (see
|
||||
@secref["transformer-model"]) of each @scheme[id] with the value of
|
||||
@scheme[trans-expr], which is an expression at @tech{phase level} 1
|
||||
|
|
@ -1265,17 +1268,23 @@ Each @scheme[id] is bound in the @scheme[body]s, and not in other
|
|||
|
||||
@defform[(letrec-syntax ([id trans-expr] ...) body ...+)]{
|
||||
|
||||
@margin-note/ref{See also @scheme[splicing-letrec-syntax].}
|
||||
|
||||
Like @scheme[let-syntax], except that each @scheme[id] is also bound
|
||||
within all @scheme[trans-expr]s.}
|
||||
|
||||
@defform[(let-syntaxes ([(id ...) trans-expr] ...) body ...+)]{
|
||||
|
||||
@margin-note/ref{See also @scheme[splicing-let-syntaxes].}
|
||||
|
||||
Like @scheme[let-syntax], but each @scheme[trans-expr] must produce as
|
||||
many values as corresponding @scheme[id]s, each of which is bound to
|
||||
the corresponding value.}
|
||||
|
||||
@defform[(letrec-syntaxes ([(id ...) trans-expr] ...) body ...+)]{
|
||||
|
||||
@margin-note/ref{See also @scheme[splicing-letrec-syntaxes].}
|
||||
|
||||
Like @scheme[let-syntax], except that each @scheme[id] is also bound
|
||||
within all @scheme[trans-expr]s.}
|
||||
|
||||
|
|
|
|||
|
|
@ -1,309 +1,187 @@
|
|||
|
||||
(load-relative "loadtest.ss")
|
||||
(require mzlib/package)
|
||||
|
||||
(require scheme/package)
|
||||
|
||||
(Section 'packages)
|
||||
|
||||
(define expand-test-use-toplevel? #t)
|
||||
(define-syntax (test-pack-seq stx)
|
||||
(syntax-case stx ()
|
||||
[(_ result form ...)
|
||||
(let loop ([forms #'(form ...)]
|
||||
[pre null])
|
||||
(syntax-case forms ()
|
||||
[([#:fail expr exn?])
|
||||
(with-syntax ([(form ...) (reverse pre)])
|
||||
#`(test-pack-seq* (list (quote-syntax form) ...)
|
||||
(quote-syntax [#:fail expr])
|
||||
'expr
|
||||
exn?))]
|
||||
[(expr)
|
||||
(with-syntax ([(form ...) (reverse pre)])
|
||||
#`(test-pack-seq* (list (quote-syntax form) ...)
|
||||
(quote-syntax expr)
|
||||
'expr
|
||||
result))]
|
||||
[([#:fail expr exn?] . more)
|
||||
#`(begin
|
||||
#,(loop #'([#:fail expr exn?]) pre)
|
||||
#,(loop #'more pre))]
|
||||
[(form . more)
|
||||
(loop #'more (cons #'form pre))]))]))
|
||||
|
||||
;; syntax
|
||||
(syntax-test #'(dot))
|
||||
(syntax-test #'(dot 1))
|
||||
(syntax-test #'(dot 1 2))
|
||||
(syntax-test #'(dot 1 x))
|
||||
(define (fail? e)
|
||||
(syntax-case e ()
|
||||
[(#:fail e) #'e]
|
||||
[_ #f]))
|
||||
|
||||
(syntax-test #'(open))
|
||||
(syntax-test #'(open 1))
|
||||
(syntax-test #'(open 1 2))
|
||||
(syntax-test #'(open 1 x))
|
||||
(define (fail-expr e)
|
||||
(or (fail? e) e))
|
||||
|
||||
(syntax-test #'(define-dot))
|
||||
(syntax-test #'(define-dot 1))
|
||||
(syntax-test #'(define-dot x))
|
||||
(syntax-test #'(define-dot 1 2))
|
||||
(syntax-test #'(define-dot 1 x))
|
||||
(syntax-test #'(define-dot x 1))
|
||||
(syntax-test #'(define-dot x y))
|
||||
(syntax-test #'(define-dot 1 x y))
|
||||
(syntax-test #'(define-dot x y 3))
|
||||
(syntax-test #'(define-dot x 2 y))
|
||||
(define (test-pack-seq* forms expr q-expr result)
|
||||
(let ([orig (current-namespace)])
|
||||
(let ([ns (make-base-namespace)])
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-attach-module orig 'scheme/package)
|
||||
(namespace-require '(for-syntax scheme/base))
|
||||
(namespace-require 'scheme/package)
|
||||
(for-each eval forms)
|
||||
(if (fail? expr)
|
||||
(err/rt-test (eval (fail-expr expr)) result)
|
||||
(test result q-expr (eval expr)))))
|
||||
(let ([ns (make-base-namespace)])
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-attach-module orig 'scheme/package)
|
||||
(namespace-require '(for-syntax scheme/base))
|
||||
(namespace-require 'scheme/package)
|
||||
(let ([e `(let () (begin . ,forms) ,(fail-expr expr))])
|
||||
(if (fail? expr)
|
||||
(err/rt-test (eval e) result)
|
||||
(test result `(let ... ,q-expr) (eval e))))))
|
||||
(let ([ns (make-base-namespace)])
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-attach-module orig 'scheme/package)
|
||||
(let ([m `(module m scheme/base
|
||||
(require (for-syntax scheme/base)
|
||||
scheme/package)
|
||||
(begin . ,forms)
|
||||
(define result ,(fail-expr expr))
|
||||
(provide result))])
|
||||
(if (fail? expr)
|
||||
(err/rt-test (eval m) exn:fail:syntax?)
|
||||
(begin
|
||||
(eval m)
|
||||
(test result `(module ... ,q-expr) (dynamic-require ''m 'result)))))))))
|
||||
|
||||
(syntax-test #'(package))
|
||||
(syntax-test #'(package x))
|
||||
(syntax-test #'(package 1))
|
||||
(syntax-test #'(package x 1))
|
||||
(syntax-test #'(package x x))
|
||||
(syntax-test #'(package x (1)))
|
||||
;; ----------------------------------------
|
||||
|
||||
(test-pack-seq
|
||||
12
|
||||
(define-package p (x)
|
||||
(define y 5)
|
||||
(define x 12))
|
||||
[#:fail x exn:fail:contract:variable?]
|
||||
(open-package p)
|
||||
x
|
||||
[#:fail y exn:fail:contract:variable?])
|
||||
|
||||
(test-pack-seq
|
||||
13
|
||||
(define-package p (q)
|
||||
(define-package q (x)
|
||||
(define y 8)
|
||||
(define x 13)))
|
||||
[#:fail x exn:fail:contract:variable?]
|
||||
[#:fail (open-package q) exn:fail:syntax?]
|
||||
(open-package p)
|
||||
[#:fail x exn:fail:contract:variable?]
|
||||
(open-package q)
|
||||
x
|
||||
[#:fail y exn:fail:contract:variable?])
|
||||
|
||||
;; Providing
|
||||
(package p1 all-defined
|
||||
(define x 10)
|
||||
(package y all-defined
|
||||
(define x 12)))
|
||||
(test-pack-seq
|
||||
14
|
||||
(define-package p (q)
|
||||
(define-package q (r)
|
||||
(define-package r (x)
|
||||
(define x 14))))
|
||||
[#:fail x exn:fail:contract:variable?]
|
||||
[#:fail (open-package q) exn:fail:syntax?]
|
||||
[#:fail (open-package r) exn:fail:syntax?]
|
||||
(open-package p)
|
||||
(open-package q)
|
||||
(open-package r)
|
||||
x)
|
||||
|
||||
(package p2 ()
|
||||
(define x 10))
|
||||
(test-pack-seq
|
||||
15
|
||||
(define-package p (x)
|
||||
(define x 15))
|
||||
[#:fail x exn:fail:contract:variable?]
|
||||
(define-package q #:all-defined
|
||||
(open-package p))
|
||||
[#:fail x exn:fail:contract:variable?]
|
||||
(open-package q)
|
||||
x)
|
||||
|
||||
(package p3 (x)
|
||||
(package x all-defined
|
||||
(define x 10)))
|
||||
(test-pack-seq
|
||||
'(16 160)
|
||||
(define-package p #:all-defined
|
||||
(define x 16)
|
||||
(define y 160))
|
||||
(open-package p)
|
||||
(list x y))
|
||||
|
||||
(package p4 all-defined
|
||||
(package x (x)
|
||||
(define x 10)
|
||||
(define y 11)))
|
||||
(test-pack-seq
|
||||
170
|
||||
(define-package p #:all-defined-except (x)
|
||||
(define x 17)
|
||||
(define y 170))
|
||||
(open-package p)
|
||||
[#:fail x exn:fail:contract:variable?]
|
||||
y)
|
||||
|
||||
(define exn:variable? exn:fail:contract:variable?)
|
||||
;; ----------------------------------------
|
||||
|
||||
(err/rt-test xxxx exn:variable?)
|
||||
(test 10 "" (dot p1 x))
|
||||
(test 12 "" (dot p1 y x))
|
||||
(syntax-test #'(dot p2 x))
|
||||
(test 10 "" (dot p3 x x))
|
||||
(test 10 "" (dot p4 x x))
|
||||
(syntax-test #'(dot p4 x y))
|
||||
(syntax-test #'(package p (x)))
|
||||
(syntax-test #'(package p (x) (package y (x) (define x 10))))
|
||||
(test-pack-seq
|
||||
2
|
||||
(define-package p (x)
|
||||
(define* x 1)
|
||||
(define* x 2))
|
||||
(open-package p)
|
||||
x)
|
||||
|
||||
;; Internal-defines
|
||||
(let ((p1 1)
|
||||
(x 2))
|
||||
(define x 1111)
|
||||
(package p1 all-defined
|
||||
(define x 10)
|
||||
(package y all-defined
|
||||
(define x 12)))
|
||||
|
||||
(package p2 ()
|
||||
(define x 10))
|
||||
|
||||
(package p3 (x)
|
||||
(package x all-defined
|
||||
(define x 10)))
|
||||
|
||||
(package p4 all-defined
|
||||
(package x (x)
|
||||
(define x 10)
|
||||
(define y 11)))
|
||||
|
||||
(test 10 "" (dot p1 x))
|
||||
(test 12 "" (dot p1 y x))
|
||||
(syntax-test #'(dot p2 x))
|
||||
(test 10 "" (dot p3 x x))
|
||||
(test 10 "" (dot p4 x x))
|
||||
(syntax-test #'(dot p4 x y)))
|
||||
(syntax-test #'(let () (package p (x)) 1))
|
||||
(syntax-test #'(let () (package p (x) (package y (x) (define x 10))) 1))
|
||||
(syntax-test #'(let ((all-defined 1)) (package p all-defined (define s 1)) 1))
|
||||
(test-pack-seq
|
||||
'(2 1)
|
||||
(define-package p (x y)
|
||||
(define* x 1)
|
||||
(define y x)
|
||||
(define* x 2))
|
||||
(open-package p)
|
||||
(list x y))
|
||||
|
||||
;; starred defines
|
||||
(package p5 all-defined
|
||||
(define*-values (x) 10)
|
||||
(define*-values (f) (lambda () x))
|
||||
(define*-values (x) 12))
|
||||
(test 12 "" (dot p5 x))
|
||||
(test 10 "" ((dot p5 f)))
|
||||
(test-pack-seq
|
||||
'(2 1)
|
||||
(define-package p (x y)
|
||||
(define* x 1)
|
||||
(define y x)
|
||||
(define* x 2))
|
||||
(open-package p)
|
||||
(list x y))
|
||||
|
||||
;; mutual references
|
||||
(package p99 all-defined
|
||||
(define (f) x)
|
||||
(define x 77))
|
||||
(test 77 "" (dot p99 x))
|
||||
(test 77 "" ((dot p99 f)))
|
||||
(let ()
|
||||
(package p99. all-defined
|
||||
(define (f) x)
|
||||
(define x 177))
|
||||
(test 177 "" (dot p99. x))
|
||||
(test 177 "" ((dot p99. f))))
|
||||
;;
|
||||
(package p98 all-defined
|
||||
(define (f) x)
|
||||
(define* y 11)
|
||||
(define x 78))
|
||||
(test 78 "" (dot p98 x))
|
||||
(test 11 "" (dot p98 y))
|
||||
(test 78 "" ((dot p98 f)))
|
||||
(let ()
|
||||
(package p98. all-defined
|
||||
(define (f) x)
|
||||
(define* y 111)
|
||||
(define x 178))
|
||||
(test 178 "" (dot p98. x))
|
||||
(test 111 "" (dot p98. y))
|
||||
(test 178 "" ((dot p98. f))))
|
||||
;; ----------------------------------------
|
||||
|
||||
;; nesting
|
||||
(package p6 all-defined
|
||||
(package xx all-defined
|
||||
(define x 10))
|
||||
(package z all-defined
|
||||
(package a all-defined
|
||||
(define z 111)))
|
||||
(define y (dot xx x))
|
||||
(define x 11))
|
||||
(test-pack-seq
|
||||
'(17 12)
|
||||
(define-syntax-rule (mk id)
|
||||
(begin
|
||||
(define-package p (x)
|
||||
(define x 17))
|
||||
(open-package p)
|
||||
(define id x)))
|
||||
(define x 12)
|
||||
(mk z)
|
||||
(list z x))
|
||||
|
||||
(test 11 "" (dot p6 x))
|
||||
(test 10 "" (dot p6 y))
|
||||
(syntax-test #'(dot p6 x x))
|
||||
(test 111 "" (dot p6 z a z))
|
||||
|
||||
;; open
|
||||
(let ()
|
||||
(package p7 all-defined
|
||||
(define a 1)
|
||||
(define b 2)
|
||||
(define c 3))
|
||||
(let ()
|
||||
(package p8 all-defined
|
||||
(open* p7)
|
||||
(define* c 4))
|
||||
(test 1 "" (dot p8 a))
|
||||
(test 1 "" (dot p7 a))
|
||||
(test 2 "" (dot p8 b))
|
||||
(test 2 "" (dot p7 b))
|
||||
(test 4 "" (dot p8 c))
|
||||
(test 3 "" (dot p7 c))))
|
||||
|
||||
(let ()
|
||||
;; Same test as above, but without nested lets:
|
||||
(package p7. all-defined
|
||||
(define a 10)
|
||||
(define b 20)
|
||||
(define c 30))
|
||||
(package p8. all-defined
|
||||
(open* p7.)
|
||||
(define* c 40))
|
||||
(test 10 "" (dot p8. a))
|
||||
(test 10 "" (dot p7. a))
|
||||
(test 20 "" (dot p8. b))
|
||||
(test 20 "" (dot p7. b))
|
||||
(test 40 "" (dot p8. c))
|
||||
(test 30 "" (dot p7. c)))
|
||||
|
||||
(let ()
|
||||
(package p9 all-defined
|
||||
(package x all-defined
|
||||
(define x 1)))
|
||||
(let ()
|
||||
(open p9)
|
||||
(test 1 "" (dot x x))))
|
||||
|
||||
(let ()
|
||||
(package p9 all-defined
|
||||
(package x all-defined
|
||||
(define x 1)))
|
||||
(let ()
|
||||
(open p9 x)
|
||||
(test 1 "" x)))
|
||||
|
||||
(syntax-test #'(open x))
|
||||
(syntax-test #'(let () (package y all-defined (package z ())) (let () (open y a))))
|
||||
(syntax-test #'(let () (package y all-defined (package z ())) (let () (open y z a))))
|
||||
|
||||
;; open* after use => no capture
|
||||
(let ([x 99])
|
||||
(package yyy ()
|
||||
(package p (x) (define x 8))
|
||||
(define (f) x)
|
||||
(open* p)
|
||||
(test 99 f))
|
||||
'ok)
|
||||
;; open after use => capture
|
||||
(package yyy ()
|
||||
(package p (x)
|
||||
(define x 88))
|
||||
(define (f) x)
|
||||
(open p)
|
||||
(test 88 f))
|
||||
|
||||
;; Mutually referential packages:
|
||||
(let ()
|
||||
(package o (odd)
|
||||
(define (odd x) (if (zero? x) #f (even (sub1 x)))))
|
||||
(package e (even)
|
||||
(define (even x) (if (zero? x) #t (odd (sub1 x)))))
|
||||
(open o)
|
||||
(open e)
|
||||
(test #t odd 17)
|
||||
(test #f even 19))
|
||||
(err/rt-test
|
||||
;; Like above, but omit an open:
|
||||
(let ()
|
||||
(package o (odd)
|
||||
(define (odd x) (if (zero? x) #f (even (sub1 x)))))
|
||||
(package e (even)
|
||||
(define (even x) (if (zero? x) #t (odd (sub1 x)))))
|
||||
(open o)
|
||||
(odd 17))
|
||||
exn:variable?)
|
||||
(err/rt-test
|
||||
;; Omit the other open:
|
||||
(let ()
|
||||
(package o (odd)
|
||||
(define (odd x) (if (zero? x) #f (even (sub1 x)))))
|
||||
(package e (even)
|
||||
(define (even x) (if (zero? x) #t (odd (sub1 x)))))
|
||||
(open e)
|
||||
(even 17))
|
||||
exn:variable?)
|
||||
;; Same as working, but in a package:
|
||||
(package yyy ()
|
||||
(package o (odd)
|
||||
(define (odd x) (if (zero? x) #f (even (sub1 x)))))
|
||||
(package e (even)
|
||||
(define (even x) (if (zero? x) #t (odd (sub1 x)))))
|
||||
(open o)
|
||||
(open e)
|
||||
(test #t odd 17)
|
||||
(test #f even 19))
|
||||
(err/rt-test
|
||||
;; open* shouldn't work:
|
||||
(let ()
|
||||
(package yyy ()
|
||||
(package o (odd)
|
||||
(define (odd x) (if (zero? x) #f (even (sub1 x)))))
|
||||
(package e (even)
|
||||
(define (even x) (if (zero? x) #t (odd (sub1 x)))))
|
||||
(open* o)
|
||||
(open e)
|
||||
(odd 17))
|
||||
'ok)
|
||||
exn:variable?)
|
||||
|
||||
;; define-dot
|
||||
(let ()
|
||||
(package x all-defined
|
||||
(define z 10))
|
||||
(define-dot a x z)
|
||||
(test 10 "" a))
|
||||
(let ()
|
||||
(package x all-defined
|
||||
(package y all-defined
|
||||
(define z 10)))
|
||||
(define-dot a x y)
|
||||
(define-dot b a z)
|
||||
(test 10 "" b))
|
||||
|
||||
(syntax-test #'(let () (package x ()) (define-dot a x c) 1))
|
||||
|
||||
;; dot
|
||||
(let ()
|
||||
(package x all-defined
|
||||
(define z 10))
|
||||
(test 10 "" (dot x z)))
|
||||
(let ()
|
||||
(package x all-defined
|
||||
(package y all-defined
|
||||
(define z 10)))
|
||||
(define-dot a x y)
|
||||
(test 10 "" (dot a z)))
|
||||
(syntax-test #'(let () (package x ()) (dot x c)))
|
||||
|
||||
|
||||
(define expand-test-use-toplevel? #f)
|
||||
;; ----------------------------------------
|
||||
|
||||
(report-errs)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user