SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace");
-/* Check that the body denoted by XORIG is valid and rewrite it into
- its internal form. The internal form of a body is just the body
- itself, but prefixed with an ISYM that denotes to what kind of
- outer construct this body belongs. A lambda body starts with
- SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
- etc. The one exception is a body that belongs to a letrec that has
- been formed by rewriting internal defines: it starts with
- SCM_IM_DEFINE. */
-
-/* XXX - Besides controlling the rewriting of internal defines, the
- additional ISYM could be used for improved error messages.
- This is not done yet. */
-
+/* Rewrite the body (which is given as the list of expressions forming the
+ * body) into its internal form. The internal form of a body (<expr> ...) is
+ * just the body itself, but prefixed with an ISYM that denotes to what kind
+ * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
+ * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
+ * SCM_IM_LET, etc. The one exception is a body that belongs to a letrec that
+ * has been formed by rewriting internal defines: It starts with SCM_IM_DEFINE
+ * (instead of SCM_IM_LETREC).
+ *
+ * It is assumed that the calling expression has already made sure that the
+ * body is a proper list. */
static SCM
-scm_m_body (SCM op, SCM xorig, const char *what)
+scm_m_body (SCM op, SCM exprs)
{
- SCM_ASSYNT (scm_ilength (xorig) >= 1, s_body, what);
-
/* Don't add another ISYM if one is present already. */
- if (SCM_ISYMP (SCM_CAR (xorig)))
- return xorig;
-
- /* Retain possible doc string. */
- 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);
+ if (SCM_ISYMP (SCM_CAR (exprs)))
+ return exprs;
+ else
+ return scm_cons (op, exprs);
}
{
SCM formals;
SCM formals_idx;
+ SCM cddr_expr;
+ int documentation;
+ SCM body;
+ SCM new_body;
const SCM cdr_expr = SCM_CDR (expr);
const long length = scm_ilength (cdr_expr);
ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx) || SCM_SYMBOLP (formals_idx),
s_bad_formal, formals_idx, expr);
- return scm_cons2 (SCM_IM_LAMBDA, SCM_CAR (cdr_expr),
- scm_m_body (SCM_IM_LAMBDA, SCM_CDR (cdr_expr), s_lambda));
+ /* Memoize the body. Keep a potential documentation string. */
+ /* Dirk:FIXME:: We should probably extract the documentation string to
+ * some external database. Otherwise it will slow down execution, since
+ * the documentation string will have to be skipped with every execution
+ * of the closure. */
+ cddr_expr = SCM_CDR (cdr_expr);
+ documentation = (length >= 3 && SCM_STRINGP (SCM_CAR (cddr_expr)));
+ body = documentation ? SCM_CDR (cddr_expr) : cddr_expr;
+ new_body = scm_m_body (SCM_IM_LAMBDA, body);
+
+ SCM_SETCAR (expr, SCM_IM_LAMBDA);
+ if (documentation)
+ SCM_SETCDR (cddr_expr, new_body);
+ else
+ SCM_SETCDR (cdr_expr, new_body);
+ return expr;
}
{
const SCM let_body = SCM_CDR (cddr_expr);
- 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);
const SCM lambda_tail = scm_cons (variables, lambda_body);
const SCM lambda_form = scm_cons_source (expr, scm_sym_lambda, lambda_tail);
const SCM rvar = scm_list_1 (name);
const SCM init = scm_list_1 (lambda_form);
- 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));
const SCM letrec_tail = scm_cons (rvar, scm_cons (init, body));
const SCM letrec_form = scm_cons_source (expr, SCM_IM_LETREC, letrec_tail);
return scm_cons_source (expr, letrec_form, inits);
if (SCM_NULLP (bindings) || SCM_NULLP (SCM_CDR (bindings)))
{
/* Special case: no bindings or single binding => let* is faster. */
- 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));
return scm_m_letstar (scm_cons2 (SCM_CAR (expr), bindings, body), env);
}
else
transform_bindings (bindings, expr, &rvariables, &inits);
{
- 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));
const SCM new_tail = scm_cons2 (rvariables, inits, new_body);
SCM_SETCAR (expr, SCM_IM_LET);
SCM_SETCDR (expr, new_tail);
}
new_bindings = scm_reverse_x (new_bindings, SCM_UNDEFINED);
- 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));
return scm_cons2 (SCM_IM_LETSTAR, new_bindings, new_body);
}
if (SCM_NULLP (bindings))
{
/* no bindings, let* is executed faster */
- 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));
return scm_m_letstar (scm_cons2 (SCM_CAR (expr), SCM_EOL, body), env);
}
else
check_bindings (bindings, expr);
transform_bindings (bindings, expr, &rvariables, &inits);
- 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));
return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body));
}
}
SCM rvars, inits, body, letrec;
check_bindings (defs, xorig);
transform_bindings (defs, xorig, &rvars, &inits);
- body = scm_m_body (SCM_IM_DEFINE, x, what);
+ body = scm_m_body (SCM_IM_DEFINE, x);
letrec = scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body));
SCM_SETCAR (xorig, letrec);
SCM_SETCDR (xorig, SCM_EOL);