Add a `compatibility' collect for compatibility with other languages.
It includes `defmacro' and Chez-style modules (packages).
This commit is contained in:
Vincent St-Amour
parent
c408dfb03b
commit
ab2226a19e
4
collects/compatibility/info.rkt
Normal file
4
collects/compatibility/info.rkt
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
#lang setup/infotab
|
||||
|
||||
(define scribblings
|
||||
'(("scribblings/compatibility.scrbl" (multi-page) (legacy))))
|
||||
458
collects/compatibility/package.rkt
Normal file
458
collects/compatibility/package.rkt
Normal file
|
|
@ -0,0 +1,458 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
racket/list
|
||||
syntax/kerncase
|
||||
syntax/boundmap
|
||||
syntax/define
|
||||
syntax/flatten-begin
|
||||
syntax/context))
|
||||
|
||||
(provide define-package
|
||||
package-begin
|
||||
|
||||
open-package
|
||||
open*-package
|
||||
|
||||
define*
|
||||
define*-values
|
||||
define*-syntax
|
||||
define*-syntaxes
|
||||
|
||||
(for-syntax package?
|
||||
package-exported-identifiers
|
||||
package-original-identifiers))
|
||||
|
||||
(define-for-syntax (do-define-* stx define-values-id)
|
||||
(syntax-case stx ()
|
||||
[(_ (id ...) rhs)
|
||||
(let ([ids (syntax->list #'(id ...))])
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for definition"
|
||||
stx
|
||||
id)))
|
||||
ids)
|
||||
(with-syntax ([define-values define-values-id])
|
||||
(syntax/loc stx
|
||||
(define-values (id ...) rhs))))]))
|
||||
(define-syntax (-define*-values stx)
|
||||
(do-define-* stx #'define-values))
|
||||
(define-syntax (-define*-syntaxes stx)
|
||||
(do-define-* stx #'define-syntaxes))
|
||||
(define-syntax (define*-values stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (id ...) rhs)
|
||||
(syntax-property
|
||||
(syntax/loc stx (-define*-values (id ...) rhs))
|
||||
'certify-mode
|
||||
'transparent-binding)]))
|
||||
(define-syntax (define*-syntaxes stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (id ...) rhs)
|
||||
(syntax-property
|
||||
(syntax/loc stx (-define*-syntaxes (id ...) rhs))
|
||||
'certify-mode
|
||||
'transparent-binding)]))
|
||||
|
||||
(define-syntax (define* stx)
|
||||
(let-values ([(id rhs) (normalize-definition stx #'lambda)])
|
||||
(quasisyntax/loc stx
|
||||
(define*-values (#,id) #,rhs))))
|
||||
(define-syntax (define*-syntax stx)
|
||||
(let-values ([(id rhs) (normalize-definition stx #'lambda)])
|
||||
(quasisyntax/loc stx
|
||||
(define*-syntaxes (#,id) #,rhs))))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-struct package (exports hidden)
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:procedure (lambda (r stx)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"misuse of a package name"
|
||||
stx)))
|
||||
|
||||
(define (generate-hidden id)
|
||||
;; Like `generate-temporaries', but preserve the symbolic name
|
||||
((make-syntax-introducer) (datum->syntax #f (syntax-e id))))
|
||||
|
||||
(define (reverse-mapping who id exports hidden)
|
||||
(or (ormap (lambda (m)
|
||||
(and (free-identifier=? id (cdr m))
|
||||
(car m)))
|
||||
exports)
|
||||
(ormap (lambda (h)
|
||||
(and (free-identifier=? id h)
|
||||
;; Not at top level, where free-id=? is unreliable,
|
||||
;; and re-definition is ok:
|
||||
(identifier-binding id)
|
||||
;; Name is inaccessible. Generate a temporary to
|
||||
;; avoid potential duplicate-definition errors
|
||||
;; when the name is bound in the same context as
|
||||
;; the package.
|
||||
(generate-hidden id)))
|
||||
hidden)
|
||||
id)))
|
||||
|
||||
(define-for-syntax (move-props orig new)
|
||||
(datum->syntax new
|
||||
(syntax-e new)
|
||||
orig
|
||||
orig))
|
||||
|
||||
(define-for-syntax code-insp (variable-reference->module-declaration-inspector
|
||||
(#%variable-reference)))
|
||||
(define-for-syntax (disarm* stx)
|
||||
(cond
|
||||
[(and (syntax? stx)
|
||||
(pair? (syntax-e stx)))
|
||||
(let ([stx (syntax-disarm stx code-insp)])
|
||||
(datum->syntax stx (disarm* (syntax-e stx)) stx stx))]
|
||||
[(pair? stx) (cons (disarm* (car stx)) (disarm* (cdr stx)))]
|
||||
[else stx]))
|
||||
|
||||
(define-for-syntax (do-define-package stx exp-stx)
|
||||
(syntax-case exp-stx ()
|
||||
[(_ pack-id mode exports form ...)
|
||||
(let ([id #'pack-id]
|
||||
[exports #'exports]
|
||||
[mode (syntax-e #'mode)])
|
||||
(unless (eq? mode '#:begin)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error #f
|
||||
"expected an identifier"
|
||||
stx
|
||||
id)))
|
||||
(let ([exports
|
||||
(cond
|
||||
[(syntax->list exports)
|
||||
=> (lambda (l)
|
||||
(for-each (lambda (i)
|
||||
(unless (identifier? i)
|
||||
(raise-syntax-error #f
|
||||
"expected identifier to export"
|
||||
stx
|
||||
i)))
|
||||
l)
|
||||
(let ([dup-id (check-duplicate-identifier l)])
|
||||
(when dup-id
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate export"
|
||||
stx
|
||||
dup-id)))
|
||||
l)]
|
||||
[else (raise-syntax-error #f
|
||||
(format "expected a parenthesized sequence of identifiers ~a"
|
||||
(case mode
|
||||
[(#:only) "to export"]
|
||||
[(#:all-defined-except) "to exclude from export"]
|
||||
[else (format "for ~a" mode)]))
|
||||
stx
|
||||
exports)])])
|
||||
(let* ([def-ctx (syntax-local-make-definition-context)]
|
||||
[ctx (generate-expand-context #t)]
|
||||
[pre-package-id (lambda (id def-ctxes)
|
||||
(identifier-remove-from-definition-context
|
||||
id
|
||||
def-ctxes))]
|
||||
[kernel-forms (list*
|
||||
#'-define*-values
|
||||
#'-define*-syntaxes
|
||||
(kernel-form-identifier-list))]
|
||||
[init-exprs (syntax->list #'(form ...))]
|
||||
[new-bindings (make-bound-identifier-mapping)]
|
||||
[fixup-sub-package (lambda (renamed-exports renamed-defines def-ctxes)
|
||||
(lambda (stx)
|
||||
(syntax-case* (disarm* stx) (define-syntaxes #%plain-app make-package quote-syntax
|
||||
list cons #%plain-lambda)
|
||||
free-transformer-identifier=?
|
||||
[(define-syntaxes (pack-id)
|
||||
(#%plain-app
|
||||
make-package
|
||||
(#%plain-lambda ()
|
||||
(#%plain-app list
|
||||
(#%plain-app cons
|
||||
(quote-syntax export)
|
||||
(quote-syntax renamed))
|
||||
...))
|
||||
hidden))
|
||||
(with-syntax ([(export ...)
|
||||
(map (lambda (id)
|
||||
(if (or (ormap (lambda (e-id)
|
||||
(bound-identifier=? id e-id))
|
||||
renamed-exports)
|
||||
(not (ormap (lambda (e-id)
|
||||
(bound-identifier=? id e-id))
|
||||
renamed-defines)))
|
||||
;; Need to preserve the original
|
||||
(pre-package-id id def-ctxes)
|
||||
;; It's not accessible, so just hide the name
|
||||
;; to avoid re-binding errors. (Is this necessary,
|
||||
;; or would `pre-package-id' take care of it?)
|
||||
(generate-hidden id)))
|
||||
(syntax->list #'(export ...)))])
|
||||
(syntax/loc stx
|
||||
(define-syntaxes (pack-id)
|
||||
(make-package
|
||||
(lambda ()
|
||||
(list (cons (quote-syntax export)
|
||||
(quote-syntax renamed))
|
||||
...))
|
||||
hidden))))]
|
||||
[_ stx])))]
|
||||
[complement (lambda (bindings ids)
|
||||
(let ([tmp (make-bound-identifier-mapping)])
|
||||
(bound-identifier-mapping-for-each bindings
|
||||
(lambda (k v)
|
||||
(bound-identifier-mapping-put! tmp k #t)))
|
||||
(for-each (lambda (id)
|
||||
(bound-identifier-mapping-put! tmp id #f))
|
||||
ids)
|
||||
(filter
|
||||
values
|
||||
(bound-identifier-mapping-map tmp (lambda (k v) (and v k))))))])
|
||||
(let ([register-bindings!
|
||||
(lambda (ids)
|
||||
(for-each (lambda (id)
|
||||
(when (bound-identifier-mapping-get new-bindings id (lambda () #f))
|
||||
(raise-syntax-error #f
|
||||
"duplicate binding"
|
||||
stx
|
||||
id))
|
||||
(bound-identifier-mapping-put! new-bindings
|
||||
id
|
||||
#t))
|
||||
ids))]
|
||||
[add-package-context (lambda (def-ctxes)
|
||||
(lambda (stx)
|
||||
(let ([q (local-expand #`(quote #,stx)
|
||||
ctx
|
||||
(list #'quote)
|
||||
def-ctxes)])
|
||||
(syntax-case q ()
|
||||
[(_ stx) #'stx]))))])
|
||||
(let loop ([exprs init-exprs]
|
||||
[rev-forms null]
|
||||
[def-ctxes (list def-ctx)])
|
||||
(cond
|
||||
[(null? exprs)
|
||||
(for-each (lambda (def-ctx)
|
||||
(internal-definition-context-seal def-ctx))
|
||||
def-ctxes)
|
||||
(let ([exports-renamed (map (add-package-context def-ctxes) exports)]
|
||||
[defined-renamed (bound-identifier-mapping-map new-bindings
|
||||
(lambda (k v) k))])
|
||||
(for-each (lambda (ex renamed)
|
||||
(unless (bound-identifier-mapping-get new-bindings
|
||||
renamed
|
||||
(lambda () #f))
|
||||
(raise-syntax-error #f
|
||||
(format "no definition for ~a identifier"
|
||||
(case mode
|
||||
[(#:only) "exported"]
|
||||
[(#:all-defined-except) "excluded"]))
|
||||
stx
|
||||
ex)))
|
||||
exports
|
||||
exports-renamed)
|
||||
(let-values ([(exports exports-renamed)
|
||||
(if (memq mode '(#:only #:begin))
|
||||
(values exports exports-renamed)
|
||||
(let ([all-exports-renamed (complement new-bindings exports-renamed)])
|
||||
;; In case of define*, get only the last definition:
|
||||
(let ([tmp (make-bound-identifier-mapping)])
|
||||
(for-each (lambda (id)
|
||||
(bound-identifier-mapping-put!
|
||||
tmp
|
||||
((add-package-context def-ctxes)
|
||||
(pre-package-id id def-ctxes))
|
||||
#t))
|
||||
all-exports-renamed)
|
||||
(let* ([exports-renamed (bound-identifier-mapping-map tmp (lambda (k v) k))]
|
||||
[exports (map (lambda (id) (pre-package-id id def-ctxes))
|
||||
exports-renamed)])
|
||||
(values exports exports-renamed)))))]
|
||||
[(prune)
|
||||
(lambda (stx)
|
||||
(identifier-prune-lexical-context stx (list (syntax-e stx) '#%top)))])
|
||||
(with-syntax ([(export ...) (map prune exports)]
|
||||
[(renamed ...) (map prune exports-renamed)]
|
||||
[(hidden ...) (map prune (complement new-bindings exports-renamed))])
|
||||
(let ([body (map (fixup-sub-package exports-renamed defined-renamed def-ctxes)
|
||||
(reverse rev-forms))])
|
||||
(if (eq? mode '#:begin)
|
||||
(if (eq? 'expression (syntax-local-context))
|
||||
(quasisyntax/loc stx (let () #,@body))
|
||||
(quasisyntax/loc stx (begin #,@body)))
|
||||
(quasisyntax/loc stx
|
||||
(begin
|
||||
#,@(if (eq? 'top-level (syntax-local-context))
|
||||
;; delcare all bindings before they are used:
|
||||
#`((define-syntaxes #,defined-renamed (values)))
|
||||
null)
|
||||
#,@body
|
||||
(define-syntax pack-id
|
||||
(make-package
|
||||
(lambda ()
|
||||
(list (cons (quote-syntax export)
|
||||
(quote-syntax renamed))
|
||||
...))
|
||||
(lambda ()
|
||||
(list (quote-syntax hidden) ...)))))))))))]
|
||||
[else
|
||||
(let ([expr (local-expand (car exprs)
|
||||
ctx
|
||||
kernel-forms
|
||||
def-ctxes)])
|
||||
(syntax-case expr (begin)
|
||||
[(begin . rest)
|
||||
(loop (append (flatten-begin expr) (cdr exprs))
|
||||
rev-forms
|
||||
def-ctxes)]
|
||||
[(def (id ...) rhs)
|
||||
(and (or (free-identifier=? #'def #'define-syntaxes)
|
||||
(free-identifier=? #'def #'-define*-syntaxes))
|
||||
(andmap identifier? (syntax->list #'(id ...))))
|
||||
(with-syntax ([rhs (local-transformer-expand
|
||||
#'rhs
|
||||
'expression
|
||||
null)])
|
||||
(let ([star? (free-identifier=? #'def #'-define*-syntaxes)]
|
||||
[ids (syntax->list #'(id ...))])
|
||||
(let* ([def-ctx (if star?
|
||||
(syntax-local-make-definition-context (car def-ctxes))
|
||||
(last def-ctxes))]
|
||||
[ids (map
|
||||
(lambda (id) (syntax-property id 'unshadowable #t))
|
||||
(if star?
|
||||
(map (add-package-context (list def-ctx)) ids)
|
||||
ids))])
|
||||
(syntax-local-bind-syntaxes ids #'rhs def-ctx)
|
||||
(register-bindings! ids)
|
||||
(loop (cdr exprs)
|
||||
(cons (move-props expr #`(define-syntaxes #,ids rhs))
|
||||
rev-forms)
|
||||
(if star? (cons def-ctx def-ctxes) def-ctxes)))))]
|
||||
[(def (id ...) rhs)
|
||||
(and (or (free-identifier=? #'def #'define-values)
|
||||
(free-identifier=? #'def #'-define*-values))
|
||||
(andmap identifier? (syntax->list #'(id ...))))
|
||||
(let ([star? (free-identifier=? #'def #'-define*-values)]
|
||||
[ids (syntax->list #'(id ...))])
|
||||
(let* ([def-ctx (if star?
|
||||
(syntax-local-make-definition-context (car def-ctxes))
|
||||
(last def-ctxes))]
|
||||
[ids (map
|
||||
(lambda (id) (syntax-property id 'unshadowable #t))
|
||||
(if star?
|
||||
(map (add-package-context (list def-ctx)) ids)
|
||||
ids))])
|
||||
(syntax-local-bind-syntaxes ids #f def-ctx)
|
||||
(register-bindings! ids)
|
||||
(loop (cdr exprs)
|
||||
(cons (move-props expr #`(define-values #,ids rhs)) rev-forms)
|
||||
(if star? (cons def-ctx def-ctxes) def-ctxes))))]
|
||||
[else
|
||||
(loop (cdr exprs)
|
||||
(cons (if (and (eq? mode '#:begin)
|
||||
(null? (cdr exprs)))
|
||||
expr
|
||||
#`(define-values () (begin #,expr (values))))
|
||||
rev-forms)
|
||||
def-ctxes)]))]))))))]))
|
||||
|
||||
(define-syntax (define-package stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id #:all-defined form ...)
|
||||
(do-define-package stx #'(define-package id #:all-defined () form ...))]
|
||||
[(_ id #:all-defined-except ids form ...)
|
||||
(do-define-package stx stx)]
|
||||
[(_ id #:only ids form ...)
|
||||
(do-define-package stx stx)]
|
||||
[(_ id ids form ...)
|
||||
(do-define-package stx #'(define-package id #:only ids form ...))]))
|
||||
|
||||
(define-syntax (package-begin stx)
|
||||
(syntax-case stx ()
|
||||
[(_ form ...)
|
||||
(do-define-package stx #'(define-package #f #:begin () form ...))]))
|
||||
|
||||
(define-for-syntax (do-open stx define-syntaxes-id)
|
||||
(syntax-case stx ()
|
||||
[(_ pack-id)
|
||||
(let ([id #'pack-id])
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error #f
|
||||
"expected an identifier for a package"
|
||||
stx
|
||||
id))
|
||||
(let ([v (syntax-local-value id (lambda () #f))])
|
||||
(unless (package? v)
|
||||
(raise-syntax-error #f
|
||||
"identifier is not bound to a package"
|
||||
stx
|
||||
id))
|
||||
(let ([introduce (syntax-local-make-delta-introducer
|
||||
(syntax-local-introduce id))])
|
||||
(with-syntax ([(intro ...)
|
||||
(map (lambda (i)
|
||||
(syntax-local-introduce
|
||||
(syntax-local-get-shadower
|
||||
(introduce i))))
|
||||
(map car ((package-exports v))))]
|
||||
[(defined ...)
|
||||
(map (lambda (v) (syntax-local-introduce (cdr v)))
|
||||
((package-exports v)))]
|
||||
[((a . b) ...) (map (lambda (p)
|
||||
(cons (syntax-local-introduce (car p))
|
||||
(syntax-local-introduce (cdr p))))
|
||||
((package-exports v)))]
|
||||
[(h ...) (map syntax-local-introduce ((package-hidden v)))])
|
||||
(syntax-property
|
||||
#`(#,define-syntaxes-id (intro ...)
|
||||
(let ([rev-map (lambda (x)
|
||||
(reverse-mapping
|
||||
'pack-id
|
||||
x
|
||||
(list (cons (quote-syntax a)
|
||||
(quote-syntax b))
|
||||
...)
|
||||
(list (quote-syntax h) ...)))])
|
||||
(values (make-rename-transformer #'defined rev-map)
|
||||
...)))
|
||||
'disappeared-use
|
||||
(syntax-local-introduce id))))))]))
|
||||
|
||||
(define-syntax (open-package stx)
|
||||
(do-open stx #'define-syntaxes))
|
||||
(define-syntax (open*-package stx)
|
||||
(do-open stx #'define*-syntaxes))
|
||||
|
||||
(define-for-syntax (package-exported-identifiers id)
|
||||
(let ([v (and (identifier? id)
|
||||
(syntax-local-value id (lambda () #f)))])
|
||||
(unless (package? v)
|
||||
(if (identifier? id)
|
||||
(raise-arguments-error 'package-exported-identifiers "identifier is not bound to a package"
|
||||
"identifier" id)
|
||||
(raise-argument-error 'package-exported-identifiers "identifier?" id)))
|
||||
(let ([introduce (syntax-local-make-delta-introducer
|
||||
(syntax-local-introduce id))])
|
||||
(map (lambda (i)
|
||||
(syntax-local-introduce
|
||||
(syntax-local-get-shadower
|
||||
(introduce (car i)))))
|
||||
((package-exports v))))))
|
||||
|
||||
(define-for-syntax (package-original-identifiers id)
|
||||
(let ([v (and (identifier? id)
|
||||
(syntax-local-value id (lambda () #f)))])
|
||||
(unless (package? v)
|
||||
(if (identifier? id)
|
||||
(raise-arguments-error 'package-original-identifiers "identifier is not bound to a package"
|
||||
"identifier" id)
|
||||
(raise-argument-error 'package-original-identifiers "identifier?" id)))
|
||||
(map cdr ((package-exports v)))))
|
||||
24
collects/compatibility/scribblings/compatibility.scrbl
Normal file
24
collects/compatibility/scribblings/compatibility.scrbl
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/base scribble/manual)
|
||||
|
||||
@title[#:tag "compatibility"]{Compatibility: Features from Racket Relatives}
|
||||
|
||||
The @racketidfont{compatibility} collection includes features borrowed from
|
||||
other languages closely related to Racket.
|
||||
We provide these features to ease porting code from these languages to Racket.
|
||||
|
||||
We do @emph{not} recommend using any of these bindings in new code.
|
||||
Racket provides better alternatives, which we point to in this manual.
|
||||
We @emph{strongly} recommend using these alternatives.
|
||||
|
||||
@local-table-of-contents[#:style 'immediate-only]
|
||||
|
||||
@include-section["defmacro.scrbl"]
|
||||
@include-section["package.scrbl"]
|
||||
|
||||
@(bibliography
|
||||
(bib-entry #:key "Waddell99"
|
||||
#:author "Oscar Waddell and R. Kent Dybvig"
|
||||
#:title "Extending the Scope of Syntactic Abstraction"
|
||||
#:location "Principles of Programming Languages"
|
||||
#:date "1999"))
|
||||
|
|
@ -1,12 +1,12 @@
|
|||
#lang scribble/doc
|
||||
@(require "mz.rkt"
|
||||
(for-label racket/defmacro))
|
||||
@(require scribblings/reference/mz
|
||||
(for-label compatibility/defmacro))
|
||||
|
||||
@title[#:tag "defmacro"]{Legacy macro support}
|
||||
|
||||
@note-lib-only[racket/defmacro]
|
||||
@defmodule[compatibility/defmacro]
|
||||
|
||||
This @racketmodname[racket/defmacro] library provides support for
|
||||
This @racketmodname[compatibility/defmacro] library provides support for
|
||||
writing legacy macros. Support for @racket[defmacro] is provided
|
||||
primarily for porting code from other languages (e.g., some
|
||||
implementations of Scheme or Common Lisp) that use symbol-based
|
||||
|
|
@ -26,7 +26,8 @@ discouraged. Instead, consider using @racket[syntax-parse] or
|
|||
)]{
|
||||
|
||||
Defines a (non-hygienic) macro @racket[id] through a procedure that
|
||||
manipulates S-expressions, as opposed to @tech{syntax objects}.
|
||||
manipulates S-expressions, as opposed to
|
||||
@tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{syntax objects}.
|
||||
|
||||
In the first form, @racket[expr] must produce a procedure. In the
|
||||
second form, @racket[formals] determines the formal arguments of the
|
||||
|
|
@ -35,7 +36,8 @@ procedure body. The last form, with @racket[defmacro], is like the
|
|||
second form, but with slightly different parentheses.
|
||||
|
||||
In all cases, the procedure is generated in the
|
||||
@tech{transformer environment}, not the normal environment.
|
||||
@tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{
|
||||
transformer environment}, not the normal environment.
|
||||
|
||||
In a use of the macro,
|
||||
|
||||
155
collects/compatibility/scribblings/package.scrbl
Normal file
155
collects/compatibility/scribblings/package.scrbl
Normal file
|
|
@ -0,0 +1,155 @@
|
|||
#lang scribble/doc
|
||||
@(require scribblings/reference/mz (for-label compatibility/package))
|
||||
|
||||
@(define pack-eval (make-base-eval))
|
||||
@interaction-eval[#:eval pack-eval (require compatibility/package)]
|
||||
|
||||
@title[#:tag "compatibility-package"]{Limiting Scope: @racket[define-package], @racket[open-package], ...}
|
||||
|
||||
@defmodule[compatibility/package]
|
||||
|
||||
This @racketmodname[compatibility/package] library provides support for
|
||||
the Chez Scheme module system. Support for packages is provided
|
||||
primarily to help porting code.
|
||||
|
||||
Use of packages for modern Racket code is discouraged.
|
||||
Instead, consider using
|
||||
@tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{submodules}.
|
||||
|
||||
@deftogether[(
|
||||
@defform[(define-package package-id exports form ...)]
|
||||
@defform/subs[(open-package package-id)
|
||||
([exports (id ...)
|
||||
(code:line #:only (id ...))
|
||||
#:all-defined
|
||||
(code:line #:all-defined-except (id ...))])]
|
||||
)]{
|
||||
|
||||
@margin-note{The @racket[define-package] form is based on the @racketidfont{module}
|
||||
form of Chez Scheme @cite["Waddell99"].}
|
||||
|
||||
The @racket[define-package] form is similar to @racket[module], except
|
||||
that it can appear in any definition context. The @racket[form]s
|
||||
within a @racket[define-package] form can be definitions or
|
||||
expressions; definitions are not visible outside the
|
||||
@racket[define-package] form, but @racket[exports] determines a subset
|
||||
of the bindings that can be made visible outside the package using
|
||||
the definition form @racket[(open-package package-id)].
|
||||
|
||||
The @racket[(id ...)] and @racket[#:only (id ...)] @racket[exports]
|
||||
forms are equivalent: exactly the listed @racket[id]s are
|
||||
exported. The @racket[#:all-defined] form exports all definitions from
|
||||
the package body, and @racket[#:all-defined-except (id ...)] exports
|
||||
all definitions except the listed @racket[id]s.
|
||||
|
||||
All of the usual definition forms work within a
|
||||
@racket[define-package] body, and such definitions are visible to all
|
||||
expressions within the body (and, in particular, the definitions can
|
||||
refer to each other). However, @racket[define-package] handles
|
||||
@racket[define*], @racket[define*-syntax], @racket[define*-values],
|
||||
@racket[define*-syntaxes], and
|
||||
@racket[open*-package] specially: the bindings introduced by those
|
||||
forms within a @racket[define-package] body are visible only to
|
||||
@racket[form]s that appear later in the body, and they can shadow any
|
||||
binding from preceding @racket[form]s (even if the preceding binding
|
||||
did not use one of the special @racketidfont{*} definition forms). If
|
||||
an exported identifier is defined multiple times, the last definition
|
||||
is the exported one.
|
||||
|
||||
@examples[
|
||||
#:eval pack-eval
|
||||
(define-package presents (doll)
|
||||
(define doll "Molly Coddle")
|
||||
(define robot "Destructo"))
|
||||
doll
|
||||
robot
|
||||
(open-package presents)
|
||||
doll
|
||||
robot
|
||||
(define-package big-russian-doll (middle-russian-doll)
|
||||
(define-package middle-russian-doll (little-russian-doll)
|
||||
(define little-russian-doll "Anastasia")))
|
||||
(open-package big-russian-doll)
|
||||
(open-package middle-russian-doll)
|
||||
little-russian-doll
|
||||
]}
|
||||
|
||||
|
||||
@defform[(package-begin form ...)]{
|
||||
|
||||
Similar to @racket[define-package], but it only limits the visible of
|
||||
definitions without binding a package name. If the last @racket[form]
|
||||
is an expression, then the expression is in
|
||||
@tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{tail position}
|
||||
for the @racket[package-begin] form, so that its result is the
|
||||
@racket[package-begin] result.
|
||||
|
||||
A @racket[package-begin] form can be used as an expression, but if it
|
||||
is used in a context where definitions are allowed, then the
|
||||
definitions are essentially spliced into the enclosing context (though
|
||||
the defined bindings remain hidden outside the
|
||||
@racket[package-begin]).
|
||||
|
||||
@examples[
|
||||
#:eval pack-eval
|
||||
(package-begin
|
||||
(define secret "mimi")
|
||||
(list secret))
|
||||
secret
|
||||
]}
|
||||
|
||||
@deftogether[(
|
||||
@defidform[define*]
|
||||
@defidform[define*-values]
|
||||
@defidform[define*-syntax]
|
||||
@defidform[define*-syntaxes]
|
||||
@defidform[open*-package]
|
||||
)]{
|
||||
|
||||
Equivalent to @racket[define], @racket[define-values],
|
||||
@racket[define-syntax], @racket[define-syntaxes],
|
||||
and @racket[open-package], except within a
|
||||
@racket[define-package] or @racket[package-begin] form, where they
|
||||
create bindings that are visible only to later body forms.
|
||||
|
||||
@examples[
|
||||
#:eval pack-eval
|
||||
(define-package mail (cookies)
|
||||
(define* cookies (list 'sugar))
|
||||
(define* cookies (cons 'chocolate-chip cookies)))
|
||||
(open-package mail)
|
||||
cookies
|
||||
(define-syntax-rule (define-seven id) (define id 7))
|
||||
(define-syntax-rule (define*-seven id)
|
||||
(begin
|
||||
(define-package p (id) (define-seven id))
|
||||
(open*-package p)))
|
||||
(package-begin
|
||||
(define vii 8)
|
||||
(define*-seven vii)
|
||||
vii)]}
|
||||
|
||||
@deftogether[(
|
||||
@defproc[(package? [v any/c]) boolean?]
|
||||
@defproc[(package-exported-identifiers [id identifier?]) (listof identifier?)]
|
||||
@defproc[(package-original-identifiers [id identifier?]) (listof identifier?)]
|
||||
)]{
|
||||
|
||||
The @racket[package?], @racket[package-exported-identifiers], and
|
||||
@racket[package-original-identifiers] functions are exported
|
||||
@racket[for-syntax] by @racketmodname[compatibility/package].
|
||||
|
||||
The @racket[package?] predicate returns @racket[#t] if @racket[v] is a
|
||||
package value as obtained by @racket[syntax-local-value] on an
|
||||
identifier that is bound to a package.
|
||||
|
||||
Given such an identifier, the @racket[package-exported-identifiers]
|
||||
function returns a list of identifiers that correspond to the
|
||||
bindings that would be introduced by opening the package in the
|
||||
lexical context being expanded. The
|
||||
@racket[package-original-identifiers] function returns a parallel list
|
||||
of identifiers for existing bindings of package's exports.}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
||||
@close-eval[pack-eval]
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
#lang racket/base
|
||||
|
||||
;; deprecated library, see racket/defmacro
|
||||
;; deprecated library, see compatibility/defmacro
|
||||
;;
|
||||
;; for legacy use only
|
||||
|
||||
(require racket/defmacro)
|
||||
(provide (all-from-out racket/defmacro))
|
||||
(require compatibility/defmacro)
|
||||
(provide (all-from-out compatibility/defmacro))
|
||||
|
|
|
|||
|
|
@ -120,9 +120,9 @@ Re-exports @racketmodname[file/gzip].
|
|||
|
||||
@mzlib[defmacro]
|
||||
|
||||
@deprecated[@racketmodname[racket/defmacro]]{}
|
||||
@deprecated[@racketmodname[compatibility/defmacro]]{}
|
||||
|
||||
Re-exports @racketmodname[racket/defmacro].
|
||||
Re-exports @racketmodname[compatibility/defmacro].
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -1,458 +1,6 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
racket/list
|
||||
syntax/kerncase
|
||||
syntax/boundmap
|
||||
syntax/define
|
||||
syntax/flatten-begin
|
||||
syntax/context))
|
||||
|
||||
(provide define-package
|
||||
package-begin
|
||||
;; compatibility library, see compatibility/package
|
||||
|
||||
open-package
|
||||
open*-package
|
||||
|
||||
define*
|
||||
define*-values
|
||||
define*-syntax
|
||||
define*-syntaxes
|
||||
|
||||
(for-syntax package?
|
||||
package-exported-identifiers
|
||||
package-original-identifiers))
|
||||
|
||||
(define-for-syntax (do-define-* stx define-values-id)
|
||||
(syntax-case stx ()
|
||||
[(_ (id ...) rhs)
|
||||
(let ([ids (syntax->list #'(id ...))])
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for definition"
|
||||
stx
|
||||
id)))
|
||||
ids)
|
||||
(with-syntax ([define-values define-values-id])
|
||||
(syntax/loc stx
|
||||
(define-values (id ...) rhs))))]))
|
||||
(define-syntax (-define*-values stx)
|
||||
(do-define-* stx #'define-values))
|
||||
(define-syntax (-define*-syntaxes stx)
|
||||
(do-define-* stx #'define-syntaxes))
|
||||
(define-syntax (define*-values stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (id ...) rhs)
|
||||
(syntax-property
|
||||
(syntax/loc stx (-define*-values (id ...) rhs))
|
||||
'certify-mode
|
||||
'transparent-binding)]))
|
||||
(define-syntax (define*-syntaxes stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (id ...) rhs)
|
||||
(syntax-property
|
||||
(syntax/loc stx (-define*-syntaxes (id ...) rhs))
|
||||
'certify-mode
|
||||
'transparent-binding)]))
|
||||
|
||||
(define-syntax (define* stx)
|
||||
(let-values ([(id rhs) (normalize-definition stx #'lambda)])
|
||||
(quasisyntax/loc stx
|
||||
(define*-values (#,id) #,rhs))))
|
||||
(define-syntax (define*-syntax stx)
|
||||
(let-values ([(id rhs) (normalize-definition stx #'lambda)])
|
||||
(quasisyntax/loc stx
|
||||
(define*-syntaxes (#,id) #,rhs))))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-struct package (exports hidden)
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:procedure (lambda (r stx)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"misuse of a package name"
|
||||
stx)))
|
||||
|
||||
(define (generate-hidden id)
|
||||
;; Like `generate-temporaries', but preserve the symbolic name
|
||||
((make-syntax-introducer) (datum->syntax #f (syntax-e id))))
|
||||
|
||||
(define (reverse-mapping who id exports hidden)
|
||||
(or (ormap (lambda (m)
|
||||
(and (free-identifier=? id (cdr m))
|
||||
(car m)))
|
||||
exports)
|
||||
(ormap (lambda (h)
|
||||
(and (free-identifier=? id h)
|
||||
;; Not at top level, where free-id=? is unreliable,
|
||||
;; and re-definition is ok:
|
||||
(identifier-binding id)
|
||||
;; Name is inaccessible. Generate a temporary to
|
||||
;; avoid potential duplicate-definition errors
|
||||
;; when the name is bound in the same context as
|
||||
;; the package.
|
||||
(generate-hidden id)))
|
||||
hidden)
|
||||
id)))
|
||||
|
||||
(define-for-syntax (move-props orig new)
|
||||
(datum->syntax new
|
||||
(syntax-e new)
|
||||
orig
|
||||
orig))
|
||||
|
||||
(define-for-syntax code-insp (variable-reference->module-declaration-inspector
|
||||
(#%variable-reference)))
|
||||
(define-for-syntax (disarm* stx)
|
||||
(cond
|
||||
[(and (syntax? stx)
|
||||
(pair? (syntax-e stx)))
|
||||
(let ([stx (syntax-disarm stx code-insp)])
|
||||
(datum->syntax stx (disarm* (syntax-e stx)) stx stx))]
|
||||
[(pair? stx) (cons (disarm* (car stx)) (disarm* (cdr stx)))]
|
||||
[else stx]))
|
||||
|
||||
(define-for-syntax (do-define-package stx exp-stx)
|
||||
(syntax-case exp-stx ()
|
||||
[(_ pack-id mode exports form ...)
|
||||
(let ([id #'pack-id]
|
||||
[exports #'exports]
|
||||
[mode (syntax-e #'mode)])
|
||||
(unless (eq? mode '#:begin)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error #f
|
||||
"expected an identifier"
|
||||
stx
|
||||
id)))
|
||||
(let ([exports
|
||||
(cond
|
||||
[(syntax->list exports)
|
||||
=> (lambda (l)
|
||||
(for-each (lambda (i)
|
||||
(unless (identifier? i)
|
||||
(raise-syntax-error #f
|
||||
"expected identifier to export"
|
||||
stx
|
||||
i)))
|
||||
l)
|
||||
(let ([dup-id (check-duplicate-identifier l)])
|
||||
(when dup-id
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate export"
|
||||
stx
|
||||
dup-id)))
|
||||
l)]
|
||||
[else (raise-syntax-error #f
|
||||
(format "expected a parenthesized sequence of identifiers ~a"
|
||||
(case mode
|
||||
[(#:only) "to export"]
|
||||
[(#:all-defined-except) "to exclude from export"]
|
||||
[else (format "for ~a" mode)]))
|
||||
stx
|
||||
exports)])])
|
||||
(let* ([def-ctx (syntax-local-make-definition-context)]
|
||||
[ctx (generate-expand-context #t)]
|
||||
[pre-package-id (lambda (id def-ctxes)
|
||||
(identifier-remove-from-definition-context
|
||||
id
|
||||
def-ctxes))]
|
||||
[kernel-forms (list*
|
||||
#'-define*-values
|
||||
#'-define*-syntaxes
|
||||
(kernel-form-identifier-list))]
|
||||
[init-exprs (syntax->list #'(form ...))]
|
||||
[new-bindings (make-bound-identifier-mapping)]
|
||||
[fixup-sub-package (lambda (renamed-exports renamed-defines def-ctxes)
|
||||
(lambda (stx)
|
||||
(syntax-case* (disarm* stx) (define-syntaxes #%plain-app make-package quote-syntax
|
||||
list cons #%plain-lambda)
|
||||
free-transformer-identifier=?
|
||||
[(define-syntaxes (pack-id)
|
||||
(#%plain-app
|
||||
make-package
|
||||
(#%plain-lambda ()
|
||||
(#%plain-app list
|
||||
(#%plain-app cons
|
||||
(quote-syntax export)
|
||||
(quote-syntax renamed))
|
||||
...))
|
||||
hidden))
|
||||
(with-syntax ([(export ...)
|
||||
(map (lambda (id)
|
||||
(if (or (ormap (lambda (e-id)
|
||||
(bound-identifier=? id e-id))
|
||||
renamed-exports)
|
||||
(not (ormap (lambda (e-id)
|
||||
(bound-identifier=? id e-id))
|
||||
renamed-defines)))
|
||||
;; Need to preserve the original
|
||||
(pre-package-id id def-ctxes)
|
||||
;; It's not accessible, so just hide the name
|
||||
;; to avoid re-binding errors. (Is this necessary,
|
||||
;; or would `pre-package-id' take care of it?)
|
||||
(generate-hidden id)))
|
||||
(syntax->list #'(export ...)))])
|
||||
(syntax/loc stx
|
||||
(define-syntaxes (pack-id)
|
||||
(make-package
|
||||
(lambda ()
|
||||
(list (cons (quote-syntax export)
|
||||
(quote-syntax renamed))
|
||||
...))
|
||||
hidden))))]
|
||||
[_ stx])))]
|
||||
[complement (lambda (bindings ids)
|
||||
(let ([tmp (make-bound-identifier-mapping)])
|
||||
(bound-identifier-mapping-for-each bindings
|
||||
(lambda (k v)
|
||||
(bound-identifier-mapping-put! tmp k #t)))
|
||||
(for-each (lambda (id)
|
||||
(bound-identifier-mapping-put! tmp id #f))
|
||||
ids)
|
||||
(filter
|
||||
values
|
||||
(bound-identifier-mapping-map tmp (lambda (k v) (and v k))))))])
|
||||
(let ([register-bindings!
|
||||
(lambda (ids)
|
||||
(for-each (lambda (id)
|
||||
(when (bound-identifier-mapping-get new-bindings id (lambda () #f))
|
||||
(raise-syntax-error #f
|
||||
"duplicate binding"
|
||||
stx
|
||||
id))
|
||||
(bound-identifier-mapping-put! new-bindings
|
||||
id
|
||||
#t))
|
||||
ids))]
|
||||
[add-package-context (lambda (def-ctxes)
|
||||
(lambda (stx)
|
||||
(let ([q (local-expand #`(quote #,stx)
|
||||
ctx
|
||||
(list #'quote)
|
||||
def-ctxes)])
|
||||
(syntax-case q ()
|
||||
[(_ stx) #'stx]))))])
|
||||
(let loop ([exprs init-exprs]
|
||||
[rev-forms null]
|
||||
[def-ctxes (list def-ctx)])
|
||||
(cond
|
||||
[(null? exprs)
|
||||
(for-each (lambda (def-ctx)
|
||||
(internal-definition-context-seal def-ctx))
|
||||
def-ctxes)
|
||||
(let ([exports-renamed (map (add-package-context def-ctxes) exports)]
|
||||
[defined-renamed (bound-identifier-mapping-map new-bindings
|
||||
(lambda (k v) k))])
|
||||
(for-each (lambda (ex renamed)
|
||||
(unless (bound-identifier-mapping-get new-bindings
|
||||
renamed
|
||||
(lambda () #f))
|
||||
(raise-syntax-error #f
|
||||
(format "no definition for ~a identifier"
|
||||
(case mode
|
||||
[(#:only) "exported"]
|
||||
[(#:all-defined-except) "excluded"]))
|
||||
stx
|
||||
ex)))
|
||||
exports
|
||||
exports-renamed)
|
||||
(let-values ([(exports exports-renamed)
|
||||
(if (memq mode '(#:only #:begin))
|
||||
(values exports exports-renamed)
|
||||
(let ([all-exports-renamed (complement new-bindings exports-renamed)])
|
||||
;; In case of define*, get only the last definition:
|
||||
(let ([tmp (make-bound-identifier-mapping)])
|
||||
(for-each (lambda (id)
|
||||
(bound-identifier-mapping-put!
|
||||
tmp
|
||||
((add-package-context def-ctxes)
|
||||
(pre-package-id id def-ctxes))
|
||||
#t))
|
||||
all-exports-renamed)
|
||||
(let* ([exports-renamed (bound-identifier-mapping-map tmp (lambda (k v) k))]
|
||||
[exports (map (lambda (id) (pre-package-id id def-ctxes))
|
||||
exports-renamed)])
|
||||
(values exports exports-renamed)))))]
|
||||
[(prune)
|
||||
(lambda (stx)
|
||||
(identifier-prune-lexical-context stx (list (syntax-e stx) '#%top)))])
|
||||
(with-syntax ([(export ...) (map prune exports)]
|
||||
[(renamed ...) (map prune exports-renamed)]
|
||||
[(hidden ...) (map prune (complement new-bindings exports-renamed))])
|
||||
(let ([body (map (fixup-sub-package exports-renamed defined-renamed def-ctxes)
|
||||
(reverse rev-forms))])
|
||||
(if (eq? mode '#:begin)
|
||||
(if (eq? 'expression (syntax-local-context))
|
||||
(quasisyntax/loc stx (let () #,@body))
|
||||
(quasisyntax/loc stx (begin #,@body)))
|
||||
(quasisyntax/loc stx
|
||||
(begin
|
||||
#,@(if (eq? 'top-level (syntax-local-context))
|
||||
;; delcare all bindings before they are used:
|
||||
#`((define-syntaxes #,defined-renamed (values)))
|
||||
null)
|
||||
#,@body
|
||||
(define-syntax pack-id
|
||||
(make-package
|
||||
(lambda ()
|
||||
(list (cons (quote-syntax export)
|
||||
(quote-syntax renamed))
|
||||
...))
|
||||
(lambda ()
|
||||
(list (quote-syntax hidden) ...)))))))))))]
|
||||
[else
|
||||
(let ([expr (local-expand (car exprs)
|
||||
ctx
|
||||
kernel-forms
|
||||
def-ctxes)])
|
||||
(syntax-case expr (begin)
|
||||
[(begin . rest)
|
||||
(loop (append (flatten-begin expr) (cdr exprs))
|
||||
rev-forms
|
||||
def-ctxes)]
|
||||
[(def (id ...) rhs)
|
||||
(and (or (free-identifier=? #'def #'define-syntaxes)
|
||||
(free-identifier=? #'def #'-define*-syntaxes))
|
||||
(andmap identifier? (syntax->list #'(id ...))))
|
||||
(with-syntax ([rhs (local-transformer-expand
|
||||
#'rhs
|
||||
'expression
|
||||
null)])
|
||||
(let ([star? (free-identifier=? #'def #'-define*-syntaxes)]
|
||||
[ids (syntax->list #'(id ...))])
|
||||
(let* ([def-ctx (if star?
|
||||
(syntax-local-make-definition-context (car def-ctxes))
|
||||
(last def-ctxes))]
|
||||
[ids (map
|
||||
(lambda (id) (syntax-property id 'unshadowable #t))
|
||||
(if star?
|
||||
(map (add-package-context (list def-ctx)) ids)
|
||||
ids))])
|
||||
(syntax-local-bind-syntaxes ids #'rhs def-ctx)
|
||||
(register-bindings! ids)
|
||||
(loop (cdr exprs)
|
||||
(cons (move-props expr #`(define-syntaxes #,ids rhs))
|
||||
rev-forms)
|
||||
(if star? (cons def-ctx def-ctxes) def-ctxes)))))]
|
||||
[(def (id ...) rhs)
|
||||
(and (or (free-identifier=? #'def #'define-values)
|
||||
(free-identifier=? #'def #'-define*-values))
|
||||
(andmap identifier? (syntax->list #'(id ...))))
|
||||
(let ([star? (free-identifier=? #'def #'-define*-values)]
|
||||
[ids (syntax->list #'(id ...))])
|
||||
(let* ([def-ctx (if star?
|
||||
(syntax-local-make-definition-context (car def-ctxes))
|
||||
(last def-ctxes))]
|
||||
[ids (map
|
||||
(lambda (id) (syntax-property id 'unshadowable #t))
|
||||
(if star?
|
||||
(map (add-package-context (list def-ctx)) ids)
|
||||
ids))])
|
||||
(syntax-local-bind-syntaxes ids #f def-ctx)
|
||||
(register-bindings! ids)
|
||||
(loop (cdr exprs)
|
||||
(cons (move-props expr #`(define-values #,ids rhs)) rev-forms)
|
||||
(if star? (cons def-ctx def-ctxes) def-ctxes))))]
|
||||
[else
|
||||
(loop (cdr exprs)
|
||||
(cons (if (and (eq? mode '#:begin)
|
||||
(null? (cdr exprs)))
|
||||
expr
|
||||
#`(define-values () (begin #,expr (values))))
|
||||
rev-forms)
|
||||
def-ctxes)]))]))))))]))
|
||||
|
||||
(define-syntax (define-package stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id #:all-defined form ...)
|
||||
(do-define-package stx #'(define-package id #:all-defined () form ...))]
|
||||
[(_ id #:all-defined-except ids form ...)
|
||||
(do-define-package stx stx)]
|
||||
[(_ id #:only ids form ...)
|
||||
(do-define-package stx stx)]
|
||||
[(_ id ids form ...)
|
||||
(do-define-package stx #'(define-package id #:only ids form ...))]))
|
||||
|
||||
(define-syntax (package-begin stx)
|
||||
(syntax-case stx ()
|
||||
[(_ form ...)
|
||||
(do-define-package stx #'(define-package #f #:begin () form ...))]))
|
||||
|
||||
(define-for-syntax (do-open stx define-syntaxes-id)
|
||||
(syntax-case stx ()
|
||||
[(_ pack-id)
|
||||
(let ([id #'pack-id])
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error #f
|
||||
"expected an identifier for a package"
|
||||
stx
|
||||
id))
|
||||
(let ([v (syntax-local-value id (lambda () #f))])
|
||||
(unless (package? v)
|
||||
(raise-syntax-error #f
|
||||
"identifier is not bound to a package"
|
||||
stx
|
||||
id))
|
||||
(let ([introduce (syntax-local-make-delta-introducer
|
||||
(syntax-local-introduce id))])
|
||||
(with-syntax ([(intro ...)
|
||||
(map (lambda (i)
|
||||
(syntax-local-introduce
|
||||
(syntax-local-get-shadower
|
||||
(introduce i))))
|
||||
(map car ((package-exports v))))]
|
||||
[(defined ...)
|
||||
(map (lambda (v) (syntax-local-introduce (cdr v)))
|
||||
((package-exports v)))]
|
||||
[((a . b) ...) (map (lambda (p)
|
||||
(cons (syntax-local-introduce (car p))
|
||||
(syntax-local-introduce (cdr p))))
|
||||
((package-exports v)))]
|
||||
[(h ...) (map syntax-local-introduce ((package-hidden v)))])
|
||||
(syntax-property
|
||||
#`(#,define-syntaxes-id (intro ...)
|
||||
(let ([rev-map (lambda (x)
|
||||
(reverse-mapping
|
||||
'pack-id
|
||||
x
|
||||
(list (cons (quote-syntax a)
|
||||
(quote-syntax b))
|
||||
...)
|
||||
(list (quote-syntax h) ...)))])
|
||||
(values (make-rename-transformer #'defined rev-map)
|
||||
...)))
|
||||
'disappeared-use
|
||||
(syntax-local-introduce id))))))]))
|
||||
|
||||
(define-syntax (open-package stx)
|
||||
(do-open stx #'define-syntaxes))
|
||||
(define-syntax (open*-package stx)
|
||||
(do-open stx #'define*-syntaxes))
|
||||
|
||||
(define-for-syntax (package-exported-identifiers id)
|
||||
(let ([v (and (identifier? id)
|
||||
(syntax-local-value id (lambda () #f)))])
|
||||
(unless (package? v)
|
||||
(if (identifier? id)
|
||||
(raise-arguments-error 'package-exported-identifiers "identifier is not bound to a package"
|
||||
"identifier" id)
|
||||
(raise-argument-error 'package-exported-identifiers "identifier?" id)))
|
||||
(let ([introduce (syntax-local-make-delta-introducer
|
||||
(syntax-local-introduce id))])
|
||||
(map (lambda (i)
|
||||
(syntax-local-introduce
|
||||
(syntax-local-get-shadower
|
||||
(introduce (car i)))))
|
||||
((package-exports v))))))
|
||||
|
||||
(define-for-syntax (package-original-identifiers id)
|
||||
(let ([v (and (identifier? id)
|
||||
(syntax-local-value id (lambda () #f)))])
|
||||
(unless (package? v)
|
||||
(if (identifier? id)
|
||||
(raise-arguments-error 'package-original-identifiers "identifier is not bound to a package"
|
||||
"identifier" id)
|
||||
(raise-argument-error 'package-original-identifiers "identifier?" id)))
|
||||
(map cdr ((package-exports v)))))
|
||||
(require compatibility/package)
|
||||
(provide (all-from-out compatibility/package))
|
||||
|
|
|
|||
|
|
@ -25,4 +25,3 @@ called.
|
|||
@include-section["stx-expand.scrbl"]
|
||||
@include-section["include.scrbl"]
|
||||
@include-section["syntax-util.scrbl"]
|
||||
@include-section["defmacro.scrbl"]
|
||||
|
|
|
|||
|
|
@ -1,146 +1,10 @@
|
|||
#lang scribble/doc
|
||||
@(require "mz.rkt" (for-label racket/package))
|
||||
|
||||
@(define pack-eval (make-base-eval))
|
||||
@interaction-eval[#:eval pack-eval (require racket/package)]
|
||||
@(require "mz.rkt" (for-label racket/package compatibility/package))
|
||||
|
||||
@title[#:tag "package"]{Limiting Scope: @racket[define-package], @racket[open-package], ...}
|
||||
|
||||
@note-lib-only[racket/package]
|
||||
|
||||
@deftogether[(
|
||||
@defform[(define-package package-id exports form ...)]
|
||||
@defform/subs[(open-package package-id)
|
||||
([exports (id ...)
|
||||
(code:line #:only (id ...))
|
||||
#:all-defined
|
||||
(code:line #:all-defined-except (id ...))])]
|
||||
)]{
|
||||
@deprecated[@racketmodname[compatibility/package]]{}
|
||||
|
||||
@margin-note{The @racket[define-package] form is based on the @racketidfont{module}
|
||||
form of Chez Scheme @cite["Waddell99"].}
|
||||
|
||||
The @racket[define-package] form is similar to @racket[module], except
|
||||
that it can appear in any definition context. The @racket[form]s
|
||||
within a @racket[define-package] form can be definitions or
|
||||
expressions; definitions are not visible outside the
|
||||
@racket[define-package] form, but @racket[exports] determines a subset
|
||||
of the bindings that can be made visible outside the package using
|
||||
the definition form @racket[(open-package package-id)].
|
||||
|
||||
The @racket[(id ...)] and @racket[#:only (id ...)] @racket[exports]
|
||||
forms are equivalent: exactly the listed @racket[id]s are
|
||||
exported. The @racket[#:all-defined] form exports all definitions from
|
||||
the package body, and @racket[#:all-defined-except (id ...)] exports
|
||||
all definitions except the listed @racket[id]s.
|
||||
|
||||
All of the usual definition forms work within a
|
||||
@racket[define-package] body, and such definitions are visible to all
|
||||
expressions within the body (and, in particular, the definitions can
|
||||
refer to each other). However, @racket[define-package] handles
|
||||
@racket[define*], @racket[define*-syntax], @racket[define*-values],
|
||||
@racket[define*-syntaxes], and
|
||||
@racket[open*-package] specially: the bindings introduced by those
|
||||
forms within a @racket[define-package] body are visible only to
|
||||
@racket[form]s that appear later in the body, and they can shadow any
|
||||
binding from preceding @racket[form]s (even if the preceding binding
|
||||
did not use one of the special @racketidfont{*} definition forms). If
|
||||
an exported identifier is defined multiple times, the last definition
|
||||
is the exported one.
|
||||
|
||||
@examples[
|
||||
#:eval pack-eval
|
||||
(define-package presents (doll)
|
||||
(define doll "Molly Coddle")
|
||||
(define robot "Destructo"))
|
||||
doll
|
||||
robot
|
||||
(open-package presents)
|
||||
doll
|
||||
robot
|
||||
(define-package big-russian-doll (middle-russian-doll)
|
||||
(define-package middle-russian-doll (little-russian-doll)
|
||||
(define little-russian-doll "Anastasia")))
|
||||
(open-package big-russian-doll)
|
||||
(open-package middle-russian-doll)
|
||||
little-russian-doll
|
||||
]}
|
||||
|
||||
|
||||
@defform[(package-begin form ...)]{
|
||||
|
||||
Similar to @racket[define-package], but it only limits the visible of
|
||||
definitions without binding a package name. If the last @racket[form]
|
||||
is an expression, then the expression is in @tech{tail position} for
|
||||
the @racket[package-begin] form, so that its result is the
|
||||
@racket[package-begin] result.
|
||||
|
||||
A @racket[package-begin] form can be used as an expression, but if it
|
||||
is used in a context where definitions are allowed, then the
|
||||
definitions are essentially spliced into the enclosing context (though
|
||||
the defined bindings remain hidden outside the
|
||||
@racket[package-begin]).
|
||||
|
||||
@examples[
|
||||
#:eval pack-eval
|
||||
(package-begin
|
||||
(define secret "mimi")
|
||||
(list secret))
|
||||
secret
|
||||
]}
|
||||
|
||||
@deftogether[(
|
||||
@defidform[define*]
|
||||
@defidform[define*-values]
|
||||
@defidform[define*-syntax]
|
||||
@defidform[define*-syntaxes]
|
||||
@defidform[open*-package]
|
||||
)]{
|
||||
|
||||
Equivalent to @racket[define], @racket[define-values],
|
||||
@racket[define-syntax], @racket[define-syntaxes],
|
||||
and @racket[open-package], except within a
|
||||
@racket[define-package] or @racket[package-begin] form, where they
|
||||
create bindings that are visible only to later body forms.
|
||||
|
||||
@examples[
|
||||
#:eval pack-eval
|
||||
(define-package mail (cookies)
|
||||
(define* cookies (list 'sugar))
|
||||
(define* cookies (cons 'chocolate-chip cookies)))
|
||||
(open-package mail)
|
||||
cookies
|
||||
(define-syntax-rule (define-seven id) (define id 7))
|
||||
(define-syntax-rule (define*-seven id)
|
||||
(begin
|
||||
(define-package p (id) (define-seven id))
|
||||
(open*-package p)))
|
||||
(package-begin
|
||||
(define vii 8)
|
||||
(define*-seven vii)
|
||||
vii)]}
|
||||
|
||||
@deftogether[(
|
||||
@defproc[(package? [v any/c]) boolean?]
|
||||
@defproc[(package-exported-identifiers [id identifier?]) (listof identifier?)]
|
||||
@defproc[(package-original-identifiers [id identifier?]) (listof identifier?)]
|
||||
)]{
|
||||
|
||||
The @racket[package?], @racket[package-exported-identifiers], and
|
||||
@racket[package-original-identifiers] functions are exported
|
||||
@racket[for-syntax] by @racketmodname[racket/package].
|
||||
|
||||
The @racket[package?] predicate returns @racket[#t] if @racket[v] is a
|
||||
package value as obtained by @racket[syntax-local-value] on an
|
||||
identifier that is bound to a package.
|
||||
|
||||
Given such an identifier, the @racket[package-exported-identifiers]
|
||||
function returns a list of identifiers that correspond to the
|
||||
bindings that would be introduced by opening the package in the
|
||||
lexical context being expanded. The
|
||||
@racket[package-original-identifiers] function returns a parallel list
|
||||
of identifiers for existing bindings of package's exports.}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
||||
@close-eval[pack-eval]
|
||||
Re-exports @racketmodname[compatibility/package].
|
||||
|
|
|
|||
|
|
@ -177,12 +177,6 @@ The @racketmodname[racket] library combines
|
|||
#:url "http://srfi.schemers.org/srfi-42/"
|
||||
#:date "2003")
|
||||
|
||||
(bib-entry #:key "Waddell99"
|
||||
#:author "Oscar Waddell and R. Kent Dybvig"
|
||||
#:title "Extending the Scope of Syntactic Abstraction"
|
||||
#:location "Principles of Programming Languages"
|
||||
#:date "1999")
|
||||
|
||||
)
|
||||
|
||||
@;------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -157,7 +157,7 @@
|
|||
;;> with `defsubst' above).
|
||||
;;> * A `letmacro' form for local macros is provided.
|
||||
|
||||
(require (for-syntax (submod racket/defmacro dmhelp)))
|
||||
(require (for-syntax (submod compatibility/defmacro dmhelp)))
|
||||
(provide defmacro letmacro)
|
||||
(define-syntaxes (defmacro letmacro)
|
||||
(let ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user