diff --git a/collects/framework/private/main.rkt b/collects/framework/private/main.rkt index 710e8ea00f..815790e0cb 100644 --- a/collects/framework/private/main.rkt +++ b/collects/framework/private/main.rkt @@ -248,7 +248,7 @@ letrec-values with-syntax with-continuation-mark - module module* + module module* module+ match match-let match-let* match-letrec let/cc let/ec letcc catch let-syntax letrec-syntax fluid-let-syntax letrec-syntaxes+values diff --git a/collects/racket/private/base.rkt b/collects/racket/private/base.rkt index 793f680d7b..797f99d769 100644 --- a/collects/racket/private/base.rkt +++ b/collects/racket/private/base.rkt @@ -10,6 +10,7 @@ "namespace.rkt" "struct.rkt" "cert.rkt" + "submodule.rkt" (for-syntax "stxcase-scheme.rkt")) (#%provide (all-from-except "pre-base.rkt" @@ -33,6 +34,7 @@ (all-from-except "qqstx.rkt" quasidatum undatum undatum-splicing) (all-from "namespace.rkt") (all-from "cert.rkt") + (all-from "submodule.rkt") (for-syntax syntax-rules syntax-id-rules ... _) (rename -open-input-file open-input-file) (rename -open-output-file open-output-file) diff --git a/collects/racket/private/submodule.rkt b/collects/racket/private/submodule.rkt new file mode 100644 index 0000000000..8aef98f6e9 --- /dev/null +++ b/collects/racket/private/submodule.rkt @@ -0,0 +1,73 @@ +(module module+ '#%kernel + (#%require "more-scheme.rkt" + "modbeg.rkt" + (for-syntax '#%kernel + "stxcase-scheme.rkt" + "more-scheme.rkt" + "letstx-scheme.rkt" + "qqstx.rkt")) + + (#%provide module+) + + (define-syntaxes (module+) + (lambda (stx) + (case (syntax-local-context) + [(module-begin) + (quasisyntax/loc stx (begin #,stx))] + [(module) + (syntax-case stx () + [(_ the-submodule e ...) + (begin + (unless (symbol? (syntax-e #'the-submodule)) + (raise-syntax-error #f + "expected an identifier for a submodule, found something else" + stx + #'the-submodule)) + ;; This looks it up the first time and is allowed to create a + ;; list and lift a module-end declaration if necessary: + (let ([stxs-box (get-stxs-box stx #'the-submodule #t)]) + (set-box! stxs-box + (append (reverse (syntax->list (syntax-local-introduce #'(e ...)))) + (unbox stxs-box)))) + (syntax/loc stx (begin)))])] + [else + (raise-syntax-error #f + "allowed only in a module body" + stx)]))) + + (begin-for-syntax + ;; The following table is newly instantiated for each module + ;; expansion that uses `module+', so it is effectively + ;; module-local: + (define-values (submodule->stxs-box) (make-weak-hash)) + (define-values (get-stxs-box) + (lambda (form-stx the-submodule-stx lift?) + (hash-ref! submodule->stxs-box (syntax-e the-submodule-stx) + (lambda () + (when lift? + (syntax-local-lift-module-end-declaration + ;; Use the lexical context of the first `module+' + ;; form as the context of the implicit `#%module-begin': + (datum->syntax + form-stx + (list #'define-module the-submodule-stx) + form-stx))) + (box null)))))) + + ;; A use of this form is lifted to the end of the enclosing module + ;; for each submodule created by `module+': + (define-syntaxes (define-module) + (lambda (stx) + (syntax-case stx () + [(_ the-submodule) + (let ([stxs-box (get-stxs-box #f #'the-submodule #f)]) + ;; Propagate the lexical context of the first `module+' + ;; for the implicit `#%module-begin': + (datum->syntax + stx + (list* + #'module* + #'the-submodule + #'#f + (map syntax-local-introduce (reverse (unbox stxs-box)))) + stx))])))) diff --git a/collects/racket/slice.rkt b/collects/racket/slice.rkt deleted file mode 100644 index 7c2f64b6e5..0000000000 --- a/collects/racket/slice.rkt +++ /dev/null @@ -1,47 +0,0 @@ -#lang racket/base -(require (for-syntax racket/base)) - -(begin-for-syntax - (define module->submodule->stxs-box (make-weak-hash)) - (define (get-stxs-box the-submodule-stx lift?) - (define the-module (syntax-source-module the-submodule-stx)) - (define submodule->stxs-box - (hash-ref! module->submodule->stxs-box the-module make-weak-hasheq)) - (define the-submodule-id - (syntax->datum the-submodule-stx)) - (define stxs-box - (hash-ref! submodule->stxs-box the-submodule-id - (λ () - (when lift? - (syntax-local-lift-module-end-declaration - (quasisyntax/loc the-submodule-stx - (define-module #,the-submodule-stx)))) - (box null)))) - stxs-box)) - -(define-syntax (slice stx) - (syntax-case stx () - [(_ the-submodule e ...) - (identifier? #'the-submodule) - (begin - ;; This looks it up the first time and is allowed to create a - ;; list if necessary - (get-stxs-box #'the-submodule #t) - #'(begin-for-syntax - (define stxs-box - (get-stxs-box #'the-submodule #f)) - (set-box! stxs-box - (append (unbox stxs-box) - (syntax->list #'(e ...))))))])) - -(define-syntax (define-module stx) - (syntax-case stx () - [(_ the-submodule) - (begin - (define stxs-box - (get-stxs-box #'the-submodule #f)) - (quasisyntax/loc #'the-submodule - (module* the-submodule #f - #,@(unbox stxs-box))))])) - -(provide slice) diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 4661f9f95b..9c1ab044ed 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -11,7 +11,6 @@ racket/package racket/splicing racket/runtime-path - racket/slice racket/performance-hint)) @(define require-eval (make-base-eval)) @@ -305,6 +304,22 @@ starts with an empty lexical context in the same way as a top-level have no effect on the submodule.} +@defform[(module+ id form ...)]{ + +Declares and/or adds to a @tech{submodule} named @racket[id]. + +Each addition for @racket[id] is combined in order to form the entire +submodule using @racket[(module* id #f ....)] at the end of the +enclosing module. If there is only one @racket[module+] for a given +@racket[id], then @racket[(module+ id form ...)] is equivalent to +@racket[(module* id #f form ...)]. + +A submodule must not be defined using @racket[module+] @emph{and} +@racket[module] or @racket[module*]. That is, if a submodule is made +of @racket[module+] pieces, then it must be made @emph{only} of +@racket[module+] pieces. } + + @defform[(#%module-begin form ...)]{ Legal only in a @tech{module begin context}, and handled by the @@ -320,24 +335,6 @@ Legal only in a @tech{module begin context}, and handled by the @racket[module] and @racket[module*] forms.} -@;------------------------------------------------------------------------ -@subsection[#:tag "slice"]{Slices: @racket[slice]} - -@note-lib-only[racket/slice] - -@defform[(slice id form ...)]{ - -Declares a @tech{slice} of a @tech{submodule} named @racket[id]. - -A @deftech{slice} is a piece of a @tech{submodule}. Each slice of a -submodule is combined to form the entire submodule at -the end of the enclosing module. If there is only one slice, then -@racket[(slice id form ...)] is equivalent to @racket[(module* id #f -form ...)]. It is an error for a submodule to be defined using -@racket[slice] @emph{and} @racket[module] or @racket[module*]. That -is, if a submodule is made of slices, then it must be -made @emph{only} of slices. } - @;------------------------------------------------------------------------ @section[#:tag '("require" "provide")]{Importing and Exporting: @racket[require] and @racket[provide]} diff --git a/collects/tests/racket/slice.rkt b/collects/tests/racket/slice.rkt deleted file mode 100644 index 1073a41ec8..0000000000 --- a/collects/tests/racket/slice.rkt +++ /dev/null @@ -1,18 +0,0 @@ -#lang racket/base - -(module fac1 racket/base - (printf "fac1 running\n") - (require racket/slice) - (define (! n) - (if (zero? n) - 1 - (* n (! (sub1 n))))) - (slice test - (printf "fac1 testing\n") - (require rackunit) - (check-equal? (! 0) 1)) - (slice test - (check-equal? (! 1) 1) - (check-equal? (! 5) 120))) - -(require (submod 'fac1 test)) diff --git a/collects/tests/racket/submodule.rktl b/collects/tests/racket/submodule.rktl index c9d96270e6..03410b2955 100644 --- a/collects/tests/racket/submodule.rktl +++ b/collects/tests/racket/submodule.rktl @@ -319,6 +319,49 @@ (test '(a) dynamic-require '(submod 'subm-example-12 a) 'a) (test 'b dynamic-require '(submod 'subm-example-12 b) 'b) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; The `section' form: + +(module module+-example-1 racket/base + (module+ alpha (define a root) (provide a)) + (module+ beta (define b (+ root 1)) (provide b)) + (module+ alpha (define aa (+ a a)) (provide aa)) + (module+ gamma + (require (submod "." ".." beta)) + (provide c) + (define c (+ b 1))) + (module+ beta) + (module+ beta) + (module+ beta) + (define root 1)) + +(test 1 dynamic-require '(submod 'module+-example-1 alpha) 'a) +(test 2 dynamic-require '(submod 'module+-example-1 alpha) 'aa) +(test 2 dynamic-require '(submod 'module+-example-1 beta) 'b) +(test 3 dynamic-require '(submod 'module+-example-1 gamma) 'c) + +(syntax-test #'(module+ a)) +(err/rt-test (eval #'(module m racket/base module+)) exn:fail:syntax?) +(err/rt-test (eval #'(module m racket/base (module+))) exn:fail:syntax?) +(err/rt-test (eval #'(module m racket/base (module+ 1))) exn:fail:syntax?) +(err/rt-test (eval #'(module m racket/base (module+ a . 2))) exn:fail:syntax?) + +;; Check that `#%module-begin' context is reasonable: +(module module+-example-2 racket/base + (module alt-mod-beg racket/base + (provide (rename-out [module-begin #%module-begin]) + module+ + #%datum + #%app + void) + (define-syntax-rule (module-begin a b c) + (#%module-begin a (define x (+ b c)) (provide x)))) + (module a (submod "." ".." alt-mod-beg) + (module+ b (void) 1 2) + 3 4)) + +(test 3 dynamic-require '(submod 'module+-example-2 a b) 'x) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs)