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

299.201

Browse Source 
svn: r572
This commit is contained in:
Matthew Flatt 2005-08-09 13:41:06 +00:00
parent 2863c91763
commit 4ad1f38141
11 changed files with 1292 additions and 1279 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/eopl/datatype.ss
View File

@ -123,6 +123,7 @@
...
variant? ...
variant-accessor ...))))
;; Compatibility bindings
(define-values (make-variant-name ...) (values variant-name ...))))))]
[(_ name pred-name variant ...)
;; Must be a bad variant...

5
collects/mzlib/struct.ss
View File

@ -53,7 +53,7 @@
(let ([dests
(map
(lambda (field)
(or (ormap (lambda (f2) (and (module-or-top-identifier=? field f2) f2)) accessors)
(or (ormap (lambda (f2) (and f2 (module-or-top-identifier=? field f2) f2)) accessors)
(raise-syntax-error #f "accessor name not associated with the given structure type" stx field)))
as)])
;; Check for duplicates using dests, not as, because mod=? as might not be id=?
@ -64,7 +64,8 @@
stx
;; Map back to an original field:
(ormap (lambda (a)
(and (module-or-top-identifier=? dupe a)
(and a
(module-or-top-identifier=? dupe a)
a))
(reverse as))))))

6
collects/texpict/private/mrpict-extra.ss
View File

@ -80,10 +80,10 @@
(let ([x (current-expected-text-scale)])
(if (equal? x '(1 1))
(thunk)
(begin
(send dc set-scale (car x) (cadr x))
(let-values ([(xs ys) (send dc get-scale)])
(send dc set-scale (* xs (car x)) (* ys (cadr x)))
(let-values ([(w h d s) (thunk)])
(send dc set-scale 1 1)
(send dc set-scale xs ys)
(values w h d s))))))
(define (memq* a l)

2497
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

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

@ -3020,7 +3020,7 @@ local_exp_time_value(int argc, Scheme_Object *argv[])
v = SCHEME_PTR_VAL(v);
if (SAME_TYPE(SCHEME_TYPE(v), scheme_id_macro_type)) {
sym = SCHEME_PTR1_VAL(v);
sym = scheme_stx_cert(sym, scheme_false, menv, sym, NULL);
sym = scheme_stx_cert(sym, scheme_false, menv, sym, NULL, 1);
renamed = 1;
menv = NULL;
SCHEME_USE_FUEL(1);
@ -3305,13 +3305,15 @@ certifier(void *_data, int argc, Scheme_Object **argv)
s = scheme_stx_cert(s, mark,
(Scheme_Env *)(cert_data[1] ? cert_data[1] : cert_data[2]),
cert_data[0],
(argc > 1) ? argv[1] : NULL);
(argc > 1) ? argv[1] : NULL,
0 /* inactive cert */);
if (cert_data[1] && cert_data[2] && !SAME_OBJ(cert_data[1], cert_data[2])) {
/* Have module we're expanding, in addition to module that bound
the expander. */
s = scheme_stx_cert(s, mark, (Scheme_Env *)cert_data[2],
NULL,
(argc > 1) ? argv[1] : NULL);
(argc > 1) ? argv[1] : NULL,
0 /* inactive cert */);
}
}
@ -3385,7 +3387,7 @@ local_lift_expr(int argc, Scheme_Object *argv[])
expr = scheme_stx_cert(expr, scheme_false,
(menv && menv->module) ? menv : NULL,
scheme_current_thread->current_local_certs,
NULL);
NULL, 1);
expr = scheme_stx_activate_certs(expr);

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

@ -1884,7 +1884,7 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
} else if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) {
if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(val)), scheme_id_macro_type)) {
/* It's a rename. Look up the target name and try again. */
name = scheme_stx_cert(SCHEME_PTR_VAL(SCHEME_PTR_VAL(val)), scheme_false, menv, name, NULL);
name = scheme_stx_cert(SCHEME_PTR_VAL(SCHEME_PTR_VAL(val)), scheme_false, menv, name, NULL, 1);
menv = NULL;
SCHEME_USE_FUEL(1);
} else {
@ -2048,7 +2048,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
if (!rec[drec].comp) {
new_name = scheme_stx_track(new_name, find_name, find_name);
}
new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL);
new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1);
find_name = new_name;
SCHEME_USE_FUEL(1);
menv = NULL;
@ -2140,7 +2140,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
if (!rec[drec].comp) {
new_name = scheme_stx_track(new_name, find_name, find_name);
}
new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL);
new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1);
find_name = new_name;
SCHEME_USE_FUEL(1);
menv = NULL;
@ -2213,7 +2213,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
if (!rec[drec].comp) {
new_name = scheme_stx_track(new_name, find_name, find_name);
}
new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL);
new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1);
find_name = new_name;
SCHEME_USE_FUEL(1);
menv = NULL;
@ -2404,7 +2404,7 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env,
0, 2);
/* Copy certifications from lambda to `body'. */
body = scheme_stx_cert(body, NULL, NULL, name, NULL);
body = scheme_stx_cert(body, NULL, NULL, name, NULL, 1);
return scheme_compile_expand_expr(body, env, rec, drec, 0);
} else {

6
src/mzscheme/src/fun.c
View File

@ -1363,7 +1363,7 @@ cert_with_specials(Scheme_Object *code, Scheme_Object *mark, Scheme_Env *menv,
if (SCHEME_STXP(code)) {
prop = scheme_stx_property(code, certify_mode_symbol, NULL);
if (SAME_OBJ(prop, opaque_symbol)) {
return scheme_stx_cert(code, mark, menv, orig_code, NULL);
return scheme_stx_cert(code, mark, menv, orig_code, NULL, 1);
} else if (SAME_OBJ(prop, transparent_symbol)) {
cadr_deflt = 0;
/* fall through */
@ -1391,7 +1391,7 @@ cert_with_specials(Scheme_Object *code, Scheme_Object *mark, Scheme_Env *menv,
}
if (!trans)
return scheme_stx_cert(code, mark, menv, orig_code, NULL);
return scheme_stx_cert(code, mark, menv, orig_code, NULL, 1);
}
}
@ -1412,7 +1412,7 @@ cert_with_specials(Scheme_Object *code, Scheme_Object *mark, Scheme_Env *menv,
} else if (SCHEME_STX_NULLP(code))
return code;
return scheme_stx_cert(code, mark, menv, orig_code, NULL);
return scheme_stx_cert(code, mark, menv, orig_code, NULL, 1);
}
Scheme_Object *

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

@ -631,7 +631,7 @@ Scheme_Object *scheme_source_to_name(Scheme_Object *code);
#define STX_SRCTAG scheme_false
Scheme_Object *scheme_stx_cert(Scheme_Object *o, Scheme_Object *mark, Scheme_Env *menv, Scheme_Object *plus_stx,
Scheme_Object *mkey);
Scheme_Object *mkey, int active);
int scheme_stx_certified(Scheme_Object *stx, Scheme_Object *extra_certs, Scheme_Object *modidx, Scheme_Object *home_insp);
int scheme_module_protected_wrt(Scheme_Object *home_insp, Scheme_Object *insp);
Scheme_Object *scheme_stx_activate_certs(Scheme_Object *stx);

