672 |
SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace"); |
SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace"); |
673 |
|
|
674 |
|
|
675 |
/* Check that the body denoted by XORIG is valid and rewrite it into |
/* Rewrite the body (which is given as the list of expressions forming the |
676 |
its internal form. The internal form of a body is just the body |
* body) into its internal form. The internal form of a body (<expr> ...) is |
677 |
itself, but prefixed with an ISYM that denotes to what kind of |
* just the body itself, but prefixed with an ISYM that denotes to what kind |
678 |
outer construct this body belongs. A lambda body starts with |
* of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body |
679 |
SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET, |
* starts with SCM_IM_LAMBDA, for example, a body of a let starts with |
680 |
etc. The one exception is a body that belongs to a letrec that has |
* SCM_IM_LET, etc. The one exception is a body that belongs to a letrec that |
681 |
been formed by rewriting internal defines: it starts with |
* has been formed by rewriting internal defines: It starts with SCM_IM_DEFINE |
682 |
SCM_IM_DEFINE. */ |
* (instead of SCM_IM_LETREC). |
683 |
|
* |
684 |
/* XXX - Besides controlling the rewriting of internal defines, the |
* It is assumed that the calling expression has already made sure that the |
685 |
additional ISYM could be used for improved error messages. |
* body is a proper list. */ |
|
This is not done yet. */ |
|
|
|
|
686 |
static SCM |
static SCM |
687 |
scm_m_body (SCM op, SCM xorig, const char *what) |
scm_m_body (SCM op, SCM exprs) |
688 |
{ |
{ |
|
SCM_ASSYNT (scm_ilength (xorig) >= 1, s_body, what); |
|
|
|
|
689 |
/* Don't add another ISYM if one is present already. */ |
/* Don't add another ISYM if one is present already. */ |
690 |
if (SCM_ISYMP (SCM_CAR (xorig))) |
if (SCM_ISYMP (SCM_CAR (exprs))) |
691 |
return xorig; |
return exprs; |
692 |
|
else |
693 |
/* Retain possible doc string. */ |
return scm_cons (op, exprs); |
|
if (!SCM_CONSP (SCM_CAR (xorig))) |
|
|
{ |
|
|
if (!SCM_NULLP (SCM_CDR (xorig))) |
|
|
return scm_cons (SCM_CAR (xorig), |
|
|
scm_m_body (op, SCM_CDR (xorig), what)); |
|
|
return xorig; |
|
|
} |
|
|
|
|
|
return scm_cons (op, xorig); |
|
694 |
} |
} |
695 |
|
|
696 |
|
|
1088 |
{ |
{ |
1089 |
SCM formals; |
SCM formals; |
1090 |
SCM formals_idx; |
SCM formals_idx; |
1091 |
|
SCM cddr_expr; |
1092 |
|
int documentation; |
1093 |
|
SCM body; |
1094 |
|
SCM new_body; |
1095 |
|
|
1096 |
const SCM cdr_expr = SCM_CDR (expr); |
const SCM cdr_expr = SCM_CDR (expr); |
1097 |
const long length = scm_ilength (cdr_expr); |
const long length = scm_ilength (cdr_expr); |
1127 |
ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx) || SCM_SYMBOLP (formals_idx), |
ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx) || SCM_SYMBOLP (formals_idx), |
1128 |
s_bad_formal, formals_idx, expr); |
s_bad_formal, formals_idx, expr); |
1129 |
|
|
1130 |
return scm_cons2 (SCM_IM_LAMBDA, SCM_CAR (cdr_expr), |
/* Memoize the body. Keep a potential documentation string. */ |
1131 |
scm_m_body (SCM_IM_LAMBDA, SCM_CDR (cdr_expr), s_lambda)); |
/* Dirk:FIXME:: We should probably extract the documentation string to |
1132 |
|
* some external database. Otherwise it will slow down execution, since |
1133 |
|
* the documentation string will have to be skipped with every execution |
1134 |
|
* of the closure. */ |
1135 |
|
cddr_expr = SCM_CDR (cdr_expr); |
1136 |
|
documentation = (length >= 3 && SCM_STRINGP (SCM_CAR (cddr_expr))); |
1137 |
|
body = documentation ? SCM_CDR (cddr_expr) : cddr_expr; |
1138 |
|
new_body = scm_m_body (SCM_IM_LAMBDA, body); |
1139 |
|
|
1140 |
|
SCM_SETCAR (expr, SCM_IM_LAMBDA); |
1141 |
|
if (documentation) |
1142 |
|
SCM_SETCDR (cddr_expr, new_body); |
1143 |
|
else |
1144 |
|
SCM_SETCDR (cdr_expr, new_body); |
1145 |
|
return expr; |
1146 |
} |
} |
1147 |
|
|
1148 |
|
|
1225 |
|
|
1226 |
{ |
{ |
1227 |
const SCM let_body = SCM_CDR (cddr_expr); |
const SCM let_body = SCM_CDR (cddr_expr); |
1228 |
const SCM lambda_body = scm_m_body (SCM_IM_LET, let_body, "let"); |
const SCM lambda_body = scm_m_body (SCM_IM_LET, let_body); |
1229 |
const SCM lambda_tail = scm_cons (variables, lambda_body); |
const SCM lambda_tail = scm_cons (variables, lambda_body); |
1230 |
const SCM lambda_form = scm_cons_source (expr, scm_sym_lambda, lambda_tail); |
const SCM lambda_form = scm_cons_source (expr, scm_sym_lambda, lambda_tail); |
1231 |
|
|
1232 |
const SCM rvar = scm_list_1 (name); |
const SCM rvar = scm_list_1 (name); |
1233 |
const SCM init = scm_list_1 (lambda_form); |
const SCM init = scm_list_1 (lambda_form); |
1234 |
const SCM body = scm_m_body (SCM_IM_LET, scm_list_1 (name), "let"); |
const SCM body = scm_m_body (SCM_IM_LET, scm_list_1 (name)); |
1235 |
const SCM letrec_tail = scm_cons (rvar, scm_cons (init, body)); |
const SCM letrec_tail = scm_cons (rvar, scm_cons (init, body)); |
1236 |
const SCM letrec_form = scm_cons_source (expr, SCM_IM_LETREC, letrec_tail); |
const SCM letrec_form = scm_cons_source (expr, SCM_IM_LETREC, letrec_tail); |
1237 |
return scm_cons_source (expr, letrec_form, inits); |
return scm_cons_source (expr, letrec_form, inits); |
1261 |
if (SCM_NULLP (bindings) || SCM_NULLP (SCM_CDR (bindings))) |
if (SCM_NULLP (bindings) || SCM_NULLP (SCM_CDR (bindings))) |
1262 |
{ |
{ |
1263 |
/* Special case: no bindings or single binding => let* is faster. */ |
/* Special case: no bindings or single binding => let* is faster. */ |
1264 |
const SCM body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr), s_let); |
const SCM body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr)); |
1265 |
return scm_m_letstar (scm_cons2 (SCM_CAR (expr), bindings, body), env); |
return scm_m_letstar (scm_cons2 (SCM_CAR (expr), bindings, body), env); |
1266 |
} |
} |
1267 |
else |
else |
1272 |
transform_bindings (bindings, expr, &rvariables, &inits); |
transform_bindings (bindings, expr, &rvariables, &inits); |
1273 |
|
|
1274 |
{ |
{ |
1275 |
const SCM new_body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr), "let"); |
const SCM new_body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr)); |
1276 |
const SCM new_tail = scm_cons2 (rvariables, inits, new_body); |
const SCM new_tail = scm_cons2 (rvariables, inits, new_body); |
1277 |
SCM_SETCAR (expr, SCM_IM_LET); |
SCM_SETCAR (expr, SCM_IM_LET); |
1278 |
SCM_SETCDR (expr, new_tail); |
SCM_SETCDR (expr, new_tail); |
1310 |
} |
} |
1311 |
new_bindings = scm_reverse_x (new_bindings, SCM_UNDEFINED); |
new_bindings = scm_reverse_x (new_bindings, SCM_UNDEFINED); |
1312 |
|
|
1313 |
new_body = scm_m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr), s_letstar); |
new_body = scm_m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr)); |
1314 |
return scm_cons2 (SCM_IM_LETSTAR, new_bindings, new_body); |
return scm_cons2 (SCM_IM_LETSTAR, new_bindings, new_body); |
1315 |
} |
} |
1316 |
|
|
1331 |
if (SCM_NULLP (bindings)) |
if (SCM_NULLP (bindings)) |
1332 |
{ |
{ |
1333 |
/* no bindings, let* is executed faster */ |
/* no bindings, let* is executed faster */ |
1334 |
SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr), s_letrec); |
SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr)); |
1335 |
return scm_m_letstar (scm_cons2 (SCM_CAR (expr), SCM_EOL, body), env); |
return scm_m_letstar (scm_cons2 (SCM_CAR (expr), SCM_EOL, body), env); |
1336 |
} |
} |
1337 |
else |
else |
1342 |
|
|
1343 |
check_bindings (bindings, expr); |
check_bindings (bindings, expr); |
1344 |
transform_bindings (bindings, expr, &rvariables, &inits); |
transform_bindings (bindings, expr, &rvariables, &inits); |
1345 |
new_body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr), "letrec"); |
new_body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr)); |
1346 |
return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body)); |
return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body)); |
1347 |
} |
} |
1348 |
} |
} |
1846 |
SCM rvars, inits, body, letrec; |
SCM rvars, inits, body, letrec; |
1847 |
check_bindings (defs, xorig); |
check_bindings (defs, xorig); |
1848 |
transform_bindings (defs, xorig, &rvars, &inits); |
transform_bindings (defs, xorig, &rvars, &inits); |
1849 |
body = scm_m_body (SCM_IM_DEFINE, x, what); |
body = scm_m_body (SCM_IM_DEFINE, x); |
1850 |
letrec = scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body)); |
letrec = scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body)); |
1851 |
SCM_SETCAR (xorig, letrec); |
SCM_SETCAR (xorig, letrec); |
1852 |
SCM_SETCDR (xorig, SCM_EOL); |
SCM_SETCDR (xorig, SCM_EOL); |