From 4e48a33a49c090faccef0d4f0db9250788b2a71e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 25 Nov 2008 17:58:21 +0000 Subject: [PATCH] scheme/package (and more int-def repairs) svn: r12589 original commit: ed536c002e3ef5a7f908584f9d50421fcac827b4 --- collects/mzlib/unit.ss | 11 +-- collects/scheme/package.ss | 162 +++++++++++++++++++++++++++---------- 2 files changed, 120 insertions(+), 53 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 698092e..593155f 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -126,8 +126,7 @@ ((((int-sid . ext-sid) ...) . sbody) ...)) (map-sig (lambda (x) x) (make-syntax-introducer) - sig) - #;(add-context-to-sig sig)]) + sig)]) (list #'((ext-ivar ... ext-vid ... ... ext-sid ... ...) (values @@ -329,14 +328,6 @@ 'expression (list #'stop) def-ctx)))) - - (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))) (define-for-syntax (iota n) (let loop ((n n) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index 0aabb74..edb53be 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -4,13 +4,17 @@ syntax/boundmap syntax/define)) -(provide define* +(provide define-package + package-begin + + open-package + open*-package + + define* define*-values define*-syntax define*-syntaxes - define-package - open-package - open*-package) + define*-struct) (define-for-syntax (do-define-* stx define-values-id) (syntax-case stx () @@ -50,13 +54,15 @@ "misuse of a package name" stx))) - (define (reverse-mapping id exports hidden) + (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: + (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 @@ -65,19 +71,20 @@ hidden) id))) -(define-syntax (define-package stx) - (syntax-case stx () - [(_ pack-id exports form ...) +(define-for-syntax (do-define-package stx exp-stx) + (syntax-case exp-stx () + [(_ pack-id mode exports form ...) (let ([id #'pack-id] - [exports #'exports]) - (unless (identifier? id) - (raise-syntax-error #f - "expected an identifier" - stx - 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 - [(eq? (syntax-e exports) 'all-defined) #f] [(syntax->list exports) => (lambda (l) (for-each (lambda (i) @@ -96,7 +103,11 @@ dup-id))) l)] [else (raise-syntax-error #f - "expected a parenthesized sequence of identifiers to export" + (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)] @@ -154,7 +165,18 @@ (quote-syntax renamed)) ...)) hidden))))] - [_ stx])))]) + [_ 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) @@ -186,7 +208,7 @@ (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))] + (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) @@ -194,33 +216,55 @@ renamed (lambda () #f)) (raise-syntax-error #f - "no definition for exported identifier" + (format "no definition for ~a identifier" + (case mode + [(#:only) "exported"] + [(#:all-defined-except) "excluded"])) stx ex))) - (or exports null) + exports 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) ...)))))))] + (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)))))]) + (with-syntax ([(export ...) exports] + [(renamed ...) exports-renamed] + [(hidden ...) (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 ((add-package-context (cdr def-ctxes)) (local-expand ((add-package-context (cdr def-ctxes)) (car exprs)) @@ -276,11 +320,30 @@ (if star? (cons def-ctx def-ctxes) def-ctxes))))] [else (loop (cdr exprs) - (cons #`(define-values () (begin #,expr (values))) + (cons (if (and (eq? mode '#:begin) + (null? (cdr exprs))) + expr + #`(define-values () (begin #,expr (values)))) rev-forms) defined 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) @@ -316,6 +379,7 @@ (#,define-syntaxes-id (intro ...) (let ([rev-map (lambda (x) (reverse-mapping + 'pack-id x (list (cons (quote-syntax a) (quote-syntax b)) @@ -328,3 +392,15 @@ (do-open stx #'define-syntaxes)) (define-syntax (open*-package stx) (do-open stx #'define*-syntaxes)) + +(define-syntax (define*-struct stx) + (syntax-case stx () + [(_ . rest) + (let ([ds (quasisyntax/loc stx + (define-struct/derived #,stx . rest))]) + (quasisyntax/loc stx + (begin + (define-package p #:all-defined + #,ds) + (open*-package p))))])) +