* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
-/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
- gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
-
\f
/* This file is read twice in order to produce debugging versions of
# include <alloca.h>
# else
# ifdef _AIX
- #pragma alloca
+# pragma alloca
# else
# ifndef alloca /* predefined by HP cc +Olibcalls */
char *alloca ();
#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)) \
- ? (SCM_IMP (SCM_CAR (x)) \
- ? SCM_EVALIM (SCM_CAR (x), env) \
- : SCM_GLOC_VAL (SCM_CAR (x))) \
- : EVALCELLCAR (x, env))
+#define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
+ ? SCM_EVALIM (SCM_CAR (x), env) \
+ : EVALCELLCAR (x, env))
#define EXTEND_ENV SCM_EXTEND_ENV
tree-code instructions.
There shouldn't normally be a problem with memoizing local and
- global variable references (into ilocs and glocs), because all
+ global variable references (into ilocs and variables), because all
threads will mutate the code in *exactly* the same way and (if I
read the C code correctly) it is not possible to observe a half-way
mutated cons cell. The lookup procedure can handle this
It is different with macro expansion, because macro expansion
happens outside of the lookup procedure and can't be
- undone. Therefore it can't cope with it. It has to indicate
- failure when it detects a lost race and hope that the caller can
- handle it. Luckily, it turns out that this is the case.
+ undone. Therefore the lookup procedure can't cope with it. It has
+ to indicate failure when it detects a lost race and hope that the
+ caller can handle it. Luckily, it turns out that this is the case.
- An example to illustrate this: Suppose that the follwing form will
+ An example to illustrate this: Suppose that the following form will
be memoized concurrently by two threads
(let ((x 12)) x)
But let's see what will happen when the race occurs while looking
up the symbol "let" at the start of the form. It could happen that
the second thread interrupts the lookup of the first thread and not
- only substitutes a gloc for it but goes right ahead and replaces it
- with the compiled form (#@let* (x 12) x). Now, when the first
- thread completes its lookup, it would replace the #@let* with a
- gloc pointing to the "let" binding, effectively reverting the form
- to (let (x 12) x). This is wrong. It has to detect that it has
- lost the race and the evaluator has to reconsider the changed form
- completely.
+ only substitutes a variable for it but goes right ahead and
+ replaces it with the compiled form (#@let* (x 12) x). Now, when
+ the first thread completes its lookup, it would replace the #@let*
+ with a variable containing the "let" binding, effectively reverting
+ the form to (let (x 12) x). This is wrong. It has to detect that
+ it has lost the race and the evaluator has to reconsider the
+ changed form completely.
This race condition could be resolved with some kind of traffic
light (like mutexes) around scm_lookupcar, but I think that it is
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
al = SCM_CARLOC (env);
for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl))
{
- if (SCM_NCONSP (fl))
+ if (!SCM_CONSP (fl))
{
if (SCM_EQ_P (fl, var))
{
goto errout;
#ifndef SCM_RECKLESS
- if (SCM_NNULLP (env) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var)))
+ 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
{
completely. */
race:
var = SCM_CAR (vloc);
- if (SCM_ITAG3 (var) == scm_tc3_cons_gloc)
- return SCM_GLOC_VAL_LOC (var);
+ if (SCM_VARIABLEP (var))
+ return SCM_VARIABLE_LOC (var);
#ifdef MEMOIZE_LOCALS
if (SCM_ITAG7 (var) == SCM_ITAG7 (SCM_ILOC00))
return scm_ilookup (var, genv);
#endif
- /* We can't cope with anything else than glocs and ilocs. When
+ /* We can't cope with anything else than variables and ilocs. When
a special form has been memoized (i.e. `let' into `#@let') we
return NULL and expect the calling function to do the right
thing. For the evaluator, this means going back and redoing
}
#endif /* USE_THREADS */
- SCM_SET_CELL_WORD_0 (vloc, SCM_UNPACK (real_var) + scm_tc3_cons_gloc);
+ SCM_SETCAR (vloc, real_var);
return SCM_VARIABLE_LOC (real_var);
}
}
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_ITAG3 (c) == scm_tc3_cons_gloc)
+ else
{
- SCM sym =
- scm_module_reverse_lookup (scm_env_module (env), SCM_GLOC_VAR (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_NNULLP (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_NCONSP (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_NCONSP (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_NNULLP (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))
{
- long i = SCM_VECTOR_LENGTH (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))
+ {
+ 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_ECONSP (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);
- SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (var) + scm_tc3_cons_gloc);
+ "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
+ named by `var's (symbols, not evaluated), creating them if they
+ don't exist, executes body, and then restores the previous values of
+ the `var's. Additionally, whenever control leaves body, the values
+ of the `var's are saved and restored when control returns. It is an
+ error when a symbol appears more than once among the `var's.
+ All `exp's are evaluated before any `var' is set.
+
+ Think of this as `let' for dynamic scope.
+
+ It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
+
+ XXX - also implement `@bind*'.
+*/
+
SCM_SYNTAX (s_atbind, "@bind", scm_makmmacro, scm_m_atbind);
SCM
scm_m_atbind (SCM xorig, SCM env)
{
SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (x) > 1, scm_s_expression, "@bind");
+ SCM top_level = scm_env_top_level (env);
+ SCM vars = SCM_EOL, var;
+ SCM exps = SCM_EOL;
+
+ SCM_ASSYNT (scm_ilength (x) > 1, scm_s_expression, s_atbind);
- if (SCM_IMP (env))
- env = SCM_BOOL_F;
- else
- {
- while (SCM_NIMP (SCM_CDR (env)))
- env = SCM_CDR (env);
- env = SCM_CAR (env);
- if (SCM_CONSP (env))
- env = SCM_BOOL_F;
- }
-
x = SCM_CAR (x);
while (SCM_NIMP (x))
{
- SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_sym2var (SCM_CAR (x), env, SCM_BOOL_T)) + scm_tc3_cons_gloc);
+ SCM rest;
+ SCM sym_exp = SCM_CAR (x);
+ SCM_ASSYNT (scm_ilength (sym_exp) == 2, scm_s_bindings, 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_CAAR (rest)))
+ scm_misc_error (s_atbind, scm_s_duplicate_bindings, SCM_EOL);
+ /* 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, SCM_CDR (xorig));
+ return scm_cons (SCM_IM_BIND,
+ scm_cons (scm_cons (scm_reverse_x (vars, SCM_EOL), exps),
+ SCM_CDDR (xorig)));
}
SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_makmmacro, scm_m_at_call_with_values);
}
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;
}
return x;
SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */
- res = scm_apply (SCM_MACRO_CODE (proc), x, scm_cons (env, scm_listofnull));
+ 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_NCELLP (x) || SCM_NECONSP (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);
- /* binding names */
- f = v = SCM_CAR (x);
+ inits = scm_reverse (unmemocopy (SCM_CAR (x), env));
+ env = EXTEND_ENV (names, SCM_EOL, 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;
+ test = unmemocopy (SCM_CAR (x), env);
+ x = SCM_CDR (x);
+ 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))
+ bindings = SCM_EOL;
+ while (!SCM_NULLP (names))
{
- 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))
- {
- 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));
- if (SCM_NNULLP (env))
- SCM_SETCAR (SCM_CAR (env), scm_cons (n, SCM_CAR (SCM_CAR (env))));
+ 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_CAAR (env)));
break;
}
case SCM_BIT8(SCM_MAKISYM (0)):
env);
}
loop:
- while (SCM_CELLP (x = SCM_CDR (x)) && SCM_ECONSP (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
- if (SCM_NFALSEP (p))
+ if (!SCM_FALSEP (p))
scm_whash_insert (scm_source_whash, ls, p);
#endif
return ls;
SCM
scm_unmemocopy (SCM x, SCM env)
{
- if (SCM_NNULLP (env))
+ if (!SCM_NULLP (env))
/* Make a copy of the lowest frame to protect it from
modifications by SCM_IM_DEFINE */
return unmemocopy (x, scm_cons (SCM_CAR (env), SCM_CDR (env)));
{
while (SCM_NIMP (formals))
{
- if (SCM_NCONSP (formals))
+ if (!SCM_CONSP (formals))
return 0;
if (SCM_IMP(args))
return 1;
formals = SCM_CDR (formals);
args = SCM_CDR (args);
}
- return SCM_NNULLP (args) ? 1 : 0;
+ return !SCM_NULLP (args) ? 1 : 0;
}
+
#endif
static int
scm_eval_args (SCM l, SCM env, SCM proc)
{
SCM results = SCM_EOL, *lloc = &results, res;
- while (!SCM_IMP (l))
+ while (SCM_CONSP (l))
{
-#ifdef SCM_CAUTIOUS
- if (SCM_CONSP (l))
- {
- if (SCM_IMP (SCM_CAR (l)))
- res = SCM_EVALIM (SCM_CAR (l), env);
- else
- res = EVALCELLCAR (l, env);
- }
- else if (SCM_TYP3 (l) == scm_tc3_cons_gloc)
- {
- scm_bits_t vcell =
- SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell];
- if (vcell == 0)
- res = SCM_CAR (l); /* struct planted in code */
- else
- res = SCM_GLOC_VAL (SCM_CAR (l));
- }
- else
- goto wrongnumargs;
-#else
res = EVALCAR (l, env);
-#endif
- *lloc = scm_cons (res, SCM_EOL);
+
+ *lloc = scm_list_1 (res);
lloc = SCM_CDRLOC (*lloc);
l = SCM_CDR (l);
}
#ifdef SCM_CAUTIOUS
if (!SCM_NULLP (l))
- {
- wrongnumargs:
- scm_wrong_num_args (proc);
- }
+ scm_wrong_num_args (proc);
#endif
return results;
}
{
SCM next;
again:
- next = code;
- while (SCM_NNULLP (next = SCM_CDR (next)))
+ next = SCM_CDR (code);
+ while (!SCM_NULLP (next))
{
if (SCM_IMP (SCM_CAR (code)))
{
else
SCM_XEVAL (SCM_CAR (code), env);
code = next;
+ next = SCM_CDR (code);
}
return SCM_XEVALCAR (code, env);
}
#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
{\
SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
SCM_SET_TRACED_FRAME (debug); \
+ SCM_TRAPS_P = 0;\
if (SCM_CHEAPTRAPS_P)\
{\
tmp = scm_make_debugobj (&debug);\
- scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
+ scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
}\
else\
{\
int first;\
tmp = scm_make_continuation (&first);\
if (first)\
- scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
+ scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
}\
+ SCM_TRAPS_P = 1;\
}\
} 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
*/
#ifndef USE_THREADS
-scm_debug_frame_t *scm_last_debug_frame;
+scm_t_debug_frame *scm_last_debug_frame;
#endif
/* scm_debug_eframe_size is the number of slots available for pseudo
long scm_eval_stack;
-scm_option_t scm_eval_opts[] = {
+scm_t_option scm_eval_opts[] = {
{ SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." }
};
-scm_option_t scm_debug_opts[] = {
+scm_t_option scm_debug_opts[] = {
{ SCM_OPTION_BOOLEAN, "cheap", 1,
"*Flyweight representation of the stack at traps." },
{ SCM_OPTION_BOOLEAN, "breakpoints", 0, "*Check for breakpoints." },
{ SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." },
{ SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." },
{ SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
- { SCM_OPTION_SCM, "show-file-name", SCM_BOOL_T, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."}
+ { SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."}
};
-scm_option_t scm_evaluator_trap_table[] = {
+scm_t_option scm_evaluator_trap_table[] = {
{ SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." },
{ SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." },
{ SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." },
- { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." }
+ { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." },
+ { SCM_OPTION_SCM, "enter-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for enter-frame traps." },
+ { SCM_OPTION_SCM, "apply-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for apply-frame traps." },
+ { SCM_OPTION_SCM, "exit-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for exit-frame traps." }
};
SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0,
}
#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_IMP (l))
+ while (SCM_CONSP (l))
{
-#ifdef SCM_CAUTIOUS
- if (SCM_CONSP (l))
- {
- if (SCM_IMP (SCM_CAR (l)))
- res = SCM_EVALIM (SCM_CAR (l), env);
- else
- res = EVALCELLCAR (l, env);
- }
- else if (SCM_TYP3 (l) == scm_tc3_cons_gloc)
- {
- scm_bits_t vcell =
- SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell];
- if (vcell == 0)
- res = SCM_CAR (l); /* struct planted in code */
- else
- res = SCM_GLOC_VAL (SCM_CAR (l));
- }
- else
- goto wrongnumargs;
-#else
res = EVALCAR (l, env);
-#endif
- *lloc = scm_cons (res, SCM_EOL);
+
+ *lloc = scm_list_1 (res);
lloc = SCM_CDRLOC (*lloc);
l = SCM_CDR (l);
}
#ifdef SCM_CAUTIOUS
if (!SCM_NULLP (l))
- {
- wrongnumargs:
- scm_wrong_num_args (proc);
- }
+ scm_wrong_num_args (proc);
#endif
return *results;
}
#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 (); \
} while (0)
#ifndef DEVAL
-#define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
+#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)
{}
} t;
SCM proc, arg2, orig_sym;
#ifdef DEVAL
- scm_debug_frame_t debug;
- scm_debug_info_t *debug_info_end;
+ scm_t_debug_frame debug;
+ scm_t_debug_info *debug_info_end;
debug.prev = scm_last_debug_frame;
debug.status = scm_debug_eframe_size;
/*
- * The debug.vect contains twice as much scm_debug_info_t frames as the
+ * The debug.vect contains twice as much scm_t_debug_info frames as the
* user has specified with (debug-set! frames <n>).
*
* Even frames are eval frames, odd frames are apply frames.
*/
- debug.vect = (scm_debug_info_t *) alloca (scm_debug_eframe_size
- * sizeof (debug.vect[0]));
+ debug.vect = (scm_t_debug_info *) alloca (scm_debug_eframe_size
+ * 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. */
goto dispatch;
}
}
- scm_ithrow (scm_sym_enter_frame,
- scm_cons2 (t.arg1, tail,
- scm_cons (scm_unmemocopy (x, env), SCM_EOL)),
- 0);
+ SCM_TRAPS_P = 0;
+ scm_call_4 (SCM_ENTER_FRAME_HDLR,
+ scm_sym_enter_frame,
+ t.arg1,
+ tail,
+ scm_unmemocopy (x, env));
+ SCM_TRAPS_P = 1;
}
#endif
#if defined (USE_THREADS) || defined (DEVAL)
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_NNULLP (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_IMP (x) ? SCM_EVALIM (x, env) : SCM_GLOC_VAL (x))
+ 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_NFALSEP (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_NFALSEP (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):
switch (SCM_ITAG3 (proc))
{
case scm_tc3_cons:
- t.lloc = scm_lookupcar (x, env, 1);
- break;
- case scm_tc3_cons_gloc:
- t.lloc = SCM_GLOC_VAL_LOC (proc);
+ if (SCM_VARIABLEP (proc))
+ t.lloc = SCM_VARIABLE_LOC (proc);
+ else
+ t.lloc = scm_lookupcar (x, env, 1);
break;
#ifdef MEMOIZE_LOCALS
case scm_tc3_imm24:
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 */
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
if (SCM_IMP (proc))
arg2 = *scm_ilookup (proc, env);
- else if (SCM_NCONSP (proc))
+ else if (!SCM_CONSP (proc))
{
- if (SCM_NCELLP (proc))
- arg2 = SCM_GLOC_VAL (proc);
+ if (SCM_VARIABLEP (proc))
+ arg2 = SCM_VARIABLE_REF (proc);
else
arg2 = *scm_lookupcar (SCM_CDR (x), env, 1);
}
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)))
- {
- 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_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_NFALSEP (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)))
+ || 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_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_NFALSEP (EVALCAR (x, env))
- ? SCM_MAKINUM (1)
- : SCM_INUM0)
+#endif /* SCM_ENABLE_ELISP */
case (SCM_ISYMNUM (SCM_IM_BIND)):
- x = SCM_CDR (x);
+ {
+ SCM vars, exps, vals;
- t.arg1 = SCM_CAR (x);
- arg2 = SCM_CDAR (env);
- while (SCM_NIMP (arg2))
- {
- proc = SCM_GLOC_VAL (SCM_CAR (t.arg1));
- SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t.arg1)) - 1L),
- SCM_CAR (arg2));
- SCM_SETCAR (arg2, proc);
- t.arg1 = SCM_CDR (t.arg1);
- arg2 = SCM_CDR (arg2);
- }
- t.arg1 = SCM_CAR (x);
- scm_dynwinds = scm_acons (t.arg1, SCM_CDAR (env), scm_dynwinds);
+ x = SCM_CDR (x);
+ vars = SCM_CAAR (x);
+ exps = SCM_CDAR (x);
+
+ vals = SCM_EOL;
+
+ while (SCM_NIMP (exps))
+ {
+ vals = scm_cons (EVALCAR (exps, env), vals);
+ exps = SCM_CDR (exps);
+ }
+
+ scm_swap_bindings (vars, vals);
+ scm_dynwinds = scm_acons (vars, vals, scm_dynwinds);
- arg2 = x = SCM_CDR (x);
- while (SCM_NNULLP (arg2 = SCM_CDR (arg2)))
- {
- SIDEVAL (SCM_CAR (x), env);
- x = arg2;
- }
- proc = EVALCAR (x, env);
+ arg2 = x = SCM_CDR (x);
+ while (!SCM_NULLP (arg2 = SCM_CDR (arg2)))
+ {
+ SIDEVAL (SCM_CAR (x), env);
+ x = arg2;
+ }
+ proc = EVALCAR (x, env);
- scm_dynwinds = SCM_CDR (scm_dynwinds);
- arg2 = SCM_CDAR (env);
- while (SCM_NIMP (arg2))
- {
- SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t.arg1)) - 1L),
- SCM_CAR (arg2));
- t.arg1 = SCM_CDR (t.arg1);
- arg2 = SCM_CDR (arg2);
- }
+ 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_LIST1 (proc));
+ scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc));
case scm_tc7_vector:
case scm_tc7_wvect:
#ifdef HAVE_ARRAYS
#endif
#endif
case scm_tc7_string:
- case scm_tc7_substring:
case scm_tc7_smob:
case scm_tcs_closures:
case scm_tc7_cclo:
case scm_tc7_pws:
case scm_tcs_subrs:
+ case scm_tcs_struct:
RETURN (x);
+ case scm_tc7_variable:
+ RETURN (SCM_VARIABLE_REF(x));
+
#ifdef MEMOIZE_LOCALS
case SCM_BIT8(SCM_ILOC00):
proc = *scm_ilookup (SCM_CAR (x), env);
#endif
break;
#endif /* ifdef MEMOIZE_LOCALS */
-
-
- case scm_tcs_cons_gloc: {
- scm_bits_t vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell];
- if (vcell == 0) {
- /* This is a struct implanted in the code, not a gloc. */
- RETURN (x);
- } else {
- proc = SCM_GLOC_VAL (SCM_CAR (x));
- SCM_ASRTGO (SCM_NIMP (proc), badfun);
-#ifndef SCM_RECKLESS
-#ifdef SCM_CAUTIOUS
- goto checkargs;
-#endif
-#endif
- }
- break;
- }
-
+
case scm_tcs_cons_nimcar:
orig_sym = SCM_CAR (x);
if (SCM_SYMBOLP (orig_sym))
{
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;
- case scm_tcs_cons_gloc: /* really structs, not glocs */
+ goto nontoplevel_begin;
+ case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
x = SCM_ENTITY_PROCEDURE (proc);
: 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 */
else
t.arg1 = EVALCELLCAR (x, env);
}
- else if (SCM_TYP3 (x) == scm_tc3_cons_gloc)
- {
- scm_bits_t vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell];
- if (vcell == 0)
- t.arg1 = SCM_CAR (x); /* struct planted in code */
- else
- t.arg1 = SCM_GLOC_VAL (SCM_CAR (x));
- }
else
goto wrongnumargs;
#else
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_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (t.arg1))));
}
- SCM_ASRTGO (SCM_NIMP (t.arg1), floerr);
- if (SCM_REALP (t.arg1))
+ else if (SCM_REALP (t.arg1))
{
RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (t.arg1))));
}
#ifdef SCM_BIGDIG
- if (SCM_BIGP (t.arg1))
+ else if (SCM_BIGP (t.arg1))
{
RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (t.arg1))));
}
#endif
- floerr:
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), t.arg1,
SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
}
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;
- case scm_tcs_cons_gloc: /* really structs, not glocs */
+ goto nontoplevel_begin;
+ case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
x = SCM_ENTITY_PROCEDURE (proc);
#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;
}
else
arg2 = EVALCELLCAR (x, env);
}
- else if (SCM_TYP3 (x) == scm_tc3_cons_gloc)
- {
- scm_bits_t vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell];
- if (vcell == 0)
- arg2 = SCM_CAR (x); /* struct planted in code */
- else
- arg2 = SCM_GLOC_VAL (SCM_CAR (x));
- }
else
goto wrongnumargs;
#else
#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));
proc))),
SCM_EOL));
#endif
- case scm_tcs_cons_gloc: /* really structs, not glocs */
+ case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
x = SCM_ENTITY_PROCEDURE (proc);
#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
- if (SCM_IMP (x) || SCM_NECONSP (x))
+ if (SCM_IMP (x) || !SCM_CONSP (x))
goto wrongnumargs;
#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_cons_gloc: /* really structs, not glocs */
+ case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
#ifdef DEVAL
goto ret;
}
}
- scm_ithrow (scm_sym_exit_frame, scm_cons2 (t.arg1, proc, SCM_EOL), 0);
+ SCM_TRAPS_P = 0;
+ scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, t.arg1, proc);
+ SCM_TRAPS_P = 1;
}
ret:
scm_last_debug_frame = debug.prev;
#ifndef DEVAL
+\f
+/* Simple procedure calls
+ */
+
+SCM
+scm_call_0 (SCM proc)
+{
+ return scm_apply (proc, SCM_EOL, SCM_EOL);
+}
+
+SCM
+scm_call_1 (SCM proc, SCM arg1)
+{
+ return scm_apply (proc, arg1, scm_listofnull);
+}
+
+SCM
+scm_call_2 (SCM proc, SCM arg1, SCM arg2)
+{
+ return scm_apply (proc, arg1, scm_cons (arg2, scm_listofnull));
+}
+
+SCM
+scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
+{
+ return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, scm_listofnull));
+}
+
+SCM
+scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
+{
+ return scm_apply (proc, arg1, scm_cons2 (arg2, arg3,
+ scm_cons (arg4, scm_listofnull)));
+}
+
+/* Simple procedure applies
+ */
+
+SCM
+scm_apply_0 (SCM proc, SCM args)
+{
+ return scm_apply (proc, args, SCM_EOL);
+}
+
+SCM
+scm_apply_1 (SCM proc, SCM arg1, SCM args)
+{
+ return scm_apply (proc, scm_cons (arg1, args), SCM_EOL);
+}
+
+SCM
+scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args)
+{
+ return scm_apply (proc, scm_cons2 (arg1, arg2, args), SCM_EOL);
+}
+
+SCM
+scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args)
+{
+ return scm_apply (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)),
+ SCM_EOL);
+}
+
/* This code processes the arguments to apply:
(apply PROC ARG1 ... ARGS)
SCM *lloc;
SCM_VALIDATE_NONEMPTYLIST (1,lst);
lloc = &lst;
- while (SCM_NNULLP (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 */ }
{
#ifdef DEBUG_EXTENSIONS
#ifdef DEVAL
- scm_debug_frame_t debug;
- scm_debug_info_t debug_vect_body;
+ scm_t_debug_frame debug;
+ scm_t_debug_info debug_vect_body;
debug.prev = scm_last_debug_frame;
debug.status = SCM_APPLYFRAME;
debug.vect = &debug_vect_body;
if (!first)
goto entap;
}
- scm_ithrow (scm_sym_enter_frame, scm_cons (tmp, SCM_EOL), 0);
+ SCM_TRAPS_P = 0;
+ scm_call_2 (SCM_ENTER_FRAME_HDLR, scm_sym_enter_frame, tmp);
+ SCM_TRAPS_P = 1;
}
entap:
ENTER_APPLY;
{
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_NNULLP (args) && SCM_NULLP (SCM_CDR (args)),
+ 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))
{
RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1))));
}
- SCM_ASRTGO (SCM_NIMP (arg1), floerr);
- if (SCM_REALP (arg1))
+ else if (SCM_REALP (arg1))
{
RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
}
#ifdef SCM_BIGDIG
- if (SCM_BIGP (arg1))
- RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))))
+ else if (SCM_BIGP (arg1))
+ RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
#endif
- floerr:
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_NNULLP (args)
- && SCM_NNULLP (SCM_CDR (args))
+ 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_NNULLP (arg1 = SCM_CDR (arg1)))
+ while (!SCM_NULLP (arg1 = SCM_CDR (arg1)))
{
if (SCM_IMP (SCM_CAR (proc)))
{
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:
debug.vect[0].a.proc = proc;
#endif
goto tail;
- case scm_tcs_cons_gloc: /* really structs, not glocs */
+ case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
#ifdef DEVAL
goto ret;
}
}
- scm_ithrow (scm_sym_exit_frame, scm_cons2 (arg1, proc, SCM_EOL), 0);
+ SCM_TRAPS_P = 0;
+ scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
+ SCM_TRAPS_P = 1;
}
ret:
scm_last_debug_frame = debug.prev;
{
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;
}
-scm_bits_t scm_tc16_promise;
+scm_t_bits scm_tc16_promise;
SCM
scm_makprom (SCM code)
SCM_VALIDATE_SMOB (1, x, promise);
if (!((1L << 16) & SCM_CELL_WORD_0 (x)))
{
- SCM ans = scm_apply (SCM_CELL_OBJECT_1 (x), SCM_EOL, SCM_EOL);
+ SCM ans = scm_call_0 (SCM_CELL_OBJECT_1 (x));
if (!((1L << 16) & SCM_CELL_WORD_0 (x)))
{
SCM_DEFER_INTS;
#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_VELTS (ans)[i] = scm_copy_tree (SCM_VELTS (obj)[i]);
return ans;
}
- if (SCM_NCONSP (obj))
+ if (!SCM_CONSP (obj))
return obj;
ans = tl = scm_cons_source (obj,
scm_copy_tree (SCM_CAR (obj)),
SCM env;
SCM transformer = scm_current_module_transformer ();
if (SCM_NIMP (transformer))
- exp = scm_apply (transformer, exp, scm_listofnull);
+ exp = scm_call_1 (transformer, exp);
env = scm_top_level_env (scm_current_module_lookup_closure ());
return scm_i_eval_x (exp, env);
}
SCM env;
SCM transformer = scm_current_module_transformer ();
if (SCM_NIMP (transformer))
- exp = scm_apply (transformer, exp, scm_listofnull);
+ exp = scm_call_1 (transformer, exp);
env = scm_top_level_env (scm_current_module_lookup_closure ());
return scm_i_eval (exp, env);
}
(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