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

352.2, including clean up of MSVC 8.0 build warnings

Browse Source 
svn: r3903
This commit is contained in:
Matthew Flatt 2006-07-31 13:06:39 +00:00
parent 0760d57b01
commit a020290c65
36 changed files with 3187 additions and 2469 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/mzscheme/include/scheme.h
View File

@ -1041,6 +1041,7 @@ typedef void (*Scheme_Kill_Action_Func)(void *);
savebuf = scheme_current_thread->error_buf; \
scheme_current_thread->error_buf = &newbuf; \
if (scheme_setjmp(newbuf)) { \
scheme_pop_kill_action(); \
func(data); \
scheme_longjmp(*savebuf, 1); \
} else {
@ -1146,6 +1147,8 @@ enum {
MZCONFIG_THREAD_SET,
MZCONFIG_THREAD_INIT_STACK_SIZE,
MZCONFIG_EXPAND_OBSERVE,
__MZCONFIG_BUILTIN_COUNT__
};

4018
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

@ -28,6 +28,7 @@
#include "schpriv.h"
#include "schminc.h"
#include "schexpobs.h"
#if defined(UNIX_LIMIT_STACK) || defined(UNIX_LIMIT_FDSET_SIZE)
# include <signal.h>
@ -341,6 +342,7 @@ Scheme_Env *scheme_basic_env()
(Scheme_Object *)env);
scheme_init_memtrace(env);
scheme_init_parameterization(env);
scheme_init_expand_observe(env);
#ifndef DONT_USE_FOREIGN
scheme_init_foreign(env);
@ -3898,6 +3900,7 @@ local_lift_expr(int argc, Scheme_Object *argv[])
Scheme_Comp_Env *env, *orig_env;
Scheme_Object *id, *local_mark, *expr, *data, *vec, *id_sym;
Scheme_Lift_Capture_Proc cp;
Scheme_Object *orig_expr;
expr = argv[0];
if (!SCHEME_STXP(expr))
@ -3936,6 +3939,7 @@ local_lift_expr(int argc, Scheme_Object *argv[])
NULL, 1);
expr = scheme_stx_activate_certs(expr);
orig_expr = expr;
expr = cp(data, &id, expr, orig_env);
@ -3944,6 +3948,8 @@ local_lift_expr(int argc, Scheme_Object *argv[])
id = scheme_add_remove_mark(id, local_mark);
SCHEME_EXPAND_OBSERVE_LOCAL_LIFT(scheme_get_expand_observe(), id, orig_expr);
return id;
}
@ -3952,6 +3958,7 @@ local_lift_end_statement(int argc, Scheme_Object *argv[])
{
Scheme_Comp_Env *env;
Scheme_Object *local_mark, *expr, *pr;
Scheme_Object *orig_expr;
expr = argv[0];
if (!SCHEME_STXP(expr))
@ -3977,9 +3984,12 @@ local_lift_end_statement(int argc, Scheme_Object *argv[])
" a run-time expression in a module declaration");
expr = scheme_add_remove_mark(expr, local_mark);
orig_expr = expr;
pr = scheme_make_pair(expr, SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3]);
SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3] = pr;
SCHEME_EXPAND_OBSERVE_LIFT_STATEMENT(scheme_get_expand_observe(), orig_expr);
return scheme_void;
}

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

@ -117,6 +117,7 @@
#include "schpriv.h"
#include "schrunst.h"
#include "schexpobs.h"
#ifdef USE_STACKAVAIL
#include <malloc.h>
@ -215,7 +216,7 @@ static Scheme_Object *read_quote_syntax(Scheme_Object *obj);
static Scheme_Object *define_values_symbol, *letrec_values_symbol, *lambda_symbol;
static Scheme_Object *unknown_symbol, *void_link_symbol, *quote_symbol;
static Scheme_Object *letrec_syntaxes_symbol, *begin_symbol;
static Scheme_Object *let_symbol;
static Scheme_Object *let_values_symbol;
static Scheme_Object *internal_define_symbol;
static Scheme_Object *module_symbol;
@ -295,11 +296,11 @@ scheme_init_eval (Scheme_Env *env)
REGISTER_SO(quote_symbol);
REGISTER_SO(letrec_syntaxes_symbol);
REGISTER_SO(begin_symbol);
REGISTER_SO(let_symbol);
REGISTER_SO(let_values_symbol);
define_values_symbol = scheme_intern_symbol("define-values");
letrec_values_symbol = scheme_intern_symbol("letrec-values");
let_symbol = scheme_intern_symbol("let");
let_values_symbol = scheme_intern_symbol("let-values");
lambda_symbol = scheme_intern_symbol("lambda");
unknown_symbol = scheme_intern_symbol("unknown");
void_link_symbol = scheme_intern_symbol("-v");
@ -1611,7 +1612,7 @@ static Scheme_Object *link_toplevel(Scheme_Object *expr, Scheme_Env *env,
}
}
static Scheme_Object *resolve_k()
static Scheme_Object *resolve_k(void)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *expr = (Scheme_Object *)p->ku.k.p1;
@ -2374,7 +2375,7 @@ static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info)
return (Scheme_Object *)wcm;
}
static Scheme_Object *optimize_k()
static Scheme_Object *optimize_k(void)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *expr = (Scheme_Object *)p->ku.k.p1;
@ -3192,6 +3193,8 @@ void scheme_init_compile_recs(Scheme_Compile_Info *src, int drec,
dest[i].resolve_module_ids = src[drec].resolve_module_ids;
dest[i].value_name = scheme_false;
dest[i].certs = src[drec].certs;
/* should be always NULL */
dest[i].observer = src[drec].observer;
}
}
@ -3208,6 +3211,7 @@ void scheme_init_expand_recs(Scheme_Expand_Info *src, int drec,
dest[i].depth = src[drec].depth;
dest[i].value_name = scheme_false;
dest[i].certs = src[drec].certs;
dest[i].observer = src[drec].observer;
}
}
@ -3225,6 +3229,7 @@ void scheme_init_lambda_rec(Scheme_Compile_Info *src, int drec,
lam[dlrec].resolve_module_ids = src[drec].resolve_module_ids;
lam[dlrec].value_name = scheme_false;
lam[dlrec].certs = src[drec].certs;
lam[dlrec].observer = src[drec].observer;
}
void scheme_merge_lambda_rec(Scheme_Compile_Info *src, int drec,
@ -3468,6 +3473,7 @@ static void *compile_k(void)
rec.resolve_module_ids = !writeable && !genv->module;
rec.value_name = scheme_false;
rec.certs = NULL;
rec.observer = NULL;
cenv = scheme_new_comp_env(genv, insp, SCHEME_TOPLEVEL_FRAME);
@ -3631,6 +3637,8 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
Scheme_Env *menv = NULL;
int need_cert;
SCHEME_EXPAND_OBSERVE_ENTER_CHECK(rec[drec].observer, first);
check_top:
*current_val = NULL;
@ -3642,8 +3650,10 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
need_cert = 0;
}
if (!SCHEME_STX_SYMBOLP(name))
if (!SCHEME_STX_SYMBOLP(name)) {
SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first);
return first;
}
while (1) {
@ -3671,6 +3681,7 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
*current_val = val;
if (!val) {
SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first);
return first;
} else if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) {
if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(val)), scheme_id_macro_type)) {
@ -3700,6 +3711,7 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
break; /* break to outer loop */
}
} else {
SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first);
return first;
}
}
@ -3729,7 +3741,7 @@ compile_expand_macro_app(Scheme_Object *name, Scheme_Env *menv, Scheme_Object *m
if (!boundname)
boundname = scheme_false;
return scheme_apply_macro(name, menv, xformer, form, env, boundname, rec[drec].certs, 0);
return scheme_apply_macro(name, menv, xformer, form, env, boundname, rec, drec, 0);
/* caller expects rec[drec] to be used to compile the result... */
}
@ -3798,8 +3810,11 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
scheme_signal_error("not syntax");
#endif
if (rec[drec].comp)
if (rec[drec].comp) {
scheme_default_compile_rec(rec, drec);
} else {
SCHEME_EXPAND_OBSERVE_VISIT(rec[drec].observer,form);
}
looking_for_top = 0;
@ -3831,6 +3846,8 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
rec[drec].certs, env->in_modidx,
&menv, &protected);
SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer,find_name);
if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
&& SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) {
/* It's a rename. Look up the target name and try again. */
@ -3857,9 +3874,13 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
looking_for_top = 1;
} else {
if (SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) {
if (var == stop_expander)
if (var == stop_expander) {
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(rec[drec].observer,form);
SCHEME_EXPAND_OBSERVE_PRIM_STOP(rec[drec].observer);
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(rec[drec].observer,form);
SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer,form);
return form;
else {
} else {
scheme_wrong_syntax(NULL, NULL, form, "bad syntax");
return NULL;
}
@ -3880,6 +3901,8 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
/* Add a property to indicate that the name is protected */
find_name = scheme_stx_property(find_name, protected_symbol, scheme_true);
}
SCHEME_EXPAND_OBSERVE_VARIABLE(rec[drec].observer, form, find_name);
SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, find_name);
return find_name; /* which is usually == form */
}
}
@ -3922,6 +3945,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
erec1.certs, env->in_modidx,
&menv, NULL);
SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name);
if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
&& SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) {
/* It's a rename. Look up the target name and try again. */
@ -3954,7 +3978,11 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
} else {
Scheme_Syntax_Expander *f;
f = (Scheme_Syntax_Expander *)SCHEME_SYNTAX_EXP(var);
return f(form, env, rec, drec);
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(rec[drec].observer, form);
form = f(form, env, rec, drec);
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(rec[drec].observer, form);
SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form);
return form;
}
}
@ -3995,6 +4023,8 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
rec[drec].certs, env->in_modidx,
&menv, NULL);
SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name);
if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
&& SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) {
/* It's a rename. Look up the target name and try again. */
@ -4042,6 +4072,10 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
|| SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type))) {
if (SAME_OBJ(var, stop_expander)) {
/* Return original: */
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(rec[drec].observer, form);
SCHEME_EXPAND_OBSERVE_PRIM_STOP(rec[drec].observer);
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(rec[drec].observer, form);
SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form);
return form;
} else if (rec[drec].comp && SAME_OBJ(var, normal)) {
/* Skip creation of intermediate form */
@ -4060,7 +4094,11 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
} else {
Scheme_Syntax_Expander *f;
f = (Scheme_Syntax_Expander *)SCHEME_SYNTAX_EXP(var);
return f(form, env, rec, drec);
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(rec[drec].observer, form);
form = f(form, env, rec, drec);
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(rec[drec].observer, form);
SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form);
return form;
}
} else {
name = stx;
@ -4078,10 +4116,15 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
}
macro:
if (!rec[drec].comp && !rec[drec].depth)
if (!rec[drec].comp && !rec[drec].depth) {
SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form);
return form; /* We've gone as deep as requested */
}
SCHEME_EXPAND_OBSERVE_ENTER_MACRO(rec[drec].observer, form);
form = compile_expand_macro_app(name, menv, var, form, env, rec, drec);
SCHEME_EXPAND_OBSERVE_EXIT_MACRO(rec[drec].observer, form);
if (rec[drec].comp)
goto top;
else {
@ -4089,8 +4132,10 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
--rec[drec].depth;
if (rec[drec].depth)
goto top;
else
else {
SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form);
return form;
}
}
}
@ -4159,7 +4204,7 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env,
rest = SCHEME_STX_CDR(form);
al = scheme_stx_proper_list_length(rest);
if (al == pl) {
DupCheckRecord r;
@ -4175,7 +4220,7 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env,
scheme_dup_symbol_check(&r, NULL, n, "argument", name);
v = SCHEME_STX_CAR(rest);
v = cons(cons(n, cons(v, scheme_null)), scheme_null);
v = cons(cons(cons(n, scheme_null), cons(v, scheme_null)), scheme_null);
if (last)
SCHEME_CDR(last) = v;
else
@ -4186,7 +4231,7 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env,
rest = SCHEME_STX_CDR(rest);
}
body = scheme_datum_to_syntax(cons(let_symbol,
body = scheme_datum_to_syntax(cons(let_values_symbol,
cons(bindings,
body)),
form,
@ -4201,7 +4246,7 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env,
#if 0
scheme_wrong_syntax(scheme_application_stx_string, NULL, form,
"procedure application: bad ((lambda (...) ...) ...) syntax");
return NULL
return NULL;
#endif
}
}
@ -4246,6 +4291,7 @@ app_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
static Scheme_Object *
app_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
SCHEME_EXPAND_OBSERVE_PRIM_APP(erec[drec].observer);
return compile_expand_app(form, env, erec, drec);
}
@ -4269,6 +4315,7 @@ datum_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec
static Scheme_Object *
datum_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
SCHEME_EXPAND_OBSERVE_PRIM_DATUM(erec[drec].observer);
return form;
}
@ -4343,8 +4390,8 @@ top_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
static Scheme_Object *
top_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
SCHEME_EXPAND_OBSERVE_PRIM_TOP(erec[drec].observer);
check_top(scheme_expand_stx_string, form, env);
return form;
}
@ -4370,7 +4417,7 @@ static Scheme_Object *pair_lifted(Scheme_Object *_ip, Scheme_Object **_id, Schem
scheme_add_compilation_binding(0, *_id, naya);
return icons(*_id, icons(expr, scheme_null));
return icons(icons(*_id, scheme_null), icons(expr, scheme_null));
}
static Scheme_Object *compile_expand_expr_lift_to_let_k(void);
@ -4464,7 +4511,7 @@ compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
revl = icons(SCHEME_CAR(l), revl);
}
for (; SCHEME_PAIRP(revl); revl = SCHEME_CDR(revl)) {
o = icons(scheme_datum_to_syntax(let_symbol, scheme_false, scheme_sys_wraps(env), 0, 0),
o = icons(scheme_datum_to_syntax(let_values_symbol, scheme_false, scheme_sys_wraps(env), 0, 0),
icons(icons(SCHEME_CAR(revl), scheme_null),
icons(o, scheme_null)));
}
@ -4517,15 +4564,22 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
Scheme_Compile_Info recs[2];
DupCheckRecord r;
if (rec[drec].comp)
if (rec[drec].comp) {
scheme_default_compile_rec(rec, drec);
} else {
SCHEME_EXPAND_OBSERVE_ENTER_BLOCK(rec[drec].observer, forms);
}
if (SCHEME_STX_NULLP(forms)) {
if (rec[drec].comp) {
scheme_compile_rec_done_local(rec, drec);
return scheme_null;
} else
} else {
SCHEME_EXPAND_OBSERVE_BLOCK_TO_LIST(rec[drec].observer, forms);
SCHEME_EXPAND_OBSERVE_ENTER_LIST(rec[drec].observer, forms);
SCHEME_EXPAND_OBSERVE_EXIT_LIST(rec[drec].observer, forms);
return forms;
}
}
rib = scheme_make_rename_rib();
@ -4538,13 +4592,24 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
try_again:
SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
if (!SCHEME_STX_PAIRP(forms)) {
scheme_wrong_syntax(scheme_begin_stx_string, NULL, forms, "bad syntax");
return NULL;
}
first = SCHEME_STX_CAR(forms);
first = scheme_add_rename_rib(first, rib);
{
/* Need to send both parts (before & after) of block rename */
Scheme_Object *old_first;
old_first = first;
first = scheme_add_rename_rib(first, rib);
SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(rec[drec].observer,old_first,first);
}
{
Scheme_Object *gval, *result;
@ -4560,6 +4625,9 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
/* Inline content */
Scheme_Object *orig_forms = forms;
SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(rec[drec].observer);
/* FIXME: Redundant with check done by scheme_flatten_begin below? */
if (scheme_stx_proper_list_length(first) < 0)
scheme_wrong_syntax(scheme_begin_stx_string, NULL, first,
"bad syntax (" IMPROPER_LIST_FORM ")");
@ -4576,7 +4644,9 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
}
forms = scheme_flatten_begin(first, forms);
SCHEME_EXPAND_OBSERVE_SPLICE(rec[drec].observer, forms);
if (SCHEME_STX_NULLP(forms)) {
scheme_wrong_syntax(scheme_begin_stx_string, NULL, first,
"bad syntax (empty form)");
@ -4599,6 +4669,12 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
is_val = SAME_OBJ(gval, scheme_define_values_syntax);
v = SCHEME_STX_CDR(first);
if (is_val) {
SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(rec[drec].observer);
} else {
SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(rec[drec].observer);
}
if (!SCHEME_STX_PAIRP(v))
scheme_wrong_syntax(NULL, NULL, first,
@ -4687,9 +4763,9 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
expr = scheme_add_rename_rib(expr, rib);
scheme_bind_syntaxes("local syntax definition",
names, expr,
new_env->genv->exp_env, new_env->insp, rec[drec].certs,
new_env->genv->exp_env, new_env->insp, rec, drec,
new_env, new_env,
&pos, NULL);
&pos);
}
/* Extend shared rib with renamings */
@ -4705,7 +4781,13 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
if (!SCHEME_STX_NULLP(result)) {
first = SCHEME_STX_CAR(result);
first = scheme_datum_to_syntax(first, forms, forms, 0, 0);
first = scheme_add_rename_rib(first, rib);
{
Scheme_Object *old_first;
old_first = first;
first = scheme_add_rename_rib(first, rib);
SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(rec[drec].observer,old_first,first);
}
first = scheme_check_immediate_macro(first, env, rec, drec, 1, &gval, &xenv, ectx);
more = 1;
if (NOT_SAME_OBJ(gval, scheme_define_values_syntax)
@ -4713,8 +4795,10 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
if (SAME_OBJ(gval, scheme_begin_syntax)) {
/* Inline content */
result = SCHEME_STX_CDR(result);
SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(rec[drec].observer);
result = scheme_flatten_begin(first, result);
goto define_try_again;
SCHEME_EXPAND_OBSERVE_SPLICE(rec[drec].observer,result);
goto define_try_again;
} else {
/* Keep partially expanded `first': */
result = SCHEME_STX_CDR(result);
@ -4750,16 +4834,18 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
}
if (!more) {
if (rec[drec].comp)
if (rec[drec].comp) {
result = scheme_compile_expr(result, env, rec, drec);
else {
return scheme_make_immutable_pair(result, scheme_null);
} else {
if (rec[drec].depth > 0)
--rec[drec].depth;
if (rec[drec].depth)
result = scheme_expand_expr(result, env, rec, drec);
if (rec[drec].depth) {
result = scheme_make_immutable_pair(result, scheme_null);
SCHEME_EXPAND_OBSERVE_BLOCK_TO_LETREC(rec[drec].observer, result);
return scheme_expand_list(result, env, rec, drec);
}
}
return scheme_make_immutable_pair(result, scheme_null);
}
}
@ -4786,7 +4872,11 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
#endif
scheme_merge_compile_recs(rec, drec, recs, 2);
return scheme_make_immutable_pair(first, forms);
} else {
#if EMBEDDED_DEFINES_START_ANYWHERE
/* Expand-observe not implemented for this case,
so fix that if it's ever enabled. */
Scheme_Object *rest, *vname;
vname = rec[drec].value_name;
@ -4803,16 +4893,29 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
first = scheme_expand_expr(first, env, recs, 0);
rest = scheme_datum_to_syntax(rest, forms, forms, 0, -1);
#if EMBEDDED_DEFINES_START_ANYWHERE
forms = scheme_compile_expand_block(rest, env, recs, 1);
return scheme_make_immutable_pair(first, forms);
#else
if (scheme_stx_proper_list_length(rest) < 0)
scheme_wrong_syntax(scheme_begin_stx_string, NULL, rest, "bad syntax");
forms = scheme_expand_list(rest, env, recs, 1);
Scheme_Object *newforms, *vname;
vname = rec[drec].value_name;
rec[drec].value_name = scheme_false;
scheme_init_expand_recs(rec, drec, recs, 2);
recs[0].value_name = vname;
newforms = SCHEME_STX_CDR(forms);
newforms = scheme_make_immutable_pair(first, newforms);
forms = scheme_datum_to_syntax(newforms, forms, forms, 0, -1);
if (scheme_stx_proper_list_length(forms) < 0)
scheme_wrong_syntax(scheme_begin_stx_string, NULL, forms, "bad syntax");
SCHEME_EXPAND_OBSERVE_BLOCK_TO_LIST(rec[drec].observer, forms);
forms = scheme_expand_list(forms, env, recs, 0);
return forms;
#endif
}
return scheme_make_immutable_pair(first, forms);
}
Scheme_Object *
@ -4833,8 +4936,12 @@ scheme_expand_list(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info
{
Scheme_Object *first = NULL, *last = NULL, *fm;
if (SCHEME_STX_NULLP(form))
SCHEME_EXPAND_OBSERVE_ENTER_LIST(erec[drec].observer, form);
if (SCHEME_STX_NULLP(form)) {
SCHEME_EXPAND_OBSERVE_EXIT_LIST(erec[drec].observer, form);
return scheme_null;
}
if (scheme_stx_proper_list_length(form) < 0) {
/* This is already checked for anything but application */
@ -4847,6 +4954,8 @@ scheme_expand_list(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info
Scheme_Object *r, *p;
Scheme_Expand_Info erec1;
SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
p = SCHEME_STX_CDR(fm);
scheme_init_expand_recs(erec, drec, &erec1, 1);
@ -4864,7 +4973,9 @@ scheme_expand_list(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info
fm = SCHEME_STX_CDR(fm);
}
return scheme_datum_to_syntax(first, form, form, 0, 0);
form = scheme_datum_to_syntax(first, form, form, 0, 0);
SCHEME_EXPAND_OBSERVE_EXIT_LIST(erec[drec].observer, form);
return form;
}
@ -5519,7 +5630,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
data = ((Scheme_Native_Closure *)obj)->code;
/* Enlarge the runstack? This max_let_depth is in bytes instead of words. */
if (data->max_let_depth > ((unsigned long)RUNSTACK - (unsigned long)RUNSTACK_START)) {
if ((unsigned long)data->max_let_depth > ((unsigned long)RUNSTACK - (unsigned long)RUNSTACK_START)) {
p->ku.k.p1 = (void *)obj;
p->ku.k.i1 = num_rands;
p->ku.k.p2 = (void *)rands;
@ -6502,6 +6613,7 @@ static void *expand_k(void)
erec1.depth = depth;
erec1.value_name = scheme_false;
erec1.certs = certs;
erec1.observer = scheme_get_expand_observe();
if (catch_lifts)
scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false);
@ -6522,6 +6634,7 @@ static void *expand_k(void)
obj = icons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(env), 0, 0),
obj);
obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 0, 0);
SCHEME_EXPAND_OBSERVE_LIFT_LOOP(erec1.observer,obj);
if (depth >= 0)
break;
} else
@ -6766,6 +6879,7 @@ static Scheme_Object *stop_syntax(Scheme_Object *form, Scheme_Comp_Env *env,
static Scheme_Object *stop_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
SCHEME_EXPAND_OBSERVE_PRIM_STOP(erec[drec].observer);
return form;
}
@ -6803,6 +6917,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int argc, Scheme
Scheme_Object *l, *local_mark, *renaming = NULL, *orig_l;
int cnt, pos, kind;
int bad_sub_env = 0;
Scheme_Object *observer;
env = scheme_current_thread->current_local_env;
@ -6907,6 +7022,9 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int argc, Scheme
orig_l = l;
observer = scheme_get_expand_observe();
SCHEME_EXPAND_OBSERVE_ENTER_LOCAL(observer, l);
if (local_mark) {
/* Since we have an expression from local context,
we need to remove the temporary mark... */
@ -6918,6 +7036,8 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int argc, Scheme
if (renaming)
l = scheme_add_rename(l, renaming);
SCHEME_EXPAND_OBSERVE_LOCAL_PRE(observer, l);
if (SCHEME_FALSEP(argv[2])) {
Scheme_Object *xl, *gval;
Scheme_Compile_Expand_Info drec[1];
@ -6935,6 +7055,8 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int argc, Scheme
l = _expand(l, env, -2, 0, 0, catch_lifts, 0, scheme_current_thread->current_local_certs);
}
SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, l);
if (renaming)
l = scheme_add_rename(l, renaming);
@ -6943,6 +7065,8 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int argc, Scheme
l = scheme_add_remove_mark(l, local_mark);
}
SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, l);
return l;
}
@ -7137,6 +7261,14 @@ local_eval(int argc, Scheme_Object **argv)
stx_env->in_modidx = scheme_current_thread->current_local_modidx;
if (!SCHEME_FALSEP(expr)) {
Scheme_Compile_Expand_Info rec;
rec.comp = 0;
rec.depth = -1;
rec.value_name = scheme_false;
rec.certs = certs;
rec.observer = scheme_get_expand_observe();
/* Evaluate and bind syntaxes */
expr = scheme_add_remove_mark(expr, scheme_current_thread->current_local_mark);
@ -7144,9 +7276,9 @@ local_eval(int argc, Scheme_Object **argv)
pos = 0;
expr = scheme_add_rename_rib(expr, rib);
scheme_bind_syntaxes("local syntax definition", names, expr,
stx_env->genv->exp_env, stx_env->insp, certs,
stx_env->genv->exp_env, stx_env->insp, &rec, 0,
stx_env, stx_env,
&pos, NULL);
&pos);
}
/* Extend shared rib with renamings */

