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

fix define after define* in package; doc repairs

Browse Source 
svn: r14701
This commit is contained in:
Matthew Flatt 2009-05-03 23:49:22 +00:00
parent db90b44b0d
commit 16e483033c
6 changed files with 74 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/scheme/package.ss
View File

@ -1,5 +1,6 @@
#lang scheme/base
(require (for-syntax scheme/base
scheme/list
syntax/kerncase
syntax/boundmap
syntax/define
@ -312,7 +313,7 @@
[ids (syntax->list #'(id ...))])
(let* ([def-ctx (if star?
(syntax-local-make-definition-context (car def-ctxes))
(car def-ctxes))]
(last def-ctxes))]
[ids (if star?
(map (add-package-context (list def-ctx)) ids)
ids)])
@ -330,7 +331,7 @@
[ids (syntax->list #'(id ...))])
(let* ([def-ctx (if star?
(syntax-local-make-definition-context (car def-ctxes))
(car def-ctxes))]
(last def-ctxes))]
[ids (if star?
(map (add-package-context (list def-ctx)) ids)
ids)])

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

@ -41,7 +41,7 @@ expressions within the body (and, in particular, the definitions can
refer to each other). However, @scheme[define-package] handles
@scheme[define*], @scheme[define*-syntax], @scheme[define*-values],
@scheme[define*-syntaxes], and
@scheme[open*-syntaxes] specially: the bindings introduced by those
@scheme[open*-package] specially: the bindings introduced by those
forms within a @scheme[define-package] body are visible only to
@scheme[form]s that appear later in the body, and they can shadow any
binding from preceding @scheme[form]s (even if the preceding binding

2
collects/scribblings/reference/printer.scrbl
View File

@ -213,7 +213,7 @@ for a table using @scheme[equal?], @scheme[eqv?], or @scheme[eq?] key comparison
respectively. After this prefix, each key--value mapping is shown as
@litchar{(}, the printed form of a key, a space, @litchar{.}, a space,
the printed form the corresponding value, and @litchar{)}, with an
additional space if the key--value pairs is not the last to be printed.
additional space if the key--value pair is not the last to be printed.
After all key-value pairs, the printed form completes with
@litchar{)}.

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

@ -150,6 +150,27 @@
(open-package p)
x)
(test-pack-seq
14
(define-package p (z)
(define* x (lambda () y))
(define z x)
(define* x 2)
(define y 14))
(open-package p)
(z))
(test-pack-seq
21
(define-package p (x)
(define* x (lambda () y))
(define* x2 0)
(define* x3 1)
(define* x4 1)
(define y 21))
(open-package p)
(x))
(test-pack-seq
'(2 1)
(define-package p (x y)

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

@ -4381,6 +4381,9 @@ local_make_intdef_context(int argc, Scheme_Object *argv[])
{
Scheme_Comp_Env *env, *senv;
Scheme_Object *c, *rib;
void **d;
d = MALLOC_N(void*, 3);
env = scheme_current_thread->current_local_env;
if (!env)
@ -4389,19 +4392,21 @@ local_make_intdef_context(int argc, Scheme_Object *argv[])
if (argc && SCHEME_TRUEP(argv[0])) {
if (!SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[0])))
scheme_wrong_type("syntax-local-bind-syntaxes", "internal-definition context or #f", 0, argc, argv);
senv = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(argv[0]);
senv = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[0]))[0];
if (!scheme_is_sub_env(senv, env)) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-make-definition-context: transforming context does "
"not match given internal-definition context");
}
env = senv;
d[1] = argv[0];
}
d[0] = env;
rib = scheme_make_rename_rib();
c = scheme_alloc_object();
c->type = scheme_intdef_context_type;
SCHEME_PTR1_VAL(c) = env;
SCHEME_PTR1_VAL(c) = d;
SCHEME_PTR2_VAL(c) = rib;
return c;

49
src/mzscheme/src/eval.c
View File

