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; \ savebuf = scheme_current_thread->error_buf; \
scheme_current_thread->error_buf = &newbuf; \ scheme_current_thread->error_buf = &newbuf; \
if (scheme_setjmp(newbuf)) { \ if (scheme_setjmp(newbuf)) { \
scheme_pop_kill_action(); \
func(data); \ func(data); \
scheme_longjmp(*savebuf, 1); \ scheme_longjmp(*savebuf, 1); \
} else { } else {
@ -1146,6 +1147,8 @@ enum {
MZCONFIG_THREAD_SET, MZCONFIG_THREAD_SET,
MZCONFIG_THREAD_INIT_STACK_SIZE, MZCONFIG_THREAD_INIT_STACK_SIZE,
MZCONFIG_EXPAND_OBSERVE,
__MZCONFIG_BUILTIN_COUNT__ __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 "schpriv.h"
#include "schminc.h" #include "schminc.h"
#include "schexpobs.h"
#if defined(UNIX_LIMIT_STACK) || defined(UNIX_LIMIT_FDSET_SIZE) #if defined(UNIX_LIMIT_STACK) || defined(UNIX_LIMIT_FDSET_SIZE)
# include <signal.h> # include <signal.h>
@ -341,6 +342,7 @@ Scheme_Env *scheme_basic_env()
(Scheme_Object *)env); (Scheme_Object *)env);
scheme_init_memtrace(env); scheme_init_memtrace(env);
scheme_init_parameterization(env); scheme_init_parameterization(env);
scheme_init_expand_observe(env);
#ifndef DONT_USE_FOREIGN #ifndef DONT_USE_FOREIGN
scheme_init_foreign(env); scheme_init_foreign(env);
@ -3898,6 +3900,7 @@ local_lift_expr(int argc, Scheme_Object *argv[])
Scheme_Comp_Env *env, *orig_env; Scheme_Comp_Env *env, *orig_env;
Scheme_Object *id, *local_mark, *expr, *data, *vec, *id_sym; Scheme_Object *id, *local_mark, *expr, *data, *vec, *id_sym;
Scheme_Lift_Capture_Proc cp; Scheme_Lift_Capture_Proc cp;
Scheme_Object *orig_expr;
expr = argv[0]; expr = argv[0];
if (!SCHEME_STXP(expr)) if (!SCHEME_STXP(expr))
@ -3936,6 +3939,7 @@ local_lift_expr(int argc, Scheme_Object *argv[])
NULL, 1); NULL, 1);
expr = scheme_stx_activate_certs(expr); expr = scheme_stx_activate_certs(expr);
orig_expr = expr;
expr = cp(data, &id, expr, orig_env); 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); id = scheme_add_remove_mark(id, local_mark);
SCHEME_EXPAND_OBSERVE_LOCAL_LIFT(scheme_get_expand_observe(), id, orig_expr);
return id; return id;
} }
@ -3952,6 +3958,7 @@ local_lift_end_statement(int argc, Scheme_Object *argv[])
{ {
Scheme_Comp_Env *env; Scheme_Comp_Env *env;
Scheme_Object *local_mark, *expr, *pr; Scheme_Object *local_mark, *expr, *pr;
Scheme_Object *orig_expr;
expr = argv[0]; expr = argv[0];
if (!SCHEME_STXP(expr)) if (!SCHEME_STXP(expr))
@ -3977,10 +3984,13 @@ local_lift_end_statement(int argc, Scheme_Object *argv[])
" a run-time expression in a module declaration"); " a run-time expression in a module declaration");
expr = scheme_add_remove_mark(expr, local_mark); expr = scheme_add_remove_mark(expr, local_mark);
orig_expr = expr;
pr = scheme_make_pair(expr, SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3]); pr = scheme_make_pair(expr, SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3]);
SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3] = pr; SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3] = pr;
SCHEME_EXPAND_OBSERVE_LIFT_STATEMENT(scheme_get_expand_observe(), orig_expr);
return scheme_void; return scheme_void;
} }

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

