137 |
* expressions may be grouped arbitraryly with begin, but it is not allowed to |
* expressions may be grouped arbitraryly with begin, but it is not allowed to |
138 |
* mix definitions and expressions. If a define form in a body mixes |
* mix definitions and expressions. If a define form in a body mixes |
139 |
* definitions and expressions, a 'Mixed definitions and expressions' error is |
* definitions and expressions, a 'Mixed definitions and expressions' error is |
140 |
* signalled. |
* signalled. */ |
|
*/ |
|
141 |
static const char s_mixed_body_forms[] = "Mixed definitions and expressions in"; |
static const char s_mixed_body_forms[] = "Mixed definitions and expressions in"; |
142 |
|
/* Definitions are only allowed on the top level and at the start of a body. |
143 |
|
* If a definition is detected anywhere else, a 'Bad define placement' error |
144 |
|
* is signalled. */ |
145 |
|
static const char s_bad_define[] = "Bad define placement"; |
146 |
|
|
147 |
/* Case or cond expressions must have at least one clause. If a case or cond |
/* Case or cond expressions must have at least one clause. If a case or cond |
148 |
* expression without any clauses is detected, a 'Missing clauses' error is |
* expression without any clauses is detected, a 'Missing clauses' error is |
749 |
* just the body itself, but prefixed with an ISYM that denotes to what kind |
* just the body itself, but prefixed with an ISYM that denotes to what kind |
750 |
* of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body |
* of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body |
751 |
* starts with SCM_IM_LAMBDA, for example, a body of a let starts with |
* starts with SCM_IM_LAMBDA, for example, a body of a let starts with |
752 |
* SCM_IM_LET, etc. The one exception is a body that belongs to a letrec that |
* SCM_IM_LET, etc. |
|
* has been formed by rewriting internal defines: It starts with SCM_IM_DEFINE |
|
|
* (instead of SCM_IM_LETREC). |
|
753 |
* |
* |
754 |
* It is assumed that the calling expression has already made sure that the |
* It is assumed that the calling expression has already made sure that the |
755 |
* body is a proper list. */ |
* body is a proper list. */ |
1198 |
SCM |
SCM |
1199 |
scm_m_define (SCM expr, SCM env) |
scm_m_define (SCM expr, SCM env) |
1200 |
{ |
{ |
1201 |
SCM canonical_definition; |
ASSERT_SYNTAX (SCM_TOP_LEVEL (env), s_bad_define, expr); |
|
SCM cdr_canonical_definition; |
|
|
SCM body; |
|
1202 |
|
|
1203 |
canonical_definition = canonicalize_define (expr); |
{ |
1204 |
cdr_canonical_definition = SCM_CDR (canonical_definition); |
const SCM canonical_definition = canonicalize_define (expr); |
1205 |
body = SCM_CDR (cdr_canonical_definition); |
const SCM cdr_canonical_definition = SCM_CDR (canonical_definition); |
1206 |
|
const SCM variable = SCM_CAR (cdr_canonical_definition); |
1207 |
if (SCM_TOP_LEVEL (env)) |
const SCM body = SCM_CDR (cdr_canonical_definition); |
1208 |
{ |
const SCM value = scm_eval_car (body, env); |
1209 |
SCM var; |
|
1210 |
const SCM variable = SCM_CAR (cdr_canonical_definition); |
SCM var; |
1211 |
const SCM value = scm_eval_car (body, env); |
if (SCM_REC_PROCNAMES_P) |
1212 |
if (SCM_REC_PROCNAMES_P) |
{ |
1213 |
{ |
SCM tmp = value; |
1214 |
SCM tmp = value; |
while (SCM_MACROP (tmp)) |
1215 |
while (SCM_MACROP (tmp)) |
tmp = SCM_MACRO_CODE (tmp); |
1216 |
tmp = SCM_MACRO_CODE (tmp); |
if (SCM_CLOSUREP (tmp) |
1217 |
if (SCM_CLOSUREP (tmp) |
/* Only the first definition determines the name. */ |
1218 |
/* Only the first definition determines the name. */ |
&& SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name))) |
1219 |
&& SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name))) |
scm_set_procedure_property_x (tmp, scm_sym_name, variable); |
1220 |
scm_set_procedure_property_x (tmp, scm_sym_name, variable); |
} |
1221 |
} |
|
1222 |
var = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T); |
var = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T); |
1223 |
SCM_VARIABLE_SET (var, value); |
SCM_VARIABLE_SET (var, value); |
1224 |
return SCM_UNSPECIFIED; |
|
1225 |
} |
return SCM_UNSPECIFIED; |
1226 |
else |
} |
|
{ |
|
|
SCM_SETCAR (canonical_definition, SCM_IM_DEFINE); |
|
|
return canonical_definition; |
|
|
} |
|
1227 |
} |
} |
1228 |
|
|
1229 |
|
|
2261 |
#endif |
#endif |
2262 |
|
|
2263 |
|
|
2264 |
static SCM |
SCM |
2265 |
unmemocopy (SCM x, SCM env) |
scm_unmemocopy (SCM x, SCM env) |
2266 |
{ |
{ |
2267 |
SCM ls, z; |
SCM ls, z; |
2268 |
SCM p; |
SCM p; |
2299 |
SCM names, inits, test, memoized_body, steps, bindings; |
SCM names, inits, test, memoized_body, steps, bindings; |
2300 |
|
|
2301 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
2302 |
inits = scm_reverse (unmemocopy (SCM_CAR (x), env)); |
inits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env)); |
2303 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
2304 |
names = SCM_CAR (x); |
names = SCM_CAR (x); |
2305 |
env = SCM_EXTEND_ENV (names, SCM_EOL, env); |
env = SCM_EXTEND_ENV (names, SCM_EOL, env); |
2306 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
2307 |
test = unmemocopy (SCM_CAR (x), env); |
test = scm_unmemocopy (SCM_CAR (x), env); |
2308 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
2309 |
memoized_body = SCM_CAR (x); |
memoized_body = SCM_CAR (x); |
2310 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
2311 |
steps = scm_reverse (unmemocopy (x, env)); |
steps = scm_reverse (scm_unmemocopy (x, env)); |
2312 |
|
|
2313 |
/* build transformed binding list */ |
/* build transformed binding list */ |
2314 |
bindings = SCM_EOL; |
bindings = SCM_EOL; |
2344 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
2345 |
rnames = SCM_CAR (x); |
rnames = SCM_CAR (x); |
2346 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
2347 |
rinits = scm_reverse (unmemocopy (SCM_CAR (x), env)); |
rinits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env)); |
2348 |
env = SCM_EXTEND_ENV (rnames, SCM_EOL, env); |
env = SCM_EXTEND_ENV (rnames, SCM_EOL, env); |
2349 |
|
|
2350 |
bindings = build_binding_list (rnames, rinits); |
bindings = build_binding_list (rnames, rinits); |
2363 |
rnames = SCM_CAR (x); |
rnames = SCM_CAR (x); |
2364 |
env = SCM_EXTEND_ENV (rnames, SCM_EOL, env); |
env = SCM_EXTEND_ENV (rnames, SCM_EOL, env); |
2365 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
2366 |
rinits = scm_reverse (unmemocopy (SCM_CAR (x), env)); |
rinits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env)); |
2367 |
|
|
2368 |
bindings = build_binding_list (rnames, rinits); |
bindings = build_binding_list (rnames, rinits); |
2369 |
z = scm_cons (bindings, SCM_UNSPECIFIED); |
z = scm_cons (bindings, SCM_UNSPECIFIED); |
2383 |
} |
} |
2384 |
y = z = scm_acons (SCM_CAR (b), |
y = z = scm_acons (SCM_CAR (b), |
2385 |
unmemocar ( |
unmemocar ( |
2386 |
scm_cons (unmemocopy (SCM_CADR (b), env), SCM_EOL), env), |
scm_cons (scm_unmemocopy (SCM_CADR (b), env), SCM_EOL), env), |
2387 |
SCM_UNSPECIFIED); |
SCM_UNSPECIFIED); |
2388 |
env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env); |
env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env); |
2389 |
b = SCM_CDDR (b); |
b = SCM_CDDR (b); |
2398 |
{ |
{ |
2399 |
SCM_SETCDR (z, scm_acons (SCM_CAR (b), |
SCM_SETCDR (z, scm_acons (SCM_CAR (b), |
2400 |
unmemocar ( |
unmemocar ( |
2401 |
scm_list_1 (unmemocopy (SCM_CADR (b), env)), env), |
scm_list_1 (scm_unmemocopy (SCM_CADR (b), env)), env), |
2402 |
SCM_UNSPECIFIED)); |
SCM_UNSPECIFIED)); |
2403 |
z = SCM_CDR (z); |
z = SCM_CDR (z); |
2404 |
env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env); |
env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env); |
2430 |
z = SCM_CAR (x); |
z = SCM_CAR (x); |
2431 |
switch (SCM_ISYMNUM (z)) |
switch (SCM_ISYMNUM (z)) |
2432 |
{ |
{ |
|
case (SCM_ISYMNUM (SCM_IM_DEFINE)): |
|
|
{ |
|
|
SCM n; |
|
|
x = SCM_CDR (x); |
|
|
n = SCM_CAR (x); |
|
|
z = scm_cons (n, SCM_UNSPECIFIED); |
|
|
ls = scm_cons (scm_sym_define, z); |
|
|
if (!SCM_NULLP (env)) |
|
|
env = scm_cons (scm_cons (scm_cons (n, SCM_CAAR (env)), |
|
|
SCM_CDAR (env)), |
|
|
SCM_CDR (env)); |
|
|
break; |
|
|
} |
|
2433 |
case (SCM_ISYMNUM (SCM_IM_APPLY)): |
case (SCM_ISYMNUM (SCM_IM_APPLY)): |
2434 |
ls = z = scm_cons (scm_sym_atapply, SCM_UNSPECIFIED); |
ls = z = scm_cons (scm_sym_atapply, SCM_UNSPECIFIED); |
2435 |
goto loop; |
goto loop; |
2454 |
/* appease the Sun compiler god: */ ; |
/* appease the Sun compiler god: */ ; |
2455 |
} |
} |
2456 |
default: |
default: |
2457 |
ls = z = unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env), |
ls = z = unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x), env), |
2458 |
SCM_UNSPECIFIED), |
SCM_UNSPECIFIED), |
2459 |
env); |
env); |
2460 |
} |
} |
2465 |
SCM form = SCM_CAR (x); |
SCM form = SCM_CAR (x); |
2466 |
if (!SCM_ISYMP (form)) |
if (!SCM_ISYMP (form)) |
2467 |
{ |
{ |
2468 |
SCM copy = scm_cons (unmemocopy (form, env), SCM_UNSPECIFIED); |
SCM copy = scm_cons (scm_unmemocopy (form, env), SCM_UNSPECIFIED); |
2469 |
SCM_SETCDR (z, unmemocar (copy, env)); |
SCM_SETCDR (z, unmemocar (copy, env)); |
2470 |
z = SCM_CDR (z); |
z = SCM_CDR (z); |
2471 |
} |
} |
2482 |
return ls; |
return ls; |
2483 |
} |
} |
2484 |
|
|
|
SCM |
|
|
scm_unmemocopy (SCM x, SCM env) |
|
|
{ |
|
|
if (!SCM_NULLP (env)) |
|
|
/* Make a copy of the lowest frame to protect it from |
|
|
modifications by SCM_IM_DEFINE */ |
|
|
return unmemocopy (x, scm_cons (SCM_CAR (env), SCM_CDR (env))); |
|
|
else |
|
|
return unmemocopy (x, env); |
|
|
} |
|
|
|
|
2485 |
|
|
2486 |
/*****************************************************************************/ |
/*****************************************************************************/ |
2487 |
/*****************************************************************************/ |
/*****************************************************************************/ |
3251 |
{ |
{ |
3252 |
|
|
3253 |
|
|
|
case (SCM_ISYMNUM (SCM_IM_DEFINE)): |
|
|
/* Top level defines are handled directly by the memoizer and thus |
|
|
* will never generate memoized code with SCM_IM_DEFINE. Internal |
|
|
* defines which occur at valid positions will be transformed into |
|
|
* letrec expressions. Thus, whenever the executor detects |
|
|
* SCM_IM_DEFINE, this must come from an internal definition at an |
|
|
* illegal position. */ |
|
|
scm_misc_error (NULL, "Bad define placement", SCM_EOL); |
|
|
|
|
|
|
|
3254 |
case (SCM_ISYMNUM (SCM_IM_APPLY)): |
case (SCM_ISYMNUM (SCM_IM_APPLY)): |
3255 |
|
/* Evaluate the procedure to be applied. */ |
3256 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
3257 |
proc = EVALCAR (x, env); |
proc = EVALCAR (x, env); |
3258 |
PREP_APPLY (proc, SCM_EOL); |
PREP_APPLY (proc, SCM_EOL); |
3259 |
|
|
3260 |
|
/* Evaluate the argument holding the list of arguments */ |
3261 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
3262 |
arg1 = EVALCAR (x, env); |
arg1 = EVALCAR (x, env); |
3263 |
|
|
3313 |
{ |
{ |
3314 |
arg1 = val; |
arg1 = val; |
3315 |
proc = SCM_CDR (x); |
proc = SCM_CDR (x); |
3316 |
proc = scm_eval_car (proc, env); |
proc = EVALCAR (proc, env); |
3317 |
PREP_APPLY (proc, scm_list_1 (arg1)); |
PREP_APPLY (proc, scm_list_1 (arg1)); |
3318 |
ENTER_APPLY; |
ENTER_APPLY; |
3319 |
goto evap1; |
goto evap1; |
3643 |
SCM_SET_MACROEXP (debug); |
SCM_SET_MACROEXP (debug); |
3644 |
#endif |
#endif |
3645 |
arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x, |
arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x, |
3646 |
scm_cons (env, scm_listofnull)); |
scm_cons (env, scm_listofnull)); |
|
|
|
3647 |
#ifdef DEVAL |
#ifdef DEVAL |
3648 |
SCM_CLEAR_MACROEXP (debug); |
SCM_CLEAR_MACROEXP (debug); |
3649 |
#endif |
#endif |
4135 |
arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env)); |
arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env)); |
4136 |
x = SCM_CDR(x); |
x = SCM_CDR(x); |
4137 |
} |
} |
4138 |
while (SCM_NIMP (x)); |
while (!SCM_NULLP (x)); |
4139 |
RETURN (arg1); |
RETURN (arg1); |
4140 |
case scm_tc7_rpsubr: |
case scm_tc7_rpsubr: |
4141 |
if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2))) |
if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2))) |
4148 |
arg2 = arg1; |
arg2 = arg1; |
4149 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
4150 |
} |
} |
4151 |
while (SCM_NIMP (x)); |
while (!SCM_NULLP (x)); |
4152 |
RETURN (SCM_BOOL_T); |
RETURN (SCM_BOOL_T); |
4153 |
case scm_tc7_lsubr_2: |
case scm_tc7_lsubr_2: |
4154 |
RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc))); |
RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc))); |
5430 |
} |
} |
5431 |
#undef FUNC_NAME |
#undef FUNC_NAME |
5432 |
|
|
5433 |
|
|
5434 |
/* Eval does not take the second arg optionally. This is intentional |
/* Eval does not take the second arg optionally. This is intentional |
5435 |
* in order to be R5RS compatible, and to prepare for the new module |
* in order to be R5RS compatible, and to prepare for the new module |
5436 |
* system, where we would like to make the choice of evaluation |
* system, where we would like to make the choice of evaluation |
5446 |
scm_set_current_module (new_module); |
scm_set_current_module (new_module); |
5447 |
} |
} |
5448 |
|
|
|
|
|
5449 |
static void |
static void |
5450 |
restore_environment (void *data) |
restore_environment (void *data) |
5451 |
{ |
{ |