From db12513b65e79d2fe9e3c824e4232b1c981082d0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 21 Jan 2009 20:00:55 +0000 Subject: [PATCH] fix #:all-defined for 'define-package' by adjusting 'identifier-remove-from-definition-context'; add for-syntax 'package?' and 'package-export-identifiers'; adjust Scribble to find definitions of phase-1 exports svn: r13253 --- collects/scheme/package.ss | 30 ++++++++++---- collects/scribble/search.ss | 9 ++-- collects/scribblings/reference/package.scrbl | 18 ++++++++ .../scribblings/reference/stx-trans.scrbl | 26 ++++++++---- collects/tests/mzscheme/package.ss | 12 ++++++ src/mzscheme/src/env.c | 41 ++++++++++++++++--- src/mzscheme/src/schpriv.h | 2 + src/mzscheme/src/stxobj.c | 16 ++++++++ 8 files changed, 128 insertions(+), 26 deletions(-) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index 9667509e30..569f493c00 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -13,7 +13,10 @@ define* define*-values define*-syntax - define*-syntaxes) + define*-syntaxes + + (for-syntax package? + package-exported-identifiers)) (define-for-syntax (do-define-* stx define-values-id) (syntax-case stx () @@ -117,11 +120,9 @@ 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)))] + (identifier-remove-from-definition-context + id + def-ctxes))] [kernel-forms (list* #'define*-values #'define*-syntaxes @@ -154,7 +155,8 @@ ;; 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. + ;; to avoid re-binding errors. (Is this necessary, + ;; or would `pre-package-id' take care of it?) (car (generate-temporaries (list id))))) (syntax->list #'(export ...)))]) (syntax/loc stx @@ -391,4 +393,16 @@ (define-syntax (open-package stx) (do-open stx #'define-syntaxes)) (define-syntax (open*-package stx) - (do-open stx #'define*-syntaxes)) + (syntax-property (do-open stx #'define*-syntaxes) + 'certify-mode + 'transparent-binding)) + +(define-for-syntax (package-exported-identifiers id) + (let ([v (and (identifier? id) + (syntax-local-value id (lambda () #f)))]) + (unless (package? v) + (raise-type-error 'package-exported-identifiers "identifier bound to a package" id)) + (let ([introduce (syntax-local-make-delta-introducer + (syntax-local-introduce id))]) + (map (lambda (v) (syntax-local-introduce (cdr v))) + ((package-exports v)))))) diff --git a/collects/scribble/search.ss b/collects/scribble/search.ss index 034b72558f..1186ed6305 100644 --- a/collects/scribble/search.ss +++ b/collects/scribble/search.ss @@ -28,10 +28,11 @@ ;; because no one uses the same name for different-phase exported ;; bindings. ;; - ;; However, we assume that bidings are defined as originating from some - ;; module at phase 0. Maybe it's defined at phase 1 and re-exported + ;; Formerly, we assumed that bidings are defined as originating from some + ;; module at phase 0. [Maybe it's defined at phase 1 and re-exported ;; later for phase 0 (after a require-for-template), in which case the - ;; re-exporting module is the one we find. + ;; re-exporting module is the one we find.] That assumption has been + ;; lifted, however; search for "GONE" below. (let ([b (cond [(identifier? stx/binding) (identifier-binding stx/binding phase-level)] @@ -74,7 +75,7 @@ [export-phase (list-ref (car queue) 4)] [queue (cdr queue)]) (let* ([rmp (module-path-index-resolve mod)] - [eb (and (equal? 0 export-phase) ;; look for the phase-0 export; good idea? + [eb (and ;; GONE: (equal? 0 export-phase) ;; look for the phase-0 export; good idea? (list (module-path-index->taglet mod) id))]) (when (and eb diff --git a/collects/scribblings/reference/package.scrbl b/collects/scribblings/reference/package.scrbl index 817da947d2..a79f078399 100644 --- a/collects/scribblings/reference/package.scrbl +++ b/collects/scribblings/reference/package.scrbl @@ -121,6 +121,24 @@ cookies (define*-seven vii) vii)]} +@deftogether[( +@defproc[(package? [v any/c]) boolean?] +@defproc[(package-exported-identifiers [id identifier?]) (listof identifier?)] +)]{ + +The @scheme[package?] and @scheme[package-exported-identifiers] +functions are exported @scheme[for-syntax] by +@schememodname[scheme/package]. + +The @scheme[package?] predicate returns @scheme[#t] if @scheme[v] is a +package value as obtained by @scheme[syntax-local-value] on an +identifier that is bound to a package. + +Given such an identifier, the @scheme[package-exported-identifiers] +function returns a list of identifiers that corresponding to the +bindings that would be introduced by opening the package in the the +lexical context being expanded.} + @; ---------------------------------------------------------------------- @close-eval[pack-eval] diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index 9ca81d5210..62e0fbd9fc 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -238,14 +238,24 @@ Indicates that no further bindings will be added to @scheme[syntax-local-make-definition-context].} -@defproc[(identifier-remove-from-defininition-context [id-stx identifier?] - [intdef-ctx internal-definition-context?]) +@defproc[(identifier-remove-from-definition-context [id-stx identifier?] + [intdef-ctx (or/c internal-definition-context? + (listof internal-definition-context?))]) identifier?]{ -Removes @scheme[intdef-ctx] from the @tech{lexical information} of -@scheme[id-stx]. This operation is useful for correlating an identifier -that is bound in an internal-definition context with its binding -before the internal-definition context was created.} +Removes @scheme[intdef-ctx] (or each identifier in the list) from the +@tech{lexical information} of @scheme[id-stx]. This operation is +useful for correlating an identifier that is bound in an +internal-definition context with its binding before the +internal-definition context was created. + +If simply removing the contexts produces a different binding than +completely ignoring the contexts (due to nested internal definition +contexts, for example), then the resulting identifier is given a +@tech{syntax mark} to simulate a non-existent lexical context. The +@scheme[intdef-ctx] argument can be a list because removing +internal-definition contexts one at a time can produce a different +intermediate binding then removing them all at once.} @defproc[(syntax-local-value [id-stx syntax?] @@ -259,7 +269,7 @@ before the internal-definition context was created.} Returns the @tech{transformer binding} value of @scheme[id-stx] in either the context associated with @scheme[intdef-ctx] (if not @scheme[#f]) or the context of the expression being expanded (if -@scheme[indef-ctx] is @scheme[#f]). If @scheme[intdef-ctx] is +@scheme[intdef-ctx] is @scheme[#f]). If @scheme[intdef-ctx] is provided, it must be an extension of the context of the expression being expanded. @@ -324,8 +334,6 @@ for caching lift information to avoid redundant lifts. @transform-time[]} - - @defproc[(syntax-local-lift-module-end-declaration [stx syntax?]) void?]{ diff --git a/collects/tests/mzscheme/package.ss b/collects/tests/mzscheme/package.ss index f9f6b3f656..65c6e320c9 100644 --- a/collects/tests/mzscheme/package.ss +++ b/collects/tests/mzscheme/package.ss @@ -170,6 +170,18 @@ ;; ---------------------------------------- +(test-pack-seq + 5 + (define-package p1 #:all-defined + (define-package p2 () + (define x 10)) + (open-package p2)) + (open-package p1) + [#:fail x exn:fail:contract:variable?] + 5) + +;; ---------------------------------------- + (test-pack-seq '(17 12) (define-syntax-rule (mk id) diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index bd1794bbc6..660b76364f 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -4339,15 +4339,46 @@ static Scheme_Object *intdef_context_seal(int argc, Scheme_Object *argv[]) static Scheme_Object * id_intdef_remove(int argc, Scheme_Object *argv[]) { + Scheme_Object *l, *res, *skips; + if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0]))) scheme_wrong_type("identifier-from-from-definition-context", "syntax identifier", 0, argc, argv); - - if (!SAME_TYPE(SCHEME_TYPE(argv[1]), scheme_intdef_context_type)) - scheme_wrong_type("identifier-remove-from-definition-context", - "internal-definition context", 1, argc, argv); - return scheme_stx_id_remove_rib(argv[0], SCHEME_PTR2_VAL(argv[1])); + l = argv[1]; + if (!SAME_TYPE(SCHEME_TYPE(l), scheme_intdef_context_type)) { + while (SCHEME_PAIRP(l)) { + if (!SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(l)), scheme_intdef_context_type)) + break; + l = SCHEME_CDR(l); + } + if (!SCHEME_NULLP(l)) + scheme_wrong_type("identifier-remove-from-definition-context", + "internal-definition context or list of internal-definition contexts", + 1, argc, argv); + } + + l = argv[1]; + if (SAME_TYPE(SCHEME_TYPE(l), scheme_intdef_context_type)) + l = scheme_make_pair(l, scheme_null); + + res = argv[0]; + skips = scheme_null; + + while (SCHEME_PAIRP(l)) { + res = scheme_stx_id_remove_rib(res, SCHEME_PTR2_VAL(SCHEME_CAR(l))); + skips = scheme_make_pair(SCHEME_PTR2_VAL(SCHEME_CAR(l)), skips); + l = SCHEME_CDR(l); + } + + if (scheme_stx_ribs_matter(res, skips)) { + /* Removing ribs leaves the binding for this identifier in limbo, because + the rib that binds it depends on the removed ribs. Invent in inaccessible + identifier. */ + res = scheme_add_remove_mark(res, scheme_new_mark()); + } + + return res; } static Scheme_Object * diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 6f5ec3e0fc..0b2311b223 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -806,6 +806,8 @@ Scheme_Object *scheme_stx_module_name(Scheme_Object **name, Scheme_Object *phase Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a); int scheme_stx_parallel_is_used(Scheme_Object *sym, Scheme_Object *stx); +int scheme_stx_ribs_matter(Scheme_Object *a, Scheme_Object *skip_ribs); + int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase); int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, Scheme_Object *phase); diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 41c26b2ec4..a7af2834fd 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -4276,6 +4276,22 @@ Scheme_Object *scheme_stx_module_name(Scheme_Object **a, Scheme_Object *phase, return NULL; } +int scheme_stx_ribs_matter(Scheme_Object *a, Scheme_Object *skip_ribs) +{ + Scheme_Object *m1, *m2, *skips = NULL; + + while (SCHEME_PAIRP(skip_ribs)) { + skips = scheme_make_raw_pair(((Scheme_Lexical_Rib *)SCHEME_CAR(skip_ribs))->timestamp, + skips); + skip_ribs = SCHEME_CDR(skip_ribs); + } + + m1 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, NULL, NULL, NULL, 0); + m2 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, skips, NULL, NULL, 0); + + return !SAME_OBJ(m1, m2); +} + Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a) /* Returns either false, a lexical-rename symbol, or void for "floating" */ {