From 2c48c2c817d718915a6140ba1a22ac85c341642d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 26 Nov 2008 21:31:58 +0000 Subject: [PATCH] splicing-syntax-parameterize and docs for scheme/splicing svn: r12600 --- collects/scheme/private/stxparam.ss | 49 ++ collects/scheme/splicing.ss | 81 +++- collects/scheme/stxparam.ss | 35 +- collects/scribblings/reference/macros.scrbl | 1 + collects/scribblings/reference/package.scrbl | 4 + collects/scribblings/reference/splicing.scrbl | 58 +++ .../scribblings/reference/stx-param.scrbl | 5 +- collects/scribblings/reference/syntax.scrbl | 11 +- collects/tests/mzscheme/package.ss | 448 +++++++----------- 9 files changed, 358 insertions(+), 334 deletions(-) create mode 100644 collects/scheme/private/stxparam.ss create mode 100644 collects/scribblings/reference/splicing.scrbl diff --git a/collects/scheme/private/stxparam.ss b/collects/scheme/private/stxparam.ss new file mode 100644 index 0000000000..6871bb99be --- /dev/null +++ b/collects/scheme/private/stxparam.ss @@ -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 ...)))))]))) diff --git a/collects/scheme/splicing.ss b/collects/scheme/splicing.ss index 23eb987652..3a864ce061 100644 --- a/collects/scheme/splicing.ss +++ b/collects/scheme/splicing.ss @@ -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)) \ No newline at end of file + (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))])) diff --git a/collects/scheme/stxparam.ss b/collects/scheme/stxparam.ss index a584efd236..cb72eaa35c 100644 --- a/collects/scheme/stxparam.ss +++ b/collects/scheme/stxparam.ss @@ -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))) diff --git a/collects/scribblings/reference/macros.scrbl b/collects/scribblings/reference/macros.scrbl index 5b0803e0cb..67896acf3a 100644 --- a/collects/scribblings/reference/macros.scrbl +++ b/collects/scribblings/reference/macros.scrbl @@ -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"] diff --git a/collects/scribblings/reference/package.scrbl b/collects/scribblings/reference/package.scrbl index 1305de688a..1dd753af16 100644 --- a/collects/scribblings/reference/package.scrbl +++ b/collects/scribblings/reference/package.scrbl @@ -117,3 +117,7 @@ cookies (define vii 8) (define*-seven vii) vii)]} + +@; ---------------------------------------------------------------------- + +@close-eval[pack-eval] diff --git a/collects/scribblings/reference/splicing.scrbl b/collects/scribblings/reference/splicing.scrbl new file mode 100644 index 0000000000..634458661c --- /dev/null +++ b/collects/scribblings/reference/splicing.scrbl @@ -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] diff --git a/collects/scribblings/reference/stx-param.scrbl b/collects/scribblings/reference/stx-param.scrbl index 52e134e137..638b3475d7 100644 --- a/collects/scribblings/reference/stx-param.scrbl +++ b/collects/scribblings/reference/stx-param.scrbl @@ -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 diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index d55fdc6aef..365eb9ce7e 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -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.} diff --git a/collects/tests/mzscheme/package.ss b/collects/tests/mzscheme/package.ss index db30b1f1ed..f9f6b3f656 100644 --- a/collects/tests/mzscheme/package.ss +++ b/collects/tests/mzscheme/package.ss @@ -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)