4
src/mzscheme/src/schvers.h
View File

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 299
#define MZSCHEME_VERSION_MINOR 200
#define MZSCHEME_VERSION_MINOR 201
#define MZSCHEME_VERSION "299.200" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "299.201" _MZ_SPECIAL_TAG

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

@ -1615,7 +1615,8 @@ Scheme_Object *scheme_stx_extract_certs(Scheme_Object *o, Scheme_Object *base_ce
}
Scheme_Object *scheme_stx_cert(Scheme_Object *o, Scheme_Object *mark, Scheme_Env *menv,
Scheme_Object *plus_stx_or_certs, Scheme_Object *key)
Scheme_Object *plus_stx_or_certs, Scheme_Object *key,
int active)
/* If `name' is module-bound, add the module's certification.
Also copy any certifications from plus_stx.
If mark is non-NULL, make inactive certificates active. */
@ -1630,7 +1631,7 @@ Scheme_Object *scheme_stx_cert(Scheme_Object *o, Scheme_Object *mark, Scheme_Env
else
certs = (Scheme_Cert *)plus_stx_or_certs;
if (certs)
o = add_certs(o, certs, key, 1);
o = add_certs(o, certs, key, active);
/* Also copy over inactive certs, if any */
if (SCHEME_STXP(plus_stx_or_certs))
o = add_certs(o, INACTIVE_CERTS((Scheme_Stx *)plus_stx_or_certs), key, 0);
@ -1646,23 +1647,32 @@ Scheme_Object *scheme_stx_cert(Scheme_Object *o, Scheme_Object *mark, Scheme_Env
res->wraps = stx->wraps;
res->u.lazy_prefix = stx->u.lazy_prefix;
cert = ACTIVE_CERTS(stx);
if (SCHEME_FALSEP(mark)) {
/* Need to invent a mark and apply it */
mark = scheme_new_mark();
res = (Scheme_Stx *)scheme_add_remove_mark((Scheme_Object *)res, mark);
}
if (active)
cert = ACTIVE_CERTS(stx);
else
cert = INACTIVE_CERTS(stx);
cert = cons_cert(mark, menv->link_midx ? menv->link_midx : menv->module->src_modidx,
menv->module->insp, key, cert);
if (stx->certs && SCHEME_PAIRP(stx->certs)) {
if (active) {
if (stx->certs && SCHEME_PAIRP(stx->certs)) {
Scheme_Object *pr;
pr = scheme_make_pair((Scheme_Object *)cert, SCHEME_CDR(stx->certs));
res->certs = pr;
} else
res->certs = (Scheme_Object *)cert;
} else {
Scheme_Object *pr;
pr = scheme_make_pair((Scheme_Object *)cert, SCHEME_CDR(stx->certs));
pr = scheme_make_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)cert);
res->certs = pr;
} else
res->certs = (Scheme_Object *)cert;
}
o = (Scheme_Object *)res;
}

4
src/mzscheme/src/syntax.c
View File

@ -1246,7 +1246,7 @@ set_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
return scheme_compile_expr(form, env, rec, drec);
} else if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) {
find_name = SCHEME_PTR_VAL(SCHEME_PTR_VAL(var));
find_name = scheme_stx_cert(find_name, scheme_false, menv, find_name, NULL);
find_name = scheme_stx_cert(find_name, scheme_false, menv, find_name, NULL, 1);
SCHEME_USE_FUEL(1);
menv = NULL;
} else
@ -1335,7 +1335,7 @@ set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec,
Scheme_Object *new_name;
new_name = SCHEME_PTR_VAL(SCHEME_PTR_VAL(var));
new_name = scheme_stx_track(new_name, find_name, find_name);
new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL);
new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1);
find_name = new_name;
menv = NULL;
} else