2
src/mzscheme/src/file.c
View File

@ -128,7 +128,7 @@ static int check_dos_slashslash_qm(const char *next, int len, int *drive_end,
int *clean_start, int *add_sep);
#endif
#define is_drive_letter(c) ((c > 0) && (c < 128) && scheme_isalpha(c))
#define is_drive_letter(c) ((c > 0) && (c < 128) && isalpha(c))
/* local */
static Scheme_Object *path_p(int argc, Scheme_Object **argv);

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

@ -29,6 +29,7 @@
overflow and continuation-jump limits. */
#include "schpriv.h"
#include "schexpobs.h"
/* The implementations of the time primitives, such as
`current-seconds', vary a lot from platform to platform. */
@ -2138,13 +2139,16 @@ Scheme_Object *
scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv,
Scheme_Object *rator, Scheme_Object *code,
Scheme_Comp_Env *env, Scheme_Object *boundname,
Scheme_Object *certs, int for_set)
Scheme_Compile_Expand_Info *rec, int drec,
int for_set)
{
Scheme_Object *orig_code = code;
Scheme_Object *certs;
certs = rec[drec].certs;
if (SAME_TYPE(SCHEME_TYPE(rator), scheme_id_macro_type)) {
Scheme_Object *mark;
rator = SCHEME_PTR1_VAL(rator);
/* rator is now an identifier */
@ -2184,12 +2188,16 @@ scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv,
mark = scheme_new_mark();
code = scheme_add_remove_mark(code, mark);
SCHEME_EXPAND_OBSERVE_MACRO_PRE_X(rec[drec].observer, code);
scheme_on_next_top(env, mark, boundname, certs,
menv, menv ? menv->link_midx : env->genv->link_midx);
rands_vec[0] = code;
code = scheme_apply(rator, 1, rands_vec);
SCHEME_EXPAND_OBSERVE_MACRO_POST_X(rec[drec].observer, code);
if (!SCHEME_STXP(code)) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%S: return value from syntax expander was not syntax: %V",

4
src/mzscheme/src/lightning/i386/funcs.h
View File

@ -56,11 +56,11 @@ jit_flush_code(void *dest, void *end)
jit_flush_code as an mprotect. */
#if defined(MZ_JIT_USE_MPROTECT) || defined(MZ_JIT_USE_WINDOWS_VIRTUAL_ALLOC)
static unsigned long prev_page = 0, prev_length = 0;
long page, length;
unsigned long page, length;
# ifdef PAGESIZE
const long page_size = PAGESIZE;
# else
static long page_size = -1;
static unsigned long page_size = -1;
if (page_size == -1) {
# ifdef MZ_JIT_USE_WINDOWS_VIRTUAL_ALLOC
SYSTEM_INFO info;

83
src/mzscheme/src/module.c
View File

@ -25,6 +25,7 @@
#include "schpriv.h"
#include "schmach.h"
#include "schexpobs.h"
/* globals */
Scheme_Object *scheme_sys_wraps0;
@ -78,10 +79,12 @@ static Scheme_Object *module_resolve(Scheme_Object *data, Resolve_Info *info);
static Scheme_Object *top_level_require_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *top_level_require_resolve(Scheme_Object *data, Resolve_Info *info);
static void module_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Scheme_Hash_Table *ht,
static void module_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts);
static void top_level_require_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Scheme_Hash_Table *ht,
static void top_level_require_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts);
@ -3147,7 +3150,8 @@ static Scheme_Object *module_jit(Scheme_Object *data)
return (Scheme_Object *)m;
}
static void module_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Scheme_Hash_Table *ht,
static void module_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts)
{
@ -3471,7 +3475,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
empty_self_modidx = scheme_make_modidx(scheme_false, scheme_false, scheme_false);
empty_self_symbol = scheme_make_symbol("expanded module"); /* uninterned */
}
/* phase shift to replace self_modidx of previous expansion (if any): */
fm = scheme_stx_phase_shift(fm, 0, empty_self_modidx, self_modidx, NULL);
@ -3480,8 +3484,13 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
fm = scheme_add_rename(fm, tt_rn);
if (!check_mb) {
SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
fm = scheme_check_immediate_macro(fm, benv, rec, drec, 0, &mbval, NULL, NULL);
SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
/* If expansion is not the primitive `#%module-begin', add local one: */
if (!SAME_OBJ(mbval, modbeg_syntax)) {
Scheme_Object *mb;
@ -3592,6 +3601,7 @@ module_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *re
static Scheme_Object *
module_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
SCHEME_EXPAND_OBSERVE_PRIM_MODULE(erec[drec].observer);
if (erec[drec].depth > 0)
erec[drec].depth++;
@ -3750,6 +3760,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
int all_simple_renames = 1, et_all_simple_renames = 1, tt_all_simple_renames = 1;
int maybe_has_lifts = 0;
Scheme_Object *redef_modname;
Scheme_Object *observer;
if (!(env->flags & SCHEME_MODULE_FRAME))
scheme_wrong_syntax(NULL, NULL, form, "illegal use (not a module body)");
@ -3906,6 +3917,10 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
maybe_has_lifts = 0;
/* Pass 1 */
observer = rec[drec].observer;
/* Partially expand all expressions, and process definitions, requires,
and provides. Also, flatten top-level `begin' expressions: */
for (fm = SCHEME_STX_CDR(form); !SCHEME_STX_NULLP(fm); ) {
@ -3915,6 +3930,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
while (1) {
Scheme_Object *fst;
SCHEME_EXPAND_OBSERVE_NEXT(observer);
e = SCHEME_STX_CAR(fm);
p = (maybe_has_lifts
@ -3929,6 +3946,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
erec1.depth = -1;
erec1.value_name = scheme_false;
erec1.certs = rec[drec].certs;
erec1.observer = rec[drec].observer;
e = scheme_expand_expr(e, xenv, &erec1, 0);
}
@ -3944,6 +3962,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
fm = scheme_named_map_1(NULL, add_a_rename, fm, post_ex_et_rn);
fm = scheme_named_map_1(NULL, add_a_rename, fm, post_ex_tt_rn);
fm = scheme_append(fst, scheme_make_pair(e, fm));
SCHEME_EXPAND_OBSERVE_LIFT_LOOP(observer, fst);
} else {
/* No lifts added... */
if (SCHEME_STX_PAIRP(e))
@ -3957,9 +3976,11 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
e = scheme_add_rename(e, post_ex_et_rn);
e = scheme_add_rename(e, post_ex_tt_rn);
fm = scheme_flatten_begin(e, fm);
SCHEME_EXPAND_OBSERVE_SPLICE(observer, fm);
if (SCHEME_STX_NULLP(fm)) {
fm = scheme_frame_get_end_statement_lifts(xenv);
fm = scheme_reverse(fm);
SCHEME_EXPAND_OBSERVE_LIFT_END_LOOP(observer, fm);
maybe_has_lifts = 0;
if (SCHEME_NULLP(fm)) {
e = NULL;
@ -3989,6 +4010,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
/************ define-values *************/
Scheme_Object *vars, *val;
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(observer);
/* Create top-level vars */
scheme_define_parse(e, &vars, &val, 0, env);
@ -4033,7 +4057,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
vars = SCHEME_STX_CDR(vars);
}
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
normal = 1;
} else if (scheme_stx_module_eq(scheme_define_syntaxes_stx, fst, 0)
|| scheme_stx_module_eq(define_for_syntaxes_stx, fst, 0)) {
@ -4050,6 +4075,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
for_stx = scheme_stx_module_eq(define_for_syntaxes_stx, fst, 0);
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(observer);
scheme_define_parse(e, &names, &code, 1, env);
if (SCHEME_STX_PAIRP(names) && SCHEME_STX_NULLP(SCHEME_STX_CDR(names)))
@ -4117,6 +4145,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
mrec.resolve_module_ids = 0;
mrec.value_name = NULL;
mrec.certs = rec[drec].certs;
mrec.observer = NULL;
if (!rec[drec].comp) {
Scheme_Expand_Info erec1;
@ -4124,6 +4153,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
erec1.depth = -1;
erec1.value_name = boundname;
erec1.certs = rec[drec].certs;
erec1.observer = rec[drec].observer;
SCHEME_EXPAND_OBSERVE_PHASE_UP(observer);
code = scheme_expand_expr_lift_to_let(code, eenv, &erec1, 0);
}
m = scheme_compile_expr_lift_to_let(code, eenv, &mrec, 0);
@ -4163,10 +4194,15 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
scheme_make_pair(m, scheme_make_pair(code, scheme_null)));
e = scheme_datum_to_syntax(m, e, e, 0, 2);
}
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
normal = 0;
} else if (scheme_stx_module_eq(require_stx, fst, 0)) {
/************ require *************/
Scheme_Object *imods;
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE(observer);
/* Add requires to renaming: */
imods = parse_requires(e, self_modidx, env->genv,
@ -4179,11 +4215,16 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
if (rec[drec].comp)
e = NULL;
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
normal = 0;
} else if (scheme_stx_module_eq(require_for_syntax_stx, fst, 0)) {
/************ require-for-syntax *************/
Scheme_Object *imods;
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE_FOR_SYNTAX(observer);
scheme_prepare_exp_env(env->genv);
/* Add requires to renaming: */
@ -4201,11 +4242,16 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
if (rec[drec].comp)
e = NULL;
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
normal = 0;
} else if (scheme_stx_module_eq(require_for_template_stx, fst, 0)) {
/************ require-for-template *************/
Scheme_Object *imods;
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE_FOR_TEMPLATE(observer);
scheme_prepare_template_env(env->genv);
/* Add requires to renaming: */
@ -4223,6 +4269,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
if (rec[drec].comp)
e = NULL;
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
normal = 0;
} else if (scheme_stx_module_eq(provide_stx, fst, 0)) {
/************ provide *************/
@ -4230,6 +4278,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
Scheme_Object *l;
int protect_cnt = 0;
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
SCHEME_EXPAND_OBSERVE_PRIM_PROVIDE(observer);
if (scheme_stx_proper_list_length(e) < 0)
scheme_wrong_syntax(NULL, e, form, "bad syntax (" IMPROPER_LIST_FORM ")");
@ -4478,9 +4529,12 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
if (rec[drec].comp)
e = NULL;
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
normal = 0;
} else
} else {
normal = 1;
}
} else
normal = 1;
} else
@ -4501,11 +4555,15 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
if (SCHEME_STX_NULLP(fm) && maybe_has_lifts) {
fm = scheme_frame_get_end_statement_lifts(xenv);
fm = scheme_reverse(fm);
SCHEME_EXPAND_OBSERVE_LIFT_END_LOOP(observer, fm);
maybe_has_lifts = 0;
}
}
/* first = a list of (cons semi-expanded-expression normal?) */
/* Phase 2 */
SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer);
if (rec[drec].comp) {
/* Module manages its own prefix. That's how we get
multiple instantiation of a module with "dynamic linking". */
@ -4528,6 +4586,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
e = SCHEME_CAR(p);
normal = SCHEME_TRUEP(SCHEME_CDR(e));
e = SCHEME_CAR(e);
SCHEME_EXPAND_OBSERVE_NEXT(observer);
if (normal) {
l = (maybe_has_lifts
? scheme_frame_get_end_statement_lifts(cenv)
@ -4567,6 +4628,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
} else {
first = p;
}
SCHEME_EXPAND_OBSERVE_LIFT_LOOP(observer, first);
}
} else {
SCHEME_CAR(p) = e;
@ -4577,6 +4639,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
/* If we're out of declarations, check for lifted-to-end: */
if (SCHEME_NULLP(p) && maybe_has_lifts) {
p = scheme_frame_get_end_statement_lifts(cenv);
SCHEME_EXPAND_OBSERVE_LIFT_END_LOOP(observer, scheme_reverse(p));
p = scheme_reverse(p);
for (ll = p; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) {
e = scheme_make_pair(SCHEME_CAR(ll), scheme_true);
@ -5117,6 +5180,7 @@ module_begin_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_In
static Scheme_Object *
module_begin_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
SCHEME_EXPAND_OBSERVE_PRIM_MODULE_BEGIN(erec[drec].observer);
return do_module_begin(form, env, erec, drec);
}
@ -5800,7 +5864,8 @@ top_level_require_jit(Scheme_Object *data)
return data;
}
static void top_level_require_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Scheme_Hash_Table *ht,
static void top_level_require_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts)
{
@ -5882,6 +5947,7 @@ require_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *r
static Scheme_Object *
require_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE(erec[drec].observer);
return do_require(form, env, erec, drec, 0);
}
@ -5894,6 +5960,7 @@ require_for_syntax_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Comp
static Scheme_Object *
require_for_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE_FOR_SYNTAX(erec[drec].observer);
return do_require(form, env, erec, drec, 1);
}
@ -5906,6 +5973,7 @@ require_for_template_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Co
static Scheme_Object *
require_for_template_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE_FOR_TEMPLATE(erec[drec].observer);
return do_require(form, env, erec, drec, -1);
}
@ -5923,6 +5991,7 @@ provide_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *r
static Scheme_Object *
provide_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
SCHEME_EXPAND_OBSERVE_PRIM_PROVIDE(erec[drec].observer);
scheme_wrong_syntax(NULL, NULL, form, "not in module body");
return NULL;
}

