revised internal-definitions context and a basic 'define-package' form
svn: r12579 original commit: a0f91d905e78288ac9ee252f24e8157f5cbea3f9
This commit is contained in:
Matthew Flatt
parent
fe2ab39bbd
commit
bfb0bc4ffd
|
|
@ -386,6 +386,7 @@
|
||||||
[else
|
[else
|
||||||
(list expr)])))
|
(list expr)])))
|
||||||
exprs)))])
|
exprs)))])
|
||||||
|
(internal-definition-context-seal def-ctx)
|
||||||
(let loop ([exprs exprs]
|
(let loop ([exprs exprs]
|
||||||
[prev-stx-defns null]
|
[prev-stx-defns null]
|
||||||
[prev-defns null]
|
[prev-defns null]
|
||||||
|
|
|
||||||
|
|
@ -667,6 +667,7 @@
|
||||||
(let loop ([pre-lines null][lines (append import-stxes body)][port #f][port-name #f][body null][vars null])
|
(let loop ([pre-lines null][lines (append import-stxes body)][port #f][port-name #f][body null][vars null])
|
||||||
(cond
|
(cond
|
||||||
[(and (null? pre-lines) (not port) (null? lines))
|
[(and (null? pre-lines) (not port) (null? lines))
|
||||||
|
(internal-definition-context-seal def-ctx)
|
||||||
(make-parsed-unit imports
|
(make-parsed-unit imports
|
||||||
renames
|
renames
|
||||||
vars
|
vars
|
||||||
|
|
|
||||||
|
|
@ -333,6 +333,7 @@
|
||||||
(define-for-syntax (add-context-to-sig sig)
|
(define-for-syntax (add-context-to-sig sig)
|
||||||
(let ((def-ctx (syntax-local-make-definition-context)))
|
(let ((def-ctx (syntax-local-make-definition-context)))
|
||||||
(syntax-local-bind-syntaxes (sig-ext-names sig) #f def-ctx)
|
(syntax-local-bind-syntaxes (sig-ext-names sig) #f def-ctx)
|
||||||
|
(internal-definition-context-seal def-ctx)
|
||||||
(map-sig (lambda (x) x)
|
(map-sig (lambda (x) x)
|
||||||
(lambda (x) (localify x def-ctx))
|
(lambda (x) (localify x def-ctx))
|
||||||
sig)))
|
sig)))
|
||||||
|
|
@ -619,6 +620,7 @@
|
||||||
[_ (void)]))
|
[_ (void)]))
|
||||||
expanded-body)
|
expanded-body)
|
||||||
table)])
|
table)])
|
||||||
|
(internal-definition-context-seal def-ctx)
|
||||||
|
|
||||||
;; Mark exported names and
|
;; Mark exported names and
|
||||||
;; check that all exported names are defined (as var):
|
;; check that all exported names are defined (as var):
|
||||||
|
|
|
||||||
|
|
@ -158,7 +158,10 @@
|
||||||
[else (list defn-or-expr)])))
|
[else (list defn-or-expr)])))
|
||||||
defns&exprs)))
|
defns&exprs)))
|
||||||
values)])
|
values)])
|
||||||
|
|
||||||
(let ([all-expanded (expand-all (syntax->list (syntax (defn&expr ...))))])
|
(let ([all-expanded (expand-all (syntax->list (syntax (defn&expr ...))))])
|
||||||
|
(when def-ctx
|
||||||
|
(internal-definition-context-seal def-ctx))
|
||||||
;; Get all the defined names, sorting out variable definitions
|
;; Get all the defined names, sorting out variable definitions
|
||||||
;; from syntax definitions.
|
;; from syntax definitions.
|
||||||
(let* ([definition?
|
(let* ([definition?
|
||||||
|
|
|
||||||
252
collects/scheme/package.ss
Normal file
252
collects/scheme/package.ss
Normal file
|
|
@ -0,0 +1,252 @@
|
||||||
|
#lang scheme/base
|
||||||
|
(require (for-syntax scheme/base
|
||||||
|
syntax/kerncase
|
||||||
|
syntax/boundmap))
|
||||||
|
|
||||||
|
(provide define-package
|
||||||
|
open-package)
|
||||||
|
|
||||||
|
(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 (reverse-mapping id exports hidden)
|
||||||
|
(or (ormap (lambda (m)
|
||||||
|
(and (free-identifier=? id (cdr m))
|
||||||
|
(car m)))
|
||||||
|
exports)
|
||||||
|
(ormap (lambda (h)
|
||||||
|
(and (free-identifier=? id h)
|
||||||
|
;; Name is inaccessible. Generate a temporary to
|
||||||
|
;; avoid potential duplicate-definition errors
|
||||||
|
;; when the name is bound in the same context as
|
||||||
|
;; the package.
|
||||||
|
(car (generate-temporaries (list id)))))
|
||||||
|
hidden)
|
||||||
|
id)))
|
||||||
|
|
||||||
|
(define-syntax (define-package stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ pack-id exports form ...)
|
||||||
|
(let ([id #'pack-id]
|
||||||
|
[exports #'exports])
|
||||||
|
(unless (identifier? id)
|
||||||
|
(raise-syntax-error #f
|
||||||
|
"expected an identifier"
|
||||||
|
stx
|
||||||
|
id))
|
||||||
|
(let ([exports
|
||||||
|
(cond
|
||||||
|
[(eq? (syntax-e exports) 'all-defined) #f]
|
||||||
|
[(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
|
||||||
|
"expected a parenthesized sequence of identifiers to export"
|
||||||
|
stx
|
||||||
|
exports)])])
|
||||||
|
(let* ([def-ctx (syntax-local-make-definition-context)]
|
||||||
|
[ctx (cons (gensym 'intdef)
|
||||||
|
(let ([orig-ctx (syntax-local-context)])
|
||||||
|
(if (pair? orig-ctx)
|
||||||
|
orig-ctx
|
||||||
|
null)))]
|
||||||
|
[pre-package-id (lambda (id)
|
||||||
|
(identifier-remove-from-definition-context
|
||||||
|
id
|
||||||
|
def-ctx))]
|
||||||
|
[kernel-forms (kernel-form-identifier-list)]
|
||||||
|
[init-exprs (syntax->list #'(form ...))]
|
||||||
|
[new-bindings (make-bound-identifier-mapping)]
|
||||||
|
[fixup-sub-package (lambda (renamed-exports renamed-defines)
|
||||||
|
(lambda (stx)
|
||||||
|
(syntax-case* 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)
|
||||||
|
;; It's not accessible, so just hide the name
|
||||||
|
;; to avoid re-binding errors.
|
||||||
|
(car (generate-temporaries (list id)))))
|
||||||
|
(syntax->list #'(export ...)))])
|
||||||
|
(syntax/loc stx
|
||||||
|
(define-syntaxes (pack-id)
|
||||||
|
(make-package
|
||||||
|
(lambda ()
|
||||||
|
(list (cons (quote-syntax export)
|
||||||
|
(quote-syntax renamed))
|
||||||
|
...))
|
||||||
|
hidden))))]
|
||||||
|
[_ stx])))])
|
||||||
|
(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 (stx)
|
||||||
|
(let ([q (local-expand #`(quote #,stx)
|
||||||
|
ctx
|
||||||
|
(list #'quote)
|
||||||
|
def-ctx)])
|
||||||
|
(syntax-case q ()
|
||||||
|
[(_ stx) #'stx])))])
|
||||||
|
(let loop ([exprs init-exprs]
|
||||||
|
[rev-forms null]
|
||||||
|
[defined null])
|
||||||
|
(cond
|
||||||
|
[(null? exprs)
|
||||||
|
(internal-definition-context-seal def-ctx)
|
||||||
|
(let ([exports-renamed (map add-package-context (or exports null))]
|
||||||
|
[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
|
||||||
|
"no definition for exported identifier"
|
||||||
|
stx
|
||||||
|
ex)))
|
||||||
|
(or exports null)
|
||||||
|
exports-renamed)
|
||||||
|
(with-syntax ([(export ...) exports]
|
||||||
|
[(renamed ...) exports-renamed]
|
||||||
|
[(hidden ...)
|
||||||
|
(begin
|
||||||
|
(for-each (lambda (ex)
|
||||||
|
(bound-identifier-mapping-put! new-bindings ex #f))
|
||||||
|
exports-renamed)
|
||||||
|
(filter
|
||||||
|
values
|
||||||
|
(bound-identifier-mapping-map new-bindings
|
||||||
|
(lambda (k v) (and v k)))))])
|
||||||
|
#`(begin
|
||||||
|
#,@(map (fixup-sub-package exports-renamed defined-renamed) (reverse rev-forms))
|
||||||
|
(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-ctx)])
|
||||||
|
(syntax-case expr (begin define-syntaxes define-values)
|
||||||
|
[(begin . rest)
|
||||||
|
(loop (append (syntax->list #'rest) (cdr exprs))
|
||||||
|
rev-forms
|
||||||
|
defined)]
|
||||||
|
[(define-syntaxes (id ...) rhs)
|
||||||
|
(andmap identifier? (syntax->list #'(id ...)))
|
||||||
|
(with-syntax ([rhs (local-transformer-expand
|
||||||
|
#'rhs
|
||||||
|
'expression
|
||||||
|
null)])
|
||||||
|
(let ([ids (syntax->list #'(id ...))])
|
||||||
|
(syntax-local-bind-syntaxes ids #'rhs def-ctx)
|
||||||
|
(register-bindings! ids)
|
||||||
|
(loop (cdr exprs)
|
||||||
|
(cons #'(define-syntaxes (id ...) rhs)
|
||||||
|
rev-forms)
|
||||||
|
(cons ids defined))))]
|
||||||
|
[(define-values (id ...) rhs)
|
||||||
|
(andmap identifier? (syntax->list #'(id ...)))
|
||||||
|
(let ([ids (syntax->list #'(id ...))])
|
||||||
|
(syntax-local-bind-syntaxes ids #f def-ctx)
|
||||||
|
(register-bindings! ids)
|
||||||
|
(loop (cdr exprs)
|
||||||
|
(cons expr rev-forms)
|
||||||
|
(cons ids defined)))]
|
||||||
|
[else
|
||||||
|
(loop (cdr exprs)
|
||||||
|
(cons #`(define-values () (begin #,expr (values)))
|
||||||
|
rev-forms)
|
||||||
|
defined)]))]))))))]))
|
||||||
|
|
||||||
|
(define-syntax (open-package stx)
|
||||||
|
(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)))])
|
||||||
|
#'(begin
|
||||||
|
(define-syntaxes (intro ...)
|
||||||
|
(let ([rev-map (lambda (x)
|
||||||
|
(reverse-mapping
|
||||||
|
x
|
||||||
|
(list (cons (quote-syntax a)
|
||||||
|
(quote-syntax b))
|
||||||
|
...)
|
||||||
|
(list (quote-syntax h) ...)))])
|
||||||
|
(values (make-rename-transformer #'defined rev-map)
|
||||||
|
...))))))))]))
|
||||||
Loading…
Reference in New Issue
Block a user