summaryrefslogtreecommitdiff
path: root/libguile/eval.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/eval.c')
-rw-r--r--libguile/eval.c1889
1 files changed, 1212 insertions, 677 deletions
diff --git a/libguile/eval.c b/libguile/eval.c
index 7b2f3600e..b8c8e1b1f 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997 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
@@ -40,36 +40,116 @@
*/
-/* This file is read twice in order to produce a second debugging
- * version of scm_ceval called scm_deval. scm_deval is produced when
- * we define the preprocessor macro DEVAL.
+/* This file is read twice in order to produce debugging versions of
+ * scm_ceval and scm_apply. These functions, scm_deval and
+ * scm_dapply, are produced when we define the preprocessor macro
+ * DEVAL. The file is divided into sections which are treated
+ * differently with respect to DEVAL. The heads of these sections are
+ * marked with the string "SECTION:".
+ */
+
+
+/* SECTION: This code is compiled once.
*/
#ifndef DEVAL
+/* AIX requires this to be the first thing in the file. The #pragma
+ directive is indented so pre-ANSI compilers will ignore it, rather
+ than choke on it. */
+#ifndef __GNUC__
+# if HAVE_ALLOCA_H
+# include <alloca.h>
+# else
+# ifdef _AIX
+ #pragma alloca
+# else
+# ifndef alloca /* predefined by HP cc +Olibcalls */
+char *alloca ();
+# endif
+# endif
+# endif
+#endif
+
#include <stdio.h>
#include "_scm.h"
+#include "debug.h"
+#include "append.h"
+#include "alist.h"
+#include "sequences.h"
+#include "eq.h"
+#include "continuations.h"
+#include "throw.h"
+#include "smob.h"
+#include "markers.h"
+#include "procprop.h"
+#include "hashtab.h"
+#include "hash.h"
+#ifdef DEBUG_EXTENSIONS
+#include "debug.h"
+#endif /* DEBUG_EXTENSIONS */
+
+#include "srcprop.h"
+#include "stackchk.h"
+
+#include "eval.h"
+/* The evaluator contains a plethora of EVAL symbols.
+ * This is an attempt at explanation.
+ *
+ * The following macros should be used in code which is read twice
+ * (where the choice of evaluator is hard soldered):
+ *
+ * SCM_CEVAL is the symbol used within one evaluator to call itself.
+ * Originally, it is defined to scm_ceval, but is redefined to
+ * scm_deval during the second pass.
+ *
+ * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
+ * only side effects of expressions matter. All immediates are
+ * ignored.
+ *
+ * EVALIM is used when it is known that the expression is an
+ * immediate. (This macro never calls an evaluator.)
+ *
+ * EVALCAR evaluates the car of an expression.
+ *
+ * EVALCELLCAR is like EVALCAR, but is used when it is known that the
+ * car is a lisp cell.
+ *
+ * The following macros should be used in code which is read once
+ * (where the choice of evaluator is dynamic):
+ *
+ * XEVAL takes care of immediates without calling an evaluator. It
+ * then calls scm_ceval *or* scm_deval, depending on the debugging
+ * mode.
+ *
+ * XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
+ * depending on the debugging mode.
+ *
+ * The main motivation for keeping this plethora is efficiency
+ * together with maintainability (=> locality of code).
+ */
+
#define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR(x)) \
? *scm_lookupcar(x, env) \
: SCM_CEVAL(SCM_CAR(x), env))
#ifdef MEMOIZE_LOCALS
-#define EVALIMP(x, env) (SCM_ILOCP(x)?*scm_ilookup((x), env):x)
+#define EVALIM(x, env) (SCM_ILOCP(x)?*scm_ilookup((x), env):x)
#else
-#define EVALIMP(x, env) x
+#define EVALIM(x, env) x
#endif
#define EVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x))\
? (SCM_IMP(SCM_CAR(x)) \
- ? EVALIMP(SCM_CAR(x), env) \
+ ? EVALIM(SCM_CAR(x), env) \
: SCM_GLOC_VAL(SCM_CAR(x))) \
: EVALCELLCAR(x, env))
#ifdef DEBUG_EXTENSIONS
#define XEVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x)) \
? (SCM_IMP(SCM_CAR(x)) \
- ? EVALIMP(SCM_CAR(x), env) \
+ ? EVALIM(SCM_CAR(x), env) \
: SCM_GLOC_VAL(SCM_CAR(x))) \
: (SCM_SYMBOLP(SCM_CAR(x)) \
? *scm_lookupcar(x, env) \
@@ -78,18 +158,14 @@
#define XEVALCAR(x, env) EVALCAR(x, env)
#endif
-#define EXTEND_SCM_ENV SCM_EXTEND_SCM_ENV
+#define EXTEND_ENV SCM_EXTEND_ENV
#ifdef MEMOIZE_LOCALS
-#ifdef __STDC__
-SCM *
-scm_ilookup (SCM iloc, SCM env)
-#else
+
SCM *
scm_ilookup (iloc, env)
SCM iloc;
SCM env;
-#endif
{
register int ir = SCM_IFRAME (iloc);
register SCM er = env;
@@ -99,20 +175,16 @@ scm_ilookup (iloc, env)
for (ir = SCM_IDIST (iloc); 0 != ir; --ir)
er = SCM_CDR (er);
if (SCM_ICDRP (iloc))
- return &SCM_CDR (er);
- return &SCM_CAR (SCM_CDR (er));
+ return SCM_CDRLOC (er);
+ return SCM_CARLOC (SCM_CDR (er));
}
#endif
-#ifdef __STDC__
-SCM *
-scm_lookupcar (SCM vloc, SCM genv)
-#else
+
SCM *
scm_lookupcar (vloc, genv)
SCM vloc;
SCM genv;
-#endif
{
SCM env = genv;
register SCM *al, fl, var = SCM_CAR (vloc);
@@ -123,20 +195,20 @@ scm_lookupcar (vloc, genv)
{
if (SCM_BOOL_T == scm_procedure_p (SCM_CAR (env)))
break;
- al = &SCM_CAR (env);
+ al = SCM_CARLOC (env);
for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl))
{
if (SCM_NCONSP (fl))
if (fl == var)
{
#ifdef MEMOIZE_LOCALS
- SCM_CAR (vloc) = iloc + SCM_ICDR;
+ SCM_SETCAR (vloc, iloc + SCM_ICDR);
#endif
- return &SCM_CDR (*al);
+ return SCM_CDRLOC (*al);
}
else
break;
- al = &SCM_CDR (*al);
+ al = SCM_CDRLOC (*al);
if (SCM_CAR (fl) == var)
{
#ifdef MEMOIZE_LOCALS
@@ -147,9 +219,9 @@ scm_lookupcar (vloc, genv)
goto errout;
}
#endif
- SCM_CAR (vloc) = iloc;
+ SCM_SETCAR (vloc, iloc);
#endif
- return &SCM_CAR (*al);
+ return SCM_CARLOC (*al);
}
#ifdef MEMOIZE_LOCALS
iloc += SCM_IDINC;
@@ -179,40 +251,40 @@ scm_lookupcar (vloc, genv)
{
var = SCM_CAR (var);
errout:
- scm_everr (vloc, genv, var,
- (SCM_NULLP (env)
- ? "unbound variable: "
- : "damaged environment"),
- "");
+ /* scm_everr (vloc, genv,...) */
+ scm_misc_error (NULL,
+ SCM_NULLP (env)
+ ? "Unbound variable: %S"
+ : "Damaged environment: %S",
+ scm_listify (var, SCM_UNDEFINED));
}
#endif
- SCM_CAR (vloc) = var + 1;
+ SCM_SETCAR (vloc, var + 1);
/* Except wait...what if the var is not a vcell,
* but syntax or something....
*/
- return &SCM_CDR (var);
+ return SCM_CDRLOC (var);
}
#define unmemocar scm_unmemocar
-#ifdef __STDC__
-SCM
-scm_unmemocar (SCM form, SCM env)
-#else
+
SCM
scm_unmemocar (form, env)
SCM form;
SCM env;
-#endif
{
+#ifdef DEBUG_EXTENSIONS
register int ir;
+#endif
SCM c;
if (SCM_IMP (form))
return form;
c = SCM_CAR (form);
if (1 == (c & 7))
- SCM_CAR (form) = SCM_CAR (c - 1);
+ SCM_SETCAR (form, SCM_CAR (c - 1));
#ifdef MEMOIZE_LOCALS
+#ifdef DEBUG_EXTENSIONS
else if (SCM_ILOCP (c))
{
for (ir = SCM_IFRAME (c); ir != 0; --ir)
@@ -220,23 +292,20 @@ scm_unmemocar (form, env)
env = SCM_CAR (SCM_CAR (env));
for (ir = SCM_IDIST (c); ir != 0; --ir)
env = SCM_CDR (env);
- SCM_CAR (form) = SCM_ICDRP (c) ? env : SCM_CAR (env);
+ SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env));
}
#endif
+#endif
return form;
}
-#ifdef __STDC__
-SCM
-scm_eval_car (SCM pair, SCM env)
-#else
+
SCM
scm_eval_car (pair, env)
SCM pair;
SCM env;
-#endif
{
- return EVALCAR (pair, env);
+ return XEVALCAR (pair, env);
}
@@ -256,70 +325,60 @@ static char s_formals[] = "bad formals";
SCM scm_i_dot, scm_i_quote, scm_i_quasiquote, scm_i_lambda, scm_i_let,
scm_i_arrow, scm_i_else, scm_i_unquote, scm_i_uq_splicing, scm_i_apply;
-SCM scm_i_name;
-#ifdef DEBUG_EXTENSIONS
-static SCM enter_frame_sym, exit_frame_sym;
-#endif
+SCM scm_i_define, scm_i_and, scm_i_begin, scm_i_case, scm_i_cond,
+ scm_i_do, scm_i_if, scm_i_let, scm_i_letrec, scm_i_letstar,
+ scm_i_or, scm_i_set, scm_i_atapply, scm_i_atcall_cc;
static char s_quasiquote[] = "quasiquote";
static char s_delay[] = "delay";
+static char s_undefine[] = "undefine";
+#ifdef DEBUG_EXTENSIONS
+SCM scm_i_enter_frame, scm_i_apply_frame, scm_i_exit_frame;
+SCM scm_i_trace;
+#endif
#define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what);
-#ifdef __STDC__
-static void
-bodycheck (SCM xorig, SCM *bodyloc, char *what)
-#else
+
+static void bodycheck SCM_P ((SCM xorig, SCM *bodyloc, char *what));
+
static void
bodycheck (xorig, bodyloc, what)
SCM xorig;
SCM *bodyloc;
char *what;
-#endif
{
ASRTSYNTAX (scm_ilength (*bodyloc) >= 1, s_expression);
}
-#ifdef __STDC__
-SCM
-scm_m_quote (SCM xorig, SCM env)
-#else
+
SCM
scm_m_quote (xorig, env)
SCM xorig;
SCM env;
-#endif
{
ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, xorig, s_expression, "quote");
return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig));
}
-#ifdef __STDC__
-SCM
-scm_m_begin (SCM xorig, SCM env)
-#else
+
SCM
scm_m_begin (xorig, env)
SCM xorig;
SCM env;
-#endif
{
ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 1, xorig, s_expression, "begin");
return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig));
}
-#ifdef __STDC__
-SCM
-scm_m_if (SCM xorig, SCM env)
-#else
+
SCM
scm_m_if (xorig, env)
SCM xorig;
SCM env;
-#endif
{
int len = scm_ilength (SCM_CDR (xorig));
ASSYNT (len >= 2 && len <= 3, xorig, s_expression, "if");
@@ -327,55 +386,35 @@ scm_m_if (xorig, env)
}
-#ifdef __STDC__
-SCM
-scm_m_set (SCM xorig, SCM env)
-#else
+
SCM
scm_m_set (xorig, env)
SCM xorig;
SCM env;
-#endif
{
- SCM x;
- int len;
-
- x = SCM_CDR (xorig);
- len = scm_ilength (x);
- ASSYNT ((len > 0) && !(len & 1), xorig, s_expression, "set!");
-
- {
- SCM y;
- y = x;
- while (len)
- {
- ASSYNT (SCM_NIMP (SCM_CAR (y)) && SCM_SYMBOLP (SCM_CAR (y)),
- xorig, s_variable, "set!");
- y = SCM_CDR (SCM_CDR (x));
- len -= 2;
- }
- }
+ SCM x = SCM_CDR (xorig);
+ ASSYNT (2 == scm_ilength (x), xorig, s_expression, "set!");
+ ASSYNT (SCM_NIMP (SCM_CAR (x)) && SCM_SYMBOLP (SCM_CAR (x)),
+ xorig, s_variable, "set!");
return scm_cons (SCM_IM_SET, x);
}
#if 0
-#ifdef __STDC__
-SCM
-scm_m_vref (SCM xorig, SCM env)
-#else
+
SCM
scm_m_vref (xorig, env)
SCM xorig;
SCM env;
-#endif
{
SCM x = SCM_CDR (xorig);
ASSYNT (1 == scm_ilength (x), xorig, s_expression, s_vref);
if (SCM_NIMP(x) && UDSCM_VARIABLEP (SCM_CAR (x)))
{
- scm_everr (SCM_UNDEFINED, env, SCM_CAR(SCM_CDR(x)), s_variable,
- "global variable reference");
+ /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
+ scm_misc_error (NULL,
+ "Bad variable: %S",
+ scm_listify (SCM_CAR (SCM_CDR (x)), SCM_UNDEFINED));
}
ASSYNT (SCM_NIMP(x) && DEFSCM_VARIABLEP (SCM_CAR (x)),
xorig, s_variable, s_vref);
@@ -384,15 +423,11 @@ scm_m_vref (xorig, env)
}
-#ifdef __STDC__
-SCM
-scm_m_vset (SCM xorig, SCM env)
-#else
+
SCM
scm_m_vset (xorig, env)
SCM xorig;
SCM env;
-#endif
{
SCM x = SCM_CDR (xorig);
ASSYNT (3 == scm_ilength (x), xorig, s_expression, s_vset);
@@ -404,15 +439,11 @@ scm_m_vset (xorig, env)
#endif
-#ifdef __STDC__
-SCM
-scm_m_and (SCM xorig, SCM env)
-#else
+
SCM
scm_m_and (xorig, env)
SCM xorig;
SCM env;
-#endif
{
int len = scm_ilength (SCM_CDR (xorig));
ASSYNT (len >= 0, xorig, s_test, "and");
@@ -423,15 +454,11 @@ scm_m_and (xorig, env)
}
-#ifdef __STDC__
-SCM
-scm_m_or (SCM xorig, SCM env)
-#else
+
SCM
scm_m_or (xorig, env)
SCM xorig;
SCM env;
-#endif
{
int len = scm_ilength (SCM_CDR (xorig));
ASSYNT (len >= 0, xorig, s_test, "or");
@@ -442,15 +469,11 @@ scm_m_or (xorig, env)
}
-#ifdef __STDC__
-SCM
-scm_m_case (SCM xorig, SCM env)
-#else
+
SCM
scm_m_case (xorig, env)
SCM xorig;
SCM env;
-#endif
{
SCM proc, x = SCM_CDR (xorig);
ASSYNT (scm_ilength (x) >= 2, xorig, s_clauses, "case");
@@ -465,15 +488,11 @@ scm_m_case (xorig, env)
}
-#ifdef __STDC__
-SCM
-scm_m_cond (SCM xorig, SCM env)
-#else
+
SCM
scm_m_cond (xorig, env)
SCM xorig;
SCM env;
-#endif
{
SCM arg1, x = SCM_CDR (xorig);
int len = scm_ilength (x);
@@ -486,7 +505,7 @@ scm_m_cond (xorig, env)
if (scm_i_else == SCM_CAR (arg1))
{
ASSYNT (SCM_NULLP (SCM_CDR (x)) && len >= 2, xorig, "bad ELSE clause", "cond");
- SCM_CAR (arg1) = SCM_BOOL_T;
+ SCM_SETCAR (arg1, SCM_BOOL_T);
}
if (len >= 2 && scm_i_arrow == SCM_CAR (SCM_CDR (arg1)))
ASSYNT (3 == len && SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1)))),
@@ -497,15 +516,11 @@ scm_m_cond (xorig, env)
}
-#ifdef __STDC__
-SCM
-scm_m_lambda (SCM xorig, SCM env)
-#else
+
SCM
scm_m_lambda (xorig, env)
SCM xorig;
SCM env;
-#endif
{
SCM proc, x = SCM_CDR (xorig);
if (scm_ilength (x) < 2)
@@ -536,38 +551,33 @@ scm_m_lambda (xorig, env)
(proc)
badforms:scm_wta (xorig, s_formals, "lambda");
memlambda:
- bodycheck (xorig, &SCM_CDR (x), "lambda");
+ bodycheck (xorig, SCM_CDRLOC (x), "lambda");
return scm_cons (SCM_IM_LAMBDA, SCM_CDR (xorig));
}
-#ifdef __STDC__
-SCM
-scm_m_letstar (SCM xorig, SCM env)
-#else
+
SCM
scm_m_letstar (xorig, env)
SCM xorig;
SCM env;
-#endif
{
SCM x = SCM_CDR (xorig), arg1, proc, vars = SCM_EOL, *varloc = &vars;
int len = scm_ilength (x);
ASSYNT (len >= 2, xorig, s_body, "let*");
proc = SCM_CAR (x);
ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, "let*");
- while SCM_NIMP
- (proc)
+ while SCM_NIMP (proc)
{
arg1 = SCM_CAR (proc);
ASSYNT (2 == scm_ilength (arg1), xorig, s_bindings, "let*");
ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), xorig, s_variable, "let*");
*varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
- varloc = &SCM_CDR (SCM_CDR (*varloc));
+ varloc = SCM_CDRLOC (SCM_CDR (*varloc));
proc = SCM_CDR (proc);
}
x = scm_cons (vars, SCM_CDR (x));
- bodycheck (xorig, &SCM_CDR (x), "let*");
+ bodycheck (xorig, SCM_CDRLOC (x), "let*");
return scm_cons (SCM_IM_LETSTAR, x);
}
@@ -586,15 +596,11 @@ scm_m_letstar (xorig, env)
*/
-#ifdef __STDC__
-SCM
-scm_m_do (SCM xorig, SCM env)
-#else
+
SCM
scm_m_do (xorig, env)
SCM xorig;
SCM env;
-#endif
{
SCM x = SCM_CDR (xorig), arg1, proc;
SCM vars = SCM_EOL, inits = SCM_EOL, steps = SCM_EOL;
@@ -614,44 +620,33 @@ scm_m_do (xorig, env)
vars = scm_cons (SCM_CAR (arg1), vars); /* variable */
arg1 = SCM_CDR (arg1);
*initloc = scm_cons (SCM_CAR (arg1), SCM_EOL); /* init */
- initloc = &SCM_CDR (*initloc);
+ 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_CDR (*steploc);
+ steploc = SCM_CDRLOC (*steploc);
proc = SCM_CDR (proc);
}
x = SCM_CDR (x);
ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, xorig, s_test, "do");
x = scm_cons2 (SCM_CAR (x), SCM_CDR (x), steps);
x = scm_cons2 (vars, inits, x);
- bodycheck (xorig, &SCM_CAR (SCM_CDR (SCM_CDR (x))), "do");
+ bodycheck (xorig, SCM_CARLOC (SCM_CDR (SCM_CDR (x))), "do");
return scm_cons (SCM_IM_DO, x);
}
-/* evalcar is small version of inline EVALCAR when we don't care about speed */
-#ifdef __STDC__
-static SCM
-evalcar (SCM x, SCM env)
-#else
-static SCM
-evalcar (x, env)
- SCM x;
- SCM env;
-#endif
-{
- return XEVALCAR (x, env);
-}
+/* evalcar is small version of inline EVALCAR when we don't care about
+ * speed
+ */
+#define evalcar scm_eval_car
+
+
+static SCM iqq SCM_P ((SCM form, SCM env, int depth));
-#ifdef __STDC__
-static SCM
-iqq (SCM form, SCM env, int depth)
-#else
static SCM
iqq (form, env, depth)
SCM form;
SCM env;
int depth;
-#endif
{
SCM tmp;
int edepth = depth;
@@ -679,7 +674,6 @@ iqq (form, env, depth)
--depth;
label:
form = SCM_CDR (form);
- /* !!! might need a check here to be sure that form isn't a struct. */
SCM_ASSERT (SCM_NIMP (form) && SCM_ECONSP (form) && SCM_NULLP (SCM_CDR (form)),
form, SCM_ARG1, s_quasiquote);
if (0 == depth)
@@ -697,30 +691,22 @@ iqq (form, env, depth)
/* Here are acros which return values rather than code. */
-#ifdef __STDC__
-SCM
-scm_m_quasiquote (SCM xorig, SCM env)
-#else
+
SCM
scm_m_quasiquote (xorig, env)
SCM xorig;
SCM env;
-#endif
{
SCM x = SCM_CDR (xorig);
ASSYNT (scm_ilength (x) == 1, xorig, s_expression, s_quasiquote);
return iqq (SCM_CAR (x), env, 1);
}
-#ifdef __STDC__
-SCM
-scm_m_delay (SCM xorig, SCM env)
-#else
+
SCM
scm_m_delay (xorig, env)
SCM xorig;
SCM env;
-#endif
{
ASSYNT (scm_ilength (xorig) == 2, xorig, s_expression, s_delay);
xorig = SCM_CDR (xorig);
@@ -728,14 +714,12 @@ scm_m_delay (xorig, env)
env));
}
-#ifdef __STDC__
-static SCM
-env_top_level (SCM env)
-#else
+
+static SCM env_top_level SCM_P ((SCM env));
+
static SCM
env_top_level (env)
SCM env;
-#endif
{
while (SCM_NIMP(env))
{
@@ -746,15 +730,11 @@ env_top_level (env)
return SCM_BOOL_F;
}
-#ifdef __STDC__
-SCM
-scm_m_define (SCM x, SCM env)
-#else
+
SCM
scm_m_define (x, env)
SCM x;
SCM env;
-#endif
{
SCM proc, arg1 = x;
x = SCM_CDR (x);
@@ -772,6 +752,10 @@ scm_m_define (x, env)
if (SCM_TOP_LEVEL (env))
{
x = evalcar (x, env);
+#ifdef DEBUG_EXTENSIONS
+ if (SCM_REC_PROCNAMES_P && SCM_NIMP (x) && SCM_CLOSUREP (x))
+ scm_set_procedure_property_x (x, scm_i_name, proc);
+#endif
arg1 = scm_sym2vcell (proc, env_top_level (env), SCM_BOOL_T);
#if 0
#ifndef RECKLESS
@@ -783,11 +767,7 @@ scm_m_define (x, env)
if (5 <= scm_verbose && SCM_UNDEFINED != SCM_CDR (arg1))
scm_warn ("redefining ", SCM_CHARS (proc));
#endif
-#ifdef DEBUG_EXTENSIONS
- if (RECORD_PROCNAMES && SCM_NIMP (x) && SCM_CLOSUREP (x))
- scm_set_procedure_property_x (x, scm_i_name, proc);
-#endif
- SCM_CDR (arg1) = x;
+ SCM_SETCDR (arg1, x);
#ifdef SICP
return scm_cons2 (scm_i_quote, SCM_CAR (arg1), SCM_EOL);
#else
@@ -796,17 +776,45 @@ scm_m_define (x, env)
}
return scm_cons2 (SCM_IM_DEFINE, proc, x);
}
-/* end of acros */
-#ifdef __STDC__
-SCM
-scm_m_letrec (SCM xorig, SCM env)
+SCM
+scm_m_undefine (x, env)
+ SCM x, env;
+{
+ SCM arg1 = x;
+ x = SCM_CDR (x);
+ ASSYNT (SCM_TOP_LEVEL (env), arg1, "bad placement ", s_undefine);
+ ASSYNT (SCM_NIMP (x) && SCM_CONSP (x) && SCM_CDR (x) == SCM_EOL,
+ arg1, s_expression, s_undefine);
+ x = SCM_CAR (x);
+ ASSYNT (SCM_NIMP (x) && SCM_SYMBOLP (x), arg1, s_variable, s_undefine);
+ arg1 = scm_sym2vcell (x, env_top_level (env), SCM_BOOL_F);
+ ASSYNT (SCM_NFALSEP (arg1) && !SCM_UNBNDP (SCM_CDR (arg1)),
+ x, "variable already unbound ", s_undefine);
+#if 0
+#ifndef RECKLESS
+ if (SCM_NIMP (SCM_CDR (arg1)) && ((SCM) SCM_SNAME (SCM_CDR (arg1)) == x))
+ scm_warn ("undefining built-in ", SCM_CHARS (x));
+ else
+#endif
+ if (5 <= scm_verbose && SCM_UNDEFINED != SCM_CDR (arg1))
+ scm_warn ("redefining ", SCM_CHARS (x));
+#endif
+ SCM_SETCDR (arg1, SCM_UNDEFINED);
+#ifdef SICP
+ return SCM_CAR (arg1);
#else
+ return SCM_UNSPECIFIED;
+#endif
+}
+
+/* end of acros */
+
+
SCM
scm_m_letrec (xorig, env)
SCM xorig;
SCM env;
-#endif
{
SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */
char *what = SCM_CHARS (SCM_CAR (xorig));
@@ -826,24 +834,20 @@ scm_m_letrec (xorig, env)
ASRTSYNTAX (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), s_variable);
vars = scm_cons (SCM_CAR (arg1), vars);
*initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
- initloc = &SCM_CDR (*initloc);
+ initloc = SCM_CDRLOC (*initloc);
}
while SCM_NIMP
(proc = SCM_CDR (proc));
cdrx = scm_cons2 (vars, inits, SCM_CDR (x));
- bodycheck (xorig, &SCM_CDR (SCM_CDR (cdrx)), what);
+ bodycheck (xorig, SCM_CDRLOC (SCM_CDR (cdrx)), what);
return scm_cons (SCM_IM_LETREC, cdrx);
}
-#ifdef __STDC__
-SCM
-scm_m_let (SCM xorig, SCM env)
-#else
+
SCM
scm_m_let (xorig, env)
SCM xorig;
SCM env;
-#endif
{
SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */
SCM x = cdrx, proc, arg1, name; /* structure traversers */
@@ -872,9 +876,9 @@ scm_m_let (xorig, env)
ASSYNT (2 == scm_ilength (arg1), xorig, s_bindings, "let");
ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), xorig, s_variable, "let");
*varloc = scm_cons (SCM_CAR (arg1), SCM_EOL);
- varloc = &SCM_CDR (*varloc);
+ varloc = SCM_CDRLOC (*varloc);
*initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL);
- initloc = &SCM_CDR (*initloc);
+ initloc = SCM_CDRLOC (*initloc);
proc = SCM_CDR (proc);
}
return
@@ -885,46 +889,238 @@ scm_m_let (xorig, env)
}
-#ifdef __STDC__
-SCM
-scm_m_apply (SCM xorig, SCM env)
-#else
+
SCM
scm_m_apply (xorig, env)
SCM xorig;
SCM env;
-#endif
{
ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, xorig, s_expression, "@apply");
return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig));
}
-#define s_atcall_cc (SCM_ISYMSCM_CHARS(SCM_IM_CONT)+1)
+#define s_atcall_cc (SCM_ISYMCHARS(SCM_IM_CONT)+1)
+
-#ifdef __STDC__
-SCM
-scm_m_cont (SCM xorig, SCM env)
-#else
SCM
scm_m_cont (xorig, env)
SCM xorig;
SCM env;
-#endif
{
ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, xorig, s_expression, "@call-with-current-continuation");
return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));
}
+/* scm_unmemocopy takes a memoized expression together with its
+ * environment and rewrites it to its original form. Thus, it is the
+ * inversion of the rewrite rules above. The procedure is not
+ * optimized for speed. It's used in scm_iprin1 when printing the
+ * 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.
+ */
+
+static SCM unmemocopy SCM_P ((SCM x, SCM env));
+
+static SCM
+unmemocopy (x, env)
+ SCM x;
+ SCM env;
+{
+ SCM ls, z;
+#ifdef DEBUG_EXTENSIONS
+ SCM p;
+#endif
+ if (SCM_NCELLP (x) || SCM_NECONSP (x))
+ return x;
+#ifdef DEBUG_EXTENSIONS
+ p = scm_whash_lookup (scm_source_whash, x);
+#endif
+ switch (SCM_TYP7 (x))
+ {
+ case (127 & SCM_IM_AND):
+ ls = z = scm_cons (scm_i_and, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_BEGIN):
+ ls = z = scm_cons (scm_i_begin, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_CASE):
+ ls = z = scm_cons (scm_i_case, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_COND):
+ ls = z = scm_cons (scm_i_cond, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_DO):
+ ls = scm_cons (scm_i_do, SCM_UNSPECIFIED);
+ goto transform;
+ case (127 & SCM_IM_IF):
+ ls = z = scm_cons (scm_i_if, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_LET):
+ ls = scm_cons (scm_i_let, SCM_UNSPECIFIED);
+ goto transform;
+ case (127 & SCM_IM_LETREC):
+ {
+ SCM f, v, e, s;
+ ls = scm_cons (scm_i_letrec, SCM_UNSPECIFIED);
+ transform:
+ x = SCM_CDR (x);
+ f = v = SCM_CAR (x);
+ x = SCM_CDR (x);
+ z = EXTEND_ENV (f, SCM_EOL, env);
+ e = scm_reverse (unmemocopy (SCM_CAR (x),
+ SCM_CAR (ls) == scm_i_letrec ? z : env));
+ env = z;
+ s = SCM_CAR (ls) == scm_i_do
+ ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x))), env))
+ : f;
+ z = SCM_EOL;
+ do
+ {
+ z = scm_acons (SCM_CAR (v),
+ scm_cons (SCM_CAR (e),
+ 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);
+ }
+ while SCM_NIMP (v);
+ z = scm_cons (z, SCM_UNSPECIFIED);
+ SCM_SETCDR (ls, z);
+ if (SCM_CAR (ls) == scm_i_do)
+ {
+ x = SCM_CDR (x);
+ SCM_SETCDR (z, scm_cons (unmemocopy (SCM_CAR (x), env),
+ SCM_UNSPECIFIED));
+ z = SCM_CDR (z);
+ x = (SCM) (SCM_CARLOC (SCM_CDR (x)) - 1);
+ }
+ break;
+ }
+ case (127 & SCM_IM_LETSTAR):
+ {
+ SCM b, y;
+ x = SCM_CDR (x);
+ b = SCM_CAR (x);
+ y = SCM_EOL;
+ if SCM_IMP (b)
+ {
+ env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
+ goto letstar;
+ }
+ y = z = scm_acons (SCM_CAR (b),
+ unmemocar (
+ scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b)), env), SCM_EOL), env),
+ SCM_UNSPECIFIED);
+ env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
+ b = SCM_CDR (SCM_CDR (b));
+ if (SCM_IMP (b))
+ {
+ SCM_SETCDR (y, SCM_EOL);
+ ls = scm_cons (scm_i_let, z = scm_cons (y, SCM_UNSPECIFIED));
+ break;
+ }
+ do
+ {
+ SCM_SETCDR (z, scm_acons (SCM_CAR (b),
+ unmemocar (
+ scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b)), env), SCM_EOL), env),
+ SCM_UNSPECIFIED));
+ z = SCM_CDR (z);
+ env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
+ b = SCM_CDR (SCM_CDR (b));
+ }
+ while SCM_NIMP (b);
+ SCM_SETCDR (z, SCM_EOL);
+ letstar:
+ ls = scm_cons (scm_i_letstar, z = scm_cons (y, SCM_UNSPECIFIED));
+ break;
+ }
+ case (127 & SCM_IM_OR):
+ ls = z = scm_cons (scm_i_or, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_LAMBDA):
+ x = SCM_CDR (x);
+ ls = scm_cons (scm_i_lambda,
+ z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED));
+ env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, env);
+ break;
+ case (127 & SCM_IM_QUOTE):
+ ls = z = scm_cons (scm_i_quote, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_SET):
+ ls = z = scm_cons (scm_i_set, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_DEFINE):
+ {
+ SCM n;
+ x = SCM_CDR (x);
+ ls = scm_cons (scm_i_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))));
+ break;
+ }
+ case (127 & SCM_MAKISYM (0)):
+ z = SCM_CAR (x);
+ if (!SCM_ISYMP (z))
+ goto unmemo;
+ switch SCM_ISYMNUM (z)
+ {
+ case (SCM_ISYMNUM (SCM_IM_APPLY)):
+ ls = z = scm_cons (scm_i_atapply, SCM_UNSPECIFIED);
+ goto loop;
+ case (SCM_ISYMNUM (SCM_IM_CONT)):
+ ls = z = scm_cons (scm_i_atcall_cc, SCM_UNSPECIFIED);
+ goto loop;
+ default:
+ /* appease the Sun compiler god: */ ;
+ }
+ unmemo:
+ default:
+ ls = z = unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env),
+ SCM_UNSPECIFIED),
+ env);
+ }
+loop:
+ while (SCM_CELLP (x = SCM_CDR (x)) && SCM_ECONSP (x))
+ {
+ SCM_SETCDR (z, unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env),
+ SCM_UNSPECIFIED),
+ env));
+ z = SCM_CDR (z);
+ }
+ SCM_SETCDR (z, x);
+#ifdef DEBUG_EXTENSIONS
+ if (SCM_NFALSEP (p))
+ scm_whash_insert (scm_source_whash, ls, p);
+#endif
+ return ls;
+}
+
+
+SCM
+scm_unmemocopy (x, env)
+ SCM x;
+ SCM env;
+{
+ if (SCM_NNULLP (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)));
+ else
+ return unmemocopy (x, env);
+}
+
#ifndef RECKLESS
-#ifdef __STDC__
-int
-scm_badargsp (SCM formals, SCM args)
-#else
+
int
scm_badargsp (formals, args)
SCM formals;
SCM args;
-#endif
{
while SCM_NIMP
(formals)
@@ -944,69 +1140,224 @@ scm_badargsp (formals, args)
long scm_tc16_macro;
+
+SCM
+scm_eval_args (l, env)
+ SCM l;
+ SCM env;
+{
+ SCM res = SCM_EOL, *lloc = &res;
+ while (SCM_NIMP (l))
+ {
+ *lloc = scm_cons (EVALCAR (l, env), SCM_EOL);
+ lloc = SCM_CDRLOC (*lloc);
+ l = SCM_CDR (l);
+ }
+ return res;
+}
+
+
+/* The SCM_CEVAL and SCM_APPLY functions use this function instead of
+ calling setjmp directly, to make sure that local variables don't
+ have their values clobbered by a longjmp.
+
+ According to Harbison & Steele, "Automatic variables local to the
+ function containing setjmp are guaranteed to have their correct
+ value in ANSI C only if they have a volatile-qualified type or if
+ their values were not changed between the original call to setjmp
+ and the corresponding longjmp call."
+
+ SCM_CEVAL and SCM_APPLY are too complex for me to see how to meet
+ the second condition, and making x and env volatile would be a
+ speed problem, so we'll just trivially meet the first, by having no
+ "automatic variables local to the function containing setjmp." */
+
+/* Actually, this entire approach is bogus, because setjmp ends up
+ capturing the stack frame of the wrapper function, which then
+ returns, rendering the jump buffer invalid. Duh. Gotta find a
+ better way... -JimB */
+#define safe_setjmp(x) setjmp (x)
+static int
+unsafe_setjmp (jmp_buf env)
+{
+ /* I think ANSI requires us to write the function this way, instead
+ of just saying "return setjmp (env)". Maybe I'm being silly.
+ See Harbison & Steele, third edition, p. 353. */
+ int val;
+ val = setjmp (env);
+ return val;
+}
+
+
#endif /* !DEVAL */
-#ifdef DEVAL
-#undef SCM_EVAL_ARGS
-#define SCM_EVAL_ARGS scm_deval_args
+
+/* SECTION: This code is specific for the debugging support. One
+ * branch is read when DEVAL isn't defined, the other when DEVAL is
+ * defined.
+ */
+
+#ifndef DEVAL
+
+#define SCM_APPLY scm_apply
+#define PREP_APPLY(proc, args)
+#define ENTER_APPLY
+#define RETURN(x) return x;
+#ifdef STACK_CHECKING
+#ifndef NO_CEVAL_STACK_CHECKING
+#define EVAL_STACK_CHECKING
+#endif
+#endif
+
+#else /* !DEVAL */
+
#undef SCM_CEVAL
#define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
#undef SCM_APPLY
#define SCM_APPLY scm_dapply
+#undef PREP_APPLY
+#define PREP_APPLY(p, l) \
+{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
+#undef ENTER_APPLY
+#define ENTER_APPLY \
+{\
+ SCM_SET_ARGSREADY (debug);\
+ if (CHECK_APPLY)\
+ if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
+ {\
+ SCM tmp, tail = SCM_TRACED_FRAME_P (debug) ? SCM_BOOL_T : SCM_BOOL_F;\
+ SCM_SET_TRACED_FRAME (debug); \
+ SCM_APPLY_FRAME_P = 0; \
+ SCM_TRACE_P = 0; \
+ SCM_RESET_DEBUG_MODE; \
+ if (SCM_CHEAPTRAPS_P)\
+ {\
+ tmp = scm_make_debugobj (&debug);\
+ scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
+ }\
+ else\
+ {\
+ scm_make_cont (&tmp);\
+ if (!safe_setjmp (SCM_JMPBUF (tmp)))\
+ scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
+ }\
+ }\
+}
#undef RETURN
#define RETURN(e) {proc = (e); goto exit;}
-#else
-#define SCM_EVAL_ARGS scm_eval_args
-#define RETURN(x) return x;
+#ifdef STACK_CHECKING
+#ifndef EVAL_STACK_CHECKING
+#define EVAL_STACK_CHECKING
+#endif
#endif
-SCM
-SCM_EVAL_ARGS (l, env)
- SCM l, env;
+/* scm_ceval_ptr points to the currently selected evaluator.
+ * *fixme*: Although efficiency is important here, this state variable
+ * should probably not be a global. It should be related to the
+ * current repl.
+ */
+
+
+SCM (*scm_ceval_ptr) SCM_P ((SCM x, SCM env));
+
+/* scm_last_debug_frame contains a pointer to the last debugging
+ * information stack frame. It is accessed very often from the
+ * debugging evaluator, so it should probably not be indirectly
+ * addressed. Better to save and restore it from the current root at
+ * any stack swaps.
+ */
+
+#ifndef USE_THREADS
+scm_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;
+
+int scm_debug_mode, scm_check_entry_p, scm_check_apply_p, scm_check_exit_p;
+
+scm_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, "trace", 0, "*Trace mode." },
+ { SCM_OPTION_BOOLEAN, "procnames", 1,
+ "Record procedure names at definition." },
+ { SCM_OPTION_BOOLEAN, "backwards", 0,
+ "Display backtrace in anti-chronological order." },
+ { SCM_OPTION_INTEGER, "indent", 10, "Maximal indentation in backtrace." },
+ { SCM_OPTION_INTEGER, "frames", 3,
+ "Maximum number of tail-recursive frames in backtrace." },
+ { SCM_OPTION_INTEGER, "maxdepth", 1000,
+ "Maximal number of stored backtrace frames." },
+ { 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 (0 = no check)." }
+};
+
+scm_option scm_evaluator_trap_table[] = {
+ { 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
+scm_deval_args (l, env, lloc)
+ SCM l, env, *lloc;
{
- SCM res = SCM_EOL, *lloc = &res;
+ SCM *res = lloc;
while (SCM_NIMP (l))
{
*lloc = scm_cons (EVALCAR (l, env), SCM_EOL);
- lloc = &SCM_CDR (*lloc);
+ lloc = SCM_CDRLOC (*lloc);
l = SCM_CDR (l);
}
- return res;
+ return *res;
}
-#if 0
-#ifdef __STDC__
-SCM
-scm_ceval (SCM x, SCM env)
+#endif /* !DEVAL */
+
+
+/* SECTION: Some local definitions for the evaluator.
+ */
+
+#ifndef DEVAL
+#ifdef SCM_FLOATS
+#define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
#else
+#define CHECK_EQVISH(A,B) ((A) == (B))
+#endif
+#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.
+ */
+
+#if 0
+
SCM
scm_ceval (x, env)
SCM x;
SCM env;
-#endif
{}
#endif
#if 0
-#ifdef __STDC__
-SCM
-scm_deval (SCM x, SCM env)
-#else
+
SCM
scm_deval (x, env)
SCM x;
SCM env;
-#endif
{}
#endif
-#ifdef SCM_FLOATS
-#define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
-#else
-#define CHECK_EQVISH(A,B) ((A) == (B))
-#endif
-
-SCM
+SCM
SCM_CEVAL (x, env)
SCM x;
SCM env;
@@ -1016,14 +1367,80 @@ SCM_CEVAL (x, env)
SCM *lloc;
SCM arg1;
} t;
- SCM proc;
- SCM arg2;
-
- SCM_CHECK_STACK;
-
- loop:
+ SCM proc, arg2;
+#ifdef DEVAL
+ scm_debug_frame debug;
+ scm_debug_info *debug_info_end;
+ debug.prev = scm_last_debug_frame;
+ debug.status = scm_debug_eframe_size;
+ debug.vect = (scm_debug_info *) alloca (scm_debug_eframe_size
+ * sizeof (debug.vect[0]));
+ debug.info = debug.vect;
+ debug_info_end = debug.vect + scm_debug_eframe_size;
+ scm_last_debug_frame = &debug;
+#endif
+#ifdef EVAL_STACK_CHECKING
+ if (SCM_STACK_OVERFLOW_P ((SCM_STACKITEM *) &proc)
+ && scm_stack_checking_enabled_p)
+ {
+#ifdef DEVAL
+ debug.info->e.exp = x;
+ debug.info->e.env = env;
+#endif
+ scm_report_stack_overflow ();
+ }
+#endif
+#ifdef DEVAL
+ goto start;
+#endif
+loopnoap:
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+loop:
+#ifdef DEVAL
+ SCM_CLEAR_ARGSREADY (debug);
+ if (SCM_OVERFLOWP (debug))
+ --debug.info;
+ else if (++debug.info >= debug_info_end)
+ {
+ SCM_SET_OVERFLOW (debug);
+ debug.info -= 2;
+ }
+start:
+ debug.info->e.exp = x;
+ debug.info->e.env = env;
+ if (CHECK_ENTRY)
+ if (SCM_ENTER_FRAME_P || (SCM_BREAKPOINTS_P && SRCBRKP (x)))
+ {
+ SCM tail = SCM_TAILRECP (debug) ? SCM_BOOL_T : SCM_BOOL_F;
+ SCM_SET_TAILREC (debug);
+ SCM_ENTER_FRAME_P = 0;
+ SCM_RESET_DEBUG_MODE;
+ if (SCM_CHEAPTRAPS_P)
+ t.arg1 = scm_make_debugobj (&debug);
+ else
+ {
+ scm_make_cont (&t.arg1);
+ if (safe_setjmp (SCM_JMPBUF (t.arg1)))
+ {
+ x = SCM_THROW_VALUE (t.arg1);
+ if (SCM_IMP (x))
+ {
+ RETURN (x);
+ }
+ else
+ /* This gives the possibility for the debugger to
+ modify the source expression before evaluation. */
+ goto dispatch;
+ }
+ }
+ scm_ithrow (scm_i_enter_frame,
+ scm_cons2 (t.arg1, tail,
+ scm_cons (scm_unmemocopy (x, env), SCM_EOL)),
+ 0);
+ }
+dispatch:
+#endif
SCM_ASYNC_TICK;
-
switch (SCM_TYP7 (x))
{
case scm_tcs_symbols:
@@ -1042,10 +1459,12 @@ SCM_CEVAL (x, env)
}
else
x = t.arg1;
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop;
case (127 & SCM_IM_BEGIN):
-
+ cdrxnoap:
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
cdrxbegin:
x = SCM_CDR (x);
@@ -1061,13 +1480,13 @@ SCM_CEVAL (x, env)
if (SCM_NCELLP (SCM_CAR (x)))
{
x = SCM_CAR (x);
- RETURN (SCM_IMP (x) ? EVALIMP (x, env) : SCM_GLOC_VAL (x));
+ RETURN (SCM_IMP (x) ? EVALIM (x, env) : SCM_GLOC_VAL (x))
}
if (SCM_SYMBOLP (SCM_CAR (x)))
{
retval:
- RETURN (*scm_lookupcar (x, env));
+ RETURN (*scm_lookupcar (x, env))
}
x = SCM_CAR (x);
@@ -1083,6 +1502,7 @@ SCM_CEVAL (x, env)
if (scm_i_else == SCM_CAR (proc))
{
x = SCM_CDR (proc);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto begin;
}
proc = SCM_CAR (proc);
@@ -1091,12 +1511,13 @@ SCM_CEVAL (x, env)
if (CHECK_EQVISH (SCM_CAR (proc), t.arg1))
{
x = SCM_CDR (SCM_CAR (x));
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto begin;
}
proc = SCM_CDR (proc);
}
}
- RETURN (SCM_UNSPECIFIED);
+ RETURN (SCM_UNSPECIFIED)
case (127 & SCM_IM_COND):
@@ -1107,19 +1528,24 @@ SCM_CEVAL (x, env)
if (SCM_NFALSEP (t.arg1))
{
x = SCM_CDR (proc);
- if (SCM_NULLP (x))
+ if SCM_NULLP (x)
{
- RETURN (t.arg1);
+ RETURN (t.arg1)
}
if (scm_i_arrow != SCM_CAR (x))
- goto begin;
+ {
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
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;
goto evap1;
}
}
- RETURN (SCM_UNSPECIFIED);
+ RETURN (SCM_UNSPECIFIED)
case (127 & SCM_IM_DO):
@@ -1131,7 +1557,7 @@ SCM_CEVAL (x, env)
t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
proc = SCM_CDR (proc);
}
- env = EXTEND_SCM_ENV (SCM_CAR (x), t.arg1, env);
+ 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)))
{
@@ -1142,13 +1568,12 @@ SCM_CEVAL (x, env)
}
for (t.arg1 = SCM_EOL, proc = SCM_CDR (SCM_CDR (x)); SCM_NIMP (proc); proc = SCM_CDR (proc))
t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); /* steps */
- env = EXTEND_SCM_ENV (SCM_CAR (SCM_CAR (env)), t.arg1, SCM_CDR (env));
+ env = EXTEND_ENV (SCM_CAR (SCM_CAR (env)), t.arg1, SCM_CDR (env));
}
x = SCM_CDR (proc);
if (SCM_NULLP (x))
- {
- RETURN (SCM_UNSPECIFIED);
- }
+ RETURN (SCM_UNSPECIFIED);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto begin;
@@ -1160,6 +1585,7 @@ SCM_CEVAL (x, env)
{
RETURN (SCM_UNSPECIFIED);
}
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop;
@@ -1172,14 +1598,14 @@ SCM_CEVAL (x, env)
t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
}
while (SCM_NIMP (proc = SCM_CDR (proc)));
- env = EXTEND_SCM_ENV (SCM_CAR (x), t.arg1, env);
+ env = EXTEND_ENV (SCM_CAR (x), t.arg1, env);
x = SCM_CDR (x);
- goto cdrxbegin;
+ goto cdrxnoap;
case (127 & SCM_IM_LETREC):
x = SCM_CDR (x);
- env = EXTEND_SCM_ENV (SCM_CAR (x), scm_undefineds, env);
+ env = EXTEND_ENV (SCM_CAR (x), scm_undefineds, env);
x = SCM_CDR (x);
proc = SCM_CAR (x);
t.arg1 = SCM_EOL;
@@ -1188,8 +1614,8 @@ SCM_CEVAL (x, env)
t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
}
while (SCM_NIMP (proc = SCM_CDR (proc)));
- SCM_CDR (SCM_CAR (env)) = t.arg1;
- goto cdrxbegin;
+ SCM_SETCDR (SCM_CAR (env), t.arg1);
+ goto cdrxnoap;
case (127 & SCM_IM_LETSTAR):
@@ -1197,17 +1623,17 @@ SCM_CEVAL (x, env)
proc = SCM_CAR (x);
if (SCM_IMP (proc))
{
- env = EXTEND_SCM_ENV (SCM_EOL, SCM_EOL, env);
- goto cdrxbegin;
+ env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
+ goto cdrxnoap;
}
do
{
t.arg1 = SCM_CAR (proc);
proc = SCM_CDR (proc);
- env = EXTEND_SCM_ENV (t.arg1, EVALCAR (proc, env), env);
+ env = EXTEND_ENV (t.arg1, EVALCAR (proc, env), env);
}
while (SCM_NIMP (proc = SCM_CDR (proc)));
- goto cdrxbegin;
+ goto cdrxnoap;
case (127 & SCM_IM_OR):
x = SCM_CDR (x);
@@ -1221,6 +1647,7 @@ SCM_CEVAL (x, env)
}
x = t.arg1;
}
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop;
@@ -1233,16 +1660,15 @@ SCM_CEVAL (x, env)
case (127 & SCM_IM_SET):
- set_some_more:
x = SCM_CDR (x);
proc = SCM_CAR (x);
- switch (7 & (int)proc)
+ switch (7 & (int) proc)
{
case 0:
t.lloc = scm_lookupcar (x, env);
break;
case 1:
- t.lloc = &SCM_GLOC_VAL (proc);
+ t.lloc = SCM_GLOC_VAL_LOC (proc);
break;
#ifdef MEMOIZE_LOCALS
case 4:
@@ -1252,8 +1678,6 @@ SCM_CEVAL (x, env)
}
x = SCM_CDR (x);
*t.lloc = EVALCAR (x, env);
- if (!SCM_NULLP (SCM_CDR(x)))
- goto set_some_more;
#ifdef SICP
RETURN (*t.lloc);
#else
@@ -1266,15 +1690,18 @@ SCM_CEVAL (x, env)
proc = SCM_CAR (x);
x = SCM_CDR (x);
x = evalcar (x, env);
+#ifdef DEBUG_EXTENSIONS
+ if (SCM_REC_PROCNAMES_P && SCM_NIMP (x) && SCM_CLOSUREP (x))
+ scm_set_procedure_property_x (x, scm_i_name, proc);
+#endif
env = SCM_CAR (env);
SCM_DEFER_INTS;
- SCM_CAR (env) = scm_cons (proc, SCM_CAR (env));
- SCM_CDR (env) = scm_cons (x, SCM_CDR (env));
+ SCM_SETCAR (env, scm_cons (proc, SCM_CAR (env)));
+ SCM_SETCDR (env, scm_cons (x, SCM_CDR (env)));
SCM_ALLOW_INTS;
RETURN (SCM_UNSPECIFIED);
-
/* new syntactic forms go here. */
case (127 & SCM_MAKISYM (0)):
proc = SCM_CAR (x);
@@ -1291,7 +1718,7 @@ SCM_CEVAL (x, env)
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);
+ RETURN (SCM_UNSPECIFIED)
#endif
case (SCM_ISYMNUM (SCM_IM_APPLY)):
@@ -1300,13 +1727,17 @@ SCM_CEVAL (x, env)
SCM_ASRTGO (SCM_NIMP (proc), badfun);
if (SCM_CLOSUREP (proc))
{
+ PREP_APPLY (proc, SCM_EOL);
t.arg1 = SCM_CDR (SCM_CDR (x));
t.arg1 = EVALCAR (t.arg1, env);
+#ifdef DEVAL
+ debug.info->a.args = t.arg1;
+#endif
#ifndef RECKLESS
if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), t.arg1))
goto wrongnumargs;
#endif
- env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), t.arg1, SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), t.arg1, SCM_ENV (proc));
x = SCM_CODE (proc);
goto cdrxbegin;
}
@@ -1315,15 +1746,17 @@ SCM_CEVAL (x, env)
case (SCM_ISYMNUM (SCM_IM_CONT)):
scm_make_cont (&t.arg1);
- if (setjmp (SCM_JMPBUF (t.arg1)))
+ if (safe_setjmp (SCM_JMPBUF (t.arg1)))
{
SCM val;
val = SCM_THROW_VALUE (t.arg1);
- RETURN (val);;
+ 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;
goto evap1;
default:
@@ -1333,8 +1766,10 @@ SCM_CEVAL (x, env)
default:
proc = x;
badfun:
- scm_everr (x, env, proc, "Wrong type to apply: ", "");
-
+ /* scm_everr (x, env,...) */
+ scm_misc_error (NULL,
+ "Wrong type to apply: %S",
+ scm_listify (proc, SCM_UNDEFINED));
case scm_tc7_vector:
case scm_tc7_wvect:
case scm_tc7_bvect:
@@ -1401,14 +1836,37 @@ SCM_CEVAL (x, env)
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 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));
+ SCM_ALLOW_INTS;
+ goto dispatch;
+ }
+ /* Prevent memoizing of debug info expression. */
+ 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_CAR (x) = SCM_CAR (t.arg1);
- SCM_CDR (x) = SCM_CDR (t.arg1);
+ SCM_SETCAR (x, SCM_CAR (t.arg1));
+ SCM_SETCDR (x, SCM_CDR (t.arg1));
SCM_ALLOW_INTS;
- goto loop;
+ goto loopnoap;
case 1:
if (SCM_NIMP (x = t.arg1))
- goto loop;
+ goto loopnoap;
case 0:
RETURN (t.arg1);
}
@@ -1443,8 +1901,10 @@ SCM_CEVAL (x, env)
}
- evapply:
- if (SCM_NULLP (SCM_CDR (x)))
+evapply:
+ PREP_APPLY (proc, SCM_EOL);
+ if (SCM_NULLP (SCM_CDR (x))) {
+ ENTER_APPLY;
switch (SCM_TYP7 (proc))
{ /* no arguments given */
case scm_tc7_subr_0:
@@ -1457,13 +1917,19 @@ SCM_CEVAL (x, env)
RETURN (SCM_BOOL_T);
case scm_tc7_asubr:
RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
+#ifdef CCLO
case scm_tc7_cclo:
t.arg1 = proc;
proc = SCM_CCLO_SUBR (proc);
+#ifdef DEVAL
+ debug.info->a.proc = proc;
+ debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
+#endif
goto evap1;
+#endif
case scm_tcs_closures:
x = SCM_CODE (proc);
- env = EXTEND_SCM_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc));
goto cdrxbegin;
case scm_tc7_contin:
case scm_tc7_subr_1:
@@ -1475,12 +1941,13 @@ SCM_CEVAL (x, env)
umwrongnumargs:
unmemocar (x, env);
wrongnumargs:
- scm_everr (x, env, proc, (char *) SCM_WNA, "");
+ /* scm_everr (x, env,...) */
+ scm_wrong_num_args (proc);
default:
/* handle macros here */
goto badfun;
}
-
+ }
/* must handle macros by here */
x = SCM_CDR (x);
@@ -1489,12 +1956,16 @@ SCM_CEVAL (x, env)
goto wrongnumargs;
#endif
t.arg1 = EVALCAR (x, env);
+#ifdef DEVAL
+ debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
+#endif
x = SCM_CDR (x);
if (SCM_NULLP (x))
{
+ ENTER_APPLY;
evap1:
switch (SCM_TYP7 (proc))
- { /* have one argument in t.arg1 */
+ { /* have one argument in t.arg1 */
case scm_tc7_subr_2o:
RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED));
case scm_tc7_subr_1:
@@ -1541,21 +2012,27 @@ SCM_CEVAL (x, env)
RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED));
case scm_tc7_lsubr:
#ifdef DEVAL
- RETURN (SCM_SUBRF (proc) (dbg_info.args));
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args))
#else
RETURN (SCM_SUBRF (proc) (scm_cons (t.arg1, SCM_EOL)));
#endif
+#ifdef CCLO
case scm_tc7_cclo:
arg2 = t.arg1;
t.arg1 = proc;
proc = SCM_CCLO_SUBR (proc);
+#ifdef DEVAL
+ debug.info->a.args = scm_cons (t.arg1, debug.info->a.args);
+ debug.info->a.proc = proc;
+#endif
goto evap2;
+#endif
case scm_tcs_closures:
x = SCM_CODE (proc);
#ifdef DEVAL
- env = EXTEND_SCM_ENV (SCM_CAR (x), dbg_info.args, SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CAR (x), debug.info->a.args, SCM_ENV (proc));
#else
- env = EXTEND_SCM_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
#endif
goto cdrxbegin;
case scm_tc7_contin:
@@ -1575,165 +2052,216 @@ SCM_CEVAL (x, env)
#endif
{ /* have two or more arguments */
arg2 = EVALCAR (x, env);
+#ifdef DEVAL
+ debug.info->a.args = scm_cons2 (t.arg1, arg2, SCM_EOL);
+#endif
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_subr_2o:
+ RETURN (SCM_SUBRF (proc) (t.arg1, arg2));
+ case scm_tc7_lsubr:
#ifdef DEVAL
- dbg_info.args = scm_cons2 (t.arg1, arg2, SCM_EOL);
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args))
+#else
+ RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, SCM_EOL)));
#endif
- switch SCM_TYP7
- (proc)
- { /* have two arguments */
- case scm_tc7_subr_2:
- case scm_tc7_subr_2o:
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2));
- case scm_tc7_lsubr:
+ case scm_tc7_lsubr_2:
+ RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_EOL));
+ case scm_tc7_rpsubr:
+ case scm_tc7_asubr:
+ RETURN (SCM_SUBRF (proc) (t.arg1, arg2));
+#ifdef CCLO
+ cclon:
+ case scm_tc7_cclo:
#ifdef DEVAL
- RETURN (SCM_SUBRF (proc) (dbg_info.args));
+ RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc,
+ scm_cons (debug.info->a.args, SCM_EOL)));
#else
- RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, SCM_EOL)));
+ RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc,
+ scm_cons2 (t.arg1, arg2,
+ scm_cons (scm_eval_args (x, env), SCM_EOL))));
#endif
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_EOL));
- case scm_tc7_rpsubr:
- case scm_tc7_asubr:
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2));
-#ifdef CCLO
- cclon: case scm_tc7_cclo:
- RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc,
- scm_cons2 (t.arg1, arg2, scm_cons (SCM_EVAL_ARGS (x, env), SCM_EOL))));
- /* 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_tc7_subr_0:
- case scm_tc7_cxr:
- 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:
+ /* 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_tc7_subr_0:
+ case scm_tc7_cxr:
+ 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:
#ifdef DEVAL
- env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), dbg_info.args, SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), debug.info->a.args, SCM_ENV (proc));
#else
- env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
#endif
- x = SCM_CODE (proc);
- goto cdrxbegin;
- }
+ x = SCM_CODE (proc);
+ goto cdrxbegin;
+ }
}
#ifdef DEVAL
- dbg_info.args = scm_cons2 (t.arg1, arg2, scm_deval_args (x, env));
+ debug.info->a.args = scm_cons2 (t.arg1, arg2,
+ scm_deval_args (x, env, SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
#endif
- switch SCM_TYP7
- (proc)
- { /* have 3 or more arguments */
+ ENTER_APPLY;
+ switch (SCM_TYP7 (proc))
+ { /* have 3 or more arguments */
#ifdef DEVAL
- case scm_tc7_subr_3:
- SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CAR (SCM_CDR (SCM_CDR (dbg_info.args)))));
- case scm_tc7_asubr:
- /* t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
- while SCM_NIMP(x) {
- t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));
- x = SCM_CDR(x);
- }
- RETURN (t.arg1) */
- case scm_tc7_rpsubr:
- RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, SCM_CDR (SCM_CDR (dbg_info.args)), SCM_EOL)));
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CDR (SCM_CDR (dbg_info.args))));
- case scm_tc7_lsubr:
- RETURN (SCM_SUBRF (proc) (dbg_info.args));
+ case scm_tc7_subr_3:
+ SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
+ RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CAR (SCM_CDR (SCM_CDR (debug.info->a.args)))));
+ case scm_tc7_asubr:
+#ifdef BUILTIN_RPASUBR
+ t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
+ arg2 = SCM_CDR (SCM_CDR (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)
+#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));
+ do {
+ if (SCM_FALSEP (SCM_SUBRF (proc) (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)
+#else /* BUILTIN_RPASUBR */
+ RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, SCM_CDR (SCM_CDR (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))))
+ case scm_tc7_lsubr:
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args))
#ifdef CCLO
- case scm_tc7_cclo:
- goto cclon;
+ case scm_tc7_cclo:
+ goto cclon;
#endif
- case scm_tcs_closures:
- env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)),
- dbg_info.args,
- SCM_ENV (proc));
- x = SCM_CODE (proc);
- goto cdrxbegin;
-#else
- case scm_tc7_subr_3:
- SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2, EVALCAR (x, env)));
- case scm_tc7_asubr:
- /* t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
- while SCM_NIMP(x) {
- t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));
- x = SCM_CDR(x);
- }
- RETURN (t.arg1) */
- case scm_tc7_rpsubr:
- RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, scm_eval_args (x, env), SCM_EOL)));
- case scm_tc7_lsubr_2:
- RETURN (SCM_SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env)));
- case scm_tc7_lsubr:
- RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, scm_eval_args (x, env))));
+ case scm_tcs_closures:
+ SCM_SET_ARGSREADY (debug);
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
+ debug.info->a.args,
+ SCM_ENV (proc));
+ x = SCM_CODE (proc);
+ goto cdrxbegin;
+#else /* DEVAL */
+ case scm_tc7_subr_3:
+ SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
+ RETURN (SCM_SUBRF (proc) (t.arg1, arg2, EVALCAR (x, env)));
+ case scm_tc7_asubr:
+#ifdef BUILTIN_RPASUBR
+ t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
+ do {
+ t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));
+ x = SCM_CDR(x);
+ } while (SCM_NIMP (x));
+ 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)
+ do {
+ t.arg1 = EVALCAR (x, env);
+ if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, t.arg1)))
+ RETURN (SCM_BOOL_F)
+ arg2 = t.arg1;
+ x = SCM_CDR (x);
+ } while (SCM_NIMP (x));
+ RETURN (SCM_BOOL_T)
+#else /* BUILTIN_RPASUBR */
+ RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, scm_eval_args (x, env), SCM_EOL)));
+#endif /* BUILTIN_RPASUBR */
+ case scm_tc7_lsubr_2:
+ RETURN (SCM_SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env)));
+ case scm_tc7_lsubr:
+ RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, scm_eval_args (x, env))));
#ifdef CCLO
- case scm_tc7_cclo:
- goto cclon;
+ case scm_tc7_cclo:
+ goto cclon;
#endif
- case scm_tcs_closures:
- env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)),
- scm_cons2 (t.arg1, arg2, scm_eval_args (x, env)),
- SCM_ENV (proc));
- x = SCM_CODE (proc);
- goto cdrxbegin;
+ case scm_tcs_closures:
+#ifdef DEVAL
+ SCM_SET_ARGSREADY (debug);
+#endif
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
+ scm_cons2 (t.arg1, arg2, scm_eval_args (x, env)),
+ SCM_ENV (proc));
+ x = SCM_CODE (proc);
+ goto cdrxbegin;
#endif /* DEVAL */
- case scm_tc7_subr_2:
- case scm_tc7_subr_1o:
- case scm_tc7_subr_2o:
- case scm_tc7_subr_0:
- case scm_tc7_cxr:
- case scm_tc7_subr_1:
- case scm_tc7_contin:
- goto wrongnumargs;
- default:
- goto badfun;
- }
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_1o:
+ case scm_tc7_subr_2o:
+ case scm_tc7_subr_0:
+ case scm_tc7_cxr:
+ case scm_tc7_subr_1:
+ case scm_tc7_contin:
+ goto wrongnumargs;
+ default:
+ goto badfun;
+ }
}
#ifdef DEVAL
- exit:
- if (CHECK_SCM_EXIT)
- {
- /* if (SINGLE_STEP) ... but this is always fulfilled. */
- SINGLE_STEP = 0;
- scm_make_cont (&t.arg1);
- if (setjmp (SCM_JMPBUF (t.arg1)))
- {
- proc = SCM_THROW_VALUE(t.arg1);
- goto ret;
- }
- scm_ithrow (exit_frame_sym, proc, 0);
- }
- ret:
- last_debug_info_frame = dbg_info.prev;
+exit:
+ if (CHECK_EXIT)
+ if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
+ {
+ SCM_EXIT_FRAME_P = 0;
+ SCM_TRACE_P = 0;
+ SCM_RESET_DEBUG_MODE;
+ SCM_CLEAR_TRACED_FRAME (debug);
+ if (SCM_CHEAPTRAPS_P)
+ t.arg1 = scm_make_debugobj (&debug);
+ else
+ {
+ scm_make_cont (&t.arg1);
+ if (safe_setjmp (SCM_JMPBUF (t.arg1)))
+ {
+ proc = SCM_THROW_VALUE (t.arg1);
+ goto ret;
+ }
+ }
+ scm_ithrow (scm_i_exit_frame, scm_cons2 (t.arg1, proc, SCM_EOL), 0);
+ }
+ret:
+ scm_last_debug_frame = debug.prev;
return proc;
#endif
}
+
+/* SECTION: This code is compiled once.
+ */
+
#ifndef DEVAL
SCM_PROC(s_procedure_documentation, "procedure-documentation", 1, 0, 0, scm_procedure_documentation);
-#ifdef __STDC__
-SCM
-scm_procedure_documentation (SCM proc)
-#else
+
SCM
scm_procedure_documentation (proc)
SCM proc;
-#endif
{
SCM code;
SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc) && SCM_NIMP (proc) && SCM_TYP7 (proc) != scm_tc7_contin,
@@ -1760,111 +2288,162 @@ scm_procedure_documentation (proc)
}
}
-/* This code is for scm_apply. it is destructive on multiple args.
- * This will only screw you if you do (scm_apply scm_apply '( ... ))
- */
+/* This code processes the arguments to apply:
+
+ (apply PROC ARG1 ... ARGS)
+
+ Given a list (ARG1 ... ARGS), this function conses the ARG1
+ ... arguments onto the front of ARGS, and returns the resulting
+ list. Note that ARGS is a list; thus, the argument to this
+ function is a list whose last element is a list.
+
+ Apply calls this function, and applies PROC to the elements of the
+ result. apply:nconc2last takes care of building the list of
+ arguments, given (ARG1 ... ARGS).
+
+ Rather than do new consing, apply:nconc2last destroys its argument.
+ On that topic, this code came into my care with the following
+ beautifully cryptic comment on that topic: "This will only screw
+ you if you do (scm_apply scm_apply '( ... ))" If you know what
+ they're referring to, send me a patch to this comment. */
+
SCM_PROC(s_nconc2last, "apply:nconc2last", 1, 0, 0, scm_nconc2last);
-#ifdef __STDC__
-SCM
-scm_nconc2last (SCM lst)
-#else
+
SCM
scm_nconc2last (lst)
SCM lst;
-#endif
{
SCM *lloc;
- if (SCM_EOL == lst)
- return lst;
- SCM_ASSERT (SCM_NIMP (lst) && SCM_CONSP (lst), lst, SCM_ARG1, s_nconc2last);
+ SCM_ASSERT (scm_ilength (lst) > 0, lst, SCM_ARG1, s_nconc2last);
lloc = &lst;
while (SCM_NNULLP (SCM_CDR (*lloc)))
- {
- lloc = &SCM_CDR (*lloc);
- SCM_ASSERT (SCM_NIMP (*lloc) && SCM_CONSP (*lloc), lst, SCM_ARG1, s_nconc2last);
- }
+ lloc = SCM_CDRLOC (*lloc);
+ SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, s_nconc2last);
*lloc = SCM_CAR (*lloc);
return lst;
}
#endif /* !DEVAL */
+
+/* SECTION: When DEVAL is defined this code yields scm_dapply.
+ * It is compiled twice.
+ */
+
#if 0
-#ifdef __STDC__
-SCM
-scm_apply (SCM proc, SCM arg1, SCM args)
-#else
+
SCM
scm_apply (proc, arg1, args)
SCM proc;
SCM arg1;
SCM args;
-#endif
{}
#endif
#if 0
-#ifdef __STDC__
-SCM
-scm_dapply (SCM proc, SCM arg1, SCM args)
-#else
+
SCM
scm_dapply (proc, arg1, args)
SCM proc;
SCM arg1;
SCM args;
-#endif
{}
#endif
+/* Apply a function to a list of arguments.
+
+ This function is exported to the Scheme level as taking two
+ required arguments and a tail argument, as if it were:
+ (lambda (proc arg1 . args) ...)
+ Thus, if you just have a list of arguments to pass to a procedure,
+ pass the list as ARG1, and '() for ARGS. If you have some fixed
+ args, pass the first as ARG1, then cons any remaining fixed args
+ onto the front of your argument list, and pass that as ARGS. */
-#ifdef __STDC__
-SCM
-SCM_APPLY (SCM proc, SCM arg1, SCM args)
-#else
SCM
SCM_APPLY (proc, arg1, args)
SCM proc;
SCM arg1;
SCM args;
-#endif
{
#ifdef DEBUG_EXTENSIONS
#ifdef DEVAL
- debug_info dbg_info;
- dbg_info.prev = last_debug_info_frame;
- dbg_info.exp = SCM_UNDEFINED;
- dbg_info.proc = proc;
- dbg_info.args = SCM_UNDEFINED;
- last_debug_info_frame = &dbg_info;
-#else
- if (DEBUGGINGP)
+ scm_debug_frame debug;
+ scm_debug_info debug_vect_body;
+ debug.prev = scm_last_debug_frame;
+ debug.status = SCM_APPLYFRAME;
+ debug.vect = &debug_vect_body;
+ debug.vect[0].a.proc = proc;
+ debug.vect[0].a.args = SCM_EOL;
+ scm_last_debug_frame = &debug;
+#else
+ if (SCM_DEBUGGINGP)
return scm_dapply (proc, arg1, args);
#endif
#endif
SCM_ASRTGO (SCM_NIMP (proc), badproc);
+
+ /* If ARGS is the empty list, then we're calling apply with only two
+ arguments --- ARG1 is the list of arguments for PROC. Whatever
+ the case, futz with things so that ARG1 is the first argument to
+ give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
+ rest.
+
+ Setting the debug apply frame args this way is pretty messy.
+ Perhaps we should store arg1 and args directly in the frame as
+ received, and let scm_frame_arguments unpack them, because that's
+ a relatively rare operation. This works for now; if the Guile
+ developer archives are still around, see Mikael's post of
+ 11-Apr-97. */
if (SCM_NULLP (args))
{
if (SCM_NULLP (arg1))
- arg1 = SCM_UNDEFINED;
+ {
+ arg1 = SCM_UNDEFINED;
+#ifdef DEVAL
+ debug.vect[0].a.args = SCM_EOL;
+#endif
+ }
else
{
+#ifdef DEVAL
+ debug.vect[0].a.args = arg1;
+#endif
args = SCM_CDR (arg1);
arg1 = SCM_CAR (arg1);
}
}
else
{
- /* SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */
+ /* SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */
args = scm_nconc2last (args);
- }
-#ifdef CCLO
- tail:
+#ifdef DEVAL
+ debug.vect[0].a.args = scm_cons (arg1, args);
#endif
+ }
#ifdef DEVAL
- dbg_info.args = scm_cons (arg1, args);
+ if (SCM_ENTER_FRAME_P)
+ {
+ SCM tmp;
+ SCM_ENTER_FRAME_P = 0;
+ SCM_RESET_DEBUG_MODE;
+ if (SCM_CHEAPTRAPS_P)
+ tmp = scm_make_debugobj (&debug);
+ else
+ {
+ scm_make_cont (&tmp);
+ if (safe_setjmp (SCM_JMPBUF (tmp)))
+ goto entap;
+ }
+ scm_ithrow (scm_i_enter_frame, scm_cons (tmp, SCM_EOL), 0);
+ }
+entap:
+ ENTER_APPLY;
+#endif
+#ifdef CCLO
+tail:
#endif
switch (SCM_TYP7 (proc))
{
@@ -1887,13 +2466,15 @@ SCM_APPLY (proc, arg1, args)
#ifdef SCM_FLOATS
if (SCM_SUBRF (proc))
{
- if SCM_INUMP
- (arg1)
- RETURN (scm_makdbl (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)), 0.0))
+ if (SCM_INUMP (arg1))
+ {
+ RETURN (scm_makdbl (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)), 0.0));
+ }
SCM_ASRTGO (SCM_NIMP (arg1), floerr);
- if SCM_REALP
- (arg1)
- RETURN (scm_makdbl (SCM_DSUBRF (proc) (SCM_REALPART (arg1)), 0.0))
+ if (SCM_REALP (arg1))
+ {
+ RETURN (scm_makdbl (SCM_DSUBRF (proc) (SCM_REALPART (arg1)), 0.0));
+ }
#ifdef SCM_BIGDIG
if SCM_BIGP
(arg1)
@@ -1918,7 +2499,7 @@ SCM_APPLY (proc, arg1, args)
RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CAR (SCM_CDR (args))))
case scm_tc7_lsubr:
#ifdef DEVAL
- RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : dbg_info.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)))
#endif
@@ -1949,7 +2530,7 @@ SCM_APPLY (proc, arg1, args)
RETURN (SCM_BOOL_T);
case scm_tcs_closures:
#ifdef DEVAL
- arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : dbg_info.args);
+ arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args);
#else
arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
#endif
@@ -1957,7 +2538,7 @@ SCM_APPLY (proc, arg1, args)
if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), arg1))
goto wrongnumargs;
#endif
- args = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), arg1, SCM_ENV (proc));
+ args = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), arg1, SCM_ENV (proc));
proc = SCM_CODE (proc);
while (SCM_NNULLP (proc = SCM_CDR (proc)))
arg1 = EVALCAR (proc, args);
@@ -1968,54 +2549,65 @@ SCM_APPLY (proc, arg1, args)
#ifdef CCLO
case scm_tc7_cclo:
#ifdef DEVAL
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : dbg_info.args);
+ args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
+ arg1 = proc;
+ proc = SCM_CCLO_SUBR (proc);
+ debug.vect[0].a.proc = proc;
+ debug.vect[0].a.args = scm_cons (arg1, args);
#else
args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
-#endif
arg1 = proc;
proc = SCM_CCLO_SUBR (proc);
+#endif
goto tail;
#endif
wrongnumargs:
- scm_wta (proc, (char *) SCM_WNA, "apply");
+ scm_wrong_num_args (proc);
default:
badproc:
scm_wta (proc, (char *) SCM_ARG1, "apply");
RETURN (arg1);
}
#ifdef DEVAL
- exit:
- if (CHECK_SCM_EXIT)
- {
- /* if (SINGLE_STEP) ... but this is always fulfilled. */
- SINGLE_STEP = 0;
- scm_make_cont (&arg1);
- if (setjmp (SCM_JMPBUF (arg1)))
- {
- proc = SCM_THROW_VALUE(arg1);
- goto ret;
- }
- scm_ithrow (exit_frame_sym, proc, 0);
- }
- ret:
- last_debug_info_frame = dbg_info.prev;
+exit:
+ if (CHECK_EXIT)
+ if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
+ {
+ SCM_EXIT_FRAME_P = 0;
+ SCM_RESET_DEBUG_MODE;
+ SCM_CLEAR_TRACED_FRAME (debug);
+ if (SCM_CHEAPTRAPS_P)
+ arg1 = scm_make_debugobj (&debug);
+ else
+ {
+ scm_make_cont (&arg1);
+ if (safe_setjmp (SCM_JMPBUF (arg1)))
+ {
+ proc = SCM_THROW_VALUE (arg1);
+ goto ret;
+ }
+ }
+ scm_ithrow (scm_i_exit_frame, scm_cons2 (arg1, proc, SCM_EOL), 0);
+ }
+ret:
+ scm_last_debug_frame = debug.prev;
return proc;
#endif
}
+
+/* SECTION: The rest of this file is only read once.
+ */
+
#ifndef DEVAL
SCM_PROC(s_map, "map", 2, 0, 1, scm_map);
-#ifdef __STDC__
-SCM
-scm_map (SCM proc, SCM arg1, SCM args)
-#else
+
SCM
scm_map (proc, arg1, args)
SCM proc;
SCM arg1;
SCM args;
-#endif
{
long i;
SCM res = SCM_EOL;
@@ -2031,7 +2623,7 @@ scm_map (proc, arg1, args)
{
SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG2, s_map);
*pres = scm_cons (scm_apply (proc, SCM_CAR (arg1), scm_listofnull), SCM_EOL);
- pres = &SCM_CDR (*pres);
+ pres = SCM_CDRLOC (*pres);
arg1 = SCM_CDR (arg1);
}
return res;
@@ -2053,22 +2645,18 @@ scm_map (proc, arg1, args)
ve[i] = SCM_CDR (ve[i]);
}
*pres = scm_cons (scm_apply (proc, arg1, SCM_EOL), SCM_EOL);
- pres = &SCM_CDR (*pres);
+ pres = SCM_CDRLOC (*pres);
}
}
SCM_PROC(s_for_each, "for-each", 2, 0, 1, scm_for_each);
-#ifdef __STDC__
-SCM
-scm_for_each (SCM proc, SCM arg1, SCM args)
-#else
+
SCM
scm_for_each (proc, arg1, args)
SCM proc;
SCM arg1;
SCM args;
-#endif
{
SCM *ve = &args; /* Keep args from being optimized away. */
long i;
@@ -2106,125 +2694,105 @@ scm_for_each (proc, arg1, args)
}
-#ifdef __STDC__
-SCM
-scm_closure (SCM code, SCM env)
-#else
+
SCM
scm_closure (code, env)
SCM code;
SCM env;
-#endif
{
register SCM z;
SCM_NEWCELL (z);
SCM_SETCODE (z, code);
- SCM_ENV (z) = env;
+ SCM_SETENV (z, env);
return z;
}
long scm_tc16_promise;
-#ifdef __STDC__
-SCM
-scm_makprom (SCM code)
-#else
+
SCM
scm_makprom (code)
SCM code;
-#endif
{
register SCM z;
SCM_NEWCELL (z);
- SCM_CDR (z) = code;
- SCM_CAR (z) = scm_tc16_promise;
+ SCM_SETCDR (z, code);
+ SCM_SETCAR (z, scm_tc16_promise);
return z;
}
-#ifdef __STDC__
-static int
-prinprom (SCM exp, SCM port, int writing)
-#else
+
+static int prinprom SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
+
static int
-prinprom (exp, port, writing)
+prinprom (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
+ int writingp = SCM_WRITINGP (pstate);
scm_gen_puts (scm_regular_string, "#<promise ", port);
- scm_iprin1 (SCM_CDR (exp), port, writing);
+ SCM_SET_WRITINGP (pstate, 1);
+ scm_iprin1 (SCM_CDR (exp), port, pstate);
+ SCM_SET_WRITINGP (pstate, writingp);
scm_gen_putc ('>', port);
return !0;
}
SCM_PROC(s_makacro, "procedure->syntax", 1, 0, 0, scm_makacro);
-#ifdef __STDC__
-SCM
-scm_makacro (SCM code)
-#else
+
SCM
scm_makacro (code)
SCM code;
-#endif
{
register SCM z;
SCM_NEWCELL (z);
- SCM_CDR (z) = code;
- SCM_CAR (z) = scm_tc16_macro;
+ SCM_SETCDR (z, code);
+ SCM_SETCAR (z, scm_tc16_macro);
return z;
}
SCM_PROC(s_makmacro, "procedure->macro", 1, 0, 0, scm_makmacro);
-#ifdef __STDC__
-SCM
-scm_makmacro (SCM code)
-#else
+
SCM
scm_makmacro (code)
SCM code;
-#endif
{
register SCM z;
SCM_NEWCELL (z);
- SCM_CDR (z) = code;
- SCM_CAR (z) = scm_tc16_macro | (1L << 16);
+ SCM_SETCDR (z, code);
+ SCM_SETCAR (z, scm_tc16_macro | (1L << 16));
return z;
}
SCM_PROC(s_makmmacro, "procedure->memoizing-macro", 1, 0, 0, scm_makmmacro);
-#ifdef __STDC__
-SCM
-scm_makmmacro (SCM code)
-#else
+
SCM
scm_makmmacro (code)
SCM code;
-#endif
{
register SCM z;
SCM_NEWCELL (z);
- SCM_CDR (z) = code;
- SCM_CAR (z) = scm_tc16_macro | (2L << 16);
+ SCM_SETCDR (z, code);
+ SCM_SETCAR (z, scm_tc16_macro | (2L << 16));
return z;
}
-#ifdef __STDC__
-static int
-prinmacro (SCM exp, SCM port, int writing)
-#else
+
+static int prinmacro SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
+
static int
-prinmacro (exp, port, writing)
+prinmacro (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
+ int writingp = SCM_WRITINGP (pstate);
if (SCM_CAR (exp) & (3L << 16))
scm_gen_puts (scm_regular_string, "#<macro", port);
else
@@ -2232,20 +2800,18 @@ prinmacro (exp, port, writing)
if (SCM_CAR (exp) & (2L << 16))
scm_gen_putc ('!', port);
scm_gen_putc (' ', port);
- scm_iprin1 (SCM_CDR (exp), port, writing);
+ SCM_SET_WRITINGP (pstate, 1);
+ scm_iprin1 (SCM_CDR (exp), port, pstate);
+ SCM_SET_WRITINGP (pstate, writingp);
scm_gen_putc ('>', port);
return !0;
}
SCM_PROC(s_force, "force", 1, 0, 0, scm_force);
-#ifdef __STDC__
-SCM
-scm_force (SCM x)
-#else
+
SCM
scm_force (x)
SCM x;
-#endif
{
SCM_ASSERT ((SCM_TYP16 (x) == scm_tc16_promise), x, SCM_ARG1, s_force);
if (!((1L << 16) & SCM_CAR (x)))
@@ -2254,8 +2820,8 @@ scm_force (x)
if (!((1L << 16) & SCM_CAR (x)))
{
SCM_DEFER_INTS;
- SCM_CDR (x) = ans;
- SCM_CAR (x) |= (1L << 16);
+ SCM_SETCDR (x, ans);
+ SCM_SETOR_CAR (x, (1L << 16));
SCM_ALLOW_INTS;
}
}
@@ -2263,14 +2829,10 @@ scm_force (x)
}
SCM_PROC (s_promise_p, "promise?", 1, 0, 0, scm_promise_p);
-#ifdef __STDC__
-SCM
-scm_promise_p (SCM x)
-#else
+
SCM
scm_promise_p (x)
SCM x;
-#endif
{
return ((SCM_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_promise))
? SCM_BOOL_T
@@ -2278,14 +2840,10 @@ scm_promise_p (x)
}
SCM_PROC(s_copy_tree, "copy-tree", 1, 0, 0, scm_copy_tree);
-#ifdef __STDC__
-SCM
-scm_copy_tree (SCM obj)
-#else
+
SCM
scm_copy_tree (obj)
SCM obj;
-#endif
{
SCM ans, tl;
if SCM_IMP
@@ -2303,37 +2861,33 @@ scm_copy_tree (obj)
/* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
ans = tl = scm_cons (scm_copy_tree (SCM_CAR (obj)), SCM_UNSPECIFIED);
while (SCM_NIMP (obj = SCM_CDR (obj)) && SCM_CONSP (obj))
- tl = (SCM_CDR (tl) = scm_cons (scm_copy_tree (SCM_CAR (obj)), SCM_UNSPECIFIED));
- SCM_CDR (tl) = obj;
+ {
+ SCM_SETCDR (tl, scm_cons (scm_copy_tree (SCM_CAR (obj)),
+ SCM_UNSPECIFIED));
+ tl = SCM_CDR (tl);
+ }
+ SCM_SETCDR (tl, obj);
return ans;
}
-#ifdef __STDC__
-SCM
-scm_eval_3 (SCM obj, int copyp, SCM env)
-#else
+
SCM
scm_eval_3 (obj, copyp, env)
SCM obj;
int copyp;
SCM env;
-#endif
{
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 EVAL (obj, env);
+ return XEVAL (obj, env);
}
-#ifdef __STDC__
-SCM
-scm_top_level_env (SCM thunk)
-#else
+
SCM
scm_top_level_env (thunk)
SCM thunk;
-#endif
{
if (SCM_IMP(thunk))
return SCM_EOL;
@@ -2342,83 +2896,66 @@ scm_top_level_env (thunk)
}
SCM_PROC(s_eval2, "eval2", 2, 0, 0, scm_eval2);
-#ifdef __STDC__
-SCM
-scm_eval2 (SCM obj, SCM env_thunk)
-#else
+
SCM
scm_eval2 (obj, env_thunk)
SCM obj;
SCM env_thunk;
-#endif
{
return scm_eval_3 (obj, 1, scm_top_level_env(env_thunk));
}
SCM_PROC(s_eval, "eval", 1, 0, 0, scm_eval);
-#ifdef __STDC__
-SCM
-scm_eval (SCM obj)
-#else
+
SCM
scm_eval (obj)
SCM obj;
-#endif
{
return
- scm_eval_3(obj, 1, scm_top_level_env(SCM_CDR(scm_top_level_lookup_thunk_var)));
+ scm_eval_3(obj, 1, scm_top_level_env(SCM_CDR(scm_top_level_lookup_closure_var)));
}
-SCM_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x);
-#ifdef __STDC__
-SCM
-scm_eval_x (SCM obj)
-#else
+/* SCM_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x); */
+
SCM
scm_eval_x (obj)
SCM obj;
-#endif
{
return
scm_eval_3(obj,
0,
- scm_top_level_env (SCM_CDR (scm_top_level_lookup_thunk_var)));
+ scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var)));
}
SCM_PROC (s_macro_eval_x, "macro-eval!", 2, 0, 0, scm_macro_eval_x);
-#ifdef __STDC__
-SCM
-scm_macro_eval_x (SCM exp, SCM env)
-#else
+
SCM
scm_macro_eval_x (exp, env)
SCM exp;
SCM env;
-#endif
{
return scm_eval_3 (exp, 0, env);
}
-#ifdef __STDC__
-SCM
-scm_definedp (SCM x, SCM env)
-#else
+
+SCM_PROC (s_definedp, "defined?", 1, 0, 0, scm_definedp);
+
SCM
-scm_definedp (x, env)
- SCM x;
- SCM env;
-#endif
+scm_definedp (sym)
+ SCM sym;
{
- SCM proc = SCM_CAR (x = SCM_CDR (x));
- if (SCM_ISYMP (proc))
+ SCM vcell;
+
+ if (SCM_ISYMP (sym))
return SCM_BOOL_T;
- else if(SCM_IMP(proc) || !SCM_SYMBOLP(proc))
- return SCM_BOOL_F;
- else
- {
- SCM vcell = scm_sym2vcell(proc, env_top_level(env), SCM_BOOL_F);
- return (vcell == SCM_BOOL_F || SCM_UNBNDP(SCM_CDR(vcell))) ? SCM_BOOL_F : SCM_BOOL_T;
- }
+
+ SCM_ASSERT (SCM_NIMP (sym) && SCM_SYMBOLP (sym), sym, SCM_ARG1, s_definedp);
+
+ vcell = scm_sym2vcell(sym,
+ SCM_CDR (scm_top_level_lookup_closure_var),
+ SCM_BOOL_F);
+ return (vcell == SCM_BOOL_F || SCM_UNBNDP(SCM_CDR(vcell))) ?
+ SCM_BOOL_F : SCM_BOOL_T;
}
static scm_smobfuns promsmob =
@@ -2427,16 +2964,12 @@ static scm_smobfuns promsmob =
static scm_smobfuns macrosmob =
{scm_markcdr, scm_free0, prinmacro};
-#ifdef __STDC__
-SCM
-scm_make_synt (char *name, SCM (*macroizer) (), SCM (*fcn) ())
-#else
+
SCM
scm_make_synt (name, macroizer, fcn)
char *name;
SCM (*macroizer) ();
SCM (*fcn) ();
-#endif
{
SCM symcell = scm_sysintern (name, SCM_UNDEFINED);
long tmp = ((((SCM_CELLPTR) (SCM_CAR (symcell))) - scm_heap_org) << 8);
@@ -2445,31 +2978,25 @@ scm_make_synt (name, macroizer, fcn)
tmp = 0;
SCM_NEWCELL (z);
SCM_SUBRF (z) = fcn;
- SCM_CAR (z) = tmp + scm_tc7_subr_2;
- SCM_CDR (symcell) = macroizer (z);
+ SCM_SETCAR (z, tmp + scm_tc7_subr_2);
+ SCM_SETCDR (symcell, macroizer (z));
return SCM_CAR (symcell);
}
+
+/* At this point, scm_deval and scm_dapply are generated.
+ */
+
#ifdef DEBUG_EXTENSIONS
-# ifndef DEVAL
-# define DEVAL
-# include "eval.c"
-# endif
+# define DEVAL
+# include "eval.c"
#endif
-#ifdef __STDC__
-void
-scm_init_eval (void)
-#else
+
void
scm_init_eval ()
-#endif
{
-#ifdef DEBUG_EXTENSIONS
- enter_frame_sym = SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED));
- exit_frame_sym = SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED));
-#endif
scm_tc16_promise = scm_newsmob (&promsmob);
scm_tc16_macro = scm_newsmob (&macrosmob);
scm_i_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply);
@@ -2482,32 +3009,40 @@ scm_init_eval ()
/* acros */
scm_i_quasiquote = scm_make_synt (s_quasiquote, scm_makacro, scm_m_quasiquote);
- scm_make_synt ("define", scm_makmmacro, scm_m_define);
+ scm_make_synt (s_undefine, scm_makacro, scm_m_undefine);
scm_make_synt (s_delay, scm_makacro, scm_m_delay);
/* end of acros */
- scm_top_level_lookup_thunk_var =
- scm_sysintern("*top-level-lookup-thunk*", SCM_BOOL_F);
-
- scm_make_synt ("and", scm_makmmacro, scm_m_and);
- scm_make_synt ("begin", scm_makmmacro, scm_m_begin);
- scm_make_synt ("case", scm_makmmacro, scm_m_case);
- scm_make_synt ("cond", scm_makmmacro, scm_m_cond);
- scm_make_synt ("do", scm_makmmacro, scm_m_do);
- scm_make_synt ("if", scm_makmmacro, scm_m_if);
+ scm_top_level_lookup_closure_var =
+ scm_sysintern("*top-level-lookup-closure*", SCM_BOOL_F);
+ scm_can_use_top_level_lookup_closure_var = 1;
+
+ scm_i_and = scm_make_synt ("and", scm_makmmacro, scm_m_and);
+ scm_i_begin = scm_make_synt ("begin", scm_makmmacro, scm_m_begin);
+ scm_i_case = scm_make_synt ("case", scm_makmmacro, scm_m_case);
+ scm_i_cond = scm_make_synt ("cond", scm_makmmacro, scm_m_cond);
+ scm_i_define = scm_make_synt ("define", scm_makmmacro, scm_m_define);
+ scm_i_do = scm_make_synt ("do", scm_makmmacro, scm_m_do);
+ scm_i_if = scm_make_synt ("if", scm_makmmacro, scm_m_if);
scm_i_lambda = scm_make_synt ("lambda", scm_makmmacro, scm_m_lambda);
scm_i_let = scm_make_synt ("let", scm_makmmacro, scm_m_let);
- scm_make_synt ("letrec", scm_makmmacro, scm_m_letrec);
- scm_make_synt ("let*", scm_makmmacro, scm_m_letstar);
- scm_make_synt ("or", scm_makmmacro, scm_m_or);
+ scm_i_letrec = scm_make_synt ("letrec", scm_makmmacro, scm_m_letrec);
+ scm_i_letstar = scm_make_synt ("let*", scm_makmmacro, scm_m_letstar);
+ scm_i_or = scm_make_synt ("or", scm_makmmacro, scm_m_or);
scm_i_quote = scm_make_synt ("quote", scm_makmmacro, scm_m_quote);
- scm_make_synt ("set!", scm_makmmacro, scm_m_set);
- scm_make_synt ("@apply", scm_makmmacro, scm_m_apply);
- scm_make_synt ("@call-with-current-continuation", scm_makmmacro, scm_m_cont);
- scm_make_synt ("defined?", scm_makmmacro, scm_definedp);
- scm_i_name = SCM_CAR (scm_sysintern ("name", SCM_UNDEFINED));
- scm_permanent_object (scm_i_name);
+ scm_i_set = scm_make_synt ("set!", scm_makmmacro, scm_m_set);
+ scm_i_atapply = scm_make_synt ("@apply", scm_makmmacro, scm_m_apply);
+ scm_i_atcall_cc = scm_make_synt ("@call-with-current-continuation",
+ scm_makmmacro, scm_m_cont);
+
+#ifdef DEBUG_EXTENSIONS
+ scm_i_enter_frame = SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED));
+ scm_i_apply_frame = SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED));
+ scm_i_exit_frame = SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED));
+ scm_i_trace = SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED));
+#endif
+
#include "eval.x"
}
-#endif /* !DEVAL */
+#endif /* !DEVAL */