@ -117,6 +117,7 @@
#include "schpriv.h" #include "schpriv.h"
#include "schrunst.h" #include "schrunst.h"
#include "schexpobs.h"
#ifdef USE_STACKAVAIL #ifdef USE_STACKAVAIL
#include <malloc.h> #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 *define_values_symbol, *letrec_values_symbol, *lambda_symbol;
static Scheme_Object *unknown_symbol, *void_link_symbol, *quote_symbol; static Scheme_Object *unknown_symbol, *void_link_symbol, *quote_symbol;
static Scheme_Object *letrec_syntaxes_symbol, *begin_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 *internal_define_symbol;
static Scheme_Object *module_symbol; static Scheme_Object *module_symbol;
@ -295,11 +296,11 @@ scheme_init_eval (Scheme_Env *env)
REGISTER_SO(quote_symbol); REGISTER_SO(quote_symbol);
REGISTER_SO(letrec_syntaxes_symbol); REGISTER_SO(letrec_syntaxes_symbol);
REGISTER_SO(begin_symbol); REGISTER_SO(begin_symbol);
REGISTER_SO(let_symbol); REGISTER_SO(let_values_symbol);
define_values_symbol = scheme_intern_symbol("define-values"); define_values_symbol = scheme_intern_symbol("define-values");
letrec_values_symbol = scheme_intern_symbol("letrec-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"); lambda_symbol = scheme_intern_symbol("lambda");
unknown_symbol = scheme_intern_symbol("unknown"); unknown_symbol = scheme_intern_symbol("unknown");
void_link_symbol = scheme_intern_symbol("-v"); 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_Thread *p = scheme_current_thread;
Scheme_Object *expr = (Scheme_Object *)p->ku.k.p1; 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; return (Scheme_Object *)wcm;
} }
static Scheme_Object *optimize_k() static Scheme_Object *optimize_k(void)
{ {
Scheme_Thread *p = scheme_current_thread; Scheme_Thread *p = scheme_current_thread;
Scheme_Object *expr = (Scheme_Object *)p->ku.k.p1; 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].resolve_module_ids = src[drec].resolve_module_ids;
dest[i].value_name = scheme_false; dest[i].value_name = scheme_false;
dest[i].certs = src[drec].certs; 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].depth = src[drec].depth;
dest[i].value_name = scheme_false; dest[i].value_name = scheme_false;
dest[i].certs = src[drec].certs; 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].resolve_module_ids = src[drec].resolve_module_ids;
lam[dlrec].value_name = scheme_false; lam[dlrec].value_name = scheme_false;
lam[dlrec].certs = src[drec].certs; lam[dlrec].certs = src[drec].certs;
lam[dlrec].observer = src[drec].observer;
} }
void scheme_merge_lambda_rec(Scheme_Compile_Info *src, int drec, 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.resolve_module_ids = !writeable && !genv->module;
rec.value_name = scheme_false; rec.value_name = scheme_false;
rec.certs = NULL; rec.certs = NULL;
rec.observer = NULL;
cenv = scheme_new_comp_env(genv, insp, SCHEME_TOPLEVEL_FRAME); 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; Scheme_Env *menv = NULL;
int need_cert; int need_cert;
SCHEME_EXPAND_OBSERVE_ENTER_CHECK(rec[drec].observer, first);
check_top: check_top:
*current_val = NULL; *current_val = NULL;
@ -3642,8 +3650,10 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
need_cert = 0; need_cert = 0;
} }
if (!SCHEME_STX_SYMBOLP(name)) if (!SCHEME_STX_SYMBOLP(name)) {
SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first);
return first; return first;
}
while (1) { while (1) {
@ -3671,6 +3681,7 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
*current_val = val; *current_val = val;
if (!val) { if (!val) {
SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first);
return first; return first;
} else if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) { } else if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) {
if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(val)), scheme_id_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 */ break; /* break to outer loop */
} }
} else { } else {
SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first);
return first; return first;
} }
} }
@ -3729,7 +3741,7 @@ compile_expand_macro_app(Scheme_Object *name, Scheme_Env *menv, Scheme_Object *m
if (!boundname) if (!boundname)
boundname = scheme_false; 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... */ /* 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"); scheme_signal_error("not syntax");
#endif #endif
if (rec[drec].comp) if (rec[drec].comp) {
scheme_default_compile_rec(rec, drec); scheme_default_compile_rec(rec, drec);
} else {
SCHEME_EXPAND_OBSERVE_VISIT(rec[drec].observer,form);
}
looking_for_top = 0; 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, rec[drec].certs, env->in_modidx,
&menv, &protected); &menv, &protected);
SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer,find_name);
if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
&& SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_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. */ /* 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; looking_for_top = 1;
} else { } else {
if (SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) { 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; return form;
else { } else {
scheme_wrong_syntax(NULL, NULL, form, "bad syntax"); scheme_wrong_syntax(NULL, NULL, form, "bad syntax");
return NULL; 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 */ /* Add a property to indicate that the name is protected */
find_name = scheme_stx_property(find_name, protected_symbol, scheme_true); 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 */ 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, erec1.certs, env->in_modidx,
&menv, NULL); &menv, NULL);
SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name);
if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
&& SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_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. */ /* 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 { } else {
Scheme_Syntax_Expander *f; Scheme_Syntax_Expander *f;
f = (Scheme_Syntax_Expander *)SCHEME_SYNTAX_EXP(var); 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, rec[drec].certs, env->in_modidx,
&menv, NULL); &menv, NULL);
SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name);
if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
&& SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_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. */ /* 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))) { || SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type))) {
if (SAME_OBJ(var, stop_expander)) { if (SAME_OBJ(var, stop_expander)) {
/* Return original: */ /* 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; return form;
} else if (rec[drec].comp && SAME_OBJ(var, normal)) { } else if (rec[drec].comp && SAME_OBJ(var, normal)) {
/* Skip creation of intermediate form */ /* Skip creation of intermediate form */
@ -4060,7 +4094,11 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
} else { } else {
Scheme_Syntax_Expander *f; Scheme_Syntax_Expander *f;
f = (Scheme_Syntax_Expander *)SCHEME_SYNTAX_EXP(var); 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 { } else {
name = stx; name = stx;
@ -4078,10 +4116,15 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
} }
macro: 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 */ 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); 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) if (rec[drec].comp)
goto top; goto top;
else { else {
@ -4089,9 +4132,11 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
--rec[drec].depth; --rec[drec].depth;
if (rec[drec].depth) if (rec[drec].depth)
goto top; goto top;
else else {
SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form);
return form; return form;
} }
}
} }
static Scheme_Object * static Scheme_Object *
@ -4175,7 +4220,7 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env,
scheme_dup_symbol_check(&r, NULL, n, "argument", name); scheme_dup_symbol_check(&r, NULL, n, "argument", name);
v = SCHEME_STX_CAR(rest); 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) if (last)
SCHEME_CDR(last) = v; SCHEME_CDR(last) = v;
else else
@ -4186,7 +4231,7 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env,
rest = SCHEME_STX_CDR(rest); rest = SCHEME_STX_CDR(rest);
} }
body = scheme_datum_to_syntax(cons(let_symbol, body = scheme_datum_to_syntax(cons(let_values_symbol,
cons(bindings, cons(bindings,
body)), body)),
form, form,
@ -4201,7 +4246,7 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env,
#if 0 #if 0
scheme_wrong_syntax(scheme_application_stx_string, NULL, form, scheme_wrong_syntax(scheme_application_stx_string, NULL, form,
"procedure application: bad ((lambda (...) ...) ...) syntax"); "procedure application: bad ((lambda (...) ...) ...) syntax");
return NULL return NULL;
#endif #endif
} }
} }
@ -4246,6 +4291,7 @@ app_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
static Scheme_Object * static Scheme_Object *
app_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) 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); 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 * static Scheme_Object *
datum_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) 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; return form;
} }
@ -4343,8 +4390,8 @@ top_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
static Scheme_Object * static Scheme_Object *
top_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) 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); check_top(scheme_expand_stx_string, form, env);
return form; 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); 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); 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); revl = icons(SCHEME_CAR(l), revl);
} }
for (; SCHEME_PAIRP(revl); revl = SCHEME_CDR(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(icons(SCHEME_CAR(revl), scheme_null),
icons(o, scheme_null))); icons(o, scheme_null)));
} }
@ -4517,16 +4564,23 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
Scheme_Compile_Info recs[2]; Scheme_Compile_Info recs[2];
DupCheckRecord r; DupCheckRecord r;
if (rec[drec].comp) if (rec[drec].comp) {
scheme_default_compile_rec(rec, drec); scheme_default_compile_rec(rec, drec);
} else {
SCHEME_EXPAND_OBSERVE_ENTER_BLOCK(rec[drec].observer, forms);
}
if (SCHEME_STX_NULLP(forms)) { if (SCHEME_STX_NULLP(forms)) {
if (rec[drec].comp) { if (rec[drec].comp) {
scheme_compile_rec_done_local(rec, drec); scheme_compile_rec_done_local(rec, drec);
return scheme_null; 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; return forms;
} }
}
rib = scheme_make_rename_rib(); rib = scheme_make_rename_rib();
ctx = scheme_alloc_object(); ctx = scheme_alloc_object();
@ -4538,14 +4592,25 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
try_again: try_again:
SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
if (!SCHEME_STX_PAIRP(forms)) { if (!SCHEME_STX_PAIRP(forms)) {
scheme_wrong_syntax(scheme_begin_stx_string, NULL, forms, "bad syntax"); scheme_wrong_syntax(scheme_begin_stx_string, NULL, forms, "bad syntax");
return NULL; return NULL;
} }
first = SCHEME_STX_CAR(forms); first = SCHEME_STX_CAR(forms);
{
/* Need to send both parts (before & after) of block rename */
Scheme_Object *old_first;
old_first = first;
first = scheme_add_rename_rib(first, rib); first = scheme_add_rename_rib(first, rib);
SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(rec[drec].observer,old_first,first);
}
{ {
Scheme_Object *gval, *result; Scheme_Object *gval, *result;
int more = 1; int more = 1;
@ -4560,6 +4625,9 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
/* Inline content */ /* Inline content */
Scheme_Object *orig_forms = forms; 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) if (scheme_stx_proper_list_length(first) < 0)
scheme_wrong_syntax(scheme_begin_stx_string, NULL, first, scheme_wrong_syntax(scheme_begin_stx_string, NULL, first,
"bad syntax (" IMPROPER_LIST_FORM ")"); "bad syntax (" IMPROPER_LIST_FORM ")");
@ -4577,6 +4645,8 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
forms = scheme_flatten_begin(first, forms); forms = scheme_flatten_begin(first, forms);
SCHEME_EXPAND_OBSERVE_SPLICE(rec[drec].observer, forms);
if (SCHEME_STX_NULLP(forms)) { if (SCHEME_STX_NULLP(forms)) {
scheme_wrong_syntax(scheme_begin_stx_string, NULL, first, scheme_wrong_syntax(scheme_begin_stx_string, NULL, first,
"bad syntax (empty form)"); "bad syntax (empty form)");
@ -4600,6 +4670,12 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
v = SCHEME_STX_CDR(first); 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)) if (!SCHEME_STX_PAIRP(v))
scheme_wrong_syntax(NULL, NULL, first, scheme_wrong_syntax(NULL, NULL, first,
"bad syntax (" IMPROPER_LIST_FORM ")"); "bad syntax (" IMPROPER_LIST_FORM ")");
@ -4687,9 +4763,9 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
expr = scheme_add_rename_rib(expr, rib); expr = scheme_add_rename_rib(expr, rib);
scheme_bind_syntaxes("local syntax definition", scheme_bind_syntaxes("local syntax definition",
names, expr, 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, new_env, new_env,
&pos, NULL); &pos);
} }
/* Extend shared rib with renamings */ /* 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)) { if (!SCHEME_STX_NULLP(result)) {
first = SCHEME_STX_CAR(result); first = SCHEME_STX_CAR(result);
first = scheme_datum_to_syntax(first, forms, forms, 0, 0); first = scheme_datum_to_syntax(first, forms, forms, 0, 0);
{
Scheme_Object *old_first;
old_first = first;
first = scheme_add_rename_rib(first, rib); 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); first = scheme_check_immediate_macro(first, env, rec, drec, 1, &gval, &xenv, ectx);
more = 1; more = 1;
if (NOT_SAME_OBJ(gval, scheme_define_values_syntax) if (NOT_SAME_OBJ(gval, scheme_define_values_syntax)
@ -4713,7 +4795,9 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
if (SAME_OBJ(gval, scheme_begin_syntax)) { if (SAME_OBJ(gval, scheme_begin_syntax)) {
/* Inline content */ /* Inline content */
result = SCHEME_STX_CDR(result); result = SCHEME_STX_CDR(result);
SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(rec[drec].observer);
result = scheme_flatten_begin(first, result); result = scheme_flatten_begin(first, result);
SCHEME_EXPAND_OBSERVE_SPLICE(rec[drec].observer,result);
goto define_try_again; goto define_try_again;
} else { } else {
/* Keep partially expanded `first': */ /* Keep partially expanded `first': */
@ -4750,16 +4834,18 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
} }
if (!more) { if (!more) {
if (rec[drec].comp) if (rec[drec].comp) {
result = scheme_compile_expr(result, env, rec, drec); result = scheme_compile_expr(result, env, rec, drec);
else { return scheme_make_immutable_pair(result, scheme_null);
} else {
if (rec[drec].depth > 0) if (rec[drec].depth > 0)
--rec[drec].depth; --rec[drec].depth;
if (rec[drec].depth) if (rec[drec].depth) {
result = scheme_expand_expr(result, env, rec, drec); 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 #endif
scheme_merge_compile_recs(rec, drec, recs, 2); scheme_merge_compile_recs(rec, drec, recs, 2);
return scheme_make_immutable_pair(first, forms);
} else { } 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; Scheme_Object *rest, *vname;
vname = rec[drec].value_name; 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); first = scheme_expand_expr(first, env, recs, 0);
rest = scheme_datum_to_syntax(rest, forms, forms, 0, -1); rest = scheme_datum_to_syntax(rest, forms, forms, 0, -1);
#if EMBEDDED_DEFINES_START_ANYWHERE
forms = scheme_compile_expand_block(rest, env, recs, 1); forms = scheme_compile_expand_block(rest, env, recs, 1);
return scheme_make_immutable_pair(first, forms);
#else #else
if (scheme_stx_proper_list_length(rest) < 0) Scheme_Object *newforms, *vname;
scheme_wrong_syntax(scheme_begin_stx_string, NULL, rest, "bad syntax");
forms = scheme_expand_list(rest, env, recs, 1); 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 #endif
} }
return scheme_make_immutable_pair(first, forms);
} }
Scheme_Object * 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; 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; return scheme_null;
}
if (scheme_stx_proper_list_length(form) < 0) { if (scheme_stx_proper_list_length(form) < 0) {
/* This is already checked for anything but application */ /* 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_Object *r, *p;
Scheme_Expand_Info erec1; Scheme_Expand_Info erec1;
SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
p = SCHEME_STX_CDR(fm); p = SCHEME_STX_CDR(fm);
scheme_init_expand_recs(erec, drec, &erec1, 1); 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); 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; data = ((Scheme_Native_Closure *)obj)->code;
/* Enlarge the runstack? This max_let_depth is in bytes instead of words. */ /* 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.p1 = (void *)obj;
p->ku.k.i1 = num_rands; p->ku.k.i1 = num_rands;
p->ku.k.p2 = (void *)rands; p->ku.k.p2 = (void *)rands;
@ -6502,6 +6613,7 @@ static void *expand_k(void)
erec1.depth = depth; erec1.depth = depth;
erec1.value_name = scheme_false; erec1.value_name = scheme_false;
erec1.certs = certs; erec1.certs = certs;
erec1.observer = scheme_get_expand_observe();
if (catch_lifts) if (catch_lifts)
scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false); 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 = icons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(env), 0, 0),
obj); obj);
obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 0, 0); obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 0, 0);
SCHEME_EXPAND_OBSERVE_LIFT_LOOP(erec1.observer,obj);
if (depth >= 0) if (depth >= 0)
break; break;
} else } 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) 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; 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; Scheme_Object *l, *local_mark, *renaming = NULL, *orig_l;
int cnt, pos, kind; int cnt, pos, kind;
int bad_sub_env = 0; int bad_sub_env = 0;
Scheme_Object *observer;
env = scheme_current_thread->current_local_env; 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; orig_l = l;
observer = scheme_get_expand_observe();
SCHEME_EXPAND_OBSERVE_ENTER_LOCAL(observer, l);
if (local_mark) { if (local_mark) {
/* Since we have an expression from local context, /* Since we have an expression from local context,
we need to remove the temporary mark... */ 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) if (renaming)
l = scheme_add_rename(l, renaming); l = scheme_add_rename(l, renaming);
SCHEME_EXPAND_OBSERVE_LOCAL_PRE(observer, l);
if (SCHEME_FALSEP(argv[2])) { if (SCHEME_FALSEP(argv[2])) {
Scheme_Object *xl, *gval; Scheme_Object *xl, *gval;
Scheme_Compile_Expand_Info drec[1]; 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); 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) if (renaming)
l = scheme_add_rename(l, 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); l = scheme_add_remove_mark(l, local_mark);
} }
SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, l);
return l; return l;
} }
@ -7137,6 +7261,14 @@ local_eval(int argc, Scheme_Object **argv)
stx_env->in_modidx = scheme_current_thread->current_local_modidx; stx_env->in_modidx = scheme_current_thread->current_local_modidx;
if (!SCHEME_FALSEP(expr)) { 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 */ /* Evaluate and bind syntaxes */
expr = scheme_add_remove_mark(expr, scheme_current_thread->current_local_mark); 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; pos = 0;
expr = scheme_add_rename_rib(expr, rib); expr = scheme_add_rename_rib(expr, rib);
scheme_bind_syntaxes("local syntax definition", names, expr, 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, stx_env, stx_env,
&pos, NULL); &pos);
} }
/* Extend shared rib with renamings */ /* 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); int *clean_start, int *add_sep);
#endif #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 */ /* local */
static Scheme_Object *path_p(int argc, Scheme_Object **argv); static Scheme_Object *path_p(int argc, Scheme_Object **argv);

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

