329 lines
17 KiB
Scheme
329 lines
17 KiB
Scheme
#lang scheme/base
|
|
(require (for-syntax scheme/base
|
|
syntax/kerncase
|
|
syntax/boundmap
|
|
syntax/define))
|
|
|
|
(provide define*
|
|
define*-values
|
|
define*-syntax
|
|
define*-syntaxes
|
|
define-package
|
|
open-package)
|
|
|
|
(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* 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 (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 def-ctxes)
|
|
(for/fold ([id id])
|
|
([def-ctx (in-list def-ctxes)])
|
|
(identifier-remove-from-definition-context
|
|
id
|
|
def-ctx)))]
|
|
[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* 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.
|
|
(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 (def-ctxes)
|
|
(lambda (stx)
|
|
(for/fold ([stx stx])
|
|
([def-ctx (in-list (reverse def-ctxes))])
|
|
(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]
|
|
[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) (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 def-ctxes)
|
|
(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 ((add-package-context (cdr def-ctxes))
|
|
(local-expand ((add-package-context (cdr def-ctxes)) (car exprs))
|
|
ctx
|
|
kernel-forms
|
|
(car def-ctxes)))])
|
|
(syntax-case expr (begin)
|
|
[(begin . rest)
|
|
(loop (append (syntax->list #'rest) (cdr exprs))
|
|
rev-forms
|
|
defined)]
|
|
[(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))]
|
|
[ids (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 #`(define-syntaxes #,ids rhs)
|
|
rev-forms)
|
|
(cons ids defined)
|
|
(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))]
|
|
[ids (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 #`(define-values #,ids rhs) rev-forms)
|
|
(cons ids defined)
|
|
(if star? (cons def-ctx def-ctxes) def-ctxes))))]
|
|
[else
|
|
(loop (cdr exprs)
|
|
(cons #`(define-values () (begin #,expr (values)))
|
|
rev-forms)
|
|
defined
|
|
def-ctxes)]))]))))))]))
|
|
|
|
(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)))])
|
|
#`(begin
|
|
(#,define-syntaxes-id (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)
|
|
...))))))))]))
|
|
|
|
(define-syntax (open-package stx)
|
|
(do-open stx #'define-syntaxes))
|
|
(define-syntax (open*-package stx)
|
|
(do-open stx #'define*-syntaxes))
|