mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

* eval.c (s_bad_bindings, s_bad_binding, s_bad_exit_clause): New

Browse source 
static identifiers.

	(scm_m_do): Use ASSERT_SYNTAX to signal syntax errors.  Be more
	specific about the kind of error that was detected.  Avoid use of
	SCM_CDRLOC.  Avoid unnecessary consing when creating the memoized
	code, this way also making sure that file name, line number
	information etc. remain available.
This commit is contained in:
Dirk Herrmann 2003-10-12 09:22:52 +00:00
parent 8ae95199fd
commit a954ce1d25
2 changed files with 84 additions and 42 deletions
Download patch file Download diff file Expand all files Collapse all files

11
libguile/ChangeLog
View file

@ -1,3 +1,14 @@
2003-10-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
* eval.c (s_bad_bindings, s_bad_binding, s_bad_exit_clause): New
static identifiers.
(scm_m_do): Use ASSERT_SYNTAX to signal syntax errors. Be more
specific about the kind of error that was detected. Avoid use of
SCM_CDRLOC. Avoid unnecessary consing when creating the memoized
code, this way also making sure that file name, line number
information etc. remain available.
2003-10-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
* eval.c (memoize_as_thunk_prototype): New static function.

115
libguile/eval.c
View file

@ -151,6 +151,22 @@ static const char s_missing_recipient[] = "Missing recipient in";
* detected, a 'Bad variable' error is signalled. */
static const char s_bad_variable[] = "Bad variable";
/* Bindings for forms like 'let' and 'do' have to be given in a proper,
* possibly empty list. If any other object is detected in a place where a
* list of bindings was required, a 'Bad bindings' error is signalled. */
static const char s_bad_bindings[] = "Bad bindings";
/* Depending on the syntactic context, a binding has to be in the format
* (<variable> <expression>) or (<variable> <expression1> <expression2>).
* If anything else is detected in a place where a binding was expected, a
* 'Bad binding' error is signalled. */
static const char s_bad_binding[] = "Bad binding";
/* If the exit form of a 'do' expression is not in the format
* (<test> <expression> ...)
* a 'Bad exit clause' error is signalled. */
static const char s_bad_exit_clause[] = "Bad exit clause";
/* Signal a syntax error. We distinguish between the form that caused the
* error and the enclosing expression. The error message will print out as
@ -966,64 +982,79 @@ scm_m_delay (SCM expr, SCM env)
}
SCM_SYNTAX(s_do, "do", scm_i_makbimacro, scm_m_do);
SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
/* DO gets the most radically altered syntax. The order of the vars is
* reversed here. In contrast, the order of the inits and steps is reversed
* during the evaluation:
(do ((<var1> <init1> <step1>)
(<var2> <init2>)
... )
(<test> <return>)
<body>)
(<var2> <init2>)
... )
(<test> <return>)
<body>)
;; becomes
(#@do (<init1> <init2> ... <initn>)
(varn ... var2 var1)
(<test> <return>)
(<body>)
<step1> <step2> ... <stepn>) ;; missing steps replaced by var
(varn ... var2 var1)
(<test> <return>)
(<body>)
<step1> <step2> ... <stepn>) ;; missing steps replaced by var
*/
SCM_SYNTAX(s_do, "do", scm_i_makbimacro, scm_m_do);
SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
SCM
scm_m_do (SCM xorig, SCM env SCM_UNUSED)
scm_m_do (SCM expr, SCM env SCM_UNUSED)
{
SCM bindings;
SCM x = SCM_CDR (xorig);
SCM vars = SCM_EOL;
SCM inits = SCM_EOL;
SCM *initloc = &inits;
SCM steps = SCM_EOL;
SCM *steploc = &steps;
SCM_ASSYNT (scm_ilength (x) >= 2, s_test, "do");
bindings = SCM_CAR (x);
SCM_ASSYNT (scm_ilength (bindings) >= 0, s_bindings, "do");
while (!SCM_NULLP (bindings))
SCM variables = SCM_EOL;
SCM init_forms = SCM_EOL;
SCM step_forms = SCM_EOL;
SCM binding_idx;
SCM cddr_expr;
SCM exit_clause;
SCM commands;
SCM tail;
const SCM cdr_expr = SCM_CDR (expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
/* Collect variables, init and step forms. */
binding_idx = SCM_CAR (cdr_expr);
ASSERT_SYNTAX_2 (scm_ilength (binding_idx) >= 0,
s_bad_bindings, binding_idx, expr);
for (; !SCM_NULLP (binding_idx); binding_idx = SCM_CDR (binding_idx))
{
SCM binding = SCM_CAR (bindings);
long len = scm_ilength (binding);
SCM_ASSYNT (len == 2 || len == 3, s_bindings, "do");
const SCM binding = SCM_CAR (binding_idx);
const long length = scm_ilength (binding);
ASSERT_SYNTAX_2 (length == 2 || length == 3,
s_bad_binding, binding, expr);
{
SCM name = SCM_CAR (binding);
SCM init = SCM_CADR (binding);
SCM step = (len == 2) ? name : SCM_CADDR (binding);
SCM_ASSYNT (SCM_SYMBOLP (name), s_variable, "do");
vars = scm_cons (name, vars);
*initloc = scm_list_1 (init);
initloc = SCM_CDRLOC (*initloc);
*steploc = scm_list_1 (step);
steploc = SCM_CDRLOC (*steploc);
bindings = SCM_CDR (bindings);
const SCM name = SCM_CAR (binding);
const SCM init = SCM_CADR (binding);
const SCM step = (length == 2) ? name : SCM_CADDR (binding);
ASSERT_SYNTAX_2 (SCM_SYMBOLP (name), s_bad_variable, name, expr);
variables = scm_cons (name, variables);
init_forms = scm_cons (init, init_forms);
step_forms = scm_cons (step, step_forms);
}
}
x = SCM_CDR (x);
SCM_ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, s_test, "do");
x = scm_cons2 (SCM_CAR (x), SCM_CDR (x), steps);
x = scm_cons2 (inits, vars, x);
return scm_cons (SCM_IM_DO, x);
init_forms = scm_reverse_x (init_forms, SCM_UNDEFINED);
step_forms = scm_reverse_x (step_forms, SCM_UNDEFINED);
/* Memoize the test form and the exit sequence. */
cddr_expr = SCM_CDR (cdr_expr);
exit_clause = SCM_CAR (cddr_expr);
ASSERT_SYNTAX_2 (scm_ilength (exit_clause) >= 1,
s_bad_exit_clause, exit_clause, expr);
commands = SCM_CDR (cddr_expr);
tail = scm_cons2 (exit_clause, commands, step_forms);
tail = scm_cons2 (init_forms, variables, tail);
SCM_SETCAR (expr, SCM_IM_DO);
SCM_SETCDR (expr, tail);
return expr;
}