re-implement racket/package for the new macro system
The new implementation is considerably simpler than the old implementation, and it avoids `syntax-local-make-definition-context`, `syntax-local-get-shadower`, and `syntax-local-make-delta-introducer`.
This commit is contained in:
Matthew Flatt
parent
f540a6c108
commit
35af3d14d0
|
|
@ -1,11 +1,8 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
racket/list
|
||||
syntax/kerncase
|
||||
syntax/boundmap
|
||||
syntax/define
|
||||
syntax/flatten-begin
|
||||
syntax/context))
|
||||
syntax/boundmap
|
||||
racket/pretty))
|
||||
|
||||
(provide define-package
|
||||
package-begin
|
||||
|
|
@ -22,6 +19,279 @@
|
|||
package-exported-identifiers
|
||||
package-original-identifiers))
|
||||
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(begin-for-syntax
|
||||
(struct package (root-id sig-ids impl-ids))
|
||||
|
||||
(define (get-package who id)
|
||||
(let ([p (syntax-local-value id (lambda () #f))])
|
||||
(unless (package? p)
|
||||
(error who
|
||||
"not defined as a package\n identifier: ~a"
|
||||
id))))
|
||||
|
||||
(define (package-exported-identifiers id)
|
||||
(define p (get-package 'package-exported-identifiers id))
|
||||
(map
|
||||
(lambda (sig-id)
|
||||
(make-syntax-delta-introducer sig-id (package-root-id p))
|
||||
(datum->syntax id (syntax-e sig-id) sig-id sig-id))
|
||||
(syntax->list (package-sig-ids p))))
|
||||
|
||||
(define (package-original-identifiers id)
|
||||
(define p (get-package 'package-original-identifiers id))
|
||||
(syntax->list (package-impl-ids p))))
|
||||
|
||||
(define-syntax (define-package stx)
|
||||
(check-definition-context stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id . _)
|
||||
(let ([id #'id])
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error #f
|
||||
"expected an identifier for the package name"
|
||||
stx
|
||||
id))
|
||||
(define (accumulate exports forms)
|
||||
(define intro (make-syntax-introducer))
|
||||
#`(drive-top-level
|
||||
(accumulate-package #,id #,(intro id) #,(intro id) #f #,stx
|
||||
#,exports
|
||||
()
|
||||
#,(intro forms))))
|
||||
(syntax-case stx ()
|
||||
[(_ _ #:only (export-id ...) form ...)
|
||||
(accumulate #'(#:only (export-id ...)) #'(form ...))]
|
||||
[(_ _ #:all-defined-except (export-id ...) form ...)
|
||||
(accumulate #'(#:all-defined-except (export-id ...)) #'(form ...))]
|
||||
[(_ _ #:all-defined form ...)
|
||||
(accumulate #'(#:all-defined-except ()) #'(form ...))]
|
||||
[(_ _ (export-id ...) form ...)
|
||||
(accumulate #'(#:only (export-id ...)) #'(form ...))]))]))
|
||||
|
||||
(define-syntax (accumulate-package stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id intro-id star-id any-stars? orig-form exports defined-ids (form . forms))
|
||||
(let ([exp-form (local-expand #'form
|
||||
(list (gensym))
|
||||
(list #'define-values
|
||||
#'-define*-values
|
||||
#'define-syntaxes
|
||||
#'-define*-syntaxes
|
||||
#'begin)
|
||||
#f)])
|
||||
(syntax-case exp-form (begin)
|
||||
[(begin seq-form ...)
|
||||
#`(accumulate-package id intro-id star-id any-stars? orig-form
|
||||
exports
|
||||
defined-ids
|
||||
(seq-form ... . forms))]
|
||||
[(def (new-def-id ...) rhs)
|
||||
(or (free-identifier=? #'def #'define-values)
|
||||
(free-identifier=? #'def #'define-syntaxes)
|
||||
(free-identifier=? #'def #'-define*-values)
|
||||
(free-identifier=? #'def #'-define*-syntaxes))
|
||||
(let* ([star? (or (free-identifier=? #'def #'-define*-values)
|
||||
(free-identifier=? #'def #'-define*-syntaxes))]
|
||||
[next-intro (if star?
|
||||
(make-syntax-introducer)
|
||||
(lambda (s) s))]
|
||||
[exp-form
|
||||
(with-syntax ([(new-def-id ...) (if star?
|
||||
;; Add another scope layer:
|
||||
(next-intro #'(new-def-id ...))
|
||||
;; Remove star layers:
|
||||
((make-syntax-delta-introducer #'star-id #'intro-id)
|
||||
#'(new-def-id ...)
|
||||
'remove))])
|
||||
(syntax/loc exp-form
|
||||
(def (new-def-id ...) rhs)))])
|
||||
(with-syntax ([(_ (new-def-id ...) _) exp-form]) ; sync with above adjustments to `new-def-id`
|
||||
(when (and (not star?)
|
||||
(syntax-e #'any-stars?))
|
||||
;; Make sure that a name is not defined with `define` if
|
||||
;; there's a preceeding `define*`
|
||||
(let ([intro (make-syntax-delta-introducer #'star-id #'intro-id)])
|
||||
(for ([id (in-list (syntax->list #'(new-def-id ...)))])
|
||||
(unless (free-identifier=? id (intro id))
|
||||
(raise-syntax-error #f
|
||||
"duplicate definition for identifier"
|
||||
#'orig-form
|
||||
id)))))
|
||||
;; Let definition out of `accumulate-package` form, accumulate new
|
||||
;; defintions, and continue with the rest of the package body:
|
||||
(with-syntax ([forms (next-intro #'forms)]
|
||||
[star-id (next-intro #'star-id)]
|
||||
[any-stars? (or star? (syntax-e #'any-stars?))])
|
||||
#`(begin
|
||||
#,exp-form
|
||||
(accumulate-package id intro-id star-id any-stars? orig-form
|
||||
exports
|
||||
(new-def-id ... . defined-ids)
|
||||
forms)))))]
|
||||
[_
|
||||
(and (not (syntax-e #'id))
|
||||
(null? (syntax-e #'forms)))
|
||||
;; Allow last expression to produce a result for `package-begin`
|
||||
exp-form]
|
||||
[_
|
||||
#`(begin
|
||||
(begin0 (void) #,exp-form)
|
||||
(accumulate-package id intro-id star-id any-stars? orig-form
|
||||
exports
|
||||
defined-ids
|
||||
forms))]))]
|
||||
[(_ #f #f #f _ orig-form exports defined-ids ())
|
||||
;; Last thing in `begin-package` was a definition; add a `(void)`
|
||||
#'(void)]
|
||||
[(_ id intro-id star-id any-stars? orig-form exports defined-ids ())
|
||||
(let ()
|
||||
(define (find-ids ids keep?)
|
||||
(define intro (make-syntax-delta-introducer #'star-id #'id))
|
||||
(let ([ids (syntax->list ids)]
|
||||
[defined-ids (syntax->list #'defined-ids)])
|
||||
(define defined-bindings (make-bound-identifier-mapping))
|
||||
;; `defined-ids` were accumulated in reverse order; add them
|
||||
;; in the original order, so that we end up with the last
|
||||
;; definition of each equilavent id (in the case of `define*`s
|
||||
(for-each
|
||||
(lambda (defined-id)
|
||||
(bound-identifier-mapping-put! defined-bindings
|
||||
(syntax-local-identifier-as-binding
|
||||
(intro defined-id 'remove))
|
||||
defined-id))
|
||||
(reverse defined-ids))
|
||||
;; Check that each explicitly named `id` is defined:
|
||||
(define mentioned-ids (make-bound-identifier-mapping))
|
||||
(for-each (lambda (id)
|
||||
(define bind-id (syntax-local-identifier-as-binding
|
||||
id))
|
||||
(unless (bound-identifier-mapping-get defined-bindings
|
||||
bind-id
|
||||
(lambda () #f))
|
||||
(raise-syntax-error #f
|
||||
"identifier not defined within the package"
|
||||
#'orig-form
|
||||
id))
|
||||
(bound-identifier-mapping-put! mentioned-ids
|
||||
bind-id
|
||||
#t))
|
||||
ids)
|
||||
;; Get identifiers that should be exported:
|
||||
(filter
|
||||
values
|
||||
(bound-identifier-mapping-map
|
||||
defined-bindings
|
||||
(lambda (bind-id defined-id)
|
||||
(and (keep? (bound-identifier-mapping-get mentioned-ids bind-id
|
||||
(lambda () #f)))
|
||||
(cons bind-id
|
||||
defined-id)))))))
|
||||
(define mapping
|
||||
(syntax-case #'exports ()
|
||||
[(#:only (id ...))
|
||||
(find-ids #'(id ...) values)]
|
||||
[(#:all-defined-except (id ...))
|
||||
(find-ids #'(id ...) not)]))
|
||||
#`(define-syntax id (package (quote-syntax star-id)
|
||||
(quote-syntax #,(map car mapping))
|
||||
(quote-syntax #,(map cdr mapping)))))]))
|
||||
|
||||
(define-for-syntax (do-open-package stx def-stxes)
|
||||
(check-definition-context stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
(let ([id #'id])
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error #f
|
||||
"not an identifier for a package to open"
|
||||
stx
|
||||
id))
|
||||
(let ([p (syntax-local-value id (lambda () #f))])
|
||||
(unless (package? p)
|
||||
(raise-syntax-error #f
|
||||
"not defined as a package"
|
||||
stx
|
||||
id))
|
||||
(define (locally sig-id)
|
||||
((make-syntax-delta-introducer sig-id (package-root-id p))
|
||||
(datum->syntax id (syntax-e sig-id) sig-id sig-id)))
|
||||
#`(begin
|
||||
#,@(map (lambda (sig-id impl-id)
|
||||
#`(#,def-stxes (#,(locally sig-id))
|
||||
(make-rename-transformer (quote-syntax #,impl-id))))
|
||||
(syntax->list (package-sig-ids p))
|
||||
(syntax->list (syntax-local-introduce (package-impl-ids p)))))))]))
|
||||
|
||||
(define-syntax (open-package stx)
|
||||
(do-open-package stx #'define-syntaxes))
|
||||
(define-syntax (open*-package stx)
|
||||
(do-open-package stx #'define*-syntaxes))
|
||||
|
||||
(define-syntax (package-begin stx)
|
||||
(if (eq? 'expression (syntax-local-context))
|
||||
#`(let () #,stx)
|
||||
(syntax-case stx ()
|
||||
[(_ form ...)
|
||||
#`(drive-top-level
|
||||
(accumulate-package #f #f #f #,stx
|
||||
#f
|
||||
()
|
||||
#,((make-syntax-introducer)
|
||||
#'(form ...))))])))
|
||||
|
||||
(define-for-syntax (check-definition-context stx)
|
||||
(when (eq? 'expression (syntax-local-context))
|
||||
(raise-syntax-error #f
|
||||
"not in a definition context"
|
||||
stx)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-syntax (drive-top-level stx)
|
||||
(syntax-case stx ()
|
||||
[(_ form)
|
||||
(cond
|
||||
[(eq? 'top-level (syntax-local-context))
|
||||
;; In a opt-level context, we need to use the `(define-syntaxes
|
||||
;; (...) (values))` trick to introduce all defined names before
|
||||
;; expanding expressions.
|
||||
#'(accumulate-top-level () (form))]
|
||||
[else
|
||||
;; No special treatment needed:
|
||||
#'form])]))
|
||||
|
||||
(define-syntax (accumulate-top-level stx)
|
||||
(syntax-case stx ()
|
||||
[(_ exp-forms ())
|
||||
#`(begin
|
||||
#,@(reverse (syntax->list #'exp-forms)))]
|
||||
[(_ exp-forms (form . forms))
|
||||
(let ([exp-form (local-expand #'form
|
||||
(list (gensym))
|
||||
(list #'define-values
|
||||
#'define-syntaxes
|
||||
#'begin)
|
||||
#f)])
|
||||
(syntax-case exp-form (begin define-values define-syntaxes)
|
||||
[(begin form ...)
|
||||
#'(accumulate-top-level exp-forms (form ... . forms))]
|
||||
[(define-values (new-def-id ...) rhs)
|
||||
#`(begin
|
||||
(define-syntaxes (new-def-id ...) (values))
|
||||
(accumulate-top-level (#,exp-form . exp-forms)
|
||||
forms))]
|
||||
[(define-syntaxes . _)
|
||||
#`(begin
|
||||
#,exp-form
|
||||
(accumulate-top-level exp-forms forms))]
|
||||
[_
|
||||
#`(accumulate-top-level (#,exp-form . exp-forms) forms)]))]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-for-syntax (do-define-* stx define-values-id)
|
||||
(syntax-case stx ()
|
||||
[(_ (id ...) rhs)
|
||||
|
|
@ -64,395 +334,3 @@
|
|||
(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)))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user