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

@@ -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)))]
+                                   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))))))

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
+    ;; 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
+    ;; 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

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]

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?]
+@defproc[(identifier-remove-from-definition-context [id-stx identifier?]
-                                                      [intdef-ctx internal-definition-context?])
+                                                    [intdef-ctx (or/c internal-definition-context?
+                                                                      (listof internal-definition-context?))])
          identifier?]{
 
-Removes @scheme[intdef-ctx] from the @tech{lexical information} of
+Removes @scheme[intdef-ctx] (or each identifier in the list) from the
-@scheme[id-stx]. This operation is useful for correlating an identifier
+@tech{lexical information} of @scheme[id-stx]. This operation is
-that is bound in an internal-definition context with its binding
+useful for correlating an identifier that is bound in an
-before the internal-definition context was created.}
+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?]{
 

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)

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))
+  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", 1, argc, argv);
+                        "internal-definition context or list of internal-definition contexts", 
+                        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))
+    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 *

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);
 

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" */
 {