@ -6339,6 +6339,7 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
before deciding what we have. */
{
Scheme_Object *first, *rib, *ctx, *ectx, *orig = forms;
void **d;
Scheme_Comp_Env *xenv = NULL;
Scheme_Compile_Info recs[2];
DupCheckRecord r;
@ -6364,7 +6365,9 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
rib = scheme_make_rename_rib();
ctx = scheme_alloc_object();
ctx->type = scheme_intdef_context_type;
SCHEME_PTR1_VAL(ctx) = env;
d = MALLOC_N(void*, 3);
d[0] = env;
SCHEME_PTR1_VAL(ctx) = d;
SCHEME_PTR2_VAL(ctx) = rib;
ectx = scheme_make_pair(ctx, scheme_null);
scheme_begin_dup_symbol_check(&r, env);
@ -6561,7 +6564,7 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
}
/* Remember extended environment */
SCHEME_PTR1_VAL(ctx) = new_env;
((void **)SCHEME_PTR1_VAL(ctx))[0] = new_env;
env = new_env;
xenv = NULL;
}
@ -9292,6 +9295,31 @@ static Scheme_Object *add_intdef_renamings(Scheme_Object *l, Scheme_Object *rena
return l;
}
static void update_intdef_chain(Scheme_Object *intdef)
{
Scheme_Comp_Env *orig, *current_next;
Scheme_Object *base;
/* If this intdef chains to another, and if the other has been
extended, then fix up the chain. */
while (1) {
base = (Scheme_Object *)((void **)SCHEME_PTR1_VAL(intdef))[1];
if (base) {
current_next = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(base))[0];
orig = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(intdef))[2];
if (orig) {
orig->next = current_next;
} else {
((void **)SCHEME_PTR1_VAL(base))[0] = current_next;
}
intdef = base;
} else {
break;
}
}
}
static Scheme_Object *
do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, int argc, Scheme_Object **argv)
{
@ -9337,7 +9365,8 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
if (SCHEME_TRUEP(argv[3])) {
if (SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[3]))) {
Scheme_Comp_Env *stx_env;
stx_env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(argv[3]);
update_intdef_chain(argv[3]);
stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[3]))[0];
renaming = SCHEME_PTR2_VAL(argv[3]);
if (!scheme_is_sub_env(stx_env, env))
bad_sub_env = 1;
@ -9347,7 +9376,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
while (SCHEME_PAIRP(rl)) {
if (SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(SCHEME_CAR(rl)))) {
Scheme_Comp_Env *stx_env;
stx_env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(SCHEME_CAR(rl));
stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(SCHEME_CAR(rl)))[0];
if (!scheme_is_sub_env(stx_env, env))
bad_sub_env = 1;
} else
@ -9358,7 +9387,8 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
bad_intdef = 1;
else {
rl = argv[3];
env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(SCHEME_CAR(rl));
update_intdef_chain(SCHEME_CAR(rl));
env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(SCHEME_CAR(rl)))[0];
if (SCHEME_NULLP(SCHEME_CDR(rl)))
renaming = SCHEME_PTR2_VAL(SCHEME_CAR(rl));
else {
@ -9837,7 +9867,7 @@ local_eval(int argc, Scheme_Object **argv)
cnt++;
}
if (!SCHEME_NULLP(l))
scheme_wrong_type("syntax-local-bind-syntaxes", "list of syntax identifieres", 0, argc, argv);
scheme_wrong_type("syntax-local-bind-syntaxes", "list of syntax identifiers", 0, argc, argv);
expr = argv[1];
if (!SCHEME_FALSEP(expr) && !SCHEME_STXP(expr))
@ -9849,7 +9879,8 @@ local_eval(int argc, Scheme_Object **argv)
if (!env)
scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-bind-syntaxes: not currently transforming");
stx_env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(argv[2]);
update_intdef_chain(argv[2]);
stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[2]))[0];
rib = SCHEME_PTR2_VAL(argv[2]);
if (*scheme_stx_get_rib_sealed(rib)) {
@ -9909,7 +9940,9 @@ local_eval(int argc, Scheme_Object **argv)
scheme_add_env_renames(rib, stx_env, old_stx_env);
/* Remember extended environment */
SCHEME_PTR1_VAL(argv[2]) = stx_env;
((void **)SCHEME_PTR1_VAL(argv[2]))[0] = stx_env;
if (!((void **)SCHEME_PTR1_VAL(argv[2]))[2])
((void **)SCHEME_PTR1_VAL(argv[2]))[2] = stx_env;
return scheme_void;
}