694 |
* 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 |
695 |
* body is a proper list. */ |
* body is a proper list. */ |
696 |
static SCM |
static SCM |
697 |
scm_m_body (SCM op, SCM exprs) |
m_body (SCM op, SCM exprs) |
698 |
{ |
{ |
699 |
/* Don't add another ISYM if one is present already. */ |
/* Don't add another ISYM if one is present already. */ |
700 |
if (SCM_ISYMP (SCM_CAR (exprs))) |
if (SCM_ISYMP (SCM_CAR (exprs))) |
1161 |
cddr_expr = SCM_CDR (cdr_expr); |
cddr_expr = SCM_CDR (cdr_expr); |
1162 |
documentation = (length >= 3 && SCM_STRINGP (SCM_CAR (cddr_expr))); |
documentation = (length >= 3 && SCM_STRINGP (SCM_CAR (cddr_expr))); |
1163 |
body = documentation ? SCM_CDR (cddr_expr) : cddr_expr; |
body = documentation ? SCM_CDR (cddr_expr) : cddr_expr; |
1164 |
new_body = scm_m_body (SCM_IM_LAMBDA, body); |
new_body = m_body (SCM_IM_LAMBDA, body); |
1165 |
|
|
1166 |
SCM_SETCAR (expr, SCM_IM_LAMBDA); |
SCM_SETCAR (expr, SCM_IM_LAMBDA); |
1167 |
if (documentation) |
if (documentation) |
1251 |
|
|
1252 |
{ |
{ |
1253 |
const SCM let_body = SCM_CDR (cddr_expr); |
const SCM let_body = SCM_CDR (cddr_expr); |
1254 |
const SCM lambda_body = scm_m_body (SCM_IM_LET, let_body); |
const SCM lambda_body = m_body (SCM_IM_LET, let_body); |
1255 |
const SCM lambda_tail = scm_cons (variables, lambda_body); |
const SCM lambda_tail = scm_cons (variables, lambda_body); |
1256 |
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); |
1257 |
|
|
1258 |
const SCM rvar = scm_list_1 (name); |
const SCM rvar = scm_list_1 (name); |
1259 |
const SCM init = scm_list_1 (lambda_form); |
const SCM init = scm_list_1 (lambda_form); |
1260 |
const SCM body = scm_m_body (SCM_IM_LET, scm_list_1 (name)); |
const SCM body = m_body (SCM_IM_LET, scm_list_1 (name)); |
1261 |
const SCM letrec_tail = scm_cons (rvar, scm_cons (init, body)); |
const SCM letrec_tail = scm_cons (rvar, scm_cons (init, body)); |
1262 |
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); |
1263 |
return scm_cons_source (expr, letrec_form, inits); |
return scm_cons_source (expr, letrec_form, inits); |
1287 |
if (SCM_NULLP (bindings) || SCM_NULLP (SCM_CDR (bindings))) |
if (SCM_NULLP (bindings) || SCM_NULLP (SCM_CDR (bindings))) |
1288 |
{ |
{ |
1289 |
/* Special case: no bindings or single binding => let* is faster. */ |
/* Special case: no bindings or single binding => let* is faster. */ |
1290 |
const SCM body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr)); |
const SCM body = m_body (SCM_IM_LET, SCM_CDR (cdr_expr)); |
1291 |
return scm_m_letstar (scm_cons2 (SCM_CAR (expr), bindings, body), env); |
return scm_m_letstar (scm_cons2 (SCM_CAR (expr), bindings, body), env); |
1292 |
} |
} |
1293 |
else |
else |
1298 |
transform_bindings (bindings, expr, &rvariables, &inits); |
transform_bindings (bindings, expr, &rvariables, &inits); |
1299 |
|
|
1300 |
{ |
{ |
1301 |
const SCM new_body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr)); |
const SCM new_body = m_body (SCM_IM_LET, SCM_CDR (cdr_expr)); |
1302 |
const SCM new_tail = scm_cons2 (rvariables, inits, new_body); |
const SCM new_tail = scm_cons2 (rvariables, inits, new_body); |
1303 |
SCM_SETCAR (expr, SCM_IM_LET); |
SCM_SETCAR (expr, SCM_IM_LET); |
1304 |
SCM_SETCDR (expr, new_tail); |
SCM_SETCDR (expr, new_tail); |
1336 |
} |
} |
1337 |
new_bindings = scm_reverse_x (new_bindings, SCM_UNDEFINED); |
new_bindings = scm_reverse_x (new_bindings, SCM_UNDEFINED); |
1338 |
|
|
1339 |
new_body = scm_m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr)); |
new_body = m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr)); |
1340 |
return scm_cons2 (SCM_IM_LETSTAR, new_bindings, new_body); |
return scm_cons2 (SCM_IM_LETSTAR, new_bindings, new_body); |
1341 |
} |
} |
1342 |
|
|
1357 |
if (SCM_NULLP (bindings)) |
if (SCM_NULLP (bindings)) |
1358 |
{ |
{ |
1359 |
/* no bindings, let* is executed faster */ |
/* no bindings, let* is executed faster */ |
1360 |
SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr)); |
SCM body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr)); |
1361 |
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); |
1362 |
} |
} |
1363 |
else |
else |
1368 |
|
|
1369 |
check_bindings (bindings, expr); |
check_bindings (bindings, expr); |
1370 |
transform_bindings (bindings, expr, &rvariables, &inits); |
transform_bindings (bindings, expr, &rvariables, &inits); |
1371 |
new_body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr)); |
new_body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr)); |
1372 |
return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body)); |
return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body)); |
1373 |
} |
} |
1374 |
} |
} |
1875 |
SCM rvars, inits, body, letrec; |
SCM rvars, inits, body, letrec; |
1876 |
check_bindings (defs, xorig); |
check_bindings (defs, xorig); |
1877 |
transform_bindings (defs, xorig, &rvars, &inits); |
transform_bindings (defs, xorig, &rvars, &inits); |
1878 |
body = scm_m_body (SCM_IM_DEFINE, x); |
body = m_body (SCM_IM_DEFINE, x); |
1879 |
letrec = scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body)); |
letrec = scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body)); |
1880 |
SCM_SETCAR (xorig, letrec); |
SCM_SETCAR (xorig, letrec); |
1881 |
SCM_SETCDR (xorig, SCM_EOL); |
SCM_SETCDR (xorig, SCM_EOL); |