@ -29,6 +29,7 @@
overflow and continuation-jump limits. */ overflow and continuation-jump limits. */
#include "schpriv.h" #include "schpriv.h"
#include "schexpobs.h"
/* The implementations of the time primitives, such as /* The implementations of the time primitives, such as
`current-seconds', vary a lot from platform to platform. */ `current-seconds', vary a lot from platform to platform. */
@ -2138,9 +2139,12 @@ Scheme_Object *
scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv, scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv,
Scheme_Object *rator, Scheme_Object *code, Scheme_Object *rator, Scheme_Object *code,
Scheme_Comp_Env *env, Scheme_Object *boundname, 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 *orig_code = code;
Scheme_Object *certs;
certs = rec[drec].certs;
if (SAME_TYPE(SCHEME_TYPE(rator), scheme_id_macro_type)) { if (SAME_TYPE(SCHEME_TYPE(rator), scheme_id_macro_type)) {
Scheme_Object *mark; Scheme_Object *mark;
@ -2184,12 +2188,16 @@ scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv,
mark = scheme_new_mark(); mark = scheme_new_mark();
code = scheme_add_remove_mark(code, 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, scheme_on_next_top(env, mark, boundname, certs,
menv, menv ? menv->link_midx : env->genv->link_midx); menv, menv ? menv->link_midx : env->genv->link_midx);
rands_vec[0] = code; rands_vec[0] = code;
code = scheme_apply(rator, 1, rands_vec); code = scheme_apply(rator, 1, rands_vec);
SCHEME_EXPAND_OBSERVE_MACRO_POST_X(rec[drec].observer, code);
if (!SCHEME_STXP(code)) { if (!SCHEME_STXP(code)) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%S: return value from syntax expander was not syntax: %V", "%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. */ jit_flush_code as an mprotect. */
#if defined(MZ_JIT_USE_MPROTECT) || defined(MZ_JIT_USE_WINDOWS_VIRTUAL_ALLOC) #if defined(MZ_JIT_USE_MPROTECT) || defined(MZ_JIT_USE_WINDOWS_VIRTUAL_ALLOC)
static unsigned long prev_page = 0, prev_length = 0; static unsigned long prev_page = 0, prev_length = 0;
long page, length; unsigned long page, length;
# ifdef PAGESIZE # ifdef PAGESIZE
const long page_size = PAGESIZE; const long page_size = PAGESIZE;
# else # else
static long page_size = -1; static unsigned long page_size = -1;
if (page_size == -1) { if (page_size == -1) {
# ifdef MZ_JIT_USE_WINDOWS_VIRTUAL_ALLOC # ifdef MZ_JIT_USE_WINDOWS_VIRTUAL_ALLOC
SYSTEM_INFO info; SYSTEM_INFO info;

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

@ -25,6 +25,7 @@
#include "schpriv.h" #include "schpriv.h"
#include "schmach.h" #include "schmach.h"
#include "schexpobs.h"
/* globals */ /* globals */
Scheme_Object *scheme_sys_wraps0; 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_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *top_level_require_resolve(Scheme_Object *data, Resolve_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 depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts); 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 depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts); 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; 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 depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts) int num_toplevels, int num_stxes, int num_lifts)
{ {
@ -3480,8 +3484,13 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
fm = scheme_add_rename(fm, tt_rn); fm = scheme_add_rename(fm, tt_rn);
if (!check_mb) { if (!check_mb) {
SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
fm = scheme_check_immediate_macro(fm, benv, rec, drec, 0, &mbval, NULL, NULL); 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 expansion is not the primitive `#%module-begin', add local one: */
if (!SAME_OBJ(mbval, modbeg_syntax)) { if (!SAME_OBJ(mbval, modbeg_syntax)) {
Scheme_Object *mb; Scheme_Object *mb;
@ -3592,6 +3601,7 @@ module_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *re
static Scheme_Object * static Scheme_Object *
module_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) 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) if (erec[drec].depth > 0)
erec[drec].depth++; 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 all_simple_renames = 1, et_all_simple_renames = 1, tt_all_simple_renames = 1;
int maybe_has_lifts = 0; int maybe_has_lifts = 0;
Scheme_Object *redef_modname; Scheme_Object *redef_modname;
Scheme_Object *observer;
if (!(env->flags & SCHEME_MODULE_FRAME)) if (!(env->flags & SCHEME_MODULE_FRAME))
scheme_wrong_syntax(NULL, NULL, form, "illegal use (not a module body)"); 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; maybe_has_lifts = 0;
/* Pass 1 */
observer = rec[drec].observer;
/* Partially expand all expressions, and process definitions, requires, /* Partially expand all expressions, and process definitions, requires,
and provides. Also, flatten top-level `begin' expressions: */ and provides. Also, flatten top-level `begin' expressions: */
for (fm = SCHEME_STX_CDR(form); !SCHEME_STX_NULLP(fm); ) { 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) { while (1) {
Scheme_Object *fst; Scheme_Object *fst;
SCHEME_EXPAND_OBSERVE_NEXT(observer);
e = SCHEME_STX_CAR(fm); e = SCHEME_STX_CAR(fm);
p = (maybe_has_lifts 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.depth = -1;
erec1.value_name = scheme_false; erec1.value_name = scheme_false;
erec1.certs = rec[drec].certs; erec1.certs = rec[drec].certs;
erec1.observer = rec[drec].observer;
e = scheme_expand_expr(e, xenv, &erec1, 0); 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_et_rn);
fm = scheme_named_map_1(NULL, add_a_rename, fm, post_ex_tt_rn); fm = scheme_named_map_1(NULL, add_a_rename, fm, post_ex_tt_rn);
fm = scheme_append(fst, scheme_make_pair(e, fm)); fm = scheme_append(fst, scheme_make_pair(e, fm));
SCHEME_EXPAND_OBSERVE_LIFT_LOOP(observer, fst);
} else { } else {
/* No lifts added... */ /* No lifts added... */
if (SCHEME_STX_PAIRP(e)) 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_et_rn);
e = scheme_add_rename(e, post_ex_tt_rn); e = scheme_add_rename(e, post_ex_tt_rn);
fm = scheme_flatten_begin(e, fm); fm = scheme_flatten_begin(e, fm);
SCHEME_EXPAND_OBSERVE_SPLICE(observer, fm);
if (SCHEME_STX_NULLP(fm)) { if (SCHEME_STX_NULLP(fm)) {
fm = scheme_frame_get_end_statement_lifts(xenv); fm = scheme_frame_get_end_statement_lifts(xenv);
fm = scheme_reverse(fm); fm = scheme_reverse(fm);
SCHEME_EXPAND_OBSERVE_LIFT_END_LOOP(observer, fm);
maybe_has_lifts = 0; maybe_has_lifts = 0;
if (SCHEME_NULLP(fm)) { if (SCHEME_NULLP(fm)) {
e = NULL; e = NULL;
@ -3989,6 +4010,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
/************ define-values *************/ /************ define-values *************/
Scheme_Object *vars, *val; Scheme_Object *vars, *val;
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(observer);
/* Create top-level vars */ /* Create top-level vars */
scheme_define_parse(e, &vars, &val, 0, env); scheme_define_parse(e, &vars, &val, 0, env);
@ -4034,6 +4058,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
vars = SCHEME_STX_CDR(vars); vars = SCHEME_STX_CDR(vars);
} }
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
normal = 1; normal = 1;
} else if (scheme_stx_module_eq(scheme_define_syntaxes_stx, fst, 0) } else if (scheme_stx_module_eq(scheme_define_syntaxes_stx, fst, 0)
|| scheme_stx_module_eq(define_for_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); 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); scheme_define_parse(e, &names, &code, 1, env);
if (SCHEME_STX_PAIRP(names) && SCHEME_STX_NULLP(SCHEME_STX_CDR(names))) 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.resolve_module_ids = 0;
mrec.value_name = NULL; mrec.value_name = NULL;
mrec.certs = rec[drec].certs; mrec.certs = rec[drec].certs;
mrec.observer = NULL;
if (!rec[drec].comp) { if (!rec[drec].comp) {
Scheme_Expand_Info erec1; 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.depth = -1;
erec1.value_name = boundname; erec1.value_name = boundname;
erec1.certs = rec[drec].certs; 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); code = scheme_expand_expr_lift_to_let(code, eenv, &erec1, 0);
} }
m = scheme_compile_expr_lift_to_let(code, eenv, &mrec, 0); m = scheme_compile_expr_lift_to_let(code, eenv, &mrec, 0);
@ -4163,11 +4194,16 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
scheme_make_pair(m, scheme_make_pair(code, scheme_null))); scheme_make_pair(m, scheme_make_pair(code, scheme_null)));
e = scheme_datum_to_syntax(m, e, e, 0, 2); e = scheme_datum_to_syntax(m, e, e, 0, 2);
} }
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
normal = 0; normal = 0;
} else if (scheme_stx_module_eq(require_stx, fst, 0)) { } else if (scheme_stx_module_eq(require_stx, fst, 0)) {
/************ require *************/ /************ require *************/
Scheme_Object *imods; Scheme_Object *imods;
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE(observer);
/* Add requires to renaming: */ /* Add requires to renaming: */
imods = parse_requires(e, self_modidx, env->genv, imods = parse_requires(e, self_modidx, env->genv,
rn, post_ex_rn, check_require_name, tables, 0, 1, rn, post_ex_rn, check_require_name, tables, 0, 1,
@ -4179,11 +4215,16 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
if (rec[drec].comp) if (rec[drec].comp)
e = NULL; e = NULL;
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
normal = 0; normal = 0;
} else if (scheme_stx_module_eq(require_for_syntax_stx, fst, 0)) { } else if (scheme_stx_module_eq(require_for_syntax_stx, fst, 0)) {
/************ require-for-syntax *************/ /************ require-for-syntax *************/
Scheme_Object *imods; Scheme_Object *imods;
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE_FOR_SYNTAX(observer);
scheme_prepare_exp_env(env->genv); scheme_prepare_exp_env(env->genv);
/* Add requires to renaming: */ /* 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) if (rec[drec].comp)
e = NULL; e = NULL;
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
normal = 0; normal = 0;
} else if (scheme_stx_module_eq(require_for_template_stx, fst, 0)) { } else if (scheme_stx_module_eq(require_for_template_stx, fst, 0)) {
/************ require-for-template *************/ /************ require-for-template *************/
Scheme_Object *imods; Scheme_Object *imods;
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE_FOR_TEMPLATE(observer);
scheme_prepare_template_env(env->genv); scheme_prepare_template_env(env->genv);
/* Add requires to renaming: */ /* 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) if (rec[drec].comp)
e = NULL; e = NULL;
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
normal = 0; normal = 0;
} else if (scheme_stx_module_eq(provide_stx, fst, 0)) { } else if (scheme_stx_module_eq(provide_stx, fst, 0)) {
/************ provide *************/ /************ provide *************/
@ -4230,6 +4278,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
Scheme_Object *l; Scheme_Object *l;
int protect_cnt = 0; 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) if (scheme_stx_proper_list_length(e) < 0)
scheme_wrong_syntax(NULL, e, form, "bad syntax (" IMPROPER_LIST_FORM ")"); 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) if (rec[drec].comp)
e = NULL; e = NULL;
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
normal = 0; normal = 0;
} else } else {
normal = 1; normal = 1;
}
} else } else
normal = 1; normal = 1;
} else } 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) { if (SCHEME_STX_NULLP(fm) && maybe_has_lifts) {
fm = scheme_frame_get_end_statement_lifts(xenv); fm = scheme_frame_get_end_statement_lifts(xenv);
fm = scheme_reverse(fm); fm = scheme_reverse(fm);
SCHEME_EXPAND_OBSERVE_LIFT_END_LOOP(observer, fm);
maybe_has_lifts = 0; maybe_has_lifts = 0;
} }
} }
/* first = a list of (cons semi-expanded-expression normal?) */ /* first = a list of (cons semi-expanded-expression normal?) */
/* Phase 2 */
SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer);
if (rec[drec].comp) { if (rec[drec].comp) {
/* Module manages its own prefix. That's how we get /* Module manages its own prefix. That's how we get
multiple instantiation of a module with "dynamic linking". */ 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); e = SCHEME_CAR(p);
normal = SCHEME_TRUEP(SCHEME_CDR(e)); normal = SCHEME_TRUEP(SCHEME_CDR(e));
e = SCHEME_CAR(e); e = SCHEME_CAR(e);
SCHEME_EXPAND_OBSERVE_NEXT(observer);
if (normal) { if (normal) {
l = (maybe_has_lifts l = (maybe_has_lifts
? scheme_frame_get_end_statement_lifts(cenv) ? 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 { } else {
first = p; first = p;
} }
SCHEME_EXPAND_OBSERVE_LIFT_LOOP(observer, first);
} }
} else { } else {
SCHEME_CAR(p) = e; 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 we're out of declarations, check for lifted-to-end: */
if (SCHEME_NULLP(p) && maybe_has_lifts) { if (SCHEME_NULLP(p) && maybe_has_lifts) {
p = scheme_frame_get_end_statement_lifts(cenv); p = scheme_frame_get_end_statement_lifts(cenv);
SCHEME_EXPAND_OBSERVE_LIFT_END_LOOP(observer, scheme_reverse(p));
p = scheme_reverse(p); p = scheme_reverse(p);
for (ll = p; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) { for (ll = p; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) {
e = scheme_make_pair(SCHEME_CAR(ll), scheme_true); 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 * static Scheme_Object *
module_begin_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) 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); return do_module_begin(form, env, erec, drec);
} }
@ -5800,7 +5864,8 @@ top_level_require_jit(Scheme_Object *data)
return 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 depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts) 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 * static Scheme_Object *
require_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) 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); 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 * static Scheme_Object *
require_for_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) 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); 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 * static Scheme_Object *
require_for_template_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) 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); 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 * static Scheme_Object *
provide_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) 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"); scheme_wrong_syntax(NULL, NULL, form, "not in module body");
return NULL; return NULL;
} }

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

@ -998,6 +998,7 @@ mark_comp_info {
gcMARK(i->value_name); gcMARK(i->value_name);
gcMARK(i->certs); gcMARK(i->certs);
gcMARK(i->observer);
size: size:
gcBYTES_TO_WORDS(sizeof(Scheme_Compile_Info)); 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_bufmode < 2) {
if (data->b.out_bufmax + len < TCP_BUFFER_SIZE) { if (data->b.out_bufmax + len < TCP_BUFFER_SIZE) {
memcpy(data->b.out_buffer + data->b.out_bufmax, s + offset, len); 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) { if (data->b.out_bufmode == 1) {
/* Check for newline */ /* Check for newline */
int i; 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; int i;
unsigned char *t = (unsigned char *)_t; 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]) if (s[i] || t[i])
return 1; return 1;
@ -5014,7 +5014,7 @@ static Scheme_Object *make_readtable(int argc, Scheme_Object **argv)
} else { } else {
scheme_hash_set(t->mapping, scheme_make_integer(ch), val); scheme_hash_set(t->mapping, scheme_make_integer(ch), val);
if (ch < 128) 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

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

@ -1514,6 +1514,7 @@ typedef struct Scheme_Compile_Expand_Info
int comp; int comp;
Scheme_Object *value_name; Scheme_Object *value_name;
Scheme_Object *certs; Scheme_Object *certs;
Scheme_Object *observer;
char dont_mark_local_use; char dont_mark_local_use;
char resolve_module_ids; char resolve_module_ids;
int depth; 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 *scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv,
Scheme_Object *f, Scheme_Object *code, Scheme_Object *f, Scheme_Object *code,
Scheme_Comp_Env *env, Scheme_Object *boundname, 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 *scheme_new_compilation_frame(int num_bindings, int flags,
Scheme_Comp_Env *env, Scheme_Object *certs); 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_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec); Scheme_Compile_Info *rec, int drec);
Scheme_Object *scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a, void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a,
Scheme_Env *exp_env, Scheme_Object *insp, Scheme_Object *certs, Scheme_Env *exp_env, Scheme_Object *insp,
Scheme_Compile_Expand_Info *rec, int drec,
Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env, Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env,
int *_pos, Scheme_Object *names_to_disappear); int *_pos);
int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env); int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env);
/* Resolving & linking */ /* Resolving & linking */

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

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 352 #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(syntax? p) "
"(if(list?(syntax-e p))" "(if(list?(syntax-e p))"
" #t" " #t"
"(let loop((l(syntax-e p)))" "(letrec-values(((loop)"
"(lambda(l)"
"(if(pair? l)" "(if(pair? l)"
"(loop(cdr l))" "(loop(cdr l))"
"(stx-list? l))))" "(stx-list? l)))))"
"(loop(syntax-e p))))"
"(if(pair? p)" "(if(pair? p)"
"(stx-list?(cdr p))" "(stx-list?(cdr p))"
" #f)))))" " #f)))))"
@ -56,8 +58,9 @@
"(lambda(e)" "(lambda(e)"
"(if(syntax? e)" "(if(syntax? e)"
"(syntax->list e)" "(syntax->list e)"
"(let((flat-end" "(let-values(((flat-end)"
"(let loop((l e))" "(letrec-values(((loop)"
"(lambda(l)"
"(if(null? l) " "(if(null? l) "
" #f" " #f"
"(if(pair? l)" "(if(pair? l)"
@ -65,14 +68,17 @@
"(if(syntax? l) " "(if(syntax? l) "
"(syntax->list l)" "(syntax->list l)"
" #f))))))" " #f))))))"
"(loop e))))"
"(if flat-end" "(if flat-end"
"(let loop((l e))" "(letrec-values(((loop)"
"(lambda(l)"
"(if(null? l) " "(if(null? l) "
" null" " null"
"(if(pair? l) " "(if(pair? l) "
"(cons(car l)(loop(cdr l)))" "(cons(car l)(loop(cdr l)))"
"(if(syntax? l) " "(if(syntax? l) "
" flat-end))))" " flat-end))))))"
"(loop e))"
" e)))))" " e)))))"
"(define-values(stx-vector?)" "(define-values(stx-vector?)"
"(lambda(p len)" "(lambda(p len)"
@ -114,7 +120,8 @@
"(define-values(split-stx-list)" "(define-values(split-stx-list)"
"(lambda(s n prop?)" "(lambda(s n prop?)"
"(let-values(((pre post m)" "(let-values(((pre post m)"
"(let loop((s s))" "(letrec-values(((loop)"
"(lambda(s)"
"(if(stx-pair? s)" "(if(stx-pair? s)"
"(let-values(((pre post m)(loop(stx-cdr s))))" "(let-values(((pre post m)(loop(stx-cdr s))))"
"(if(< m n)" "(if(< m n)"
@ -127,6 +134,7 @@
"(if(stx-null? s)" "(if(stx-null? s)"
" -inf.0" " -inf.0"
" 1)))))))" " 1)))))))"
"(loop s))))"
"(values pre post(= m n)))))" "(values pre post(= m n)))))"
"(provide identifier? stx-null? stx-null/#f stx-pair? stx-list?" "(provide identifier? stx-null? stx-null/#f stx-pair? stx-list?"
" stx-car stx-cdr stx->list" " stx-car stx-cdr stx->list"
@ -138,15 +146,153 @@
EVAL_ONE_STR( EVAL_ONE_STR(
"(module #%qq-and-or #%kernel" "(module #%qq-and-or #%kernel"
"(require-for-syntax #%stx #%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)" "(define-values(qq-append)"
"(lambda(a b)" "(lambda(a b)"
"(if(list? a)" "(if(list? a)"
"(append a b)" "(append a b)"
" (raise-type-error 'unquote-splicing \"proper list\" a))))" " (raise-type-error 'unquote-splicing \"proper list\" a))))"
"(define-syntaxes(quasiquote)" "(define-syntaxes(quasiquote)"
"(let((here(quote-syntax here)) " "(let-values(((here)(quote-syntax here)) "
"(unquote-stx(quote-syntax unquote))" "((unquote-stx)(quote-syntax unquote))"
"(unquote-splicing-stx(quote-syntax unquote-splicing)))" "((unquote-splicing-stx)(quote-syntax unquote-splicing)))"
"(lambda(in-form)" "(lambda(in-form)"
"(if(identifier? in-form)" "(if(identifier? in-form)"
" (raise-syntax-error #f \"bad syntax\" in-form))" " (raise-syntax-error #f \"bad syntax\" in-form))"
@ -308,11 +454,11 @@
" form)" " form)"
" in-form)))))" " in-form)))))"
"(define-syntaxes(and)" "(define-syntaxes(and)"
"(let((here(quote-syntax here)))" "(let-values(((here)(quote-syntax here)))"
"(lambda(x)" "(lambda(x)"
"(if(not(stx-list? x))" "(if(not(stx-list? x))"
" (raise-syntax-error #f \"bad syntax\" x))" " (raise-syntax-error #f \"bad syntax\" x))"
"(let((e(stx-cdr x)))" "(let-values(((e)(stx-cdr x)))"
"(if(stx-null? e)" "(if(stx-null? e)"
"(quote-syntax #t)" "(quote-syntax #t)"
"(if(if(stx-pair? e)" "(if(if(stx-pair? e)"
@ -328,11 +474,11 @@
"(quote-syntax #f))" "(quote-syntax #f))"
" x)))))))" " x)))))))"
"(define-syntaxes(or)" "(define-syntaxes(or)"
"(let((here(quote-syntax here)))" "(let-values(((here)(quote-syntax here)))"
"(lambda(x)" "(lambda(x)"
"(if(identifier? x)" "(if(identifier? x)"
" (raise-syntax-error #f \"bad syntax\" x))" " (raise-syntax-error #f \"bad syntax\" x))"
"(let((e(stx-cdr x)))" "(let-values(((e)(stx-cdr x)))"
"(if(stx-null? e) " "(if(stx-null? e) "
"(quote-syntax #f)" "(quote-syntax #f)"
"(if(if(stx-pair? e)" "(if(if(stx-pair? e)"
@ -340,7 +486,7 @@
" #f)" " #f)"
"(stx-car e)" "(stx-car e)"
"(if(stx-list? e)" "(if(stx-list? e)"
"(let((tmp 'or-part))" "(let-values(((tmp) 'or-part))"
"(datum->syntax-object" "(datum->syntax-object"
" here" " here"
"(list(quote-syntax let)(list" "(list(quote-syntax let)(list"
@ -357,7 +503,8 @@
" #f" " #f"
" \"bad syntax\"" " \"bad syntax\""
" x))))))))" " x))))))))"
"(provide quasiquote and or))" "(provide let let* letrec"
" quasiquote and or))"
); );
EVAL_ONE_STR( EVAL_ONE_STR(
"(module #%cond #%kernel" "(module #%cond #%kernel"
@ -401,7 +548,7 @@
" #t " " #t "
" test))" " test))"
"(gen(gensym)))" "(gen(gensym)))"
" `(,(quote-syntax let)((,gen ,test))" " `(,(quote-syntax let-values)(((,gen) ,test))"
"(,(quote-syntax if) ,gen" "(,(quote-syntax if) ,gen"
"(,(stx-car(stx-cdr value)) ,gen)" "(,(stx-car(stx-cdr value)) ,gen)"
" ,(loop rest #f))))" " ,(loop rest #f))))"
@ -414,7 +561,7 @@
"(cons(quote-syntax begin) value))" "(cons(quote-syntax begin) value))"
"(if(stx-null? value)" "(if(stx-null? value)"
"(let((gen(gensym)))" "(let((gen(gensym)))"
" `(,(quote-syntax let)((,gen ,test))" " `(,(quote-syntax let-values)(((,gen) ,test))"
"(,(quote-syntax if) ,gen ,gen ,(loop rest #f))))" "(,(quote-syntax if) ,gen ,gen ,(loop rest #f))))"
"(list" "(list"
"(quote-syntax if) test" "(quote-syntax if) test"
@ -696,7 +843,7 @@
" ,defined-names" " ,defined-names"
" ,(let((core(make-core name(and inspector 'inspector) super-id/struct: field-names)))" " ,(let((core(make-core name(and inspector 'inspector) super-id/struct: field-names)))"
"(if inspector" "(if inspector"
" `(let((inspector ,inspector))" " `(let-values(((inspector) ,inspector))"
"(if(if inspector(not(inspector? inspector)) #f)" "(if(if inspector(not(inspector? inspector)) #f)"
" (raise-type-error 'define-struct \"inspector or #f\" inspector))" " (raise-type-error 'define-struct \"inspector or #f\" inspector))"
" ,core)" " ,core)"
@ -715,7 +862,7 @@
"(require #%stx #%qq-and-or #%cond #%define-et-al)" "(require #%stx #%qq-and-or #%cond #%define-et-al)"
"(provide(all-from #%qq-and-or)" "(provide(all-from #%qq-and-or)"
"(all-from #%cond)" "(all-from #%cond)"
"(all-from-except #%define-et-al)))" "(all-from #%define-et-al)))"
); );
EVAL_ONE_STR( EVAL_ONE_STR(
"(module #%sc #%kernel" "(module #%sc #%kernel"
@ -1680,7 +1827,7 @@
); );
EVAL_ONE_STR( EVAL_ONE_STR(
"(module #%stxloc #%kernel" "(module #%stxloc #%kernel"
"(require #%stxcase #%define-et-al)" "(require #%qq-and-or #%stxcase #%define-et-al)"
"(require-for-syntax #%kernel #%stxcase #%sc)" "(require-for-syntax #%kernel #%stxcase #%sc)"
"(-define-syntax syntax-case*" "(-define-syntax syntax-case*"
"(lambda(stx)" "(lambda(stx)"
@ -1695,7 +1842,7 @@
"(-define loc-insp(current-code-inspector))" "(-define loc-insp(current-code-inspector))"
"(-define(relocate loc stx)" "(-define(relocate loc stx)"
"(if(syntax-source loc)" "(if(syntax-source loc)"
"(let((new-stx(datum->syntax-object" "(let-values(((new-stx)(datum->syntax-object"
" stx" " stx"
"(syntax-e stx)" "(syntax-e stx)"
" loc)))" " loc)))"

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

@ -82,10 +82,12 @@
(if (syntax? p) (if (syntax? p)
(if (list? (syntax-e p)) (if (list? (syntax-e p))
#t #t
(let loop ([l (syntax-e p)]) (letrec-values ([(loop)
(lambda (l)
(if (pair? l) (if (pair? l)
(loop (cdr l)) (loop (cdr l))
(stx-list? l)))) (stx-list? l)))])
(loop (syntax-e p))))
(if (pair? p) (if (pair? p)
(stx-list? (cdr p)) (stx-list? (cdr p))
#f))))) #f)))))
@ -109,8 +111,9 @@
(lambda (e) (lambda (e)
(if (syntax? e) (if (syntax? e)
(syntax->list e) (syntax->list e)
(let ([flat-end (let-values ([(flat-end)
(let loop ([l e]) (letrec-values ([(loop)
(lambda (l)
(if (null? l) (if (null? l)
#f #f
(if (pair? l) (if (pair? l)
@ -118,15 +121,18 @@
(if (syntax? l) (if (syntax? l)
(syntax->list l) (syntax->list l)
#f))))]) #f))))])
(loop e))])
(if flat-end (if flat-end
;; flatten ;; flatten
(let loop ([l e]) (letrec-values ([(loop)
(lambda (l)
(if (null? l) (if (null? l)
null null
(if (pair? l) (if (pair? l)
(cons (car l) (loop (cdr l))) (cons (car l) (loop (cdr l)))
(if (syntax? l) (if (syntax? l)
flat-end)))) flat-end))))])
(loop e))
e))))) e)))))
;; a syntax vector? ;; a syntax vector?
@ -190,7 +196,8 @@
(define-values (split-stx-list) (define-values (split-stx-list)
(lambda (s n prop?) (lambda (s n prop?)
(let-values ([(pre post m) (let-values ([(pre post m)
(let loop ([s s]) (letrec-values ([(loop)
(lambda (s)
(if (stx-pair? s) (if (stx-pair? s)
(let-values ([(pre post m) (loop (stx-cdr s))]) (let-values ([(pre post m) (loop (stx-cdr s))])
(if (< m n) (if (< m n)
@ -203,6 +210,7 @@
(if (stx-null? s) (if (stx-null? s)
-inf.0 -inf.0
1)))))]) 1)))))])
(loop s))])
(values pre post (= m n))))) (values pre post (= m n)))))
(provide identifier? stx-null? stx-null/#f stx-pair? stx-list? (provide identifier? stx-null? stx-null/#f stx-pair? stx-list?
@ -218,6 +226,145 @@
(module #%qq-and-or #%kernel (module #%qq-and-or #%kernel
(require-for-syntax #%stx #%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) (define-values (qq-append)
(lambda (a b) (lambda (a b)
(if (list? a) (if (list? a)
@ -225,9 +372,9 @@
(raise-type-error 'unquote-splicing "proper list" a)))) (raise-type-error 'unquote-splicing "proper list" a))))
(define-syntaxes (quasiquote) (define-syntaxes (quasiquote)
(let ([here (quote-syntax here)] ; id with module bindings, but not lexical (let-values ([(here) (quote-syntax here)] ; id with module bindings, but not lexical
[unquote-stx (quote-syntax unquote)] [(unquote-stx) (quote-syntax unquote)]
[unquote-splicing-stx (quote-syntax unquote-splicing)]) [(unquote-splicing-stx) (quote-syntax unquote-splicing)])
(lambda (in-form) (lambda (in-form)
(if (identifier? in-form) (if (identifier? in-form)
(raise-syntax-error #f "bad syntax" in-form)) (raise-syntax-error #f "bad syntax" in-form))
@ -390,11 +537,11 @@
in-form))))) in-form)))))
(define-syntaxes (and) (define-syntaxes (and)
(let ([here (quote-syntax here)]) (let-values ([(here) (quote-syntax here)])
(lambda (x) (lambda (x)
(if (not (stx-list? x)) (if (not (stx-list? x))
(raise-syntax-error #f "bad syntax" x)) (raise-syntax-error #f "bad syntax" x))
(let ([e (stx-cdr x)]) (let-values ([(e) (stx-cdr x)])
(if (stx-null? e) (if (stx-null? e)
(quote-syntax #t) (quote-syntax #t)
(if (if (stx-pair? e) (if (if (stx-pair? e)
@ -411,11 +558,11 @@
x))))))) x)))))))
(define-syntaxes (or) (define-syntaxes (or)
(let ([here (quote-syntax here)]) (let-values ([(here) (quote-syntax here)])
(lambda (x) (lambda (x)
(if (identifier? x) (if (identifier? x)
(raise-syntax-error #f "bad syntax" x)) (raise-syntax-error #f "bad syntax" x))
(let ([e (stx-cdr x)]) (let-values ([(e) (stx-cdr x)])
(if (stx-null? e) (if (stx-null? e)
(quote-syntax #f) (quote-syntax #f)
(if (if (stx-pair? e) (if (if (stx-pair? e)
@ -423,7 +570,7 @@
#f) #f)
(stx-car e) (stx-car e)
(if (stx-list? e) (if (stx-list? e)
(let ([tmp 'or-part]) (let-values ([(tmp) 'or-part])
(datum->syntax-object (datum->syntax-object
here here
(list (quote-syntax let) (list (list (quote-syntax let) (list
@ -441,7 +588,8 @@
"bad syntax" "bad syntax"
x)))))))) x))))))))
(provide quasiquote and or)) (provide let let* letrec
quasiquote and or))
;;---------------------------------------------------------------------- ;;----------------------------------------------------------------------
;; cond ;; cond
@ -488,7 +636,7 @@
#t #t
test)] test)]
[gen (gensym)]) [gen (gensym)])
`(,(quote-syntax let) ([,gen ,test]) `(,(quote-syntax let-values) ([(,gen) ,test])
(,(quote-syntax if) ,gen (,(quote-syntax if) ,gen
(,(stx-car (stx-cdr value)) ,gen) (,(stx-car (stx-cdr value)) ,gen)
,(loop rest #f)))) ,(loop rest #f))))
@ -503,7 +651,7 @@
(cons (quote-syntax begin) value)) (cons (quote-syntax begin) value))
(if (stx-null? value) (if (stx-null? value)
(let ([gen (gensym)]) (let ([gen (gensym)])
`(,(quote-syntax let) ([,gen ,test]) `(,(quote-syntax let-values) ([(,gen) ,test])
(,(quote-syntax if) ,gen ,gen ,(loop rest #f)))) (,(quote-syntax if) ,gen ,gen ,(loop rest #f))))
(list (list
(quote-syntax if) test (quote-syntax if) test
@ -816,7 +964,7 @@
,defined-names ,defined-names
,(let ([core (make-core name (and inspector 'inspector) super-id/struct: field-names)]) ,(let ([core (make-core name (and inspector 'inspector) super-id/struct: field-names)])
(if inspector (if inspector
`(let ([inspector ,inspector]) `(let-values ([(inspector) ,inspector])
(if (if inspector (not (inspector? inspector)) #f) (if (if inspector (not (inspector? inspector)) #f)
(raise-type-error 'define-struct "inspector or #f" inspector)) (raise-type-error 'define-struct "inspector or #f" inspector))
,core) ,core)
@ -839,7 +987,7 @@
(provide (all-from #%qq-and-or) (provide (all-from #%qq-and-or)
(all-from #%cond) (all-from #%cond)
(all-from-except #%define-et-al))) (all-from #%define-et-al)))
;;---------------------------------------------------------------------- ;;----------------------------------------------------------------------
;; pattern-matching utilities ;; pattern-matching utilities
@ -1979,7 +2127,7 @@
;; syntax/loc ;; syntax/loc
(module #%stxloc #%kernel (module #%stxloc #%kernel
(require #%stxcase #%define-et-al) (require #%qq-and-or #%stxcase #%define-et-al)
(require-for-syntax #%kernel #%stxcase #%sc) (require-for-syntax #%kernel #%stxcase #%sc)
;; Regular syntax-case ;; Regular syntax-case
@ -1999,7 +2147,7 @@
(-define loc-insp (current-code-inspector)) (-define loc-insp (current-code-inspector))
(-define (relocate loc stx) (-define (relocate loc stx)
(if (syntax-source loc) (if (syntax-source loc)
(let ([new-stx (datum->syntax-object (let-values ([(new-stx) (datum->syntax-object
stx stx
(syntax-e stx) (syntax-e stx)
loc)]) loc)])

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

@ -30,6 +30,7 @@
#include "schpriv.h" #include "schpriv.h"
#include "schmach.h" #include "schmach.h"
#include "schexpobs.h"
/* globals */ /* globals */
Scheme_Object *scheme_define_values_syntax, *scheme_define_syntaxes_syntax; 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 *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_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 *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_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_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); 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 *begin0_jit(Scheme_Object *data);
static Scheme_Object *bangboxvalue_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 *expand_lam(int argc, Scheme_Object **argv);
static Scheme_Object *write_let_value(Scheme_Object *obj); static Scheme_Object *write_let_value(Scheme_Object *obj);
@ -196,9 +188,6 @@ static Scheme_Object *read_case_lambda(Scheme_Object *obj);
/* symbols */ /* symbols */
static Scheme_Object *lambda_symbol; 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 *letrec_values_symbol;
static Scheme_Object *let_star_values_symbol; static Scheme_Object *let_star_values_symbol;
static Scheme_Object *let_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(scheme_compiled_void_code);
REGISTER_SO(lambda_symbol); REGISTER_SO(lambda_symbol);
REGISTER_SO(letrec_symbol);
REGISTER_SO(let_star_symbol);
REGISTER_SO(let_symbol);
REGISTER_SO(letrec_values_symbol); REGISTER_SO(letrec_values_symbol);
REGISTER_SO(let_star_values_symbol); REGISTER_SO(let_star_values_symbol);
REGISTER_SO(let_values_symbol); REGISTER_SO(let_values_symbol);
@ -247,10 +233,6 @@ scheme_init_syntax (Scheme_Env *env)
lambda_symbol = scheme_intern_symbol("lambda"); 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"); letrec_values_symbol = scheme_intern_symbol("letrec-values");
let_star_values_symbol = scheme_intern_symbol("let*-values"); let_star_values_symbol = scheme_intern_symbol("let*-values");
let_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), case_lambda_expand),
env); 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_add_global_keyword("let-values",
scheme_make_compiled_syntax(let_values_syntax, scheme_make_compiled_syntax(let_values_syntax,
let_values_expand), 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_Object *args, *body, *fn;
Scheme_Comp_Env *newenv; Scheme_Comp_Env *newenv;
SCHEME_EXPAND_OBSERVE_PRIM_LAMBDA(erec[drec].observer);
lambda_check(form); lambda_check(form);
args = SCHEME_STX_CDR(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); body = scheme_add_env_renames(body, newenv, env);
args = scheme_add_env_renames(args, newenv, env); /* for re-expansion */ 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); 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_Object *var, *val, *fn, *boundname;
SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(erec[drec].observer);
scheme_define_parse(form, &var, &val, 0, env); scheme_define_parse(form, &var, &val, 0, env);
env = scheme_no_defines(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_Object *rest;
SCHEME_EXPAND_OBSERVE_PRIM_QUOTE(erec[drec].observer);
rest = SCHEME_STX_CDR(form); rest = SCHEME_STX_CDR(form);
if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest)))) 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; int len;
Scheme_Expand_Info recs[3]; Scheme_Expand_Info recs[3];
SCHEME_EXPAND_OBSERVE_PRIM_IF(erec[drec].observer);
len = check_form(form, form); len = check_form(form, form);
if (!(((len == 3) || (len == 4)))) if (!(((len == 3) || (len == 4))))
bad_form(form, len); bad_form(form, len);
if (len == 3) {
SCHEME_EXPAND_OBSERVE_NEXT_GROUP(erec[drec].observer);
}
env = scheme_no_defines(env); env = scheme_no_defines(env);
boundname = scheme_check_name_property(form, erec[drec].value_name); 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_STX_CAR(rest);
test = scheme_expand_expr(test, env, recs, 0); test = scheme_expand_expr(test, env, recs, 0);
SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
rest = SCHEME_STX_CDR(rest); rest = SCHEME_STX_CDR(rest);
thenp = SCHEME_STX_CAR(rest); thenp = SCHEME_STX_CAR(rest);
thenp = scheme_expand_expr(thenp, env, recs, 1); thenp = scheme_expand_expr(thenp, env, recs, 1);
rest = SCHEME_STX_CDR(rest); rest = SCHEME_STX_CDR(rest);
if (!SCHEME_STX_NULLP(rest)) { if (!SCHEME_STX_NULLP(rest)) {
SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
elsep = SCHEME_STX_CAR(rest); elsep = SCHEME_STX_CAR(rest);
elsep = scheme_expand_expr(elsep, env, recs, 2); elsep = scheme_expand_expr(elsep, env, recs, 2);
rest = icons(elsep, scheme_null); 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; int len;
Scheme_Expand_Info recs[3]; Scheme_Expand_Info recs[3];
SCHEME_EXPAND_OBSERVE_PRIM_WCM(erec[drec].observer);
len = check_form(form, form); len = check_form(form, form);
if (len != 4) if (len != 4)
bad_form(form, len); 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); expr = SCHEME_STX_CAR(form);
key = scheme_expand_expr(key, env, recs, 0); key = scheme_expand_expr(key, env, recs, 0);
SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
val = scheme_expand_expr(val, env, recs, 1); val = scheme_expand_expr(val, env, recs, 1);
SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
expr = scheme_expand_expr(expr, env, recs, 2); expr = scheme_expand_expr(expr, env, recs, 2);
fn = SCHEME_STX_CAR(orig_form); 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)) { if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) {
/* Redirect to a macro? */ /* Redirect to a macro? */
if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_set_macro_type)) { 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); return scheme_compile_expr(form, env, rec, drec);
} else if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) { } 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_Env *menv = NULL;
Scheme_Object *name, *var, *fn, *rhs, *find_name; Scheme_Object *name, *var, *fn, *rhs, *find_name;
int l; int l;
SCHEME_EXPAND_OBSERVE_PRIM_SET(erec[drec].observer);
l = check_form(form, form); l = check_form(form, form);
if (l != 3) if (l != 3)
bad_form(form, l); bad_form(form, l);
@ -1597,10 +1588,17 @@ set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec,
erec[drec].certs, env->in_modidx, erec[drec].certs, env->in_modidx,
&menv, NULL); &menv, NULL);
SCHEME_EXPAND_OBSERVE_RESOLVE(erec[drec].observer, find_name);
if ((erec[drec].depth != 0) && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { if ((erec[drec].depth != 0) && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) {
/* Redirect to a macro? */ /* Redirect to a macro? */
if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_set_macro_type)) { 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) if (erec[drec].depth > 0)
erec[drec].depth--; 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_wrong_syntax(NULL, name, form, "cannot mutate syntax identifier");
} }
SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
fn = SCHEME_STX_CAR(form); fn = SCHEME_STX_CAR(form);
rhs = SCHEME_STX_CDR(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; erec[drec].value_name = name;
rhs = scheme_expand_expr(rhs, env, erec, drec);
return scheme_datum_to_syntax(icons(fn, return scheme_datum_to_syntax(icons(fn,
icons(find_name, icons(find_name,
icons(scheme_expand_expr(rhs, env, erec, drec), icons(rhs, scheme_null))),
scheme_null))),
form, form,
form, form,
0, 2); 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_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 = SCHEME_STX_CAR(form);
first = icons(first, scheme_null); first = icons(first, scheme_null);
last = first; last = first;
@ -2177,6 +2180,8 @@ case_lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info
Scheme_Object *line_form; Scheme_Object *line_form;
Scheme_Comp_Env *newenv; Scheme_Comp_Env *newenv;
SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
line_form = SCHEME_STX_CAR(form); line_form = SCHEME_STX_CAR(form);
case_lambda_check_line(line_form, orig_form, env); case_lambda_check_line(line_form, orig_form, env);
@ -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); body = scheme_add_env_renames(body, newenv, env);
args = scheme_add_env_renames(args, 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; 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, const char *formname, int letrec, int multi, int letstar,
Scheme_Comp_Env *env_already) Scheme_Comp_Env *env_already)
{ {
int named, partial;
Scheme_Object *vars, *body, *first, *last, *name, *v, *vs, *vlist, *boundname; Scheme_Object *vars, *body, *first, *last, *name, *v, *vs, *vlist, *boundname;
Scheme_Comp_Env *use_env, *env; Scheme_Comp_Env *use_env, *env;
Scheme_Expand_Info erec1; 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); 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)) if (!SCHEME_STX_PAIRP(vars))
scheme_wrong_syntax(NULL, NULL, form, NULL); 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); a = SCHEME_STX_CAR(vars);
vr = SCHEME_STX_CDR(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); first = scheme_datum_to_syntax(first, form, scheme_sys_wraps(origenv), 0, 0);
if (SCHEME_STX_NULLP(vr)) { if (SCHEME_STX_NULLP(vr)) {
/* Don't create redundant empty let form */ /* Don't create redundant empty let form */
} else { } 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); last = scheme_datum_to_syntax(last, form, scheme_sys_wraps(origenv), 0, 0);
body = icons(icons(last, icons(vr, body)), body = icons(icons(last, icons(vr, body)),
scheme_null); scheme_null);
@ -3449,7 +3445,7 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
body = icons(first, icons(scheme_null, body)); 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); first = SCHEME_STX_CAR(form);
body = scheme_stx_track(body, form, first); body = scheme_stx_track(body, form, first);
@ -3467,26 +3463,6 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
/* Note: no more letstar handling needed after this point */ /* 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); scheme_begin_dup_symbol_check(&r, origenv);
vlist = scheme_null; 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); name = SCHEME_STX_CAR(v);
if (multi) { {
DupCheckRecord r2; DupCheckRecord r2;
Scheme_Object *names = name; Scheme_Object *names = name;
scheme_begin_dup_symbol_check(&r2, origenv); 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)) if (!SCHEME_STX_NULLP(names))
scheme_wrong_syntax(NULL, names, form, NULL); 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); vs = SCHEME_STX_CDR(vs);
@ -3535,48 +3507,72 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
use_env = origenv; use_env = origenv;
if (env_already) if (env_already)
env = env_already; env = env_already;
else if (partial)
env = origenv;
else 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) if (letrec)
use_env = env; use_env = env;
/* Pass 1: Rename */
first = last = NULL; first = last = NULL;
vs = vars; vs = vars;
while (SCHEME_STX_PAIRP(vars)) { while (SCHEME_STX_PAIRP(vars)) {
Scheme_Object *rhs, *rhs_name; Scheme_Object *rhs;
v = SCHEME_STX_CAR(vars); v = SCHEME_STX_CAR(vars);
/* Make sure names gets their own renames: */ /* Make sure names gets their own renames: */
name = SCHEME_STX_CAR(v); name = SCHEME_STX_CAR(v);
if (!multi) {
if (!partial)
name = scheme_add_env_renames(name, env, origenv); name = scheme_add_env_renames(name, env, origenv);
name = icons(name, scheme_null);
} else {
if (!partial)
name = scheme_add_env_renames(name, env, origenv);
}
rhs = SCHEME_STX_CDR(v); rhs = SCHEME_STX_CDR(v);
rhs = SCHEME_STX_CAR(rhs); 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))) { if (SCHEME_STX_PAIRP(name) && SCHEME_STX_NULLP(SCHEME_STX_CDR(name))) {
rhs_name = SCHEME_STX_CAR(name); rhs_name = SCHEME_STX_CAR(name);
} else { } else {
rhs_name = scheme_false; rhs_name = scheme_false;
} }
if (!partial) {
scheme_init_expand_recs(erec, drec, &erec1, 1); scheme_init_expand_recs(erec, drec, &erec1, 1);
erec1.value_name = rhs_name; erec1.value_name = rhs_name;
rhs = scheme_expand_expr(rhs, use_env, &erec1, 0); 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 = scheme_datum_to_syntax(icons(name, icons(rhs, scheme_null)), v, v, 0, 1);
v = icons(v, scheme_null); 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); vars = SCHEME_STX_CDR(vars);
} }
/* End Pass 2 */
if (!SCHEME_STX_NULLP(vars)) if (!SCHEME_STX_NULLP(vars))
scheme_wrong_syntax(NULL, vars, form, NULL); scheme_wrong_syntax(NULL, vars, form, NULL);
@ -3599,99 +3597,39 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
first = scheme_datum_to_syntax(first, vs, vs, 0, 1); first = scheme_datum_to_syntax(first, vs, vs, 0, 1);
body = scheme_datum_to_syntax(body, form, form, 0, 0); SCHEME_EXPAND_OBSERVE_NEXT_GROUP(erec[drec].observer);
if (!partial) {
body = scheme_add_env_renames(body, env, origenv);
scheme_init_expand_recs(erec, drec, &erec1, 1); scheme_init_expand_recs(erec, drec, &erec1, 1);
erec1.value_name = erec[drec].value_name; erec1.value_name = erec[drec].value_name;
body = scheme_expand_block(body, env, &erec1, 0); body = scheme_expand_block(body, env, &erec1, 0);
}
if (multi)
v = SCHEME_STX_CAR(form); 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);
v = icons(v, icons(first, body)); v = icons(v, icons(first, body));
v = scheme_datum_to_syntax(v, form, form, 0, 2);
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);
}
return v; 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 * static Scheme_Object *
let_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) 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 * static Scheme_Object *
let_star_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) 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 * static Scheme_Object *
letrec_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) 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 * static Scheme_Object *
let_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, 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); 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 */ /* begin, begin0, implicit begins */
/**********************************************************************/ /**********************************************************************/
@ -4103,8 +3938,11 @@ do_begin_expand(char *name,
rest = SCHEME_STX_CDR(form); rest = SCHEME_STX_CDR(form);
if (SCHEME_STX_NULLP(rest)) { 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; return form;
}
scheme_wrong_syntax(NULL, NULL, form, "bad syntax (empty form)"); scheme_wrong_syntax(NULL, NULL, form, "bad syntax (empty form)");
return NULL; return NULL;
} }
@ -4124,11 +3962,14 @@ do_begin_expand(char *name,
erec[drec].value_name = scheme_false; erec[drec].value_name = scheme_false;
fst = SCHEME_STX_CAR(rest); fst = SCHEME_STX_CAR(rest);
rest = SCHEME_STX_CDR(rest); rest = SCHEME_STX_CDR(rest);
form = icons(scheme_expand_expr(fst, env, &erec1, 0),
scheme_expand_list(scheme_datum_to_syntax(rest, SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
form, fst = scheme_expand_expr(fst, env, &erec1, 0);
form, 0, 0), rest = scheme_datum_to_syntax(rest, form, form, 0, 0);
env, erec, drec)); SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
rest = scheme_expand_list(rest, env, erec, drec);
form = icons(fst, rest);
} else { } else {
Scheme_Object *boundname; Scheme_Object *boundname;
boundname = scheme_check_name_property(form, erec[drec].value_name); boundname = scheme_check_name_property(form, erec[drec].value_name);
@ -4157,12 +3998,14 @@ do_begin_expand(char *name,
static Scheme_Object * static Scheme_Object *
begin_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) 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); return do_begin_expand("begin", form, env, erec, drec, 0);
} }
static Scheme_Object * static Scheme_Object *
begin0_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) 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); 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 * static Scheme_Object *
quote_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) 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); 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.resolve_module_ids = 0;
rec1.value_name = NULL; rec1.value_name = NULL;
rec1.certs = rec[drec].certs; rec1.certs = rec[drec].certs;
rec1.observer = NULL;
if (for_stx) { if (for_stx) {
names = defn_targets_syntax(names, exp_env, &rec1, 0); 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_Object *names, *code, *fpart, *fn;
SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(erec[drec].observer);
scheme_prepare_exp_env(env->genv); scheme_prepare_exp_env(env->genv);
scheme_define_parse(form, &names, &code, 1, env); 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, void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a,
Scheme_Env *exp_env, Scheme_Object *insp, Scheme_Object *certs, Scheme_Env *exp_env, Scheme_Object *insp,
Scheme_Compile_Expand_Info *rec, int drec,
Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env, Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env,
int *_pos, Scheme_Object *names_to_disappear) int *_pos)
{ {
Scheme_Object **results, *l; Scheme_Object **results, *l;
Scheme_Comp_Env *eenv; Scheme_Comp_Env *eenv;
Scheme_Object *certs;
Resolve_Prefix *rp; Resolve_Prefix *rp;
Resolve_Info *ri; Resolve_Info *ri;
Optimize_Info *oi; Optimize_Info *oi;
int vc, nc, j, i; int vc, nc, j, i;
Scheme_Compile_Info mrec; Scheme_Compile_Info mrec;
certs = rec[drec].certs;
mrec.comp = 1; mrec.comp = 1;
mrec.dont_mark_local_use = 0; mrec.dont_mark_local_use = 0;
mrec.resolve_module_ids = 1; mrec.resolve_module_ids = 1;
mrec.value_name = NULL; mrec.value_name = NULL;
mrec.certs = certs; mrec.certs = certs;
mrec.observer = NULL;
eenv = scheme_new_comp_env(exp_env, insp, 0); 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); a = scheme_compile_expr_lift_to_let(a, eenv, &mrec, 0);
/* For internal defn, don't simplify as resolving, because the /* 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_PTR_VAL(macro) = results[j];
scheme_set_local_syntax(i++, name, macro, stx_env); scheme_set_local_syntax(i++, name, macro, stx_env);
if (names_to_disappear)
names_to_disappear = icons(name, names_to_disappear);
} }
*_pos = i; *_pos = i;
return names_to_disappear;
} }
static Scheme_Object * static Scheme_Object *
@ -4817,6 +4674,8 @@ do_letrec_syntaxes(const char *where,
scheme_begin_dup_symbol_check(&r, stx_env); scheme_begin_dup_symbol_check(&r, stx_env);
/* Pass 1: Check and Rename */
for (i = 0; i < 2 ; i++) { for (i = 0; i < 2 ; i++) {
for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
Scheme_Object *a, *l; 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); scheme_prepare_exp_env(stx_env->genv);
i = 0; i = 0;
@ -4896,22 +4779,23 @@ do_letrec_syntaxes(const char *where,
for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
Scheme_Object *a, *names; Scheme_Object *a, *names;
SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
a = SCHEME_STX_CAR(v); a = SCHEME_STX_CAR(v);
names = SCHEME_STX_CAR(a); names = SCHEME_STX_CAR(a);
a = SCHEME_STX_CDR(a); a = SCHEME_STX_CDR(a);
a = SCHEME_STX_CAR(a); a = SCHEME_STX_CAR(a);
a = scheme_add_env_renames(a, stx_env, origenv); scheme_bind_syntaxes(where, names, a,
if (var_env) stx_env->genv->exp_env,
a = scheme_add_env_renames(a, var_env, stx_env); stx_env->insp,
rec, drec,
names_to_disappear = scheme_bind_syntaxes(where, names, a,
stx_env->genv->exp_env, stx_env->insp, rec[drec].certs,
stx_env, rhs_env, stx_env, rhs_env,
&i, names_to_disappear); &i);
} }
body = scheme_add_env_renames(body, stx_env, origenv); SCHEME_EXPAND_OBSERVE_NEXT_GROUP(rec[drec].observer);
if (names_to_disappear) { if (names_to_disappear) {
/* Need to add renaming for disappeared bindings --- unless /* Need to add renaming for disappeared bindings --- unless
they originated for internal definitions, in which case 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) { if (!var_env) {
var_env = scheme_require_renames(stx_env); var_env = scheme_require_renames(stx_env);
@ -4960,6 +4842,7 @@ do_letrec_syntaxes(const char *where,
if (rec[drec].comp) { if (rec[drec].comp) {
v = gen_let_syntax(v, stx_env, "letrec-values", 0, 1, 1, rec, drec, var_env); v = gen_let_syntax(v, stx_env, "letrec-values", 0, 1, 1, rec, drec, var_env);
} else { } 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); v = do_let_expand(v, stx_env, rec, drec, "letrec-values", 1, 1, 0, var_env);
if ((depth >= 0) || (depth == -2)) { if ((depth >= 0) || (depth == -2)) {
@ -4990,6 +4873,8 @@ letrec_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env,
static Scheme_Object * static Scheme_Object *
letrec_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) 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); 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; 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 */ /* precise GC */
/**********************************************************************/ /**********************************************************************/

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

@ -55,6 +55,8 @@
"type" "type"
"vector")) "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?) (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)) (when (or (not re:only) (regexp-match re:only dest))
(unless (and (file-exists? dest) (unless (and (file-exists? dest)
@ -90,7 +92,10 @@
(list (list
"--depends" "--depends"
"--cpp" "--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" "-o"
dest dest
src))) src)))
@ -101,6 +106,7 @@
(when objdest (when objdest
(compile dest objdest null (string-append (compile dest objdest null (string-append
extra-compile-flags extra-compile-flags
common-cpp-defs
(if msvc-pch (if msvc-pch
(format " /Fp~a" msvc-pch) (format " /Fp~a" msvc-pch)
"")))))) ""))))))

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

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

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

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

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

@ -3,6 +3,7 @@
ProjectType="Visual C++" ProjectType="Visual C++"
Version="8.00" Version="8.00"
Name="libmzgc" Name="libmzgc"
ProjectGUID="{CB68718B-24BF-43E3-9E96-BCF9B37CFE2D}"
> >
<Platforms> <Platforms>
<Platform <Platform
@ -41,7 +42,7 @@
Name="VCCLCompilerTool" Name="VCCLCompilerTool"
Optimization="0" Optimization="0"
AdditionalIncludeDirectories="..\..\MzScheme\Gc\Include,$(NOINHERIT)" 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" BasicRuntimeChecks="3"
RuntimeLibrary="1" RuntimeLibrary="1"
UsePrecompiledHeader="0" UsePrecompiledHeader="0"
@ -126,7 +127,7 @@
EnableIntrinsicFunctions="true" EnableIntrinsicFunctions="true"
FavorSizeOrSpeed="1" FavorSizeOrSpeed="1"
AdditionalIncludeDirectories="..\..\MzScheme\Gc\Include,$(NOINHERIT)" 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" StringPooling="true"
RuntimeLibrary="0" RuntimeLibrary="0"
EnableFunctionLevelLinking="true" EnableFunctionLevelLinking="true"

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

@ -3,6 +3,7 @@
ProjectType="Visual C++" ProjectType="Visual C++"
Version="8.00" Version="8.00"
Name="libmzsch" Name="libmzsch"
ProjectGUID="{2D99E176-BCA5-4B8E-B25C-1B2D7179C188}"
> >
<Platforms> <Platforms>
<Platform <Platform
@ -41,7 +42,7 @@
Name="VCCLCompilerTool" Name="VCCLCompilerTool"
Optimization="0" Optimization="0"
AdditionalIncludeDirectories="..,..\..\mzscheme\include,..\..\mzscheme\src,..\..\foreign\libffi_msvc,$(NOINHERIT)" 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" BasicRuntimeChecks="3"
RuntimeLibrary="1" RuntimeLibrary="1"
EnableFunctionLevelLinking="true" EnableFunctionLevelLinking="true"
@ -129,7 +130,7 @@
EnableIntrinsicFunctions="true" EnableIntrinsicFunctions="true"
FavorSizeOrSpeed="1" FavorSizeOrSpeed="1"
AdditionalIncludeDirectories="..,..\..\mzscheme\include,..\..\mzscheme\src,..\..\foreign\libffi_msvc,$(NOINHERIT)" 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" StringPooling="true"
RuntimeLibrary="0" RuntimeLibrary="0"
EnableFunctionLevelLinking="true" EnableFunctionLevelLinking="true"

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

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

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

@ -3,6 +3,7 @@
ProjectType="Visual C++" ProjectType="Visual C++"
Version="8.00" Version="8.00"
Name="MzScheme" Name="MzScheme"
ProjectGUID="{EB7023C8-6D72-4DE4-ADFC-3913C4C70991}"
> >
<Platforms> <Platforms>
<Platform <Platform
@ -41,7 +42,7 @@
Name="VCCLCompilerTool" Name="VCCLCompilerTool"
Optimization="0" Optimization="0"
AdditionalIncludeDirectories="..,..\..\mzscheme\include,$(NOINHERIT)" AdditionalIncludeDirectories="..,..\..\mzscheme\include,$(NOINHERIT)"
PreprocessorDefinitions="WIN32,_DEBUG,_CONSOLE,GC_DLL" PreprocessorDefinitions="WIN32,_DEBUG,_CONSOLE,GC_DLL,_CRT_SECURE_NO_DEPRECATE"
BasicRuntimeChecks="3" BasicRuntimeChecks="3"
RuntimeLibrary="1" RuntimeLibrary="1"
UsePrecompiledHeader="0" UsePrecompiledHeader="0"
@ -94,17 +95,7 @@
/> />
<Tool <Tool
Name="VCPostBuildEventTool" Name="VCPostBuildEventTool"
CommandLine="&#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;"
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;
"
/> />
</Configuration> </Configuration>
<Configuration <Configuration
@ -138,7 +129,7 @@ cd ..\..\worksp\mzscheme&#x0D;&#x0A;
EnableIntrinsicFunctions="true" EnableIntrinsicFunctions="true"
FavorSizeOrSpeed="1" FavorSizeOrSpeed="1"
AdditionalIncludeDirectories="..,..\..\mzscheme\include,$(NOINHERIT)" AdditionalIncludeDirectories="..,..\..\mzscheme\include,$(NOINHERIT)"
PreprocessorDefinitions="WIN32,NDEBUG,_CONSOLE,GC_DLL" PreprocessorDefinitions="WIN32,NDEBUG,_CONSOLE,GC_DLL,_CRT_SECURE_NO_DEPRECATE"
StringPooling="true" StringPooling="true"
RuntimeLibrary="0" RuntimeLibrary="0"
EnableFunctionLevelLinking="true" EnableFunctionLevelLinking="true"
@ -193,17 +184,7 @@ cd ..\..\worksp\mzscheme&#x0D;&#x0A;
/> />
<Tool <Tool
Name="VCPostBuildEventTool" Name="VCPostBuildEventTool"
CommandLine="&#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;"
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;
"
/> />
</Configuration> </Configuration>
</Configurations> </Configurations>

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

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

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

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

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

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

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

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

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

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

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

@ -42,7 +42,7 @@
Name="VCCLCompilerTool" Name="VCCLCompilerTool"
Optimization="0" Optimization="0"
AdditionalIncludeDirectories="..\zlib,$(NOINHERIT)" AdditionalIncludeDirectories="..\zlib,$(NOINHERIT)"
PreprocessorDefinitions="WIN32,_DEBUG,_LIB,GC_DLL" PreprocessorDefinitions="WIN32,_DEBUG,_LIB,GC_DLL,_CRT_SECURE_NO_DEPRECATE"
RuntimeLibrary="1" RuntimeLibrary="1"
UsePrecompiledHeader="0" UsePrecompiledHeader="0"
WarningLevel="3" WarningLevel="3"
@ -113,7 +113,7 @@
EnableIntrinsicFunctions="true" EnableIntrinsicFunctions="true"
FavorSizeOrSpeed="1" FavorSizeOrSpeed="1"
AdditionalIncludeDirectories="..\zlib,$(NOINHERIT)" AdditionalIncludeDirectories="..\zlib,$(NOINHERIT)"
PreprocessorDefinitions="WIN32,NDEBUG,_LIB,GC_DLL" PreprocessorDefinitions="WIN32,NDEBUG,_LIB,GC_DLL,_CRT_SECURE_NO_DEPRECATE"
StringPooling="true" StringPooling="true"
RuntimeLibrary="0" RuntimeLibrary="0"
EnableFunctionLevelLinking="true" 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);
inline void *operator new(size_t size, GCPlacement gcp); inline void *operator new(size_t size, GCPlacement gcp);
inline void operator delete(void *obj); inline void operator delete(void *obj);
#ifdef _MSC_VER
inline void operator delete(void *obj, GCPlacement gcp);
#endif
#ifdef OPERATOR_NEW_ARRAY #ifdef OPERATOR_NEW_ARRAY
inline void *operator new[](size_t size); inline void *operator new[](size_t size);
inline void *operator new[](size_t size, GCPlacement gcp); inline void *operator new[](size_t size, GCPlacement gcp);
inline void operator delete[](void *obj); inline void operator delete[](void *obj);
# ifdef _MSC_VER
inline void operator delete[](void *obj, GCPlacement gcp);
# endif
#endif #endif
#ifdef MZ_PRECISE_GC #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 #ifdef OPERATOR_NEW_ARRAY
inline void *gc::operator new[](size_t size) { inline void *gc::operator new[](size_t size) {
#if defined(USE_SENORA_GC) || defined(MZ_PRECISE_GC) #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) { inline void gc::operator delete[](void *obj) {
gc::operator delete(obj); gc::operator delete(obj);
} }
# ifdef _MSC_VER
inline void gc::operator delete[](void *obj, GCPlacement gcp) {
gc::operator delete(obj, gcp);
}
# endif
#endif #endif
@ -263,5 +282,14 @@ inline void *operator new[](size_t size, GCPlacement gcp)
} }
#endif #endif
#ifdef _MSC_VER
inline void operator delete(void *, GCPlacement)
{
}
inline void operator delete[](void *, GCPlacement)
{
}
#endif
#endif /* WXGC_CPP_H */ #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; state.adornment = focused ? kThemeAdornmentFocus : kThemeAdornmentNone;
if (isgray) { if (isgray) {
buttonBitmap->DrawMac(IB_MARGIN_X, IB_MARGIN_Y, patOr); 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 { } 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); 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.value = bitmapState ? kThemeButtonOn : kThemeButtonOff;
state.adornment = ((trackState & 0x2) ? kThemeAdornmentFocus : kThemeAdornmentNone); 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); str = wxCFString(labelString);
DrawThemeTextBox(str, kThemeSystemFont, kThemeStateActive, DrawThemeTextBox(str, kThemeSystemFont, kThemeStateActive,
0, &r, teJustLeft, NULL); 0, &r, teJustLeft, 0);
CFRelease(str); CFRelease(str);
} }
@ -276,7 +276,7 @@ void wxRadioButton::Paint(void)
state.value = bitmapState ? kThemeButtonOn : kThemeButtonOff; state.value = bitmapState ? kThemeButtonOn : kThemeButtonOff;
state.adornment = ((trackState & 0x2) ? kThemeAdornmentFocus : kThemeAdornmentNone); 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); wxDrawUnicodeText(t, 0, -1, 0);
} else { } else {
str = wxCFString(t); str = wxCFString(t);
DrawThemeTextBox(str, kThemeSystemFont, kThemeStateActive, DrawThemeTextBox(str, kThemeSystemFont, kThemeStateActive, 0, &r, teJustCenter, 0);
0, &r, teJustCenter, NULL);
CFRelease(str); 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) static long DoEndSessionWin(void *data)
{ {
HWND win;
MSG msg; MSG msg;
qes_win = CreateWindowW(L"wxEndSessionWatcher", L"EndSession Watcher", WS_POPUP, qes_win = CreateWindowW(L"wxEndSessionWatcher", L"EndSession Watcher", WS_POPUP,