-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003, 2004 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004
+ * Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
\f
-/* This file is read twice in order to produce debugging versions of
- * scm_ceval and scm_apply. These functions, scm_deval and
- * scm_dapply, are produced when we define the preprocessor macro
- * DEVAL. The file is divided into sections which are treated
- * differently with respect to DEVAL. The heads of these sections are
- * marked with the string "SECTION:".
- */
+/* This file is read twice in order to produce debugging versions of ceval and
+ * scm_apply. These functions, deval and scm_dapply, are produced when we
+ * define the preprocessor macro DEVAL. The file is divided into sections
+ * which are treated differently with respect to DEVAL. The heads of these
+ * sections are marked with the string "SECTION:". */
/* SECTION: This code is compiled once.
*/
#include "libguile/modules.h"
#include "libguile/objects.h"
#include "libguile/ports.h"
+#include "libguile/print.h"
#include "libguile/procprop.h"
#include "libguile/root.h"
#include "libguile/smob.h"
* is signalled. */
static const char s_bad_define[] = "Bad define placement";
+/* If a macro keyword is detected in a place where macro keywords are not
+ * allowed, a 'Misplaced syntactic keyword' error is signalled. */
+static const char s_macro_keyword[] = "Misplaced syntactic keyword";
+
/* Case or cond expressions must have at least one clause. If a case or cond
* expression without any clauses is detected, a 'Missing clauses' error is
* signalled. */
* boolean value indicating whether the binding is the last binding in the
* frame.
*/
+
#define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
+#define SCM_IFRINC (0x00000100L)
+#define SCM_ICDR (0x00080000L)
#define SCM_IDINC (0x00100000L)
+#define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
+ & (SCM_UNPACK (n) >> 8))
+#define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
+#define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
#define SCM_IDSTMSK (-SCM_IDINC)
#define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
SCM_PACK ( \
+ ((last_p) ? SCM_ICDR : 0) \
+ scm_tc8_iloc )
+void
+scm_i_print_iloc (SCM iloc, SCM port)
+{
+ scm_puts ("#@", port);
+ scm_intprint ((long) SCM_IFRAME (iloc), 10, port);
+ scm_putc (SCM_ICDRP (iloc) ? '-' : '+', port);
+ scm_intprint ((long) SCM_IDIST (iloc), 10, port);
+}
+
#if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
SCM scm_dbg_make_iloc (SCM frame, SCM binding, SCM cdrp);
\f
+/* {Evaluator byte codes (isyms)}
+ */
+
+#define ISYMNUM(n) (SCM_ITAG8_DATA (n))
+
+/* This table must agree with the list of SCM_IM_ constants in tags.h */
+static const char *const isymnames[] =
+{
+ "#@and",
+ "#@begin",
+ "#@case",
+ "#@cond",
+ "#@do",
+ "#@if",
+ "#@lambda",
+ "#@let",
+ "#@let*",
+ "#@letrec",
+ "#@or",
+ "#@quote",
+ "#@set!",
+ "#@define",
+ "#@apply",
+ "#@call-with-current-continuation",
+ "#@dispatch",
+ "#@slot-ref",
+ "#@slot-set!",
+ "#@delay",
+ "#@future",
+ "#@call-with-values",
+ "#@else",
+ "#@arrow",
+ "#@nil-cond",
+ "#@bind"
+};
+
+void
+scm_i_print_isym (SCM isym, SCM port)
+{
+ const size_t isymnum = ISYMNUM (isym);
+ if (isymnum < (sizeof isymnames / sizeof (char *)))
+ scm_puts (isymnames[isymnum], port);
+ else
+ scm_ipruk ("isym", isym, port);
+}
+
+\f
+
/* The function lookup_symbol is used during memoization: Lookup the symbol
* in the environment. If there is no binding for the symbol, SCM_UNDEFINED
* is returned. If the symbol is a syntactic keyword, the macro object to
return 0;
}
+
+/* Return true if the expression is self-quoting in the memoized code. Thus,
+ * some other objects (like e. g. vectors) are reported as self-quoting, which
+ * according to R5RS would need to be quoted. */
+static int
+is_self_quoting_p (const SCM expr)
+{
+ if (SCM_CONSP (expr))
+ return 0;
+ else if (SCM_SYMBOLP (expr))
+ return 0;
+ else if (SCM_NULLP (expr))
+ return 0;
+ else return 1;
+}
+
\f
/* Lookup a given local variable in an environment. The local variable is
var = SCM_CAR (vloc);
if (SCM_VARIABLEP (var))
return SCM_VARIABLE_LOC (var);
- if (SCM_ITAG7 (var) == SCM_ITAG7 (SCM_ILOC00))
+ if (SCM_ILOCP (var))
return scm_ilookup (var, genv);
/* We can't cope with anything else than variables and ilocs. When
a special form has been memoized (i.e. `let' into `#@let') we
}
}
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-/* Deprecated in guile 1.7.0 on 2003-11-09. */
-SCM
-scm_m_expand_body (SCM exprs, SCM env)
-{
- scm_c_issue_deprecation_warning
- ("`scm_m_expand_body' is deprecated.");
- m_expand_body (exprs, env);
- return exprs;
-}
-
-#endif
-
/* Start of the memoizers for the standard R5RS builtin macros. */
return expr;
}
+/* According to section 5.2.1 of R5RS we first have to make sure that the
+ * variable is bound, and then perform the (set! variable expression)
+ * operation. This means, that within the expression we may already assign
+ * values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */
SCM
scm_m_define (SCM expr, SCM env)
{
const SCM canonical_definition = canonicalize_define (expr);
const SCM cdr_canonical_definition = SCM_CDR (canonical_definition);
const SCM variable = SCM_CAR (cdr_canonical_definition);
- const SCM body = SCM_CDR (cdr_canonical_definition);
- const SCM value = scm_eval_car (body, env);
+ const SCM location
+ = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T);
+ const SCM value = scm_eval_car (SCM_CDR (cdr_canonical_definition), env);
- SCM var;
if (SCM_REC_PROCNAMES_P)
{
SCM tmp = value;
scm_set_procedure_property_x (tmp, scm_sym_name, variable);
}
- var = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T);
- SCM_VARIABLE_SET (var, value);
+ SCM_VARIABLE_SET (location, value);
return SCM_UNSPECIFIED;
}
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
quotee = SCM_CAR (cdr_expr);
- if (SCM_IMP (quotee) && !SCM_NULLP (quotee))
- return quotee;
- else if (SCM_VECTORP (quotee))
+ if (is_self_quoting_p (quotee))
return quotee;
-#if 0
- /* The following optimization would be possible if all variable references
- * were resolved during memoization: */
- else if (SCM_SYMBOLP (quotee))
- return quotee;
-#endif
SCM_SETCAR (expr, SCM_IM_QUOTE);
return expr;
}
scm_m_set_x (SCM expr, SCM env SCM_UNUSED)
{
SCM variable;
+ SCM new_variable;
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_expression, expr);
variable = SCM_CAR (cdr_expr);
- ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable) || SCM_VARIABLEP (variable),
- s_bad_variable, variable, expr);
+
+ /* Memoize the variable form. */
+ ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr);
+ new_variable = lookup_symbol (variable, env);
+ ASSERT_SYNTAX (!SCM_MACROP (new_variable), s_macro_keyword, variable);
+ /* Leave the memoization of unbound symbols to lazy memoization: */
+ if (SCM_UNBNDP (new_variable))
+ new_variable = variable;
SCM_SETCAR (expr, SCM_IM_SET_X);
+ SCM_SETCAR (cdr_expr, new_variable);
return expr;
}
#endif /* SCM_ENABLE_ELISP */
-/* Start of the memoizers for deprecated macros. */
+#if (SCM_ENABLE_DEPRECATED == 1)
+/* Deprecated in guile 1.7.0 on 2003-11-09. */
+SCM
+scm_m_expand_body (SCM exprs, SCM env)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_m_expand_body' is deprecated.");
+ m_expand_body (exprs, env);
+ return exprs;
+}
-#if (SCM_ENABLE_DEPRECATED == 1)
SCM_SYNTAX (s_undefine, "undefine", scm_makacro, scm_m_undefine);
return SCM_UNSPECIFIED;
}
-#endif
-
-
-#if (SCM_ENABLE_DEPRECATED == 1)
SCM
scm_macroexp (SCM x, SCM env)
}
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-SCM
-scm_unmemocar (SCM form, SCM env)
-{
- return unmemocar (form, env);
-}
-
-#endif
-
-
SCM
scm_unmemocopy (SCM x, SCM env)
{
return x;
p = scm_whash_lookup (scm_source_whash, x);
- switch (SCM_ITAG7 (SCM_CAR (x)))
+ if (SCM_ISYMP (SCM_CAR (x)))
{
- case SCM_BIT7 (SCM_IM_AND):
- ls = z = scm_cons (scm_sym_and, SCM_UNSPECIFIED);
- break;
- case SCM_BIT7 (SCM_IM_BEGIN):
- ls = z = scm_cons (scm_sym_begin, SCM_UNSPECIFIED);
- break;
- case SCM_BIT7 (SCM_IM_CASE):
- ls = z = scm_cons (scm_sym_case, SCM_UNSPECIFIED);
- break;
- case SCM_BIT7 (SCM_IM_COND):
- ls = z = scm_cons (scm_sym_cond, SCM_UNSPECIFIED);
- break;
- case SCM_BIT7 (SCM_IM_DO):
- {
- /* format: (#@do (i1 ... ik) (nk nk-1 ...) (test) (body) s1 ... sk),
- * where ix is an initializer for a local variable, nx is the name of
- * the local variable, test is the test clause of the do loop, body is
- * the body of the do loop and sx are the step clauses for the local
- * variables. */
- SCM names, inits, test, memoized_body, steps, bindings;
-
- x = SCM_CDR (x);
- inits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env));
- x = SCM_CDR (x);
- names = SCM_CAR (x);
- env = SCM_EXTEND_ENV (names, SCM_EOL, env);
- x = SCM_CDR (x);
- test = scm_unmemocopy (SCM_CAR (x), env);
- x = SCM_CDR (x);
- memoized_body = SCM_CAR (x);
- x = SCM_CDR (x);
- steps = scm_reverse (scm_unmemocopy (x, env));
-
- /* build transformed binding list */
- bindings = SCM_EOL;
- while (!SCM_NULLP (names))
- {
- SCM name = SCM_CAR (names);
- SCM init = SCM_CAR (inits);
- SCM step = SCM_CAR (steps);
- step = SCM_EQ_P (step, name) ? SCM_EOL : scm_list_1 (step);
+ switch (ISYMNUM (SCM_CAR (x)))
+ {
+ case (ISYMNUM (SCM_IM_AND)):
+ ls = z = scm_cons (scm_sym_and, SCM_UNSPECIFIED);
+ break;
+ case (ISYMNUM (SCM_IM_BEGIN)):
+ ls = z = scm_cons (scm_sym_begin, SCM_UNSPECIFIED);
+ break;
+ case (ISYMNUM (SCM_IM_CASE)):
+ ls = z = scm_cons (scm_sym_case, SCM_UNSPECIFIED);
+ break;
+ case (ISYMNUM (SCM_IM_COND)):
+ ls = z = scm_cons (scm_sym_cond, SCM_UNSPECIFIED);
+ break;
+ case (ISYMNUM (SCM_IM_DO)):
+ {
+ /* format: (#@do (i1 ... ik) (nk ... n1) (test) (body) s1 ... sk),
+ * where ix is an initializer for a local variable, nx is the name
+ * of the local variable, test is the test clause of the do loop,
+ * body is the body of the do loop and sx are the step clauses for
+ * the local variables. */
+ SCM names, inits, test, memoized_body, steps, bindings;
+
+ x = SCM_CDR (x);
+ inits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env));
+ x = SCM_CDR (x);
+ names = SCM_CAR (x);
+ env = SCM_EXTEND_ENV (names, SCM_EOL, env);
+ x = SCM_CDR (x);
+ test = scm_unmemocopy (SCM_CAR (x), env);
+ x = SCM_CDR (x);
+ memoized_body = SCM_CAR (x);
+ x = SCM_CDR (x);
+ steps = scm_reverse (scm_unmemocopy (x, env));
+
+ /* build transformed binding list */
+ bindings = SCM_EOL;
+ while (!SCM_NULLP (names))
+ {
+ SCM name = SCM_CAR (names);
+ SCM init = SCM_CAR (inits);
+ SCM step = SCM_CAR (steps);
+ step = SCM_EQ_P (step, name) ? SCM_EOL : scm_list_1 (step);
- bindings = scm_cons (scm_cons2 (name, init, step), bindings);
+ bindings = scm_cons (scm_cons2 (name, init, step), bindings);
- names = SCM_CDR (names);
- inits = SCM_CDR (inits);
- steps = SCM_CDR (steps);
- }
- z = scm_cons (test, SCM_UNSPECIFIED);
- ls = scm_cons2 (scm_sym_do, bindings, z);
+ names = SCM_CDR (names);
+ inits = SCM_CDR (inits);
+ steps = SCM_CDR (steps);
+ }
+ z = scm_cons (test, SCM_UNSPECIFIED);
+ ls = scm_cons2 (scm_sym_do, bindings, z);
- x = scm_cons (SCM_BOOL_F, memoized_body);
- break;
- }
- case SCM_BIT7 (SCM_IM_IF):
- ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED);
- break;
- case SCM_BIT7 (SCM_IM_LET):
- {
- /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
- * where nx is the name of a local variable, ix is an initializer for
- * the local variable and by are the body clauses. */
- SCM rnames, rinits, bindings;
-
- x = SCM_CDR (x);
- rnames = SCM_CAR (x);
- x = SCM_CDR (x);
- rinits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env));
- env = SCM_EXTEND_ENV (rnames, SCM_EOL, env);
-
- bindings = build_binding_list (rnames, rinits);
- z = scm_cons (bindings, SCM_UNSPECIFIED);
- ls = scm_cons (scm_sym_let, z);
- break;
- }
- case SCM_BIT7 (SCM_IM_LETREC):
- {
- /* format: (#@letrec (vn ... v2 v1) (i1 i2 ... in) b1 ...),
- * where vx is the name of a local variable, ix is an initializer for
- * the local variable and by are the body clauses. */
- SCM rnames, rinits, bindings;
-
- x = SCM_CDR (x);
- rnames = SCM_CAR (x);
- env = SCM_EXTEND_ENV (rnames, SCM_EOL, env);
- x = SCM_CDR (x);
- rinits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env));
-
- bindings = build_binding_list (rnames, rinits);
- z = scm_cons (bindings, SCM_UNSPECIFIED);
- ls = scm_cons (scm_sym_letrec, z);
- break;
- }
- case SCM_BIT7 (SCM_IM_LETSTAR):
- {
- SCM b, y;
- x = SCM_CDR (x);
- b = SCM_CAR (x);
- y = SCM_EOL;
- if SCM_IMP (b)
- {
- env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env);
- goto letstar;
- }
- y = z = scm_acons (SCM_CAR (b),
- unmemocar (
- scm_cons (scm_unmemocopy (SCM_CADR (b), env), SCM_EOL), env),
- SCM_UNSPECIFIED);
- env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
- b = SCM_CDDR (b);
- if (SCM_IMP (b))
- {
- SCM_SETCDR (y, SCM_EOL);
- z = scm_cons (y, SCM_UNSPECIFIED);
+ x = scm_cons (SCM_BOOL_F, memoized_body);
+ break;
+ }
+ case (ISYMNUM (SCM_IM_IF)):
+ ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED);
+ break;
+ case (ISYMNUM (SCM_IM_LET)):
+ {
+ /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
+ * where nx is the name of a local variable, ix is an initializer
+ * for the local variable and by are the body clauses. */
+ SCM rnames, rinits, bindings;
+
+ x = SCM_CDR (x);
+ rnames = SCM_CAR (x);
+ x = SCM_CDR (x);
+ rinits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env));
+ env = SCM_EXTEND_ENV (rnames, SCM_EOL, env);
+
+ bindings = build_binding_list (rnames, rinits);
+ z = scm_cons (bindings, SCM_UNSPECIFIED);
ls = scm_cons (scm_sym_let, z);
- break;
- }
- do
- {
- SCM_SETCDR (z, scm_acons (SCM_CAR (b),
- unmemocar (
- scm_list_1 (scm_unmemocopy (SCM_CADR (b), env)), env),
- SCM_UNSPECIFIED));
- z = SCM_CDR (z);
- env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
- b = SCM_CDDR (b);
- }
- while (SCM_NIMP (b));
- SCM_SETCDR (z, SCM_EOL);
- letstar:
- z = scm_cons (y, SCM_UNSPECIFIED);
- ls = scm_cons (scm_sym_letstar, z);
- break;
- }
- case SCM_BIT7 (SCM_IM_OR):
- ls = z = scm_cons (scm_sym_or, SCM_UNSPECIFIED);
- break;
- case SCM_BIT7 (SCM_IM_LAMBDA):
- x = SCM_CDR (x);
- z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED);
- ls = scm_cons (scm_sym_lambda, z);
- env = SCM_EXTEND_ENV (SCM_CAR (x), SCM_EOL, env);
- break;
- case SCM_BIT7 (SCM_IM_QUOTE):
- ls = z = scm_cons (scm_sym_quote, SCM_UNSPECIFIED);
- break;
- case SCM_BIT7 (SCM_IM_SET_X):
- ls = z = scm_cons (scm_sym_set_x, SCM_UNSPECIFIED);
- break;
- case SCM_BIT7 (SCM_MAKISYM (0)):
- z = SCM_CAR (x);
- switch (SCM_ISYMNUM (z))
- {
- case (SCM_ISYMNUM (SCM_IM_APPLY)):
+ break;
+ }
+ case (ISYMNUM (SCM_IM_LETREC)):
+ {
+ /* format: (#@letrec (vn ... v2 v1) (i1 i2 ... in) b1 ...),
+ * where vx is the name of a local variable, ix is an initializer
+ * for the local variable and by are the body clauses. */
+ SCM rnames, rinits, bindings;
+
+ x = SCM_CDR (x);
+ rnames = SCM_CAR (x);
+ env = SCM_EXTEND_ENV (rnames, SCM_EOL, env);
+ x = SCM_CDR (x);
+ rinits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env));
+
+ bindings = build_binding_list (rnames, rinits);
+ z = scm_cons (bindings, SCM_UNSPECIFIED);
+ ls = scm_cons (scm_sym_letrec, z);
+ break;
+ }
+ case (ISYMNUM (SCM_IM_LETSTAR)):
+ {
+ SCM b, y;
+ x = SCM_CDR (x);
+ b = SCM_CAR (x);
+ y = SCM_EOL;
+ if (SCM_NULLP (b))
+ {
+ env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env);
+ }
+ else
+ {
+ SCM copy = scm_unmemocopy (SCM_CADR (b), env);
+ SCM initializer = unmemocar (scm_list_1 (copy), env);
+ y = z = scm_acons (SCM_CAR (b), initializer, SCM_UNSPECIFIED);
+ env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
+ b = SCM_CDDR (b);
+ if (SCM_NULLP (b))
+ {
+ SCM_SETCDR (y, SCM_EOL);
+ z = scm_cons (y, SCM_UNSPECIFIED);
+ ls = scm_cons (scm_sym_let, z);
+ break;
+ }
+ do
+ {
+ copy = scm_unmemocopy (SCM_CADR (b), env);
+ initializer = unmemocar (scm_list_1 (copy), env);
+ SCM_SETCDR (z, scm_acons (SCM_CAR (b),
+ initializer,
+ SCM_UNSPECIFIED));
+ z = SCM_CDR (z);
+ env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
+ b = SCM_CDDR (b);
+ }
+ while (!SCM_NULLP (b));
+ SCM_SETCDR (z, SCM_EOL);
+ }
+ z = scm_cons (y, SCM_UNSPECIFIED);
+ ls = scm_cons (scm_sym_letstar, z);
+ break;
+ }
+ case (ISYMNUM (SCM_IM_OR)):
+ ls = z = scm_cons (scm_sym_or, SCM_UNSPECIFIED);
+ break;
+ case (ISYMNUM (SCM_IM_LAMBDA)):
+ x = SCM_CDR (x);
+ z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED);
+ ls = scm_cons (scm_sym_lambda, z);
+ env = SCM_EXTEND_ENV (SCM_CAR (x), SCM_EOL, env);
+ break;
+ case (ISYMNUM (SCM_IM_QUOTE)):
+ ls = z = scm_cons (scm_sym_quote, SCM_UNSPECIFIED);
+ break;
+ case (ISYMNUM (SCM_IM_SET_X)):
+ ls = z = scm_cons (scm_sym_set_x, SCM_UNSPECIFIED);
+ break;
+ case (ISYMNUM (SCM_IM_APPLY)):
ls = z = scm_cons (scm_sym_atapply, SCM_UNSPECIFIED);
- goto loop;
- case (SCM_ISYMNUM (SCM_IM_CONT)):
+ break;
+ case (ISYMNUM (SCM_IM_CONT)):
ls = z = scm_cons (scm_sym_atcall_cc, SCM_UNSPECIFIED);
- goto loop;
- case (SCM_ISYMNUM (SCM_IM_DELAY)):
+ break;
+ case (ISYMNUM (SCM_IM_DELAY)):
ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED);
x = SCM_CDR (x);
- goto loop;
- case (SCM_ISYMNUM (SCM_IM_FUTURE)):
+ break;
+ case (ISYMNUM (SCM_IM_FUTURE)):
ls = z = scm_cons (scm_sym_future, SCM_UNSPECIFIED);
x = SCM_CDR (x);
- goto loop;
- case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
+ break;
+ case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
ls = z = scm_cons (scm_sym_at_call_with_values, SCM_UNSPECIFIED);
- goto loop;
- case (SCM_ISYMNUM (SCM_IM_ELSE)):
+ break;
+ case (ISYMNUM (SCM_IM_ELSE)):
ls = z = scm_cons (scm_sym_else, SCM_UNSPECIFIED);
- goto loop;
- default:
- /* appease the Sun compiler god: */ ;
- }
- default:
+ break;
+ default:
+ ls = z = unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x), env),
+ SCM_UNSPECIFIED),
+ env);
+ }
+ }
+ else
+ {
ls = z = unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x), env),
SCM_UNSPECIFIED),
env);
}
-loop:
+
x = SCM_CDR (x);
while (SCM_CONSP (x))
{
}
+#if (SCM_ENABLE_DEPRECATED == 1)
+
+SCM
+scm_unmemocar (SCM form, SCM env)
+{
+ return unmemocar (form, env);
+}
+
+#endif
+
/*****************************************************************************/
/*****************************************************************************/
/* The definitions for execution start here. */
\f
-/* The evaluator contains a plethora of EVAL symbols.
- * This is an attempt at explanation.
+/* The evaluator contains a plethora of EVAL symbols. This is an attempt at
+ * explanation.
*
- * The following macros should be used in code which is read twice
- * (where the choice of evaluator is hard soldered):
+ * The following macros should be used in code which is read twice (where the
+ * choice of evaluator is hard soldered):
*
- * SCM_CEVAL is the symbol used within one evaluator to call itself.
- * Originally, it is defined to scm_ceval, but is redefined to
- * scm_deval during the second pass.
+ * CEVAL is the symbol used within one evaluator to call itself.
+ * Originally, it is defined to ceval, but is redefined to deval during the
+ * second pass.
*
* SCM_EVALIM is used when it is known that the expression is an
* immediate. (This macro never calls an evaluator.)
- *
- * EVALCAR evaluates the car of an expression.
+ *
+ * EVAL evaluates an expression that is expected to have its symbols already
+ * memoized. Expressions that are not of the form '(<form> <form> ...)' are
+ * evaluated inline without calling an evaluator.
+ *
+ * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
+ * potentially replacing a symbol at the position Y:<form> by its memoized
+ * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
+ * evaluation is performed inline without calling an evaluator.
*
* The following macros should be used in code which is read once
* (where the choice of evaluator is dynamic):
*
- * SCM_XEVAL takes care of immediates without calling an evaluator. It
- * then calls scm_ceval *or* scm_deval, depending on the debugging
- * mode.
+ * SCM_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
+ * debugging mode.
*
- * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
- * depending on the debugging mode.
+ * SCM_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
+ * on the debugging mode.
*
* The main motivation for keeping this plethora is efficiency
* together with maintainability (=> locality of code).
*/
-#define SCM_CEVAL scm_ceval
+static SCM ceval (SCM x, SCM env);
+static SCM deval (SCM x, SCM env);
+#define CEVAL ceval
+
#define SCM_EVALIM2(x) \
((SCM_EQ_P ((x), SCM_EOL) \
(x))
#define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
- ? *scm_ilookup ((x), env) \
+ ? *scm_ilookup ((x), (env)) \
: SCM_EVALIM2(x))
-#define SCM_XEVAL(x, env) (SCM_IMP (x) \
- ? SCM_EVALIM2(x) \
- : (*scm_ceval_ptr) ((x), (env)))
+#define SCM_XEVAL(x, env) \
+ (SCM_IMP (x) \
+ ? SCM_EVALIM2 (x) \
+ : (SCM_VARIABLEP (x) \
+ ? SCM_VARIABLE_REF (x) \
+ : (SCM_CONSP (x) \
+ ? (scm_debug_mode_p \
+ ? deval ((x), (env)) \
+ : ceval ((x), (env))) \
+ : (x))))
+
+#define SCM_XEVALCAR(x, env) \
+ (SCM_IMP (SCM_CAR (x)) \
+ ? SCM_EVALIM (SCM_CAR (x), (env)) \
+ : (SCM_VARIABLEP (SCM_CAR (x)) \
+ ? SCM_VARIABLE_REF (SCM_CAR (x)) \
+ : (SCM_CONSP (SCM_CAR (x)) \
+ ? (scm_debug_mode_p \
+ ? deval (SCM_CAR (x), (env)) \
+ : ceval (SCM_CAR (x), (env))) \
+ : (!SCM_SYMBOLP (SCM_CAR (x)) \
+ ? SCM_CAR (x) \
+ : *scm_lookupcar ((x), (env), 1)))))
+
+#define EVAL(x, env) \
+ (SCM_IMP (x) \
+ ? SCM_EVALIM ((x), (env)) \
+ : (SCM_VARIABLEP (x) \
+ ? SCM_VARIABLE_REF (x) \
+ : (SCM_CONSP (x) \
+ ? CEVAL ((x), (env)) \
+ : (x))))
+
+#define EVALCAR(x, env) \
+ (SCM_IMP (SCM_CAR (x)) \
+ ? SCM_EVALIM (SCM_CAR (x), (env)) \
+ : (SCM_VARIABLEP (SCM_CAR (x)) \
+ ? SCM_VARIABLE_REF (SCM_CAR (x)) \
+ : (SCM_CONSP (SCM_CAR (x)) \
+ ? CEVAL (SCM_CAR (x), (env)) \
+ : (!SCM_SYMBOLP (SCM_CAR (x)) \
+ ? SCM_CAR (x) \
+ : *scm_lookupcar ((x), (env), 1)))))
-#define SCM_XEVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
- ? SCM_EVALIM (SCM_CAR (x), env) \
- : (SCM_SYMBOLP (SCM_CAR (x)) \
- ? *scm_lookupcar (x, env, 1) \
- : (*scm_ceval_ptr) (SCM_CAR (x), env)))
+SCM_REC_MUTEX (source_mutex);
-#define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
- ? SCM_EVALIM (SCM_CAR (x), env) \
- : (SCM_SYMBOLP (SCM_CAR (x)) \
- ? *scm_lookupcar (x, env, 1) \
- : SCM_CEVAL (SCM_CAR (x), env)))
-SCM_REC_MUTEX (source_mutex);
+/* During execution, look up a symbol in the top level of the given local
+ * environment and return the corresponding variable object. If no binding
+ * for the symbol can be found, an 'Unbound variable' error is signalled. */
+static SCM
+lazy_memoize_variable (const SCM symbol, const SCM environment)
+{
+ const SCM top_level = scm_env_top_level (environment);
+ const SCM variable = scm_sym2var (symbol, top_level, SCM_BOOL_F);
+
+ if (SCM_FALSEP (variable))
+ error_unbound_variable (symbol);
+ else
+ return variable;
+}
SCM
scm_eval_body (SCM code, SCM env)
{
SCM next;
+
again:
next = SCM_CDR (code);
while (!SCM_NULLP (next))
#else /* !DEVAL */
-#undef SCM_CEVAL
-#define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
+#undef CEVAL
+#define CEVAL deval /* Substitute all uses of ceval */
+
#undef SCM_APPLY
#define SCM_APPLY scm_dapply
+
#undef PREP_APPLY
#define PREP_APPLY(p, l) \
{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
+
#undef ENTER_APPLY
#define ENTER_APPLY \
do { \
SCM_TRAPS_P = 1;\
}\
} while (0)
+
#undef RETURN
#define RETURN(e) do { proc = (e); goto exit; } while (0)
+
#ifdef STACK_CHECKING
#ifndef EVAL_STACK_CHECKING
#define EVAL_STACK_CHECKING
#endif
#endif
-/* scm_ceval_ptr points to the currently selected evaluator.
- * *fixme*: Although efficiency is important here, this state variable
- * should probably not be a global. It should be related to the
- * current repl.
- */
-
-SCM (*scm_ceval_ptr) (SCM x, SCM env);
-
-/* scm_last_debug_frame contains a pointer to the last debugging
- * information stack frame. It is accessed very often from the
- * debugging evaluator, so it should probably not be indirectly
- * addressed. Better to save and restore it from the current root at
- * any stack swaps.
+/* scm_last_debug_frame contains a pointer to the last debugging information
+ * stack frame. It is accessed very often from the debugging evaluator, so it
+ * should probably not be indirectly addressed. Better to save and restore it
+ * from the current root at any stack swaps.
*/
/* scm_debug_eframe_size is the number of slots available for pseudo
long scm_debug_eframe_size;
-int scm_debug_mode, scm_check_entry_p, scm_check_apply_p, scm_check_exit_p;
+int scm_debug_mode_p;
+int scm_check_entry_p;
+int scm_check_apply_p;
+int scm_check_exit_p;
long scm_eval_stack;
static SCM
deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
{
- SCM *results = lloc, res;
+ SCM *results = lloc;
while (SCM_CONSP (l))
{
- res = EVALCAR (l, env);
+ const SCM res = EVALCAR (l, env);
*lloc = scm_list_1 (res);
lloc = SCM_CDRLOC (*lloc);
/* This is the evaluator. Like any real monster, it has three heads:
*
- * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
- * version. Both are implemented using a common code base, using the
- * following mechanism: SCM_CEVAL is a macro, which is either defined to
- * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
- * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
- * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
- * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
- * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
+ * ceval is the non-debugging evaluator, deval is the debugging version. Both
+ * are implemented using a common code base, using the following mechanism:
+ * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
+ * is no function CEVAL, but the code for CEVAL actually compiles to either
+ * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
+ * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
+ * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
* are enclosed within #ifdef DEVAL ... #endif.
*
- * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
- * take two input parameters, x and env: x is a single expression to be
- * evalutated. env is the environment in which bindings are searched.
+ * All three (ceval, deval and their common implementation CEVAL) take two
+ * input parameters, x and env: x is a single expression to be evalutated.
+ * env is the environment in which bindings are searched.
*
- * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
- * is a single expression, it is necessarily in a tail position. If x is just
- * a call to another function like in the expression (foo exp1 exp2 ...), the
- * realization of that call therefore _must_not_ increase stack usage (the
- * evaluation of exp1, exp2 etc., however, may do so). This is realized by
- * making extensive use of 'goto' statements within the evaluator: The gotos
- * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
- * that SCM_CEVAL was already using. If, however, x represents some form that
- * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
- * then recursive calls to SCM_CEVAL are performed for all but the last
- * expression of that sequence. */
-
-#if 0
-SCM
-scm_ceval (SCM x, SCM env)
-{}
-#endif
+ * x is known to be a pair. Since x is a single expression, it is necessarily
+ * in a tail position. If x is just a call to another function like in the
+ * expression (foo exp1 exp2 ...), the realization of that call therefore
+ * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
+ * however, may do so). This is realized by making extensive use of 'goto'
+ * statements within the evaluator: The gotos replace recursive calls to
+ * CEVAL, thus re-using the same stack frame that CEVAL was already using.
+ * If, however, x represents some form that requires to evaluate a sequence of
+ * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
+ * performed for all but the last expression of that sequence. */
-#if 0
-SCM
-scm_deval (SCM x, SCM env)
-{}
-#endif
-
-SCM
-SCM_CEVAL (SCM x, SCM env)
+static SCM
+CEVAL (SCM x, SCM env)
{
SCM proc, arg1;
#ifdef DEVAL
#endif
dispatch:
SCM_TICK;
- switch (SCM_TYP7 (x))
+ if (SCM_ISYMP (SCM_CAR (x)))
{
- case SCM_BIT7 (SCM_IM_AND):
- x = SCM_CDR (x);
- while (!SCM_NULLP (SCM_CDR (x)))
- {
- SCM test_result = EVALCAR (x, env);
- if (SCM_FALSEP (test_result) || SCM_NILP (test_result))
- RETURN (SCM_BOOL_F);
- else
- x = SCM_CDR (x);
- }
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
-
- case SCM_BIT7 (SCM_IM_BEGIN):
- x = SCM_CDR (x);
- if (SCM_NULLP (x))
- RETURN (SCM_UNSPECIFIED);
+ switch (ISYMNUM (SCM_CAR (x)))
+ {
+ case (ISYMNUM (SCM_IM_AND)):
+ x = SCM_CDR (x);
+ while (!SCM_NULLP (SCM_CDR (x)))
+ {
+ SCM test_result = EVALCAR (x, env);
+ if (SCM_FALSEP (test_result) || SCM_NILP (test_result))
+ RETURN (SCM_BOOL_F);
+ else
+ x = SCM_CDR (x);
+ }
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto carloop;
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ case (ISYMNUM (SCM_IM_BEGIN)):
+ x = SCM_CDR (x);
+ if (SCM_NULLP (x))
+ RETURN (SCM_UNSPECIFIED);
- begin:
- /* If we are on toplevel with a lookup closure, we need to sync
- with the current module. */
- if (SCM_CONSP (env) && !SCM_CONSP (SCM_CAR (env)))
- {
- UPDATE_TOPLEVEL_ENV (env);
- while (!SCM_NULLP (SCM_CDR (x)))
- {
- EVALCAR (x, env);
- UPDATE_TOPLEVEL_ENV (env);
- x = SCM_CDR (x);
- }
- goto carloop;
- }
- else
- goto nontoplevel_begin;
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- nontoplevel_begin:
- while (!SCM_NULLP (SCM_CDR (x)))
- {
- SCM form = SCM_CAR (x);
- if (SCM_IMP (form))
- {
- if (SCM_ISYMP (form))
- {
- scm_rec_mutex_lock (&source_mutex);
- /* check for race condition */
- if (SCM_ISYMP (SCM_CAR (x)))
- m_expand_body (x, env);
- scm_rec_mutex_unlock (&source_mutex);
- goto nontoplevel_begin;
- }
- else
- SCM_VALIDATE_NON_EMPTY_COMBINATION (form);
- }
- else
- SCM_CEVAL (form, env);
- x = SCM_CDR (x);
- }
-
- carloop:
- {
- /* scm_eval last form in list */
- SCM last_form = SCM_CAR (x);
+ begin:
+ /* If we are on toplevel with a lookup closure, we need to sync
+ with the current module. */
+ if (SCM_CONSP (env) && !SCM_CONSP (SCM_CAR (env)))
+ {
+ UPDATE_TOPLEVEL_ENV (env);
+ while (!SCM_NULLP (SCM_CDR (x)))
+ {
+ EVALCAR (x, env);
+ UPDATE_TOPLEVEL_ENV (env);
+ x = SCM_CDR (x);
+ }
+ goto carloop;
+ }
+ else
+ goto nontoplevel_begin;
- if (SCM_CONSP (last_form))
- {
- /* This is by far the most frequent case. */
- x = last_form;
- goto loop; /* tail recurse */
- }
- else if (SCM_IMP (last_form))
- RETURN (SCM_EVALIM (last_form, env));
- else if (SCM_VARIABLEP (last_form))
- RETURN (SCM_VARIABLE_REF (last_form));
- else if (SCM_SYMBOLP (last_form))
- RETURN (*scm_lookupcar (x, env, 1));
- else
- RETURN (last_form);
- }
+ nontoplevel_begin:
+ while (!SCM_NULLP (SCM_CDR (x)))
+ {
+ const SCM form = SCM_CAR (x);
+ if (SCM_IMP (form))
+ {
+ if (SCM_ISYMP (form))
+ {
+ scm_rec_mutex_lock (&source_mutex);
+ /* check for race condition */
+ if (SCM_ISYMP (SCM_CAR (x)))
+ m_expand_body (x, env);
+ scm_rec_mutex_unlock (&source_mutex);
+ goto nontoplevel_begin;
+ }
+ else
+ SCM_VALIDATE_NON_EMPTY_COMBINATION (form);
+ }
+ else
+ (void) EVAL (form, env);
+ x = SCM_CDR (x);
+ }
+ carloop:
+ {
+ /* scm_eval last form in list */
+ const SCM last_form = SCM_CAR (x);
- case SCM_BIT7 (SCM_IM_CASE):
- x = SCM_CDR (x);
- {
- SCM key = EVALCAR (x, env);
- x = SCM_CDR (x);
- while (!SCM_NULLP (x))
- {
- SCM clause = SCM_CAR (x);
- SCM labels = SCM_CAR (clause);
- if (SCM_EQ_P (labels, SCM_IM_ELSE))
- {
- x = SCM_CDR (clause);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
- }
- while (!SCM_NULLP (labels))
- {
- SCM label = SCM_CAR (labels);
- if (SCM_EQ_P (label, key) || !SCM_FALSEP (scm_eqv_p (label, key)))
- {
- x = SCM_CDR (clause);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
- }
- labels = SCM_CDR (labels);
- }
- x = SCM_CDR (x);
- }
- }
- RETURN (SCM_UNSPECIFIED);
+ if (SCM_CONSP (last_form))
+ {
+ /* This is by far the most frequent case. */
+ x = last_form;
+ goto loop; /* tail recurse */
+ }
+ else if (SCM_IMP (last_form))
+ RETURN (SCM_EVALIM (last_form, env));
+ else if (SCM_VARIABLEP (last_form))
+ RETURN (SCM_VARIABLE_REF (last_form));
+ else if (SCM_SYMBOLP (last_form))
+ RETURN (*scm_lookupcar (x, env, 1));
+ else
+ RETURN (last_form);
+ }
- case SCM_BIT7 (SCM_IM_COND):
- x = SCM_CDR (x);
- while (!SCM_NULLP (x))
- {
- SCM clause = SCM_CAR (x);
- if (SCM_EQ_P (SCM_CAR (clause), SCM_IM_ELSE))
- {
- x = SCM_CDR (clause);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
- }
- else
- {
- arg1 = EVALCAR (clause, env);
- if (!SCM_FALSEP (arg1) && !SCM_NILP (arg1))
- {
- x = SCM_CDR (clause);
- if (SCM_NULLP (x))
- RETURN (arg1);
- else if (!SCM_EQ_P (SCM_CAR (x), SCM_IM_ARROW))
- {
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
- }
- else
- {
- proc = SCM_CDR (x);
- proc = EVALCAR (proc, env);
- PREP_APPLY (proc, scm_list_1 (arg1));
- ENTER_APPLY;
- goto evap1;
- }
- }
- x = SCM_CDR (x);
- }
- }
- RETURN (SCM_UNSPECIFIED);
+ case (ISYMNUM (SCM_IM_CASE)):
+ x = SCM_CDR (x);
+ {
+ const SCM key = EVALCAR (x, env);
+ x = SCM_CDR (x);
+ while (!SCM_NULLP (x))
+ {
+ const SCM clause = SCM_CAR (x);
+ SCM labels = SCM_CAR (clause);
+ if (SCM_EQ_P (labels, SCM_IM_ELSE))
+ {
+ x = SCM_CDR (clause);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
+ while (!SCM_NULLP (labels))
+ {
+ const SCM label = SCM_CAR (labels);
+ if (SCM_EQ_P (label, key)
+ || !SCM_FALSEP (scm_eqv_p (label, key)))
+ {
+ x = SCM_CDR (clause);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
+ labels = SCM_CDR (labels);
+ }
+ x = SCM_CDR (x);
+ }
+ }
+ RETURN (SCM_UNSPECIFIED);
- case SCM_BIT7 (SCM_IM_DO):
- x = SCM_CDR (x);
- {
- /* Compute the initialization values and the initial environment. */
- SCM init_forms = SCM_CAR (x);
- SCM init_values = SCM_EOL;
- while (!SCM_NULLP (init_forms))
- {
- init_values = scm_cons (EVALCAR (init_forms, env), init_values);
- init_forms = SCM_CDR (init_forms);
- }
- x = SCM_CDR (x);
- env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
- }
- x = SCM_CDR (x);
- {
- SCM test_form = SCM_CAR (x);
- SCM body_forms = SCM_CADR (x);
- SCM step_forms = SCM_CDDR (x);
+ case (ISYMNUM (SCM_IM_COND)):
+ x = SCM_CDR (x);
+ while (!SCM_NULLP (x))
+ {
+ const SCM clause = SCM_CAR (x);
+ if (SCM_EQ_P (SCM_CAR (clause), SCM_IM_ELSE))
+ {
+ x = SCM_CDR (clause);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
+ else
+ {
+ arg1 = EVALCAR (clause, env);
+ if (!SCM_FALSEP (arg1) && !SCM_NILP (arg1))
+ {
+ x = SCM_CDR (clause);
+ if (SCM_NULLP (x))
+ RETURN (arg1);
+ else if (!SCM_EQ_P (SCM_CAR (x), SCM_IM_ARROW))
+ {
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
+ else
+ {
+ proc = SCM_CDR (x);
+ proc = EVALCAR (proc, env);
+ PREP_APPLY (proc, scm_list_1 (arg1));
+ ENTER_APPLY;
+ goto evap1;
+ }
+ }
+ x = SCM_CDR (x);
+ }
+ }
+ RETURN (SCM_UNSPECIFIED);
- SCM test_result = EVALCAR (test_form, env);
- while (SCM_FALSEP (test_result) || SCM_NILP (test_result))
- {
- {
- /* Evaluate body forms. */
- SCM temp_forms;
- for (temp_forms = body_forms;
- !SCM_NULLP (temp_forms);
- temp_forms = SCM_CDR (temp_forms))
- {
- SCM form = SCM_CAR (temp_forms);
- /* Dirk:FIXME: We only need to eval forms, that may have a
- * side effect here. This is only true for forms that start
- * with a pair. All others are just constants. However,
- * since in the common case there is no constant expression
- * in a body of a do form, we just check for immediates here
- * and have SCM_CEVAL take care of other cases. In the long
- * run it would make sense to get rid of this test and have
- * the macro transformer of 'do' eliminate all forms that
- * have no sideeffect. */
- if (!SCM_IMP (form))
- SCM_CEVAL (form, env);
- }
- }
+ case (ISYMNUM (SCM_IM_DO)):
+ x = SCM_CDR (x);
+ {
+ /* Compute the initialization values and the initial environment. */
+ SCM init_forms = SCM_CAR (x);
+ SCM init_values = SCM_EOL;
+ while (!SCM_NULLP (init_forms))
+ {
+ init_values = scm_cons (EVALCAR (init_forms, env), init_values);
+ init_forms = SCM_CDR (init_forms);
+ }
+ x = SCM_CDR (x);
+ env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
+ }
+ x = SCM_CDR (x);
+ {
+ SCM test_form = SCM_CAR (x);
+ SCM body_forms = SCM_CADR (x);
+ SCM step_forms = SCM_CDDR (x);
- {
- /* Evaluate the step expressions. */
- SCM temp_forms;
- SCM step_values = SCM_EOL;
- for (temp_forms = step_forms;
- !SCM_NULLP (temp_forms);
- temp_forms = SCM_CDR (temp_forms))
- {
- SCM value = EVALCAR (temp_forms, env);
- step_values = scm_cons (value, step_values);
- }
- env = SCM_EXTEND_ENV (SCM_CAAR (env),
- step_values,
- SCM_CDR (env));
- }
+ SCM test_result = EVALCAR (test_form, env);
- test_result = EVALCAR (test_form, env);
- }
- }
- x = SCM_CDAR (x);
- if (SCM_NULLP (x))
- RETURN (SCM_UNSPECIFIED);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto nontoplevel_begin;
+ while (SCM_FALSEP (test_result) || SCM_NILP (test_result))
+ {
+ {
+ /* Evaluate body forms. */
+ SCM temp_forms;
+ for (temp_forms = body_forms;
+ !SCM_NULLP (temp_forms);
+ temp_forms = SCM_CDR (temp_forms))
+ {
+ SCM form = SCM_CAR (temp_forms);
+ /* Dirk:FIXME: We only need to eval forms that may have
+ * a side effect here. This is only true for forms that
+ * start with a pair. All others are just constants.
+ * Since with the current memoizer 'form' may hold a
+ * constant, we call EVAL here to handle the constant
+ * cases. In the long run it would make sense to have
+ * the macro transformer of 'do' eliminate all forms
+ * that have no sideeffect. Then instead of EVAL we
+ * could call CEVAL directly here. */
+ (void) EVAL (form, env);
+ }
+ }
+ {
+ /* Evaluate the step expressions. */
+ SCM temp_forms;
+ SCM step_values = SCM_EOL;
+ for (temp_forms = step_forms;
+ !SCM_NULLP (temp_forms);
+ temp_forms = SCM_CDR (temp_forms))
+ {
+ const SCM value = EVALCAR (temp_forms, env);
+ step_values = scm_cons (value, step_values);
+ }
+ env = SCM_EXTEND_ENV (SCM_CAAR (env),
+ step_values,
+ SCM_CDR (env));
+ }
- case SCM_BIT7 (SCM_IM_IF):
- x = SCM_CDR (x);
- {
- SCM test_result = EVALCAR (x, env);
- x = SCM_CDR (x); /* then expression */
- if (SCM_FALSEP (test_result) || SCM_NILP (test_result))
- {
- x = SCM_CDR (x); /* else expression */
- if (SCM_NULLP (x))
- RETURN (SCM_UNSPECIFIED);
- }
- }
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
+ test_result = EVALCAR (test_form, env);
+ }
+ }
+ x = SCM_CDAR (x);
+ if (SCM_NULLP (x))
+ RETURN (SCM_UNSPECIFIED);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto nontoplevel_begin;
- case SCM_BIT7 (SCM_IM_LET):
- x = SCM_CDR (x);
- {
- SCM init_forms = SCM_CADR (x);
- SCM init_values = SCM_EOL;
- do
- {
- init_values = scm_cons (EVALCAR (init_forms, env), init_values);
- init_forms = SCM_CDR (init_forms);
- }
- while (!SCM_NULLP (init_forms));
- env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
- }
- x = SCM_CDDR (x);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto nontoplevel_begin;
+ case (ISYMNUM (SCM_IM_IF)):
+ x = SCM_CDR (x);
+ {
+ SCM test_result = EVALCAR (x, env);
+ x = SCM_CDR (x); /* then expression */
+ if (SCM_FALSEP (test_result) || SCM_NILP (test_result))
+ {
+ x = SCM_CDR (x); /* else expression */
+ if (SCM_NULLP (x))
+ RETURN (SCM_UNSPECIFIED);
+ }
+ }
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto carloop;
- case SCM_BIT7 (SCM_IM_LETREC):
- x = SCM_CDR (x);
- env = SCM_EXTEND_ENV (SCM_CAR (x), undefineds, env);
- x = SCM_CDR (x);
- {
- SCM init_forms = SCM_CAR (x);
- SCM init_values = SCM_EOL;
- do
- {
- init_values = scm_cons (EVALCAR (init_forms, env), init_values);
- init_forms = SCM_CDR (init_forms);
- }
- while (!SCM_NULLP (init_forms));
- SCM_SETCDR (SCM_CAR (env), init_values);
- }
- x = SCM_CDR (x);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto nontoplevel_begin;
+ case (ISYMNUM (SCM_IM_LET)):
+ x = SCM_CDR (x);
+ {
+ SCM init_forms = SCM_CADR (x);
+ SCM init_values = SCM_EOL;
+ do
+ {
+ init_values = scm_cons (EVALCAR (init_forms, env), init_values);
+ init_forms = SCM_CDR (init_forms);
+ }
+ while (!SCM_NULLP (init_forms));
+ env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
+ }
+ x = SCM_CDDR (x);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto nontoplevel_begin;
- case SCM_BIT7 (SCM_IM_LETSTAR):
- x = SCM_CDR (x);
- {
- SCM bindings = SCM_CAR (x);
- if (SCM_NULLP (bindings))
- env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env);
- else
- {
- do
- {
- SCM name = SCM_CAR (bindings);
- SCM init = SCM_CDR (bindings);
- env = SCM_EXTEND_ENV (name, EVALCAR (init, env), env);
- bindings = SCM_CDR (init);
- }
- while (!SCM_NULLP (bindings));
- }
- }
- x = SCM_CDR (x);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto nontoplevel_begin;
+ case (ISYMNUM (SCM_IM_LETREC)):
+ x = SCM_CDR (x);
+ env = SCM_EXTEND_ENV (SCM_CAR (x), undefineds, env);
+ x = SCM_CDR (x);
+ {
+ SCM init_forms = SCM_CAR (x);
+ SCM init_values = SCM_EOL;
+ do
+ {
+ init_values = scm_cons (EVALCAR (init_forms, env), init_values);
+ init_forms = SCM_CDR (init_forms);
+ }
+ while (!SCM_NULLP (init_forms));
+ SCM_SETCDR (SCM_CAR (env), init_values);
+ }
+ x = SCM_CDR (x);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto nontoplevel_begin;
- case SCM_BIT7 (SCM_IM_OR):
- x = SCM_CDR (x);
- while (!SCM_NULLP (SCM_CDR (x)))
- {
- SCM val = EVALCAR (x, env);
- if (!SCM_FALSEP (val) && !SCM_NILP (val))
- RETURN (val);
- else
- x = SCM_CDR (x);
- }
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
+ case (ISYMNUM (SCM_IM_LETSTAR)):
+ x = SCM_CDR (x);
+ {
+ SCM bindings = SCM_CAR (x);
+ if (SCM_NULLP (bindings))
+ env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env);
+ else
+ {
+ do
+ {
+ SCM name = SCM_CAR (bindings);
+ SCM init = SCM_CDR (bindings);
+ env = SCM_EXTEND_ENV (name, EVALCAR (init, env), env);
+ bindings = SCM_CDR (init);
+ }
+ while (!SCM_NULLP (bindings));
+ }
+ }
+ x = SCM_CDR (x);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto nontoplevel_begin;
- case SCM_BIT7 (SCM_IM_LAMBDA):
- RETURN (scm_closure (SCM_CDR (x), env));
+ case (ISYMNUM (SCM_IM_OR)):
+ x = SCM_CDR (x);
+ while (!SCM_NULLP (SCM_CDR (x)))
+ {
+ SCM val = EVALCAR (x, env);
+ if (!SCM_FALSEP (val) && !SCM_NILP (val))
+ RETURN (val);
+ else
+ x = SCM_CDR (x);
+ }
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto carloop;
- case SCM_BIT7 (SCM_IM_QUOTE):
- RETURN (SCM_CADR (x));
+ case (ISYMNUM (SCM_IM_LAMBDA)):
+ RETURN (scm_closure (SCM_CDR (x), env));
- case SCM_BIT7 (SCM_IM_SET_X):
- x = SCM_CDR (x);
- {
- SCM *location;
- SCM variable = SCM_CAR (x);
- if (SCM_ILOCP (variable))
- location = scm_ilookup (variable, env);
- else if (SCM_VARIABLEP (variable))
- location = SCM_VARIABLE_LOC (variable);
- else /* (SCM_SYMBOLP (variable)) is known to be true */
- location = scm_lookupcar (x, env, 1);
- x = SCM_CDR (x);
- *location = EVALCAR (x, env);
- }
- RETURN (SCM_UNSPECIFIED);
+ case (ISYMNUM (SCM_IM_QUOTE)):
+ RETURN (SCM_CADR (x));
- /* new syntactic forms go here. */
- case SCM_BIT7 (SCM_MAKISYM (0)):
- proc = SCM_CAR (x);
- switch (SCM_ISYMNUM (proc))
- {
+ case (ISYMNUM (SCM_IM_SET_X)):
+ x = SCM_CDR (x);
+ {
+ SCM *location;
+ SCM variable = SCM_CAR (x);
+ if (SCM_ILOCP (variable))
+ location = scm_ilookup (variable, env);
+ else if (SCM_VARIABLEP (variable))
+ location = SCM_VARIABLE_LOC (variable);
+ else
+ {
+ /* (SCM_SYMBOLP (variable)) is known to be true */
+ variable = lazy_memoize_variable (variable, env);
+ SCM_SETCAR (x, variable);
+ location = SCM_VARIABLE_LOC (variable);
+ }
+ x = SCM_CDR (x);
+ *location = EVALCAR (x, env);
+ }
+ RETURN (SCM_UNSPECIFIED);
- case (SCM_ISYMNUM (SCM_IM_APPLY)):
+ case (ISYMNUM (SCM_IM_APPLY)):
/* Evaluate the procedure to be applied. */
x = SCM_CDR (x);
proc = EVALCAR (x, env);
}
- case (SCM_ISYMNUM (SCM_IM_CONT)):
+ case (ISYMNUM (SCM_IM_CONT)):
{
int first;
SCM val = scm_make_continuation (&first);
}
- case (SCM_ISYMNUM (SCM_IM_DELAY)):
+ case (ISYMNUM (SCM_IM_DELAY)):
RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)));
- case (SCM_ISYMNUM (SCM_IM_FUTURE)):
+ case (ISYMNUM (SCM_IM_FUTURE)):
RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env)));
- /* PLACEHOLDER for case (SCM_ISYMNUM (SCM_IM_DISPATCH)): The
- following code (type_dispatch) is intended to be the tail
- of the case clause for the internal macro
- SCM_IM_DISPATCH. Please don't remove it from this
- location without discussing it with Mikael
+ /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
+ code (type_dispatch) is intended to be the tail of the case
+ clause for the internal macro SCM_IM_DISPATCH. Please don't
+ remove it from this location without discussing it with Mikael
<djurfeldt@nada.kth.se> */
/* The type dispatch code is duplicated below
}
- case (SCM_ISYMNUM (SCM_IM_SLOT_REF)):
+ case (ISYMNUM (SCM_IM_SLOT_REF)):
x = SCM_CDR (x);
{
SCM instance = EVALCAR (x, env);
}
- case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X)):
+ case (ISYMNUM (SCM_IM_SLOT_SET_X)):
x = SCM_CDR (x);
{
SCM instance = EVALCAR (x, env);
#if SCM_ENABLE_ELISP
- case (SCM_ISYMNUM (SCM_IM_NIL_COND)):
+ case (ISYMNUM (SCM_IM_NIL_COND)):
{
SCM test_form = SCM_CDR (x);
x = SCM_CDR (test_form);
#endif /* SCM_ENABLE_ELISP */
- case (SCM_ISYMNUM (SCM_IM_BIND)):
+ case (ISYMNUM (SCM_IM_BIND)):
{
SCM vars, exps, vals;
for (x = SCM_CDR (x); !SCM_NULLP (SCM_CDR (x)); x = SCM_CDR (x))
{
if (SCM_CONSP (SCM_CAR (x)))
- SCM_CEVAL (SCM_CAR (x), env);
+ CEVAL (SCM_CAR (x), env);
}
proc = EVALCAR (x, env);
}
- case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
+ case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
{
SCM producer;
default:
- goto evapply;
+ break;
}
-
-
- default:
- proc = x;
- goto evapply;
-
-
- case scm_tc7_vector:
- case scm_tc7_wvect:
-#if SCM_HAVE_ARRAYS
- case scm_tc7_bvect:
- case scm_tc7_byvect:
- case scm_tc7_svect:
- case scm_tc7_ivect:
- case scm_tc7_uvect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
-#if SCM_SIZEOF_LONG_LONG != 0
- case scm_tc7_llvect:
-#endif
-#endif
- case scm_tc7_number:
- case scm_tc7_string:
- case scm_tc7_smob:
- case scm_tcs_closures:
- case scm_tc7_cclo:
- case scm_tc7_pws:
- case scm_tcs_subrs:
- case scm_tcs_struct:
- case scm_tc7_port:
- RETURN (x);
-
- case scm_tc7_symbol:
- /* Only happens when called at top level. */
- x = scm_cons (x, SCM_UNDEFINED);
- RETURN (*scm_lookupcar (x, env, 1));
-
- case scm_tc7_variable:
- RETURN (SCM_VARIABLE_REF(x));
-
- case SCM_BIT7 (SCM_ILOC00):
- proc = *scm_ilookup (SCM_CAR (x), env);
- goto checkmacro;
-
- case scm_tcs_cons_nimcar:
- if (SCM_SYMBOLP (SCM_CAR (x)))
+ }
+ else
+ {
+ if (SCM_VARIABLEP (SCM_CAR (x)))
+ proc = SCM_VARIABLE_REF (SCM_CAR (x));
+ else if (SCM_ILOCP (SCM_CAR (x)))
+ proc = *scm_ilookup (SCM_CAR (x), env);
+ else if (SCM_CONSP (SCM_CAR (x)))
+ proc = CEVAL (SCM_CAR (x), env);
+ else if (SCM_SYMBOLP (SCM_CAR (x)))
{
SCM orig_sym = SCM_CAR (x);
{
}
}
else
- proc = SCM_CEVAL (SCM_CAR (x), env);
+ proc = SCM_CAR (x);
- checkmacro:
if (SCM_MACROP (proc))
goto handle_a_macro;
}
-evapply: /* inputs: x, proc */
+ /* When reaching this part of the code, the following is granted: Variable x
+ * holds the first pair of an expression of the form (<function> arg ...).
+ * Variable proc holds the object that resulted from the evaluation of
+ * <function>. In the following, the arguments (if any) will be evaluated,
+ * and proc will be applied to them. If proc does not really hold a
+ * function object, this will be signalled as an error on the scheme
+ * level. If the number of arguments does not match the number of arguments
+ * that are allowed to be passed to proc, also an error on the scheme level
+ * will be signalled. */
PREP_APPLY (proc, SCM_EOL);
if (SCM_NULLP (SCM_CDR (x))) {
ENTER_APPLY;
debug.vect[0].a.args = SCM_EOL;
scm_last_debug_frame = &debug;
#else
- if (SCM_DEBUGGINGP)
+ if (scm_debug_mode_p)
return scm_dapply (proc, arg1, args);
#endif
SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc));
}
else
- SCM_CEVAL (SCM_CAR (proc), args);
+ (void) EVAL (SCM_CAR (proc), args);
proc = arg1;
arg1 = SCM_CDR (proc);
}
/* If debugging is enabled, we want to see all calls to proc on the stack.
* Thus, we replace the trampoline shortcut with scm_call_0. */
- if (SCM_DEBUGGINGP)
+ if (scm_debug_mode_p)
return scm_call_0;
else
return trampoline;
/* If debugging is enabled, we want to see all calls to proc on the stack.
* Thus, we replace the trampoline shortcut with scm_call_1. */
- if (SCM_DEBUGGINGP)
+ if (scm_debug_mode_p)
return scm_call_1;
else
return trampoline;
/* If debugging is enabled, we want to see all calls to proc on the stack.
* Thus, we replace the trampoline shortcut with scm_call_2. */
- if (SCM_DEBUGGINGP)
+ if (scm_debug_mode_p)
return scm_call_2;
else
return trampoline;
* that in contrast to the typical hare-and-tortoise pattern, the step
* of the tortoise happens before the hare takes its steps. This is, in
* principle, no problem, except for the start of the algorithm: Then,
- * it has to be made sure that the hare actually gets its advantage by
+ * it has to be made sure that the hare actually gets its advantage of
* two steps. */
if (tortoise_delay == 0)
{
SCM
scm_i_eval_x (SCM exp, SCM env)
{
- return SCM_XEVAL (exp, env);
+ if (SCM_SYMBOLP (exp))
+ return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1);
+ else
+ return SCM_XEVAL (exp, env);
}
SCM
scm_i_eval (SCM exp, SCM env)
{
exp = scm_copy_tree (exp);
- return SCM_XEVAL (exp, env);
+ if (SCM_SYMBOLP (exp))
+ return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1);
+ else
+ return SCM_XEVAL (exp, env);
}
SCM
#undef FUNC_NAME
-/* At this point, scm_deval and scm_dapply are generated.
+/* At this point, deval and scm_dapply are generated.
*/
#define DEVAL
#include "eval.c"
+#if (SCM_ENABLE_DEPRECATED == 1)
+
+/* Deprecated in guile 1.7.0 on 2004-03-29. */
+SCM scm_ceval (SCM x, SCM env)
+{
+ if (SCM_CONSP (x))
+ return ceval (x, env);
+ else if (SCM_SYMBOLP (x))
+ return *scm_lookupcar (scm_cons (x, SCM_UNDEFINED), env, 1);
+ else
+ return SCM_XEVAL (x, env);
+}
+
+/* Deprecated in guile 1.7.0 on 2004-03-29. */
+SCM scm_deval (SCM x, SCM env)
+{
+ if (SCM_CONSP (x))
+ return deval (x, env);
+ else if (SCM_SYMBOLP (x))
+ return *scm_lookupcar (scm_cons (x, SCM_UNDEFINED), env, 1);
+ else
+ return SCM_XEVAL (x, env);
+}
+
+static SCM
+dispatching_eval (SCM x, SCM env)
+{
+ if (scm_debug_mode_p)
+ return scm_deval (x, env);
+ else
+ return scm_ceval (x, env);
+}
+
+/* Deprecated in guile 1.7.0 on 2004-03-29. */
+SCM (*scm_ceval_ptr) (SCM x, SCM env) = dispatching_eval;
+
+#endif
+
+
void
scm_init_eval ()
{
HCoop / bpt / guile.git / blobdiff