1
src/mzscheme/src/mzmarksrc.c
View File

@ -998,6 +998,7 @@ mark_comp_info {
gcMARK(i->value_name);
gcMARK(i->certs);
gcMARK(i->observer);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Compile_Info));

2
src/mzscheme/src/network.c
View File

@ -1473,7 +1473,7 @@ static long tcp_write_string(Scheme_Output_Port *port,
if (data->b.out_bufmode < 2) {
if (data->b.out_bufmax + len < TCP_BUFFER_SIZE) {
memcpy(data->b.out_buffer + data->b.out_bufmax, s + offset, len);
data->b.out_bufmax += len;
data->b.out_bufmax += (short)len;
if (data->b.out_bufmode == 1) {
/* Check for newline */
int i;

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

@ -3244,7 +3244,7 @@ static int u_strcmp(mzchar *s, const char *_t)
int i;
unsigned char *t = (unsigned char *)_t;
for (i = 0; s[i] && (scheme_tolower(s[i]) == scheme_tolower(((unsigned char *)t)[i])); i++) {
for (i = 0; s[i] && (scheme_tolower(s[i]) == scheme_tolower((mzchar)((unsigned char *)t)[i])); i++) {
}
if (s[i] || t[i])
return 1;
@ -5014,7 +5014,7 @@ static Scheme_Object *make_readtable(int argc, Scheme_Object **argv)
} else {
scheme_hash_set(t->mapping, scheme_make_integer(ch), val);
if (ch < 128)
t->fast_mapping[ch] = SCHEME_INT_VAL(SCHEME_CAR(val));
t->fast_mapping[ch] = (char)SCHEME_INT_VAL(SCHEME_CAR(val));
}
}
}

136
src/mzscheme/src/schexpobs.h Normal file
View File

@ -0,0 +1,136 @@
#ifndef __mzscheme_expobs__
#define __mzscheme_expobs__
#define SCHEME_EXPAND_OBSERVE_ENABLE
extern void scheme_call_expand_observe(Scheme_Object *obs, int signal, Scheme_Object *argument);
extern Scheme_Object *scheme_expand_observe_renames(Scheme_Object *env_pair);
extern void scheme_init_expand_observe(Scheme_Env *);
extern Scheme_Object *scheme_get_expand_observe();
#ifdef SCHEME_EXPAND_OBSERVE_ENABLE
# define _SCHEME_EXPOBS(observer, signal, argument) \
if (observer) { scheme_call_expand_observe(observer, signal, argument); } else {}
#endif
#ifndef SCHEME_EXPAND_OBSERVE_ENABLE
#define _SCHEME_EXPOBS(observer, signal, argument) \
((void)0)
#endif
/* Individual signals */
#define SCHEME_EXPAND_OBSERVE_VISIT(observer,stx) _SCHEME_EXPOBS(observer,0,stx)
#define SCHEME_EXPAND_OBSERVE_RESOLVE(observer,stx) _SCHEME_EXPOBS(observer,1,stx)
#define SCHEME_EXPAND_OBSERVE_RETURN(observer,stx) _SCHEME_EXPOBS(observer,2,stx)
#define SCHEME_EXPAND_OBSERVE_NEXT(observer) _SCHEME_EXPOBS(observer,3,NULL)
#define SCHEME_EXPAND_OBSERVE_ENTER_LIST(observer,stx) _SCHEME_EXPOBS(observer,4,stx)
#define SCHEME_EXPAND_OBSERVE_EXIT_LIST(observer,stx) _SCHEME_EXPOBS(observer,5,stx)
#define SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer,stx) _SCHEME_EXPOBS(observer,6,stx)
#define SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer,stx) _SCHEME_EXPOBS(observer,7,stx)
#define SCHEME_EXPAND_OBSERVE_ENTER_MACRO(observer,stx) _SCHEME_EXPOBS(observer,8,stx)
#define SCHEME_EXPAND_OBSERVE_EXIT_MACRO(observer,stx) _SCHEME_EXPOBS(observer,9,stx)
#define SCHEME_EXPAND_OBSERVE_ENTER_BLOCK(observer,stx) _SCHEME_EXPOBS(observer,10,stx)
#define SCHEME_EXPAND_OBSERVE_SPLICE(observer,stx) _SCHEME_EXPOBS(observer,11,stx)
#define SCHEME_EXPAND_OBSERVE_BLOCK_TO_LIST(observer,stx) _SCHEME_EXPOBS(observer,12,stx)
#define SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer) _SCHEME_EXPOBS(observer,13,NULL)
#define SCHEME_EXPAND_OBSERVE_BLOCK_TO_LETREC(observer,stx) _SCHEME_EXPOBS(observer,14,stx)
#define SCHEME_EXPAND_OBSERVE_LET_RENAMES(observer,vars,body) \
_SCHEME_EXPOBS(observer,16, scheme_make_immutable_pair(vars, body))
#define SCHEME_EXPAND_OBSERVE_LAMBDA_RENAMES(observer,vars,body) \
_SCHEME_EXPOBS(observer,17, scheme_make_immutable_pair(vars, body))
#define SCHEME_EXPAND_OBSERVE_CASE_LAMBDA_RENAMES(observer,vars,body) \
_SCHEME_EXPOBS(observer,18, scheme_make_immutable_pair(vars, body))
#define SCHEME_EXPAND_OBSERVE_LETREC_SYNTAXES_RENAMES(observer,sbinds,vbinds,body) \
_SCHEME_EXPOBS(observer,19, scheme_make_immutable_pair(sbinds, scheme_make_immutable_pair(vbinds, body)))
#define SCHEME_EXPAND_OBSERVE_PHASE_UP(observer) _SCHEME_EXPOBS(observer,20,NULL)
#define SCHEME_EXPAND_OBSERVE_MACRO_PRE_X(observer,stx) _SCHEME_EXPOBS(observer,21,stx)
#define SCHEME_EXPAND_OBSERVE_MACRO_POST_X(observer,stx) _SCHEME_EXPOBS(observer,22,stx)
#define SCHEME_EXPAND_OBSERVE_MODULE_BODY(observer,list) _SCHEME_EXPOBS(observer,23,list)
#define SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(observer,old,new) \
_SCHEME_EXPOBS(observer,24, scheme_make_immutable_pair(old, new))
/* Prim signals */
#define SCHEME_EXPAND_OBSERVE_PRIM_STOP(observer) \
_SCHEME_EXPOBS(observer,100,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_MODULE(observer) \
_SCHEME_EXPOBS(observer,101,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_MODULE_BEGIN(observer) \
_SCHEME_EXPOBS(observer,102,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(observer) \
_SCHEME_EXPOBS(observer,103,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(observer) \
_SCHEME_EXPOBS(observer,104,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_IF(observer) \
_SCHEME_EXPOBS(observer,105,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_WCM(observer) \
_SCHEME_EXPOBS(observer,106,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(observer) \
_SCHEME_EXPOBS(observer,107,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_BEGIN0(observer) \
_SCHEME_EXPOBS(observer,108,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_APP(observer) \
_SCHEME_EXPOBS(observer,109,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_LAMBDA(observer) \
_SCHEME_EXPOBS(observer,110,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_CASE_LAMBDA(observer) \
_SCHEME_EXPOBS(observer,111,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_LET_VALUES(observer) \
_SCHEME_EXPOBS(observer,112,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(observer) \
_SCHEME_EXPOBS(observer,113,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_LETREC_SYNTAXES_VALUES(observer) \
_SCHEME_EXPOBS(observer,114,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_DATUM(observer) \
_SCHEME_EXPOBS(observer,115,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_TOP(observer) \
_SCHEME_EXPOBS(observer,116,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_QUOTE(observer) \
_SCHEME_EXPOBS(observer,117,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_QUOTE_SYNTAX(observer) \
_SCHEME_EXPOBS(observer,118,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE(observer) \
_SCHEME_EXPOBS(observer,119,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE_FOR_SYNTAX(observer) \
_SCHEME_EXPOBS(observer,120,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE_FOR_TEMPLATE(observer) \
_SCHEME_EXPOBS(observer,121,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_PROVIDE(observer) \
_SCHEME_EXPOBS(observer,122,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_SET(observer) \
_SCHEME_EXPOBS(observer,123,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_LETSTAR_VALUES(observer) \
_SCHEME_EXPOBS(observer,124,NULL)
#define SCHEME_EXPAND_OBSERVE_VARIABLE(observer,e1,e2) \
_SCHEME_EXPOBS(observer,125,scheme_make_pair(e1, e2))
#define SCHEME_EXPAND_OBSERVE_ENTER_CHECK(observer,stx) \
_SCHEME_EXPOBS(observer,126,stx)
#define SCHEME_EXPAND_OBSERVE_EXIT_CHECK(observer,stx) \
_SCHEME_EXPOBS(observer,127,stx)
#define SCHEME_EXPAND_OBSERVE_LIFT_LOOP(observer,stx) \
_SCHEME_EXPOBS(observer,128,stx)
#define SCHEME_EXPAND_OBSERVE_LIFT_END_LOOP(observer,stx) \
_SCHEME_EXPOBS(observer,135,stx)
#define SCHEME_EXPAND_OBSERVE_LOCAL_LIFT(obs,id,stx) \
_SCHEME_EXPOBS(obs,129,scheme_make_pair(id,stx))
#define SCHEME_EXPAND_OBSERVE_LIFT_STATEMENT(obs,stx) \
_SCHEME_EXPOBS(obs,134,stx)
#define SCHEME_EXPAND_OBSERVE_ENTER_LOCAL(obs,stx) \
_SCHEME_EXPOBS(obs,130,stx)
#define SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(obs,stx) \
_SCHEME_EXPOBS(obs,131,stx)
#define SCHEME_EXPAND_OBSERVE_LOCAL_PRE(obs,stx) \
_SCHEME_EXPOBS(obs,132,stx)
#define SCHEME_EXPAND_OBSERVE_LOCAL_POST(obs,stx) \
_SCHEME_EXPOBS(obs,133,stx)
#endif

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

@ -1514,6 +1514,7 @@ typedef struct Scheme_Compile_Expand_Info
int comp;
Scheme_Object *value_name;
Scheme_Object *certs;
Scheme_Object *observer;
char dont_mark_local_use;
char resolve_module_ids;
int depth;
@ -1687,7 +1688,8 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
Scheme_Object *scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv,
Scheme_Object *f, Scheme_Object *code,
Scheme_Comp_Env *env, Scheme_Object *boundname,
Scheme_Object *certs, int for_set);
Scheme_Compile_Expand_Info *rec, int drec,
int for_set);
Scheme_Comp_Env *scheme_new_compilation_frame(int num_bindings, int flags,
Scheme_Comp_Env *env, Scheme_Object *certs);
@ -1735,10 +1737,11 @@ Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Com
Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec);
Scheme_Object *scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a,
Scheme_Env *exp_env, Scheme_Object *insp, Scheme_Object *certs,
Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env,
int *_pos, Scheme_Object *names_to_disappear);
void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a,
Scheme_Env *exp_env, Scheme_Object *insp,
Scheme_Compile_Expand_Info *rec, int drec,
Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env,
int *_pos);
int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env);
/* Resolving & linking */

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

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 352
#define MZSCHEME_VERSION_MINOR 1
#define MZSCHEME_VERSION_MINOR 2
#define MZSCHEME_VERSION "352.1" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "352.2" _MZ_SPECIAL_TAG

191
src/mzscheme/src/startup.inc
View File

@ -35,10 +35,12 @@
"(if(syntax? p) "
"(if(list?(syntax-e p))"
" #t"
"(let loop((l(syntax-e p)))"
"(letrec-values(((loop)"
"(lambda(l)"
"(if(pair? l)"
"(loop(cdr l))"
"(stx-list? l))))"
"(stx-list? l)))))"
"(loop(syntax-e p))))"
"(if(pair? p)"
"(stx-list?(cdr p))"
" #f)))))"
@ -56,8 +58,9 @@
"(lambda(e)"
"(if(syntax? e)"
"(syntax->list e)"
"(let((flat-end"
"(let loop((l e))"
"(let-values(((flat-end)"
"(letrec-values(((loop)"
"(lambda(l)"
"(if(null? l) "
" #f"
"(if(pair? l)"
@ -65,14 +68,17 @@
"(if(syntax? l) "
"(syntax->list l)"
" #f))))))"
"(loop e))))"
"(if flat-end"
"(let loop((l e))"
"(letrec-values(((loop)"
"(lambda(l)"
"(if(null? l) "
" null"
"(if(pair? l) "
"(cons(car l)(loop(cdr l)))"
"(if(syntax? l) "
" flat-end))))"
" flat-end))))))"
"(loop e))"
" e)))))"
"(define-values(stx-vector?)"
"(lambda(p len)"
@ -114,7 +120,8 @@
"(define-values(split-stx-list)"
"(lambda(s n prop?)"
"(let-values(((pre post m)"
"(let loop((s s))"
"(letrec-values(((loop)"
"(lambda(s)"
"(if(stx-pair? s)"
"(let-values(((pre post m)(loop(stx-cdr s))))"
"(if(< m n)"
@ -127,6 +134,7 @@
"(if(stx-null? s)"
" -inf.0"
" 1)))))))"
"(loop s))))"
"(values pre post(= m n)))))"
"(provide identifier? stx-null? stx-null/#f stx-pair? stx-list?"
" stx-car stx-cdr stx->list"
@ -138,15 +146,153 @@
EVAL_ONE_STR(
"(module #%qq-and-or #%kernel"
"(require-for-syntax #%stx #%kernel)"
"(define-syntaxes(let let* letrec)"
"(let-values(((lambda-stx)(quote-syntax lambda-stx))"
"((letrec-values-stx)(quote-syntax letrec-values)))"
"(let-values(((go)"
"(lambda(stx named? star? target)"
"(define-values(stx-cadr)(lambda(x)(stx-car(stx-cdr x))))"
"(define-values(id-in-list?)"
"(lambda(id l)"
"(if(null? l)"
" #f"
"(if(bound-identifier=? id(car l)) "
" #t"
"(id-in-list? id(cdr l))))))"
"(define-values(stx-2list?)"
"(lambda(x)"
"(if(stx-pair? x)"
"(if(stx-pair?(stx-cdr x))"
"(stx-null?(stx-cdr(stx-cdr x)))"
" #f)"
" #f)))"
"(if(if(not(stx-list? stx))"
" #t"
"(let-values(((tail1)(stx-cdr stx)))"
"(if(stx-null? tail1)"
" #t"
"(if(stx-null?(stx-cdr tail1))"
" #t"
"(if named?"
"(if(symbol?(syntax-e(stx-car tail1)))"
"(stx-null?(stx-cdr(stx-cdr tail1)))"
" #f)"
" #f)))))"
" (raise-syntax-error #f \"bad syntax\" stx))"
"(let-values(((name)(if named?"
"(let-values(((n)(stx-cadr stx)))"
"(if(symbol?(syntax-e n))"
" n"
" #f))"
" #f)))"
"(let-values(((bindings)(stx->list(stx-cadr(if name"
"(stx-cdr stx)"
" stx))))"
"((body)(stx-cdr(stx-cdr(if name"
"(stx-cdr stx)"
" stx)))))"
"(if(not bindings)"
"(raise-syntax-error "
" #f "
" \"bad syntax (not a sequence of identifier--expression bindings)\" "
" stx"
"(stx-cadr stx))"
"(let-values(((new-bindings)"
"(letrec-values(((loop)"
"(lambda(l)"
"(if(null? l)"
" null"
"(let-values(((binding)(car l)))"
"(cons-immutable"
"(if(stx-2list? binding)"
"(if(symbol?(syntax-e(stx-car binding)))"
"(if name"
"(cons(stx-car binding)"
"(stx-cadr binding))"
"(datum->syntax-object"
" lambda-stx"
"(cons-immutable(cons-immutable(stx-car binding)"
" null)"
"(stx-cdr binding))"
" binding))"
"(raise-syntax-error "
" #f "
" \"bad syntax (not an identifier)\" "
" stx"
"(stx-car binding)))"
"(raise-syntax-error "
" #f "
" \"bad syntax (not an identifier and expression for a binding)\" "
" stx"
" binding))"
"(loop(cdr l))))))))"
"(loop bindings))))"
"(if star?"
"(void)"
"(if((length new-bindings) . > . 5)"
"(let-values(((ht)(make-hash-table)))"
"(letrec-values(((check)(lambda(l)"
"(if(null? l)"
"(void)"
"(let*-values(((id)(if name"
"(caar l)"
"(stx-car(stx-car(car l)))))"
"((idl)(hash-table-get ht(syntax-e id) null)))"
"(if(id-in-list? id idl)"
"(raise-syntax-error"
" #f"
" \"duplicate identifier\""
" stx"
" id)"
"(begin"
"(hash-table-put! ht(syntax-e id)(cons id idl))"
"(check(cdr l)))))))))"
"(check new-bindings)))"
"(letrec-values(((check)(lambda(l accum)"
"(if(null? l)"
"(void)"
"(let-values(((id)(if name"
"(caar l)"
"(stx-car(stx-car(car l))))))"
"(if(id-in-list? id accum)"
"(raise-syntax-error"
" #f"
" \"duplicate identifier\""
" stx"
" id)"
"(check(cdr l)(cons id accum))))))))"
"(check new-bindings null))))"
"(datum->syntax-object"
" lambda-stx"
"(if name"
"(apply list-immutable"
"(list-immutable "
"(quote-syntax letrec-values)"
"(list-immutable"
"(list-immutable"
"(list-immutable name)"
"(list*-immutable(quote-syntax lambda)"
"(apply list-immutable(map car new-bindings))"
" body)))"
" name)"
"(map cdr new-bindings))"
"(list*-immutable target"
" new-bindings"
" body))"
" stx))))))))"
"(values"
"(lambda(stx)(go stx #t #f(quote-syntax let-values)))"
"(lambda(stx)(go stx #f #t(quote-syntax let*-values)))"
"(lambda(stx)(go stx #f #f(quote-syntax letrec-values)))))))"
"(define-values(qq-append)"
"(lambda(a b)"
"(if(list? a)"
"(append a b)"
" (raise-type-error 'unquote-splicing \"proper list\" a))))"
"(define-syntaxes(quasiquote)"
"(let((here(quote-syntax here)) "
"(unquote-stx(quote-syntax unquote))"
"(unquote-splicing-stx(quote-syntax unquote-splicing)))"
"(let-values(((here)(quote-syntax here)) "
"((unquote-stx)(quote-syntax unquote))"
"((unquote-splicing-stx)(quote-syntax unquote-splicing)))"
"(lambda(in-form)"
"(if(identifier? in-form)"
" (raise-syntax-error #f \"bad syntax\" in-form))"
@ -308,11 +454,11 @@
" form)"
" in-form)))))"
"(define-syntaxes(and)"
"(let((here(quote-syntax here)))"
"(let-values(((here)(quote-syntax here)))"
"(lambda(x)"
"(if(not(stx-list? x))"
" (raise-syntax-error #f \"bad syntax\" x))"
"(let((e(stx-cdr x)))"
"(let-values(((e)(stx-cdr x)))"
"(if(stx-null? e)"
"(quote-syntax #t)"
"(if(if(stx-pair? e)"
@ -328,11 +474,11 @@
"(quote-syntax #f))"
" x)))))))"
"(define-syntaxes(or)"
"(let((here(quote-syntax here)))"
"(let-values(((here)(quote-syntax here)))"
"(lambda(x)"
"(if(identifier? x)"
" (raise-syntax-error #f \"bad syntax\" x))"
"(let((e(stx-cdr x)))"
"(let-values(((e)(stx-cdr x)))"
"(if(stx-null? e) "
"(quote-syntax #f)"
"(if(if(stx-pair? e)"
@ -340,7 +486,7 @@
" #f)"
"(stx-car e)"
"(if(stx-list? e)"
"(let((tmp 'or-part))"
"(let-values(((tmp) 'or-part))"
"(datum->syntax-object"
" here"
"(list(quote-syntax let)(list"
@ -357,7 +503,8 @@
" #f"
" \"bad syntax\""
" x))))))))"
"(provide quasiquote and or))"
"(provide let let* letrec"
" quasiquote and or))"
);
EVAL_ONE_STR(
"(module #%cond #%kernel"
@ -401,7 +548,7 @@
" #t "
" test))"
"(gen(gensym)))"
" `(,(quote-syntax let)((,gen ,test))"
" `(,(quote-syntax let-values)(((,gen) ,test))"
"(,(quote-syntax if) ,gen"
"(,(stx-car(stx-cdr value)) ,gen)"
" ,(loop rest #f))))"
@ -414,7 +561,7 @@
"(cons(quote-syntax begin) value))"
"(if(stx-null? value)"
"(let((gen(gensym)))"
" `(,(quote-syntax let)((,gen ,test))"
" `(,(quote-syntax let-values)(((,gen) ,test))"
"(,(quote-syntax if) ,gen ,gen ,(loop rest #f))))"
"(list"
"(quote-syntax if) test"
@ -696,7 +843,7 @@
" ,defined-names"
" ,(let((core(make-core name(and inspector 'inspector) super-id/struct: field-names)))"
"(if inspector"
" `(let((inspector ,inspector))"
" `(let-values(((inspector) ,inspector))"
"(if(if inspector(not(inspector? inspector)) #f)"
" (raise-type-error 'define-struct \"inspector or #f\" inspector))"
" ,core)"
@ -715,7 +862,7 @@
"(require #%stx #%qq-and-or #%cond #%define-et-al)"
"(provide(all-from #%qq-and-or)"
"(all-from #%cond)"
"(all-from-except #%define-et-al)))"
"(all-from #%define-et-al)))"
);
EVAL_ONE_STR(
"(module #%sc #%kernel"
@ -1680,7 +1827,7 @@
);
EVAL_ONE_STR(
"(module #%stxloc #%kernel"
"(require #%stxcase #%define-et-al)"
"(require #%qq-and-or #%stxcase #%define-et-al)"
"(require-for-syntax #%kernel #%stxcase #%sc)"
"(-define-syntax syntax-case*"
"(lambda(stx)"
@ -1695,7 +1842,7 @@
"(-define loc-insp(current-code-inspector))"
"(-define(relocate loc stx)"
"(if(syntax-source loc)"
"(let((new-stx(datum->syntax-object"
"(let-values(((new-stx)(datum->syntax-object"
" stx"
"(syntax-e stx)"
" loc)))"

262
src/mzscheme/src/startup.ss
View File

@ -82,10 +82,12 @@
(if (syntax? p)
(if (list? (syntax-e p))
#t
(let loop ([l (syntax-e p)])
(if (pair? l)
(loop (cdr l))
(stx-list? l))))
(letrec-values ([(loop)
(lambda (l)
(if (pair? l)
(loop (cdr l))
(stx-list? l)))])
(loop (syntax-e p))))
(if (pair? p)
(stx-list? (cdr p))
#f)))))
@ -109,24 +111,28 @@
(lambda (e)
(if (syntax? e)
(syntax->list e)
(let ([flat-end
(let loop ([l e])
(if (null? l)
#f
(if (pair? l)
(loop (cdr l))
(if (syntax? l)
(syntax->list l)
#f))))])
(let-values ([(flat-end)
(letrec-values ([(loop)
(lambda (l)
(if (null? l)
#f
(if (pair? l)
(loop (cdr l))
(if (syntax? l)
(syntax->list l)
#f))))])
(loop e))])
(if flat-end
;; flatten
(let loop ([l e])
(if (null? l)
null
(if (pair? l)
(cons (car l) (loop (cdr l)))
(if (syntax? l)
flat-end))))
(letrec-values ([(loop)
(lambda (l)
(if (null? l)
null
(if (pair? l)
(cons (car l) (loop (cdr l)))
(if (syntax? l)
flat-end))))])
(loop e))
e)))))
;; a syntax vector?
@ -190,19 +196,21 @@
(define-values (split-stx-list)
(lambda (s n prop?)
(let-values ([(pre post m)
(let loop ([s s])
(if (stx-pair? s)
(let-values ([(pre post m) (loop (stx-cdr s))])
(if (< m n)
(values '() s (add1 m))
(values (cons (stx-car s) pre) post m)))
(values '() s (if prop?
(if (stx-null? s)
0
-inf.0)
(if (stx-null? s)
-inf.0
1)))))])
(letrec-values ([(loop)
(lambda (s)
(if (stx-pair? s)
(let-values ([(pre post m) (loop (stx-cdr s))])
(if (< m n)
(values '() s (add1 m))
(values (cons (stx-car s) pre) post m)))
(values '() s (if prop?
(if (stx-null? s)
0
-inf.0)
(if (stx-null? s)
-inf.0
1)))))])
(loop s))])
(values pre post (= m n)))))
(provide identifier? stx-null? stx-null/#f stx-pair? stx-list?
@ -217,6 +225,145 @@
(module #%qq-and-or #%kernel
(require-for-syntax #%stx #%kernel)
(define-syntaxes (let let* letrec)
(let-values ([(lambda-stx) (quote-syntax lambda-stx)]
[(letrec-values-stx) (quote-syntax letrec-values)])
(let-values ([(go)
(lambda (stx named? star? target)
(define-values (stx-cadr) (lambda (x) (stx-car (stx-cdr x))))
(define-values (id-in-list?)
(lambda (id l)
(if (null? l)
#f
(if (bound-identifier=? id (car l))
#t
(id-in-list? id (cdr l))))))
(define-values (stx-2list?)
(lambda (x)
(if (stx-pair? x)
(if (stx-pair? (stx-cdr x))
(stx-null? (stx-cdr (stx-cdr x)))
#f)
#f)))
(if (if (not (stx-list? stx))
#t
(let-values ([(tail1) (stx-cdr stx)])
(if (stx-null? tail1)
#t
(if (stx-null? (stx-cdr tail1))
#t
(if named?
(if (symbol? (syntax-e (stx-car tail1)))
(stx-null? (stx-cdr (stx-cdr tail1)))
#f)
#f)))))
(raise-syntax-error #f "bad syntax" stx))
(let-values ([(name) (if named?
(let-values ([(n) (stx-cadr stx)])
(if (symbol? (syntax-e n))
n
#f))
#f)])
(let-values ([(bindings) (stx->list (stx-cadr (if name
(stx-cdr stx)
stx)))]
[(body) (stx-cdr (stx-cdr (if name
(stx-cdr stx)
stx)))])
(if (not bindings)
(raise-syntax-error
#f
"bad syntax (not a sequence of identifier--expression bindings)"
stx
(stx-cadr stx))
(let-values ([(new-bindings)
(letrec-values ([(loop)
(lambda (l)
(if (null? l)
null
(let-values ([(binding) (car l)])
(cons-immutable
(if (stx-2list? binding)
(if (symbol? (syntax-e (stx-car binding)))
(if name
(cons (stx-car binding)
(stx-cadr binding))
(datum->syntax-object
lambda-stx
(cons-immutable (cons-immutable (stx-car binding)
null)
(stx-cdr binding))
binding))
(raise-syntax-error
#f
"bad syntax (not an identifier)"
stx
(stx-car binding)))
(raise-syntax-error
#f
"bad syntax (not an identifier and expression for a binding)"
stx
binding))
(loop (cdr l))))))])
(loop bindings))])
(if star?
(void)
(if ((length new-bindings) . > . 5)
(let-values ([(ht) (make-hash-table)])
(letrec-values ([(check) (lambda (l)
(if (null? l)
(void)
(let*-values ([(id) (if name
(caar l)
(stx-car (stx-car (car l))))]
[(idl) (hash-table-get ht (syntax-e id) null)])
(if (id-in-list? id idl)
(raise-syntax-error
#f
"duplicate identifier"
stx
id)
(begin
(hash-table-put! ht (syntax-e id) (cons id idl))
(check (cdr l)))))))])
(check new-bindings)))
(letrec-values ([(check) (lambda (l accum)
(if (null? l)
(void)
(let-values ([(id) (if name
(caar l)
(stx-car (stx-car (car l))))])
(if (id-in-list? id accum)
(raise-syntax-error
#f
"duplicate identifier"
stx
id)
(check (cdr l) (cons id accum))))))])
(check new-bindings null))))
(datum->syntax-object
lambda-stx
(if name
(apply list-immutable
(list-immutable
(quote-syntax letrec-values)
(list-immutable
(list-immutable
(list-immutable name)
(list*-immutable (quote-syntax lambda)
(apply list-immutable (map car new-bindings))
body)))
name)
(map cdr new-bindings))
(list*-immutable target
new-bindings
body))
stx))))))])
(values
(lambda (stx) (go stx #t #f (quote-syntax let-values)))
(lambda (stx) (go stx #f #t (quote-syntax let*-values)))
(lambda (stx) (go stx #f #f (quote-syntax letrec-values)))))))
(define-values (qq-append)
(lambda (a b)
@ -225,9 +372,9 @@
(raise-type-error 'unquote-splicing "proper list" a))))
(define-syntaxes (quasiquote)
(let ([here (quote-syntax here)] ; id with module bindings, but not lexical
[unquote-stx (quote-syntax unquote)]
[unquote-splicing-stx (quote-syntax unquote-splicing)])
(let-values ([(here) (quote-syntax here)] ; id with module bindings, but not lexical
[(unquote-stx) (quote-syntax unquote)]
[(unquote-splicing-stx) (quote-syntax unquote-splicing)])
(lambda (in-form)
(if (identifier? in-form)
(raise-syntax-error #f "bad syntax" in-form))
@ -390,11 +537,11 @@
in-form)))))
(define-syntaxes (and)
(let ([here (quote-syntax here)])
(let-values ([(here) (quote-syntax here)])
(lambda (x)
(if (not (stx-list? x))
(raise-syntax-error #f "bad syntax" x))
(let ([e (stx-cdr x)])
(let-values ([(e) (stx-cdr x)])
(if (stx-null? e)
(quote-syntax #t)
(if (if (stx-pair? e)
@ -411,11 +558,11 @@
x)))))))
(define-syntaxes (or)
(let ([here (quote-syntax here)])
(let-values ([(here) (quote-syntax here)])
(lambda (x)
(if (identifier? x)
(raise-syntax-error #f "bad syntax" x))
(let ([e (stx-cdr x)])
(let-values ([(e) (stx-cdr x)])
(if (stx-null? e)
(quote-syntax #f)
(if (if (stx-pair? e)
@ -423,7 +570,7 @@
#f)
(stx-car e)
(if (stx-list? e)
(let ([tmp 'or-part])
(let-values ([(tmp) 'or-part])
(datum->syntax-object
here
(list (quote-syntax let) (list
@ -441,7 +588,8 @@
"bad syntax"
x))))))))
(provide quasiquote and or))
(provide let let* letrec
quasiquote and or))
;;----------------------------------------------------------------------
;; cond
@ -474,9 +622,9 @@
"bad syntax (clause is not a test-value pair)"
line)
(let* ([test (stx-car line)]
[value (stx-cdr line)]
[else? (and (identifier? test)
(module-identifier=? test (quote-syntax else)))])
[value (stx-cdr line)]
[else? (and (identifier? test)
(module-identifier=? test (quote-syntax else)))])
(if (and else? (stx-pair? rest))
(serror "bad syntax (`else' clause must be last)" line))
(if (and (stx-pair? value)
@ -485,10 +633,10 @@
(if (and (stx-pair? (stx-cdr value))
(stx-null? (stx-cdr (stx-cdr value))))
(let ([test (if else?
#t
test)]
[gen (gensym)])
`(,(quote-syntax let) ([,gen ,test])
#t
test)]
[gen (gensym)])
`(,(quote-syntax let-values) ([(,gen) ,test])
(,(quote-syntax if) ,gen
(,(stx-car (stx-cdr value)) ,gen)
,(loop rest #f))))
@ -503,7 +651,7 @@
(cons (quote-syntax begin) value))
(if (stx-null? value)
(let ([gen (gensym)])
`(,(quote-syntax let) ([,gen ,test])
`(,(quote-syntax let-values) ([(,gen) ,test])
(,(quote-syntax if) ,gen ,gen ,(loop rest #f))))
(list
(quote-syntax if) test
@ -816,7 +964,7 @@
,defined-names
,(let ([core (make-core name (and inspector 'inspector) super-id/struct: field-names)])
(if inspector
`(let ([inspector ,inspector])
`(let-values ([(inspector) ,inspector])
(if (if inspector (not (inspector? inspector)) #f)
(raise-type-error 'define-struct "inspector or #f" inspector))
,core)
@ -839,7 +987,7 @@
(provide (all-from #%qq-and-or)
(all-from #%cond)
(all-from-except #%define-et-al)))
(all-from #%define-et-al)))
;;----------------------------------------------------------------------
;; pattern-matching utilities
@ -1979,7 +2127,7 @@
;; syntax/loc
(module #%stxloc #%kernel
(require #%stxcase #%define-et-al)
(require #%qq-and-or #%stxcase #%define-et-al)
(require-for-syntax #%kernel #%stxcase #%sc)
;; Regular syntax-case
@ -1999,10 +2147,10 @@
(-define loc-insp (current-code-inspector))
(-define (relocate loc stx)
(if (syntax-source loc)
(let ([new-stx (datum->syntax-object
stx
(syntax-e stx)
loc)])
(let-values ([(new-stx) (datum->syntax-object
stx
(syntax-e stx)
loc)])
(syntax-recertify new-stx stx loc-insp #f))
stx))

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

@ -30,6 +30,7 @@
#include "schpriv.h"
#include "schmach.h"
#include "schexpobs.h"
/* globals */
Scheme_Object *scheme_define_values_syntax, *scheme_define_syntaxes_syntax;
@ -63,12 +64,6 @@ static Scheme_Object *set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Sche
static Scheme_Object *set_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
static Scheme_Object *case_lambda_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
static Scheme_Object *case_lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
static Scheme_Object *let_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
static Scheme_Object *let_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
static Scheme_Object *let_star_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
static Scheme_Object *let_star_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
static Scheme_Object *letrec_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
static Scheme_Object *letrec_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
static Scheme_Object *let_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
static Scheme_Object *let_values_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
static Scheme_Object *let_star_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
@ -176,9 +171,6 @@ static Scheme_Object *case_lambda_jit(Scheme_Object *expr);
static Scheme_Object *begin0_jit(Scheme_Object *data);
static Scheme_Object *bangboxvalue_jit(Scheme_Object *data);
static Scheme_Object *named_let_syntax (Scheme_Object *form, Scheme_Comp_Env *env,
Scheme_Compile_Expand_Info *rec, int drec);
static Scheme_Object *expand_lam(int argc, Scheme_Object **argv);
static Scheme_Object *write_let_value(Scheme_Object *obj);
@ -196,9 +188,6 @@ static Scheme_Object *read_case_lambda(Scheme_Object *obj);
/* symbols */
static Scheme_Object *lambda_symbol;
static Scheme_Object *letrec_symbol;
static Scheme_Object *let_star_symbol;
static Scheme_Object *let_symbol;
static Scheme_Object *letrec_values_symbol;
static Scheme_Object *let_star_values_symbol;
static Scheme_Object *let_values_symbol;
@ -234,9 +223,6 @@ scheme_init_syntax (Scheme_Env *env)
REGISTER_SO(scheme_compiled_void_code);
REGISTER_SO(lambda_symbol);
REGISTER_SO(letrec_symbol);
REGISTER_SO(let_star_symbol);
REGISTER_SO(let_symbol);
REGISTER_SO(letrec_values_symbol);
REGISTER_SO(let_star_values_symbol);
REGISTER_SO(let_values_symbol);
@ -247,10 +233,6 @@ scheme_init_syntax (Scheme_Env *env)
lambda_symbol = scheme_intern_symbol("lambda");
letrec_symbol = scheme_intern_symbol("letrec");
let_star_symbol = scheme_intern_symbol("let*");
let_symbol = scheme_intern_symbol("let");
letrec_values_symbol = scheme_intern_symbol("letrec-values");
let_star_values_symbol = scheme_intern_symbol("let*-values");
let_values_symbol = scheme_intern_symbol("let-values");
@ -364,19 +346,6 @@ scheme_init_syntax (Scheme_Env *env)
case_lambda_expand),
env);
scheme_add_global_keyword("let",
scheme_make_compiled_syntax(let_syntax,
let_expand),
env);
scheme_add_global_keyword("let*",
scheme_make_compiled_syntax(let_star_syntax,
let_star_expand),
env);
scheme_add_global_keyword("letrec",
scheme_make_compiled_syntax(letrec_syntax,
letrec_expand),
env);
scheme_add_global_keyword("let-values",
scheme_make_compiled_syntax(let_values_syntax,
let_values_expand),
@ -549,6 +518,8 @@ lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *ere
Scheme_Object *args, *body, *fn;
Scheme_Comp_Env *newenv;
SCHEME_EXPAND_OBSERVE_PRIM_LAMBDA(erec[drec].observer);
lambda_check(form);
args = SCHEME_STX_CDR(form);
@ -567,6 +538,7 @@ lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *ere
body = scheme_add_env_renames(body, newenv, env);
args = scheme_add_env_renames(args, newenv, env); /* for re-expansion */
SCHEME_EXPAND_OBSERVE_LAMBDA_RENAMES(erec[drec].observer, args, body);
fn = SCHEME_STX_CAR(form);
@ -1033,6 +1005,8 @@ define_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_In
{
Scheme_Object *var, *val, *fn, *boundname;
SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(erec[drec].observer);
scheme_define_parse(form, &var, &val, 0, env);
env = scheme_no_defines(env);
@ -1084,6 +1058,8 @@ quote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec
{
Scheme_Object *rest;
SCHEME_EXPAND_OBSERVE_PRIM_QUOTE(erec[drec].observer);
rest = SCHEME_STX_CDR(form);
if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest))))
@ -1175,11 +1151,17 @@ if_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, i
int len;
Scheme_Expand_Info recs[3];
SCHEME_EXPAND_OBSERVE_PRIM_IF(erec[drec].observer);
len = check_form(form, form);
if (!(((len == 3) || (len == 4))))
bad_form(form, len);
if (len == 3) {
SCHEME_EXPAND_OBSERVE_NEXT_GROUP(erec[drec].observer);
}
env = scheme_no_defines(env);
boundname = scheme_check_name_property(form, erec[drec].value_name);
@ -1195,12 +1177,14 @@ if_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, i
test = SCHEME_STX_CAR(rest);
test = scheme_expand_expr(test, env, recs, 0);
SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
rest = SCHEME_STX_CDR(rest);
thenp = SCHEME_STX_CAR(rest);
thenp = scheme_expand_expr(thenp, env, recs, 1);
rest = SCHEME_STX_CDR(rest);
if (!SCHEME_STX_NULLP(rest)) {
SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
elsep = SCHEME_STX_CAR(rest);
elsep = scheme_expand_expr(elsep, env, recs, 2);
rest = icons(elsep, scheme_null);
@ -1273,6 +1257,8 @@ with_cont_mark_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_I
int len;
Scheme_Expand_Info recs[3];
SCHEME_EXPAND_OBSERVE_PRIM_WCM(erec[drec].observer);
len = check_form(form, form);
if (len != 4)
bad_form(form, len);
@ -1296,7 +1282,9 @@ with_cont_mark_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_I
expr = SCHEME_STX_CAR(form);
key = scheme_expand_expr(key, env, recs, 0);
SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
val = scheme_expand_expr(val, env, recs, 1);
SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
expr = scheme_expand_expr(expr, env, recs, 2);
fn = SCHEME_STX_CAR(orig_form);
@ -1516,7 +1504,7 @@ set_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) {
/* Redirect to a macro? */
if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_set_macro_type)) {
form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, rec[drec].certs, 1);
form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, rec, drec, 1);
return scheme_compile_expr(form, env, rec, drec);
} else if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) {
@ -1576,6 +1564,9 @@ set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec,
Scheme_Env *menv = NULL;
Scheme_Object *name, *var, *fn, *rhs, *find_name;
int l;
SCHEME_EXPAND_OBSERVE_PRIM_SET(erec[drec].observer);
l = check_form(form, form);
if (l != 3)
bad_form(form, l);
@ -1596,12 +1587,19 @@ set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec,
var = scheme_lookup_binding(find_name, env, SCHEME_SETTING,
erec[drec].certs, env->in_modidx,
&menv, NULL);
SCHEME_EXPAND_OBSERVE_RESOLVE(erec[drec].observer, find_name);
if ((erec[drec].depth != 0) && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) {
/* Redirect to a macro? */
if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_set_macro_type)) {
form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, erec[drec].certs, 1);
SCHEME_EXPAND_OBSERVE_ENTER_MACRO(erec[drec].observer, form);
form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, erec, drec, 1);
SCHEME_EXPAND_OBSERVE_EXIT_MACRO(erec[drec].observer, form);
if (erec[drec].depth > 0)
erec[drec].depth--;
@ -1626,6 +1624,8 @@ set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec,
scheme_wrong_syntax(NULL, name, form, "cannot mutate syntax identifier");
}
SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
fn = SCHEME_STX_CAR(form);
rhs = SCHEME_STX_CDR(form);
@ -1634,10 +1634,11 @@ set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec,
erec[drec].value_name = name;
rhs = scheme_expand_expr(rhs, env, erec, drec);
return scheme_datum_to_syntax(icons(fn,
icons(find_name,
icons(scheme_expand_expr(rhs, env, erec, drec),
scheme_null))),
icons(rhs, scheme_null))),
form,
form,
0, 2);
@ -2166,6 +2167,8 @@ case_lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info
{
Scheme_Object *first, *last, *args, *body, *c, *new_line, *orig_form = form;
SCHEME_EXPAND_OBSERVE_PRIM_CASE_LAMBDA(erec[drec].observer);
first = SCHEME_STX_CAR(form);
first = icons(first, scheme_null);
last = first;
@ -2176,6 +2179,8 @@ case_lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info
while (SCHEME_STX_PAIRP(form)) {
Scheme_Object *line_form;
Scheme_Comp_Env *newenv;
SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
line_form = SCHEME_STX_CAR(form);
@ -2190,6 +2195,7 @@ case_lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info
body = scheme_add_env_renames(body, newenv, env);
args = scheme_add_env_renames(args, newenv, env);
SCHEME_EXPAND_OBSERVE_CASE_LAMBDA_RENAMES(erec[drec].observer, args, body);
{
Scheme_Expand_Info erec1;
@ -3386,7 +3392,6 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
const char *formname, int letrec, int multi, int letstar,
Scheme_Comp_Env *env_already)
{
int named, partial;
Scheme_Object *vars, *body, *first, *last, *name, *v, *vs, *vlist, *boundname;
Scheme_Comp_Env *use_env, *env;
Scheme_Expand_Info erec1;
@ -3394,15 +3399,6 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
vars = SCHEME_STX_CDR(form);
named = (!multi
&& !letrec
&& !letstar
&& SCHEME_STX_PAIRP(vars)
&& SCHEME_STX_SYMBOLP(SCHEME_STX_CAR(vars)));
if (named)
return named_let_syntax(form, origenv, erec, drec);
if (!SCHEME_STX_PAIRP(vars))
scheme_wrong_syntax(NULL, NULL, form, NULL);
@ -3429,13 +3425,13 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
a = SCHEME_STX_CAR(vars);
vr = SCHEME_STX_CDR(vars);
first = multi ? let_values_symbol : let_symbol;
first = let_values_symbol;
first = scheme_datum_to_syntax(first, form, scheme_sys_wraps(origenv), 0, 0);
if (SCHEME_STX_NULLP(vr)) {
/* Don't create redundant empty let form */
} else {
last = multi ? let_star_values_symbol : let_star_symbol;
last = let_star_values_symbol;
last = scheme_datum_to_syntax(last, form, scheme_sys_wraps(origenv), 0, 0);
body = icons(icons(last, icons(vr, body)),
scheme_null);
@ -3448,15 +3444,15 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
first = scheme_datum_to_syntax(let_values_symbol, form, scheme_sys_wraps(origenv), 0, 0);
body = icons(first, icons(scheme_null, body));
}
body = scheme_datum_to_syntax(body, form, form, 0, 2);
body = scheme_datum_to_syntax(body, form, form, 0, -1);
first = SCHEME_STX_CAR(form);
body = scheme_stx_track(body, form, first);
if (erec[drec].depth > 0)
--erec[drec].depth;
if (!erec[drec].depth)
return body;
else {
@ -3464,29 +3460,9 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
return scheme_expand_expr(body, env, erec, drec);
}
}
/* Note: no more letstar handling needed after this point */
/* Check whether this is a partial expansion terminating in the
`-values' form. If so, don't recursively expand here and don't
introduce syntactic renamings (i.e., act like a non-primitive
macro). */
if (!multi) {
v = (letrec
? letrec_values_symbol
: let_values_symbol) ;
v = scheme_datum_to_syntax(v, scheme_false, scheme_sys_wraps(origenv), 0, 0);
v = scheme_lookup_binding(v, origenv,
SCHEME_NULL_FOR_UNBOUND
+ SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK
+ SCHEME_DONT_MARK_USE,
erec[drec].certs, origenv->in_modidx,
NULL, NULL);
first = scheme_get_stop_expander();
partial = SAME_OBJ(first, v);
} else
partial = 0;
scheme_begin_dup_symbol_check(&r, origenv);
vlist = scheme_null;
@ -3503,7 +3479,7 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
name = SCHEME_STX_CAR(v);
if (multi) {
{
DupCheckRecord r2;
Scheme_Object *names = name;
scheme_begin_dup_symbol_check(&r2, origenv);
@ -3520,10 +3496,6 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
}
if (!SCHEME_STX_NULLP(names))
scheme_wrong_syntax(NULL, names, form, NULL);
} else {
scheme_check_identifier(NULL, name, NULL, origenv, form);
vlist = cons(name, vlist);
scheme_dup_symbol_check(&r, NULL, name, "binding", form);
}
vs = SCHEME_STX_CDR(vs);
@ -3535,36 +3507,62 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
use_env = origenv;
if (env_already)
env = env_already;
else if (partial)
env = origenv;
else
env = scheme_add_compilation_frame(vlist, origenv,0,erec[drec].certs);
env = scheme_add_compilation_frame(vlist, origenv, 0, erec[drec].certs);
if (letrec)
use_env = env;
/* Pass 1: Rename */
first = last = NULL;
vs = vars;
while (SCHEME_STX_PAIRP(vars)) {
Scheme_Object *rhs, *rhs_name;
Scheme_Object *rhs;
v = SCHEME_STX_CAR(vars);
/* Make sure names gets their own renames: */
name = SCHEME_STX_CAR(v);
if (!multi) {
if (!partial)
name = scheme_add_env_renames(name, env, origenv);
name = icons(name, scheme_null);
} else {
if (!partial)
name = scheme_add_env_renames(name, env, origenv);
}
name = scheme_add_env_renames(name, env, origenv);
rhs = SCHEME_STX_CDR(v);
rhs = SCHEME_STX_CAR(rhs);
if (!partial)
rhs = scheme_add_env_renames(rhs, use_env, origenv);
rhs = scheme_add_env_renames(rhs, use_env, origenv);
v = scheme_datum_to_syntax(icons(name, icons(rhs, scheme_null)), v, v, 0, 1);
v = icons(v, scheme_null);
if (!first)
first = v;
else
SCHEME_CDR(last) = v;
last = v;
vars = SCHEME_STX_CDR(vars);
}
if (!first) {
first = scheme_null;
}
vars = first;
body = scheme_datum_to_syntax(body, form, form, 0, 0);
body = scheme_add_env_renames(body, env, origenv);
SCHEME_EXPAND_OBSERVE_LET_RENAMES(erec[drec].observer, vars, body);
/* Pass 2: Expand */
first = last = NULL;
while (SCHEME_STX_PAIRP(vars)) {
Scheme_Object *rhs, *rhs_name;
SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
v = SCHEME_STX_CAR(vars);
name = SCHEME_STX_CAR(v);
rhs = SCHEME_STX_CDR(v);
rhs = SCHEME_STX_CAR(rhs);
if (SCHEME_STX_PAIRP(name) && SCHEME_STX_NULLP(SCHEME_STX_CDR(name))) {
rhs_name = SCHEME_STX_CAR(name);
@ -3572,11 +3570,9 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
rhs_name = scheme_false;
}
if (!partial) {
scheme_init_expand_recs(erec, drec, &erec1, 1);
erec1.value_name = rhs_name;
rhs = scheme_expand_expr(rhs, use_env, &erec1, 0);
}
scheme_init_expand_recs(erec, drec, &erec1, 1);
erec1.value_name = rhs_name;
rhs = scheme_expand_expr(rhs, use_env, &erec1, 0);
v = scheme_datum_to_syntax(icons(name, icons(rhs, scheme_null)), v, v, 0, 1);
v = icons(v, scheme_null);
@ -3591,6 +3587,8 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
vars = SCHEME_STX_CDR(vars);
}
/* End Pass 2 */
if (!SCHEME_STX_NULLP(vars))
scheme_wrong_syntax(NULL, vars, form, NULL);
@ -3598,100 +3596,40 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
first = scheme_null;
first = scheme_datum_to_syntax(first, vs, vs, 0, 1);
body = scheme_datum_to_syntax(body, form, form, 0, 0);
if (!partial) {
body = scheme_add_env_renames(body, env, origenv);
scheme_init_expand_recs(erec, drec, &erec1, 1);
erec1.value_name = erec[drec].value_name;
body = scheme_expand_block(body, env, &erec1, 0);
}
if (multi)
v = SCHEME_STX_CAR(form);
else
v = scheme_datum_to_syntax((letrec
? letrec_values_symbol
: let_values_symbol),
form, scheme_sys_wraps(origenv),
0, 0);
SCHEME_EXPAND_OBSERVE_NEXT_GROUP(erec[drec].observer);
scheme_init_expand_recs(erec, drec, &erec1, 1);
erec1.value_name = erec[drec].value_name;
body = scheme_expand_block(body, env, &erec1, 0);
v = SCHEME_STX_CAR(form);
v = icons(v, icons(first, body));
v = scheme_datum_to_syntax(v, form, form, 0, multi ? 2 : -1);
if (!multi) {
name = SCHEME_STX_CAR(form);
v = scheme_stx_track(v, form, name);
}
v = scheme_datum_to_syntax(v, form, form, 0, 2);
return v;
}
static Scheme_Object *
let_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
return do_let_expand(form, env, erec, drec, "let", 0, 0, 0, NULL);
}
static Scheme_Object *
let_star_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
return do_let_expand(form, env, erec, drec, "let*", 0, 0, 1, NULL);
}
static Scheme_Object *
letrec_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
return do_let_expand(form, env, erec, drec, "letrec", 1, 0, 0, NULL);
}
static Scheme_Object *
let_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
return do_let_expand(form, env, erec, drec, "let", 0, 1, 0, NULL);
SCHEME_EXPAND_OBSERVE_PRIM_LET_VALUES(erec[drec].observer);
return do_let_expand(form, env, erec, drec, "let-values", 0, 1, 0, NULL);
}
static Scheme_Object *
let_star_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
return do_let_expand(form, env, erec, drec, "let*", 0, 1, 1, NULL);
SCHEME_EXPAND_OBSERVE_PRIM_LETSTAR_VALUES(erec[drec].observer);
return do_let_expand(form, env, erec, drec, "let*-values", 0, 1, 1, NULL);
}
static Scheme_Object *
letrec_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
return do_let_expand(form, env, erec, drec, "letrec", 1, 1, 0, NULL);
SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(erec[drec].observer);
return do_let_expand(form, env, erec, drec, "letrec-values", 1, 1, 0, NULL);
}
static Scheme_Object *
let_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
{
Scheme_Object *rest;
rest = SCHEME_STX_CDR(form);
if (!SCHEME_STX_PAIRP(rest))
scheme_wrong_syntax(NULL, NULL, form, (SCHEME_STX_NULLP(rest)
? NULL
: "bad syntax (" IMPROPER_LIST_FORM ")"));
if (SCHEME_STX_SYMBOLP(SCHEME_STX_CAR(rest)))
return named_let_syntax (form, env, rec, drec);
return gen_let_syntax(form, env, "let", 0, 0, 0, rec, drec, NULL);
}
static Scheme_Object *
let_star_syntax (Scheme_Object *form, Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec)
{
return gen_let_syntax(form, env, "let*", 1, 0, 0, rec, drec, NULL);
}
static Scheme_Object *
letrec_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
{
return gen_let_syntax(form, env, "letrec", 0, 1, 0, rec, drec, NULL);
}
static Scheme_Object *
let_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env,
@ -3713,109 +3651,6 @@ letrec_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_
return gen_let_syntax(form, env, "letrec-values", 0, 1, 1, rec, drec, NULL);
}
static Scheme_Object *nl_car(Scheme_Object *l, Scheme_Object *form)
{
Scheme_Object *s;
if (!SCHEME_STX_PAIRP(l))
scheme_wrong_syntax("named let", l, form,
"bad syntax (not an identifier-value pair)");
s = SCHEME_STX_CAR(l);
if (!SCHEME_STX_SYMBOLP(s))
scheme_wrong_syntax("named let", s, form,
"bad syntax (name not an identifier)");
return s;
}
static Scheme_Object *nl_cadr(Scheme_Object *l, Scheme_Object *form)
{
Scheme_Object *rest;
if (!SCHEME_STX_PAIRP(l) || !SCHEME_STX_PAIRP(SCHEME_STX_CDR(l)))
scheme_wrong_syntax("named let", l, form,
"bad syntax (not an identifier-value pair)");
rest = SCHEME_STX_CDR(l);
if (!SCHEME_STX_NULLP(SCHEME_STX_CDR(rest)))
scheme_wrong_syntax("named let", l, form,
"bad syntax (extra form in indentifier-value pair)");
return SCHEME_STX_CAR(rest);
}
static Scheme_Object *
named_let_syntax (Scheme_Object *form, Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec)
{
Scheme_Object *name, *bindings, *vars, *vals, *forms, *rest, *_vars, *_vals, *v;
Scheme_Object *proc, *app, *letrec;
rest = SCHEME_STX_CDR(form);
if (!SCHEME_STX_PAIRP(rest))
rest = NULL;
else {
rest = SCHEME_STX_CDR(rest);
if (!SCHEME_STX_PAIRP(rest))
rest = NULL;
else {
rest = SCHEME_STX_CDR(rest);
if (!SCHEME_STX_PAIRP(rest))
rest = NULL;
}
}
if (!rest)
scheme_wrong_syntax("named let", NULL, form, NULL);
rest = SCHEME_STX_CDR(form);
name = SCHEME_STX_CAR(rest);
rest = SCHEME_STX_CDR(rest);
bindings = SCHEME_STX_CAR(rest);
if (!SCHEME_STX_PAIRP(bindings) && !SCHEME_STX_NULLP(bindings))
scheme_wrong_syntax("named let", bindings, form, NULL);
vars = scheme_named_map_1("named let", nl_car, bindings, form);
vals = scheme_named_map_1("named let", nl_cadr, bindings, form);
/* Add inferred-name attribute to arguments: */
for (_vars = vars, _vals = vals; SCHEME_PAIRP(_vars); _vars = SCHEME_CDR(_vars), _vals = SCHEME_CDR(_vals)) {
v = scheme_stx_property(SCHEME_CAR(_vals), scheme_inferred_name_symbol, NULL);
if (SCHEME_FALSEP(v)) {
v = scheme_stx_property(SCHEME_CAR(_vals), scheme_inferred_name_symbol, SCHEME_STX_VAL(SCHEME_CAR(_vars)));
SCHEME_CAR(_vals) = v;
}
}
forms = SCHEME_STX_CDR(form);
forms = SCHEME_STX_CDR(forms);
forms = SCHEME_STX_CDR(forms);
proc = icons(lambda_symbol, icons(vars, forms));
letrec = icons(letrec_symbol,
icons(icons(icons(name, icons(proc, scheme_null)), scheme_null),
icons(name,
scheme_null)));
app = icons(letrec, vals);
app = scheme_datum_to_syntax(app, form, scheme_sys_wraps(env), 0, 2);
if (rec[drec].comp)
return scheme_compile_expr(app, env, rec, drec);
else {
name = SCHEME_STX_CAR(form);
app = scheme_stx_track(app, form, name);
if (rec[drec].depth > 0)
--rec[drec].depth;
if (!rec[drec].depth)
return app;
else
return scheme_expand_expr(app, env, rec, drec);
}
}
/**********************************************************************/
/* begin, begin0, implicit begins */
/**********************************************************************/
@ -4103,8 +3938,11 @@ do_begin_expand(char *name,
rest = SCHEME_STX_CDR(form);
if (SCHEME_STX_NULLP(rest)) {
if (!zero && scheme_is_toplevel(env))
if (!zero && scheme_is_toplevel(env)) {
SCHEME_EXPAND_OBSERVE_ENTER_LIST(erec[drec].observer, form);
SCHEME_EXPAND_OBSERVE_EXIT_LIST(erec[drec].observer, form);
return form;
}
scheme_wrong_syntax(NULL, NULL, form, "bad syntax (empty form)");
return NULL;
}
@ -4124,11 +3962,14 @@ do_begin_expand(char *name,
erec[drec].value_name = scheme_false;
fst = SCHEME_STX_CAR(rest);
rest = SCHEME_STX_CDR(rest);
form = icons(scheme_expand_expr(fst, env, &erec1, 0),
scheme_expand_list(scheme_datum_to_syntax(rest,
form,
form, 0, 0),
env, erec, drec));
SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
fst = scheme_expand_expr(fst, env, &erec1, 0);
rest = scheme_datum_to_syntax(rest, form, form, 0, 0);
SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
rest = scheme_expand_list(rest, env, erec, drec);
form = icons(fst, rest);
} else {
Scheme_Object *boundname;
boundname = scheme_check_name_property(form, erec[drec].value_name);
@ -4157,12 +3998,14 @@ do_begin_expand(char *name,
static Scheme_Object *
begin_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(erec[drec].observer);
return do_begin_expand("begin", form, env, erec, drec, 0);
}
static Scheme_Object *
begin0_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
SCHEME_EXPAND_OBSERVE_PRIM_BEGIN0(erec[drec].observer);
return do_begin_expand("begin0", form, env, erec, drec, 1);
}
@ -4232,6 +4075,7 @@ quote_syntax_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_In
static Scheme_Object *
quote_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
SCHEME_EXPAND_OBSERVE_PRIM_QUOTE_SYNTAX(erec[drec].observer);
return quote_syntax_syntax(form, env, erec, drec);
}
@ -4523,6 +4367,7 @@ do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env,
rec1.resolve_module_ids = 0;
rec1.value_name = NULL;
rec1.certs = rec[drec].certs;
rec1.observer = NULL;
if (for_stx) {
names = defn_targets_syntax(names, exp_env, &rec1, 0);
@ -4557,6 +4402,8 @@ define_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_
{
Scheme_Object *names, *code, *fpart, *fn;
SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(erec[drec].observer);
scheme_prepare_exp_env(env->genv);
scheme_define_parse(form, &names, &code, 1, env);
@ -4668,27 +4515,41 @@ static void *eval_letmacro_rhs_k(void)
}
Scheme_Object *scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a,
Scheme_Env *exp_env, Scheme_Object *insp, Scheme_Object *certs,
Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env,
int *_pos, Scheme_Object *names_to_disappear)
void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a,
Scheme_Env *exp_env, Scheme_Object *insp,
Scheme_Compile_Expand_Info *rec, int drec,
Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env,
int *_pos)
{
Scheme_Object **results, *l;
Scheme_Comp_Env *eenv;
Scheme_Object *certs;
Resolve_Prefix *rp;
Resolve_Info *ri;
Optimize_Info *oi;
int vc, nc, j, i;
Scheme_Compile_Info mrec;
certs = rec[drec].certs;
mrec.comp = 1;
mrec.dont_mark_local_use = 0;
mrec.resolve_module_ids = 1;
mrec.value_name = NULL;
mrec.certs = certs;
mrec.observer = NULL;
eenv = scheme_new_comp_env(exp_env, insp, 0);
{
mrec.comp = 0;
mrec.observer = rec[drec].observer;
SCHEME_EXPAND_OBSERVE_PHASE_UP(mrec.observer);
a = scheme_expand_expr_lift_to_let(a, eenv, &mrec, 0);
mrec.comp = 1;
mrec.observer = NULL;
}
a = scheme_compile_expr_lift_to_let(a, eenv, &mrec, 0);
/* For internal defn, don't simplify as resolving, because the
@ -4757,12 +4618,8 @@ Scheme_Object *scheme_bind_syntaxes(const char *where, Scheme_Object *names, Sch
SCHEME_PTR_VAL(macro) = results[j];
scheme_set_local_syntax(i++, name, macro, stx_env);
if (names_to_disappear)
names_to_disappear = icons(name, names_to_disappear);
}
*_pos = i;
return names_to_disappear;
}
static Scheme_Object *
@ -4817,6 +4674,8 @@ do_letrec_syntaxes(const char *where,
scheme_begin_dup_symbol_check(&r, stx_env);
/* Pass 1: Check and Rename */
for (i = 0; i < 2 ; i++) {
for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
Scheme_Object *a, *l;
@ -4889,6 +4748,30 @@ do_letrec_syntaxes(const char *where,
}
}
if (names_to_disappear) {
for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
Scheme_Object *a, *names;
a = SCHEME_STX_CAR(v);
names = SCHEME_STX_CAR(a);
while (!SCHEME_STX_NULLP(names)) {
a = SCHEME_STX_CAR(names);
if (names_to_disappear)
names_to_disappear = icons(a, names_to_disappear);
names = SCHEME_STX_CDR(names);
}
}
}
bindings = scheme_add_env_renames(bindings, stx_env, origenv);
if (var_env)
bindings = scheme_add_env_renames(bindings, var_env, origenv);
if (var_env)
var_bindings = scheme_add_env_renames(var_bindings, stx_env, origenv);
body = scheme_add_env_renames(body, stx_env, origenv);
SCHEME_EXPAND_OBSERVE_LETREC_SYNTAXES_RENAMES(rec[drec].observer, bindings, var_bindings, body);
scheme_prepare_exp_env(stx_env->genv);
i = 0;
@ -4896,22 +4779,23 @@ do_letrec_syntaxes(const char *where,
for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
Scheme_Object *a, *names;
SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
a = SCHEME_STX_CAR(v);
names = SCHEME_STX_CAR(a);
a = SCHEME_STX_CDR(a);
a = SCHEME_STX_CAR(a);
a = scheme_add_env_renames(a, stx_env, origenv);
if (var_env)
a = scheme_add_env_renames(a, var_env, stx_env);
names_to_disappear = scheme_bind_syntaxes(where, names, a,
stx_env->genv->exp_env, stx_env->insp, rec[drec].certs,
stx_env, rhs_env,
&i, names_to_disappear);
scheme_bind_syntaxes(where, names, a,
stx_env->genv->exp_env,
stx_env->insp,
rec, drec,
stx_env, rhs_env,
&i);
}
body = scheme_add_env_renames(body, stx_env, origenv);
SCHEME_EXPAND_OBSERVE_NEXT_GROUP(rec[drec].observer);
if (names_to_disappear) {
/* Need to add renaming for disappeared bindings --- unless
they originated for internal definitions, in which case
@ -4927,8 +4811,6 @@ do_letrec_syntaxes(const char *where,
}
}
}
if (var_env)
var_bindings = scheme_add_env_renames(var_bindings, stx_env, origenv);
if (!var_env) {
var_env = scheme_require_renames(stx_env);
@ -4960,6 +4842,7 @@ do_letrec_syntaxes(const char *where,
if (rec[drec].comp) {
v = gen_let_syntax(v, stx_env, "letrec-values", 0, 1, 1, rec, drec, var_env);
} else {
SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(rec[drec].observer);
v = do_let_expand(v, stx_env, rec, drec, "letrec-values", 1, 1, 0, var_env);
if ((depth >= 0) || (depth == -2)) {
@ -4990,6 +4873,8 @@ letrec_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env,
static Scheme_Object *
letrec_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
SCHEME_EXPAND_OBSERVE_PRIM_LETREC_SYNTAXES_VALUES(erec[drec].observer);
return do_letrec_syntaxes("letrec-syntaxes+values", form, env, erec, drec);
}
@ -5198,6 +5083,72 @@ static Scheme_Object *read_case_lambda(Scheme_Object *obj)
return (Scheme_Object *)cl;
}
/**********************************************************************/
/* expansion observer */
/**********************************************************************/
/* RMC
* - Defines #%expobs module
* - current-expand-observe
* - ??? (other syntax observations)
*/
void scheme_call_expand_observe(Scheme_Object *obs, int tag, Scheme_Object *obj)
{
if (!SCHEME_PROCP(obs)) {
scheme_signal_error("internal error: expand-observer should never be non-procedure");
} else {
Scheme_Object *buf[2];
buf[0] = scheme_make_integer(tag);
if (obj) {
buf[1] = obj;
} else {
buf[1] = scheme_false;
}
scheme_apply(obs, 2, buf);
}
}
static Scheme_Object *
current_expand_observe(int argc, Scheme_Object **argv)
{
return scheme_param_config("current-expand-observe",
scheme_make_integer(MZCONFIG_EXPAND_OBSERVE),
argc, argv,
2, NULL, NULL, 0);
}
/* always returns either procedure or NULL */
Scheme_Object *scheme_get_expand_observe()
{
Scheme_Object *obs;
obs = scheme_get_param(scheme_current_config(),
MZCONFIG_EXPAND_OBSERVE);
if (SCHEME_PROCP(obs)) {
return obs;
} else {
return NULL;
}
}
void scheme_init_expand_observe(Scheme_Env *env)
{
Scheme_Env *newenv;
Scheme_Object *modname;
modname = scheme_intern_symbol("#%expobs");
newenv = scheme_primitive_module(modname, env);
scheme_add_global_constant
("current-expand-observe",
scheme_register_parameter(current_expand_observe,
"current-expand-observe",
MZCONFIG_EXPAND_OBSERVE),
newenv);
scheme_finish_primitive_module(newenv);
}
/**********************************************************************/
/* precise GC */
/**********************************************************************/

8
src/worksp/gc2/make.ss
View File

@ -55,6 +55,8 @@
"type"
"vector"))
(define common-cpp-defs " /D _CRT_SECURE_NO_DEPRECATE ")
(define (try src deps dest objdest includes use-precomp extra-compile-flags expand-extra-flags msvc-pch indirect?)
(when (or (not re:only) (regexp-match re:only dest))
(unless (and (file-exists? dest)
@ -90,7 +92,10 @@
(list
"--depends"
"--cpp"
(format "cl.exe /MT /E ~a ~a" expand-extra-flags includes)
(format "cl.exe /MT /E ~a ~a ~a"
common-cpp-defs
expand-extra-flags
includes)
"-o"
dest
src)))
@ -101,6 +106,7 @@
(when objdest
(compile dest objdest null (string-append
extra-compile-flags
common-cpp-defs
(if msvc-pch
(format " /Fp~a" msvc-pch)
""))))))

5
src/worksp/jpeg/jpeg.vcproj
View File

@ -3,6 +3,7 @@
ProjectType="Visual C++"
Version="8.00"
Name="jpeg"
ProjectGUID="{1549C7C5-AF41-43BE-B905-BA6374FE6BEC}"
>
<Platforms>
<Platform
@ -41,7 +42,7 @@
Name="VCCLCompilerTool"
Optimization="0"
AdditionalIncludeDirectories="..\jpeg,$(NOINHERIT)"
PreprocessorDefinitions="WIN32,_DEBUG,_LIB"
PreprocessorDefinitions="WIN32,_DEBUG,_LIB,_CRT_SECURE_NO_DEPRECATE"
RuntimeLibrary="1"
UsePrecompiledHeader="0"
WarningLevel="3"
@ -112,7 +113,7 @@
EnableIntrinsicFunctions="true"
FavorSizeOrSpeed="1"
AdditionalIncludeDirectories="..\jpeg,$(NOINHERIT)"
PreprocessorDefinitions="WIN32,NDEBUG,_LIB"
PreprocessorDefinitions="WIN32,NDEBUG,_LIB,_CRT_SECURE_NO_DEPRECATE"
StringPooling="true"
RuntimeLibrary="0"
EnableFunctionLevelLinking="true"

5
src/worksp/libmred/libmred.vcproj
View File

@ -3,6 +3,7 @@
ProjectType="Visual C++"
Version="8.00"
Name="libmred"
ProjectGUID="{81BD2D42-F150-493D-94BA-88585B202789}"
>
<Platforms>
<Platform
@ -41,7 +42,7 @@
Name="VCCLCompilerTool"
Optimization="0"
AdditionalIncludeDirectories="..,..\..\mzscheme\gc,..\..\mzscheme\include,..\..\mred\wxme,..\..\wxwindow\include\base,..\..\wxwindow\include\msw,$(NOINHERIT)"
PreprocessorDefinitions="WIN32;_DEBUG;_WINDOWS;_USRDLL;GC_DLL;LIBMRED_EXPORTS"
PreprocessorDefinitions="WIN32;_DEBUG;_WINDOWS;_USRDLL;GC_DLL;LIBMRED_EXPORTS;_CRT_SECURE_NO_DEPRECATE"
BasicRuntimeChecks="3"
RuntimeLibrary="1"
UsePrecompiledHeader="0"
@ -127,7 +128,7 @@
EnableIntrinsicFunctions="true"
FavorSizeOrSpeed="1"
AdditionalIncludeDirectories="..,..\..\mzscheme\gc,..\..\mzscheme\include,..\..\mred\wxme,..\..\wxwindow\include\base,..\..\wxwindow\include\msw,$(NOINHERIT)"
PreprocessorDefinitions="WIN32;NDEBUG;_WINDOWS;_USRDLL;GC_DLL;LIBMRED_EXPORTS"
PreprocessorDefinitions="WIN32;NDEBUG;_WINDOWS;_USRDLL;GC_DLL;LIBMRED_EXPORTS;_CRT_SECURE_NO_DEPRECATE"
StringPooling="true"
RuntimeLibrary="0"
EnableFunctionLevelLinking="true"

5
src/worksp/libmzgc/libmzgc.vcproj
View File

@ -3,6 +3,7 @@
ProjectType="Visual C++"
Version="8.00"
Name="libmzgc"
ProjectGUID="{CB68718B-24BF-43E3-9E96-BCF9B37CFE2D}"
>
<Platforms>
<Platform
@ -41,7 +42,7 @@
Name="VCCLCompilerTool"
Optimization="0"
AdditionalIncludeDirectories="..\..\MzScheme\Gc\Include,$(NOINHERIT)"
PreprocessorDefinitions="WIN32;_DEBUG;_WINDOWS;_USRDLL;GC_BUILD;MD_LIB_MAIN;SILENT;OLD_BLOCK_ALLOC;LARGE_CONFIG;ATOMIC_UNCOLLECTABLE;INITIAL_MARK_STACK_SIZE=8192;GC_DLL"
PreprocessorDefinitions="WIN32;_DEBUG;_WINDOWS;_USRDLL;GC_BUILD;MD_LIB_MAIN;SILENT;OLD_BLOCK_ALLOC;LARGE_CONFIG;ATOMIC_UNCOLLECTABLE;INITIAL_MARK_STACK_SIZE=8192;GC_DLL;_CRT_SECURE_NO_DEPRECATE"
BasicRuntimeChecks="3"
RuntimeLibrary="1"
UsePrecompiledHeader="0"
@ -126,7 +127,7 @@
EnableIntrinsicFunctions="true"
FavorSizeOrSpeed="1"
AdditionalIncludeDirectories="..\..\MzScheme\Gc\Include,$(NOINHERIT)"
PreprocessorDefinitions="WIN32;NDEBUG;_WINDOWS;_USRDLL;GC_BUILD;SILENT;OLD_BLOCK_ALLOC;LARGE_CONFIG;ATOMIC_UNCOLLECTABLE;INITIAL_MARK_STACK_SIZE=8192;GC_DLL"
PreprocessorDefinitions="WIN32;NDEBUG;_WINDOWS;_USRDLL;GC_BUILD;SILENT;OLD_BLOCK_ALLOC;LARGE_CONFIG;ATOMIC_UNCOLLECTABLE;INITIAL_MARK_STACK_SIZE=8192;GC_DLL;_CRT_SECURE_NO_DEPRECATE"
StringPooling="true"
RuntimeLibrary="0"
EnableFunctionLevelLinking="true"

5
src/worksp/libmzsch/libmzsch.vcproj
View File

@ -3,6 +3,7 @@
ProjectType="Visual C++"
Version="8.00"
Name="libmzsch"
ProjectGUID="{2D99E176-BCA5-4B8E-B25C-1B2D7179C188}"
>
<Platforms>
<Platform
@ -41,7 +42,7 @@
Name="VCCLCompilerTool"
Optimization="0"
AdditionalIncludeDirectories="..,..\..\mzscheme\include,..\..\mzscheme\src,..\..\foreign\libffi_msvc,$(NOINHERIT)"
PreprocessorDefinitions="WIN32;_DEBUG;_WINDOWS;_USRDLL;GC_DLL;__STDC__;LIBMZ_EXPORTS"
PreprocessorDefinitions="WIN32;_DEBUG;_WINDOWS;_USRDLL;GC_DLL;__STDC__;LIBMZ_EXPORTS;_CRT_SECURE_NO_DEPRECATE"
BasicRuntimeChecks="3"
RuntimeLibrary="1"
EnableFunctionLevelLinking="true"
@ -129,7 +130,7 @@
EnableIntrinsicFunctions="true"
FavorSizeOrSpeed="1"
AdditionalIncludeDirectories="..,..\..\mzscheme\include,..\..\mzscheme\src,..\..\foreign\libffi_msvc,$(NOINHERIT)"
PreprocessorDefinitions="WIN32;NDEBUG;_WINDOWS;_USRDLL;GC_DLL;__STDC__;LIBMZ_EXPORTS"
PreprocessorDefinitions="WIN32;NDEBUG;_WINDOWS;_USRDLL;GC_DLL;__STDC__;LIBMZ_EXPORTS;_CRT_SECURE_NO_DEPRECATE"
StringPooling="true"
RuntimeLibrary="0"
EnableFunctionLevelLinking="true"

5
src/worksp/mred/mred.vcproj
View File

@ -3,6 +3,7 @@
ProjectType="Visual C++"
Version="8.00"
Name="MrEd"
ProjectGUID="{D59A2B28-330B-41F5-8261-F5BC1019E163}"
>
<Platforms>
<Platform
@ -43,7 +44,7 @@
EnableIntrinsicFunctions="true"
FavorSizeOrSpeed="1"
AdditionalIncludeDirectories="..,..\..\mzscheme\gc,..\..\wxwindow\include\base,..\..\wxwindow\include\msw,..\..\mzscheme\include,..\..\mred\wxme,..\..\mzscheme\utils,..\..\wxwindow\contrib\fafa"
PreprocessorDefinitions="WIN32,NDEBUG,_WINDOWS,__WINDOWS__,GC_DLL,__STDC__"
PreprocessorDefinitions="WIN32,NDEBUG,_WINDOWS,__WINDOWS__,GC_DLL,__STDC__,_CRT_SECURE_NO_DEPRECATE"
StringPooling="true"
RuntimeLibrary="0"
EnableFunctionLevelLinking="true"
@ -130,7 +131,7 @@
Name="VCCLCompilerTool"
Optimization="0"
AdditionalIncludeDirectories="..,..\..\mzscheme\gc,..\..\wxwindow\include\base,..\..\wxwindow\include\msw,..\..\mzscheme\include,..\..\mred\wxme,..\..\mzscheme\utils,..\..\wxwindow\contrib\fafa"
PreprocessorDefinitions="WIN32,_DEBUG,_WINDOWS,__WINDOWS__,GC_DLL,__STDC__"
PreprocessorDefinitions="WIN32,_DEBUG,_WINDOWS,__WINDOWS__,GC_DLL,__STDC__,_CRT_SECURE_NO_DEPRECATE"
BasicRuntimeChecks="3"
RuntimeLibrary="1"
UsePrecompiledHeader="0"

29
src/worksp/mzscheme/mzscheme.vcproj
View File

@ -3,6 +3,7 @@
ProjectType="Visual C++"
Version="8.00"
Name="MzScheme"
ProjectGUID="{EB7023C8-6D72-4DE4-ADFC-3913C4C70991}"
>
<Platforms>
<Platform
@ -41,7 +42,7 @@
Name="VCCLCompilerTool"
Optimization="0"
AdditionalIncludeDirectories="..,..\..\mzscheme\include,$(NOINHERIT)"
PreprocessorDefinitions="WIN32,_DEBUG,_CONSOLE,GC_DLL"
PreprocessorDefinitions="WIN32,_DEBUG,_CONSOLE,GC_DLL,_CRT_SECURE_NO_DEPRECATE"
BasicRuntimeChecks="3"
RuntimeLibrary="1"
UsePrecompiledHeader="0"
@ -94,17 +95,7 @@
/>
<Tool
Name="VCPostBuildEventTool"
CommandLine="&#x0D;&#x0A;
if exist &quot;$(TargetPath)&quot; goto :MzOK&#x0D;&#x0A;
echo Error: did not find $(TargetPath)&#x0D;&#x0A;
exit 1&#x0D;&#x0A;
:MzOK&#x0D;&#x0A;
&quot;$(TargetPath)&quot; -qr ..\..\mzscheme\mkincludes.ss &quot;$(TargetDir)/include/&quot; ..\..\mzscheme ..&#x0D;&#x0A;
if errorlevel 1 exit 1&#x0D;&#x0A;
cd ..\..\mzscheme\dynsrc&#x0D;&#x0A;
mkmzdynd.bat&#x0D;&#x0A;
cd ..\..\worksp\mzscheme&#x0D;&#x0A;
"
CommandLine="&#x0D;&#x0A;if exist &quot;$(TargetPath)&quot; goto :MzOK&#x0D;&#x0A;echo Error: did not find $(TargetPath)&#x0D;&#x0A;exit 1&#x0D;&#x0A;:MzOK&#x0D;&#x0A;&quot;$(TargetPath)&quot; -qr ..\..\mzscheme\mkincludes.ss &quot;$(TargetDir)/include/&quot; ..\..\mzscheme ..&#x0D;&#x0A;if errorlevel 1 exit 1&#x0D;&#x0A;cd ..\..\mzscheme\dynsrc&#x0D;&#x0A;mkmzdynd.bat&#x0D;&#x0A;cd ..\..\worksp\mzscheme&#x0D;&#x0A;&#x0D;&#x0A;"
/>
</Configuration>
<Configuration
@ -138,7 +129,7 @@ cd ..\..\worksp\mzscheme&#x0D;&#x0A;
EnableIntrinsicFunctions="true"
FavorSizeOrSpeed="1"
AdditionalIncludeDirectories="..,..\..\mzscheme\include,$(NOINHERIT)"
PreprocessorDefinitions="WIN32,NDEBUG,_CONSOLE,GC_DLL"
PreprocessorDefinitions="WIN32,NDEBUG,_CONSOLE,GC_DLL,_CRT_SECURE_NO_DEPRECATE"
StringPooling="true"
RuntimeLibrary="0"
EnableFunctionLevelLinking="true"
@ -193,17 +184,7 @@ cd ..\..\worksp\mzscheme&#x0D;&#x0A;
/>
<Tool
Name="VCPostBuildEventTool"
CommandLine="&#x0D;&#x0A;
if exist &quot;$(TargetPath)&quot; goto :MzOK&#x0D;&#x0A;
echo Error: did not find $(TargetPath)&#x0D;&#x0A;
exit 1&#x0D;&#x0A;
:MzOK&#x0D;&#x0A;
&quot;$(TargetPath)&quot; -qr ..\..\mzscheme\mkincludes.ss &quot;$(TargetDir)/include/&quot; ..\..\mzscheme ..&#x0D;&#x0A;
if errorlevel 1 exit 1&#x0D;&#x0A;
cd ..\..\mzscheme\dynsrc&#x0D;&#x0A;
mkmzdyn.bat&#x0D;&#x0A;
cd ..\..\worksp\mzscheme&#x0D;&#x0A;
"
CommandLine="&#x0D;&#x0A;if exist &quot;$(TargetPath)&quot; goto :MzOK&#x0D;&#x0A;echo Error: did not find $(TargetPath)&#x0D;&#x0A;exit 1&#x0D;&#x0A;:MzOK&#x0D;&#x0A;&quot;$(TargetPath)&quot; -qr ..\..\mzscheme\mkincludes.ss &quot;$(TargetDir)/include/&quot; ..\..\mzscheme ..&#x0D;&#x0A;if errorlevel 1 exit 1&#x0D;&#x0A;cd ..\..\mzscheme\dynsrc&#x0D;&#x0A;mkmzdyn.bat&#x0D;&#x0A;cd ..\..\worksp\mzscheme&#x0D;&#x0A;&#x0D;&#x0A;"
/>
</Configuration>
</Configurations>

4
src/worksp/png/png.vcproj
View File

@ -43,7 +43,7 @@
InlineFunctionExpansion="2"
EnableIntrinsicFunctions="true"
AdditionalIncludeDirectories="..\..\wxcommon\zlib,$(NOINHERIT)"
PreprocessorDefinitions="WIN32,NDEBUG,_LIB,GC_DLL"
PreprocessorDefinitions="WIN32,NDEBUG,_LIB,GC_DLL,_CRT_SECURE_NO_DEPRECATE"
StringPooling="true"
RuntimeLibrary="0"
EnableFunctionLevelLinking="true"
@ -113,7 +113,7 @@
Name="VCCLCompilerTool"
Optimization="0"
AdditionalIncludeDirectories="..\..\wxcommon\zlib,$(NOINHERIT)"
PreprocessorDefinitions="WIN32,_DEBUG,_LIB,GC_DLL"
PreprocessorDefinitions="WIN32,_DEBUG,_LIB,GC_DLL,_CRT_SECURE_NO_DEPRECATE"
RuntimeLibrary="1"
UsePrecompiledHeader="0"
WarningLevel="3"

5
src/worksp/wxme/wxme.vcproj
View File

@ -3,6 +3,7 @@
ProjectType="Visual C++"
Version="8.00"
Name="wxme"
ProjectGUID="{1C9F9C4D-FA97-4A56-8E7F-CA1EC99C35E3}"
>
<Platforms>
<Platform
@ -40,7 +41,7 @@
Name="VCCLCompilerTool"
Optimization="0"
AdditionalIncludeDirectories="..,..\..\mzscheme\gc,..\..\mzscheme\include,..\..\wxwindow\include\base,..\..\wxwindow\include\msw,..\..\wxcommon\jpeg,..\jpeg,..\..\wxcommon\zlib,$(NOINHERIT)"
PreprocessorDefinitions="WIN32,_DEBUG,_WINDOWS,__WINDOWS__,GC_DLL,__STDC__"
PreprocessorDefinitions="WIN32,_DEBUG,_WINDOWS,__WINDOWS__,GC_DLL,__STDC__,_CRT_SECURE_NO_DEPRECATE"
RuntimeLibrary="1"
UsePrecompiledHeader="0"
WarningLevel="3"
@ -110,7 +111,7 @@
EnableIntrinsicFunctions="true"
FavorSizeOrSpeed="1"
AdditionalIncludeDirectories="..,..\..\mzscheme\gc,..\..\mzscheme\include,..\..\wxwindow\include\base,..\..\wxwindow\include\msw,..\..\wxcommon\jpeg,..\jpeg,..\..\wxcommon\zlib,$(NOINHERIT)"
PreprocessorDefinitions="WIN32,NDEBUG,_WINDOWS,__WINDOWS__,GC_DLL,__STDC__"
PreprocessorDefinitions="WIN32,NDEBUG,_WINDOWS,__WINDOWS__,GC_DLL,__STDC__,_CRT_SECURE_NO_DEPRECATE"
StringPooling="true"
RuntimeLibrary="0"
EnableFunctionLevelLinking="true"

5
src/worksp/wxs/wxs.vcproj
View File

@ -3,6 +3,7 @@
ProjectType="Visual C++"
Version="8.00"
Name="wxs"
ProjectGUID="{B9FC613A-B427-4DB5-B1E3-7673D384ECE3}"
>
<Platforms>
<Platform
@ -40,7 +41,7 @@
Name="VCCLCompilerTool"
Optimization="0"
AdditionalIncludeDirectories="..,..\..\mzscheme\gc,..\..\mzscheme\include,..\..\mred\wxme,..\..\wxwindow\include\base,..\..\wxwindow\include\msw,..\..\wxWindow\contrib\fafa,$(NOINHERIT)"
PreprocessorDefinitions="WIN32,_DEBUG,_WINDOWS,__WINDOWS__,GC_DLL,__STDC__"
PreprocessorDefinitions="WIN32,_DEBUG,_WINDOWS,__WINDOWS__,GC_DLL,__STDC__,_CRT_SECURE_NO_DEPRECATE"
RuntimeLibrary="1"
UsePrecompiledHeader="0"
PrecompiledHeaderThrough="wx.h"
@ -110,7 +111,7 @@
EnableIntrinsicFunctions="true"
FavorSizeOrSpeed="1"
AdditionalIncludeDirectories="..,..\..\mzscheme\gc,..\..\mzscheme\include,..\..\mred\wxme,..\..\wxwindow\include\base,..\..\wxwindow\include\msw,..\..\wxWindow\contrib\fafa,$(NOINHERIT)"
PreprocessorDefinitions="WIN32,NDEBUG,_WINDOWS,__WINDOWS__,GC_DLL,__STDC__"
PreprocessorDefinitions="WIN32,NDEBUG,_WINDOWS,__WINDOWS__,GC_DLL,__STDC__,_CRT_SECURE_NO_DEPRECATE"
StringPooling="true"
RuntimeLibrary="0"
EnableFunctionLevelLinking="true"

5
src/worksp/wxutils/wxutils.vcproj
View File

@ -3,6 +3,7 @@
ProjectType="Visual C++"
Version="8.00"
Name="wxutils"
ProjectGUID="{31231DD7-4B8F-4E46-A747-81E41AFE04B5}"
>
<Platforms>
<Platform
@ -40,7 +41,7 @@
Name="VCCLCompilerTool"
Optimization="0"
AdditionalIncludeDirectories="..\..\mzscheme\gc,..\..\wxwindow\include\base,..\..\wxwindow\include\msw,..\..\wxwindow\contrib\wxxpm\libxpm.34b\lib,..\..\wxWindow\contrib\fafa"
PreprocessorDefinitions="WIN32,_DEBUG,_WINDOWS,__WINDOWS__,$(NOINHERIT)"
PreprocessorDefinitions="WIN32,_DEBUG,_WINDOWS,__WINDOWS__,_CRT_SECURE_NO_DEPRECATE,$(NOINHERIT)"
RuntimeLibrary="1"
UsePrecompiledHeader="0"
WarningLevel="3"
@ -109,7 +110,7 @@
EnableIntrinsicFunctions="true"
FavorSizeOrSpeed="1"
AdditionalIncludeDirectories="..\..\mzscheme\gc,..\..\wxwindow\include\base,..\..\wxwindow\include\msw,..\..\wxwindow\contrib\wxxpm\libxpm.34b\lib,..\..\wxWindow\contrib\fafa"
PreprocessorDefinitions="WIN32,NDEBUG,_WINDOWS,__WINDOWS__,$(NOINHERIT)"
PreprocessorDefinitions="WIN32,NDEBUG,_WINDOWS,__WINDOWS__,_CRT_SECURE_NO_DEPRECATE,$(NOINHERIT)"
StringPooling="true"
RuntimeLibrary="0"
EnableFunctionLevelLinking="true"

5
src/worksp/wxwin/wxwin.vcproj
View File

@ -3,6 +3,7 @@
ProjectType="Visual C++"
Version="8.00"
Name="wxwin"
ProjectGUID="{5386B148-05B4-483B-B144-C3E2A6E15C78}"
>
<Platforms>
<Platform
@ -40,7 +41,7 @@
Name="VCCLCompilerTool"
Optimization="0"
AdditionalIncludeDirectories="..,..\..\mzscheme\gc,..\..\wxwindow\include\base,..\..\wxwindow\include\msw,..\..\wxwindow\contrib\wxxpm\libxpm.34b\lib,..\..\wxWindow\contrib\fafa,$(NOINHERIT)"
PreprocessorDefinitions="WIN32,_DEBUG,_WINDOWS,__WINDOWS__,GC_DLL"
PreprocessorDefinitions="WIN32,_DEBUG,_WINDOWS,__WINDOWS__,GC_DLL,_CRT_SECURE_NO_DEPRECATE"
RuntimeLibrary="1"
UsePrecompiledHeader="0"
PrecompiledHeaderThrough="wx.h"
@ -110,7 +111,7 @@
EnableIntrinsicFunctions="true"
FavorSizeOrSpeed="1"
AdditionalIncludeDirectories="..,..\..\mzscheme\gc,..\..\wxwindow\include\base,..\..\wxwindow\include\msw,..\..\wxwindow\contrib\wxxpm\libxpm.34b\lib,..\..\wxWindow\contrib\fafa,$(NOINHERIT)"
PreprocessorDefinitions="WIN32,NDEBUG,_WINDOWS,__WINDOWS__,GC_DLL"
PreprocessorDefinitions="WIN32,NDEBUG,_WINDOWS,__WINDOWS__,GC_DLL,_CRT_SECURE_NO_DEPRECATE"
StringPooling="true"
RuntimeLibrary="0"
EnableFunctionLevelLinking="true"

4
src/worksp/zlib/zlib.vcproj
View File

@ -42,7 +42,7 @@
Name="VCCLCompilerTool"
Optimization="0"
AdditionalIncludeDirectories="..\zlib,$(NOINHERIT)"
PreprocessorDefinitions="WIN32,_DEBUG,_LIB,GC_DLL"
PreprocessorDefinitions="WIN32,_DEBUG,_LIB,GC_DLL,_CRT_SECURE_NO_DEPRECATE"
RuntimeLibrary="1"
UsePrecompiledHeader="0"
WarningLevel="3"
@ -113,7 +113,7 @@
EnableIntrinsicFunctions="true"
FavorSizeOrSpeed="1"
AdditionalIncludeDirectories="..\zlib,$(NOINHERIT)"
PreprocessorDefinitions="WIN32,NDEBUG,_LIB,GC_DLL"
PreprocessorDefinitions="WIN32,NDEBUG,_LIB,GC_DLL,_CRT_SECURE_NO_DEPRECATE"
StringPooling="true"
RuntimeLibrary="0"
EnableFunctionLevelLinking="true"

28
src/wxcommon/wxGC.h
View File

@ -118,10 +118,16 @@ public:
inline void *operator new(size_t size);
inline void *operator new(size_t size, GCPlacement gcp);
inline void operator delete(void *obj);
#ifdef _MSC_VER
inline void operator delete(void *obj, GCPlacement gcp);
#endif
#ifdef OPERATOR_NEW_ARRAY
inline void *operator new[](size_t size);
inline void *operator new[](size_t size, GCPlacement gcp);
inline void operator delete[](void *obj);
# ifdef _MSC_VER
inline void operator delete[](void *obj, GCPlacement gcp);
# endif
#endif
#ifdef MZ_PRECISE_GC
@ -223,6 +229,13 @@ inline void gc::operator delete(void * /*obj*/)
{
}
#ifdef _MSC_VER
inline void gc::operator delete(void *, GCPlacement gcp)
{
}
#endif
#ifdef OPERATOR_NEW_ARRAY
inline void *gc::operator new[](size_t size) {
#if defined(USE_SENORA_GC) || defined(MZ_PRECISE_GC)
@ -239,6 +252,12 @@ inline void *gc::operator new[](size_t size, GCPlacement gcp) {
inline void gc::operator delete[](void *obj) {
gc::operator delete(obj);
}
# ifdef _MSC_VER
inline void gc::operator delete[](void *obj, GCPlacement gcp) {
gc::operator delete(obj, gcp);
}
# endif
#endif
@ -263,5 +282,14 @@ inline void *operator new[](size_t size, GCPlacement gcp)
}
#endif
#ifdef _MSC_VER
inline void operator delete(void *, GCPlacement)
{
}
inline void operator delete[](void *, GCPlacement)
{
}
#endif
#endif /* WXGC_CPP_H */

4
src/wxmac/src/mac/wx_buttn.cc
View File

@ -309,9 +309,9 @@ static void PaintBitmapButton(Rect *r, wxBitmap *buttonBitmap, Bool pressed, Boo
state.adornment = focused ? kThemeAdornmentFocus : kThemeAdornmentNone;
if (isgray) {
buttonBitmap->DrawMac(IB_MARGIN_X, IB_MARGIN_Y, patOr);
DrawThemeButton(r, kThemeRoundedBevelButton, &state, NULL, NULL /* erase */, NULL, NULL);
DrawThemeButton(r, kThemeRoundedBevelButton, &state, NULL, NULL /* erase */, NULL, 0);
} else {
DrawThemeButton(r, kThemeRoundedBevelButton, &state, NULL, NULL /* erase */, NULL, NULL);
DrawThemeButton(r, kThemeRoundedBevelButton, &state, NULL, NULL /* erase */, NULL, 0);
buttonBitmap->DrawMac(IB_MARGIN_X, IB_MARGIN_Y, patOr);
}
}

2
src/wxmac/src/mac/wx_check.cc
View File

@ -322,7 +322,7 @@ void wxCheckBox::Paint(void)
state.value = bitmapState ? kThemeButtonOn : kThemeButtonOff;
state.adornment = ((trackState & 0x2) ? kThemeAdornmentFocus : kThemeAdornmentNone);
DrawThemeButton(&r, kThemeCheckBox, &state, NULL, NULL /* erase */, NULL, NULL);
DrawThemeButton(&r, kThemeCheckBox, &state, NULL, NULL /* erase */, NULL, 0);
}
}
}

4
src/wxmac/src/mac/wx_rbut.cc
View File

@ -258,7 +258,7 @@ void wxRadioButton::Paint(void)
str = wxCFString(labelString);
DrawThemeTextBox(str, kThemeSystemFont, kThemeStateActive,
0, &r, teJustLeft, NULL);
0, &r, teJustLeft, 0);
CFRelease(str);
}
@ -276,7 +276,7 @@ void wxRadioButton::Paint(void)
state.value = bitmapState ? kThemeButtonOn : kThemeButtonOff;
state.adornment = ((trackState & 0x2) ? kThemeAdornmentFocus : kThemeAdornmentNone);
DrawThemeButton(&r, kThemeRadioButton, &state, NULL, NULL /* erase */, NULL, NULL);
DrawThemeButton(&r, kThemeRadioButton, &state, NULL, NULL /* erase */, NULL, 0);
}
}
}

3
src/wxmac/src/mac/wx_slidr.cc
View File

@ -253,8 +253,7 @@ void wxSlider::Paint(void)
wxDrawUnicodeText(t, 0, -1, 0);
} else {
str = wxCFString(t);
DrawThemeTextBox(str, kThemeSystemFont, kThemeStateActive,
0, &r, teJustCenter, NULL);
DrawThemeTextBox(str, kThemeSystemFont, kThemeStateActive, 0, &r, teJustCenter, 0);
CFRelease(str);
}
}

1
src/wxwindow/src/msw/wx_pdf.cxx
View File

@ -205,7 +205,6 @@ LRESULT APIENTRY wxEndSessionWatcherWndProc(HWND hWnd, UINT message, WPARAM wPar
static long DoEndSessionWin(void *data)
{
HWND win;
MSG msg;
qes_win = CreateWindowW(L"wxEndSessionWatcher", L"EndSession Watcher", WS_POPUP,