From bfb0bc4ffd03b723c4beedc7029fa079be654975 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 24 Nov 2008 19:52:41 +0000 Subject: [PATCH] revised internal-definitions context and a basic 'define-package' form svn: r12579 original commit: a0f91d905e78288ac9ee252f24e8157f5cbea3f9 --- collects/mzlib/etc.ss | 1 + collects/mzlib/private/sigutil.ss | 1 + collects/mzlib/unit.ss | 2 + collects/mzlib/unit200.ss | 3 + collects/scheme/package.ss | 252 ++++++++++++++++++++++++++++++ 5 files changed, 259 insertions(+) create mode 100644 collects/scheme/package.ss diff --git a/collects/mzlib/etc.ss b/collects/mzlib/etc.ss index 1e72899..c9b28bb 100644 --- a/collects/mzlib/etc.ss +++ b/collects/mzlib/etc.ss @@ -386,6 +386,7 @@ [else (list expr)]))) exprs)))]) + (internal-definition-context-seal def-ctx) (let loop ([exprs exprs] [prev-stx-defns null] [prev-defns null] diff --git a/collects/mzlib/private/sigutil.ss b/collects/mzlib/private/sigutil.ss index a99eedf..cf507a4 100644 --- a/collects/mzlib/private/sigutil.ss +++ b/collects/mzlib/private/sigutil.ss @@ -667,6 +667,7 @@ (let loop ([pre-lines null][lines (append import-stxes body)][port #f][port-name #f][body null][vars null]) (cond [(and (null? pre-lines) (not port) (null? lines)) + (internal-definition-context-seal def-ctx) (make-parsed-unit imports renames vars diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 60072b6..698092e 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -333,6 +333,7 @@ (define-for-syntax (add-context-to-sig sig) (let ((def-ctx (syntax-local-make-definition-context))) (syntax-local-bind-syntaxes (sig-ext-names sig) #f def-ctx) + (internal-definition-context-seal def-ctx) (map-sig (lambda (x) x) (lambda (x) (localify x def-ctx)) sig))) @@ -619,6 +620,7 @@ [_ (void)])) expanded-body) table)]) + (internal-definition-context-seal def-ctx) ;; Mark exported names and ;; check that all exported names are defined (as var): diff --git a/collects/mzlib/unit200.ss b/collects/mzlib/unit200.ss index 9952ceb..c3cdbb6 100644 --- a/collects/mzlib/unit200.ss +++ b/collects/mzlib/unit200.ss @@ -158,7 +158,10 @@ [else (list defn-or-expr)]))) defns&exprs))) values)]) + (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 ;; from syntax definitions. (let* ([definition? diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss new file mode 100644 index 0000000..41827b9 --- /dev/null +++ b/collects/scheme/package.ss @@ -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) + ...))))))))]))