* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
-
\f
/* This file is read twice in order to produce debugging versions of
#include "libguile/validate.h"
#include "libguile/eval.h"
+#include "libguile/lang.h"
\f
? *scm_lookupcar (x, env, 1) \
: SCM_CEVAL (SCM_CAR (x), env))
-#define EVALCAR(x, env) (!SCM_CELLP (SCM_CAR (x)) \
+#define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
? SCM_EVALIM (SCM_CAR (x), env) \
: EVALCELLCAR (x, env))
reconsider the complete special form.
SCM_LOOKUPCAR is still there, of course. It just calls
- SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR
+ SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
should only be called when it is known that VLOC is not the first
pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
for NULL. I think I've found the only places where this
if (!SCM_NULLP (env) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var)))
{
errout:
- /* scm_everr (vloc, genv,...) */
if (check)
{
if (SCM_NULLP (env))
scm_error (scm_unbound_variable_key, NULL,
"Unbound variable: ~S",
- scm_cons (var, SCM_EOL), SCM_BOOL_F);
+ scm_list_1 (var), SCM_BOOL_F);
else
scm_misc_error (NULL, "Damaged environment: ~S",
- scm_cons (var, SCM_EOL));
+ scm_list_1 (var));
}
else
{
SCM
scm_unmemocar (SCM form, SCM env)
{
- SCM c;
-
- if (SCM_IMP (form))
+ if (!SCM_CONSP (form))
return form;
- c = SCM_CAR (form);
- if (SCM_VARIABLEP (c))
+ else
{
- SCM sym =
- scm_module_reverse_lookup (scm_env_module (env), c);
- if (SCM_EQ_P (sym, SCM_BOOL_F))
- sym = sym_three_question_marks;
- SCM_SETCAR (form, sym);
- }
+ SCM c = SCM_CAR (form);
+ if (SCM_VARIABLEP (c))
+ {
+ SCM sym = scm_module_reverse_lookup (scm_env_module (env), c);
+ if (SCM_FALSEP (sym))
+ sym = sym_three_question_marks;
+ SCM_SETCAR (form, sym);
+ }
#ifdef MEMOIZE_LOCALS
-#ifdef DEBUG_EXTENSIONS
- else if (SCM_ILOCP (c))
- {
- long ir;
-
- for (ir = SCM_IFRAME (c); ir != 0; --ir)
- env = SCM_CDR (env);
- env = SCM_CAR (SCM_CAR (env));
- for (ir = SCM_IDIST (c); ir != 0; --ir)
- env = SCM_CDR (env);
- SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env));
- }
-#endif
+ else if (SCM_ILOCP (c))
+ {
+ unsigned long int ir;
+
+ for (ir = SCM_IFRAME (c); ir != 0; --ir)
+ env = SCM_CDR (env);
+ env = SCM_CAAR (env);
+ for (ir = SCM_IDIST (c); ir != 0; --ir)
+ env = SCM_CDR (env);
+ SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env));
+ }
#endif
- return form;
+ return form;
+ }
}
const char scm_s_clauses[] = "bad or missing clauses";
const char scm_s_formals[] = "bad formals";
const char scm_s_duplicate_formals[] = "duplicate formals";
+static const char s_splicing[] = "bad (non-list) result for unquote-splicing";
SCM_GLOBAL_SYMBOL (scm_sym_dot, ".");
SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
static SCM
scm_m_body (SCM op, SCM xorig, const char *what)
{
- SCM_ASSYNT (scm_ilength (xorig) >= 1, scm_s_expression, what);
+ SCM_ASSYNT (scm_ilength (xorig) >= 1, scm_s_body, what);
/* Don't add another ISYM if one is present already. */
if (SCM_ISYMP (SCM_CAR (xorig)))
/* Retain possible doc string. */
if (!SCM_CONSP (SCM_CAR (xorig)))
{
- if (!SCM_NULLP (SCM_CDR(xorig)))
+ if (!SCM_NULLP (SCM_CDR (xorig)))
return scm_cons (SCM_CAR (xorig),
- scm_m_body (op, SCM_CDR(xorig), what));
+ scm_m_body (op, SCM_CDR (xorig), what));
return xorig;
}
return scm_cons (op, xorig);
}
-SCM_SYNTAX(s_quote,"quote", scm_makmmacro, scm_m_quote);
-SCM_GLOBAL_SYMBOL(scm_sym_quote, s_quote);
-SCM
+SCM_SYNTAX (s_quote, "quote", scm_makmmacro, scm_m_quote);
+SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
+
+SCM
scm_m_quote (SCM xorig, SCM env SCM_UNUSED)
{
- SCM x = scm_copy_tree (SCM_CDR (xorig));
-
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, s_quote);
- return scm_cons (SCM_IM_QUOTE, x);
+ return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig));
}
+SCM_SYNTAX (s_begin, "begin", scm_makmmacro, scm_m_begin);
+SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);
-SCM_SYNTAX(s_begin, "begin", scm_makmmacro, scm_m_begin);
-SCM_GLOBAL_SYMBOL(scm_sym_begin, s_begin);
-
-SCM
+SCM
scm_m_begin (SCM xorig, SCM env SCM_UNUSED)
{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 1, scm_s_expression, s_begin);
+ SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 0, scm_s_expression, s_begin);
return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig));
}
-SCM_SYNTAX(s_if, "if", scm_makmmacro, scm_m_if);
-SCM_GLOBAL_SYMBOL(scm_sym_if, s_if);
-SCM
+SCM_SYNTAX (s_if, "if", scm_makmmacro, scm_m_if);
+SCM_GLOBAL_SYMBOL (scm_sym_if, s_if);
+
+SCM
scm_m_if (SCM xorig, SCM env SCM_UNUSED)
{
long len = scm_ilength (SCM_CDR (xorig));
- SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, "if");
+ SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, s_if);
return scm_cons (SCM_IM_IF, SCM_CDR (xorig));
}
/* Will go into the RnRS module when Guile is factorized.
-SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
+SCM_SYNTAX (scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
const char scm_s_set_x[] = "set!";
-SCM_GLOBAL_SYMBOL(scm_sym_set_x, scm_s_set_x);
+SCM_GLOBAL_SYMBOL (scm_sym_set_x, scm_s_set_x);
-SCM
+SCM
scm_m_set_x (SCM xorig, SCM env SCM_UNUSED)
{
SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (2 == scm_ilength (x), scm_s_expression, scm_s_set_x);
+ SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, scm_s_set_x);
SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)), scm_s_variable, scm_s_set_x);
return scm_cons (SCM_IM_SET_X, x);
}
-SCM_SYNTAX(s_and, "and", scm_makmmacro, scm_m_and);
-SCM_GLOBAL_SYMBOL(scm_sym_and, s_and);
+SCM_SYNTAX (s_and, "and", scm_makmmacro, scm_m_and);
+SCM_GLOBAL_SYMBOL (scm_sym_and, s_and);
-SCM
+SCM
scm_m_and (SCM xorig, SCM env SCM_UNUSED)
{
long len = scm_ilength (SCM_CDR (xorig));
return SCM_BOOL_T;
}
-SCM_SYNTAX(s_or,"or", scm_makmmacro, scm_m_or);
-SCM_GLOBAL_SYMBOL(scm_sym_or,s_or);
-SCM
+SCM_SYNTAX (s_or, "or", scm_makmmacro, scm_m_or);
+SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
+
+SCM
scm_m_or (SCM xorig, SCM env SCM_UNUSED)
{
long len = scm_ilength (SCM_CDR (xorig));
}
-SCM_SYNTAX(s_case, "case", scm_makmmacro, scm_m_case);
-SCM_GLOBAL_SYMBOL(scm_sym_case, s_case);
+SCM_SYNTAX (s_case, "case", scm_makmmacro, scm_m_case);
+SCM_GLOBAL_SYMBOL (scm_sym_case, s_case);
-SCM
+SCM
scm_m_case (SCM xorig, SCM env SCM_UNUSED)
{
- SCM proc, cdrx = scm_list_copy (SCM_CDR (xorig)), x = cdrx;
- SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_clauses, s_case);
- while (SCM_NIMP (x = SCM_CDR (x)))
+ SCM clauses;
+ SCM cdrx = SCM_CDR (xorig);
+ SCM_ASSYNT (scm_ilength (cdrx) >= 2, scm_s_clauses, s_case);
+ clauses = SCM_CDR (cdrx);
+ while (!SCM_NULLP (clauses))
{
- proc = SCM_CAR (x);
- SCM_ASSYNT (scm_ilength (proc) >= 2, scm_s_clauses, s_case);
- SCM_ASSYNT (scm_ilength (SCM_CAR (proc)) >= 0
- || (SCM_EQ_P (scm_sym_else, SCM_CAR (proc))
- && SCM_NULLP (SCM_CDR (x))),
+ SCM clause = SCM_CAR (clauses);
+ SCM_ASSYNT (scm_ilength (clause) >= 2, scm_s_clauses, s_case);
+ SCM_ASSYNT (scm_ilength (SCM_CAR (clause)) >= 0
+ || (SCM_EQ_P (scm_sym_else, SCM_CAR (clause))
+ && SCM_NULLP (SCM_CDR (clauses))),
scm_s_clauses, s_case);
+ clauses = SCM_CDR (clauses);
}
return scm_cons (SCM_IM_CASE, cdrx);
}
-SCM_SYNTAX(s_cond, "cond", scm_makmmacro, scm_m_cond);
-SCM_GLOBAL_SYMBOL(scm_sym_cond, s_cond);
-
+SCM_SYNTAX (s_cond, "cond", scm_makmmacro, scm_m_cond);
+SCM_GLOBAL_SYMBOL (scm_sym_cond, s_cond);
-SCM
+SCM
scm_m_cond (SCM xorig, SCM env SCM_UNUSED)
{
- SCM arg1, cdrx = scm_list_copy (SCM_CDR (xorig)), x = cdrx;
- long len = scm_ilength (x);
- SCM_ASSYNT (len >= 1, scm_s_clauses, s_cond);
- while (SCM_NIMP (x))
+ SCM cdrx = SCM_CDR (xorig);
+ SCM clauses = cdrx;
+ SCM_ASSYNT (scm_ilength (clauses) >= 1, scm_s_clauses, s_cond);
+ while (!SCM_NULLP (clauses))
{
- arg1 = SCM_CAR (x);
- len = scm_ilength (arg1);
+ SCM clause = SCM_CAR (clauses);
+ long len = scm_ilength (clause);
SCM_ASSYNT (len >= 1, scm_s_clauses, s_cond);
- if (SCM_EQ_P (scm_sym_else, SCM_CAR (arg1)))
+ if (SCM_EQ_P (scm_sym_else, SCM_CAR (clause)))
{
- SCM_ASSYNT (SCM_NULLP (SCM_CDR (x)) && len >= 2,
- "bad ELSE clause", s_cond);
- SCM_SETCAR (arg1, SCM_BOOL_T);
+ int last_clause_p = SCM_NULLP (SCM_CDR (clauses));
+ SCM_ASSYNT (len >= 2 && last_clause_p, "bad ELSE clause", s_cond);
}
- if (len >= 2 && SCM_EQ_P (scm_sym_arrow, SCM_CAR (SCM_CDR (arg1))))
- SCM_ASSYNT (3 == len && SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1)))),
- "bad recipient", s_cond);
- x = SCM_CDR (x);
+ else if (len >= 2 && SCM_EQ_P (scm_sym_arrow, SCM_CADR (clause)))
+ {
+ SCM_ASSYNT (len > 2, "missing recipient", s_cond);
+ SCM_ASSYNT (len == 3, "bad recipient", s_cond);
+ }
+ clauses = SCM_CDR (clauses);
}
return scm_cons (SCM_IM_COND, cdrx);
}
-SCM_SYNTAX(s_lambda, "lambda", scm_makmmacro, scm_m_lambda);
-SCM_GLOBAL_SYMBOL(scm_sym_lambda, s_lambda);
-/* Return true if OBJ is `eq?' to one of the elements of LIST or to the
- cdr of the last cons. (Thus, LIST is not required to be a proper
- list and when OBJ also found in the improper ending.) */
+SCM_SYNTAX (s_lambda, "lambda", scm_makmmacro, scm_m_lambda);
+SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda);
+/* Return true if OBJ is `eq?' to one of the elements of LIST or to the
+ * cdr of the last cons. (Thus, LIST is not required to be a proper
+ * list and OBJ can also be found in the improper ending.) */
static int
scm_c_improper_memq (SCM obj, SCM list)
{
return SCM_EQ_P (list, obj);
}
-SCM
+SCM
scm_m_lambda (SCM xorig, SCM env SCM_UNUSED)
{
- SCM proc, x = SCM_CDR (xorig);
- if (scm_ilength (x) < 2)
- goto badforms;
- proc = SCM_CAR (x);
- if (SCM_NULLP (proc))
- goto memlambda;
- if (SCM_EQ_P (SCM_IM_LET, proc)) /* named let */
- goto memlambda;
- if (SCM_IMP (proc))
- goto badforms;
- if (SCM_SYMBOLP (proc))
- goto memlambda;
- if (!SCM_CONSP (proc))
- goto badforms;
- while (SCM_NIMP (proc))
+ SCM formals;
+ SCM x = SCM_CDR (xorig);
+
+ SCM_ASSYNT (SCM_CONSP (x), scm_s_formals, s_lambda);
+
+ formals = SCM_CAR (x);
+ while (SCM_CONSP (formals))
{
- if (!SCM_CONSP (proc))
- {
- if (!SCM_SYMBOLP (proc))
- goto badforms;
- else
- goto memlambda;
- }
- if (!SCM_SYMBOLP (SCM_CAR (proc)))
- goto badforms;
- else if (scm_c_improper_memq (SCM_CAR(proc), SCM_CDR(proc)))
+ SCM formal = SCM_CAR (formals);
+ SCM_ASSYNT (SCM_SYMBOLP (formal), scm_s_formals, s_lambda);
+ if (scm_c_improper_memq (formal, SCM_CDR (formals)))
scm_misc_error (s_lambda, scm_s_duplicate_formals, SCM_EOL);
- proc = SCM_CDR (proc);
- }
- if (!SCM_NULLP (proc))
- {
- badforms:
- scm_misc_error (s_lambda, scm_s_formals, SCM_EOL);
+ formals = SCM_CDR (formals);
}
+ if (!SCM_NULLP (formals) && !SCM_SYMBOLP (formals))
+ scm_misc_error (s_lambda, scm_s_formals, SCM_EOL);
- memlambda:
return scm_cons2 (SCM_IM_LAMBDA, SCM_CAR (x),
scm_m_body (SCM_IM_LAMBDA, SCM_CDR (x), s_lambda));
}
-SCM_SYNTAX(s_letstar,"let*", scm_makmmacro, scm_m_letstar);
-SCM_GLOBAL_SYMBOL(scm_sym_letstar,s_letstar);
+SCM_SYNTAX (s_letstar, "let*", scm_makmmacro, scm_m_letstar);
+SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar);
-SCM
+/* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
+ * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
+SCM
scm_m_letstar (SCM xorig, SCM env SCM_UNUSED)
{
- SCM x = SCM_CDR (xorig), arg1, proc, vars = SCM_EOL, *varloc = &vars;
- long len = scm_ilength (x);
- SCM_ASSYNT (len >= 2, scm_s_body, s_letstar);
- proc = SCM_CAR (x);
- SCM_ASSYNT (scm_ilength (proc) >= 0, scm_s_bindings, s_letstar);
- while (SCM_NIMP (proc))
+ SCM bindings;
+ SCM x = SCM_CDR (xorig);
+ SCM vars = SCM_EOL;
+ SCM *varloc = &vars;
+
+ SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_letstar);
+
+ bindings = SCM_CAR (x);
+ SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, s_letstar);
+ while (!SCM_NULLP (bindings))
{
- arg1 = SCM_CAR (proc);
- SCM_ASSYNT (2 == scm_ilength (arg1), scm_s_bindings, s_letstar);
- SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), scm_s_variable, s_letstar);
- *varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
+ SCM binding = SCM_CAR (bindings);
+ SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, s_letstar);
+ SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, s_letstar);
+ *varloc = scm_list_2 (SCM_CAR (binding), SCM_CADR (binding));
varloc = SCM_CDRLOC (SCM_CDR (*varloc));
- proc = SCM_CDR (proc);
+ bindings = SCM_CDR (bindings);
}
- x = scm_cons (vars, SCM_CDR (x));
- return scm_cons2 (SCM_IM_LETSTAR, SCM_CAR (x),
+ return scm_cons2 (SCM_IM_LETSTAR, vars,
scm_m_body (SCM_IM_LETSTAR, SCM_CDR (x), s_letstar));
}
-/* DO gets the most radically altered syntax
+
+/* 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>)
+
;; becomes
- (do_mem (varn ... var2 var1)
+
+ (#@do (varn ... var2 var1)
(<init1> <init2> ... <initn>)
(<test> <return>)
(<body>)
<step1> <step2> ... <stepn>) ;; missing steps replaced by var
- */
+ */
SCM_SYNTAX(s_do, "do", scm_makmmacro, scm_m_do);
SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
SCM
scm_m_do (SCM xorig, SCM env SCM_UNUSED)
{
- SCM x = SCM_CDR (xorig), arg1, proc;
- SCM vars = SCM_EOL, inits = SCM_EOL, steps = SCM_EOL;
- SCM *initloc = &inits, *steploc = &steps;
- long len = scm_ilength (x);
- SCM_ASSYNT (len >= 2, scm_s_test, "do");
- proc = SCM_CAR (x);
- SCM_ASSYNT (scm_ilength (proc) >= 0, scm_s_bindings, "do");
- while (SCM_NIMP(proc))
+ 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, scm_s_test, "do");
+ bindings = SCM_CAR (x);
+ SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, "do");
+ while (!SCM_NULLP (bindings))
{
- arg1 = SCM_CAR (proc);
- len = scm_ilength (arg1);
- SCM_ASSYNT (2 == len || 3 == len, scm_s_bindings, "do");
- SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), scm_s_variable, "do");
- /* vars reversed here, inits and steps reversed at evaluation */
- vars = scm_cons (SCM_CAR (arg1), vars); /* variable */
- arg1 = SCM_CDR (arg1);
- *initloc = scm_cons (SCM_CAR (arg1), SCM_EOL); /* init */
- initloc = SCM_CDRLOC (*initloc);
- arg1 = SCM_CDR (arg1);
- *steploc = scm_cons (SCM_IMP (arg1) ? SCM_CAR (vars) : SCM_CAR (arg1), SCM_EOL); /* step */
- steploc = SCM_CDRLOC (*steploc);
- proc = SCM_CDR (proc);
+ SCM binding = SCM_CAR (bindings);
+ long len = scm_ilength (binding);
+ SCM_ASSYNT (len == 2 || len == 3, scm_s_bindings, "do");
+ {
+ SCM name = SCM_CAR (binding);
+ SCM init = SCM_CADR (binding);
+ SCM step = (len == 2) ? name : SCM_CADDR (binding);
+ SCM_ASSYNT (SCM_SYMBOLP (name), scm_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);
+ }
}
x = SCM_CDR (x);
SCM_ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, scm_s_test, "do");
return scm_cons (SCM_IM_DO, x);
}
-/* evalcar is small version of inline EVALCAR when we don't care about
- * speed
- */
-#define evalcar scm_eval_car
-
-
-static SCM iqq (SCM form, SCM env, long depth);
-
-SCM_SYNTAX(s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
-SCM_GLOBAL_SYMBOL(scm_sym_quasiquote, s_quasiquote);
-
-SCM
-scm_m_quasiquote (SCM xorig, SCM env)
-{
- SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_quasiquote);
- return iqq (SCM_CAR (x), env, 1);
-}
+SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
+SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote);
+/* Internal function to handle a quasiquotation: 'form' is the parameter in
+ * the call (quasiquotation form), 'env' is the environment where unquoted
+ * expressions will be evaluated, and 'depth' is the current quasiquotation
+ * nesting level and is known to be greater than zero. */
static SCM
-iqq (SCM form, SCM env, long depth)
+iqq (SCM form, SCM env, unsigned long int depth)
{
- SCM tmp;
- long edepth = depth;
- if (SCM_IMP (form))
- return form;
- if (SCM_VECTORP (form))
+ if (SCM_CONSP (form))
+ {
+ SCM tmp = SCM_CAR (form);
+ if (SCM_EQ_P (tmp, scm_sym_quasiquote))
+ {
+ SCM args = SCM_CDR (form);
+ SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote);
+ return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1));
+ }
+ else if (SCM_EQ_P (tmp, scm_sym_unquote))
+ {
+ SCM args = SCM_CDR (form);
+ SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote);
+ if (depth - 1 == 0)
+ return scm_eval_car (args, env);
+ else
+ return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth - 1));
+ }
+ else if (SCM_CONSP (tmp)
+ && SCM_EQ_P (SCM_CAR (tmp), scm_sym_uq_splicing))
+ {
+ SCM args = SCM_CDR (tmp);
+ SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote);
+ if (depth - 1 == 0)
+ {
+ SCM list = scm_eval_car (args, env);
+ SCM rest = SCM_CDR (form);
+ SCM_ASSYNT (scm_ilength (list) >= 0, s_splicing, s_quasiquote);
+ return scm_append (scm_list_2 (list, iqq (rest, env, depth)));
+ }
+ else
+ return scm_cons (iqq (SCM_CAR (form), env, depth - 1),
+ iqq (SCM_CDR (form), env, depth));
+ }
+ else
+ return scm_cons (iqq (SCM_CAR (form), env, depth),
+ iqq (SCM_CDR (form), env, depth));
+ }
+ else if (SCM_VECTORP (form))
{
- long i = SCM_VECTOR_LENGTH (form);
+ size_t i = SCM_VECTOR_LENGTH (form);
SCM *data = SCM_VELTS (form);
- tmp = SCM_EOL;
- for (; --i >= 0;)
- tmp = scm_cons (data[i], tmp);
+ SCM tmp = SCM_EOL;
+ while (i != 0)
+ tmp = scm_cons (data[--i], tmp);
+ scm_remember_upto_here_1 (form);
return scm_vector (iqq (tmp, env, depth));
}
- if (!SCM_CONSP (form))
+ else
return form;
- tmp = SCM_CAR (form);
- if (SCM_EQ_P (scm_sym_quasiquote, tmp))
- {
- depth++;
- goto label;
- }
- if (SCM_EQ_P (scm_sym_unquote, tmp))
- {
- --depth;
- label:
- form = SCM_CDR (form);
- SCM_ASSERT (SCM_CONSP (form) && SCM_NULLP (SCM_CDR (form)),
- form, SCM_ARG1, s_quasiquote);
- if (0 == depth)
- return evalcar (form, env);
- return scm_cons2 (tmp, iqq (SCM_CAR (form), env, depth), SCM_EOL);
- }
- if (SCM_CONSP (tmp) && (SCM_EQ_P (scm_sym_uq_splicing, SCM_CAR (tmp))))
- {
- tmp = SCM_CDR (tmp);
- if (0 == --edepth)
- return scm_append (scm_cons2 (evalcar (tmp, env), iqq (SCM_CDR (form), env, depth), SCM_EOL));
- }
- return scm_cons (iqq (SCM_CAR (form), env, edepth), iqq (SCM_CDR (form), env, depth));
}
-/* Here are acros which return values rather than code. */
+SCM
+scm_m_quasiquote (SCM xorig, SCM env)
+{
+ SCM x = SCM_CDR (xorig);
+ SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_quasiquote);
+ return iqq (SCM_CAR (x), env, 1);
+}
+
SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay);
SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
-SCM
+/* Promises are implemented as closures with an empty parameter list. Thus,
+ * (delay <expression>) is transformed into (#@delay '() <expression>), where
+ * the empty list represents the empty parameter list. This representation
+ * allows for easy creation of the closure during evaluation. */
+SCM
scm_m_delay (SCM xorig, SCM env SCM_UNUSED)
{
SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_delay);
SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define);
SCM_GLOBAL_SYMBOL(scm_sym_define, s_define);
-SCM
+/* Guile provides an extension to R5RS' define syntax to represent function
+ * currying in a compact way. With this extension, it is allowed to write
+ * (define <nested-variable> <body>), where <nested-variable> has of one of
+ * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
+ * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
+ * should be either a sequence of zero or more variables, or a sequence of one
+ * or more variables followed by a space-delimited period and another
+ * variable. Each level of argument nesting wraps the <body> within another
+ * lambda expression. For example, the following forms are allowed, each one
+ * followed by an equivalent, more explicit implementation.
+ * Example 1:
+ * (define ((a b . c) . d) <body>) is equivalent to
+ * (define a (lambda (b . c) (lambda d <body>)))
+ * Example 2:
+ * (define (((a) b) c . d) <body>) is equivalent to
+ * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
+ */
+/* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
+ * module that does not implement this extension. */
+SCM
scm_m_define (SCM x, SCM env)
{
- SCM proc, arg1 = x;
+ SCM name;
x = SCM_CDR (x);
SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_expression, s_define);
- proc = SCM_CAR (x);
+ name = SCM_CAR (x);
x = SCM_CDR (x);
- while (SCM_CONSP (proc))
- { /* nested define syntax */
- x = scm_cons (scm_cons2 (scm_sym_lambda, SCM_CDR (proc), x), SCM_EOL);
- proc = SCM_CAR (proc);
+ while (SCM_CONSP (name))
+ {
+ /* This while loop realizes function currying by variable nesting. */
+ SCM formals = SCM_CDR (name);
+ x = scm_list_1 (scm_cons2 (scm_sym_lambda, formals, x));
+ name = SCM_CAR (name);
}
- SCM_ASSYNT (SCM_SYMBOLP (proc), scm_s_variable, s_define);
- SCM_ASSYNT (1 == scm_ilength (x), scm_s_expression, s_define);
+ SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_variable, s_define);
+ SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_define);
if (SCM_TOP_LEVEL (env))
{
- x = evalcar (x, env);
-#ifdef DEBUG_EXTENSIONS
- if (SCM_REC_PROCNAMES_P && SCM_NIMP (x))
+ SCM var;
+ x = scm_eval_car (x, env);
+ if (SCM_REC_PROCNAMES_P)
{
- arg1 = x;
- proc:
- if (SCM_CLOSUREP (arg1)
+ SCM tmp = x;
+ while (SCM_MACROP (tmp))
+ tmp = SCM_MACRO_CODE (tmp);
+ if (SCM_CLOSUREP (tmp)
/* Only the first definition determines the name. */
- && SCM_FALSEP (scm_procedure_property (arg1, scm_sym_name)))
- scm_set_procedure_property_x (arg1, scm_sym_name, proc);
- else if (SCM_MACROP (arg1)
- /* Dirk::FIXME: Does the following test make sense? */
- && !SCM_EQ_P (SCM_MACRO_CODE (arg1), arg1))
- {
- arg1 = SCM_MACRO_CODE (arg1);
- goto proc;
- }
+ && SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name)))
+ scm_set_procedure_property_x (tmp, scm_sym_name, name);
}
-#endif
- arg1 = scm_sym2var (proc, scm_env_top_level (env), SCM_BOOL_T);
- SCM_VARIABLE_SET (arg1, x);
-#ifdef SICP
- return scm_cons2 (scm_sym_quote, proc, SCM_EOL);
-#else
+ var = scm_sym2var (name, scm_env_top_level (env), SCM_BOOL_T);
+ SCM_VARIABLE_SET (var, x);
return SCM_UNSPECIFIED;
-#endif
}
- return scm_cons2 (SCM_IM_DEFINE, proc, x);
+ else
+ return scm_cons2 (SCM_IM_DEFINE, name, x);
}
-/* end of acros */
-static SCM
-scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env SCM_UNUSED)
+/* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
+ * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
+ * reversed here, the list of inits gets reversed during evaluation. */
+static void
+transform_bindings (SCM bindings, SCM *rvarloc, SCM *initloc, const char *what)
{
- SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */
- char *what = SCM_SYMBOL_CHARS (SCM_CAR (xorig));
- SCM x = cdrx, proc, arg1; /* structure traversers */
- SCM vars = SCM_EOL, inits = SCM_EOL, *initloc = &inits;
+ SCM rvars = SCM_EOL;
+ *rvarloc = SCM_EOL;
+ *initloc = SCM_EOL;
+
+ SCM_ASSYNT (scm_ilength (bindings) >= 1, scm_s_bindings, what);
- proc = SCM_CAR (x);
- SCM_ASSYNT (scm_ilength (proc) >= 1, scm_s_bindings, what);
do
{
- /* vars scm_list reversed here, inits reversed at evaluation */
- arg1 = SCM_CAR (proc);
- SCM_ASSYNT (2 == scm_ilength (arg1), scm_s_bindings, what);
- SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), scm_s_variable, what);
- if (scm_c_improper_memq (SCM_CAR (arg1), vars))
+ SCM binding = SCM_CAR (bindings);
+ SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, what);
+ SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, what);
+ if (scm_c_improper_memq (SCM_CAR (binding), rvars))
scm_misc_error (what, scm_s_duplicate_bindings, SCM_EOL);
- vars = scm_cons (SCM_CAR (arg1), vars);
- *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
+ rvars = scm_cons (SCM_CAR (binding), rvars);
+ *initloc = scm_list_1 (SCM_CADR (binding));
initloc = SCM_CDRLOC (*initloc);
+ bindings = SCM_CDR (bindings);
}
- while (SCM_NIMP (proc = SCM_CDR (proc)));
+ while (!SCM_NULLP (bindings));
- return scm_cons2 (op, vars,
- scm_cons (inits, scm_m_body (imm, SCM_CDR (x), what)));
+ *rvarloc = rvars;
}
+
SCM_SYNTAX(s_letrec, "letrec", scm_makmmacro, scm_m_letrec);
SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
scm_m_letrec (SCM xorig, SCM env)
{
SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_body, s_letrec);
+ SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_letrec);
- if (SCM_NULLP (SCM_CAR (x))) /* null binding, let* faster */
- return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), SCM_EOL,
- scm_m_body (SCM_IM_LETREC,
- SCM_CDR (x),
- s_letrec)),
- env);
+ if (SCM_NULLP (SCM_CAR (x)))
+ {
+ /* null binding, let* faster */
+ SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), s_letrec);
+ return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), SCM_EOL, body), env);
+ }
else
- return scm_m_letrec1 (SCM_IM_LETREC, SCM_IM_LETREC, xorig, env);
+ {
+ SCM rvars, inits, body;
+ transform_bindings (SCM_CAR (x), &rvars, &inits, "letrec");
+ body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), "letrec");
+ return scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body));
+ }
}
+
SCM_SYNTAX(s_let, "let", scm_makmmacro, scm_m_let);
SCM_GLOBAL_SYMBOL(scm_sym_let, s_let);
-SCM
+SCM
scm_m_let (SCM xorig, SCM env)
{
- SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */
- SCM x = cdrx, proc, arg1, name; /* structure traversers */
- SCM vars = SCM_EOL, inits = SCM_EOL, *varloc = &vars, *initloc = &inits;
-
- SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_body, s_let);
- proc = SCM_CAR (x);
- if (SCM_NULLP (proc)
- || (SCM_CONSP (proc)
- && SCM_CONSP (SCM_CAR (proc)) && SCM_NULLP (SCM_CDR (proc))))
+ SCM x = SCM_CDR (xorig);
+ SCM temp;
+
+ SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_let);
+ temp = SCM_CAR (x);
+ if (SCM_NULLP (temp)
+ || (scm_ilength (temp) == 1 && SCM_CONSP (SCM_CAR (temp))))
{
/* null or single binding, let* is faster */
- return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), proc,
- scm_m_body (SCM_IM_LET,
- SCM_CDR (x),
- s_let)),
- env);
+ SCM bindings = temp;
+ SCM body = scm_m_body (SCM_IM_LET, SCM_CDR (x), s_let);
+ return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), bindings, body), env);
}
-
- SCM_ASSYNT (SCM_NIMP (proc), scm_s_bindings, s_let);
- if (SCM_CONSP (proc))
+ else if (SCM_CONSP (temp))
{
- /* plain let, proc is <bindings> */
- return scm_m_letrec1 (SCM_IM_LET, SCM_IM_LET, xorig, env);
+ /* plain let */
+ SCM bindings = temp;
+ SCM rvars, inits, body;
+ transform_bindings (bindings, &rvars, &inits, "let");
+ body = scm_m_body (SCM_IM_LET, SCM_CDR (x), "let");
+ return scm_cons2 (SCM_IM_LET, rvars, scm_cons (inits, body));
}
+ else
+ {
+ /* named let: Transform (let name ((var init) ...) body ...) into
+ * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
- if (!SCM_SYMBOLP (proc))
- scm_misc_error (s_let, scm_s_bindings, SCM_EOL); /* bad let */
- name = proc; /* named let, build equiv letrec */
- x = SCM_CDR (x);
- SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_body, s_let);
- proc = SCM_CAR (x); /* bindings list */
- SCM_ASSYNT (scm_ilength (proc) >= 0, scm_s_bindings, s_let);
- while (SCM_NIMP (proc))
- { /* vars and inits both in order */
- arg1 = SCM_CAR (proc);
- SCM_ASSYNT (2 == scm_ilength (arg1), scm_s_bindings, s_let);
- SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), scm_s_variable, s_let);
- *varloc = scm_cons (SCM_CAR (arg1), SCM_EOL);
- varloc = SCM_CDRLOC (*varloc);
- *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
- initloc = SCM_CDRLOC (*initloc);
- proc = SCM_CDR (proc);
- }
+ SCM name = temp;
+ SCM vars = SCM_EOL;
+ SCM *varloc = &vars;
+ SCM inits = SCM_EOL;
+ SCM *initloc = &inits;
+ SCM bindings;
- proc = scm_cons2 (scm_sym_lambda, vars,
- scm_m_body (SCM_IM_LET, SCM_CDR (x), "let"));
- proc = scm_cons2 (scm_sym_let, scm_cons (scm_cons2 (name, proc, SCM_EOL),
- SCM_EOL),
- scm_acons (name, inits, SCM_EOL));
- return scm_m_letrec1 (SCM_IM_LETREC, SCM_IM_LET, proc, env);
+ SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_bindings, s_let);
+ x = SCM_CDR (x);
+ SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_let);
+ bindings = SCM_CAR (x);
+ SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, s_let);
+ while (!SCM_NULLP (bindings))
+ { /* vars and inits both in order */
+ SCM binding = SCM_CAR (bindings);
+ SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, s_let);
+ SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, s_let);
+ *varloc = scm_list_1 (SCM_CAR (binding));
+ varloc = SCM_CDRLOC (*varloc);
+ *initloc = scm_list_1 (SCM_CADR (binding));
+ initloc = SCM_CDRLOC (*initloc);
+ bindings = SCM_CDR (bindings);
+ }
+
+ {
+ SCM lambda_body = scm_m_body (SCM_IM_LET, SCM_CDR (x), "let");
+ SCM lambda_form = scm_cons2 (scm_sym_lambda, vars, lambda_body);
+ SCM rvar = scm_list_1 (name);
+ SCM init = scm_list_1 (lambda_form);
+ SCM body = scm_m_body (SCM_IM_LET, scm_list_1 (name), "let");
+ SCM letrec = scm_cons2 (SCM_IM_LETREC, rvar, scm_cons (init, body));
+ return scm_cons (letrec, inits);
+ }
+ }
}
return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));
}
-/* Multi-language support */
-
-SCM_GLOBAL_SYMBOL (scm_lisp_nil, "nil");
-SCM_GLOBAL_SYMBOL (scm_lisp_t, "t");
+#ifdef SCM_ENABLE_ELISP
SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond);
return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig));
}
-SCM_SYNTAX (s_nil_ify, "nil-ify", scm_makmmacro, scm_m_nil_ify);
-
-SCM
-scm_m_nil_ify (SCM xorig, SCM env SCM_UNUSED)
-{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "nil-ify");
- return scm_cons (SCM_IM_NIL_IFY, SCM_CDR (xorig));
-}
-
-SCM_SYNTAX (s_t_ify, "t-ify", scm_makmmacro, scm_m_t_ify);
-
-SCM
-scm_m_t_ify (SCM xorig, SCM env SCM_UNUSED)
-{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "t-ify");
- return scm_cons (SCM_IM_T_IFY, SCM_CDR (xorig));
-}
-
-SCM_SYNTAX (s_0_cond, "0-cond", scm_makmmacro, scm_m_0_cond);
-
-SCM
-scm_m_0_cond (SCM xorig, SCM env SCM_UNUSED)
-{
- long len = scm_ilength (SCM_CDR (xorig));
- SCM_ASSYNT (len >= 1 && (len & 1) == 1, scm_s_expression, "0-cond");
- return scm_cons (SCM_IM_0_COND, SCM_CDR (xorig));
-}
-
-SCM_SYNTAX (s_0_ify, "0-ify", scm_makmmacro, scm_m_0_ify);
-
-SCM
-scm_m_0_ify (SCM xorig, SCM env SCM_UNUSED)
-{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "0-ify");
- return scm_cons (SCM_IM_0_IFY, SCM_CDR (xorig));
-}
-
-SCM_SYNTAX (s_1_ify, "1-ify", scm_makmmacro, scm_m_1_ify);
-
-SCM
-scm_m_1_ify (SCM xorig, SCM env SCM_UNUSED)
-{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "1-ify");
- return scm_cons (SCM_IM_1_IFY, SCM_CDR (xorig));
-}
-
SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop);
SCM
SCM x = SCM_CDR (xorig), var;
SCM_ASSYNT (scm_ilength (x) >= 1, scm_s_expression, "@fop");
var = scm_symbol_fref (SCM_CAR (x));
+ /* Passing the symbol name as the `subr' arg here isn't really
+ right, but without it it can be very difficult to work out from
+ the error message which function definition was missing. In any
+ case, we shouldn't really use SCM_ASSYNT here at all, but instead
+ something equivalent to (signal void-function (list SYM)) in
+ Elisp. */
SCM_ASSYNT (SCM_VARIABLEP (var),
- "Symbol's function definition is void", NULL);
+ "Symbol's function definition is void",
+ SCM_SYMBOL_CHARS (SCM_CAR (x)));
+ /* Support `defalias'. */
+ while (SCM_SYMBOLP (SCM_VARIABLE_REF (var)))
+ {
+ var = scm_symbol_fref (SCM_VARIABLE_REF (var));
+ SCM_ASSYNT (SCM_VARIABLEP (var),
+ "Symbol's function definition is void",
+ SCM_SYMBOL_CHARS (SCM_CAR (x)));
+ }
+ /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
+ former allows for automatically picking up redefinitions of the
+ corresponding symbol. */
SCM_SETCAR (x, var);
+ /* If the variable contains a procedure, leave the
+ `transformer-macro' in place so that the procedure's arguments
+ get properly transformed, and change the initial @fop to
+ SCM_IM_APPLY. */
+ if (!SCM_MACROP (SCM_VARIABLE_REF (var)))
+ {
+ SCM_SETCAR (xorig, SCM_IM_APPLY);
+ return xorig;
+ }
+ /* Otherwise (the variable contains a macro), the arguments should
+ not be transformed, so cut the `transformer-macro' out and return
+ the resulting expression starting with the variable. */
+ SCM_SETCDR (x, SCM_CDADR (x));
return x;
}
+#endif /* SCM_ENABLE_ELISP */
+
/* (@bind ((var exp) ...) body ...)
This will assign the values of the `exp's to the global variables
error when a symbol appears more than once among the `var's.
All `exp's are evaluated before any `var' is set.
- This of this as `let' for dynamic scope.
+ Think of this as `let' for dynamic scope.
It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
{
SCM x = SCM_CDR (xorig);
SCM top_level = scm_env_top_level (env);
- SCM vars = SCM_EOL;
+ SCM vars = SCM_EOL, var;
SCM exps = SCM_EOL;
SCM_ASSYNT (scm_ilength (x) > 1, scm_s_expression, s_atbind);
SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp)), scm_s_bindings, s_atbind);
x = SCM_CDR (x);
for (rest = x; SCM_NIMP (rest); rest = SCM_CDR (rest))
- if (SCM_EQ_P (SCM_CAR (sym_exp), SCM_CAR (SCM_CAR (rest))))
+ if (SCM_EQ_P (SCM_CAR (sym_exp), SCM_CAAR (rest)))
scm_misc_error (s_atbind, scm_s_duplicate_bindings, SCM_EOL);
- vars = scm_cons (scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_T),
- vars);
+ /* The first call to scm_sym2var will look beyond the current
+ module, while the second call wont. */
+ var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_F);
+ if (SCM_FALSEP (var))
+ var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_T);
+ vars = scm_cons (var, vars);
exps = scm_cons (SCM_CADR (sym_exp), exps);
}
return scm_cons (SCM_IM_BIND,
}
else if (SCM_EQ_P (SCM_IM_BEGIN, SCM_CAR (form)))
{
- x = scm_append (scm_cons2 (SCM_CDR (form), SCM_CDR (x), SCM_EOL));
+ x = scm_append (scm_list_2 (SCM_CDR (form), SCM_CDR (x)));
}
else
{
}
}
- SCM_ASSYNT (SCM_NIMP (x), scm_s_body, what);
- if (SCM_NIMP (defs))
+ if (!SCM_NULLP (defs))
{
- x = scm_cons (scm_m_letrec1 (SCM_IM_LETREC,
- SCM_IM_DEFINE,
- scm_cons2 (scm_sym_define, defs, x),
- env),
- SCM_EOL);
+ SCM rvars, inits, body, letrec;
+ transform_bindings (defs, &rvars, &inits, what);
+ body = scm_m_body (SCM_IM_DEFINE, x, what);
+ letrec = scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body));
+ SCM_SETCAR (xorig, letrec);
+ SCM_SETCDR (xorig, SCM_EOL);
+ }
+ else
+ {
+ SCM_ASSYNT (SCM_CONSP (x), scm_s_body, what);
+ SCM_SETCAR (xorig, SCM_CAR (x));
+ SCM_SETCDR (xorig, SCM_CDR (x));
}
-
- SCM_DEFER_INTS;
- SCM_SETCAR (xorig, SCM_CAR (x));
- SCM_SETCDR (xorig, SCM_CDR (x));
- SCM_ALLOW_INTS;
return xorig;
}
res = scm_call_2 (SCM_MACRO_CODE (proc), x, env);
if (scm_ilength (res) <= 0)
- res = scm_cons2 (SCM_IM_BEGIN, res, SCM_EOL);
+ res = scm_list_2 (SCM_IM_BEGIN, res);
SCM_DEFER_INTS;
SCM_SETCAR (x, SCM_CAR (res));
* generating the source for a stackframe in a backtrace, and in
* display_expression.
*
- * Unmemoizing is not a realiable process. You can not in general
+ * Unmemoizing is not a reliable process. You cannot in general
* expect to get the original source back.
*
* However, GOOPS currently relies on this for method compilation.
#define SCM_BIT8(x) (127 & SCM_UNPACK (x))
+static SCM
+build_binding_list (SCM names, SCM inits)
+{
+ SCM bindings = SCM_EOL;
+ while (!SCM_NULLP (names))
+ {
+ SCM binding = scm_list_2 (SCM_CAR (names), SCM_CAR (inits));
+ bindings = scm_cons (binding, bindings);
+ names = SCM_CDR (names);
+ inits = SCM_CDR (inits);
+ }
+ return bindings;
+}
+
static SCM
unmemocopy (SCM x, SCM env)
{
#ifdef DEBUG_EXTENSIONS
SCM p;
#endif
- if (!SCM_CELLP (x) || !SCM_CONSP (x))
+ if (!SCM_CONSP (x))
return x;
#ifdef DEBUG_EXTENSIONS
p = scm_whash_lookup (scm_source_whash, x);
#endif
- switch (SCM_TYP7 (x))
+ switch (SCM_ITAG7 (SCM_CAR (x)))
{
case SCM_BIT8(SCM_IM_AND):
ls = z = scm_cons (scm_sym_and, SCM_UNSPECIFIED);
case SCM_BIT8(SCM_IM_COND):
ls = z = scm_cons (scm_sym_cond, SCM_UNSPECIFIED);
break;
- case SCM_BIT8(SCM_IM_DO):
- ls = scm_cons (scm_sym_do, SCM_UNSPECIFIED);
- goto transform;
- case SCM_BIT8(SCM_IM_IF):
- ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED);
- break;
- case SCM_BIT8(SCM_IM_LET):
- ls = scm_cons (scm_sym_let, SCM_UNSPECIFIED);
- goto transform;
- case SCM_BIT8(SCM_IM_LETREC):
+ case SCM_BIT8 (SCM_IM_DO):
{
- SCM f, v, e, s;
- ls = scm_cons (scm_sym_letrec, SCM_UNSPECIFIED);
- transform:
+ /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk),
+ * where nx is the name of a local variable, ix is an initializer for
+ * 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);
+ names = SCM_CAR (x);
+ x = SCM_CDR (x);
+ inits = scm_reverse (unmemocopy (SCM_CAR (x), env));
+ env = EXTEND_ENV (names, SCM_EOL, env);
x = SCM_CDR (x);
- /* binding names */
- f = v = SCM_CAR (x);
+ test = unmemocopy (SCM_CAR (x), env);
x = SCM_CDR (x);
- z = EXTEND_ENV (f, SCM_EOL, env);
- /* inits */
- e = scm_reverse (unmemocopy (SCM_CAR (x),
- SCM_EQ_P (SCM_CAR (ls), scm_sym_letrec) ? z : env));
- env = z;
- /* increments */
- s = SCM_EQ_P (SCM_CAR (ls), scm_sym_do)
- ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x))), env))
- : f;
+ memoized_body = SCM_CAR (x);
+ x = SCM_CDR (x);
+ steps = scm_reverse (unmemocopy (x, env));
+
/* build transformed binding list */
- z = SCM_EOL;
- while (SCM_NIMP (v))
- {
- z = scm_acons (SCM_CAR (v),
- scm_cons (SCM_CAR (e),
- SCM_EQ_P (SCM_CAR (s), SCM_CAR (v))
- ? SCM_EOL
- : scm_cons (SCM_CAR (s), SCM_EOL)),
- z);
- v = SCM_CDR (v);
- e = SCM_CDR (e);
- s = SCM_CDR (s);
- }
- z = scm_cons (z, SCM_UNSPECIFIED);
- SCM_SETCDR (ls, z);
- if (SCM_EQ_P (SCM_CAR (ls), scm_sym_do))
+ bindings = SCM_EOL;
+ while (!SCM_NULLP (names))
{
- x = SCM_CDR (x);
- /* test clause */
- SCM_SETCDR (z, scm_cons (unmemocopy (SCM_CAR (x), env),
- SCM_UNSPECIFIED));
- z = SCM_CDR (z);
- x = (SCM) (SCM_CARLOC (SCM_CDR (x)) - 1);
- /* body forms are now to be found in SCM_CDR (x)
- (this is how *real* code look like! :) */
+ 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);
+
+ 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_BIT8(SCM_IM_IF):
+ ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED);
+ break;
+ case SCM_BIT8 (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 names, inits, bindings;
+
+ x = SCM_CDR (x);
+ names = SCM_CAR (x);
+ x = SCM_CDR (x);
+ inits = scm_reverse (unmemocopy (SCM_CAR (x), env));
+ env = EXTEND_ENV (names, SCM_EOL, env);
+
+ bindings = build_binding_list (names, inits);
+ z = scm_cons (bindings, SCM_UNSPECIFIED);
+ ls = scm_cons (scm_sym_let, z);
+ break;
+ }
+ case SCM_BIT8 (SCM_IM_LETREC):
+ {
+ /* format: (#@letrec (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 names, inits, bindings;
+
+ x = SCM_CDR (x);
+ names = SCM_CAR (x);
+ env = EXTEND_ENV (names, SCM_EOL, env);
+ x = SCM_CDR (x);
+ inits = scm_reverse (unmemocopy (SCM_CAR (x), env));
+
+ bindings = build_binding_list (names, inits);
+ z = scm_cons (bindings, SCM_UNSPECIFIED);
+ ls = scm_cons (scm_sym_letrec, z);
break;
}
case SCM_BIT8(SCM_IM_LETSTAR):
}
y = z = scm_acons (SCM_CAR (b),
unmemocar (
- scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b)), env), SCM_EOL), env),
+ scm_cons (unmemocopy (SCM_CADR (b), env), SCM_EOL), env),
SCM_UNSPECIFIED);
env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
- b = SCM_CDR (SCM_CDR (b));
+ b = SCM_CDDR (b);
if (SCM_IMP (b))
{
SCM_SETCDR (y, SCM_EOL);
{
SCM_SETCDR (z, scm_acons (SCM_CAR (b),
unmemocar (
- scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b)), env), SCM_EOL), env),
+ scm_list_1 (unmemocopy (SCM_CADR (b), env)), env),
SCM_UNSPECIFIED));
z = SCM_CDR (z);
env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
- b = SCM_CDR (SCM_CDR (b));
+ b = SCM_CDDR (b);
}
while (SCM_NIMP (b));
SCM_SETCDR (z, SCM_EOL);
break;
case SCM_BIT8(SCM_IM_LAMBDA):
x = SCM_CDR (x);
- ls = scm_cons (scm_sym_lambda,
- z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED));
+ z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED);
+ ls = scm_cons (scm_sym_lambda, z);
env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, env);
break;
case SCM_BIT8(SCM_IM_QUOTE):
{
SCM n;
x = SCM_CDR (x);
- ls = scm_cons (scm_sym_define,
- z = scm_cons (n = SCM_CAR (x), SCM_UNSPECIFIED));
+ n = SCM_CAR (x);
+ z = scm_cons (n, SCM_UNSPECIFIED);
+ ls = scm_cons (scm_sym_define, z);
if (!SCM_NULLP (env))
- SCM_SETCAR (SCM_CAR (env), scm_cons (n, SCM_CAR (SCM_CAR (env))));
+ SCM_SETCAR (SCM_CAR (env), scm_cons (n, SCM_CAAR (env)));
break;
}
case SCM_BIT8(SCM_MAKISYM (0)):
env);
}
loop:
- while (SCM_CELLP (x = SCM_CDR (x)) && SCM_CONSP (x))
+ x = SCM_CDR (x);
+ while (SCM_CONSP (x))
{
- if (SCM_ISYMP (SCM_CAR (x)))
- /* skip body markers */
- continue;
- SCM_SETCDR (z, unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env),
- SCM_UNSPECIFIED),
- env));
- z = SCM_CDR (z);
+ SCM form = SCM_CAR (x);
+ if (!SCM_ISYMP (form))
+ {
+ SCM copy = scm_cons (unmemocopy (form, env), SCM_UNSPECIFIED);
+ SCM_SETCDR (z, unmemocar (copy, env));
+ z = SCM_CDR (z);
+ }
+ x = SCM_CDR (x);
}
SCM_SETCDR (z, x);
#ifdef DEBUG_EXTENSIONS
}
return !SCM_NULLP (args) ? 1 : 0;
}
+
#endif
static int
{
res = EVALCAR (l, env);
- *lloc = scm_cons (res, SCM_EOL);
+ *lloc = scm_list_1 (res);
lloc = SCM_CDRLOC (*lloc);
l = SCM_CDR (l);
}
#define SCM_APPLY scm_apply
#define PREP_APPLY(proc, args)
#define ENTER_APPLY
-#define RETURN(x) return x;
+#define RETURN(x) do { return x; } while (0)
#ifdef STACK_CHECKING
#ifndef NO_CEVAL_STACK_CHECKING
#define EVAL_STACK_CHECKING
}\
} while (0)
#undef RETURN
-#define RETURN(e) {proc = (e); goto exit;}
+#define RETURN(e) do { proc = (e); goto exit; } while (0)
#ifdef STACK_CHECKING
#ifndef EVAL_STACK_CHECKING
#define EVAL_STACK_CHECKING
}
#undef FUNC_NAME
-SCM
-scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
+static SCM
+deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
{
SCM *results = lloc, res;
while (SCM_CONSP (l))
{
res = EVALCAR (l, env);
- *lloc = scm_cons (res, SCM_EOL);
+ *lloc = scm_list_1 (res);
lloc = SCM_CDRLOC (*lloc);
l = SCM_CDR (l);
}
#endif /* !DEVAL */
-/* SECTION: Some local definitions for the evaluator.
+/* SECTION: This code is compiled twice.
*/
+
/* Update the toplevel environment frame ENV so that it refers to the
- current module.
-*/
+ * current module. */
#define UPDATE_TOPLEVEL_ENV(env) \
do { \
SCM p = scm_current_module_lookup_closure (); \
#define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (!SCM_FALSEP (scm_eqv_p ((A), (B)))))
#endif /* DEVAL */
-#define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
-
-/* SECTION: This is the evaluator. Like any real monster, it has
- * three heads. This code is compiled twice.
- */
+/* 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
+ * 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.
+ *
+ * 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
-#if 0
+#if 0
SCM
scm_deval (SCM x, SCM env)
{}
* Even frames are eval frames, odd frames are apply frames.
*/
debug.vect = (scm_t_debug_info *) alloca (scm_debug_eframe_size
- * sizeof (debug.vect[0]));
+ * sizeof (scm_t_debug_info));
debug.info = debug.vect;
debug_info_end = debug.vect + scm_debug_eframe_size;
scm_last_debug_frame = &debug;
{
x = val;
if (SCM_IMP (x))
- {
- RETURN (x);
- }
+ RETURN (x);
else
/* This gives the possibility for the debugger to
modify the source expression before evaluation. */
switch (SCM_TYP7 (x))
{
case scm_tc7_symbol:
- /* Only happens when called at top level.
- */
+ /* Only happens when called at top level. */
x = scm_cons (x, SCM_UNDEFINED);
- goto retval;
+ RETURN (*scm_lookupcar (x, env, 1));
case SCM_BIT8(SCM_IM_AND):
x = SCM_CDR (x);
- t.arg1 = x;
- while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1)))
- if (SCM_FALSEP (EVALCAR (x, env)))
- {
+ while (!SCM_NULLP (SCM_CDR (x)))
+ {
+ if (SCM_FALSEP (t.arg1 = EVALCAR (x, env)) || SCM_NILP (t.arg1))
RETURN (SCM_BOOL_F);
- }
- else
- x = t.arg1;
+ else
+ x = SCM_CDR (x);
+ }
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop;
case SCM_BIT8(SCM_IM_BEGIN):
+ if (SCM_NULLP (SCM_CDR (x)))
+ RETURN (SCM_UNSPECIFIED);
+
/* (currently unused)
cdrxnoap: */
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
with the current module. */
if (SCM_CONSP (env) && !SCM_CONSP (SCM_CAR (env)))
{
- t.arg1 = x;
UPDATE_TOPLEVEL_ENV (env);
- while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1)))
+ while (!SCM_NULLP (SCM_CDR (x)))
{
EVALCAR (x, env);
- x = t.arg1;
UPDATE_TOPLEVEL_ENV (env);
+ x = SCM_CDR (x);
}
goto carloop;
}
nontoplevel_cdrxbegin:
x = SCM_CDR (x);
nontoplevel_begin:
- t.arg1 = x;
- while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1)))
+ while (!SCM_NULLP (SCM_CDR (x)))
{
if (SCM_IMP (SCM_CAR (x)))
{
}
else
SCM_CEVAL (SCM_CAR (x), env);
- x = t.arg1;
+ x = SCM_CDR (x);
}
carloop: /* scm_eval car of last form in list */
- if (!SCM_CELLP (SCM_CAR (x)))
+ if (SCM_IMP (SCM_CAR (x)))
{
x = SCM_CAR (x);
- RETURN (SCM_EVALIM (x, env))
+ RETURN (SCM_EVALIM (x, env));
}
if (SCM_SYMBOLP (SCM_CAR (x)))
- {
- retval:
- RETURN (*scm_lookupcar (x, env, 1))
- }
+ RETURN (*scm_lookupcar (x, env, 1));
x = SCM_CAR (x);
goto loop; /* tail recurse */
{
if (CHECK_EQVISH (SCM_CAR (proc), t.arg1))
{
- x = SCM_CDR (SCM_CAR (x));
+ x = SCM_CDAR (x);
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto begin;
}
proc = SCM_CDR (proc);
}
}
- RETURN (SCM_UNSPECIFIED)
+ RETURN (SCM_UNSPECIFIED);
- case SCM_BIT8(SCM_IM_COND):
- while (!SCM_IMP (x = SCM_CDR (x)))
+ case SCM_BIT8 (SCM_IM_COND):
+ x = SCM_CDR (x);
+ while (!SCM_NULLP (x))
{
proc = SCM_CAR (x);
+ if (SCM_EQ_P (SCM_CAR (proc), scm_sym_else))
+ {
+ x = SCM_CDR (proc);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
t.arg1 = EVALCAR (proc, env);
- if (!SCM_FALSEP (t.arg1))
+ if (!SCM_FALSEP (t.arg1) && !SCM_NILP (t.arg1))
{
x = SCM_CDR (proc);
if (SCM_NULLP (x))
- {
- RETURN (t.arg1)
- }
+ RETURN (t.arg1);
if (!SCM_EQ_P (scm_sym_arrow, SCM_CAR (x)))
{
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
proc = SCM_CDR (x);
proc = EVALCAR (proc, env);
SCM_ASRTGO (SCM_NIMP (proc), badfun);
- PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL));
+ PREP_APPLY (proc, scm_list_1 (t.arg1));
ENTER_APPLY;
if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1))
goto umwrongnumargs;
goto evap1;
}
+ x = SCM_CDR (x);
}
- RETURN (SCM_UNSPECIFIED)
+ RETURN (SCM_UNSPECIFIED);
case SCM_BIT8(SCM_IM_DO):
x = SCM_CDR (x);
- proc = SCM_CAR (SCM_CDR (x)); /* inits */
+ proc = SCM_CADR (x); /* inits */
t.arg1 = SCM_EOL; /* values */
while (SCM_NIMP (proc))
{
proc = SCM_CDR (proc);
}
env = EXTEND_ENV (SCM_CAR (x), t.arg1, env);
- x = SCM_CDR (SCM_CDR (x));
- while (proc = SCM_CAR (x), SCM_FALSEP (EVALCAR (proc, env)))
+ x = SCM_CDDR (x);
+ while (proc = SCM_CAR (x),
+ SCM_FALSEP (t.arg1 = EVALCAR (proc, env)) || SCM_NILP (t.arg1))
{
for (proc = SCM_CADR (x); SCM_NIMP (proc); proc = SCM_CDR (proc))
{
SCM_NIMP (proc);
proc = SCM_CDR (proc))
t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); /* steps */
- env = EXTEND_ENV (SCM_CAR (SCM_CAR (env)), t.arg1, SCM_CDR (env));
+ env = EXTEND_ENV (SCM_CAAR (env), t.arg1, SCM_CDR (env));
}
x = SCM_CDR (proc);
if (SCM_NULLP (x))
case SCM_BIT8(SCM_IM_IF):
x = SCM_CDR (x);
- if (!SCM_FALSEP (EVALCAR (x, env)))
+ if (!SCM_FALSEP (t.arg1 = EVALCAR (x, env)) && !SCM_NILP (t.arg1))
x = SCM_CDR (x);
- else if (SCM_IMP (x = SCM_CDR (SCM_CDR (x))))
- {
- RETURN (SCM_UNSPECIFIED);
- }
+ else if (SCM_IMP (x = SCM_CDDR (x)))
+ RETURN (SCM_UNSPECIFIED);
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop;
case SCM_BIT8(SCM_IM_LET):
x = SCM_CDR (x);
- proc = SCM_CAR (SCM_CDR (x));
+ proc = SCM_CADR (x);
t.arg1 = SCM_EOL;
do
{
case SCM_BIT8(SCM_IM_LETSTAR):
x = SCM_CDR (x);
- proc = SCM_CAR (x);
- if (SCM_IMP (proc))
- {
+ {
+ SCM bindings = SCM_CAR (x);
+ if (SCM_NULLP (bindings))
env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
- goto nontoplevel_cdrxnoap;
- }
- do
- {
- t.arg1 = SCM_CAR (proc);
- proc = SCM_CDR (proc);
- env = EXTEND_ENV (t.arg1, EVALCAR (proc, env), env);
- }
- while (SCM_NIMP (proc = SCM_CDR (proc)));
+ else
+ {
+ do
+ {
+ SCM name = SCM_CAR (bindings);
+ SCM init = SCM_CDR (bindings);
+ env = EXTEND_ENV (name, EVALCAR (init, env), env);
+ bindings = SCM_CDR (init);
+ }
+ while (!SCM_NULLP (bindings));
+ }
+ }
goto nontoplevel_cdrxnoap;
+
case SCM_BIT8(SCM_IM_OR):
x = SCM_CDR (x);
- t.arg1 = x;
- while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1)))
+ while (!SCM_NULLP (SCM_CDR (x)))
{
- x = EVALCAR (x, env);
- if (!SCM_FALSEP (x))
- {
- RETURN (x);
- }
- x = t.arg1;
+ 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_BIT8(SCM_IM_QUOTE):
- RETURN (SCM_CAR (SCM_CDR (x)));
+ RETURN (SCM_CADR (x));
case SCM_BIT8(SCM_IM_SET_X):
case SCM_BIT8(SCM_MAKISYM (0)):
proc = SCM_CAR (x);
SCM_ASRTGO (SCM_ISYMP (proc), badfun);
- switch SCM_ISYMNUM (proc)
+ switch (SCM_ISYMNUM (proc))
{
case (SCM_ISYMNUM (SCM_IM_APPLY)):
proc = SCM_CDR (x);
{
SCM argl, tl;
PREP_APPLY (proc, SCM_EOL);
- t.arg1 = SCM_CDR (SCM_CDR (x));
+ t.arg1 = SCM_CDDR (x);
t.arg1 = EVALCAR (t.arg1, env);
apply_closure:
/* Go here to tail-call a closure. PROC is the closure
}
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), argl, SCM_ENV (proc));
- x = SCM_CODE (proc);
- goto nontoplevel_cdrxbegin;
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
}
proc = scm_f_apply;
goto evapply;
RETURN (val);
}
proc = SCM_CDR (x);
- proc = evalcar (proc, env);
+ proc = scm_eval_car (proc, env);
SCM_ASRTGO (SCM_NIMP (proc), badfun);
- PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL));
+ PREP_APPLY (proc, scm_list_1 (t.arg1));
ENTER_APPLY;
if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1))
goto umwrongnumargs;
goto evap1;
case (SCM_ISYMNUM (SCM_IM_DELAY)):
- RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)))
+ RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)));
case (SCM_ISYMNUM (SCM_IM_DISPATCH)):
proc = SCM_CADR (x); /* unevaluated operands */
}
else
{
- arg2 = scm_cons (EVALCAR (proc, env), SCM_EOL);
+ arg2 = scm_list_1 (EVALCAR (proc, env));
t.lloc = SCM_CDRLOC (arg2);
while (SCM_NIMP (proc = SCM_CDR (proc)))
{
- *t.lloc = scm_cons (EVALCAR (proc, env), SCM_EOL);
+ *t.lloc = scm_list_1 (EVALCAR (proc, env));
t.lloc = SCM_CDRLOC (*t.lloc);
}
}
case (SCM_ISYMNUM (SCM_IM_SLOT_REF)):
x = SCM_CDR (x);
t.arg1 = EVALCAR (x, env);
- RETURN (SCM_PACK (SCM_STRUCT_DATA (t.arg1) [SCM_INUM (SCM_CADR (x))]))
+ RETURN (SCM_PACK (SCM_STRUCT_DATA (t.arg1) [SCM_INUM (SCM_CADR (x))]));
case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X)):
x = SCM_CDR (x);
proc = SCM_CDR (x);
SCM_STRUCT_DATA (t.arg1) [SCM_INUM (SCM_CAR (x))]
= SCM_UNPACK (EVALCAR (proc, env));
- RETURN (SCM_UNSPECIFIED)
+ RETURN (SCM_UNSPECIFIED);
+
+#ifdef SCM_ENABLE_ELISP
case (SCM_ISYMNUM (SCM_IM_NIL_COND)):
proc = SCM_CDR (x);
while (SCM_NIMP (x = SCM_CDR (proc)))
{
if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env))
- || SCM_EQ_P (t.arg1, scm_lisp_nil)))
+ || SCM_NILP (t.arg1)
+ || SCM_NULLP (t.arg1)))
{
if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED))
RETURN (t.arg1);
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop;
- case (SCM_ISYMNUM (SCM_IM_NIL_IFY)):
- x = SCM_CDR (x);
- RETURN ((SCM_FALSEP (proc = EVALCAR (x, env)) || SCM_NULLP (proc))
- ? scm_lisp_nil
- : proc)
-
- case (SCM_ISYMNUM (SCM_IM_T_IFY)):
- x = SCM_CDR (x);
- RETURN (!SCM_FALSEP (EVALCAR (x, env)) ? scm_lisp_t : scm_lisp_nil)
-
- case (SCM_ISYMNUM (SCM_IM_0_COND)):
- proc = SCM_CDR (x);
- while (SCM_NIMP (x = SCM_CDR (proc)))
- {
- if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env))
- || SCM_EQ_P (t.arg1, SCM_INUM0)))
- {
- if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED))
- RETURN (t.arg1);
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
- }
- proc = SCM_CDR (x);
- }
- x = proc;
- PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto carloop;
-
- case (SCM_ISYMNUM (SCM_IM_0_IFY)):
- x = SCM_CDR (x);
- RETURN (SCM_FALSEP (proc = EVALCAR (x, env))
- ? SCM_INUM0
- : proc)
-
- case (SCM_ISYMNUM (SCM_IM_1_IFY)):
- x = SCM_CDR (x);
- RETURN (!SCM_FALSEP (EVALCAR (x, env))
- ? SCM_MAKINUM (1)
- : SCM_INUM0)
+#endif /* SCM_ENABLE_ELISP */
case (SCM_ISYMNUM (SCM_IM_BIND)):
{
scm_dynwinds = SCM_CDR (scm_dynwinds);
scm_swap_bindings (vars, vals);
- RETURN (proc)
+ RETURN (proc);
}
-
+
case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
{
proc = SCM_CDR (x);
if (SCM_VALUESP (t.arg1))
t.arg1 = scm_struct_ref (t.arg1, SCM_INUM0);
else
- t.arg1 = scm_cons (t.arg1, SCM_EOL);
+ t.arg1 = scm_list_1 (t.arg1);
if (SCM_CLOSUREP (proc))
{
PREP_APPLY (proc, t.arg1);
default:
proc = x;
badfun:
- /* scm_everr (x, env,...) */
scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc));
case scm_tc7_vector:
case scm_tc7_wvect:
#endif
#endif
case scm_tc7_string:
- case scm_tc7_substring:
case scm_tc7_smob:
case scm_tcs_closures:
case scm_tc7_cclo:
{
case 2:
if (scm_ilength (t.arg1) <= 0)
- t.arg1 = scm_cons2 (SCM_IM_BEGIN, t.arg1, SCM_EOL);
+ t.arg1 = scm_list_2 (SCM_IM_BEGIN, t.arg1);
#ifdef DEVAL
if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))
{
proc = SCM_CCLO_SUBR (proc);
#ifdef DEVAL
debug.info->a.proc = proc;
- debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
+ debug.info->a.args = scm_list_1 (t.arg1);
#endif
goto evap1;
case scm_tc7_pws:
if (scm_badformalsp (proc, 0))
goto umwrongnumargs;
case scm_tcs_closures:
- x = SCM_CODE (proc);
+ x = SCM_CLOSURE_BODY (proc);
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), SCM_EOL, SCM_ENV (proc));
- goto nontoplevel_cdrxbegin;
+ goto nontoplevel_begin;
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
: SCM_OPERATOR_PROCEDURE (proc));
#ifdef DEVAL
debug.info->a.proc = proc;
- debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
+ debug.info->a.args = scm_list_1 (t.arg1);
#endif
if (SCM_NIMP (proc))
goto evap1;
umwrongnumargs:
unmemocar (x, env);
wrongnumargs:
- /* scm_everr (x, env,...) */
scm_wrong_num_args (proc);
default:
/* handle macros here */
t.arg1 = EVALCAR (x, env);
#endif
#ifdef DEVAL
- debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
+ debug.info->a.args = scm_list_1 (t.arg1);
#endif
x = SCM_CDR (x);
if (SCM_NULLP (x))
RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED));
case scm_tc7_lsubr:
#ifdef DEVAL
- RETURN (SCM_SUBRF (proc) (debug.info->a.args))
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args));
#else
- RETURN (SCM_SUBRF (proc) (scm_cons (t.arg1, SCM_EOL)));
+ RETURN (SCM_SUBRF (proc) (scm_list_1 (t.arg1)));
#endif
case scm_tc7_smob:
if (!SCM_SMOB_APPLICABLE_P (proc))
goto umwrongnumargs;
case scm_tcs_closures:
/* clos1: */
- x = SCM_CODE (proc);
+ x = SCM_CLOSURE_BODY (proc);
#ifdef DEVAL
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), debug.info->a.args, SCM_ENV (proc));
#else
- env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_list_1 (t.arg1), SCM_ENV (proc));
#endif
- goto nontoplevel_cdrxbegin;
+ goto nontoplevel_begin;
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
#ifdef DEVAL
arg2 = debug.info->a.args;
#else
- arg2 = scm_cons (t.arg1, SCM_EOL);
+ arg2 = scm_list_1 (t.arg1);
#endif
goto type_dispatch;
}
#endif
{ /* have two or more arguments */
#ifdef DEVAL
- debug.info->a.args = scm_cons2 (t.arg1, arg2, SCM_EOL);
+ debug.info->a.args = scm_list_2 (t.arg1, arg2);
#endif
x = SCM_CDR (x);
if (SCM_NULLP (x)) {
RETURN (SCM_SUBRF (proc) (t.arg1, arg2));
case scm_tc7_lsubr:
#ifdef DEVAL
- RETURN (SCM_SUBRF (proc) (debug.info->a.args))
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args));
#else
- RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, SCM_EOL)));
+ RETURN (SCM_SUBRF (proc) (scm_list_2 (t.arg1, arg2)));
#endif
case scm_tc7_lsubr_2:
RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_EOL));
#ifdef DEVAL
arg2 = debug.info->a.args;
#else
- arg2 = scm_cons2 (t.arg1, arg2, SCM_EOL);
+ arg2 = scm_list_2 (t.arg1, arg2);
#endif
goto type_dispatch;
}
SCM_ENV (proc));
#else
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
+ scm_list_2 (t.arg1, arg2), SCM_ENV (proc));
#endif
- x = SCM_CODE (proc);
- goto nontoplevel_cdrxbegin;
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
}
}
#ifdef SCM_CAUTIOUS
#endif
#ifdef DEVAL
debug.info->a.args = scm_cons2 (t.arg1, arg2,
- scm_deval_args (x, env, proc,
- SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
+ deval_args (x, env, proc, SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
#endif
ENTER_APPLY;
evap3:
case scm_tc7_asubr:
#ifdef BUILTIN_RPASUBR
t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
- arg2 = SCM_CDR (SCM_CDR (debug.info->a.args));
+ arg2 = SCM_CDDR (debug.info->a.args);
do
{
t.arg1 = SCM_SUBRF(proc)(t.arg1, SCM_CAR (arg2));
arg2 = SCM_CDR (arg2);
}
while (SCM_NIMP (arg2));
- RETURN (t.arg1)
+ RETURN (t.arg1);
#endif /* BUILTIN_RPASUBR */
case scm_tc7_rpsubr:
#ifdef BUILTIN_RPASUBR
if (SCM_FALSEP (SCM_SUBRF (proc) (t.arg1, arg2)))
- RETURN (SCM_BOOL_F)
- t.arg1 = SCM_CDR (SCM_CDR (debug.info->a.args));
+ RETURN (SCM_BOOL_F);
+ t.arg1 = SCM_CDDR (debug.info->a.args);
do
{
if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (t.arg1))))
- RETURN (SCM_BOOL_F)
- arg2 = SCM_CAR (t.arg1);
+ RETURN (SCM_BOOL_F);
+ arg2 = SCM_CAR (t.arg1);
t.arg1 = SCM_CDR (t.arg1);
}
while (SCM_NIMP (t.arg1));
- RETURN (SCM_BOOL_T)
+ RETURN (SCM_BOOL_T);
#else /* BUILTIN_RPASUBR */
RETURN (SCM_APPLY (proc, t.arg1,
scm_acons (arg2,
- SCM_CDR (SCM_CDR (debug.info->a.args)),
- SCM_EOL)))
+ SCM_CDDR (debug.info->a.args),
+ SCM_EOL)));
#endif /* BUILTIN_RPASUBR */
case scm_tc7_lsubr_2:
RETURN (SCM_SUBRF (proc) (t.arg1, arg2,
- SCM_CDR (SCM_CDR (debug.info->a.args))))
+ SCM_CDDR (debug.info->a.args)));
case scm_tc7_lsubr:
- RETURN (SCM_SUBRF (proc) (debug.info->a.args))
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args));
case scm_tc7_smob:
if (!SCM_SMOB_APPLICABLE_P (proc))
goto badfun;
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
debug.info->a.args,
SCM_ENV (proc));
- x = SCM_CODE (proc);
- goto nontoplevel_cdrxbegin;
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
#else /* DEVAL */
case scm_tc7_subr_3:
SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
x = SCM_CDR(x);
}
while (SCM_NIMP (x));
- RETURN (t.arg1)
+ RETURN (t.arg1);
#endif /* BUILTIN_RPASUBR */
case scm_tc7_rpsubr:
#ifdef BUILTIN_RPASUBR
if (SCM_FALSEP (SCM_SUBRF (proc) (t.arg1, arg2)))
- RETURN (SCM_BOOL_F)
+ RETURN (SCM_BOOL_F);
do
{
t.arg1 = EVALCAR (x, env);
if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, t.arg1)))
- RETURN (SCM_BOOL_F)
- arg2 = t.arg1;
+ RETURN (SCM_BOOL_F);
+ arg2 = t.arg1;
x = SCM_CDR (x);
}
while (SCM_NIMP (x));
- RETURN (SCM_BOOL_T)
+ RETURN (SCM_BOOL_T);
#else /* BUILTIN_RPASUBR */
RETURN (SCM_APPLY (proc, t.arg1,
scm_acons (arg2,
arg2,
scm_eval_args (x, env, proc)),
SCM_ENV (proc));
- x = SCM_CODE (proc);
- goto nontoplevel_cdrxbegin;
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
#endif /* DEVAL */
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
SCM *lloc;
SCM_VALIDATE_NONEMPTYLIST (1,lst);
lloc = &lst;
- while (!SCM_NULLP (SCM_CDR (*lloc)))
+ while (!SCM_NULLP (SCM_CDR (*lloc))) /* Perhaps should be
+ SCM_NULL_OR_NIL_P, but not
+ needed in 99.99% of cases,
+ and it could seriously hurt
+ performance. - Neil */
lloc = SCM_CDRLOC (*lloc);
SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
*lloc = SCM_CAR (*lloc);
*/
#if 0
-
SCM
scm_apply (SCM proc, SCM arg1, SCM args)
{}
#endif
#if 0
-
SCM
scm_dapply (SCM proc, SCM arg1, SCM args)
{ /* empty */ }
{
case scm_tc7_subr_2o:
args = SCM_NULLP (args) ? SCM_UNDEFINED : SCM_CAR (args);
- RETURN (SCM_SUBRF (proc) (arg1, args))
+ RETURN (SCM_SUBRF (proc) (arg1, args));
case scm_tc7_subr_2:
SCM_ASRTGO (!SCM_NULLP (args) && SCM_NULLP (SCM_CDR (args)),
wrongnumargs);
args = SCM_CAR (args);
- RETURN (SCM_SUBRF (proc) (arg1, args))
+ RETURN (SCM_SUBRF (proc) (arg1, args));
case scm_tc7_subr_0:
SCM_ASRTGO (SCM_UNBNDP (arg1), wrongnumargs);
- RETURN (SCM_SUBRF (proc) ())
+ RETURN (SCM_SUBRF (proc) ());
case scm_tc7_subr_1:
SCM_ASRTGO (!SCM_UNBNDP (arg1), wrongnumargs);
case scm_tc7_subr_1o:
SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
- RETURN (SCM_SUBRF (proc) (arg1))
+ RETURN (SCM_SUBRF (proc) (arg1));
case scm_tc7_cxr:
SCM_ASRTGO (!SCM_UNBNDP (arg1) && SCM_NULLP (args), wrongnumargs);
if (SCM_SUBRF (proc))
}
#ifdef SCM_BIGDIG
else if (SCM_BIGP (arg1))
- RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))))
+ RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
#endif
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc));
arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1);
}
- RETURN (arg1)
+ RETURN (arg1);
}
case scm_tc7_subr_3:
SCM_ASRTGO (!SCM_NULLP (args)
&& !SCM_NULLP (SCM_CDR (args))
&& SCM_NULLP (SCM_CDDR (args)),
wrongnumargs);
- RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CAR (SCM_CDR (args))))
+ RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args)));
case scm_tc7_lsubr:
#ifdef DEVAL
- RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args))
+ RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args));
#else
- RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)))
+ RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)));
#endif
case scm_tc7_lsubr_2:
SCM_ASRTGO (SCM_CONSP (args), wrongnumargs);
- RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args)))
+ RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args)));
case scm_tc7_asubr:
if (SCM_NULLP (args))
- RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED))
+ RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
while (SCM_NIMP (args))
{
SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG2, "apply");
}
args = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), args, SCM_ENV (proc));
- proc = SCM_CDR (SCM_CODE (proc));
+ proc = SCM_CLOSURE_BODY (proc);
again:
arg1 = proc;
while (!SCM_NULLP (arg1 = SCM_CDR (arg1)))
if (!SCM_SMOB_APPLICABLE_P (proc))
goto badproc;
if (SCM_UNBNDP (arg1))
- RETURN (SCM_SMOB_APPLY_0 (proc))
+ RETURN (SCM_SMOB_APPLY_0 (proc));
else if (SCM_NULLP (args))
- RETURN (SCM_SMOB_APPLY_1 (proc, arg1))
+ RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
else if (SCM_NULLP (SCM_CDR (args)))
- RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args)))
+ RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args)));
else
RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args)));
case scm_tc7_cclo:
{
while (SCM_NIMP (arg1))
{
- *pres = scm_cons (scm_apply (proc, SCM_CAR (arg1), scm_listofnull),
- SCM_EOL);
+ *pres = scm_list_1 (scm_apply (proc, SCM_CAR (arg1), scm_listofnull));
pres = SCM_CDRLOC (*pres);
arg1 = SCM_CDR (arg1);
}
arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
ve[i] = SCM_CDR (ve[i]);
}
- *pres = scm_cons (scm_apply (proc, arg1, SCM_EOL), SCM_EOL);
+ *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL));
pres = SCM_CDRLOC (*pres);
}
}
SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args),
SCM_ARG2, s_for_each);
SCM_VALIDATE_REST_ARGUMENT (args);
- if SCM_NULLP (args)
+ if (SCM_NULLP (args))
{
- while SCM_NIMP (arg1)
+ while (SCM_NIMP (arg1))
{
scm_apply (proc, SCM_CAR (arg1), scm_listofnull);
arg1 = SCM_CDR (arg1);
arg1 = SCM_EOL;
for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--)
{
- if SCM_IMP
- (ve[i]) return SCM_UNSPECIFIED;
+ if (SCM_IMP (ve[i]))
+ return SCM_UNSPECIFIED;
arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
ve[i] = SCM_CDR (ve[i]);
}
SCM
scm_closure (SCM code, SCM env)
{
- register SCM z;
-
- SCM_NEWCELL (z);
- SCM_SETCODE (z, code);
- SCM_SETENV (z, env);
+ SCM z;
+ SCM closcar = scm_cons (code, SCM_EOL);
+ z = scm_cell (SCM_UNPACK (closcar) + scm_tc3_closure, (scm_t_bits) env);
+ scm_remember_upto_here (closcar);
return z;
}
#define FUNC_NAME s_scm_cons_source
{
SCM p, z;
- SCM_NEWCELL (z);
- SCM_SET_CELL_OBJECT_0 (z, x);
- SCM_SET_CELL_OBJECT_1 (z, y);
+ z = scm_cons (x, y);
/* Copy source properties possibly associated with xorig. */
p = scm_whash_lookup (scm_source_whash, xorig);
if (!SCM_IMP (p))
(SCM exp, SCM module),
"Evaluate @var{exp}, a list representing a Scheme expression,\n"
"in the top-level environment specified by @var{module}.\n"
- "While @var{exp} is evaluated (using @var{primitive-eval}),\n"
+ "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
"@var{module} is made the current module. The current module\n"
"is reset to its previous value when @var{eval} returns.")
#define FUNC_NAME s_scm_eval
}
#undef FUNC_NAME
-#if (SCM_DEBUG_DEPRECATED == 0)
-
-/* Use scm_current_module () or scm_interaction_environment ()
- * instead. The former is the module selected during loading of code.
- * The latter is the module in which the user of this thread currently
- * types expressions.
- */
-
-SCM scm_top_level_lookup_closure_var;
-SCM scm_system_transformer;
-
-/* Avoid using this functionality altogether (except for implementing
- * libguile, where you can use scm_i_eval or scm_i_eval_x).
- *
- * Applications should use either C level scm_eval_x or Scheme
- * scm_eval; or scm_primitive_eval_x or scm_primitive_eval. */
-
-SCM
-scm_eval_3 (SCM obj, int copyp, SCM env)
-{
- if (copyp)
- return scm_i_eval (obj, env);
- else
- return scm_i_eval_x (obj, env);
-}
-
-SCM_DEFINE (scm_eval2, "eval2", 2, 0, 0,
- (SCM obj, SCM env_thunk),
- "Evaluate @var{exp}, a Scheme expression, in the environment\n"
- "designated by @var{lookup}, a symbol-lookup function."
- "Do not use this version of eval, it does not play well\n"
- "with the module system. Use @code{eval} or\n"
- "@code{primitive-eval} instead.")
-#define FUNC_NAME s_scm_eval2
-{
- return scm_i_eval (obj, scm_top_level_env (env_thunk));
-}
-#undef FUNC_NAME
-
-#endif /* DEPRECATED */
-
/* At this point, scm_deval and scm_dapply are generated.
*/
scm_set_smob_print (scm_tc16_promise, promise_print);
/* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */
- scm_undefineds = scm_cons (SCM_UNDEFINED, SCM_EOL);
+ scm_undefineds = scm_list_1 (SCM_UNDEFINED);
SCM_SETCDR (scm_undefineds, scm_undefineds);
- scm_listofnull = scm_cons (SCM_EOL, SCM_EOL);
+ scm_listofnull = scm_list_1 (SCM_EOL);
scm_f_apply = scm_c_define_subr ("apply", scm_tc7_lsubr_2, scm_apply);
/* acros */
/* end of acros */
-#if SCM_DEBUG_DEPRECATED == 0
- scm_top_level_lookup_closure_var =
- scm_c_define ("*top-level-lookup-closure*", scm_make_fluid ());
- scm_system_transformer =
- scm_c_define ("scm:eval-transformer", scm_make_fluid ());
-#endif
-
#ifndef SCM_MAGIC_SNARFER
#include "libguile/eval.x"
#endif
-
- scm_c_define ("nil", scm_lisp_nil);
- scm_c_define ("t", scm_lisp_t);
scm_add_feature ("delay");
}
HCoop / bpt / guile.git / blobdiff