suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
svn: r13253
This commit is contained in:
Matthew Flatt 2009-01-21 20:00:55 +00:00
parent 70d25c8f0c
commit db12513b65
8 changed files with 128 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
collects/scheme/package.ss
View File

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

9
collects/scribble/search.ss
View File

@ -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

18
collects/scribblings/reference/package.scrbl
View File

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

26
collects/scribblings/reference/stx-trans.scrbl
View File

@ -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?]{

12
collects/tests/mzscheme/package.ss
View File

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

41
src/mzscheme/src/env.c
View File

@ -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 *

2
src/mzscheme/src/schpriv.h
View File

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

16
src/mzscheme/src/stxobj.c
View File

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