-/* Copyright (C) 1995, 96, 97, 98, 99, 2000 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* marked with the string "SECTION:".
*/
-
/* SECTION: This code is compiled once.
*/
# include <alloca.h>
# else
# ifdef _AIX
- #pragma alloca
+# pragma alloca
# else
# ifndef alloca /* predefined by HP cc +Olibcalls */
char *alloca ();
# endif
#endif
-#include <stdio.h>
#include "libguile/_scm.h"
#include "libguile/debug.h"
+#include "libguile/dynwind.h"
#include "libguile/alist.h"
#include "libguile/eq.h"
#include "libguile/continuations.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/vectors.h"
+#include "libguile/fluids.h"
+#include "libguile/values.h"
#include "libguile/validate.h"
#include "libguile/eval.h"
-SCM (*scm_memoize_method) (SCM, SCM);
+\f
+
+#define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
+ do { \
+ if (SCM_EQ_P ((x), SCM_EOL)) \
+ scm_misc_error (NULL, scm_s_expression, SCM_EOL); \
+ } while (0)
\f
? *scm_lookupcar (x, env, 1) \
: SCM_CEVAL (SCM_CAR (x), env))
-#define EVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \
+#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))) \
SCM *
scm_ilookup (SCM iloc, SCM env)
{
- register int ir = SCM_IFRAME (iloc);
+ register long ir = SCM_IFRAME (iloc);
register SCM er = env;
for (; 0 != ir; --ir)
er = SCM_CDR (er);
{
SCM env = genv;
register SCM *al, fl, var = SCM_CAR (vloc);
-#ifdef USE_THREADS
- register SCM var2 = var;
-#endif
#ifdef MEMOIZE_LOCALS
register SCM iloc = SCM_ILOC00;
#endif
}
#endif
#ifdef USE_THREADS
- if (SCM_CAR (vloc) != var)
+ if (!SCM_EQ_P (SCM_CAR (vloc), var))
goto race;
#endif
SCM_SETCAR (vloc, iloc);
#endif
}
{
- SCM top_thunk, vcell;
+ SCM top_thunk, real_var;
if (SCM_NIMP (env))
{
- top_thunk = SCM_CAR (env); /* env now refers to a top level env thunk */
+ top_thunk = SCM_CAR (env); /* env now refers to a
+ top level env thunk */
env = SCM_CDR (env);
}
else
top_thunk = SCM_BOOL_F;
- vcell = scm_sym2vcell (var, top_thunk, SCM_BOOL_F);
- if (SCM_FALSEP (vcell))
+ real_var = scm_sym2var (var, top_thunk, SCM_BOOL_F);
+ if (SCM_FALSEP (real_var))
goto errout;
- else
- var = vcell;
- }
+
#ifndef SCM_RECKLESS
- if (SCM_NNULLP (env) || SCM_UNBNDP (SCM_CDR (var)))
- {
- var = SCM_CAR (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);
- else
- scm_misc_error (NULL, "Damaged environment: ~S",
- scm_cons (var, SCM_EOL));
- }
- else {
- /* A variable could not be found, but we shall not throw an error. */
- static SCM undef_object = SCM_UNDEFINED;
- return &undef_object;
+ if (SCM_NNULLP (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);
+ else
+ scm_misc_error (NULL, "Damaged environment: ~S",
+ scm_cons (var, SCM_EOL));
+ }
+ else
+ {
+ /* A variable could not be found, but we shall
+ not throw an error. */
+ static SCM undef_object = SCM_UNDEFINED;
+ return &undef_object;
+ }
}
- }
#endif
+
#ifdef USE_THREADS
- if (SCM_CAR (vloc) != var2)
- {
- /* Some other thread has changed the very cell we are working
- on. In effect, it must have done our job or messed it up
- completely. */
- race:
- var = SCM_CAR (vloc);
- if (SCM_ITAG3 (var) == scm_tc3_cons_gloc)
- return SCM_GLOC_VAL_LOC (var);
+ if (!SCM_EQ_P (SCM_CAR (vloc), var))
+ {
+ /* Some other thread has changed the very cell we are working
+ on. In effect, it must have done our job or messed it up
+ completely. */
+ race:
+ var = SCM_CAR (vloc);
+ if (SCM_ITAG3 (var) == scm_tc3_cons_gloc)
+ return SCM_GLOC_VAL_LOC (var);
#ifdef MEMOIZE_LOCALS
- if ((SCM_UNPACK (var) & 127) == (127 & SCM_UNPACK (SCM_ILOC00)))
- return scm_ilookup (var, genv);
-#endif
- /* We can't cope with anything else than glocs 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
- the dispatch on the car of the form. */
- return NULL;
- }
+ 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
+ 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
+ the dispatch on the car of the form. */
+ return NULL;
+ }
#endif /* USE_THREADS */
- SCM_SET_CELL_WORD_0 (vloc, SCM_UNPACK (var) + scm_tc3_cons_gloc);
- /* Except wait...what if the var is not a vcell,
- * but syntax or something.... */
- return SCM_CDRLOC (var);
+ SCM_SET_CELL_WORD_0 (vloc, SCM_UNPACK (real_var) + scm_tc3_cons_gloc);
+ return SCM_VARIABLE_LOC (real_var);
+ }
}
#ifdef USE_THREADS
#define unmemocar scm_unmemocar
+SCM_SYMBOL (sym_three_question_marks, "???");
+
SCM
scm_unmemocar (SCM form, SCM env)
{
return form;
c = SCM_CAR (form);
if (SCM_ITAG3 (c) == scm_tc3_cons_gloc)
- SCM_SETCAR (form, SCM_GLOC_SYM (c));
+ {
+ 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);
+ }
#ifdef MEMOIZE_LOCALS
#ifdef DEBUG_EXTENSIONS
else if (SCM_ILOCP (c))
{
- int ir;
+ long ir;
for (ir = SCM_IFRAME (c); ir != 0; --ir)
env = SCM_CDR (env);
const char scm_s_test[] = "bad test";
const char scm_s_body[] = "bad body";
const char scm_s_bindings[] = "bad bindings";
+const char scm_s_duplicate_bindings[] = "duplicate bindings";
const char scm_s_variable[] = "bad variable";
const char scm_s_clauses[] = "bad or missing clauses";
const char scm_s_formals[] = "bad formals";
+const char scm_s_duplicate_formals[] = "duplicate formals";
-SCM scm_sym_dot, scm_sym_arrow, scm_sym_else;
-SCM scm_sym_unquote, scm_sym_uq_splicing, scm_sym_apply;
+SCM_GLOBAL_SYMBOL (scm_sym_dot, ".");
+SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
+SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
+SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
+SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
SCM scm_f_apply;
#ifdef DEBUG_EXTENSIONS
-SCM scm_sym_enter_frame, scm_sym_apply_frame, scm_sym_exit_frame;
-SCM scm_sym_trace;
+SCM_GLOBAL_SYMBOL (scm_sym_enter_frame, "enter-frame");
+SCM_GLOBAL_SYMBOL (scm_sym_apply_frame, "apply-frame");
+SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "exit-frame");
+SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace");
#endif
static SCM
scm_m_body (SCM op, SCM xorig, const char *what)
{
- SCM_ASSYNT (scm_ilength (xorig) >= 1, xorig, scm_s_expression, what);
+ SCM_ASSYNT (scm_ilength (xorig) >= 1, scm_s_expression, what);
/* Don't add another ISYM if one is present already. */
if (SCM_ISYMP (SCM_CAR (xorig)))
SCM_GLOBAL_SYMBOL(scm_sym_quote, s_quote);
SCM
-scm_m_quote (SCM xorig, SCM env)
+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,
- xorig, scm_s_expression, s_quote);
+ SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, s_quote);
return scm_cons (SCM_IM_QUOTE, x);
}
SCM_GLOBAL_SYMBOL(scm_sym_begin, s_begin);
SCM
-scm_m_begin (SCM xorig, SCM env)
+scm_m_begin (SCM xorig, SCM env SCM_UNUSED)
{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 1,
- xorig, scm_s_expression, s_begin);
+ SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 1, scm_s_expression, s_begin);
return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig));
}
SCM_GLOBAL_SYMBOL(scm_sym_if, s_if);
SCM
-scm_m_if (SCM xorig, SCM env)
+scm_m_if (SCM xorig, SCM env SCM_UNUSED)
{
- int len = scm_ilength (SCM_CDR (xorig));
- SCM_ASSYNT (len >= 2 && len <= 3, xorig, scm_s_expression, "if");
+ long len = scm_ilength (SCM_CDR (xorig));
+ SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, "if");
return scm_cons (SCM_IM_IF, SCM_CDR (xorig));
}
SCM_GLOBAL_SYMBOL(scm_sym_set_x, scm_s_set_x);
SCM
-scm_m_set_x (SCM xorig, SCM env)
+scm_m_set_x (SCM xorig, SCM env SCM_UNUSED)
{
SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (2 == scm_ilength (x), xorig, scm_s_expression, scm_s_set_x);
- SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)),
- xorig, scm_s_variable, scm_s_set_x);
+ SCM_ASSYNT (2 == scm_ilength (x), 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);
}
-#if 0
-
-SCM
-scm_m_vref (SCM xorig, SCM env)
-{
- SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (1 == scm_ilength (x), xorig, scm_s_expression, s_vref);
- if (SCM_NIMP(x) && UDSCM_VARIABLEP (SCM_CAR (x)))
- {
- /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
- scm_misc_error (NULL,
- "Bad variable: ~S",
- scm_listify (SCM_CAR (SCM_CDR (x)), SCM_UNDEFINED));
- }
- SCM_ASSYNT (SCM_NIMP(x) && DEFSCM_VARIABLEP (SCM_CAR (x)),
- xorig, scm_s_variable, s_vref);
- return scm_cons (IM_VREF, x);
-}
-
-
-
-SCM
-scm_m_vset (SCM xorig, SCM env)
-{
- SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (3 == scm_ilength (x), xorig, scm_s_expression, s_vset);
- SCM_ASSYNT ((DEFSCM_VARIABLEP (SCM_CAR (x))
- || UDSCM_VARIABLEP (SCM_CAR (x))),
- xorig, scm_s_variable, s_vset);
- return scm_cons (IM_VSET, x);
-}
-#endif
-
-
SCM_SYNTAX(s_and, "and", scm_makmmacro, scm_m_and);
SCM_GLOBAL_SYMBOL(scm_sym_and, s_and);
SCM
-scm_m_and (SCM xorig, SCM env)
+scm_m_and (SCM xorig, SCM env SCM_UNUSED)
{
- int len = scm_ilength (SCM_CDR (xorig));
- SCM_ASSYNT (len >= 0, xorig, scm_s_test, s_and);
+ long len = scm_ilength (SCM_CDR (xorig));
+ SCM_ASSYNT (len >= 0, scm_s_test, s_and);
if (len >= 1)
return scm_cons (SCM_IM_AND, SCM_CDR (xorig));
else
SCM_GLOBAL_SYMBOL(scm_sym_or,s_or);
SCM
-scm_m_or (SCM xorig, SCM env)
+scm_m_or (SCM xorig, SCM env SCM_UNUSED)
{
- int len = scm_ilength (SCM_CDR (xorig));
- SCM_ASSYNT (len >= 0, xorig, scm_s_test, s_or);
+ long len = scm_ilength (SCM_CDR (xorig));
+ SCM_ASSYNT (len >= 0, scm_s_test, s_or);
if (len >= 1)
return scm_cons (SCM_IM_OR, SCM_CDR (xorig));
else
SCM_GLOBAL_SYMBOL(scm_sym_case, s_case);
SCM
-scm_m_case (SCM xorig, SCM env)
+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, xorig, scm_s_clauses, s_case);
+ SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_clauses, s_case);
while (SCM_NIMP (x = SCM_CDR (x)))
{
proc = SCM_CAR (x);
- SCM_ASSYNT (scm_ilength (proc) >= 2, xorig, scm_s_clauses, s_case);
+ 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)),
- xorig, scm_s_clauses, s_case);
+ || (SCM_EQ_P (scm_sym_else, SCM_CAR (proc))
+ && SCM_NULLP (SCM_CDR (x))),
+ scm_s_clauses, s_case);
}
return scm_cons (SCM_IM_CASE, cdrx);
}
SCM
-scm_m_cond (SCM xorig, SCM env)
+scm_m_cond (SCM xorig, SCM env SCM_UNUSED)
{
SCM arg1, cdrx = scm_list_copy (SCM_CDR (xorig)), x = cdrx;
- int len = scm_ilength (x);
- SCM_ASSYNT (len >= 1, xorig, scm_s_clauses, s_cond);
+ long len = scm_ilength (x);
+ SCM_ASSYNT (len >= 1, scm_s_clauses, s_cond);
while (SCM_NIMP (x))
{
arg1 = SCM_CAR (x);
len = scm_ilength (arg1);
- SCM_ASSYNT (len >= 1, xorig, scm_s_clauses, s_cond);
+ SCM_ASSYNT (len >= 1, scm_s_clauses, s_cond);
if (SCM_EQ_P (scm_sym_else, SCM_CAR (arg1)))
{
SCM_ASSYNT (SCM_NULLP (SCM_CDR (x)) && len >= 2,
- xorig, "bad ELSE clause", s_cond);
+ "bad ELSE clause", s_cond);
SCM_SETCAR (arg1, SCM_BOOL_T);
}
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)))),
- xorig, "bad recipient", s_cond);
+ "bad recipient", s_cond);
x = SCM_CDR (x);
}
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.) */
+
+static int
+scm_c_improper_memq (SCM obj, SCM list)
+{
+ for (; SCM_CONSP (list); list = SCM_CDR (list))
+ {
+ if (SCM_EQ_P (SCM_CAR (list), obj))
+ return 1;
+ }
+ return SCM_EQ_P (list, obj);
+}
+
SCM
-scm_m_lambda (SCM xorig, SCM env)
+scm_m_lambda (SCM xorig, SCM env SCM_UNUSED)
{
SCM proc, x = SCM_CDR (xorig);
if (scm_ilength (x) < 2)
}
if (!SCM_SYMBOLP (SCM_CAR (proc)))
goto badforms;
+ else if (scm_c_improper_memq (SCM_CAR(proc), SCM_CDR(proc)))
+ scm_misc_error (s_lambda, scm_s_duplicate_formals, SCM_EOL);
proc = SCM_CDR (proc);
}
if (SCM_NNULLP (proc))
{
badforms:
- scm_wta (xorig, scm_s_formals, s_lambda);
+ scm_misc_error (s_lambda, scm_s_formals, SCM_EOL);
}
memlambda:
SCM
-scm_m_letstar (SCM xorig, SCM env)
+scm_m_letstar (SCM xorig, SCM env SCM_UNUSED)
{
SCM x = SCM_CDR (xorig), arg1, proc, vars = SCM_EOL, *varloc = &vars;
- int len = scm_ilength (x);
- SCM_ASSYNT (len >= 2, xorig, scm_s_body, s_letstar);
+ long len = scm_ilength (x);
+ SCM_ASSYNT (len >= 2, scm_s_body, s_letstar);
proc = SCM_CAR (x);
- SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, scm_s_bindings, s_letstar);
+ SCM_ASSYNT (scm_ilength (proc) >= 0, scm_s_bindings, s_letstar);
while (SCM_NIMP (proc))
{
arg1 = SCM_CAR (proc);
- SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, s_letstar);
- SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, s_letstar);
+ 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);
varloc = SCM_CDRLOC (SCM_CDR (*varloc));
proc = SCM_CDR (proc);
SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
SCM
-scm_m_do (SCM xorig, SCM env)
+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;
- int len = scm_ilength (x);
- SCM_ASSYNT (len >= 2, xorig, scm_s_test, "do");
+ long len = scm_ilength (x);
+ SCM_ASSYNT (len >= 2, scm_s_test, "do");
proc = SCM_CAR (x);
- SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, scm_s_bindings, "do");
+ SCM_ASSYNT (scm_ilength (proc) >= 0, scm_s_bindings, "do");
while (SCM_NIMP(proc))
{
arg1 = SCM_CAR (proc);
len = scm_ilength (arg1);
- SCM_ASSYNT (2 == len || 3 == len, xorig, scm_s_bindings, "do");
- SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, "do");
+ 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);
proc = SCM_CDR (proc);
}
x = SCM_CDR (x);
- SCM_ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, xorig, scm_s_test, "do");
+ SCM_ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, scm_s_test, "do");
x = scm_cons2 (SCM_CAR (x), SCM_CDR (x), steps);
x = scm_cons2 (vars, inits, x);
return scm_cons (SCM_IM_DO, x);
#define evalcar scm_eval_car
-static SCM iqq (SCM form, SCM env, int depth);
+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_m_quasiquote (SCM xorig, SCM env)
{
SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (x) == 1, xorig, scm_s_expression, s_quasiquote);
+ SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_quasiquote);
return iqq (SCM_CAR (x), env, 1);
}
static SCM
-iqq (SCM form,SCM env,int depth)
+iqq (SCM form, SCM env, long depth)
{
SCM tmp;
- int edepth = depth;
- if (SCM_IMP(form))
+ long edepth = depth;
+ if (SCM_IMP (form))
return form;
if (SCM_VECTORP (form))
{
- long i = SCM_LENGTH (form);
+ long i = SCM_VECTOR_LENGTH (form);
SCM *data = SCM_VELTS (form);
tmp = SCM_EOL;
for (; --i >= 0;)
tmp = scm_cons (data[i], tmp);
return scm_vector (iqq (tmp, env, depth));
}
- if (SCM_NCONSP(form))
+ if (!SCM_CONSP (form))
return form;
tmp = SCM_CAR (form);
if (SCM_EQ_P (scm_sym_quasiquote, tmp))
return evalcar (form, env);
return scm_cons2 (tmp, iqq (SCM_CAR (form), env, depth), SCM_EOL);
}
- if (SCM_NIMP (tmp) && (SCM_EQ_P (scm_sym_uq_splicing, SCM_CAR (tmp))))
+ if (SCM_CONSP (tmp) && (SCM_EQ_P (scm_sym_uq_splicing, SCM_CAR (tmp))))
{
tmp = SCM_CDR (tmp);
if (0 == --edepth)
SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
SCM
-scm_m_delay (SCM xorig, SCM env)
+scm_m_delay (SCM xorig, SCM env SCM_UNUSED)
{
- SCM_ASSYNT (scm_ilength (xorig) == 2, xorig, scm_s_expression, s_delay);
+ SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_delay);
return scm_cons2 (SCM_IM_DELAY, SCM_EOL, SCM_CDR (xorig));
}
{
SCM proc, arg1 = x;
x = SCM_CDR (x);
- /* SCM_ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/
- SCM_ASSYNT (scm_ilength (x) >= 2, arg1, scm_s_expression, s_define);
+ SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_expression, s_define);
proc = SCM_CAR (x);
x = SCM_CDR (x);
while (SCM_CONSP (proc))
x = scm_cons (scm_cons2 (scm_sym_lambda, SCM_CDR (proc), x), SCM_EOL);
proc = SCM_CAR (proc);
}
- SCM_ASSYNT (SCM_SYMBOLP (proc),
- arg1, scm_s_variable, s_define);
- SCM_ASSYNT (1 == scm_ilength (x), arg1, scm_s_expression, s_define);
+ SCM_ASSYNT (SCM_SYMBOLP (proc), scm_s_variable, s_define);
+ SCM_ASSYNT (1 == scm_ilength (x), scm_s_expression, s_define);
if (SCM_TOP_LEVEL (env))
{
x = evalcar (x, env);
/* 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_TYP16 (arg1) == scm_tc16_macro
- && !SCM_EQ_P (SCM_CDR (arg1), arg1))
+ else if (SCM_MACROP (arg1)
+ /* Dirk::FIXME: Does the following test make sense? */
+ && !SCM_EQ_P (SCM_MACRO_CODE (arg1), arg1))
{
- arg1 = SCM_CDR (arg1);
+ arg1 = SCM_MACRO_CODE (arg1);
goto proc;
}
}
#endif
- arg1 = scm_sym2vcell (proc, scm_env_top_level (env), SCM_BOOL_T);
-#if 0
-#ifndef SCM_RECKLESS
- if (SCM_NIMP (SCM_CDR (arg1)) && (SCM_SNAME (SCM_CDR (arg1)) == proc)
- && (SCM_CDR (arg1) != x))
- scm_warn ("redefining built-in ", SCM_CHARS (proc));
- else
-#endif
- if (5 <= scm_verbose && SCM_UNDEFINED != SCM_CDR (arg1))
- scm_warn ("redefining ", SCM_CHARS (proc));
-#endif
- SCM_SETCDR (arg1, x);
+ 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, SCM_CAR (arg1), SCM_EOL);
+ return scm_cons2 (scm_sym_quote, proc, SCM_EOL);
#else
return SCM_UNSPECIFIED;
#endif
/* end of acros */
static SCM
-scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env)
+scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env SCM_UNUSED)
{
SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */
- char *what = SCM_CHARS (SCM_CAR (xorig));
+ char *what = SCM_SYMBOL_CHARS (SCM_CAR (xorig));
SCM x = cdrx, proc, arg1; /* structure traversers */
SCM vars = SCM_EOL, inits = SCM_EOL, *initloc = &inits;
proc = SCM_CAR (x);
- SCM_ASSYNT (scm_ilength (proc) >= 1, xorig, scm_s_bindings, what);
+ 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), xorig, scm_s_bindings, what);
- SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), xorig, scm_s_variable, what);
+ 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_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);
initloc = SCM_CDRLOC (*initloc);
scm_m_letrec (SCM xorig, SCM env)
{
SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_letrec);
+ SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_body, s_letrec);
if (SCM_NULLP (SCM_CAR (x))) /* null binding, let* faster */
return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), SCM_EOL,
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, xorig, scm_s_body, s_let);
+ SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_body, s_let);
proc = SCM_CAR (x);
if (SCM_NULLP (proc)
|| (SCM_CONSP (proc)
env);
}
- SCM_ASSYNT (SCM_NIMP (proc), xorig, scm_s_bindings, s_let);
- if (SCM_CONSP (proc))
+ SCM_ASSYNT (SCM_NIMP (proc), scm_s_bindings, s_let);
+ if (SCM_CONSP (proc))
{
/* plain let, proc is <bindings> */
return scm_m_letrec1 (SCM_IM_LET, SCM_IM_LET, xorig, env);
}
if (!SCM_SYMBOLP (proc))
- scm_wta (xorig, scm_s_bindings, s_let); /* bad let */
+ 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, xorig, scm_s_body, s_let);
+ SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_body, s_let);
proc = SCM_CAR (x); /* bindings list */
- SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, scm_s_bindings, s_let);
+ 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), xorig, scm_s_bindings, s_let);
- SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)),
- xorig, scm_s_variable, s_let);
+ 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);
SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);
SCM
-scm_m_apply (SCM xorig, SCM env)
+scm_m_apply (SCM xorig, SCM env SCM_UNUSED)
{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2,
- xorig, scm_s_expression, s_atapply);
+ SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, scm_s_expression, s_atapply);
return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig));
}
SCM
-scm_m_cont (SCM xorig, SCM env)
+scm_m_cont (SCM xorig, SCM env SCM_UNUSED)
{
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
- xorig, scm_s_expression, s_atcall_cc);
+ scm_s_expression, s_atcall_cc);
return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));
}
/* Multi-language support */
-SCM scm_lisp_nil;
-SCM scm_lisp_t;
+SCM_GLOBAL_SYMBOL (scm_lisp_nil, "nil");
+SCM_GLOBAL_SYMBOL (scm_lisp_t, "t");
SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond);
SCM
-scm_m_nil_cond (SCM xorig, SCM env)
+scm_m_nil_cond (SCM xorig, SCM env SCM_UNUSED)
{
- int len = scm_ilength (SCM_CDR (xorig));
- SCM_ASSYNT (len >= 1 && (len & 1) == 1, xorig,
- scm_s_expression, "nil-cond");
+ long len = scm_ilength (SCM_CDR (xorig));
+ SCM_ASSYNT (len >= 1 && (len & 1) == 1, scm_s_expression, "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_m_nil_ify (SCM xorig, SCM env SCM_UNUSED)
{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
- xorig, scm_s_expression, "nil-ify");
+ 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_m_t_ify (SCM xorig, SCM env SCM_UNUSED)
{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
- xorig, scm_s_expression, "t-ify");
+ 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_m_0_cond (SCM xorig, SCM env SCM_UNUSED)
{
- int len = scm_ilength (SCM_CDR (xorig));
- SCM_ASSYNT (len >= 1 && (len & 1) == 1, xorig,
- scm_s_expression, "0-cond");
+ 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_m_0_ify (SCM xorig, SCM env SCM_UNUSED)
{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
- xorig, scm_s_expression, "0-ify");
+ 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_m_1_ify (SCM xorig, SCM env SCM_UNUSED)
{
- SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
- xorig, scm_s_expression, "1-ify");
+ 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_m_atfop (SCM xorig, SCM env)
+scm_m_atfop (SCM xorig, SCM env SCM_UNUSED)
{
- SCM x = SCM_CDR (xorig), vcell;
- SCM_ASSYNT (scm_ilength (x) >= 1, xorig, scm_s_expression, "@fop");
- vcell = scm_symbol_fref (SCM_CAR (x));
- SCM_ASSYNT (SCM_CONSP (vcell), x,
+ SCM x = SCM_CDR (xorig), var;
+ SCM_ASSYNT (scm_ilength (x) >= 1, scm_s_expression, "@fop");
+ var = scm_symbol_fref (SCM_CAR (x));
+ SCM_ASSYNT (SCM_VARIABLEP (var),
"Symbol's function definition is void", NULL);
- SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (vcell) + scm_tc3_cons_gloc);
+ SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (var) + scm_tc3_cons_gloc);
return x;
}
scm_m_atbind (SCM xorig, SCM env)
{
SCM x = SCM_CDR (xorig);
- SCM_ASSYNT (scm_ilength (x) > 1, xorig, scm_s_expression, "@bind");
+ SCM_ASSYNT (scm_ilength (x) > 1, scm_s_expression, "@bind");
if (SCM_IMP (env))
env = SCM_BOOL_F;
x = SCM_CAR (x);
while (SCM_NIMP (x))
{
- SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_sym2vcell (SCM_CAR (x), env, SCM_BOOL_T)) + scm_tc3_cons_gloc);
+ SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_sym2var (SCM_CAR (x), env, SCM_BOOL_T)) + scm_tc3_cons_gloc);
x = SCM_CDR (x);
}
return scm_cons (SCM_IM_BIND, SCM_CDR (xorig));
}
+SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_makmmacro, scm_m_at_call_with_values);
+SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values);
+
+SCM
+scm_m_at_call_with_values (SCM xorig, SCM env SCM_UNUSED)
+{
+ SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2,
+ scm_s_expression, s_at_call_with_values);
+ return scm_cons (SCM_IM_CALL_WITH_VALUES, SCM_CDR (xorig));
+}
+
SCM
scm_m_expand_body (SCM xorig, SCM env)
{
- SCM form, x = SCM_CDR (xorig), defs = SCM_EOL;
+ SCM x = SCM_CDR (xorig), defs = SCM_EOL;
char *what = SCM_ISYMCHARS (SCM_CAR (xorig)) + 2;
while (SCM_NIMP (x))
{
- form = SCM_CAR (x);
- if (SCM_IMP (form) || SCM_NCONSP (form))
- break;
- if (SCM_IMP (SCM_CAR (form)))
+ SCM form = SCM_CAR (x);
+ if (!SCM_CONSP (form))
break;
if (!SCM_SYMBOLP (SCM_CAR (form)))
break;
-
+
form = scm_macroexp (scm_cons_source (form,
SCM_CAR (form),
SCM_CDR (form)),
if (SCM_EQ_P (SCM_IM_DEFINE, SCM_CAR (form)))
{
defs = scm_cons (SCM_CDR (form), defs);
- x = SCM_CDR(x);
+ x = SCM_CDR (x);
}
- else if (SCM_NIMP(defs))
+ else if (!SCM_IMP (defs))
{
break;
}
}
else
{
- x = scm_cons (form, SCM_CDR(x));
+ x = scm_cons (form, SCM_CDR (x));
break;
}
}
- SCM_ASSYNT (SCM_NIMP (x), SCM_CDR (xorig), scm_s_body, what);
+ SCM_ASSYNT (SCM_NIMP (x), scm_s_body, what);
if (SCM_NIMP (defs))
{
x = scm_cons (scm_m_letrec1 (SCM_IM_LETREC,
SCM
scm_macroexp (SCM x, SCM env)
{
- SCM res, proc;
+ SCM res, proc, orig_sym;
/* Don't bother to produce error messages here. We get them when we
eventually execute the code for real. */
macro_tail:
- if (!SCM_SYMBOLP (SCM_CAR (x)))
+ orig_sym = SCM_CAR (x);
+ if (!SCM_SYMBOLP (orig_sym))
return x;
#ifdef USE_THREADS
/* Only handle memoizing macros. `Acros' and `macros' are really
special forms and should not be evaluated here. */
- if (SCM_IMP (proc)
- || scm_tc16_macro != SCM_TYP16 (proc)
- || (SCM_CELL_WORD_0 (proc) >> 16) != 2)
+ if (!SCM_MACROP (proc) || SCM_MACRO_TYPE (proc) != 2)
return x;
- unmemocar (x, env);
- res = scm_apply (SCM_CDR (proc), x, scm_cons (env, scm_listofnull));
+ SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */
+ res = scm_call_2 (SCM_MACRO_CODE (proc), x, env);
if (scm_ilength (res) <= 0)
res = scm_cons2 (SCM_IM_BEGIN, res, SCM_EOL);
* code of a closure, in scm_procedure_source, in display_frame when
* generating the source for a stackframe in a backtrace, and in
* display_expression.
- */
-
-/* We should introduce an anti-macro interface so that it is possible
- * to plug in transformers in both directions from other compilation
- * units. unmemocopy could then dispatch to anti-macro transformers.
- * (Those transformers could perhaps be written in slightly more
- * readable style... :)
+ *
+ * Unmemoizing is not a realiable process. You can not in general
+ * expect to get the original source back.
+ *
+ * However, GOOPS currently relies on this for method compilation.
+ * This ought to change.
*/
#define SCM_BIT8(x) (127 & SCM_UNPACK (x))
: f;
/* build transformed binding list */
z = SCM_EOL;
- do
+ while (SCM_NIMP (v))
{
z = scm_acons (SCM_CAR (v),
scm_cons (SCM_CAR (e),
e = SCM_CDR (e);
s = SCM_CDR (s);
}
- while (SCM_NIMP (v));
z = scm_cons (z, SCM_UNSPECIFIED);
SCM_SETCDR (ls, z);
if (SCM_EQ_P (SCM_CAR (ls), scm_sym_do))
ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED);
x = SCM_CDR (x);
goto loop;
+ case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
+ ls = z = scm_cons (scm_sym_at_call_with_values, SCM_UNSPECIFIED);
+ goto loop;
default:
/* appease the Sun compiler god: */ ;
}
static int
scm_badformalsp (SCM closure, int n)
{
- SCM formals = SCM_CAR (SCM_CODE (closure));
- while (SCM_NIMP (formals))
+ SCM formals = SCM_CLOSURE_FORMALS (closure);
+ while (!SCM_NULLP (formals))
{
- if (SCM_NCONSP (formals))
+ if (!SCM_CONSP (formals))
return 0;
if (n == 0)
return 1;
scm_eval_args (SCM l, SCM env, SCM proc)
{
SCM results = SCM_EOL, *lloc = &results, res;
- while (SCM_NIMP (l))
+ while (!SCM_IMP (l))
{
#ifdef SCM_CAUTIOUS
if (SCM_CONSP (l))
}
else if (SCM_TYP3 (l) == scm_tc3_cons_gloc)
{
- scm_bits_t vcell = SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell];
+ scm_t_bits vcell =
+ SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell];
if (vcell == 0)
res = SCM_CAR (l); /* struct planted in code */
else
- res = SCM_PACK (vcell);
+ res = SCM_GLOC_VAL (SCM_CAR (l));
}
else
goto wrongnumargs;
l = SCM_CDR (l);
}
#ifdef SCM_CAUTIOUS
- if (SCM_NNULLP (l))
+ if (!SCM_NULLP (l))
{
wrongnumargs:
scm_wrong_num_args (proc);
{\
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\
{\
- scm_make_cont (&tmp);\
- if (!setjmp (SCM_JMPBUF (tmp)))\
- scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
+ int first;\
+ tmp = scm_make_continuation (&first);\
+ if (first)\
+ scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
}\
+ SCM_TRAPS_P = 1;\
}\
} while (0)
#undef RETURN
*/
#ifndef USE_THREADS
-scm_debug_frame *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
* stack frames at each real stack frame.
*/
-int scm_debug_eframe_size;
+long scm_debug_eframe_size;
int scm_debug_mode, scm_check_entry_p, scm_check_apply_p, scm_check_exit_p;
-int scm_eval_stack;
+long scm_eval_stack;
-scm_option scm_eval_opts[] = {
+scm_t_option scm_eval_opts[] = {
{ SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." }
};
-scm_option 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_INTEGER, "depth", 20, "Maximal length of printed backtrace." },
{ 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_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
+ { 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 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,
(SCM setting),
- "")
+ "Option interface for the evaluation options. Instead of using\n"
+ "this procedure directly, use the procedures @code{eval-enable},\n"
+ "@code{eval-disable}, @code{eval-set!} and @var{eval-options}.")
#define FUNC_NAME s_scm_eval_options_interface
{
SCM ans;
SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
(SCM setting),
- "")
+ "Option interface for the evaluator trap options.")
#define FUNC_NAME s_scm_evaluator_traps
{
SCM ans;
scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
{
SCM *results = lloc, res;
- while (SCM_NIMP (l))
+ while (!SCM_IMP (l))
{
#ifdef SCM_CAUTIOUS
if (SCM_CONSP (l))
}
else if (SCM_TYP3 (l) == scm_tc3_cons_gloc)
{
- scm_bits_t vcell = SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell];
+ scm_t_bits vcell =
+ SCM_STRUCT_VTABLE_DATA (l) [scm_vtable_index_vcell];
if (vcell == 0)
res = SCM_CAR (l); /* struct planted in code */
else
- res = SCM_PACK (vcell);
+ res = SCM_GLOC_VAL (SCM_CAR (l));
}
else
goto wrongnumargs;
l = SCM_CDR (l);
}
#ifdef SCM_CAUTIOUS
- if (SCM_NNULLP (l))
+ if (!SCM_NULLP (l))
{
wrongnumargs:
scm_wrong_num_args (proc);
/* SECTION: Some local definitions for the evaluator.
*/
+/* Update the toplevel environment frame ENV so that it refers to the
+ current module.
+*/
+#define UPDATE_TOPLEVEL_ENV(env) \
+ do { \
+ SCM p = scm_current_module_lookup_closure (); \
+ if (p != SCM_CAR(env)) \
+ env = scm_top_level_env (p); \
+ } while (0)
+
#ifndef DEVAL
#define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
#endif /* DEVAL */
SCM *lloc;
SCM arg1;
} t;
- SCM proc, arg2;
+ SCM proc, arg2, orig_sym;
#ifdef DEVAL
- scm_debug_frame debug;
- scm_debug_info *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 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 *) alloca (scm_debug_eframe_size
+ debug.vect = (scm_t_debug_info *) alloca (scm_debug_eframe_size
* sizeof (debug.vect[0]));
debug.info = debug.vect;
debug_info_end = debug.vect + scm_debug_eframe_size;
t.arg1 = scm_make_debugobj (&debug);
else
{
- scm_make_cont (&t.arg1);
- if (setjmp (SCM_JMPBUF (t.arg1)))
+ int first;
+ SCM val = scm_make_continuation (&first);
+
+ if (first)
+ t.arg1 = val;
+ else
{
- x = SCM_THROW_VALUE (t.arg1);
+ x = val;
if (SCM_IMP (x))
{
RETURN (x);
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)
SCM_TICK;
switch (SCM_TYP7 (x))
{
- case scm_tcs_symbols:
+ case scm_tc7_symbol:
/* Only happens when called at top level.
*/
x = scm_cons (x, SCM_UNDEFINED);
goto carloop;
case SCM_BIT8(SCM_IM_BEGIN):
- cdrxnoap:
+ /* (currently unused)
+ cdrxnoap: */
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- cdrxbegin:
+ /* (currently unused)
+ cdrxbegin: */
x = SCM_CDR (x);
begin:
+ /* If we are on toplevel with a lookup closure, we need to sync
+ with the current module. */
+ if (SCM_CONSP (env) && !SCM_CONSP (SCM_CAR (env)))
+ {
+ t.arg1 = x;
+ UPDATE_TOPLEVEL_ENV (env);
+ while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1)))
+ {
+ EVALCAR (x, env);
+ x = t.arg1;
+ UPDATE_TOPLEVEL_ENV (env);
+ }
+ goto carloop;
+ }
+ else
+ goto nontoplevel_begin;
+
+ nontoplevel_cdrxnoap:
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ nontoplevel_cdrxbegin:
+ x = SCM_CDR (x);
+ nontoplevel_begin:
t.arg1 = x;
- while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
+ while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1)))
{
if (SCM_IMP (SCM_CAR (x)))
{
if (SCM_ISYMP (SCM_CAR (x)))
{
x = scm_m_expand_body (x, env);
- goto begin;
+ goto nontoplevel_begin;
}
+ else
+ SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (x));
}
else
SCM_CEVAL (SCM_CAR (x), env);
x = t.arg1;
}
-
+
carloop: /* scm_eval car of last form in list */
- if (SCM_NCELLP (SCM_CAR (x)))
+ if (!SCM_CELLP (SCM_CAR (x)))
{
x = SCM_CAR (x);
RETURN (SCM_IMP (x) ? SCM_EVALIM (x, env) : SCM_GLOC_VAL (x))
case SCM_BIT8(SCM_IM_COND):
- while (SCM_NIMP (x = SCM_CDR (x)))
+ while (!SCM_IMP (x = SCM_CDR (x)))
{
proc = SCM_CAR (x);
t.arg1 = EVALCAR (proc, env);
if (SCM_NFALSEP (t.arg1))
{
x = SCM_CDR (proc);
- if SCM_NULLP (x)
+ if (SCM_NULLP (x))
{
RETURN (t.arg1)
}
- if (! SCM_EQ_P (scm_sym_arrow, SCM_CAR (x)))
+ if (!SCM_EQ_P (scm_sym_arrow, SCM_CAR (x)))
{
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto begin;
SCM_ASRTGO (SCM_NIMP (proc), badfun);
PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL));
ENTER_APPLY;
+ if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1))
+ goto umwrongnumargs;
goto evap1;
}
}
if (SCM_NULLP (x))
RETURN (SCM_UNSPECIFIED);
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
- goto begin;
+ goto nontoplevel_begin;
case SCM_BIT8(SCM_IM_IF):
while (SCM_NIMP (proc = SCM_CDR (proc)));
env = EXTEND_ENV (SCM_CAR (x), t.arg1, env);
x = SCM_CDR (x);
- goto cdrxnoap;
+ goto nontoplevel_cdrxnoap;
case SCM_BIT8(SCM_IM_LETREC):
}
while (SCM_NIMP (proc = SCM_CDR (proc)));
SCM_SETCDR (SCM_CAR (env), t.arg1);
- goto cdrxnoap;
+ goto nontoplevel_cdrxnoap;
case SCM_BIT8(SCM_IM_LETSTAR):
if (SCM_IMP (proc))
{
env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
- goto cdrxnoap;
+ goto nontoplevel_cdrxnoap;
}
do
{
env = EXTEND_ENV (t.arg1, EVALCAR (proc, env), env);
}
while (SCM_NIMP (proc = SCM_CDR (proc)));
- goto cdrxnoap;
+ goto nontoplevel_cdrxnoap;
case SCM_BIT8(SCM_IM_OR):
x = SCM_CDR (x);
t.arg1 = x;
- while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
+ while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1)))
{
x = EVALCAR (x, env);
- if (SCM_NFALSEP (x))
+ if (!SCM_FALSEP (x))
{
RETURN (x);
}
SCM_ASRTGO (SCM_ISYMP (proc), badfun);
switch SCM_ISYMNUM (proc)
{
-#if 0
- case (SCM_ISYMNUM (IM_VREF)):
- {
- SCM var;
- var = SCM_CAR (SCM_CDR (x));
- RETURN (SCM_CDR(var));
- }
- case (SCM_ISYMNUM (IM_VSET)):
- SCM_CDR (SCM_CAR ( SCM_CDR (x))) = EVALCAR( SCM_CDR ( SCM_CDR (x)), env);
- SCM_CAR (SCM_CAR ( SCM_CDR (x))) = scm_tc16_variable;
- RETURN (SCM_UNSPECIFIED)
-#endif
-
case (SCM_ISYMNUM (SCM_IM_APPLY)):
proc = SCM_CDR (x);
proc = EVALCAR (proc, env);
PREP_APPLY (proc, SCM_EOL);
t.arg1 = SCM_CDR (SCM_CDR (x));
t.arg1 = EVALCAR (t.arg1, env);
+ apply_closure:
+ /* Go here to tail-call a closure. PROC is the closure
+ and T.ARG1 is the list of arguments. Do not forget to
+ call PREP_APPLY. */
#ifdef DEVAL
debug.info->a.args = t.arg1;
#endif
#ifndef SCM_RECKLESS
- if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), t.arg1))
+ if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), t.arg1))
goto wrongnumargs;
#endif
ENTER_APPLY;
SCM_SETCDR (tl, t.arg1);
}
- env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), argl, SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), argl, SCM_ENV (proc));
x = SCM_CODE (proc);
- goto cdrxbegin;
+ goto nontoplevel_cdrxbegin;
}
proc = scm_f_apply;
goto evapply;
case (SCM_ISYMNUM (SCM_IM_CONT)):
- scm_make_cont (&t.arg1);
- if (setjmp (SCM_JMPBUF (t.arg1)))
- {
- SCM val;
- val = SCM_THROW_VALUE (t.arg1);
- RETURN (val)
- }
+ {
+ int first;
+ SCM val = scm_make_continuation (&first);
+
+ if (first)
+ t.arg1 = val;
+ else
+ RETURN (val);
+ }
proc = SCM_CDR (x);
proc = evalcar (proc, env);
SCM_ASRTGO (SCM_NIMP (proc), badfun);
PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL));
ENTER_APPLY;
+ if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1))
+ goto umwrongnumargs;
goto evap1;
case (SCM_ISYMNUM (SCM_IM_DELAY)):
* cuts down execution time for type dispatch to 50%.
*/
{
- int i, n, end, mask;
+ long i, n, end, mask;
SCM z = SCM_CDDR (x);
n = SCM_INUM (SCM_CAR (z)); /* maximum number of specializers */
proc = SCM_CADR (z);
/* Prepare for linear search */
mask = -1;
i = 0;
- end = SCM_LENGTH (proc);
+ end = SCM_VECTOR_LENGTH (proc);
}
else
{
/* Compute a hash value */
- int hashset = SCM_INUM (proc);
- int j = n;
- mask = SCM_INUM (SCM_CAR (z = SCM_CDDR (z)));
+ long hashset = SCM_INUM (proc);
+ long j = n;
+ z = SCM_CDDR (z);
+ mask = SCM_INUM (SCM_CAR (z));
proc = SCM_CADR (z);
i = 0;
t.arg1 = arg2;
[scm_si_hashsets + hashset];
t.arg1 = SCM_CDR (t.arg1);
}
- while (--j && SCM_NIMP (t.arg1));
+ while (j-- && SCM_NIMP (t.arg1));
i &= mask;
end = i;
}
/* Search for match */
do
{
- int j = n;
+ long j = n;
z = SCM_VELTS (proc)[i];
t.arg1 = arg2; /* list of arguments */
if (SCM_NIMP (t.arg1))
t.arg1 = SCM_CDR (t.arg1);
z = SCM_CDR (z);
}
- while (--j && SCM_NIMP (t.arg1));
+ while (j-- && SCM_NIMP (t.arg1));
/* Fewer arguments than specifiers => CAR != ENV */
if (!(SCM_IMP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z))))
goto next_method;
arg2,
SCM_CMETHOD_ENV (z));
x = SCM_CMETHOD_CODE (z);
- goto cdrxbegin;
+ goto nontoplevel_cdrxbegin;
next_method:
i = (i + 1) & mask;
} while (i != end);
arg2 = SCM_CDR (arg2);
}
- RETURN (proc)
+ RETURN (proc);
+ case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
+ {
+ proc = SCM_CDR (x);
+ x = EVALCAR (proc, env);
+ proc = SCM_CDR (proc);
+ proc = EVALCAR (proc, env);
+ t.arg1 = SCM_APPLY (x, SCM_EOL, SCM_EOL);
+ if (SCM_VALUESP (t.arg1))
+ t.arg1 = scm_struct_ref (t.arg1, SCM_INUM0);
+ else
+ t.arg1 = scm_cons (t.arg1, SCM_EOL);
+ if (SCM_CLOSUREP (proc))
+ {
+ PREP_APPLY (proc, t.arg1);
+ goto apply_closure;
+ }
+ return SCM_APPLY (proc, t.arg1, SCM_EOL);
+ }
+
default:
goto badfun;
}
proc = x;
badfun:
/* scm_everr (x, env,...) */
- scm_misc_error (NULL,
- "Wrong type to apply: ~S",
- scm_listify (proc, SCM_UNDEFINED));
+ scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc));
case scm_tc7_vector:
case scm_tc7_wvect:
#ifdef HAVE_ARRAYS
case scm_tc7_substring:
case scm_tc7_smob:
case scm_tcs_closures:
-#ifdef CCLO
case scm_tc7_cclo:
-#endif
case scm_tc7_pws:
case scm_tcs_subrs:
RETURN (x);
case scm_tcs_cons_gloc: {
- scm_bits_t vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell];
+ scm_t_bits 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_PACK (vcell);
+ proc = SCM_GLOC_VAL (SCM_CAR (x));
SCM_ASRTGO (SCM_NIMP (proc), badfun);
#ifndef SCM_RECKLESS
#ifdef SCM_CAUTIOUS
}
case scm_tcs_cons_nimcar:
- if (SCM_SYMBOLP (SCM_CAR (x)))
+ orig_sym = SCM_CAR (x);
+ if (SCM_SYMBOLP (orig_sym))
{
#ifdef USE_THREADS
t.lloc = scm_lookupcar1 (x, env, 1);
if (SCM_IMP (proc))
{
- unmemocar (x, env);
+ SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of
+ lookupcar */
goto badfun;
}
- if (scm_tc16_macro == SCM_TYP16 (proc))
+ if (SCM_MACROP (proc))
{
- unmemocar (x, env);
-
+ SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of
+ lookupcar */
handle_a_macro:
#ifdef DEVAL
/* Set a flag during macro expansion so that macro
application frames can be deleted from the backtrace. */
SCM_SET_MACROEXP (debug);
#endif
- t.arg1 = SCM_APPLY (SCM_CDR (proc), x,
+ t.arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x,
scm_cons (env, scm_listofnull));
#ifdef DEVAL
SCM_CLEAR_MACROEXP (debug);
#endif
- switch (SCM_CELL_WORD_0 (proc) >> 16)
+ switch (SCM_MACRO_TYPE (proc))
{
case 2:
if (scm_ilength (t.arg1) <= 0)
t.arg1 = scm_cons2 (SCM_IM_BEGIN, t.arg1, SCM_EOL);
#ifdef DEVAL
- if (!SCM_CLOSUREP (SCM_CDR (proc)))
+ if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))
{
-
-#if 0 /* Top-level defines doesn't very often occur in backtraces */
- if (scm_m_define == SCM_SUBRF (SCM_CDR (proc)) && SCM_TOP_LEVEL (env))
- /* Prevent memoizing result of define macro */
- {
- debug.info->e.exp = scm_cons (SCM_CAR (x), SCM_CDR (x));
- scm_set_source_properties_x (debug.info->e.exp,
- scm_source_properties (x));
- }
-#endif
SCM_DEFER_INTS;
SCM_SETCAR (x, SCM_CAR (t.arg1));
SCM_SETCDR (x, SCM_CDR (t.arg1));
}
else
proc = SCM_CEVAL (SCM_CAR (x), env);
- SCM_ASRTGO (SCM_NIMP (proc), badfun);
+ SCM_ASRTGO (!SCM_IMP (proc), badfun);
#ifndef SCM_RECKLESS
#ifdef SCM_CAUTIOUS
checkargs:
#endif
if (SCM_CLOSUREP (proc))
{
- arg2 = SCM_CAR (SCM_CODE (proc));
+ arg2 = SCM_CLOSURE_FORMALS (proc);
t.arg1 = SCM_CDR (x);
- while (SCM_NIMP (arg2))
+ while (!SCM_NULLP (arg2))
{
- if (SCM_NCONSP (arg2))
+ if (!SCM_CONSP (arg2))
goto evapply;
if (SCM_IMP (t.arg1))
goto umwrongnumargs;
arg2 = SCM_CDR (arg2);
t.arg1 = SCM_CDR (t.arg1);
}
- if (SCM_NNULLP (t.arg1))
+ if (!SCM_NULLP (t.arg1))
goto umwrongnumargs;
}
- else if (scm_tc16_macro == SCM_TYP16 (proc))
+ else if (SCM_MACROP (proc))
goto handle_a_macro;
#endif
}
RETURN (SCM_BOOL_T);
case scm_tc7_asubr:
RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
-#ifdef CCLO
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_0 (proc));
case scm_tc7_cclo:
t.arg1 = proc;
proc = SCM_CCLO_SUBR (proc);
debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
#endif
goto evap1;
-#endif
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
#ifdef DEVAL
goto umwrongnumargs;
case scm_tcs_closures:
x = SCM_CODE (proc);
- env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc));
- goto cdrxbegin;
- case scm_tcs_cons_gloc:
+ env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), SCM_EOL, SCM_ENV (proc));
+ goto nontoplevel_cdrxbegin;
+ case scm_tcs_cons_gloc: /* really structs, not glocs */
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
x = SCM_ENTITY_PROCEDURE (proc);
else
goto badfun;
}
- case scm_tc7_contin:
case scm_tc7_subr_1:
case scm_tc7_subr_2:
case scm_tc7_subr_2o:
}
else if (SCM_TYP3 (x) == scm_tc3_cons_gloc)
{
- scm_bits_t vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell];
+ scm_t_bits 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_PACK (vcell);
+ t.arg1 = SCM_GLOC_VAL (SCM_CAR (x));
}
else
goto wrongnumargs;
#ifdef SCM_BIGDIG
if (SCM_BIGP (t.arg1))
{
- RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_big2dbl (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_CHARS (SCM_SNAME (proc)));
+ SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
}
proc = SCM_SNAME (proc);
{
- char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1;
+ char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1;
while ('c' != *--chrs)
{
SCM_ASSERT (SCM_CONSP (t.arg1),
- t.arg1, SCM_ARG1, SCM_CHARS (proc));
+ t.arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc));
t.arg1 = ('a' == *chrs) ? SCM_CAR (t.arg1) : SCM_CDR (t.arg1);
}
RETURN (t.arg1);
#else
RETURN (SCM_SUBRF (proc) (scm_cons (t.arg1, SCM_EOL)));
#endif
-#ifdef CCLO
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_1 (proc, t.arg1));
case scm_tc7_cclo:
arg2 = t.arg1;
t.arg1 = proc;
debug.info->a.proc = proc;
#endif
goto evap2;
-#endif
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
#ifdef DEVAL
/* clos1: */
x = SCM_CODE (proc);
#ifdef DEVAL
- env = EXTEND_ENV (SCM_CAR (x), debug.info->a.args, SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), debug.info->a.args, SCM_ENV (proc));
#else
- env = EXTEND_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
#endif
- goto cdrxbegin;
- case scm_tc7_contin:
- scm_call_continuation (proc, t.arg1);
- case scm_tcs_cons_gloc:
+ goto nontoplevel_cdrxbegin;
+ case scm_tcs_cons_gloc: /* really structs, not glocs */
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
x = SCM_ENTITY_PROCEDURE (proc);
}
else if (SCM_TYP3 (x) == scm_tc3_cons_gloc)
{
- scm_bits_t vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell];
+ scm_t_bits vcell = SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_vcell];
if (vcell == 0)
arg2 = SCM_CAR (x); /* struct planted in code */
else
- arg2 = SCM_PACK (vcell);
+ arg2 = SCM_GLOC_VAL (SCM_CAR (x));
}
else
goto wrongnumargs;
x = SCM_CDR (x);
if (SCM_NULLP (x)) {
ENTER_APPLY;
-#ifdef CCLO
evap2:
-#endif
switch (SCM_TYP7 (proc))
{ /* have two arguments */
case scm_tc7_subr_2:
case scm_tc7_rpsubr:
case scm_tc7_asubr:
RETURN (SCM_SUBRF (proc) (t.arg1, arg2));
-#ifdef CCLO
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_2 (proc, t.arg1, arg2));
cclon:
case scm_tc7_cclo:
#ifdef DEVAL
proc))),
SCM_EOL));
#endif
- /* case scm_tc7_cclo:
- x = scm_cons(arg2, scm_eval_args(x, env));
- arg2 = t.arg1;
- t.arg1 = proc;
- proc = SCM_CCLO_SUBR(proc);
- goto evap3; */
-#endif
- case scm_tcs_cons_gloc:
+ case scm_tcs_cons_gloc: /* really structs, not glocs */
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
x = SCM_ENTITY_PROCEDURE (proc);
case scm_tc7_subr_1o:
case scm_tc7_subr_1:
case scm_tc7_subr_3:
- case scm_tc7_contin:
goto wrongnumargs;
default:
goto badfun;
case scm_tcs_closures:
/* clos2: */
#ifdef DEVAL
- env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
+ env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
debug.info->a.args,
SCM_ENV (proc));
#else
- env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
+ env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
#endif
x = SCM_CODE (proc);
- goto cdrxbegin;
+ goto nontoplevel_cdrxbegin;
}
}
#ifdef SCM_CAUTIOUS
SCM_CDR (SCM_CDR (debug.info->a.args))))
case scm_tc7_lsubr:
RETURN (SCM_SUBRF (proc) (debug.info->a.args))
-#ifdef CCLO
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_3 (proc, t.arg1, arg2,
+ SCM_CDDR (debug.info->a.args)));
case scm_tc7_cclo:
goto cclon;
-#endif
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
debug.info->a.proc = proc;
if (!SCM_CLOSUREP (proc))
goto evap3;
- if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), debug.info->a.args))
+ if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), debug.info->a.args))
goto umwrongnumargs;
case scm_tcs_closures:
SCM_SET_ARGSREADY (debug);
- env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
+ env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
debug.info->a.args,
SCM_ENV (proc));
x = SCM_CODE (proc);
- goto cdrxbegin;
+ goto nontoplevel_cdrxbegin;
#else /* DEVAL */
case scm_tc7_subr_3:
SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1,
arg2,
scm_eval_args (x, env, proc))));
-#ifdef CCLO
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_3 (proc, t.arg1, arg2,
+ scm_eval_args (x, env, proc)));
case scm_tc7_cclo:
goto cclon;
-#endif
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
if (!SCM_CLOSUREP (proc))
goto evap3;
{
- SCM formals = SCM_CAR (SCM_CODE (proc));
+ SCM formals = SCM_CLOSURE_FORMALS (proc);
if (SCM_NULLP (formals)
|| (SCM_CONSP (formals)
&& (SCM_NULLP (SCM_CDR (formals))
#ifdef DEVAL
SCM_SET_ARGSREADY (debug);
#endif
- env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
+ env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
scm_cons2 (t.arg1,
arg2,
scm_eval_args (x, env, proc)),
SCM_ENV (proc));
x = SCM_CODE (proc);
- goto cdrxbegin;
+ goto nontoplevel_cdrxbegin;
#endif /* DEVAL */
- case scm_tcs_cons_gloc:
+ case scm_tcs_cons_gloc: /* really structs, not glocs */
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
#ifdef DEVAL
case scm_tc7_subr_0:
case scm_tc7_cxr:
case scm_tc7_subr_1:
- case scm_tc7_contin:
goto wrongnumargs;
default:
goto badfun;
t.arg1 = scm_make_debugobj (&debug);
else
{
- scm_make_cont (&t.arg1);
- if (setjmp (SCM_JMPBUF (t.arg1)))
+ int first;
+ SCM val = scm_make_continuation (&first);
+
+ if (first)
+ t.arg1 = val;
+ else
{
- proc = SCM_THROW_VALUE (t.arg1);
+ proc = val;
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)
they're referring to, send me a patch to this comment. */
SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0,
- (SCM lst),
- "")
+ (SCM lst),
+ "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
+ "conses the @var{arg1} @dots{} arguments onto the front of\n"
+ "@var{args}, and returns the resulting list. Note that\n"
+ "@var{args} is a list; thus, the argument to this function is\n"
+ "a list whose last element is a list.\n"
+ "Note: Rather than do new consing, @code{apply:nconc2last}\n"
+ "destroys its argument, so use with care.")
#define FUNC_NAME s_scm_nconc2last
{
SCM *lloc;
{
#ifdef DEBUG_EXTENSIONS
#ifdef DEVAL
- scm_debug_frame debug;
- scm_debug_info 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;
}
else
{
- /* SCM_ASRTGO(SCM_CONSP(args), wrongnumargs); */
args = scm_nconc2last (args);
#ifdef DEVAL
debug.vect[0].a.args = scm_cons (arg1, args);
tmp = scm_make_debugobj (&debug);
else
{
- scm_make_cont (&tmp);
- if (setjmp (SCM_JMPBUF (tmp)))
+ int first;
+
+ tmp = scm_make_continuation (&first);
+ 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;
#endif
-#ifdef CCLO
tail:
-#endif
switch (SCM_TYP7 (proc))
{
case scm_tc7_subr_2o:
SCM_ASRTGO (SCM_UNBNDP (arg1), wrongnumargs);
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))
case scm_tc7_cxr:
- SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
+ SCM_ASRTGO (!SCM_UNBNDP (arg1) && SCM_NULLP (args), wrongnumargs);
if (SCM_SUBRF (proc))
{
if (SCM_INUMP (arg1))
}
#ifdef SCM_BIGDIG
if (SCM_BIGP (arg1))
- RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_big2dbl (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_CHARS (SCM_SNAME (proc)));
+ SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc)));
}
proc = SCM_SNAME (proc);
{
- char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1;
+ char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1;
while ('c' != *--chrs)
{
SCM_ASSERT (SCM_CONSP (arg1),
- arg1, SCM_ARG1, SCM_CHARS (proc));
+ arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc));
arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1);
}
RETURN (arg1)
}
case scm_tc7_subr_3:
+ SCM_ASRTGO (SCM_NNULLP (args)
+ && SCM_NNULLP (SCM_CDR (args))
+ && SCM_NULLP (SCM_CDDR (args)),
+ wrongnumargs);
RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CAR (SCM_CDR (args))))
case scm_tc7_lsubr:
#ifdef DEVAL
arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
#endif
#ifndef SCM_RECKLESS
- if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), arg1))
+ if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1))
goto wrongnumargs;
#endif
SCM_SETCDR (tl, arg1);
}
- args = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), args, SCM_ENV (proc));
+ args = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), args, SCM_ENV (proc));
proc = SCM_CDR (SCM_CODE (proc));
again:
arg1 = proc;
proc = scm_m_expand_body (proc, args);
goto again;
}
+ else
+ SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc));
}
else
SCM_CEVAL (SCM_CAR (proc), args);
proc = arg1;
}
RETURN (EVALCAR (proc, args));
- case scm_tc7_contin:
- SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
- scm_call_continuation (proc, arg1);
-#ifdef CCLO
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badproc;
+ if (SCM_UNBNDP (arg1))
+ RETURN (SCM_SMOB_APPLY_0 (proc))
+ else if (SCM_NULLP (args))
+ RETURN (SCM_SMOB_APPLY_1 (proc, arg1))
+ else if (SCM_NULLP (SCM_CDR (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:
#ifdef DEVAL
args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
proc = SCM_CCLO_SUBR (proc);
#endif
goto tail;
-#endif
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
#ifdef DEVAL
debug.vect[0].a.proc = proc;
#endif
goto tail;
- case scm_tcs_cons_gloc:
+ case scm_tcs_cons_gloc: /* really structs, not glocs */
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
#ifdef DEVAL
scm_wrong_num_args (proc);
default:
badproc:
- scm_wta (proc, (char *) SCM_ARG1, "apply");
+ scm_wrong_type_arg ("apply", SCM_ARG1, proc);
RETURN (arg1);
}
#ifdef DEVAL
arg1 = scm_make_debugobj (&debug);
else
{
- scm_make_cont (&arg1);
- if (setjmp (SCM_JMPBUF (arg1)))
+ int first;
+ SCM val = scm_make_continuation (&first);
+
+ if (first)
+ arg1 = val;
+ else
{
- proc = SCM_THROW_VALUE (arg1);
+ proc = val;
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;
const char *who)
{
SCM *ve = SCM_VELTS (argv);
- int i;
+ long i;
- for (i = SCM_LENGTH (argv) - 1; i >= 1; i--)
+ for (i = SCM_VECTOR_LENGTH (argv) - 1; i >= 1; i--)
{
- int elt_len = scm_ilength (ve[i]);
+ long elt_len = scm_ilength (ve[i]);
if (elt_len < 0)
{
scm_out_of_range (who, ve[i]);
}
- scm_remember (&argv);
+ scm_remember_upto_here_1 (argv);
}
while (1)
{
arg1 = SCM_EOL;
- for (i = SCM_LENGTH (args) - 1; i >= 0; i--)
+ for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--)
{
if (SCM_IMP (ve[i]))
return res;
while (1)
{
arg1 = SCM_EOL;
- for (i = SCM_LENGTH (args) - 1; i >= 0; i--)
+ for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--)
{
if SCM_IMP
(ve[i]) return SCM_UNSPECIFIED;
scm_closure (SCM code, SCM env)
{
register SCM z;
+
SCM_NEWCELL (z);
SCM_SETCODE (z, code);
SCM_SETENV (z, env);
}
-long scm_tc16_promise;
+scm_t_bits scm_tc16_promise;
SCM
scm_makprom (SCM code)
static int
-prinprom (SCM exp,SCM port,scm_print_state *pstate)
+promise_print (SCM exp, SCM port, scm_print_state *pstate)
{
int writingp = SCM_WRITINGP (pstate);
scm_puts ("#<promise ", port);
SCM_SET_WRITINGP (pstate, 1);
- scm_iprin1 (SCM_CDR (exp), port, pstate);
+ scm_iprin1 (SCM_CELL_OBJECT_1 (exp), port, pstate);
SCM_SET_WRITINGP (pstate, writingp);
scm_putc ('>', port);
return !0;
SCM_DEFINE (scm_force, "force", 1, 0, 0,
- (SCM x),
- "If the promise X has not been computed yet, compute and return\n"
- "X, otherwise just return the previously computed value.")
+ (SCM x),
+ "If the promise @var{x} has not been computed yet, compute and\n"
+ "return @var{x}, otherwise just return the previously computed\n"
+ "value.")
#define FUNC_NAME s_scm_force
{
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;
SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0,
- (SCM x),
+ (SCM obj),
"Return true if @var{obj} is a promise, i.e. a delayed computation\n"
- "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).")
+ "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
#define FUNC_NAME s_scm_promise_p
{
- return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_promise, x));
+ return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise, obj));
}
#undef FUNC_NAME
SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0,
(SCM xorig, SCM x, SCM y),
- "")
+ "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
+ "Any source properties associated with @var{xorig} are also associated\n"
+ "with the new pair.")
#define FUNC_NAME s_scm_cons_source
{
SCM p, z;
return obj;
if (SCM_VECTORP (obj))
{
- scm_sizet i = SCM_LENGTH (obj);
- ans = scm_make_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED);
+ unsigned long i = SCM_VECTOR_LENGTH (obj);
+ ans = scm_c_make_vector (i, SCM_UNSPECIFIED);
while (i--)
SCM_VELTS (ans)[i] = scm_copy_tree (SCM_VELTS (obj)[i]);
return ans;
}
if (SCM_NCONSP (obj))
return obj;
-/* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
ans = tl = scm_cons_source (obj,
scm_copy_tree (SCM_CAR (obj)),
SCM_UNSPECIFIED);
#undef FUNC_NAME
+/* We have three levels of EVAL here:
+
+ - scm_i_eval (exp, env)
+
+ evaluates EXP in environment ENV. ENV is a lexical environment
+ structure as used by the actual tree code evaluator. When ENV is
+ a top-level environment, then changes to the current module are
+ tracked by updating ENV so that it continues to be in sync with
+ the current module.
+
+ - scm_primitive_eval (exp)
+
+ evaluates EXP in the top-level environment as determined by the
+ current module. This is done by constructing a suitable
+ environment and calling scm_i_eval. Thus, changes to the
+ top-level module are tracked normally.
+
+ - scm_eval (exp, mod)
+
+ evaluates EXP while MOD is the current module. This is done by
+ setting the current module to MOD, invoking scm_primitive_eval on
+ EXP, and then restoring the current module to the value it had
+ previously. That is, while EXP is evaluated, changes to the
+ current module are tracked, but these changes do not persist when
+ scm_eval returns.
+
+ For each level of evals, there are two variants, distinguished by a
+ _x suffix: the ordinary variant does not modify EXP while the _x
+ variant can destructively modify EXP into something completely
+ unintelligible. A Scheme data structure passed as EXP to one of the
+ _x variants should not ever be used again for anything. So when in
+ doubt, use the ordinary variant.
+
+*/
+
SCM
-scm_eval_3 (SCM obj, int copyp, SCM env)
+scm_i_eval_x (SCM exp, SCM env)
{
- if (SCM_NIMP (SCM_CDR (scm_system_transformer)))
- obj = scm_apply (SCM_CDR (scm_system_transformer), obj, scm_listofnull);
- else if (copyp)
- obj = scm_copy_tree (obj);
- return SCM_XEVAL (obj, env);
+ return SCM_XEVAL (exp, env);
}
-SCM_DEFINE (scm_eval2, "eval2", 2, 0, 0,
- (SCM obj, SCM env_thunk),
- "Evaluate @var{exp}, a Scheme expression, in the environment designated\n"
- "by @var{lookup}, a symbol-lookup function. @code{(eval exp)} is\n"
- "equivalent to @code{(eval2 exp *top-level-lookup-closure*)}.")
-#define FUNC_NAME s_scm_eval2
+SCM
+scm_i_eval (SCM exp, SCM env)
+{
+ exp = scm_copy_tree (exp);
+ return SCM_XEVAL (exp, env);
+}
+
+SCM
+scm_primitive_eval_x (SCM exp)
+{
+ SCM env;
+ SCM transformer = scm_current_module_transformer ();
+ if (SCM_NIMP (transformer))
+ exp = scm_call_1 (transformer, exp);
+ env = scm_top_level_env (scm_current_module_lookup_closure ());
+ return scm_i_eval_x (exp, env);
+}
+
+SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0,
+ (SCM exp),
+ "Evaluate @var{exp} in the top-level environment specified by\n"
+ "the current module.")
+#define FUNC_NAME s_scm_primitive_eval
{
- return scm_eval_3 (obj, 1, scm_top_level_env (env_thunk));
+ SCM env;
+ SCM transformer = scm_current_module_transformer ();
+ if (SCM_NIMP (transformer))
+ exp = scm_call_1 (transformer, exp);
+ env = scm_top_level_env (scm_current_module_lookup_closure ());
+ return scm_i_eval (exp, env);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_eval, "eval", 1, 0, 0,
- (SCM obj),
- "Evaluate @var{exp}, a list representing a Scheme expression, in the\n"
- "top-level environment.")
+/* Eval does not take the second arg optionally. This is intentional
+ * in order to be R5RS compatible, and to prepare for the new module
+ * system, where we would like to make the choice of evaluation
+ * environment explicit. */
+
+static void
+change_environment (void *data)
+{
+ SCM pair = SCM_PACK (data);
+ SCM new_module = SCM_CAR (pair);
+ SCM old_module = scm_current_module ();
+ SCM_SETCDR (pair, old_module);
+ scm_set_current_module (new_module);
+}
+
+
+static void
+restore_environment (void *data)
+{
+ SCM pair = SCM_PACK (data);
+ SCM old_module = SCM_CDR (pair);
+ SCM new_module = scm_current_module ();
+ SCM_SETCAR (pair, new_module);
+ scm_set_current_module (old_module);
+}
+
+static SCM
+inner_eval_x (void *data)
+{
+ return scm_primitive_eval_x (SCM_PACK(data));
+}
+
+SCM
+scm_eval_x (SCM exp, SCM module)
+#define FUNC_NAME "eval!"
+{
+ SCM_VALIDATE_MODULE (2, module);
+
+ return scm_internal_dynamic_wind
+ (change_environment, inner_eval_x, restore_environment,
+ (void *) SCM_UNPACK (exp),
+ (void *) SCM_UNPACK (scm_cons (module, SCM_BOOL_F)));
+}
+#undef FUNC_NAME
+
+static SCM
+inner_eval (void *data)
+{
+ return scm_primitive_eval (SCM_PACK(data));
+}
+
+SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
+ (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"
+ "@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
{
- return scm_eval_3 (obj,
- 1,
- scm_top_level_env
- (SCM_CDR (scm_top_level_lookup_closure_var)));
+ SCM_VALIDATE_MODULE (2, module);
+
+ return scm_internal_dynamic_wind
+ (change_environment, inner_eval, restore_environment,
+ (void *) SCM_UNPACK (exp),
+ (void *) SCM_UNPACK (scm_cons (module, SCM_BOOL_F)));
}
#undef FUNC_NAME
-/*
-SCM_REGISTER_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x);
-*/
+#if (SCM_DEBUG_DEPRECATED == 0)
-SCM
-scm_eval_x (SCM obj)
+/* 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)
{
- return scm_eval_3 (obj,
- 0,
- scm_top_level_env
- (SCM_CDR (scm_top_level_lookup_closure_var)));
+ 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_tc16_promise = scm_make_smob_type ("promise", 0);
scm_set_smob_mark (scm_tc16_promise, scm_markcdr);
- scm_set_smob_print (scm_tc16_promise, prinprom);
-
- scm_f_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply);
- scm_system_transformer = scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED);
- scm_sym_dot = SCM_CAR (scm_sysintern (".", SCM_UNDEFINED));
- scm_sym_arrow = SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED));
- scm_sym_else = SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED));
- scm_sym_unquote = SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED));
- scm_sym_uq_splicing = SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED));
-
- scm_lisp_nil = scm_sysintern ("nil", SCM_UNDEFINED);
- SCM_SETCDR (scm_lisp_nil, SCM_CAR (scm_lisp_nil));
- scm_lisp_nil = SCM_CAR (scm_lisp_nil);
- scm_lisp_t = scm_sysintern ("t", SCM_UNDEFINED);
- SCM_SETCDR (scm_lisp_t, SCM_CAR (scm_lisp_t));
- scm_lisp_t = SCM_CAR (scm_lisp_t);
-
+ 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_SETCDR (scm_undefineds, scm_undefineds);
+ scm_listofnull = scm_cons (SCM_EOL, 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_sysintern("*top-level-lookup-closure*", SCM_BOOL_F);
- scm_can_use_top_level_lookup_closure_var = 1;
-
-#ifdef DEBUG_EXTENSIONS
- scm_sym_enter_frame = SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED));
- scm_sym_apply_frame = SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED));
- scm_sym_exit_frame = SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED));
- scm_sym_trace = SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED));
+ 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